A lot of changes - partly UI redesign, partly data redesign

chapter.lisp

@@ -1,56 +1,79 @@
 (in-package #:cl-bible.chapter)
 
-(defun book/chapter-window (canvas title)
+(defclass chapter ()
+  ((%verses :initarg :verses
+            :reader verses)))
+
+(defgeneric chapter-to-clog (chapter parent &key translation))
+(defgeneric book/chapter-window (canvas title))
+(defgeneric translations-drop-down (div display chapter drop-down))
+(defgeneric display-chapter-or-book (canvas title chapter))
+(defgeneric load-chapter (canvas book chapter))
+(defgeneric load-book (canvas book))
+
+(defmethod chapter-to-clog ((chapter chapter) (parent clog:clog-obj) &key (translation :mng))
+  (labels ((verse-to-clog (verse)
+;;;             (clog:set-on-click
+              (v:verse-to-clog verse parent :translation translation)
+;;;              (lambda (obj)
+;;;                (declare (ignore obj))
+;;;                (v::show-notes verse parent)))
+             ))
+    (mapcar #'verse-to-clog (verses chapter))))
+
+(defmethod book/chapter-window (canvas (title string))
   (let* ((win (window-content
                (create-gui-window canvas
                                   :title title
                                   :height 400
-                                  :width 650)))
+                                  :width 500)))
          (mbar (create-gui-menu-bar win))
          (drop-down (create-gui-menu-drop-down mbar :content "Translations")))
     (values (create-div win)
             drop-down)))
 
-(defun translations-drop-down (div display verses drop-down)
+(defmethod translations-drop-down ((div clog:clog-div) display (chapter chapter) drop-down)
   (mapcar
    (lambda (translation)
-     (labels ((verse-to-clog (verse)
+     (labels ((callback (obj)
-                (v:verse-to-clog verse
-                                 div
-                                 :translation (second translation)))
-              (hide-verse (verse) (setf (hiddenp verse) t))
-              (callback (obj)
                 (declare (ignore obj))
-                (mapc #'hide-verse display)
+                (d:update-bible (third translation))))
-                (setf display (mapcar #'verse-to-clog verses))))
        (create-gui-menu-item drop-down
                              :content (first translation)
                              :on-click #'callback)))
    d:*translations*))
 
-(defun display-chapter-or-book (canvas title verses)
+(defmethod display-chapter-or-book (canvas (title string) (chapter chapter))
   (multiple-value-bind (div drop-down)
       (book/chapter-window canvas title)
-    (flet ((verse-to-clog (verse)
+    (let ((display (chapter-to-clog chapter div :translation d:*translation*)))
-             (v:verse-to-clog verse
+      (translations-drop-down div display chapter drop-down))))
-                              div
+
-                              :translation d:*translation*)))
+(defmethod load-chapter (canvas (book string) (chapter string))
-      (let ((display (mapcar #'verse-to-clog verses)))
+  (let* ((bk (s:find-book d:*bible* book))
-        (translations-drop-down div display verses drop-down)))))
+         (verses (if (find #\- chapter)
-
+                     (loop :for chap :in (uiop:split-string chapter :separator '(#\-))
-(defun load-chapter (canvas book chapter)
+                           :append (s:find-chapter bk chap))
+                     (s:find-chapter bk chapter))))
   (display-chapter-or-book canvas
                            (format nil "~A: ~A ~A"
                                    d:*translation*
                                    book
                                    chapter)
-                        (s:find-chapter
+                           (make-instance 'chapter :verses verses))))
-                         (s:find-book d:*bible* book)
-                         chapter)))
 
-(defun load-book (canvas book)
+(defmethod load-book ((canvas clog:clog-body) (book string))
   (display-chapter-or-book canvas
                            (format nil "~A: ~A"
                                    d:*translation*
                                    book)
-                        (s:find-book d:*bible* book)))
+                           (make-instance 'chapter
+                                          :verses (s:find-book d:*bible* book))))
+
+(defmethod load-position ((canvas clog:clog-body) (pos string))
+  (display-chapter-or-book canvas
+                           (format nil "~A: ~A"
+                                   d:*translation*
+                                   pos)
+                           (make-instance 'chapter
+                                          :verses (s:find-verse d:*bible* (s:parse-position pos)))))

clog.lisp

@@ -40,7 +40,7 @@
                                                  d:*translation*
                                                  phrase)
                                   :height 400
-                                  :width 650)))
+                                  :width 500)))
          (lift-search (create-button win :content "Lift Search"))
          (div (create-div win))
          (results (s:find-in-bible bible phrase)))
@@ -50,7 +50,13 @@
     (create-p div :content (ergebnis/se
                             (length results)))
     (mapc (lambda (verse)
-            (v:verse-to-clog verse div :translation d:*translation*))
+            (clog:set-on-click
+             (v:verse-to-clog verse div :translation d:*translation*)
+             (lambda (obj)
+               (declare (ignore obj))
+               (ch:load-chapter canvas
+                                (v:bname verse)
+                                (v:chapter verse)))))
           results)))
 
 (defun %bible-book-or-chapter (bible book chapter)
@@ -100,23 +106,19 @@
 
 (defun load-book-or-chapter (canvas)
   (lambda (data)
-    (let* ((book (cadr (assoc "book" data :test #'string=)))
+    (ch:load-position canvas
-           (chapter (cadr (assoc "chapter" data :test #'string=))))
+                      (second (assoc "pos" data :test #'string=)))))
-      (if (string= chapter "")
-          (ch:load-book canvas book)
-          (ch:load-chapter canvas book chapter)))))
 
 (defun get-chapter (window body)
   (lambda (obj)
     (declare (ignore obj))
-    (form-dialog window "Which chapter do you want?"
+    (form-dialog window "Which passage do you want?"
-                 '(("Book" "book" :text)
+                 '(("" "pos" :text))
-                   ("Chapter" "chapter" :text))
                  (load-book-or-chapter body)
-                 :title "Load a Chapter")))
+                 :title "Load a Passage")))
 
 (defun setup-window (body)
-  (let ((window (create-gui-window body :title "Search"
+  (let ((window (create-gui-window body :title "background"
                                         :hidden t)))
     (window-normalize window)
     (window-center window)
@@ -140,9 +142,12 @@
                           :content "Close all windows"
                           :on-click (lambda (obj)
                                       (declare (ignore obj))
-                                      (loop for win = (current-window body)
+                                      (loop :for win = (current-window body)
-                                            unless win do (return) 
+                                            :if (or (null win)
-                                              do (window-close win))))
+                                                    (string= (window-title win)
+                                                             "background"))
+                                              :do (return) 
+                                              :do (window-close win))))
     (create-gui-menu-item mbar
                           :content "Save notes"
                           :on-click (lambda (obj)

data.lisp

@@ -2,16 +2,21 @@
 
 (in-package #:cl-bible.data)
 
-(defvar *translations* '(("Menge" :mng)
+(defvar *translations* '(("Menge" :mng "mng")
-                         ("King James Version" :kjv)
+                         ("King James Version" :kjv "kjv")
-                         ("Vulgata" :vul)
+                         ("Vulgata" :vul "vul")
-                         ("Greek Bible" :grb)
+                         ("Greek Bible" :grb "grb")
-                         ("Elberfelder Übersetzung  1871" :elb1871)
+                         ("Elberfelder Übersetzung  1871" :elb1871 "elb1871")
-                         ("NEÜ" :neue)
+                         ("NEÜ" :neue "neue")
-                         ("Luther 1545" :luth1545)
+                         ("Luther 1545" :luth1545 "luth1545")
-                         ("Luther 1912" :luth1912)
+                         ("Luther 1912" :luth1912 "luth1912")
-                         ("Schlachter 1951" :sch1951)
+                         ("Schlachter 1951" :sch1951 "sch1951")
-                         ("Ukrainische Version" :ukr)))
+                         ("Ukrainische Version" :ukr "ukr")))
+
+(defun read-bible-from-tsv (filename)
+  (mapcar #'v:string-to-verse
+          (uiop:read-file-lines
+           (uiop:native-namestring (concatenate 'string "~/.bible/" filename ".tsv")))))
 
 (defun load-bible (filename)
   (v:from-sexp
@@ -19,7 +24,7 @@
     (uiop:read-file-string (uiop:native-namestring filename)))))
 
 (defvar *translation* :mng)
-(defvar *bible*)
+(defvar *bible* nil)
 
 (defun load-bibles ()
   (ensure-directories-exist (uiop:native-namestring "~/.bible/"))
@@ -33,7 +38,8 @@
 (load-bibles)
 
 (defun update-bible (translation)
-  (setf *translation* (intern translation :keyword)))
+  (setf *translation* (intern translation :keyword))
+  (setf *bible* (read-bible-from-tsv (string-downcase translation))))
 
 (defun persist-bible (bible filename filepath)
   (with-open-file (file (uiop:native-namestring (concatenate 'string filepath filename ".sexp"))
@@ -123,10 +129,10 @@
                   ("Manasse" . "Manasse")
                   ("xEster" . "xEster")))
 
-(defun add-bible (bible new name mapping)
+(defun add-bible (bible new mapping)
   (mapc (lambda (map)
           (mapc (lambda (old new)
-                  (push (cons name (v:text new))
+                  (nconc (v:translations new)
                          (v::translations old)))
                 (cl-bible.search:find-book bible (car map))
                 (cl-bible.search:find-book new (cdr map))))

package.lisp

@@ -20,7 +20,9 @@
   (:local-nicknames (#:v #:cl-bible.verse))
   (:export find-in-bible
            find-book
-           find-chapter))
+           find-chapter
+           find-verse
+           parse-position))
 
 (defpackage #:cl-bible.data
   (:use #:cl)
@@ -46,7 +48,8 @@
                     (#:s #:cl-bible.search)
                     (#:v #:cl-bible.verse))
   (:export load-chapter
-           load-book))
+           load-book
+           load-position))
 
 (defpackage #:cl-bible.clog
   (:use #:cl #:clog #:clog-gui)

search.lisp

@@ -6,8 +6,111 @@
   (remove-if-not (lambda (verse) (search phrase (v:get-text verse)))
                  bible))
 
-(defun find-book (bible book)
+(defmethod find-book (bible book)
   (remove-if-not (lambda (verse) (search book (v:bname verse))) bible))
 
-(defun find-chapter (book chapter)
+(defmethod find-chapter (book chapter)
   (remove-if-not (lambda (verse) (string= chapter (v:chapter verse))) book))
+
+(defmethod find-verse (chapter verse)
+  (remove-if-not (lambda (v) (string= verse (v:vnumber v))) chapter))
+
+(defclass position ()
+  ((book :initarg :book
+          :reader book)
+   (start :initarg :start
+          :initform nil
+          :reader start)
+   (end :initarg :end
+        :initform nil
+        :reader end)))
+   
+(defclass verse-pos ()
+  ((chapter :initarg :chapter
+            :reader chapter)
+   (verse :initarg :verse
+          :initform nil
+          :reader verse)))
+
+(defun parse-position (position)
+  (if (find #\space position)
+      (destructuring-bind (book rest)
+          (uiop:split-string position :separator '(#\space))
+        (if (find #\- rest)
+            (destructuring-bind (start end)
+                (uiop:split-string rest :separator '(#\-))
+              (make-instance 'position :book book
+                                       :start (parse-verse-pos start)
+                                       :end (parse-verse-pos end)))
+            (make-instance 'position :book book
+                                     :start (parse-verse-pos rest))))
+      (make-instance 'position :book position)))
+
+(defun parse-verse-pos (verse-pos)
+  (if (find #\, verse-pos)
+      (destructuring-bind (chapter verse)
+          (uiop:split-string verse-pos :separator '(#\,))
+        (make-instance 'verse-pos :chapter (parse-integer chapter)
+                                  :verse (parse-integer verse)))
+      (make-instance 'verse-pos :chapter (parse-integer verse-pos))))
+
+(defmethod bookp ((pos position))
+  (if (start pos) nil t))
+
+(defmethod rangep ((pos position))
+  (if (end pos) t nil))
+
+(defmethod versep ((pos verse-pos))
+  (if (verse pos) t nil))
+
+(defmethod versep ((pos position))
+  (versep (start pos)))
+
+(defun find-position (bible position)
+  "Accepts a bible citation of the form \"Genesis 18,32\" and returns
+the requested verse/s"
+  (let ((pos (parse-position position)))
+    (with-accessors ((book book)
+                     (start start)
+                     (end end))
+        pos
+      (let* ((book (find-book bible book))
+             (chapter (if (rangep pos)
+                          (loop :for chapter :from (chapter start) :to (chapter end)
+                                :append (find-chapter book (format nil "~A" chapter)))
+                          (find-chapter book (format nil "~A" (chapter start))))))
+        (if (versep pos)
+            (if (rangep pos)
+                (loop :for verse :from (verse start) :to (verse end)
+                      :append (find-verse chapter (format nil "~A" verse)))
+                (find-verse chapter (format nil "~A" (verse start))))
+            chapter)))))
+
+(defmethod find-book (bible (pos position))
+  (find-book bible (book pos)))
+
+(defmethod find-chapter (bible (pos position))
+  (let ((book (find-book bible pos)))
+    (if (bookp pos)
+        book
+        (with-accessors ((start start)
+                         (end end))
+            pos
+          (if (rangep pos)
+              (loop :for chapter :from (chapter start) :to (chapter end)
+                    :append (find-chapter book (format nil "~A" chapter)))
+              (find-chapter book (format nil "~A" (chapter start))))))))
+
+(defmethod find-verse (bible (pos position))
+  (let ((chapter (find-chapter bible pos)))
+    (if (bookp pos)
+        chapter
+        (with-accessors ((start start)
+                         (end end))
+            pos
+          (if (versep pos)
+              (if (rangep pos)
+                  (loop :for verse :from (verse start) :to (verse end)
+                        :append (find-verse chapter (format nil "~A" verse)))
+                  (find-verse chapter (format nil "~A" (verse start))))
+              chapter)))))

verse.lisp

@@ -20,19 +20,31 @@
            :initform '()
            :accessor notes)))
 
+(defgeneric string-to-verse (string))
+(defgeneric verse-to-string (verse &key separator translation))
+(defgeneric verse-to-latex (verse &key translation port))
+(defgeneric get-text (verse))
+(defgeneric %format-notes (notes))
+(defgeneric %create-notes-window (verse parent))
+(defgeneric show-notes (verse parent))
+(defgeneric add-notes (verse parent))
+(defgeneric verse-to-clog (verse parent &key translation))
+(defgeneric to-sexp (verse))
+(defgeneric verse-from-sexp (sexp))
+(defgeneric from-sexp (bible))
+
 (defmethod print-object ((verse verse) stream)
   (format stream (verse-to-string verse :separator " ")))
 
-(defun string-to-verse (string)
+(defmethod string-to-verse ((string string))
   (let ((verse (uiop:split-string string :separator '(#\Tab))))
-    (make-instance 'verse :bname (car verse)
+    (make-instance 'verse :bname (first verse)
-                          :bsname (nth 1 verse)
+                          :bsname (second verse)
-                          :chapter (nth 3 verse)
+                          :chapter (fourth verse)
-                          :number (nth 4 verse)
+                          :number (fifth verse)
-                          :text (nth 5 verse))))
+                          :text (sixth verse))))
 
-(defgeneric verse-to-string (verse &key separator translation))
+(defmethod verse-to-string ((verse cons) &key (separator " ") translation)
-(defmethod verse-to-string (verse &key (separator " ") translation)
   (declare (ignore translation))
   (format nil "~A ~A:~A~A~A" (cadr verse)
           (nth 3 verse)
@@ -40,16 +52,19 @@
           separator
           (nth 5 verse)))
 
-(defmethod verse-to-string ((verse verse)
+(defmethod verse-to-string ((verse verse) &key (separator "<br/>") (translation :elb1871))
-                            &key (separator "<br/>")
+  (concatenate 'string 
-                              (translation :mng))
+               (when (string= (vnumber verse) "1")
-  (format nil "~A ~A:~A~A ~A" (bsname verse)
+                 (format nil "<b>~A ~A</b>~A"
+                         (bname verse)
                          (chapter verse)
+                         separator))
+               (format nil "~A ~A"
                        (vnumber verse)
-          separator
+                       (if (translations verse)
-          (cdr (assoc translation (translations verse)))))
+                           (cdr (assoc translation (translations verse)))
+                           (text verse)))))
 
-(defgeneric verse-to-latex (verse &key translation port))
 (defmethod verse-to-latex ((verse verse) &key translation (port t))
   (declare (ignore translation))
   (format port "~A ~A ^{~A} ~%~{~A~%~} \\\\~%"
@@ -60,17 +75,20 @@
                                          (translations verse)))
                   '(:mng :luth1545 :luth1912 :sch1951 :elb1871 :neue))))
 
-(defgeneric get-text (verse))
 (defmethod get-text ((verse verse))
+  (let ((translations (translations verse)))
+    (if translations
         (cdr (assoc cl-bible.data:*translation*
-              (translations verse))))
+                    translations))
+        (text verse))))
+
+(defmethod %format-notes ((notes cons))
+  (format nil "~{~A~^<br/>~}" notes))
 
-(defun %format-notes (notes)
+(defmethod %format-notes ((notes (eql nil)))
-  (if notes
+  "No notes found")
-      (format nil "~{~A~^<br/>~}" notes)
-      "No notes found"))
 
-(defun %create-notes-window (verse parent)
+(defmethod %create-notes-window ((verse verse) (parent clog:clog-obj))
   (let ((win (clog-gui:window-content
               (clog-gui:create-gui-window parent
                                           :title "Notes"
@@ -80,8 +98,6 @@
     (clog:create-button win
                         :content "Add notes")))
 
-
-(defgeneric show-notes (verse parent))
 (defmethod show-notes ((verse verse) (parent clog:clog-obj))
   (let ((button (%create-notes-window verse parent)))
     (clog:set-on-click button
@@ -89,7 +105,7 @@
                          (declare (ignore obj))
                          (add-notes verse parent)))))
 
-(defun %create-add-notes-window (parent)
+(defmethod %create-add-notes-window ((parent clog:clog-obj))
   (let* ((form (clog:create-form
                 (clog-gui:window-content
                  (clog-gui:create-gui-window parent
@@ -100,7 +116,6 @@
     (values text
             (clog:create-button form :content "submit"))))
 
-(defgeneric add-notes (verse parent))
 (defmethod add-notes ((verse verse) (parent clog:clog-obj))
   (multiple-value-bind (text button)
       (%create-add-notes-window parent)
@@ -109,19 +124,10 @@
                          (declare (ignore obj))
                          (push (clog:value text) (notes verse))))))
 
-(defgeneric verse-to-clog (verse parent &key translation))
 (defmethod verse-to-clog ((verse verse) (parent clog:clog-obj) &key (translation :mng))
-  (let ((display
+  (clog:create-p parent :content (verse-to-string verse :translation translation)))
-          (clog:create-p parent
+    
-                         :content (verse-to-string verse
-                                                   :translation translation))))
-    (clog:set-on-click display
-                       (lambda (obj)
-                         (declare (ignore obj))
-                         (show-notes verse parent)))
-    display))
 
-(defgeneric to-sexp (verse))
 (defmethod to-sexp ((verse verse))
   (list (bname verse)
         (bsname verse)
@@ -133,14 +139,14 @@
 (defmethod to-sexp ((bible cons))
   (mapcar #'to-sexp bible))
 
-(defun verse-from-sexp (sexp)
+(defmethod verse-from-sexp ((sexp cons))
   (make-instance 'verse
-                 :bname (car sexp)
+                 :bname (first sexp)
-                 :bsname (cadr sexp)
+                 :bsname (second sexp)
-                 :chapter (caddr sexp)
+                 :chapter (fourth sexp)
-                 :number (nth 3 sexp)
+                 :number (fifth sexp)
-                 :translations (nth 4 sexp)
+                 :text (sixth sexp)
-                 :notes (nth 6 sexp)))
+                 :notes (seventh sexp)))
-
+
-(defun from-sexp (bible)
+(defmethod from-sexp ((bible cons))
   (mapcar #'verse-from-sexp bible))