diff --git a/chapter.lisp b/chapter.lisp index 1591dd2..2df5a96 100644 --- a/chapter.lisp +++ b/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) - (v:verse-to-clog verse - div - :translation (second translation))) - (hide-verse (verse) (setf (hiddenp verse) t)) - (callback (obj) + (labels ((callback (obj) (declare (ignore obj)) - (mapc #'hide-verse display) - (setf display (mapcar #'verse-to-clog verses)))) + (d:update-bible (third translation)))) (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) - (v:verse-to-clog verse - div - :translation d:*translation*))) - (let ((display (mapcar #'verse-to-clog verses))) - (translations-drop-down div display verses drop-down))))) - -(defun load-chapter (canvas book chapter) + (let ((display (chapter-to-clog chapter div :translation d:*translation*))) + (translations-drop-down div display chapter drop-down)))) + +(defmethod load-chapter (canvas (book string) (chapter string)) + (let* ((bk (s:find-book d:*bible* book)) + (verses (if (find #\- chapter) + (loop :for chap :in (uiop:split-string chapter :separator '(#\-)) + :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 - (s:find-book d:*bible* book) - chapter))) - -(defun load-book (canvas book) + (format nil "~A: ~A ~A" + d:*translation* + book + chapter) + (make-instance 'chapter :verses verses)))) + +(defmethod load-book ((canvas clog:clog-body) (book string)) + (display-chapter-or-book canvas + (format nil "~A: ~A" + d:*translation* + 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* - book) - (s:find-book d:*bible* book))) + (format nil "~A: ~A" + d:*translation* + pos) + (make-instance 'chapter + :verses (s:find-verse d:*bible* (s:parse-position pos))))) diff --git a/clog.lisp b/clog.lisp index 3677634..ab75d76 100644 --- a/clog.lisp +++ b/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=))) - (chapter (cadr (assoc "chapter" data :test #'string=)))) - (if (string= chapter "") - (ch:load-book canvas book) - (ch:load-chapter canvas book chapter))))) + (ch:load-position canvas + (second (assoc "pos" data :test #'string=))))) (defun get-chapter (window body) (lambda (obj) (declare (ignore obj)) - (form-dialog window "Which chapter do you want?" - '(("Book" "book" :text) - ("Chapter" "chapter" :text)) + (form-dialog window "Which passage do you want?" + '(("" "pos" :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) - unless win do (return) - do (window-close win)))) + (loop :for win = (current-window body) + :if (or (null win) + (string= (window-title win) + "background")) + :do (return) + :do (window-close win)))) (create-gui-menu-item mbar :content "Save notes" :on-click (lambda (obj) diff --git a/data.lisp b/data.lisp index 906712b..d4aee1f 100644 --- a/data.lisp +++ b/data.lisp @@ -2,16 +2,21 @@ (in-package #:cl-bible.data) -(defvar *translations* '(("Menge" :mng) - ("King James Version" :kjv) - ("Vulgata" :vul) - ("Greek Bible" :grb) - ("Elberfelder Übersetzung 1871" :elb1871) - ("NEÜ" :neue) - ("Luther 1545" :luth1545) - ("Luther 1912" :luth1912) - ("Schlachter 1951" :sch1951) - ("Ukrainische Version" :ukr))) +(defvar *translations* '(("Menge" :mng "mng") + ("King James Version" :kjv "kjv") + ("Vulgata" :vul "vul") + ("Greek Bible" :grb "grb") + ("Elberfelder Übersetzung 1871" :elb1871 "elb1871") + ("NEÜ" :neue "neue") + ("Luther 1545" :luth1545 "luth1545") + ("Luther 1912" :luth1912 "luth1912") + ("Schlachter 1951" :sch1951 "sch1951") + ("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,11 +129,11 @@ ("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)) - (v::translations old))) + (nconc (v:translations new) + (v::translations old))) (cl-bible.search:find-book bible (car map)) (cl-bible.search:find-book new (cdr map)))) mapping)) diff --git a/package.lisp b/package.lisp index e4ac912..7509850 100644 --- a/package.lisp +++ b/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) diff --git a/search.lisp b/search.lisp index 2540032..77fa1f6 100644 --- a/search.lisp +++ b/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))))) diff --git a/verse.lisp b/verse.lisp index 1d1dd51..8d762f5 100644 --- a/verse.lisp +++ b/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) - :bsname (nth 1 verse) - :chapter (nth 3 verse) - :number (nth 4 verse) - :text (nth 5 verse)))) + (make-instance 'verse :bname (first verse) + :bsname (second verse) + :chapter (fourth verse) + :number (fifth verse) + :text (sixth verse)))) -(defgeneric verse-to-string (verse &key separator translation)) -(defmethod verse-to-string (verse &key (separator " ") translation) +(defmethod verse-to-string ((verse cons) &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) - &key (separator "
") - (translation :mng)) - (format nil "~A ~A:~A~A ~A" (bsname verse) - (chapter verse) - (vnumber verse) - separator - (cdr (assoc translation (translations verse))))) +(defmethod verse-to-string ((verse verse) &key (separator "
") (translation :elb1871)) + (concatenate 'string + (when (string= (vnumber verse) "1") + (format nil "~A ~A~A" + (bname verse) + (chapter verse) + separator)) + (format nil "~A ~A" + (vnumber verse) + (if (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)) - (cdr (assoc cl-bible.data:*translation* - (translations verse)))) + (let ((translations (translations verse))) + (if translations + (cdr (assoc cl-bible.data:*translation* + translations)) + (text verse)))) -(defun %format-notes (notes) - (if notes - (format nil "~{~A~^
~}" notes) - "No notes found")) +(defmethod %format-notes ((notes cons)) + (format nil "~{~A~^
~}" notes)) -(defun %create-notes-window (verse parent) +(defmethod %format-notes ((notes (eql nil))) + "No notes found") + +(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:set-on-click display - (lambda (obj) - (declare (ignore obj)) - (show-notes verse parent))) - display)) + (clog:create-p parent :content (verse-to-string verse :translation translation))) + -(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) - :bsname (cadr sexp) - :chapter (caddr sexp) - :number (nth 3 sexp) - :translations (nth 4 sexp) - :notes (nth 6 sexp))) - -(defun from-sexp (bible) + :bname (first sexp) + :bsname (second sexp) + :chapter (fourth sexp) + :number (fifth sexp) + :text (sixth sexp) + :notes (seventh sexp))) + +(defmethod from-sexp ((bible cons)) (mapcar #'verse-from-sexp bible))