Add code to set up xrefs in Greek Lexicon entries if present.

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-06-14 10:04:32 fred>
+;; Time-stamp: <2024-06-19 16:02:32 fred>
 
 ;; Author: Zacalot
 ;; Fixes and modifications by Fred Gilham
@@ -110,7 +110,7 @@
   "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."
+LiddellScott. XXX LiddellScott currently doesn't work."
   :type 'boolean
   :local nil
   :group 'bible-mode)
@@ -166,7 +166,7 @@ which are of the form
 
 ;;(defvar bm-verse-regexp "([\d ]*[a-zA-Z]+( \d*:\d*)?)(( - )| )?(((\d* )?[a-zA-Z]+ )?\d*([:-]+\d*)?)")
 ;; (defvar bm-verse-regexp "/(\d*)\s*([a-z]+)\s*(\d+)(?::(\d+))?(\s*-\s*(\d+)(?:\s*([a-z]+)\s*(\d+))?(?::(\d+))?)?/i")
-(defvar bm-verse-regexp "\\(I?I \\)*[a-zA-Z]* [0-9]*:[0-9]*")
+(defvar bm-verse-regexp "\\(I?I \\)*[a-zA-Z]* [0-9]*[:.][0-9]*")
 
 (defvar bm-modules (lazy-completion-table bm-modules bm--list-biblical-modules))
 
@@ -325,10 +325,19 @@ which are of the form
 (define-key bible-search-mode-map (kbd "RET") 'bible-search-mode-follow-verse)
 (define-key bible-search-mode-map [mouse-1] 'bible-search-mode-follow-xref)
 
-(defconst bible-term-hebrew-mode-map (make-keymap))
-(defconst bible-term-greek-mode-map (make-keymap))
+(defconst bible-term-hebrew-mode-map (make-sparse-keymap))
+(defconst bible-term-greek-mode-map (make-sparse-keymap))
 ;; (defconst bible-term-morph-mode-map (make-keymap))
 
+
+(defun bible-term-mode-follow-xref ()
+  (message "Bible term mode follow xref"))
+  
+
+
+(define-key bible-term-greek-mode-map [mouse-1] 'bible-search-mode-follow-xref)
+
+
 ;;;
 ;;; Menu bar items
 ;;;
@@ -452,7 +461,7 @@ which are of the form
 \\{bible-term-greek-mode-map}"
   (buffer-disable-undo)
   (font-lock-mode t)
-;;  (use-local-map bible-term-greek-mode-map)
+  (use-local-map bible-term-greek-mode-map)
   (setq buffer-read-only t)
   (visual-line-mode t))
 
@@ -473,7 +482,7 @@ which are of the form
   (let ((buf (get-buffer-create (generate-new-buffer-name (concat "*bible*")))))
     (set-buffer buf)
     (bible-mode)
-    (bm--set-location (assoc (or book-name "Genesis") bm-books) (or chapter 1) verse)
+    (bm--set-location (or (assoc (or book-name "Genesis") bm-books) (list book-name)) (or chapter 1) verse)
     (set-window-buffer (get-buffer-window (current-buffer)) buf)))
 
 ;;;###autoload
@@ -590,6 +599,7 @@ OT/NT etc."
 	 chapter-verse
 	 chapter
 	 verse)
+    (message "Following xref %s" xref)
     (if (= (length verse-ref) 3) ; II Cor 3:17 or the like
 	(progn
 	  (setq book-abbrev (concat (car verse-ref) " " (cadr verse-ref)))
@@ -598,7 +608,9 @@ OT/NT etc."
 	(setq book-abbrev (car verse-ref))
 	(setq chapter-verse (split-string (cadr verse-ref) ":"))))
 
-    (setq book (cdr (assoc book-abbrev bm-book-name-abbreviations-alist)))
+    ;;    (setq book (cdr (assoc book-abbrev bm-book-name-abbreviations-alist)))
+    (setq book (car verse-ref))
+    (message "Xref is %s %s" book chapter-verse )
     (setq chapter (car chapter-verse)
 	  verse (cadr chapter-verse))
     (bible-open (string-trim book) (string-to-number chapter) (string-to-number verse))))
