silasfox/cl-bible
1
0
Fork 0
Code Issues 3 Pull Requests Projects 1 Releases Wiki Activity

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

Browse Source
This commit is contained in:
Silas Vedder 2022-07-17 22:31:05 +02:00
parent 0dffd44f75
commit f9b3486f34
6 changed files with 259 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
chapter.lisp
View File

@ -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)))))
(let ((display (chapter-to-clog chapter div :translation d:*translation*)))
(translations-drop-down div display chapter drop-down))))
(defun load-chapter (canvas book chapter)
(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)))
(format nil "~A: ~A ~A"
d:*translation*
book
chapter)
(make-instance 'chapter :verses verses))))
(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)))
(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*
pos)
(make-instance 'chapter
:verses (s:find-verse d:*bible* (s:parse-position pos)))))

35
clog.lisp
View File

@ -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)

36
data.lisp
View File

@ -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))

7
package.lisp
View File

@ -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)

107
search.lisp
View File

@ -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)))))

102
verse.lisp
View File

@ -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 "<br/>")
(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 "<br/>") (translation :elb1871))
(concatenate 'string
(when (string= (vnumber verse) "1")
(format nil "<b>~A ~A</b>~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~^<br/>~}" notes)
"No notes found"))
(defmethod %format-notes ((notes cons))
(format nil "~{~A~^<br/>~}" 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)))
:bname (first sexp)
:bsname (second sexp)
:chapter (fourth sexp)
:number (fifth sexp)
:text (sixth sexp)
:notes (seventh sexp)))
(defun from-sexp (bible)
(defmethod from-sexp ((bible cons))
(mapcar #'verse-from-sexp bible))