From 56576a728c7e1dbb6f9ef04d46c46b78e96e41eb Mon Sep 17 00:00:00 2001 From: Silas Vedder Date: Thu, 11 Aug 2022 15:26:49 +0200 Subject: [PATCH] Update to new GUI, some changes behind the scenes. --- chapter.lisp | 69 +++++------------- clog.lisp | 185 +++++++++++++++-------------------------------- data.lisp | 118 +----------------------------- lift-search.lisp | 2 +- package.lisp | 8 +- search.lisp | 56 ++++++++------ verse.lisp | 34 ++------- 7 files changed, 124 insertions(+), 348 deletions(-) diff --git a/chapter.lisp b/chapter.lisp index 2df5a96..afe60b2 100644 --- a/chapter.lisp +++ b/chapter.lisp @@ -4,50 +4,30 @@ ((%verses :initarg :verses :reader verses))) -(defgeneric chapter-to-clog (chapter parent &key translation)) -(defgeneric book/chapter-window (canvas title)) +(defgeneric chapter-to-clog (chapter parent)) +(defgeneric book/chapter-window (canvas)) (defgeneric translations-drop-down (div display chapter drop-down)) -(defgeneric display-chapter-or-book (canvas title chapter)) +(defgeneric display-chapter-or-book (canvas chapter)) (defgeneric load-chapter (canvas book chapter)) -(defgeneric load-book (canvas book)) +(defgeneric load-position (canvas pos)) -(defmethod chapter-to-clog ((chapter chapter) (parent clog:clog-obj) &key (translation :mng)) +(defmethod chapter-to-clog ((chapter chapter) (parent clog:clog-obj)) (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))) - )) + (create-p parent + :content (concatenate 'string + (if (string= (v:vnumber verse) "1") + (format nil "~A ~A:
" + (v:bname verse) + (v:chapter verse)) + "") + (v:verse-to-string verse))))) (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 500))) - (mbar (create-gui-menu-bar win)) - (drop-down (create-gui-menu-drop-down mbar :content "Translations"))) - (values (create-div win) - drop-down))) +(defmethod book/chapter-window (canvas) + (create-div (create-web-content (create-web-main canvas)))) -(defmethod translations-drop-down ((div clog:clog-div) display (chapter chapter) drop-down) - (mapcar - (lambda (translation) - (labels ((callback (obj) - (declare (ignore obj)) - (d:update-bible (third translation)))) - (create-gui-menu-item drop-down - :content (first translation) - :on-click #'callback))) - d:*translations*)) - -(defmethod display-chapter-or-book (canvas (title string) (chapter chapter)) - (multiple-value-bind (div drop-down) - (book/chapter-window canvas title) - (let ((display (chapter-to-clog chapter div :translation d:*translation*))) - (translations-drop-down div display chapter drop-down)))) +(defmethod display-chapter-or-book (canvas (chapter chapter)) + (chapter-to-clog chapter (book/chapter-window canvas))) (defmethod load-chapter (canvas (book string) (chapter string)) (let* ((bk (s:find-book d:*bible* book)) @@ -56,24 +36,9 @@ :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) (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* - pos) (make-instance 'chapter :verses (s:find-verse d:*bible* (s:parse-position pos))))) diff --git a/clog.lisp b/clog.lisp index ab75d76..0a7d38b 100644 --- a/clog.lisp +++ b/clog.lisp @@ -5,9 +5,8 @@ (defvar *body*) (defun lift-search-window (body search) - (let ((result (mapcar #'car (l:lift-search search))) - (win (create-gui-window body))) - (create-p (window-content win) + (let ((result (mapcar #'car (l:lift-search search)))) + (create-p body :content (str:join ", " (if result result '("No results")))))) @@ -15,43 +14,22 @@ (defun ergebnis/se (n) (format nil "~A Ergebnis~A" n (if (= n 1) "" "se"))) -(defun test (canvas) - (create-gui-window canvas :title "Test" - :height 400 - :width 300)) - -(defun test (canvas) - (let* ((win (window-content - (create-gui-window canvas :title "Test" - :height 300 - :width 400))) - (button (create-button win :content "click me!")) - (div (create-div win))) - (create-p div :content "foo") - (set-on-click button (lambda (obj) - (declare (ignore obj)) - (format t "Clicked button!"))) - div)) - (defun search-in-bible (phrase bible canvas) - (let* ((win (window-content - (create-gui-window canvas - :title (format nil "~A: ~A" - d:*translation* - phrase) - :height 400 - :width 500))) - (lift-search (create-button win :content "Lift Search")) - (div (create-div win)) - (results (s:find-in-bible bible phrase))) - (set-on-click lift-search (lambda (obj) - (declare (ignore obj)) - (lift-search-window canvas results))) - (create-p div :content (ergebnis/se - (length results))) + (let ((content (create-web-content canvas)) + (results (s:find-in-bible bible phrase))) + (create-p content :content (format nil "~A" (ergebnis/se (length results)))) + (let ((lift-search (create-web-panel content))) + (set-on-click (create-button lift-search :content "Lift Search") + (lambda (obj) + (declare (ignore obj)) + (lift-search-window lift-search results)))) (mapc (lambda (verse) (clog:set-on-click - (v:verse-to-clog verse div :translation d:*translation*) + (create-p content + :content (format nil "~A ~A:
~A" + (v:bname verse) + (v:chapter verse) + (v:verse-to-string verse))) (lambda (obj) (declare (ignore obj)) (ch:load-chapter canvas @@ -59,108 +37,63 @@ (v:chapter verse))))) results))) -(defun %bible-book-or-chapter (bible book chapter) - (if (string= book "") - bible - (let ((book (s:find-book bible book))) - (if (string= chapter "") - book - (s:find-chapter book chapter))))) - -(defun search-with-chapter (window data) - (let ((book (cadr (assoc "book" data :test #'string=))) - (chapter (cadr (assoc "chapter" data :test #'string=))) - (phrase (cadr (assoc "phrase" data :test #'string=)))) - (search-in-bible phrase - (%bible-book-or-chapter d:*bible* book chapter) - window))) - -(defun searcher (window) - (lambda (obj) - (declare (ignore obj)) - (form-dialog window "What do you want to search?" - '(("Phrase" "phrase" :text) - ("Book" "book" :text) - ("Chapter" "chapter" :text)) - (lambda (data) - (search-with-chapter window data)) - :title "Search a phrase"))) - (defun reload (window) (lambda (obj) (declare (ignore obj)) - (form-dialog window "Which bible do you want?" - '(("Bible" "bible" :select (("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)))) - (lambda (results) - (d:update-bible (cadar results)) - :title "Load a Bible")))) + (let ((dialog (clog-web-form window "Which bible do you want?" + '(("Bible" "bible" :select (("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)))) + (lambda (results) + (d:update-bible (form-result results "bible"))))))))) (defun load-book-or-chapter (canvas) (lambda (data) (ch:load-position canvas (second (assoc "pos" data :test #'string=))))) -(defun get-chapter (window body) +(defun get-chapter (body) (lambda (obj) (declare (ignore obj)) - (form-dialog window "Which passage do you want?" + (clog-web-form body "Which passage do you want?" '(("" "pos" :text)) - (load-book-or-chapter body) - :title "Load a Passage"))) - -(defun setup-window (body) - (let ((window (create-gui-window body :title "background" - :hidden t))) - (window-normalize window) - (window-center window) - window)) - -(defun setup-menu-bar (body window) - (let* ((mbar (create-gui-menu-bar body)) - (drop-down (create-gui-menu-drop-down mbar - :content "Options"))) - (create-gui-menu-full-screen mbar) - (create-gui-menu-item drop-down - :content "Search" - :on-click (searcher window)) - (create-gui-menu-item drop-down - :content "Get Chapter" - :on-click (get-chapter window body)) - (create-gui-menu-item drop-down - :content "Load Bible" - :on-click (reload window)) - (create-gui-menu-item mbar - :content "Close all windows" - :on-click (lambda (obj) - (declare (ignore obj)) - (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) - (declare (ignore obj)) - (d:persist))) - (create-gui-menu-item mbar - :content "Load notes" - :on-click (lambda (obj) - (declare (ignore obj)) - (d:load-bibles))))) + (load-book-or-chapter body)))) + +(defun setup-menu-bar (body) + (let* ((form-space (create-web-content body)) + (form2 (create-form form-space)) + (bible (create-select form2 :label (create-label form2 :content "Choose your translation: "))) + (_ (create-br form-space)) + (form1 (create-form form-space)) + (passage (create-form-element form1 :search :class "w3-input w3-border")) + (__ (create-br form-space)) + (form3 (create-form form-space)) + (search (create-form-element form3 :search :class "w3-input w3-border"))) + (declare (ignore _ __)) + (add-select-options bible '("elb1871" "mng" "neue" "luth1545" "luth1912" "sch1951" "kjv" "vul" "grb" "ukr")) + (set-on-change bible (lambda (obj) + (declare (ignore obj)) + (d:update-bible (value bible)))) + (create-form-element form1 :submit :value "Get passage") + (set-on-submit form1 + (lambda (obj) + (declare (ignore obj)) + (ch:load-position body (value passage)))) + (create-form-element form3 :submit :value "Search phrase") + (set-on-submit form3 + (lambda (obj) + (declare (ignore obj)) + (search-in-bible (value search) d:*bible* body))))) (defun on-new-window (body) (setf *body* body) (setf (title (html-document body)) "Bible") - (clog-gui-initialize body) - (setup-menu-bar body (setup-window body))) + (clog-web-initialize body) + (setup-menu-bar body)) diff --git a/data.lisp b/data.lisp index d4aee1f..555a010 100644 --- a/data.lisp +++ b/data.lisp @@ -18,122 +18,8 @@ (uiop:read-file-lines (uiop:native-namestring (concatenate 'string "~/.bible/" filename ".tsv"))))) -(defun load-bible (filename) - (v:from-sexp - (read-from-string - (uiop:read-file-string (uiop:native-namestring filename))))) - -(defvar *translation* :mng) -(defvar *bible* nil) - -(defun load-bibles () - (ensure-directories-exist (uiop:native-namestring "~/.bible/")) - (if (uiop:file-exists-p (uiop:native-namestring "~/.bible/bible.sexp")) - (setf *bible* (load-bible "~/.bible/bible.sexp")) - (setf *bible* - (load-bible - (asdf:system-relative-pathname :cl-bible - "resources/bible.sexp"))))) - -(load-bibles) +(defvar *translation* :vul) +(defvar *bible* (read-bible-from-tsv "vul")) (defun update-bible (translation) - (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")) - :direction :output - :if-exists :overwrite - :if-does-not-exist :create) - (print (v:to-sexp bible) file))) - -(defun persist (&optional (filepath "~/.bible/")) - (ensure-directories-exist (uiop:native-namestring filepath)) - (persist-bible *bible* "bible" filepath)) - -(defvar mapping '(("Genesis" . "Genesis") - ("Exodus" . "Exodus") - ("Levitikus" . "Levitikus") - ("Numeri" . "Numeri") - ("Deuteronomium" . "Deuteronomium") - ("Josua" . "Josua") - ("Richter" . "Richter") - ("Rut" . "Ruth") - ("1 Samuel" . "1 Samuel") - ("2 Samuel" . "2 Samuel") - ("1 Könige" . "1 Könige") - ("2 Könige" . "2 Könige") - ("1 Chronik" . "1 Chronika") - ("2 Chronik" . "2 Chronika") - ("Esra" . "Esra") - ("Nehemia" . "Nehemia") - ("Ester" . "Esther") - ("Ijob" . "Hiob") - ("Psalmen" . "Psalmen") - ("Sprüche" . "Sprüche") - ("Kohelet" . "Kohelet") - ("Hohelied" . "Hohelied") - ("Jesaja" . "Jesaja") - ("Jeremia" . "Jeremia") - ("Klagelieder" . "Klagelieder") - ("Ezechiel" . "Hesekiel") - ("Daniel" . "Daniel") - ("Hosea" . "Hosea") - ("Joël" . "Joel") - ("Amos" . "Amos") - ("Obadja" . "Obadja") - ("Jona" . "Jona") - ("Micha" . "Micha") - ("Nahum" . "Nahum") - ("Habakuk" . "Habakuk") - ("Zephanja" . "Zephania") - ("Haggai" . "Haggai") - ("Sacharja" . "Sacharia") - ("Maleachi" . "Maleachi") - ("Matthäus" . "Matthäus") - ("Markus" . "Markus") - ("Lukas" . "Lukas") - ("Johannes" . "Johannes") - ("Apostelgeschichte" . "Apostelgeschichte") - ("Römer" . "Römer") - ("1 Korinther" . "1 Korinther") - ("2 Korinther" . "2 Korinther") - ("Galater" . "Galater") - ("Epheser" . "Epheser") - ("Philipper" . "Philipper") - ("Kolosser" . "Kolosser") - ("1 Thessalonicher" . "1 Thessalonicher") - ("2 Thessalonicher" . "2 Thessalonicher") - ("1 Timotheus" . "1 Timotheus") - ("2 Timotheus" . "2 Timotheus") - ("Titus" . "Titus") - ("Philemon" . "Philemon") - ("Hebräer" . "Hebräer") - ("Jakobus" . "Jakobus") - ("1 Petrus" . "1 Petrus") - ("2 Petrus" . "2 Petrus") - ("1 Johannes" . "1 Johannes") - ("2 Johannes" . "2 Johannes") - ("3 Johannes" . "3 Johannes") - ("Judas" . "Judas") - ("Offenbarung" . "Offenbarung") - ("Judit" . "Judit") - ("Weisheit" . "Weisheit") - ("Tobit" . "Tobit") - ("Sirach" . "Sirach") - ("Baruch" . "Baruch") - ("1 Makkabäer" . "1 Makkabäer") - ("2 Makkabäer" . "2 Makkabäer") - ("xDaniel" . "xDaniel") - ("Manasse" . "Manasse") - ("xEster" . "xEster"))) - -(defun add-bible (bible new mapping) - (mapc (lambda (map) - (mapc (lambda (old new) - (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/lift-search.lisp b/lift-search.lisp index 274d090..4ffecf6 100644 --- a/lift-search.lisp +++ b/lift-search.lisp @@ -20,7 +20,7 @@ (funcall f1 (apply f2 args)))) (defun lift-search (search-result) - (comb (diff-verses (mapcar (compose #'normalize-string #'v:get-text) + (comb (diff-verses (mapcar (compose #'normalize-string #'v:text) search-result)) (length search-result))) diff --git a/package.lisp b/package.lisp index 7509850..05ca63d 100644 --- a/package.lisp +++ b/package.lisp @@ -1,8 +1,8 @@ -;;;; package.lisp +;;; package.lisp (defpackage #:cl-bible.verse (:use #:cl) - (:export verse-to-clog + (:export verse-to-string string-to-verse to-sexp from-sexp @@ -43,7 +43,7 @@ (:export lift-search)) (defpackage #:cl-bible.chapter - (:use #:cl #:clog #:clog-gui) + (:use #:cl #:clog #:clog-gui #:clog-web) (:local-nicknames (#:d #:cl-bible.data) (#:s #:cl-bible.search) (#:v #:cl-bible.verse)) @@ -52,7 +52,7 @@ load-position)) (defpackage #:cl-bible.clog - (:use #:cl #:clog #:clog-gui) + (:use #:cl #:clog #:clog-gui #:clog-web) (:local-nicknames (#:l #:cl-bible.lift-search) (#:d #:cl-bible.data) (#:s #:cl-bible.search) diff --git a/search.lisp b/search.lisp index 77fa1f6..2f374c9 100644 --- a/search.lisp +++ b/search.lisp @@ -3,7 +3,7 @@ (in-package #:cl-bible.search) (defun find-in-bible (bible phrase) - (remove-if-not (lambda (verse) (search phrase (v:get-text verse))) + (remove-if-not (lambda (verse) (search phrase (v:text verse))) bible)) (defmethod find-book (bible book) @@ -15,7 +15,7 @@ (defmethod find-verse (chapter verse) (remove-if-not (lambda (v) (string= verse (v:vnumber v))) chapter)) -(defclass position () +(defclass pos () ((book :initarg :book :reader book) (start :initarg :start @@ -32,19 +32,33 @@ :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))) +(defmethod parse-position :around ((position string)) + (cond ((string= position "") nil) + ((find #\space position) (call-next-method)) + (t (make-instance 'pos :book position)))) + +(defmethod parse-position ((position string)) + (let* ((first-split (uiop:split-string position :separator '(#\space))) + (split (if (ignore-errors (parse-integer (first first-split))) + (cons (format nil "~A ~A" (first first-split) + (second first-split)) + (cddr first-split)) + first-split))) + (if (cdr split) + (parse-position split) + (make-instance 'pos :book (first split))))) + +(defmethod parse-position ((position cons)) + (destructuring-bind (book rest) + position + (if (find #\- rest) + (destructuring-bind (start end) + (uiop:split-string rest :separator '(#\-)) + (make-instance 'pos :book book + :start (parse-verse-pos start) + :end (parse-verse-pos end))) + (make-instance 'pos :book book + :start (parse-verse-pos rest))))) (defun parse-verse-pos (verse-pos) (if (find #\, verse-pos) @@ -54,16 +68,16 @@ :verse (parse-integer verse))) (make-instance 'verse-pos :chapter (parse-integer verse-pos)))) -(defmethod bookp ((pos position)) +(defmethod bookp ((pos pos)) (if (start pos) nil t)) -(defmethod rangep ((pos position)) +(defmethod rangep ((pos pos)) (if (end pos) t nil)) (defmethod versep ((pos verse-pos)) (if (verse pos) t nil)) -(defmethod versep ((pos position)) +(defmethod versep ((pos pos)) (versep (start pos))) (defun find-position (bible position) @@ -86,10 +100,10 @@ the requested verse/s" (find-verse chapter (format nil "~A" (verse start)))) chapter))))) -(defmethod find-book (bible (pos position)) +(defmethod find-book (bible (pos pos)) (find-book bible (book pos))) -(defmethod find-chapter (bible (pos position)) +(defmethod find-chapter (bible (pos pos)) (let ((book (find-book bible pos))) (if (bookp pos) book @@ -101,7 +115,7 @@ the requested verse/s" :append (find-chapter book (format nil "~A" chapter))) (find-chapter book (format nil "~A" (chapter start)))))))) -(defmethod find-verse (bible (pos position)) +(defmethod find-verse (bible (pos pos)) (let ((chapter (find-chapter bible pos))) (if (bookp pos) chapter diff --git a/verse.lisp b/verse.lisp index 8d762f5..2f83dd7 100644 --- a/verse.lisp +++ b/verse.lisp @@ -21,14 +21,13 @@ :accessor notes))) (defgeneric string-to-verse (string)) -(defgeneric verse-to-string (verse &key separator translation)) +(defgeneric verse-to-string (verse)) (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)) @@ -44,26 +43,16 @@ :number (fifth verse) :text (sixth verse)))) -(defmethod verse-to-string ((verse cons) &key (separator " ") translation) - (declare (ignore translation)) +(defmethod verse-to-string ((verse cons)) (format nil "~A ~A:~A~A~A" (cadr verse) (nth 3 verse) (nth 4 verse) - separator (nth 5 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))))) +(defmethod verse-to-string ((verse verse)) + (format nil "~A ~A" + (vnumber verse) + (text verse))) (defmethod verse-to-latex ((verse verse) &key translation (port t)) (declare (ignore translation)) @@ -75,13 +64,6 @@ (translations verse))) '(:mng :luth1545 :luth1912 :sch1951 :elb1871 :neue)))) -(defmethod get-text ((verse verse)) - (let ((translations (translations verse))) - (if translations - (cdr (assoc cl-bible.data:*translation* - translations)) - (text verse)))) - (defmethod %format-notes ((notes cons)) (format nil "~{~A~^
~}" notes)) @@ -124,10 +106,6 @@ (declare (ignore obj)) (push (clog:value text) (notes verse)))))) -(defmethod verse-to-clog ((verse verse) (parent clog:clog-obj) &key (translation :mng)) - (clog:create-p parent :content (verse-to-string verse :translation translation))) - - (defmethod to-sexp ((verse verse)) (list (bname verse) (bsname verse)