bible-mode/bible-mode.el

;;;; -*- mode: EMACS-LISP; lexical-binding: t -*-
;;
;; bible-mode.el --- A browsing interface for the SWORD Project's Diatheke CLI
;; Time-stamp: <2024-05-15 19:11:10 fred>

;; Author: Zacalot
;; Fixes and modifications by Fred Gilham
;; Url: https://github.com/fmgilham/bible-mode
;; Forked from
;; Url: https://github.com/Zacalot/bible-mode
;; Version: 1.0.0
;; Package-Requires: ((emacs "24.1"))
;; Keywords: diatheke, sword, research, bible

;;; Commentary:

;; This package uses the `diatheke' program to browse and search 
;; Biblical texts provided by the Sword project. 
;; Word study is also supported.

;;; Usage:

;; First install `diatheke'.  On Debian/Ubuntu it's in the `diatheke'
;; package. In other distributions it might be in the sword package.

;; For Windows I found that you can simply install the Xiphos package.
;; It includes the Sword library and its utilities including diatheke,
;; installmgr and mkfastmod. Add the "Program Files\Xiphos\bin" path
;; to your execution path.

;; Use M-x `bible-open' to open a Bible buffer.
;; Use C-h f `bible-mode' to see available keybindings.

;; You may customize `bible-mode-module' to set a default browsing
;; module, as well as `bible-mode-word-study-enabled' to enable word
;; study by default.

;;; Design:

;; The idea here is to use the diatheke program to insert code from
;; modules into buffers. The main bible display uses an "internal" XML
;; format. The whole buffer gets parsed by libxml-parse-html-region to
;; create a dom tree. This gets parsed by
;; bible-mode--insert-domnode-recursive to render the text into
;; reading format.

;; The text is then decorated using information from the dom format as
;; necessary along with regular expressions to identify the verse
;; references. This is for red letters, purple highlighting of the
;; verse numbers, bold face of the divine name in the OT and so on.

;; If strongs tags and/or morphological tags are present, they are
;; looked up in appropriate lexical and morphological modules and used
;; to add tooltips to the text so that mousing over words will bring
;; up a tooltip with information about the word. Clicking on a word
;; with lexical information will display that informatio in a "term"
;; buffer.


;;;
;;; bm- is used as shorthand (see Local Variables) for bible-mode-

;;; Code:

;;;; Requirements
(require 'cl-lib) ; XXX FMG there are just a few constructs that use this; use elisp versions instead.
;; (require 'bidi)
(require 'dom)
(require 'shr)

;; Turn off tool bar mode because we want the pixels....
(tool-bar-mode -1)

;;;; Variables

(defgroup bible-mode nil
  "Settings for `bible-mode'."
  :group 'tools
  :link '(url-link "https://github.com/fmgilham/bible-mode"))

(defcustom bm-module
  "KJV"
  "Book module for Diatheke to query."
  :type '(choice (const :tag "None" nil)
                 (string :tag "Module abbreviation (e.g. \"KJV\")"))
  :local t
  :group 'bible-mode)