@@ -709,38 +721,144 @@ Does some tweaking specific to morphology."
 	       lemma-index-hash)))
 
 
+;;;; (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" 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. This is specific to the AbbottSmith module;
+;;;;       ;; it may help for other versions.
+;;;;       (format-replace-strings
+;;;;        '((" I." . "\n   I.")
+;;;; 	 (" 1." . "\n     1.")
+;;;; 	 (" (a)" . "\n        (a)")
+;;;; 	 (" (α)" . "\n          (α)")
+;;;; 	 ("      (i)" . "\n      (i)")
+;;;; 	 ("      (1)" . "\n      (1)")
+;;;; 	 (". ." . ".")
+;;;; 	 (" . " . ". ")))
+;;;;       (goto-char (point-min))
+;;;;       (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)
+;;;; 	(add-face-text-property (match-beginning 0) (match-end 0) '(:foreground "blue"))
+;;;; 	))
+;;;;     (buffer-string)))
+
+;;;; (defun bm--process-href ()
+;;;;   (cl-do* ((text (buffer-string))
+;;;; 	   (href-match (string-match "<a href=\"passagestudy.*?</a>" text) (string-match "<a href=\"passagestudy.*?</a>" text new-start))
+;;;; 	   (href-string (match-string 0 text) (match-string 0 text))
+;;;; 	   (new-start (match-end 0) (match-end 0)))
+;;;;       ((not href-match))
+;;;;     (let* ((value-match (string-match "value=.*?&" href-string))
+;;;; 	   (value-string (match-string 0 href-string))
+;;;; 	   (verse-ref-string (substring value-string 6 (1- (length value-string)))))
+;;;;       (set-text-properties (match-beginning 0) (match-end 0) nil)
+;;;;       (replace-regexp "<a href=\"passagestudy.*?</a>" verse-ref-string t href-match new-start)
+;;;;       (message "Replaced %s with %s" href-string verse-ref-string)
+;;;;       (put-text-property (match-beginning 0) (length verse-ref-string) 'xref (match-string 0))
+;;;;       (put-text-property (match-beginning 0) (length verse-ref-string) 'keymap bible-search-mode-map)
+;;;;       (add-face-text-property (match-beginning 0) (length verse-ref-string) '(:foreground "blue")))))
+
+;;;  (while (re-search-forward REGEXP nil t)
+;;;    (replace-match TO-STRING nil nil))
+
+
+	   
+(defun bm--process-href ()
+  (goto-char (point-min))
+  (cl-do* ((href-match (re-search-forward "<a href=\"passagestudy.*?</a>" nil t) (re-search-forward "<a href=\"passagestudy.*?</a>" nil t))
+	   (match-text (match-string 0) (match-string 0)))
+      ((not href-match))
+    (replace-match "" nil nil)
+    (let* ((value-match (string-match "value=.*?&" match-text))
+	   (value-string (match-string 0 match-text))
+	   (verse-ref-string (substring value-string 6 (1- (length value-string))))
+	   (verse-ref-length (length verse-ref-string))
+	   (prefix-1 (seq-position verse-ref-string ?1))
+	   (prefix-2 (seq-position verse-ref-string ?2)))
+
+      (aset verse-ref-string (cl-search "." verse-ref-string) 32) ; Substitute first period with space
+      (aset verse-ref-string (cl-search "." verse-ref-string) 58) ; Substitute second period with colon
+
+      ;; Handle leading 1 or 2.
+      (when (and prefix-1 (= prefix-1 0))
+	(setq verse-ref-string (concat "I" (substring verse-ref-string 1))))
+      (when (and prefix-2 (= prefix-2 0))
+	(setq verse-ref-string (concat "II" (substring verse-ref-string 1))))
+
+      (message "verse-ref-string: %s; length %s; point %s" verse-ref-string (length verse-ref-string) (point))
+      (set-text-properties 0 verse-ref-length nil verse-ref-string)
+      (put-text-property 0 verse-ref-length 'xref verse-ref-string verse-ref-string)
+      (put-text-property 0 verse-ref-length 'keymap bible-search-mode-map verse-ref-string)
+      (add-face-text-property 0 (length verse-ref-string) '(:foreground "blue") nil verse-ref-string)
+      (insert verse-ref-string))))
+
+
+
+;;;; (string-match "[0-9]+" text) (string-match "[0-9]+" text (match-end 0))))
+;;;;       ((not match))
+;;;;     ;; This enables clicking on the Strong's numbers inside the term display.
+;;;;     (let* ((matchstr (match-string 0 text))
+;;;; 	   (matchstrlen (length matchstr))
+;;;;            (refstart (+ match 1))
+;;;;            (refend (+ match 1 matchstrlen)))
+;;;;       (cond ((eq termtype 'hebrew)
+;;;; 	     (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")))
+;;;; 	    ((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"))))))
+
+
+
 (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" bm-greek-lexicon "-o" "m" "-f" "plain" "-k" lemma)))
+    (let ((args (list "diatheke" nil (current-buffer) t "-b" bm-greek-lexicon "-o" "m" "-f" "HTMLHREF" "-k" lemma)))
       (apply 'call-process args)
-      ;; Clean up outlining in the term buffer. Just fix the first
-      ;; 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.")
-	 (" (a)" . "\n        (a)")
-	 (" (α)" . "\n          (α)")
-	 ("      (i)" . "\n      (i)")
-	 ("      (1)" . "\n      (1)")
-	 (". ." . ".")
-	 (" . " . ". ")))
-      (goto-char (point-min))
-      (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)
-	(add-face-text-property (match-beginning 0) (match-end 0) '(:foreground "blue"))
-	))
+      ;;;; ;; Clean up outlining in the term buffer. Just fix the first
+      ;;;; ;; 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.")
+      ;;;; 	 (" (a)" . "\n        (a)")
+      ;;;; 	 (" (α)" . "\n          (α)")
+      ;;;; 	 ("      (i)" . "\n      (i)")
+      ;;;; 	 ("      (1)" . "\n      (1)")
+      ;;;; 	 (". ." . ".")
+      ;;;; 	 (" . " . ". ")))
+      ;;;; (goto-char (point-min))
+      ;;;; (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)
+      ;;;;  (add-face-text-property (match-beginning 0) (match-end 0) '(:foreground "blue"))
+      ;;;;  ))
+      (bm--process-href)
+      (shr-render-region (point-min) (point-max)))
     (buffer-string)))
 
 
@@ -1194,27 +1312,40 @@ In processing subnodes, each case will prepend a space if it needs it."
 ;;  )
 
 (defun bm--display-term (termtype)
+  (message "bible-mode--display-term %s" 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))))
       ((not match))
+    ;; This enables clicking on the Strong's numbers inside the term display.
     (let* ((matchstr (match-string 0 text))
 	   (matchstrlen (length matchstr))
            (refstart (+ match 1))
            (refend (+ match 1 matchstrlen)))
-      ;; This enables clicking on the Strong's numbers inside the term display.
       (cond ((eq termtype 'hebrew)
 	     (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")))
-	    ((eq termtype 'greek)
+	    ((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"))))))
-    
+	     (add-face-text-property refstart refend `(:foreground "blue")))))
+
+  (goto-char (point-min))
+  (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)
+    (put-text-property (match-beginning 0) (match-end 0) 'help-echo (concat "Go to " (match-string 0)))
+    (add-face-text-property (match-beginning 0) (match-end 0) '(:foreground "blue"))
+    (message "Found xref %s" (match-string 0))
+    )
   (goto-char (point-min))
+
 ;;  (while (search-forward (concat "(" bm-module ")") nil t)
 ;;    (replace-match ""))
+
   (while (search-forward "()" nil t)
     (replace-match ""))
   (goto-char (point-min))
@@ -1265,9 +1396,7 @@ left-to-right. XXX Why doesn't this work for the tooltips?"
 	     (regexp-opt `(,bm-greek-lexicon))
 	     ""
 	     ;;	     (bm--exec-diatheke term nil "plain" nil bm-greek-lexicon)
-	     (bm--lookup-lex-greek term)
-	     nil nil nil 7
-	     ))
+	     (bm--lookup-lex-greek term)))
   (bm--display-term 'greek))