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

scripts split from implementation of counter and latex export

Browse Source
This commit is contained in:
Silas Vedder 2022-10-14 15:15:29 +02:00
parent 89c529053b
commit 48bb7cc7f0
9 changed files with 237 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
bible-tools.scm
View File

@ -1,11 +1,13 @@
(define-module (bible-tools)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-98)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:export (mapcan
get-bible
string->bible
clean-strings
book
chapter
verse
@ -13,36 +15,47 @@
get-book
get-chapter
get-verse
with-bible))
let-bible
call-with-book
call-with-chapter
with-bible
with-book
with-chapter))
(define (mapcan f l) (apply append (map f l)))
(define (make-bible-path name)
(string-append (get-environment-variable "HOME") "/.bible/" name ".tsv"))
(define make-bible-path
(cut string-append (get-environment-variable "HOME")
"/.bible/" <> ".tsv"))
(define (get-bible name)
(call-with-input-file (make-bible-path name) (compose utf8->string get-bytevector-all)))
(call-with-input-file (make-bible-path name)
(compose utf8->string get-bytevector-all)))
(define (string->verse string)
(string-split string #\tab))
(define string->verse (cut string-split <> #\tab))
(define clean-strings
(cut filter (compose not (cut string=? <> "")) <>))
(define (string->bible string)
(map string->verse
(filter (lambda (str) (not (string=? str "")))
(string-split string #\newline))))
(define string->bible
(compose (cut map string->verse <>)
clean-strings
(cut string-split <> #\newline)))
(define book car)
(define chapter cadddr)
(define verse (compose cadddr cdr))
(define text (compose cadddr cddr))
(define book first)
(define chapter fourth)
(define verse fifth)
(define text sixth)
(define (get-num bible query part)
(filter (lambda (v) (= query (string->number (part v)))) bible))
(define (get-num query bible part)
(filter (compose (cut = query <>) string->number part) bible))
(define (get-book book-name bible)
(filter (lambda (v) (string=? book-name (book v))) bible))
(define (get-chapter chapter-number book)
(get-num book chapter-number chapter))
(define (get-verse verse-number chapter)
(get-num chapter verse-number verse))
(filter (compose (cut string=? book-name <>) book) bible))
(define get-chapter (cut get-num <> <> chapter))
(define get-verse (cut get-num <> <> verse))
(define (with-bible b f)
(when (procedure? f)
(f (string->bible (get-bible b)))))
(when (procedure? f) (f (string->bible (get-bible b)))))
(define (call-with-book book thunk)
(compose thunk (cut get-book book <>)))
(define (call-with-chapter book chapter thunk)
(lambda (bible) (thunk (get-chapter (string->number chapter)
(get-book book bible)))))

22
bible-tools/count-words.scm Normal file
View File

@ -0,0 +1,22 @@
(define-module (count-words)
#:use-module (bible-tools)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (count-words))
(define (split/stuff str)
(define (split-curry char) (cut string-split <> char))
(let ((splits (map split-curry '(#\, #\: #\. #\! #\? #\; #\< #\>))))
(clean-strings (fold mapcan (string-split str #\space) splits))))
(define (count verse result)
(fold (lambda (word res)
(let ((val (assoc word res)))
(acons word (1+ (if val (cdr val) 0)) res)))
result (split/stuff verse)))
(define (co f g) (lambda (v w) (f (g v) (g w))))
(define count-words
(compose (cut delete-duplicates <> (co equal? car))
(cut sort <> (co > cdr))
(cut fold count '() <>)))

23
bible-tools/latex-export.scm Normal file
View File

@ -0,0 +1,23 @@
(define-module (latex-export)
#:use-module (bible-tools)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (as-latex))
(define (verse-to-latex v)
(define (latex-first c sec b sec-end)
(if (string=? (c v) "1") (string-append sec (b v) sec-end) ""))
(let* ((book (latex-first chapter "\\section{" book "}\n"))
(chapter
(latex-first verse "\\textbf{\\large{" chapter "}}\n")))
(string-append chapter
"\\textsuperscript{" (verse v) "}" (text v))))
(define (as-latex text)
(string-append "\\documentclass{article}\n\n"
"\\usepackage{fullpage}\n\n"
"\\begin{document}\n\n"
(string-join
(map verse-to-latex text)
"\n\n")
"\n\\end{document}\n"))

6
doc/bible-tools.texi
View File

@ -10,7 +10,7 @@
@include version.texi
@copying
Copyright @copyright{} 2022
Copyright @copyright{} 2022
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
@ -22,12 +22,12 @@ Documentation License''.
@dircategory The Algorithmic Language Scheme
@direntry
* Bible-Tools: (bible-tools).
* Bible-Tools: (bible-tools).
@end direntry
@titlepage
@title The Bible-Tools Manual
@author
@author
@page
@vskip 0pt plus 1filll

150
guix.scm
View File

@ -1,90 +1,80 @@
(use-modules
(guix packages)
((guix licenses) #:prefix license:)
(guix download)
(guix git-download)
(guix build-system gnu)
(gnu packages)
(gnu packages autotools)
(gnu packages guile)
(gnu packages guile-xyz)
(gnu packages pkg-config)
(gnu packages texinfo))
(use-modules (guix packages)
((guix licenses)
#:prefix license:)
(guix download)
(guix git-download)
(guix build-system gnu)
(gnu packages)
(gnu packages autotools)
(gnu packages guile)
(gnu packages guile-xyz)
(gnu packages pkg-config)
(gnu packages texinfo))
(define-public bible-tools
(package
(name "bible-tools")
(version "1.0")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://git.silasvedder.xyz/silasfox/bible-tools.git")
(commit "2e7be5e")))
(file-name "bible-tools-1.0-checkout")
(sha256 (base32 "0l3ndyzy6sq1cdkaklhyg1mvy6hsil7b86wk3nbs5mqgrcypar1z"))))
(source (origin
(method git-fetch)
(uri (git-reference
(url
"https://git.silasvedder.xyz/silasfox/bible-tools.git")
(commit "89c5290")))
(file-name "bible-tools-1.0-checkout")
(sha256
(base32
"0rdpn3digjxmsxqxjilgrh5fsa7v72mnwm91083wngfimvvkm6i2"))))
(build-system gnu-build-system)
(arguments
`(#:modules
((ice-9 match)
(ice-9 ftw)
,@%gnu-build-system-modules)
#:phases
(modify-phases
%standard-phases
(add-after
'install
'hall-wrap-binaries
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((compiled-dir
(lambda (out version)
(string-append
out
"/lib/guile/"
version
"/site-ccache")))
(uncompiled-dir
(lambda (out version)
(string-append
out
"/share/guile/site"
(if (string-null? version) "" "/")
version)))
(dep-path
(lambda (env modules path)
(list env
":"
'prefix
(cons modules
(map (lambda (input)
(string-append
(assoc-ref inputs input)
path))
,''())))))
(out (assoc-ref outputs "out"))
(bin (string-append out "/bin/"))
(site (uncompiled-dir out "")))
(match (scandir site)
(("." ".." version)
(for-each
(lambda (file)
(wrap-program
(string-append bin file)
(dep-path
"GUILE_LOAD_PATH"
(uncompiled-dir out version)
(uncompiled-dir "" version))
(dep-path
"GUILE_LOAD_COMPILED_PATH"
(compiled-dir out version)
(compiled-dir "" version))))
,''("bible2latex" "count-words"))
#t))))))))
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
("pkg-config" ,pkg-config)
("texinfo" ,texinfo)))
`(#:modules ((ice-9 match)
(ice-9 ftw)
,@%gnu-build-system-modules)
#:phases (modify-phases %standard-phases
(add-after 'install 'hall-wrap-binaries
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((compiled-dir (lambda (out version)
(string-append out "/lib/guile/"
version
"/site-ccache")))
(uncompiled-dir (lambda (out version)
(string-append out
"/share/guile/site"
(if (string-null? version) ""
"/") version)))
(dep-path (lambda (env modules path)
(list env ":"
'prefix
(cons modules
(map (lambda (input)
(string-append (assoc-ref
inputs
input)
path))
,''())))))
(out (assoc-ref outputs "out"))
(bin (string-append out "/bin/"))
(site (uncompiled-dir out "")))
(match (scandir site)
(("." ".." version)
(for-each (lambda (file)
(wrap-program (string-append bin file)
(dep-path
"GUILE_LOAD_PATH"
(uncompiled-dir out
version)
(uncompiled-dir ""
version))
(dep-path
"GUILE_LOAD_COMPILED_PATH"
(compiled-dir out
version)
(compiled-dir "" version))))
,''("bible2latex" "count-words")) #t))))))))
(native-inputs `(("autoconf" ,autoconf)
("automake" ,automake)
("pkg-config" ,pkg-config)
("texinfo" ,texinfo)))
(inputs `(("guile" ,guile-3.0)))
(propagated-inputs `())
(synopsis "")

14
scripts/bible-app.in Normal file
View File

@ -0,0 +1,14 @@
#! /usr/bin/env sh
exec guile -e '(@ (bible-app) main)' -s "$0" "$@"
!#
(define-module (bible-app)
#:use-module (bible-tools)
#:use-module (latex-export)
#:use-module (count-words)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (main))
(define (main args)
(display args))

53
scripts/bible2latex.in
View File

@ -4,28 +4,12 @@ exec guile -e '(@ (bible2latex) main)' -s "$0" "$@"
(define-module (bible2latex)
#:use-module (bible-tools)
#:use-module (latex-export)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (main))
(define (verse-to-latex v)
(string-append (if (string=? (verse v) "1")
(string-append (if (string=? (chapter v) "1")
(string-append "\\section{" (book v) "}\n") "")
"\\textbf{\\large{" (chapter v) "}}\n")
"")
"\\textsuperscript{" (verse v) "}" (text v)))
(define (print-text text)
(let ((result (string-append "\\documentclass{article}\n\n"
"\\usepackage{fullpage}\n\n"
"\\begin{document}\n\n"
(string-join
(map verse-to-latex text)
"\n\n")
"\n\\end{document}")))
(display result)
(newline)))
(define print-text (compose display as-latex))
(define (help)
(display "Usage: bible2latex [-b book] [-c chapter] [-h] [-v]\n")
@ -37,26 +21,17 @@ exec guile -e '(@ (bible2latex) main)' -s "$0" "$@"
(define (version)
(display "bible2latex v1.0.0\n"))
(define (print-book book)
(lambda (bible)
(print-text (get-book book bible))))
(define (print-chapter book chapter)
(lambda (bible)
(print-text (get-chapter (string->number chapter)
(get-book book bible)))))
(define (main args)
(define (get-flag flag)
(cadr (member flag args)))
(define (flag? flag)
(member flag args))
(define flag? (cut member <> args))
(define get (compose cadr flag?))
(define-syntax conf
(syntax-rules (else)
((_ (f e)... (else g)) (cond ((flag? f) e)... (else g)))))
(with-bible "jantzen"
(cond ((flag? "-h") (help))
((flag? "-v") (version))
((flag? "-b") (if (flag? "-c")
(print-chapter (get-flag "-b")
(get-flag "-c"))
(print-book (get-flag "-b"))))
(conf ("-h" (help))
("-v" (version))
("-b" (if (flag? "-c")
(call-with-chapter (get "-b") (get "-c")
print-text)
(call-with-book (get "-b") print-text)))
(else print-text))))

61
scripts/count-words.in
View File

@ -2,42 +2,18 @@
exec guile -e '(@ (count-words) main)' -s "$0" "$@"
!#
(define-module (count-words)
(define-module (word-counter)
#:use-module (bible-tools)
#:use-module (count-words)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (main))
(define (split/stuff str)
(let ((words (string-split str #\space))
(fs (map (lambda (char)
(lambda (str) (string-split str char)))
'(#\, #\: #\. #\! #\? #\; #\< #\>))))
(filter (lambda (str) (not (string=? "" str)))
(fold (lambda (f val) (mapcan f val)) words fs))))
(define (count verse result)
(let ((words (split/stuff verse)))
(fold (lambda (word res)
(let ((val (assoc word res)))
(if val
(alist-cons word (+ (cdr val) 1) res)
(alist-cons word 1 res))))
result words)))
(define (count-words verses)
(delete-duplicates (sort (fold count '() verses)
(lambda (a b) (> (cdr a) (cdr b))))
(lambda (a b) (equal? (car a) (car b)))))
(define (show-meta txt)
(let ((count (count-words (map text txt))))
(for-each (lambda (word)
(display
(string-append (car word)
":\t"
(number->string (cdr word))
"\n")))
count)))
(define (tabs w) (if (< (string-length (car w)) 7) "\t\t" "\t"))
(define (to-str w) (string-append (car w) ":" (tabs w)
(number->string (cdr w)) "\n"))
(for-each (compose display to-str) (count-words (map text txt))))
(define (help)
(display "Usage: count-words [book] [-c chapter] [-h] [-v]\n")
@ -48,18 +24,15 @@ exec guile -e '(@ (count-words) main)' -s "$0" "$@"
(define (version)
(display "count-words v1.0.0\n"))
(define (show-book book)
(lambda (bible)
(show-meta (get-book book bible))))
(define (show-chapter book chapter)
(lambda (bible)
(show-meta (get-chapter chapter (get-book book bible)))))
(define (main args)
(define flag? (cut member <> args))
(define get (compose cadr flag?))
(define-syntax conf
(syntax-rules (else)
((_ (f e)... (else g)) (cond ((flag? f) e)... (else g)))))
(with-bible "jantzen"
(cond ((< (length args) 2) (help))
((member "-h" args) (help))
((member "-v" args) (version))
((member "-c" args) (show-chapter (cadr args) (string->number (cadr (member "-c" args)))))
(else (show-book (cadr args))))))
(conf ("-h" (help))
("-v" (version))
("-c"
(call-with-chapter (cadr args) (get "-c") show-meta))
(else (call-with-book (cadr args) show-meta)))))

38
scripts/word-counter.in Normal file
View File

@ -0,0 +1,38 @@
#! /usr/bin/env sh
exec guile -e '(@ (count-words) main)' -s "$0" "$@"
!#
(define-module (word-counter)
#:use-module (bible-tools)
#:use-module (count-words)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (main))
(define (show-meta txt)
(define (tabs w) (if (< (string-length (car w)) 7) "\t\t" "\t"))
(define (to-str w) (string-append (car w) ":" (tabs w)
(number->string (cdr w)) "\n"))
(for-each (compose display to-str) (count-words (map text txt))))
(define (help)
(display "Usage: count-words [book] [-c chapter] [-h] [-v]\n")
(display "\t-c chapter count the words in this chapter\n")
(display "\t-h display this help message\n")
(display "\t-v display the current version\n"))
(define (version)
(display "count-words v1.0.0\n"))
(define (main args)
(define flag? (cut member <> args))
(define get (compose cadr flag?))
(define-syntax conf
(syntax-rules (else)
((_ (f e)... (else g)) (cond ((flag? f) e)... (else g)))))
(with-bible "jantzen"
(conf ("-h" (help))
("-v" (version))
("-c"
(call-with-chapter (cadr args) (get "-c") show-meta))
(else (call-with-book (cadr args) show-meta)))))