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

Lot of changes

master
Silas Vedder 3 years ago
parent
c9f5ae2b9c
commit
26fca1d1e3
6 changed files with 113 additions and 71 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 6
      README.md
  2. BIN
      bible
  3. 74
      clog.lisp
  4. 27
      lift-search.lisp
  5. 3
      search.lisp
  6. 72
      verse.lisp

6
README.md
Unescape View File

@ -9,10 +9,8 @@ Then do
$ git clone https://github.com/silasfox/cl-bible.git ~/quicklisp/local-projects $ git clone https://github.com/silasfox/cl-bible.git ~/quicklisp/local-projects
$ mkdir -p ~/.bible $ mkdir -p ~/.bible
$ cp ~/quicklisp/local-projects/cl-bible/resources/*.sexp ~/.bible/ $ cp ~/quicklisp/local-projects/cl-bible/resources/*.sexp ~/.bible/
$ sbcl $ make
* (ql:quickload :cl-bible) $ sudo make install
* (in-package :cl-bible-user)
* (start)
``` ```
## bibles ## bibles

BIN
bible
View File

Binary file not shown.

74
clog.lisp
Unescape View File

@ -3,28 +3,30 @@
(in-package #:cl-bible.clog) (in-package #:cl-bible.clog)
(defun lift-search-window (body search) (defun lift-search-window (body search)
(lambda (obj) (let ((result (mapcar #'car (l:lift-search search)))
(declare (ignore obj)) (win (create-gui-window body)))
(let ((result (mapcar #'car (l:lift-search search))) (create-p (window-content win)
(win (create-gui-window body))) :content (str:join ", " (if result
(create-p (window-content win) result
:content (str:join ", " result))))) '("No results"))))))
(defun ergebnis/se (n) (defun ergebnis/se (n)
(format nil "~A Ergebnis~A" n (if (= n 1) "" "se"))) (format nil "~A Ergebnis~A" n (if (= n 1) "" "se")))
(defun search-in-bible (phrase bible canvas) (defun search-in-bible (phrase bible canvas)
(let* ((win (window-content (let* ((win (window-content
(create-gui-window canvas :title (create-gui-window canvas
(format nil "~A: ~A" :title (format nil "~A: ~A"
d:*translation* d:*translation*
phrase) phrase)
:height 400 :height 400
:width 650))) :width 650)))
(lift-search (create-button win :content "Lift Search")) (lift-search (create-button win :content "Lift Search"))
(div (create-div win)) (div (create-div win))
(results (s:find-in-bible bible phrase))) (results (s:find-in-bible bible phrase)))
(set-on-click lift-search (lift-search-window canvas results)) (set-on-click lift-search (lambda (obj)
(declare (ignore obj))
(lift-search-window canvas results)))
(create-p div :content (ergebnis/se (create-p div :content (ergebnis/se
(length results))) (length results)))
(mapc (lambda (verse) (mapc (lambda (verse)
@ -39,14 +41,13 @@
book book
(s:find-chapter book chapter))))) (s:find-chapter book chapter)))))
(defun search-with-chapter (window) (defun search-with-chapter (window data)
(lambda (data) (let ((book (cadr (assoc "book" data :test #'string=)))
(let ((book (cadr (assoc "book" data :test #'string=))) (chapter (cadr (assoc "chapter" data :test #'string=)))
(chapter (cadr (assoc "chapter" data :test #'string=))) (phrase (cadr (assoc "phrase" data :test #'string=))))
(phrase (cadr (assoc "phrase" data :test #'string=)))) (search-in-bible phrase
(search-in-bible phrase (%bible-book-or-chapter d:*bible* book chapter)
(%bible-book-or-chapter d:*bible* book chapter) window)))
window))))
(defun searcher (window) (defun searcher (window)
(lambda (obj) (lambda (obj)
@ -55,7 +56,8 @@
'(("Phrase" "phrase" :text) '(("Phrase" "phrase" :text)
("Book" "book" :text) ("Book" "book" :text)
("Chapter" "chapter" :text)) ("Chapter" "chapter" :text))
(search-with-chapter window) (lambda (data)
(search-with-chapter window data))
:title "Search a phrase"))) :title "Search a phrase")))
(defun reload (window) (defun reload (window)
@ -84,28 +86,29 @@
(load-book canvas book) (load-book canvas book)
(load-chapter canvas book chapter))))) (load-chapter canvas book chapter)))))
(defun book/chapter-window (canvas title)
(create-div
(window-content
(create-gui-window canvas
:title title
:height 400
:width 650))))
(defun load-book (canvas book) (defun load-book (canvas book)
(let* ((win (window-content (let ((div (book/chapter-window canvas
(create-gui-window canvas :title (format nil "~A: ~A" (format nil "~A: ~A"
d:*translation* d:*translation*
book) book))))
:height 400
:width 650)))
(div (create-div win)))
(mapc (lambda (verse) (mapc (lambda (verse)
(v:verse-to-clog verse div :translation d:*translation*)) (v:verse-to-clog verse div :translation d:*translation*))
(s:find-book d:*bible* book)))) (s:find-book d:*bible* book))))
(defun load-chapter (canvas book chapter) (defun load-chapter (canvas book chapter)
(let* ((win (window-content (let ((div (book/chapter-window canvas
(create-gui-window canvas :title (format nil "~A: ~A ~A" (format nil "~A: ~A ~A"
d:*translation* d:*translation*
book book
chapter) chapter))))
:height 400
:width 650)))
(div (create-div win)))
(mapc (lambda (verse) (mapc (lambda (verse)
(v:verse-to-clog verse div :translation d:*translation*)) (v:verse-to-clog verse div :translation d:*translation*))
(s:find-chapter (s:find-book d:*bible* book) chapter)))) (s:find-chapter (s:find-book d:*bible* book) chapter))))
@ -158,7 +161,6 @@
(declare (ignore obj)) (declare (ignore obj))
(d:load-bibles))))) (d:load-bibles)))))
(defun on-new-window (body) (defun on-new-window (body)
(setf (title (html-document body)) "Bible") (setf (title (html-document body)) "Bible")
(clog-gui-initialize body) (clog-gui-initialize body)

27
lift-search.lisp
Unescape View File

@ -2,10 +2,26 @@
(in-package #:cl-bible.lift-search) (in-package #:cl-bible.lift-search)
(defun frequent-words () (str:words "der die das dir mir wir ihr sie sein mein dein euer unser dem den in zu und")) (defun frequent-words ()
(str:words "der die das dir mir wir ihr sie sein mein dein euer unser dem den in zu und"))
(defparameter *punctuation*
'(#\; #\: #\' #\" #\. #\, #\« #\» #\( #\) #\[ #\] #\{ #\} #\! #\? #\-))
(defun normalize-string (str)
(map 'string (lambda (char)
(if (member char *punctuation*)
#\space
char))
str))
(defun compose (f1 f2)
(lambda (&rest args)
(funcall f1 (apply f2 args))))
(defun lift-search (search-result) (defun lift-search (search-result)
(comb (diff-verses (mapcar #'v:get-text search-result)) (comb (diff-verses (mapcar (compose #'normalize-string #'v:get-text)
search-result))
(length search-result))) (length search-result)))
(defun count-words (words) (defun count-words (words)
@ -19,9 +35,10 @@
(> (cdr x) (cdr y)))))) (> (cdr x) (cdr y))))))
(defun diff-verses (verses) (defun diff-verses (verses)
(count-words (remove-if (lambda (word) (member word (count-words (remove-if (lambda (word)
(frequent-words) (member word
:test #'string=)) (frequent-words)
:test #'string=))
(mapcan #'str:words verses)))) (mapcan #'str:words verses))))
(defun comb (freqs length) (defun comb (freqs length)

3
search.lisp
Unescape View File

@ -3,8 +3,7 @@
(in-package #:cl-bible.search) (in-package #:cl-bible.search)
(defun find-in-bible (bible phrase) (defun find-in-bible (bible phrase)
(remove-if-not (lambda (verse) (search phrase (remove-if-not (lambda (verse) (search phrase (v:get-text verse)))
(v:get-text verse)))
bible)) bible))
(defun find-book (bible book) (defun find-book (bible book)

72
verse.lisp
Unescape View File

@ -49,35 +49,61 @@
separator separator
(cdr (assoc translation (translations verse))))) (cdr (assoc translation (translations 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~%~} \\\\~%"
(bname verse)
(chapter verse)
(vnumber verse)
(mapcar (lambda (trans) (assoc trans
(translations verse)))
'(:mng :luth1545 :luth1912 :sch1951 :elb1871 :neue))))
(defgeneric get-text (verse)) (defgeneric get-text (verse))
(defmethod get-text ((verse verse)) (defmethod get-text ((verse verse))
(cdr (assoc cl-bible.data:*translation* (translations verse)))) (cdr (assoc cl-bible.data:*translation*
(translations verse))))
(defun %format-notes (notes)
(if notes
(format nil "~{~A~^<br/>~}" notes)
"No notes found"))
(defun %create-notes-window (verse parent)
(let ((win (clog-gui:window-content
(clog-gui:create-gui-window parent
:title "Notes"
:content (%format-notes
(notes verse))))))
(clog:create-br win)
(clog:create-button win
:content "Add notes")))
(defgeneric show-notes (verse parent))
(defmethod show-notes ((verse verse) (parent clog:clog-obj)) (defmethod show-notes ((verse verse) (parent clog:clog-obj))
(let* ((win (clog-gui:create-gui-window parent (let ((button (%create-notes-window verse parent)))
:title "Notes"
:content (let ((notes (notes verse)))
(if notes
(format nil "~{~A~^<br/>~}" notes)
"No notes found"))))
(_ (clog:create-br (clog-gui:window-content win)))
(button (clog:create-button (clog-gui:window-content win)
:content "Add notes")))
(declare (ignore _))
(clog:set-on-click button (clog:set-on-click button
(lambda (obj) (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
(add-notes verse parent))))) (add-notes verse parent)))))
(defun %create-add-notes-window (parent)
(let* ((form (clog:create-form
(clog-gui:window-content
(clog-gui:create-gui-window parent
:title "Add note"))))
(text (clog:create-text-area form :rows 4
:columns 40)))
(clog:create-br form)
(values text
(clog:create-button form :content "submit"))))
(defgeneric add-notes (verse parent))
(defmethod add-notes ((verse verse) (parent clog:clog-obj)) (defmethod add-notes ((verse verse) (parent clog:clog-obj))
(let* ((win (clog-gui:window-content (multiple-value-bind (text button)
(clog-gui:create-gui-window parent (%create-add-notes-window parent)
:title "Add note")))
(form (clog:create-form win))
(text (clog:create-text-area form :rows 4))
(_ (clog:create-br form))
(button (clog:create-button form :content "submit")))
(declare (ignore _))
(clog:set-on-click button (clog:set-on-click button
(lambda (obj) (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
@ -85,9 +111,10 @@
(defgeneric verse-to-clog (verse parent &key translation)) (defgeneric verse-to-clog (verse parent &key translation))
(defmethod verse-to-clog ((verse verse) (parent clog:clog-obj) &key (translation :mng)) (defmethod verse-to-clog ((verse verse) (parent clog:clog-obj) &key (translation :mng))
(let* ((verse-string (verse-to-string verse :translation translation)) (let ((display
(display (clog:create-p parent (clog:create-p parent
:content verse-string))) :content (verse-to-string verse
:translation translation))))
(clog:set-on-click display (clog:set-on-click display
(lambda (obj) (lambda (obj)
(declare (ignore obj)) (declare (ignore obj))
@ -116,4 +143,3 @@
(defun from-sexp (bible) (defun from-sexp (bible)
(mapcar #'verse-from-sexp bible)) (mapcar #'verse-from-sexp bible))

Write Preview
Loading…
Cancel
Save