(defcustom bm-font
  "Ezra SIL"
  "Default font for bible-mode."
  :type '(string :tag "Font family name (e.g. \"Ezra SIL\")")
  :local t
  :group 'bible-mode)


(defcustom bm-greek-lexicon
  "MLStrong"
  "Lexicon used for displaying definitions of Greek words using Strong's codes."
  :type '(string :tag "Lexicon module (e.g. \"StrongsRealGreek\").")
  :local nil
  :group 'bible-mode)

(defcustom bm-short-greek-lexicon
  "StrongsRealGreek"
  "Lexicon used for displaying definitions of Greek words in tooltips."
  :type '(string :tag "Lexicon module (e.g. \"StrongsRealGreek\").")
  :local nil
  :group 'bible-mode)

(defcustom bm-hebrew-lexicon
  "StrongsRealHebrew"  ; Nice to use BDBGlosses_Strongs but it needs to be special-cased
  "Lexicon used for displaying definitions of Hebrew words using Strong's codes."
  :type '(string :tag "Lexicon module (e.g. \"StrongsRealHebrew\")")
  :local nil
  :group 'bible-mode)

(defcustom bm-short-hebrew-lexicon
  "StrongsRealHebrew"
  "Lexicon used for displaying definitions of Hebrew words in tooltips."
  :type '(string :tag "Lexicon module (e.g. \"StrongsRealHebrew\")")
  :local nil
  :group 'bible-mode)


(defcustom bm-word-study-enabled
  nil
  "Display Strong's Hebrew, Strong's Greek, and Lemma words for study."
  :type 'boolean
  :local t
  :group 'bible-mode)

(defcustom bm-red-letter-enabled
  t
  "Display words of Jesus in red when module has that information."
  :type 'boolean
  :local t
  :group 'bible-mode)

;;; defvars

(defvar bm-modules (lazy-completion-table bm-modules bm-list-biblical-modules))

;; XXX I believe these chapter counts aren't the same for all modules, e.g. JPS.
(defvar bm-books
  '(;; Old Testament
    ("Genesis"		. 50)	("Exodus"		. 40)	("Leviticus"		. 27)	("Numbers"		. 36)
    ("Deuteronomy"	. 34)	("Joshua"		. 24)	("Judges"		. 21)	("Ruth"			. 4)
    ("I Samuel"		. 31)	("II Samuel"		. 24)	("I Kings"		. 22)	("II Kings"		. 25)
    ("I Chronicles"	. 29)	("II Chronicles"	. 36)	("Ezra"			. 10)	("Nehemiah"		. 13)
    ("Esther" 		. 10)	("Job"			. 42)	("Psalms"		. 150)	("Proverbs"		. 31)
    ("Ecclesiastes"	. 12)	("Song of Solomon"	. 8)	("Isaiah"		. 66)	("Jeremiah"		. 52)
    ("Lamentations"	. 5)	("Ezekiel"		. 48)	("Daniel"		. 12)	("Hosea"		. 14)
    ("Joel"		. 3)	("Amos"			. 9)	("Obadiah"		. 1)	("Jonah"		. 4)
    ("Micah"		. 7)	("Nahum"		. 3)	("Habakkuk"		. 3)	("Zephaniah"		. 3)
    ("Haggai"		. 2)	("Zechariah"		. 14)	("Malachi"		. 4)
    ;; New Testament
    ("Matthew"		. 28)	("Mark"			. 16)	("Luke"			. 24)	("John"			. 21)
    ("Acts"		. 28)	("Romans"		. 16)	("I Corinthians"	. 16)	("II Corinthians" 	. 13)
    ("Galatians"	. 6)	("Ephesians"		. 6)	("Philippians"		. 4)	("Colossians"		. 4)
    ("I Thessalonians"	. 5)	("II Thessalonians"	. 3)	("I Timothy"		. 6)	("II Timothy"		. 4)
    ("Titus"		. 3)	("Philemon"		. 1)	("Hebrews"		. 13)	("James"		. 5)
    ("I Peter"		. 5)	("II Peter"		. 3)	("I John"		. 5)	("II John"		. 1)
    ("III John"		. 1)    ("Jude"			. 1)	("Revelation of John"	. 22))
  "A-list of name / chapter count for Bible books.")

;;;; Book / chapter

(defvar-local bm-current-book (assoc "Genesis" bm-books)
  "Current book data (name . chapter).")

(defvar-local bm-current-book-name "Genesis"
  "Current book name.")

(defvar-local bm-current-chapter 1
  "Current book chapter number.")

(defvar-local bm-search-query nil 
  "Search query associated with the buffer.")

(defvar-local bm-search-mode "phrase"
  "Search mode: either `lucene' or `phrase'.")

(defvar-local bm-has-strongs nil
  "Set if the module being displayed has strongs numbers availabile.")

(defvar-local bm-has-morphology nil
  "Set if the module being displayed has morphology availabile.")


;; (defvar bm-current-module nil)

;;;; Keymaps

(defconst bm-map (make-keymap))
;;;;; Navigation
(define-key bm-map "n" 'bm-next-chapter)
(define-key bm-map "p" 'bm-previous-chapter)
(define-key bm-map (kbd "TAB") 'bm-forward-word) ; TODO: bm-forward-word
;;;;; Direct jump
(define-key bm-map "b" 'bm-select-book)
(define-key bm-map "c" 'bm-select-chapter)
;;;;; Search
(define-key bm-map "s" 'bible-search)
(define-key bm-map "/" 'bible-search)
;;;; Not yet
;;(define-key bm-map "" 'bm-set-search-range)
;;;;; Misc
(define-key bm-map "m" 'bm-select-module)
(define-key bm-map "w" 'bm-toggle-word-study)
(define-key bm-map "x" 'bm-split-display)
;;;;; Deal with visual-line-mode
(define-key bm-map "\C-n" 'next-logical-line)
(define-key bm-map "\C-p" 'previous-logical-line)

(defconst bible-search-mode-map (make-keymap))
(define-key bible-search-mode-map "s" 'bible-search)
(define-key bible-search-mode-map "w" 'bm-toggle-word-study)
(define-key bible-search-mode-map (kbd "RET") 'bible-search-mode-follow-verse)

(defconst bible-term-hebrew-mode-map (make-keymap))
(defconst bible-term-greek-mode-map (make-keymap))
(defconst bible-term-morph-mode-map (make-keymap))


;;;
;;; Menu bar items
;;;
;;; Right now just convenience items. More as I think of them.
;;;
(define-key global-map [menu-bar bible-mode]
	    (cons "Bible Mode" (make-sparse-keymap "Bible Mode")))

(defun bm-set-left-to-right ()
  (interactive)
  (setq-local bidi-paragraph-direction 'left-to-right))

(defun bm-set-right-to-left ()
  (interactive)
  (setq-local bidi-paragraph-direction 'right-to-left))

(define-key global-map
	    [menu-bar bible-mode left-to-right]
	    '("Left-to-right" . bm-set-left-to-right))

(define-key global-map 
	    [menu-bar bible-mode right-to-left]
	    '("Right-to-left" . bm-set-right-to-left))

(defvar-local bm-debugme nil)

(defun bm-set-display-xml ()
  (interactive)
  (setq-local bm-debugme t)
  (bm-display))

(defun bm-set-display-text ()
  (interactive)
  (setq-local bm-debugme nil)
  (bm-display))


(define-key global-map 
	    [menu-bar bible-mode display-xml]
	    '("Display XML" . bm-set-display-xml))

(define-key global-map 
	    [menu-bar bible-mode display-text]
	    '("Display Text" . bm-set-display-text))


(define-key global-map
	    [menu-bar bible-mode select-biblical-text]
	    '("Select Module" . bm-display-available-modules))



(defun bm-display-greek ()
  (interactive)
  (let ((item (car (split-string (get-text-property (point) 'strong)))))
    ;; Remove "strong:G" prefix
    (bible-term-greek (replace-regexp-in-string "strong:G" "" item))))
	      
(defconst bm-greek-keymap (make-sparse-keymap))
(define-key bm-greek-keymap (kbd "RET") 'bm-display-greek)
(define-key bm-greek-keymap [mouse-1] 'bm-display-greek)

(defun bm-display-hebrew () 
  (interactive)
  (let ((item (car (split-string (get-text-property (point) 'strong)))))
    ;; Remove "strong:H" prefix and any alphabetic suffixes.
    (bible-term-hebrew (replace-regexp-in-string "[a-zA-Z]" "" item nil nil nil 8))))

(defconst bm-hebrew-keymap (make-sparse-keymap))
(define-key bm-hebrew-keymap (kbd "RET") 'bm-display-hebrew)
(define-key bm-hebrew-keymap [mouse-1] 'bm-display-hebrew)

(defconst bm-lemma-keymap (make-sparse-keymap))
(define-key bm-lemma-keymap (kbd "RET")
	    (lambda ()
	      (interactive)
	      ))

(defconst bm-morph-keymap (make-sparse-keymap))
(define-key bm-morph-keymap (kbd "RET")
	    (lambda ()
	      (interactive)
;;;	      (let ((thing (thing-at-point 'word)))
;;;		(message "thing at point: %s" thing)
;;;		(message "morph property %s" (get-text-property 0 'field thing))
		))

;;;; Modes

(define-derived-mode bible-mode special-mode "Bible"
  "Mode for reading the Bible.
\\{bm-map}"
  (buffer-disable-undo)
  (font-lock-mode t)
  (use-local-map bm-map)
  (setq buffer-read-only t)
  (visual-line-mode t))


(define-derived-mode bible-search-mode special-mode "Bible Search"
  "Mode for performing Bible searches.
\\{bible-search-mode-map}"
  (buffer-disable-undo)
  (font-lock-mode t)
  (use-local-map bible-search-mode-map)
  (setq buffer-read-only t)
  (visual-line-mode t)
)

(define-derived-mode bible-term-hebrew-mode special-mode "Bible Term (Hebrew)"
  "Mode for researching Hebrew terms in the Bible.
\\{bible-term-hebrew-mode-map}"
  (buffer-disable-undo)
  (font-lock-mode t)
  (use-local-map bible-term-hebrew-mode-map)
  (setq buffer-read-only t)
  (visual-line-mode t))

(define-derived-mode bible-term-greek-mode special-mode "Bible Term (Greek)"
  "Mode for researching Greek terms in the Bible.
\\{bible-term-greek-mode-map}"
  (buffer-disable-undo)
  (font-lock-mode t)
  (use-local-map bible-term-greek-mode-map)
  (setq buffer-read-only t)
  (visual-line-mode t))

(define-derived-mode module-select-mode special-mode "Select Text Module"
  (buffer-disable-undo)
  (font-lock-mode t)
  (setq buffer-read-only t))


;;;; Functions

;;;;; Commands

;;;###autoload
(defun bible-open (&optional book-name chapter verse)
  "Creates and opens a `bible-mode' buffer"
  (interactive)
  (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)
    (set-window-buffer (get-buffer-window (current-buffer)) buf)))

;;;###autoload
(defun bm-next-chapter ()
  "Pages to the next chapter for the active `bible-mode' buffer."
  (interactive)
  (let* ((book-chapters (cdr bm-current-book))
	 (chapter (min book-chapters (+ bm-current-chapter 1))))
    (bm-set-location bm-current-book chapter)))

;;;###autoload
(defun bm-previous-chapter ()
  "Pages to the previous chapter for the active `bible-mode' buffer."
  (interactive)
  (bm-set-location bm-current-book (max 1 (- bm-current-chapter 1))))


(defun bm-forward-word ()
  "Moves forward a word, taking into account the relevant text properties.
XXX Doesn't work yet."
  (interactive)
  (field-end))



;;;###autoload
(defun bm-select-book ()
  "Queries user to select a new book and chapter for the current
`bible-mode' buffer."
  (interactive)
  (let* ((completion-ignore-case t)
	 (book-data (assoc (completing-read "Book: " bm-books nil t) bm-books))
         (chapter (string-to-number (completing-read "Chapter: " (bm-list-number-range 1 (cdr book-data)) nil t))))
    (setq-local bm-current-book book-data)
    (setq-local bm-current-book-name (car book-data))
    (setq-local bm-current-chapter chapter)
    (bm-display)))


;;;###autoload
(defun bm-select-chapter ()
  "Queries user to select a new chapter for the current `bible-mode' buffer."
  (interactive)
  (let* ((book-chapters (cdr bm-current-book))
	 (chapter (string-to-number (completing-read "Chapter: " (bm-list-number-range 1 book-chapters) nil t))))
    (when chapter
      (bm-set-location bm-current-book chapter))))

;;;###autoload
(defun bm-select-module ()
  "Queries user to select a new reading module for the current `bible-mode' buffer."
  (interactive)
  (let ((module (completing-read "Module: " bm-modules)))
    (setq-local bm-module module)
    (bm-display)))

;;;###autoload
(defun bm-toggle-word-study()
  "Toggles the inclusion of word study for the active `bible-mode' buffer."
  (interactive)
  (setq bm-word-study-enabled (not bm-word-study-enabled))
  (if (equal major-mode 'bible-search-mode)
      (bm-display-search bm-search-query bm-search-mode bm-module)
    (bm-display)))

;;;###autoload
(defun bm-split-display ()
  "Copies the active `bible-mode' buffer into a new buffer in another window."
  (interactive)
  (split-window-right)
  (balance-windows)
  (other-window 1)
  (bible-open bm-current-book-name bm-current-chapter))

;;;###autoload
(defun bible-search (query)
  "Prompts the user for a Bible search query: word or phrase and type of
search: either `lucene' or `phrase'. `lucene' mode requires an index
to be built using the `mkfastmod' program. `lucene' is the default
search."
  (interactive "sBible Search: ")
  (when (> (length query) 0)
    (let* ((searchmode (completing-read "Search Mode: " '("lucene" "phrase") nil t "lucene")))
      (bm-open-search query searchmode))))

;;;###autoload
(defun bible-search-mode-follow-verse ()
  "Follows the hovered verse in a `bible-search-mode' buffer,
creating a new `bible-mode' buffer positioned at the specified verse."
  (interactive)
  (let* ((text (thing-at-point 'line t))
         book
         chapter
         verse)
    (string-match ".+ [0-9]?[0-9]?[0-9]?:[0-9]?[0-9]?[0-9]?:" text)
    (setq text (match-string 0 text))
    (string-match " [0-9]?[0-9]?[0-9]?:" text)
    (setq chapter (replace-regexp-in-string "[^0-9]" "" (match-string 0 text)))
    (string-match ":[0-9]?[0-9]?[0-9]?" text)
    (setq verse (replace-regexp-in-string "[^0-9]" "" (match-string 0 text)))
    (setq book (replace-regexp-in-string "[ ][0-9]?[0-9]?[0-9]?:[0-9]?[0-9]?[0-9]?:$" "" text))
    (bible-open book (string-to-number chapter) (string-to-number verse))))

;;;###autoload
(defun bible-term-hebrew (term)
  "Queries user for a Strong's Hebrew Lexicon term."
  (interactive "sTerm: ")
  (bm-open-term-hebrew term))

;;;###autoload
(defun bible-term-greek (term)
  "Queries user for a Strong's Greek Lexicon term."
  (interactive "sTerm: ")
  (bm-open-term-greek term))

;; (defun bible-term-morph (term morph-type)
;;   "Queries user for a Strong's Greek Lexicon term."
;;   (interactive "sTerm: ")
;; ;;;  (message "bible-term-morph: %s:%s" term morph-type)
;; ;;;  (bm-open-term-greek term)
;;   )

;;;###autoload
(defun bible-insert ()
  "Queries user to select a verse for insertion into the current buffer."
  (interactive)
  (let* ((completion-ignore-case t)
	 (book-data (assoc (completing-read "Book: " bm-books nil t) bm-books))
         (chapter (when book-data (completing-read "Chapter: " (bm-list-number-range 1 (cdr book-data)) nil t)))
         (verse (when chapter (read-from-minibuffer "Verse: "))))
    (when verse
      (insert (string-trim
	       (replace-regexp-in-string 
		(regexp-opt `(,(concat "(" bm-module ")")))
		"" 
		(bm-exec-diatheke (concat (car book-data) " " chapter ":" verse) nil "plain")))))))

;;;;; Support

;;;
;;; XXX I've magled this in an ad-hoc manner. It needs to be
;;; re-written so it is clearer (and correct, for that matter).
(defun bm-exec-diatheke (query &optional filter format searchtype module)
  "Executes `diatheke' with specified query options, returning the output."
  (let ((module (or module bm-module)))
    (with-temp-buffer
      (let ((args (list "diatheke" nil (current-buffer) t "-b" module)))
	(if filter
	    (setq filter (concat filter " avmws"))
	    (setq filter "avmws"))
	(when filter (setq args (append args (list "-o" filter))))
	(when searchtype
	  (setq args (append args (list "-s" (pcase searchtype ("lucene" "lucene") ("phrase" "phrase"))))))
	(setq args (append args (list "-f" (pcase format ("plain" "plain") (_ "internal")) "-k" query)))
	(message "%s" args)
	(apply 'call-process args))
      (buffer-string))))

(defvar-local bm-chapter-title nil
  "Document text at start of chapter, mostly in Psalms, 
like `Of David' or the like.")


;;;
;;; Greek and Hebrew lexicon and morphology tooltip rendering.
;;;

;;; Hash tables for STRONGS definitions.
(defvar greek-hash (make-hash-table :test 'equal))
(defvar hebrew-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.
Does some tweaking specific to morphology."
  (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))
      (replace-regexp-in-string
       "\n:" ""                   ; This makes the Packard morphology display look better.
       (replace-regexp-in-string 
	"Part of Speech" ""       ; This helps the Robinson display look better.
	(substring (buffer-string) (+ (length query) 1)) ; This tries to get rid of unnecessary query identifier.
	)))))


;;; Use "plain" format with diatheke.
(defun bm-lex-query (query module)
  "Executes `diatheke' for query, plain format, returns string."
  ;; 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.
Note: compiler warns about unused argument `window'."
  (let* ((query (get-text-property pos 'strong object))
	 (match (string-match "[0-9]+" query))           ; Compiler warns about match.
	 (lookup-key (match-string 0 query)))
    (and lookup-key
	 (or (gethash lookup-key greek-hash)
	     (puthash lookup-key (bm-lex-query lookup-key bm-short-greek-lexicon) greek-hash)))))


(defun bm-hebrew-lex-query (query module)
  "Executes `diatheke' to do hebrew query, renders HTML, returns string."
  (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 data for object at point. If not found in hash table,
get it from sword database, stash in hash table, and return data.
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.
	 (lookup-key (match-string 0 query)))
    (and lookup-key
	 (or (gethash lookup-key hebrew-hash)
	     ;; Use PLAIN format for lookup. XXX directionality problems.
	     (puthash lookup-key (bm-lex-query lookup-key bm-short-hebrew-lexicon) hebrew-hash)))))

(defun bm-morph-database-lookup (query database hash)
  (or (gethash query hash)
      (puthash query (bm-morph-query query database) hash)))

(defun substitute-key-definition (olddef newdef keymap)
  (message "calling me")
  nil)
			   

(defun bm-show-lex-morph (window object pos)
  (let* ((lex-morph-text "")
	 (lex (get-text-property pos 'strong object))
	 (lex-text
	  (cond ((string-match "strong:G" lex)
	   	 (bm-lookup-strongs-greek window object pos))
		((string-match "strong:H" lex)
		 (bm-lookup-strongs-hebrew window object pos)))))
    (let* ((morph (get-text-property pos 'morph object))
	   (morph-text
	    (cond ((null morph) "")
		  ((string-match "robinson:" morph)
	   	   (bm-morph-database-lookup (replace-regexp-in-string "robinson:" "" morph) "Robinson" robinson-hash))
		  ((string-match "packard:" morph)
		   (bm-morph-database-lookup (replace-regexp-in-string "packard:" "" morph) "Packard" packard-hash))
		  ((string-match "oshm:" morph)
	   	   (bm-morph-database-lookup (replace-regexp-in-string "oshm:" "" morph) "OSHM" oshm-hash)))))
      (when lex-text
	(setq lex-morph-text lex-text))
      (when morph-text
	(setq lex-morph-text (concat lex-morph-text "\n" morph-text)))
      ;; This prevents bogus command substitutions in the tooltip by
      ;; removing backslashes.
      (setq lex-morph-text (replace-regexp-in-string "\\\\" "" lex-morph-text))
      lex-morph-text)))


(defun bm-process-word (item iproperties)
  "Word study. Add tooltips for definitions and morphologyl. 
Insert lemmas in buffer. Must be done after item is inserted in buffer."

  (let ((word (dom-text item))
	(morph (dom-attr item 'morph))
	(savlm (dom-attr item 'savlm))
	(divinename (dom-by-tag item 'divinename)))

    (insert word)

    (let ((refstart (- (point) (length word)))
	  (refend  (point)))

      ;; Red letter
      (when (plist-get iproperties 'jesus)
	(add-face-text-property refstart refend '(:foreground "red")))

      ;; Special case this. XXX Some modules do this differently.
      (when divinename
	(insert "LORD")
	(let* ((refstart (- (point) (length "LORD")))
	       (refend (point))
	       (strongs (dom-attr item 'savlm)))
	  (string-match "strong:H.*" strongs)
	  (let ((strongs-ref (match-string 0 strongs)))
	    (add-face-text-property refstart refend 'bold)
      	    (put-text-property refstart refend 'keymap bm-hebrew-keymap)
	    (put-text-property refstart refend 'help-echo 'bm-show-lex-morph)
	    (put-text-property refstart refend 'strong strongs-ref))))

      ;; lexical definitions
      (when savlm
	(let ((matched nil))
	  (cond ((string-match "strong:G.*" savlm)        ; Greek
		 (setq matched (match-string 0 savlm))
		 (put-text-property refstart refend 'keymap bm-greek-keymap))
		((string-match "strong:H.*" savlm)        ; Hebrew
		 (setq matched (match-string 0 savlm))
		 (put-text-property refstart refend 'keymap bm-hebrew-keymap)))
	  ;; Add help-echo, strongs reference for tooltips if match.
	  (when matched
	    (setq-local bm-has-strongs t)
	    (put-text-property refstart refend 'help-echo 'bm-show-lex-morph)
	    (put-text-property refstart refend 'strong matched))))

      ;; morphology
      (when morph
	(let ((matched nil))
	  (cond ((string-match "robinson:.*" morph)    ; Robinson Greek morphology
		 (setq matched (match-string 0 morph)))
		((string-match "packard:.*" morph)     ; Packard Greek morphology --- LXX seems to use this
		 (setq matched (match-string 0 morph)))
		((string-match "oshm:.*" morph)        ; OSHM Hebrew morphology
		 (setq matched (match-string 0 morph)))
		(t nil
		   ;;(message "Unknown morphology %s" morph)
		   ))
	  (when matched
	    (setq-local bm-has-morphology t)
	    (put-text-property refstart refend 'morph matched)
	    (put-text-property refstart refend 'help-echo 'bm-show-lex-morph))))

      ;; Insert lemma into buffer. Lemma tag will be part of savlm item.
      (when (and bm-word-study-enabled savlm (string-match "lemma.*:.*" savlm))
	(dolist (word (split-string (match-string 0 savlm) " "))
	  (setq word (replace-regexp-in-string "[.:a-zA-Z0-9]+" "" word))
	  (insert " " word)
	  (let ((refstart (- (point) 1 (length word)))
		(refend (point)))
	    (add-face-text-property refstart refend '(:foreground "blue"))
	    (put-text-property refstart refend 'keymap bm-lemma-keymap)))))))


(defun bm-insert-domnode-recursive (node &optional iproperties notitle)
  "Recursively parses a domnode from `libxml-parse-html-region's usage on text
produced by `bm-exec-diatheke'. Outputs text to active buffer 
with properties.
In processing subnodes, each case will prepend a space if it needs it."

  (if (and bm-red-letter-enabled (equal (dom-attr node 'who) "Jesus"))
      ;; For red-letter display.
      (setq iproperties (plist-put iproperties 'jesus t))
    (setq iproperties nil))

;;  (when (equal (dom-tag node) 'title)
;;    ;; Space one line down so there's room for the title at the beginning.
;;    (insert "\n"))

  (dolist (subnode (dom-children node))
    (cond ((null subnode) nil)
	  ((stringp subnode)
	   ;; Insert the subnode. Highlight the verse references.
	   (insert subnode)
	   ;; XXX this is still not quite right
	   (let ((verse-start (string-match ".+?:[0-9]?[0-9]?[0-9]?:" subnode)))
	     (when verse-start
	       (let* ((verse-match (string-trim (match-string 0 subnode)))
		      (verse-start-text (string-trim-left (substring subnode verse-start (length subnode))))
;;		      (subnode (concat (substring subnode 0 verse-start) verse-start-text))
		      (start (- (point) 1 (length (string-trim-right verse-start-text)))))
		 (add-face-text-property start (+ start (length (string-trim-right verse-match))) '(:foreground "purple"))))))
	  ((eq (dom-tag subnode) 'title)
	   (if notitle nil
	     (progn
	       (setq bm-chapter-title subnode))))
	  ((eq (dom-tag subnode) 'body) (bm-insert-domnode-recursive subnode iproperties notitle))
	  ((eq (dom-tag subnode) 'seg) ; NASB Module uses this to indicate OT quotations (and others?).
	   (bm-insert-domnode-recursive subnode iproperties notitle))
	  ((eq (dom-tag subnode) 'q) (bm-insert-domnode-recursive subnode iproperties notitle))
	  ((eq (dom-tag subnode) 'p) (bm-insert-domnode-recursive subnode iproperties notitle))
	  ((eq (dom-tag subnode) 'w) (insert " ") (bm-process-word subnode iproperties))
	  ((eq (dom-tag subnode) 'milestone) (insert "\n"))
	  ((eq (dom-tag subnode) 'transchange) ; Word inserted by translation, not in original, give visual indication.
	   (let ((word (dom-text subnode)))
	     (insert " " word)
	     (add-face-text-property (- (point) (length word)) (point) '(:foreground "gray50")))))))


(defvar bm-debugme nil)
(setf bm-debugme nil)

(defun bm-display (&optional verse)
  "Renders text for `bible-mode'"

  ;; Clear buffer and insert the result of calling bm-exec-diatheke.
  (setq buffer-read-only nil)
  (erase-buffer)
  (setq bm-chapter-title nil
	bm-has-strongs nil
	bm-has-morphology nil)
  (insert (bm-exec-diatheke (concat bm-current-book-name ":" (number-to-string bm-current-chapter))))

  ;; Parse the xml in the buffer into a DOM tree.
  (let ((html-dom-tree (libxml-parse-html-region (point-min) (point-max))))
    ;; Render the DOM tree into the buffer.
    (if (not bm-debugme)
	(progn
	  (erase-buffer)
	  ;; Looking for the "body" tag in the DOM node.
	  (bm-insert-domnode-recursive (dom-by-tag html-dom-tree 'body) nil nil)
	  (goto-char (point-min)))
;;;      (shr-render-region (point-min) (point-max))
      ))

  ;; Remove the module name from the buffer.
  (while (search-forward (concat "(" bm-module ")") nil t)
    (replace-match ""))

  ;; Set the mode line of the biffer.
  (setq mode-name (concat "Bible (" 
			  bm-module
			  (when bm-has-strongs " Lex")
			  (when bm-has-morphology " Morph")
			  ")"))

  ;; Deal with chapter titles (i.e. in Psalms)
  ;; N.B. This won't change a title inside a chapter, and so it
  ;; doesn't work with Psalm 119 where the acrostic letters get
  ;; printed as "titles".
  (when bm-chapter-title  ; This gets set in bm-insert-domnode-recursive.
    (goto-char (point-min))
    (let ((title-text (dom-texts bm-chapter-title))
	  (refstart (point-min))
	  refend)
      ;; Insert and make bold the title.
      (when (string-or-null-p title-text)
	  (insert title-text "\n")
	  (setq refend (point))
	  (put-text-property refstart refend 'face 'bold))))

  (setq buffer-read-only t)
  (goto-char (point-min))

  ;; If optional verse specification go to that verse.
  (when verse
    (goto-char (string-match (regexp-opt `(,(concat ":" (number-to-string verse) ":"))) (buffer-string)))
    (beginning-of-line)))


(defun bm-list-biblical-modules ()
  "Returns a list of accessible Biblical Text modules."
  (let ((text (bm-exec-diatheke "modulelist" nil nil nil "system"))
	modules)
    (catch 'done
      (dolist (line (split-string text "\n"))
	(when (equal line "Commentaries:")
          (throw 'done nil))
	(when (not (equal "Biblical Texts:" line))
          (push (split-string line " : ") modules))))
    modules))

(defun bm-pick-module ()
  (interactive)
  (message "Picking module at %s" (point))
  (let ((item (get-text-property (point) 'module)))
    (setq-default bm-module item)
    (bible-open)))
    

(defconst bm-module-map (make-keymap))
(define-key bm-module-map [mouse-1] 'bm-pick-module)


(defun bm-display-available-modules ()
  (interactive)
  (let ((buf (get-buffer-create "Modules"))
	(mods (bm-list-biblical-modules)))
    (set-buffer buf)
    (module-select-mode)
    (setq buffer-read-only nil)
    (erase-buffer)
    (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))))
    (setq buffer-read-only t)
    (goto-char (point-min))
    (pop-to-buffer buf nil t)))



;;;;; Bible Searching

(defun bm-open-search (query searchmode)
  "Opens a search buffer of QUERY using SEARCHMODE."
  (let ((buf (get-buffer-create (concat "*bible-search-" (downcase bm-module) "-" query "*"))))
    (set-buffer buf)
    (bible-search-mode)
    (bm-display-search query searchmode bm-module)
    (pop-to-buffer buf nil t)))

(defun bm-display-search (query searchmode mod)
  "Renders results of search QUERY from SEARHCMODE"
  (setq buffer-read-only nil)
  (erase-buffer)
  
  (let* ((result (string-trim (replace-regexp-in-string 
			       "Entries .+?--" "" 
			       (bm-exec-diatheke query nil "plain" searchmode mod))))
	 (match 0)
	 (matchstr "")
	 (verses "")
	 fullverses)
    (if (equal result (concat "none (" bm-module ")"))
	(insert "No results found." (when (equal searchmode "lucene") " Verify index has been build with mkfastmod."))
      (progn
	(while match
	  (setq match (string-match ".+?:[0-9]?[0-9]?" result (+ match (length matchstr)))
		matchstr (match-string 0 result))
	  (when match
            (setq verses (concat verses (replace-regexp-in-string ".+; " "" matchstr) ";"))))

	(setq match 0)
	(setq fullverses (bm-exec-diatheke verses))

	(insert fullverses)
	(sort-lines nil (point-min) (point-max))
	    
	(let* ((html-dom-tree (libxml-parse-html-region (point-min) (point-max))))
	  (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)
	    (replace-match "")))))

    (setq mode-name (concat "Bible Search (" bm-module ")"))
    (setq buffer-read-only t)
    (setq-local bm-search-query query)
    (setq-local bm-search-mode searchmode)
    (goto-char (point-min))))

;;;;; Terms


;;(defun bm-display-morphology (morph)
;; ;; xxx Do something here?
;;  )

(defun bm-display-term (termtype)
  (cl-do* ((text (buffer-string))
           (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))
           (refstart (+ match 1))
           (refend (+ match 1 matchstrlen)))
      ;; This enables clicking on the Strong's numbers inside the term display.
      (add-face-text-property refstart refend `(:foreground "blue"))
      (cond ((eq termtype 'hebrew)
	     (put-text-property refstart refend 'strong (concat "strong:H" matchstr))
	     (put-text-property refstart refend 'keymap bm-hebrew-keymap))
	    ((eq termtype 'greek)
	     (put-text-property refstart refend 'strong (concat "strong:G" matchstr))
	     (put-text-property refstart refend 'keymap bm-greek-keymap)))))
  (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))
  (setq buffer-read-only t))

(defun bm-open-term-hebrew (term)
  "Opens a buffer of the Strong's Hebrew TERM's definition"
  (let ((buf (get-buffer-create (concat "*bible-term-hebrew-" term "*"))))
    (set-buffer buf)
    (bible-term-hebrew-mode)
    (bm-display-term-hebrew term)
    (pop-to-buffer buf nil t)
    (fit-window-to-buffer)))

(defun bm-open-term-greek (term)
  "Opens a buffer of the Strong's Greek TERM's definition"
  (let ((buf (get-buffer-create (concat "*bible-term-greek-" term "*"))))
    (set-buffer buf)
    (bible-term-greek-mode)
    (bm-display-term-greek term)
    (pop-to-buffer buf nil t)
    (fit-window-to-buffer)))

;;;
;;; Note: Hebrew display of terms is backwards; set bidi direction to
;;; 'left-to-right.
(defun bm-display-term-hebrew (term)
  "Render the definition of the Strong's Hebrew TERM. Use
bidi-paragraph-direction so the English text will render
left-to-right. XXX Why doesn't this work for the tooltips?"
  (setq buffer-read-only nil)
  (erase-buffer)
  (insert (replace-regexp-in-string
	   (regexp-opt `(,bm-hebrew-lexicon))
	   ""
	   (bm-exec-diatheke term nil "plain" nil bm-hebrew-lexicon)
	   nil nil nil 7
	   ))
  (bm-display-term 'hebrew)
  (setq bidi-paragraph-direction 'left-to-right))


(defun bm-display-term-greek (term)
  "Render the definition of the Strong's Greek TERM."
  (setq buffer-read-only nil)
  (erase-buffer)
  (insert (replace-regexp-in-string
	   (regexp-opt `(,bm-greek-lexicon))
	   "" 
	   (bm-exec-diatheke term nil "plain" nil bm-greek-lexicon)
	   nil nil nil 7
	   ))
  ;;  (insert "\n")
  (bm-display-term 'greek))


(defun bm-set-location (book chapter &optional verse)
  "Sets the global chapter of the active `bible-mode' buffer."
  (setq-local bm-current-book book)
  (setq-local bm-current-book-name (car book))
  (setq-local bm-current-chapter chapter)
  (bm-display verse))

;;;;; Utilities

(defun bm-list-number-range (min max &optional prefix)
  "Returns a list containing entries for each integer between min and max.
Used in tandem with `completing-read' for chapter selection."
  (let ((range-list nil))
    (dotimes (num (1+ max))
      (when (>= num min)
	(push (cons (concat prefix (number-to-string num)) num) range-list)))
    (nreverse range-list)))


;;; Provides

(provide 'bible-mode)

;; Local Variables:
;; read-symbol-shorthands: (("bm-" . "bible-mode-"))
;; End: