From 48bb7cc7f022253f2329fdf07e4b7567654577f6 Mon Sep 17 00:00:00 2001 From: Silas Vedder Date: Fri, 14 Oct 2022 15:15:29 +0200 Subject: [PATCH] scripts split from implementation of counter and latex export --- bible-tools.scm | 59 ++++++++------ bible-tools/count-words.scm | 22 +++++ bible-tools/latex-export.scm | 23 ++++++ doc/bible-tools.texi | 6 +- guix.scm | 150 ++++++++++++++++------------------- scripts/bible-app.in | 14 ++++ scripts/bible2latex.in | 53 ++++--------- scripts/count-words.in | 61 ++++---------- scripts/word-counter.in | 38 +++++++++ 9 files changed, 237 insertions(+), 189 deletions(-) create mode 100644 bible-tools/count-words.scm create mode 100644 bible-tools/latex-export.scm create mode 100644 scripts/bible-app.in create mode 100644 scripts/word-counter.in diff --git a/bible-tools.scm b/bible-tools.scm index 89d46ea..dc59c05 100644 --- a/bible-tools.scm +++ b/bible-tools.scm @@ -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))))) diff --git a/bible-tools/count-words.scm b/bible-tools/count-words.scm new file mode 100644 index 0000000..768016f --- /dev/null +++ b/bible-tools/count-words.scm @@ -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 '() <>))) diff --git a/bible-tools/latex-export.scm b/bible-tools/latex-export.scm new file mode 100644 index 0000000..73640eb --- /dev/null +++ b/bible-tools/latex-export.scm @@ -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")) diff --git a/doc/bible-tools.texi b/doc/bible-tools.texi index 92edc2f..ec08db0 100644 --- a/doc/bible-tools.texi +++ b/doc/bible-tools.texi @@ -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 diff --git a/guix.scm b/guix.scm index 8c2dc3a..b324e81 100644 --- a/guix.scm +++ b/guix.scm @@ -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 "") diff --git a/scripts/bible-app.in b/scripts/bible-app.in new file mode 100644 index 0000000..bdcc487 --- /dev/null +++ b/scripts/bible-app.in @@ -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)) diff --git a/scripts/bible2latex.in b/scripts/bible2latex.in index 6d72f21..5fdd88c 100755 --- a/scripts/bible2latex.in +++ b/scripts/bible2latex.in @@ -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)))) diff --git a/scripts/count-words.in b/scripts/count-words.in index 8cb05a9..5ff7ef0 100755 --- a/scripts/count-words.in +++ b/scripts/count-words.in @@ -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))))) diff --git a/scripts/word-counter.in b/scripts/word-counter.in new file mode 100644 index 0000000..5ff7ef0 --- /dev/null +++ b/scripts/word-counter.in @@ -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)))))