Added code to use lexicons indexed by lemma

Some lexicons are indexed by lemma rather than by Strong's numbers.
This includes AbbottSmith and LiddellScott lexicons.

It turns out that there's an index from Strong's numbers to lemmas
called AbbottSmithStrongs. Using this index allows using doing
two-step lookups of Strong's numbers with the above named lexicons.

bible-mode.el

@@ -1,7 +1,7 @@
 ;;;; -*- mode: EMACS-LISP; lexical-binding: t -*-
 ;;
 ;; bible-mode.el --- A browsing interface for the SWORD Project's Diatheke CLI
-;; Time-stamp: <2024-05-24 12:13:14 fred>
+;; Time-stamp: <2024-06-14 10:04:32 fred>
 
 ;; Author: Zacalot
 ;; Fixes and modifications by Fred Gilham
@@ -106,17 +106,27 @@
   :group 'bible-mode)
 
 
-;; This determines whether or not to use the Abbott Smith lexicon.
-;; There is special-case code for this.
-(defcustom bm-use-abbott
-  t
-  "Use the Abbott Smith `Manual Greek Lexicon' for Greek definitions."
+(defcustom bm-use-index-for-lexicon nil
+  "Some lexicons are accessed by lemmas rather than Strong's numbers. Use
+an index to look up lemmas from Strong's numbers so these lexicons can
+be used. Examples of this type of lexicon are AbbottSmith and
+LiddellScott."
   :type 'boolean
   :local nil
   :group 'bible-mode)
 
+(defcustom bm-lexicon-index "AbbottSmithStrongs"
+  "A module that consists of an index mapping Strong's numbers to Greek
+lemmas. The code is written to use the entries in AbbottSmithStrongs
+which are of the form
+
+<strong's number>: @LINK <greek lemma>"
+  :type '(string :tag "Lexicon index.")
+  :local nil
+  :group 'bible-mode)
+
 
-(defcustom bm-short-greek-lexicon
+(defcustom bm-greek-lexicon-short
   "StrongsRealGreek"
   "Lexicon used for displaying definitions of Greek words in tooltips."
   :type '(string :tag "Lexicon module (e.g. \"StrongsRealGreek\").")
@@ -130,7 +140,7 @@
   :local nil
   :group 'bible-mode)
 
-(defcustom bm-short-hebrew-lexicon
+(defcustom bm-hebrew-lexicon-short
   "BDBGlosses_Strongs" ; This seems to work
   "Lexicon used for displaying definitions of Hebrew words in tooltips."
   :type '(string :tag "Lexicon module (e.g. \"StrongsRealHebrew\")")
@@ -547,7 +557,7 @@ search."
   (interactive "sBible Search: ")
   (when (> (length query) 0)
     (let* ((searchmode (completing-read "Search Mode: " '("lucene" "phrase") nil t "lucene")))
-      (bm--open-search query searchmode))))
+      (bm--open-search query searchmode bm-module))))
 
 ;;;###autoload
 (defun bible-search-mode-follow-verse ()
@@ -652,19 +662,20 @@ like `Of David' or the like.")
 
 ;;; Hash tables for Lexical definitions.
 (defvar greek-hash (make-hash-table :test 'equal))
-(defvar greek-short-hash (make-hash-table :test 'equal))  ; Hash table for ``short'' lexical lookup
+(defvar greek-hash-short (make-hash-table :test 'equal))
 (defvar hebrew-hash (make-hash-table :test 'equal))
-(defvar hebrew-short-hash (make-hash-table :test 'equal))
+(defvar hebrew-hash-short (make-hash-table :test 'equal))
 
-;; Do lookups using AbbottSmith_Strongs as index to AbbottSmith lexicon.
-(defvar abbott-index-hash (make-hash-table :test 'equal))
-(defvar abbott-lex-hash (make-hash-table :test 'equal)) 
+;; Do lookups using index to lexicon with lookups by lemma.
+(defvar lemma-index-hash (make-hash-table :test 'equal))
+(defvar lemma-lex-hash (make-hash-table :test 'equal)) 
 
 ;;; Hash tables for Morphologies. Three at present.
 (defvar robinson-hash (make-hash-table :test 'equal))
 (defvar packard-hash (make-hash-table :test 'equal))
 (defvar oshm-hash (make-hash-table :test 'equal))
 
+
 ;;; Use HTMLHREF format with diatheke, post-process to render html.
 (defun bm--morph-query (query module)
   "Executes `diatheke' to do morph query, renders HTML, returns string.
@@ -687,37 +698,28 @@ Does some tweaking specific to morphology."
   ;; Get rid of query ID at front of string: ?????:
   (bm--exec-diatheke query nil "plain" nil module))
 
-
-(defun bm--lookup-strongs-greek (window object pos)
-  "Look up Greek lexical data for object at point. If not found in hash table,
-get it from sword database, stash in hash table, and return data."
-  (let* ((query (get-text-property pos 'strong object))
-	 (match (string-match "[0-9]+" query))
-	 (lookup-key (match-string 0 query)))
-    (and lookup-key
-	 (or (gethash lookup-key greek-hash)
-	     (puthash lookup-key (bm--lex-query lookup-key bible-mode-short-greek-lexicon) greek-hash)))))
-
-
-(defun bm--lookup-lemma-abbott (key)
-  "Given a strong's number, return the Greek lemma from AbbottSmithStrongs."
-  (or (gethash key abbott-index-hash)
+(defun bm--lookup-lemma-index (key)
+  "Given a strong's number, return the Greek lemma from lemma index."
+  (or (gethash key lemma-index-hash)
       (puthash key 
 	       (string-trim 
 		(replace-regexp-in-string
-		 "(AbbottSmithStrongs)" "" 
-		 (bm--lex-query key "AbbottSmithStrongs")))
-	       abbott-index-hash)))
+		 (concat "(" bm-lexicon-index ")") "" 
+		 (bm--lex-query key bm-lexicon-index)))
+	       lemma-index-hash)))
 
 
-(defun bm--lookup-def-abbott (lemma)
-  "Executes `diatheke' to do abbott query, renders HTML, sets text
-properties to allow verse cross references. Returns string."
+(defun bm--lookup-def-by-greek-lemma (lemma)
+  "Executes `diatheke' to do query by lemma, sets text properties to allow
+verse cross references. Returns string. Note that this looks up by lemmas, 
+not Strong's numbers. The lemmas are retrieved from a Strong's number-to-lemma
+index (or possibly otherwise)."
   (with-temp-buffer
-    (let ((args (list "diatheke" nil (current-buffer) t "-b" "AbbottSmith" "-o" "m" "-f" "plain" "-k" lemma)))
+    (let ((args (list "diatheke" nil (current-buffer) t "-b" bm-greek-lexicon "-o" "m" "-f" "plain" "-k" lemma)))
       (apply 'call-process args)
       ;; Clean up outlining in the term buffer. Just fix the first
-      ;; level of outline.
+      ;; level of outline. This is specific to the AbbottSmith module;
+      ;; it may help for other versions.
       (format-replace-strings
        '((" I." . "\n   I.")
 	 (" 1." . "\n     1.")
@@ -731,6 +733,9 @@ properties to allow verse cross references. Returns string."
       (while (search-forward "\n" nil t)
 	(delete-blank-lines))
       (goto-char (point-min))
+      ;; Highlight verse references to allow lookup from lexicon
+      ;; entry. XXX This is incomplete and does not handle all the
+      ;; types of cross-reference.
       (while (search-forward-regexp bm-verse-regexp nil t)
 	(put-text-property (match-beginning 0) (match-end 0) 'xref (match-string 0))
 	(put-text-property (match-beginning 0) (match-end 0) 'keymap bible-search-mode-map)
@@ -738,37 +743,60 @@ properties to allow verse cross references. Returns string."
 	))
     (buffer-string)))
 
-(defun bm--lookup-lex-def-abbott (key)
-  (let* ((abbott-lemma (bm--lookup-lemma-abbott key))
-	 ;; Get the lemma which is after the `@LINK' string.
-	 (lemma (caddr (split-string abbott-lemma)))
-	 ;; Use the lemma to lookup the definition.
-	 (lex-def (bm--lookup-def-abbott lemma)))
-    lex-def))
 
+(defun bm--lookup-lex-greek-indexed (key)
+  (let ((lemma-entry (bm--lookup-lemma-index key))) ; Get lemma from Strong's number
+    (when lemma-entry
+      (let ((lemma (caddr (split-string lemma-entry " "))))
+	(bm--lookup-def-by-greek-lemma lemma)))))
 
-(defun bm--lookup-strongs-greek-abbott (window object pos)
-  "To use Abbott's Lexicon we extract the Strong's key from the text in the
-buffer. Given the Strong's number, get the lemma for that number. Use
-that lemma to lookup the definition in the AbbottStrongs lexicon."
-  (let* ((query (get-text-property pos 'strong object))
+
+(defun bm--lookup-lex-greek (key)
+  "Lookup lexical definition using Strong's number. Check hash table first.
+Then, if a lexicon is accessed by lemmas, do lookup using index method;
+otherwise just use the Strong's number method."
+  (or (gethash key greek-hash)
+      (puthash key 
+	       (if bm-use-index-for-lexicon
+		   (bm--lookup-lex-greek-indexed key)
+		 (bm--lex-query key bible-mode-greek-lexicon))
+	       greek-hash)))
+
+(defun bm--lookup-strongs-greek (window object pos)
+  "Look up Greek lexical string from Greek lexicon for object
+at point. If not found in hash table, get it from sword database.
+stash in hash table, and return string.
+Note: compiler warns about unused `window' argument."
+  (let* ((query (get-text-property pos 'strong object))  ; Get Strong's number from text property
+	 (match (string-match "[0-9]+" query)) ; Compiler warns about unused match variable.
+	 (lookup-key (match-string 0 query)))
+    (bm--lookup-lex-greek lookup-key)))
+
+
+(defun bm--lookup-strongs-greek-short (window object pos)
+  "Look up Greek lexical string from short Greek lexicon for object
+at point. If not found in hash table, get it from sword database, 
+stash in hash table, and return string.
+Note: compiler warns about unused `window' argument."
+  (let* ((query (get-text-property pos 'strong object))  ; Get Strong's number from text property
 	 (match (string-match "[0-9]+" query)) ; Compiler warns about unused match variable.
 	 (lookup-key (match-string 0 query)))
+    ;; Easier to debug longer version.
+;;; (when lookup-key
+;;;   (or (gethash lookup-key greek-hash-short)
+;;;	  (puthash lookup-key (bm--lex-query lookup-key bm-greek-lexicon-short) greek-hash-short)))
     (when lookup-key
-      (bm--lookup-lex-def-abbott lookup-key))))
+      (let ((data (gethash lookup-key greek-hash-short)))
+	(if data data
+	  (let ((raw-text (bm--lex-query lookup-key bm-greek-lexicon-short)))
+	    (puthash lookup-key raw-text greek-hash-short)))))))
+      
 
-;;; Not used.
-;;;;  (defun bm--hebrew-lex-query (query module)
-;;;;    "Executes `diatheke' to do hebrew query, renders HTML, returns string. 
-;;;;  XXX directionality problems."
-;;;;    (with-temp-buffer
-;;;;      (let ((args (list "diatheke" nil (current-buffer) t "-b" module "-o" "m" "-f" "HTMLHREF" "-k" query)))
-;;;;        (apply 'call-process args)
-;;;;        (shr-render-region (point-min) (point-max)))))
 
 (defun bm--lookup-strongs-hebrew (window object pos)
-  "Look up Hebrew lexical string for object at point. If not found in hash table,
-get it from sword database, stash in hash table, and return string.
+  "Look up Hebrew lexical string for object at point. 
+If not found in hash table, get it from sword database, 
+stash in hash table, and return string.
 Note: compiler warns about unused `window' argument."
   (let* ((query (get-text-property pos 'strong object))
 	 (match (string-match "[0-9]+" query))         ; Compiler warns about match.
@@ -777,10 +805,26 @@ Note: compiler warns about unused `window' argument."
       (let ((lookup-key (concat "H" (match-string 0 query))))
 	(or (gethash lookup-key hebrew-hash)
 	    ;; Use PLAIN format for lookup. XXX directionality problems.
-	    (let ((raw-text (bm--lex-query lookup-key bm-short-hebrew-lexicon)))
+	    (let ((raw-text (bm--lex-query lookup-key bm-hebrew-lexicon)))
 	      ;; XXX massage this text to handle outline formatting a bit better.
 	      (puthash lookup-key raw-text hebrew-hash)))))))
 
+(defun bm--lookup-strongs-hebrew-short (window object pos)
+  "Look up Hebrew lexical string from short Hebrew lexicon for object
+at point. If not found in hash table, get it from sword database, 
+stash in hash table, and return string.
+Note: compiler warns about unused `window' argument."
+  (let* ((query (get-text-property pos 'strong object))
+	 (match (string-match "[0-9]+" query))         ; Compiler warns about match.
+	 (match-string (match-string 0 query)))
+    (when match-string
+      (let ((lookup-key (concat "H" (match-string 0 query))))
+	(or (gethash lookup-key hebrew-hash-short)
+	    ;; Use PLAIN format for lookup. XXX directionality problems.
+	    (let ((raw-text (bm--lex-query lookup-key bm-hebrew-lexicon-short)))
+	      ;; XXX massage this text to handle outline formatting a bit better.
+	      (puthash lookup-key raw-text hebrew-hash-short)))))))
+
 (defun bm--morph-database-lookup (query database hash)
   (or (gethash query hash)
       (puthash query (bm--morph-query query database) hash)))
@@ -805,16 +849,17 @@ Note: compiler warns about unused `window' argument."
 ;;; Get string for tooltip display
 ;;;
 (defun bm--show-lex-morph (window object pos)
+  "Get text for tooltip display. Includes both lex and morph 
+definitions if text module has both tags, otherwise just get 
+lex definition."
   (let* ((lex-morph-text "")
 	 (lex (get-text-property pos 'strong object))
 	 (lex-module nil)
 	 (lex-text
 	  (cond ((string-match "strong:G" lex)
-		 (setq lex-module bm-short-greek-lexicon)
-	   	 (bm--lookup-strongs-greek window object pos))
+		 (bm--lookup-strongs-greek-short window object pos))
 		((string-match "strong:H" lex)
-		 (setq lex-module bm-short-hebrew-lexicon)
-		 (bm--lookup-strongs-hebrew window object pos)))))
+		 (bm--lookup-strongs-hebrew-short window object pos)))))
     (setq lex-text (string-replace (concat "(" lex-module ")") "" lex-text))
     (let* ((morph (get-text-property pos 'morph object))
 	   (morph-module nil)
@@ -915,7 +960,7 @@ Insert lemmas in buffer. Must be done after item is inserted in buffer."
 
 
 (defun bm-new-line ()
-  "Ensure beginning of line. Avoid redundant blank lines."
+  "Ensure beginning of line. Try to avoid redundant blank lines."
   (unless (= (current-column) 0)
     (insert "\n")))
 
@@ -1034,7 +1079,7 @@ In processing subnodes, each case will prepend a space if it needs it."
   (let ((text (bm--exec-diatheke "modulelist" nil nil nil "system"))
 	modules)
     (catch 'done
-      (dolist (line (split-string text "\n"))
+      (dolist (line (split-string text "[\n\r]+"))
 	(when (equal line "Commentaries:")
           (throw 'done nil))
 	(when (not (equal "Biblical Texts:" line))
@@ -1060,15 +1105,18 @@ In processing subnodes, each case will prepend a space if it needs it."
     (module-select-mode)
     (setq buffer-read-only nil)
     (erase-buffer)
+    (setq-local tab-stop-list '(25))
     (dolist (mod mods)
-      (insert 
-       (propertize (car mod) 
-		   'face 'bold 
-		   'module (car mod)
-		   'help-echo (concat "Select " (car mod))
-		   'keymap bm-module-map)
-       "\t\t"
-       (format "%s\n" (cadr mod))))
+      (let ((name (string-trim (car mod)))
+	    (description (string-trim-left (cadr mod))))
+	(insert 
+	 (propertize (string-trim name)
+		     'face 'bold 
+		     'module name
+		     'help-echo (concat "Select " name)
+		     'keymap bm-module-map))
+	(move-to-tab-stop)
+	(insert (format "%s\n" description))))
     (setq buffer-read-only t)
     (goto-char (point-min))
     (pop-to-buffer buf nil t)))
@@ -1076,12 +1124,12 @@ In processing subnodes, each case will prepend a space if it needs it."
 
 ;;;;; Bible Searching
 
-(defun bm--open-search (query searchmode)
+(defun bm--open-search (query searchmode module)
   "Opens a search buffer of QUERY using SEARCHMODE."
-  (let ((buf (get-buffer-create (concat "*bible-search-" (downcase bm-module) "-" query "*"))))
+  (let ((buf (get-buffer-create (concat "*bible-search-" (downcase module) "-" query "*"))))
     (set-buffer buf)
     (bible-search-mode)
-    (bm--display-search query searchmode bm-module)
+    (bm--display-search query searchmode module)
     (pop-to-buffer buf nil t)))
 
 (defun bm--display-search (query searchmode mod)
@@ -1097,7 +1145,7 @@ In processing subnodes, each case will prepend a space if it needs it."
 	 (verses nil)
 	 (query-verses "")
 	 fullverses)
-    (if (equal result (concat "none (" bm-module ")"))
+    (if (equal result (concat "none (" mod ")"))
 	(insert "No results found." (when (equal searchmode "lucene") " Verify index has been build with mkfastmod."))
       (progn
 	(while match
@@ -1121,7 +1169,7 @@ In processing subnodes, each case will prepend a space if it needs it."
 	  (if query-verses
 	      (setq query-verses (concat query-verses ";" verse))
 	    (setq query-verses verse)))
-	(setq fullverses (bm--exec-diatheke query-verses))
+	(setq fullverses (bm--exec-diatheke query-verses nil nil nil mod))
 
 	(insert fullverses)
 	    
@@ -1129,10 +1177,10 @@ In processing subnodes, each case will prepend a space if it needs it."
 	  (erase-buffer)
 	  (bm--insert-domnode-recursive (dom-by-tag html-dom-tree 'body) nil nil)
 	  (goto-char (point-min))
-	  (while (search-forward (concat "(" bm-module ")") nil t)
+	  (while (search-forward (concat "(" mod ")") nil t)
 	    (replace-match "")))))
 
-    (setq mode-name (concat "Bible Search (" bm-module ")"))
+    (setq mode-name (concat "Bible Search (" mod ")"))
     (setq buffer-read-only t)
     (setq-local bm-search-query query)
     (setq-local bm-search-mode searchmode)
@@ -1148,7 +1196,7 @@ In processing subnodes, each case will prepend a space if it needs it."
 (defun bm--display-term (termtype)
   (setq buffer-read-only nil)
   (cl-do* ((text (buffer-string))
-           (match (string-match "[0-9]+" text) (string-match "[0-9]+" text (match-end 0))))
+	   (match (string-match "[0-9]+" text) (string-match "[0-9]+" text (match-end 0))))
       ((not match))
     (let* ((matchstr (match-string 0 text))
 	   (matchstrlen (length matchstr))
@@ -1159,7 +1207,7 @@ In processing subnodes, each case will prepend a space if it needs it."
 	     (put-text-property refstart refend 'strong (concat "strong:H" matchstr))
 	     (put-text-property refstart refend 'keymap bm-hebrew-keymap)
 	     (add-face-text-property refstart refend `(:foreground "blue")))
-	    ((and (not bm-use-abbott) (eq termtype 'greek)) ; Abbott entries don't have Strong's numbers 
+	    ((eq termtype 'greek)
 	     (put-text-property refstart refend 'strong (concat "strong:G" matchstr))
 	     (put-text-property refstart refend 'keymap bm-greek-keymap)
 	     (add-face-text-property refstart refend `(:foreground "blue"))))))
@@ -1213,14 +1261,13 @@ left-to-right. XXX Why doesn't this work for the tooltips?"
   "Render the definition of the Strong's Greek TERM."
   (setq buffer-read-only nil)
   (erase-buffer)
-  (if bm-use-abbott
-      (insert (replace-regexp-in-string "\(AbbottSmith\)" "" (bm--lookup-lex-def-abbott term)))
-    (insert (replace-regexp-in-string
+  (insert (replace-regexp-in-string
 	     (regexp-opt `(,bm-greek-lexicon))
 	     ""
-	     (bm--exec-diatheke term nil "plain" nil bm-greek-lexicon)
+	     ;;	     (bm--exec-diatheke term nil "plain" nil bm-greek-lexicon)
+	     (bm--lookup-lex-greek term)
 	     nil nil nil 7
-	     )))
+	     ))
   (bm--display-term 'greek))