nani/website

Julien LepillerMon Jul 19 23:26:26+0200 2021

8a51332

Rework dictionary generation

Makefile

 # keep po files, even if they are sometimes generated, and keep downloaded dictionaries around
 .PRECIOUS: po/%.po dictionaries/%
 all: site
 # To be filled by included files
 # DICOS is the list of generated dictionaries
 # DOWNLOADS is the list of downloaded files
 DICOS=
 DOWNLOADS=
 include radicals.mk
 include wadoku.mk
 include jmdict.mk
 include jibiki.mk
 # Files that constitute the website
 PAGES=blog.scm data.scm documentation.scm e404.scm feeds.scm index.scm mentions.scm
 HAUNT_FILES= haunt.scm $(addprefix pages/, $(PAGES)) \
         tools/i18n.scm tools/theme.scm
 SHA_DICOS=$(addsuffix .sha256, $(DICOS))
 WEB_FILES= $(HAUNT_FILES) \
         $(shell find css) $(shell find images) $(DICOS) $(addsuffix .sha256, $(DICOS)) \
 		   $(shell find css) $(shell find images) $(DICOS) $(SHA_DICOS) \
         dicos/list
 # Guile modules used to build dictionaries
 DICO_MODULES=modules/nani/trie.scm modules/nani/result.scm modules/nani/jmdict/trie.scm \
         modules/nani/jmdict/serialize.scm modules/nani/jmdict/xml.scm \
         modules/nani/jmdict/entities.scm modules/nani/frequency.scm \
         modules/nani/serialize.scm
 # Available languages
 LANGS=fr uk
 MOFILES=$(addprefix po/, $(addsuffix /LC_MESSAGES/nani.mo, $(LANGS)))
 dicos: $(DICOS) $(SHA_DICOS) dicos/list
 site: $(MOFILES) $(WEB_FILES)
 	haunt build
 	rm -rf public.bak

jibiki.mk unknown status 1

 DICOS+=dicos/jibiki_fre.nani
 DOWNLOADS+=dictionaries/jibiki.xml
 dictionaries/jibiki.xml:
 	wget https://jibiki.fr/data/Jibiki.fr/jibiki.fr_jpn_fra.xml.gz -O $@.gz
 	gunzip $@.gz
 dicos/jibiki_fre.nani: dictionaries/jibiki.xml tools/jibiki.scm dictionaries/frequency.tsv $(DICO_MODULES)
 	guile -L modules tools/jibiki.scm build $< $@

jmdict.mk

 dicos/JMdict_%.nani: dictionaries/JMdict.xml tools/jmdict.scm dictionaries/frequency.tsv $(DICO_MODULES)
 	guile -L modules tools/jmdict.scm build \
         $< $(shell echo $@ | sed 's|^.*_\([^.]*\)\..*$$|\1|g') $@
         $< $(shell basename $@ .nani | sed 's|^JMdict_||g') $@
 dicos/JMdict_e.nani: dictionaries/JMdict_e.xml tools/jmdict.scm dictionaries/frequency.tsv $(DICO_MODULES)
 	guile -L modules tools/jmdict.scm build $< e $@

modules/nani/encoding/huffman.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani encoding huffman)
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:export (create-huffman
             huffman->code
             huffman-encode
             huffman-decode
             serialize-huffman
             serialize-huffman-string huffman-string-size))
 (define (add-occurence occ char)
   (let* ((o (assoc-ref occ char))
          (o (+ (if o o 0) 1)))
     (assoc-set! occ char o)))
 (define (add-occurences occ str)
   (let loop ((lst (append (string->list str) (list #\nul))) (occ occ))
     (if (null? lst)
       occ
       (loop (cdr lst) (add-occurence occ (car lst))))))
 (define (get-occurences string-list)
   (let loop ((lst string-list) (occ '()))
     (if (null? lst)
       occ
       (loop (cdr lst) (add-occurences occ (car lst))))))
 (define (order tree)
   (if (null? tree)
     tree
     (add-in-order (car tree) (order (cdr tree)))))
 (define (add-in-order elem tree)
   (if (null? tree)
     (list elem)
     (let ((elem-pos (cdr elem))
           (tree-pos (cdr (car tree))))
       (if (> elem-pos tree-pos)
         (cons (car tree) (add-in-order elem (cdr tree)))
         (cons elem tree)))))
 (define (create-huffman string-list)
   (let ((total (apply + (map string-length string-list)))
         (occurences (get-occurences string-list)))
     (let loop ((tree (order occurences)))
       (if (equal? (length tree) 1)
         tree
         (let* ((e1 (car tree))
                (tree (cdr tree))
                (e2 (car tree))
                (tree (cdr tree)))
           (loop (add-in-order (cons (list e1 e2) (+ (cdr e1) (cdr e2))) tree)))))))
 (define (huffman->code huffman)
   (match huffman
     ('() '())
     ((((h1 h2) . weight))
      (append
        (map (lambda (e) (cons (car e) (cons 0 (cdr e)))) (huffman->code h1))
        (map (lambda (e) (cons (car e) (cons 1 (cdr e)))) (huffman->code h2))))
     (((h1 h2) . weight)
      (append
        (map (lambda (e) (cons (car e) (cons 0 (cdr e)))) (huffman->code h1))
        (map (lambda (e) (cons (car e) (cons 1 (cdr e)))) (huffman->code h2))))
     ((((? char? char) . weight))
      (list (cons char '())))
     (((? char? char) . weight)
      (list (cons char '())))))
 (define (bits->bytes b)
   (match b
    ('() '())
    ((a b c d e f g h bs ...)
     (cons (+ h (* 2 g) (* 4 f) (* 8 e) (* 16 d) (* 32 c) (* 64 b) (* 128 a))
       (bits->bytes bs)))
    (_ (bits->bytes (append b (make-list (- 8 (length b)) 0))))))
 (define (huffman-encode code str)
   (u8-list->bytevector
     (bits->bytes
       (apply append (map (lambda (c) (or (assoc-ref code c) (throw "not in huffman code" c)))
                          (append (string->list str) (list #\nul)))))))
 (define (byte->bits b)
   (let loop ((i 2) (b b) (by '()))
     (if (eq? i 512)
       by
       (loop (* i 2) (- b (modulo b i)) (cons (if (eq? (modulo b i) 0) 0 1) by)))))
 (define (huffman-decode huffman bv)
   (let ((seq (apply append (map byte->bits (bytevector->u8-list bv)))))
     (list->string
       (reverse
         (let loop ((seq seq) (result '()) (huff huffman))
           (if (null? seq)
             result
             (match huff
               ((((h1 h2) . weight))
                (if (= (car seq) 0)
                  (loop (cdr seq) result h1)
                  (loop (cdr seq) result h2)))
               (((h1 h2) . weight)
                (if (= (car seq) 0)
                  (loop (cdr seq) result h1)
                  (loop (cdr seq) result h2)))
               ((((? char? char) . weight))
                (if (equal? char #\nul)
                  result
                  (loop seq (cons char result) huffman)))
               (((? char? char) . weight)
                (if (equal? char #\nul)
                  result
                  (loop seq (cons char result) huffman))))))))))
 (define (serialize-huffman huffman)
   (define (serialize huffman)
     (match huffman
       ((((h1 h2) . weight))
        (append '(1) (serialize h1) (serialize h2)))
       (((h1 h2) . weight)
        (append '(1) (serialize h1) (serialize h2)))
       ((((? char? char) . weight))
        (append (bytevector->u8-list (string->utf8 (list->string (list char)))) '(0)))
       (((? char? char) . weight)
        (append (bytevector->u8-list (string->utf8 (list->string (list char)))) '(0)))))
   (u8-list->bytevector (serialize huffman)))
 (define (serialize-huffman-string huffman-code)
   (lambda (str pos bv)
     (let ((sbv (huffman-encode huffman-code str)))
       (bytevector-copy! sbv 0 bv pos (bytevector-length sbv))
       (+ pos (bytevector-length sbv)))))
 (define (huffman-string-size huffman-code)
   (lambda (str)
     (let ((sbv (huffman-encode huffman-code str)))
       (+ (bytevector-length sbv)))))

modules/nani/encoding/parse.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani encoding parse)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
   #:export (parse-list
             parse-char
             parse-int
             parse-boolean
             parse-string))
 (define* (parse-list parse-element #:key (size #f))
   (lambda (port)
     (let ((size (or size (bytevector-u16-ref (get-bytevector-n port 2) 0 (endianness big)))))
       (let loop ((result '()) (remaining size))
         (if (= remaining 0)
             (reverse result)
             (loop (cons (parse-element port) result) (- remaining 1)))))))
 (define (parse-char port)
   (get-u8 port))
 (define (parse-int port)
   (bytevector-u32-ref (get-bytevector-n port 4) 0 (endianness big)))
 (define (parse-boolean port)
   (= (get-u8 port) 1))
 (define (parse-string port)
   (define (get-result-string port)
     (let loop ((lu8 '()) (char (get-u8 port)))
       (if (= char 0)
           lu8
           (loop (cons char lu8) (get-u8 port)))))
   (utf8->string (u8-list->bytevector (reverse (get-result-string port)))))

modules/nani/encoding/serialize.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani encoding serialize)
   #:use-module (rnrs bytevectors)
   #:export (merge-bvs
             serialize-list list-size
             serialize-char char-size
             serialize-u16 u16-size
             serialize-int int-size
             serialize-boolean boolean-size
             serialize-string string-size))
 ;;; merge-bvs bvs
 ;;;   Returns a bytevector that contains the data from `bvs`, a list of bytevectors.  For instance,
 ;;;   (merge-bvs '(#u8(1 2) #u8(3 4))) gives #u8(1 2 3 4).
 ;;;
 ;;; Serializers and Sizers
 ;;; ----------------------
 ;;;
 ;;; A serializer is a procedure that takes a value to serialize, a position at which to serialize
 ;;; the value, and a bytevector in which to serialize: `serialize val pos bv`.
 ;;;
 ;;; A sizer is a procedure that takes a value to serialize, and returns the expected size it will
 ;;; take in the serialization.
 ;;;
 ;;; Common Serialization Functions
 ;;; ------------------------------
 ;;;
 ;;; serialize-list serialize-element [#:size? #t]
 ;;;   Returns a serializer for a list of elements. `serialize-element` is the serializer function for
 ;;;   an element.  When `#:size` is `#t`, add the size of the list to the serialization, as a 16-bits
 ;;;   unsigned integer.
 ;;;
 ;;; list-size element-size [#:size? #t]
 ;;;   Returns a sizer for lists, where elements are sized by `element-size`.
 (define (merge-bvs bvs)
   (let* ((size (apply + (map bytevector-length bvs)))
          (bv (make-bytevector size 0)))
     (let loop ((bvs bvs) (pos 0))
       (unless (null? bvs)
         (let ((sz (bytevector-length (car bvs))))
           (bytevector-copy! (car bvs) 0 bv pos sz)
           (loop (cdr bvs) (+ pos sz)))))
     bv))
 (define* (serialize-list serialize-element #:key (size? #t))
   (lambda (lst pos bv)
     (when (not (list? lst)) (throw 'not-list lst))
     (when size?
       (bytevector-u16-set! bv pos (length lst) (endianness big)))
     (let loop ((lst lst) (pos (+ pos (if size? 2 0))))
       (if (null? lst)
         pos
         (loop (cdr lst) (serialize-element (car lst) pos bv))))))
 (define* (list-size element-size #:key (size? #t))
   (lambda (lst)
     (when (not (list? lst)) (throw 'not-list lst))
     (apply + (if size? 2 0) (map element-size lst))))
 (define (serialize-char int pos bv)
   (bytevector-u8-set! bv pos int)
   (+ pos 1))
 (define char-size (const 1))
 (define (serialize-u16 int pos bv)
   (bytevector-u16-set! bv pos int (endianness big))
   (+ pos 2))
 (define u16-size (const 2))
 (define (serialize-int int pos bv)
   (bytevector-u32-set! bv pos int (endianness big))
   (+ pos 4))
 (define int-size (const 4))
 (define (serialize-boolean bool pos bv)
   (bytevector-u8-set! bv pos (if bool 1 0))
   (+ pos 1))
 (define boolean-size (const 1))
 (define (serialize-string str pos bv)
   (let ((sbv (string->utf8 str)))
     (bytevector-copy! sbv 0 bv pos (bytevector-length sbv))
     (bytevector-u8-set! bv (+ pos (bytevector-length sbv)) 0)
     (+ pos 1 (bytevector-length sbv))))
 (define (string-size str)
   (let ((sbv (string->utf8 str)))
     (+ 1 (bytevector-length sbv))))

modules/nani/encoding/trie.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani encoding trie)
   #:use-module (nani encoding serialize)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-9)
   #:export (make-trie
             trie?
             trie-position
             trie-position-set!
             trie-vals
             trie-vals-set!
             trie-transitions
             trie-transitions-set!
             make-empty-trie
             add-to-trie!
             compress-trie
             serialize-trie
             serialize-trie-single
             trie-size
             trie-size-single))
 (define-record-type trie
   (make-trie position vals transitions)
   trie?
   (position trie-position trie-position-set!) ; integer
   (vals trie-vals trie-vals-set!) ; list
   (transitions trie-transitions trie-transitions-set!)) ; array or alist
 (define (make-empty-trie)
   (make-trie 0 '() (make-array #f 16)))
 (define (add-to-trie! trie key value)
   (if (null? key)
     (trie-vals-set! trie (cons value (trie-vals trie)))
     (let ((next-trie (array-ref (trie-transitions trie) (car key))))
       (if next-trie
           (add-to-trie! next-trie (cdr key) value)
           (let ((next-trie (make-empty-trie)))
             (array-set! (trie-transitions trie) next-trie (car key))
             (add-to-trie! next-trie (cdr key) value))))))
 (define (convert-trie-transitions! trie)
   (define (get-new-transitions transitions)
     (let loop ((i 0) (tr '()))
       (if (= i 16)
         tr
         (let ((elem (array-ref transitions i)))
           (if elem
             (begin
               (convert-trie-transitions! elem)
               (loop (+ i 1) (cons (cons i elem) tr)))
             (loop (+ i 1) tr))))))
   (let* ((transitions (trie-transitions trie))
          (transitions (get-new-transitions transitions)))
     (trie-transitions-set! trie transitions)))
 (define (compress-trie trie)
   (define (compress-aux trie)
     (make-trie
       (trie-position trie)
       (trie-vals trie)
       (apply append
         (map
           (lambda (tr)
             (let ((trie (cdr tr)))
               (map
                 (lambda (tr2)
                   (cons (+ (car tr2) (* 16 (car tr)))
                         (compress-aux (cdr tr2))))
                 (trie-transitions trie))))
           (trie-transitions trie)))))
   (convert-trie-transitions! trie)
   (compress-aux trie))
 (define (pointer-size ptr)
 )
 (define (serialize-pointer ptr pos bv)
   (bytevector-u8-set! bv pos (car ptr))
   (bytevector-u32-set! bv (+ pos 1) (trie-position (cdr ptr)) (endianness big))
   (+ pos 5))
 (define (serialize-trie-single serialize-value value-size)
   (define (serialize-trie-aux transitions pos)
     (let loop ((pos pos)
                (trs transitions)
                (bvs '()))
       (if (null? trs)
         (cons pos bvs)
         (let* ((next-trie (cdr (car trs)))
                (bv (get-trie-bv next-trie pos))
                (pos (car bv))
                (bv (cdr bv)))
           (loop pos (cdr trs) (append bvs bv))))))
   (define (get-trie-bv trie pos)
     (trie-position-set! trie pos)
     (let* ((vals-sz (value-size (trie-vals trie)))
            (trs-sz ((list-size (const 5) #:size? #f) (trie-transitions trie)))
            (sz (+ vals-sz 1 trs-sz))
            (bv (make-bytevector sz 0)))
       (serialize-value (trie-vals trie) 0 bv)
       (let* ((bvs (serialize-trie-aux
                     (trie-transitions trie)
                     (+ pos sz)))
              (next-pos (car bvs))
              (bvs (cdr bvs)))
         (bytevector-u8-set! bv vals-sz (length (trie-transitions trie)))
         ((serialize-list serialize-pointer #:size? #f)
          (trie-transitions trie) (+ vals-sz 1) bv)
         (cons next-pos (cons bv bvs)))))
   (lambda (trie pos bv)
     (let* ((trie-bv (get-trie-bv trie pos))
            (new-pos (car trie-bv))
            (trie-bv (merge-bvs (cdr trie-bv))))
       (bytevector-copy! trie-bv 0 bv pos (bytevector-length trie-bv))
       new-pos)))
 (define (serialize-trie serialize-value value-size)
   (serialize-trie-single (serialize-list serialize-value) (list-size value-size)))
 (define (trie-size-single value-size)
   (lambda (trie)
     (apply +
       (value-size (trie-vals trie))
       ((list-size pointer-size #:size? #f) (trie-transitions trie))
       (map (lambda (trie) ((trie-size-single value-size) trie))
            (map cdr (trie-transitions trie))))))
 (define (trie-size value-size)
   (trie-size-single (list-size value-size)))

modules/nani/frequency.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani frequency)
   #:use-module (ice-9 rdelim)
   #:export (load-frequency
             frequency-entity))
 (define (load-frequency file)
   (call-with-input-file file
     (lambda (port)
       (let loop ((frq '()) (i 1))
         (let* ((line (%read-line port))
                (line (car line)))
           (if (eof-object? line)
             frq
             (let ((content (string-split line #\tab)))
               (loop (cons (cons (cadr (cdr content)) i) frq) (+ i 1)))))))))
 (define (frequency-entity frq word)
   (let ((freq (assoc-ref frq word)))
     (cond
       ((not freq)
        #f)
       ((< freq 501)
        "frq500")
       ((< freq 1001)
        "frq1000")
       ((< freq 2001)
        "frq2000")
       ((< freq 5001)
        "frq1000")
       ((< freq 10001)
        "frq10000")
       ((< freq 20001)
        "frq20000")
       (else #f))))

modules/nani/huffman.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani huffman)
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:export (create-huffman
             huffman->code
             huffman-encode
             huffman-decode
             serialize-huffman
             serialize-huffman-string huffman-string-size))
 (define (add-occurence occ char)
   (let* ((o (assoc-ref occ char))
          (o (+ (if o o 0) 1)))
     (assoc-set! occ char o)))
 (define (add-occurences occ str)
   (let loop ((lst (append (string->list str) (list #\nul))) (occ occ))
     (if (null? lst)
       occ
       (loop (cdr lst) (add-occurence occ (car lst))))))
 (define (get-occurences string-list)
   (let loop ((lst string-list) (occ '()))
     (if (null? lst)
       occ
       (loop (cdr lst) (add-occurences occ (car lst))))))
 (define (order tree)
   (if (null? tree)
     tree
     (add-in-order (car tree) (order (cdr tree)))))
 (define (add-in-order elem tree)
   (if (null? tree)
     (list elem)
     (let ((elem-pos (cdr elem))
           (tree-pos (cdr (car tree))))
       (if (> elem-pos tree-pos)
         (cons (car tree) (add-in-order elem (cdr tree)))
         (cons elem tree)))))
 (define (create-huffman string-list)
   (let ((total (apply + (map string-length string-list)))
         (occurences (get-occurences string-list)))
     (let loop ((tree (order occurences)))
       (if (equal? (length tree) 1)
         tree
         (let* ((e1 (car tree))
                (tree (cdr tree))
                (e2 (car tree))
                (tree (cdr tree)))
           (loop (add-in-order (cons (list e1 e2) (+ (cdr e1) (cdr e2))) tree)))))))
 (define (huffman->code huffman)
   (match huffman
     ('() '())
     ((((h1 h2) . weight))
      (append
        (map (lambda (e) (cons (car e) (cons 0 (cdr e)))) (huffman->code h1))
        (map (lambda (e) (cons (car e) (cons 1 (cdr e)))) (huffman->code h2))))
     (((h1 h2) . weight)
      (append
        (map (lambda (e) (cons (car e) (cons 0 (cdr e)))) (huffman->code h1))
        (map (lambda (e) (cons (car e) (cons 1 (cdr e)))) (huffman->code h2))))
     ((((? char? char) . weight))
      (list (cons char '())))
     (((? char? char) . weight)
      (list (cons char '())))))
 (define (bits->bytes b)
   (match b
    ('() '())
    ((a b c d e f g h bs ...)
     (cons (+ h (* 2 g) (* 4 f) (* 8 e) (* 16 d) (* 32 c) (* 64 b) (* 128 a))
       (bits->bytes bs)))
    (_ (bits->bytes (append b (make-list (- 8 (length b)) 0))))))
 (define (huffman-encode code str)
   (u8-list->bytevector
     (bits->bytes
       (apply append (map (lambda (c) (assoc-ref code c))
                          (append (string->list str) (list #\nul)))))))
 (define (byte->bits b)
   (let loop ((i 2) (b b) (by '()))
     (if (eq? i 512)
       by
       (loop (* i 2) (- b (modulo b i)) (cons (if (eq? (modulo b i) 0) 0 1) by)))))
 (define (huffman-decode huffman bv)
   (let ((seq (apply append (map byte->bits (bytevector->u8-list bv)))))
     (list->string
       (reverse
         (let loop ((seq seq) (result '()) (huff huffman))
           (if (null? seq)
             result
             (match huff
               ((((h1 h2) . weight))
                (if (= (car seq) 0)
                  (loop (cdr seq) result h1)
                  (loop (cdr seq) result h2)))
               (((h1 h2) . weight)
                (if (= (car seq) 0)
                  (loop (cdr seq) result h1)
                  (loop (cdr seq) result h2)))
               ((((? char? char) . weight))
                (if (equal? char #\nul)
                  result
                  (loop seq (cons char result) huffman)))
               (((? char? char) . weight)
                (if (equal? char #\nul)
                  result
                  (loop seq (cons char result) huffman))))))))))
 (define (serialize-huffman huffman)
   (define (serialize huffman)
     (match huffman
       ((((h1 h2) . weight))
        (append '(1) (serialize h1) (serialize h2)))
       (((h1 h2) . weight)
        (append '(1) (serialize h1) (serialize h2)))
       ((((? char? char) . weight))
        (append (bytevector->u8-list (string->utf8 (list->string (list char)))) '(0)))
       (((? char? char) . weight)
        (append (bytevector->u8-list (string->utf8 (list->string (list char)))) '(0)))))
   (u8-list->bytevector (serialize huffman)))
 (define (serialize-huffman-string huffman-code)
   (lambda (str pos bv)
     (let ((sbv (huffman-encode huffman-code str)))
       (bytevector-copy! sbv 0 bv pos (bytevector-length sbv))
       (+ pos (bytevector-length sbv)))))
 (define (huffman-string-size huffman-code)
   (lambda (str)
     (let ((sbv (huffman-encode huffman-code str)))
       (+ (bytevector-length sbv)))))

modules/nani/jmdict/entities.scm unknown status 2

 (define-module (nani jmdict entities)
   #:use-module (nani result)
   #:use-module (nani tags)
   #:re-export (get-tag get-points))

modules/nani/jmdict/serialize.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani jmdict serialize)
   #:use-module (nani huffman)
   #:use-module (nani result)
   #:use-module (nani serialize)
   #:use-module (nani trie)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
   #:export (serialize-jmdict
             jmdict-entry-count))
 (define (serialize-pointer ptr pos bv)
   (bytevector-u8-set! bv pos (car ptr))
   (bytevector-u32-set! bv (+ pos 1) (trie-position (cdr ptr)) (endianness big))
   (+ pos 5))
 (define (serialize-trie trie results pos)
   (define (serialize-trie-aux transitions pos)
     (let loop ((pos pos)
                (trs transitions)
                (bvs '()))
       (if (null? trs)
         (cons pos bvs)
         (let* ((next-trie (cdr (car trs)))
                (bv (serialize-trie next-trie results pos))
                (pos (car bv))
                (bv (cdr bv)))
           (loop pos (cdr trs) (append bvs bv))))))
   (trie-position-set! trie pos)
   (let* ((vals-sz (list-size (trie-vals trie) int-size))
          (trs-sz (list-size (trie-transitions trie) (const 5) #:size? #f))
          (sz (+ vals-sz 1 trs-sz))
          (bv (make-bytevector sz 0)))
     (serialize-list (map (lambda (pos) (result-position (array-ref results pos)))
                          (trie-vals trie))
                     serialize-int 0 bv)
     (let* ((bvs (serialize-trie-aux
                   (trie-transitions trie)
                   (+ pos (bytevector-length bv))))
            (next-pos (car bvs))
            (bvs (cdr bvs)))
       (bytevector-u8-set! bv vals-sz (length (trie-transitions trie)))
       (serialize-list (trie-transitions trie) serialize-pointer
                       (+ vals-sz 1) bv #:size? #f)
       (cons next-pos (cons bv bvs)))))
 (define (serialize-jmdict results kanji-trie reading-trie sense-trie)
   (define kanji-huffman
     (let ((kanjis (apply append (map result-kanjis results))))
       (create-huffman kanjis)))
   (define kanji-huffman-code (huffman->code kanji-huffman))
   (define reading-huffman
     (let* ((readings (apply append (map result-readings results)))
            (readings (apply append (map reading-readings readings))))
       (create-huffman readings)))
   (define reading-huffman-code (huffman->code reading-huffman))
   (define sense-huffman
     (let* ((senses (apply append (map result-senses results)))
            (glosses (apply append (map sense-glosses senses))))
       (create-huffman glosses)))
   (define sense-huffman-code (huffman->code sense-huffman))
   (define (serialize-source source pos bv)
     (when (not (source? source)) (throw 'not-source source))
     (let* ((pos (serialize-list (source-content source) serialize-string pos bv))
            (pos (serialize-boolean (source-wasei? source) pos bv))
            (pos (serialize-string (source-type source) pos bv))
            (pos (serialize-string (source-lang source) pos bv)))
       pos))
   (define (source-size source)
     (when (not (source? source)) (throw 'not-source source))
     (+ (list-size (source-content source) string-size)
        (boolean-size (source-wasei? source))
        (string-size (source-type source))
        (string-size (source-lang source))))
   (define (serialize-reading reading pos bv)
     (when (not (reading? reading)) (throw 'not-reading reading))
     (let* ((pos (serialize-list (reading-kanjis reading) serialize-string pos bv))
            (pos (serialize-list (reading-info reading) serialize-string pos bv))
            (pos (serialize-list (reading-readings reading)
                                 (serialize-huffman-string reading-huffman-code) pos bv)))
       pos))
   (define (reading-size reading)
     (when (not (reading? reading)) (throw 'not-reading reading))
     (+ (list-size (reading-kanjis reading) string-size)
        (list-size (reading-info reading) string-size)
        (list-size (reading-readings reading) (huffman-string-size reading-huffman-code))))
   (define (serialize-sense sense pos bv)
     (when (not (sense? sense)) (throw 'not-sense sense))
     (let* ((pos (serialize-list (sense-references sense) serialize-string pos bv))
            (pos (serialize-list (sense-limits sense) serialize-string pos bv))
            (pos (serialize-list (sense-infos sense) serialize-string pos bv))
            (pos (serialize-list (sense-sources sense) serialize-source pos bv))
            (pos (serialize-list (sense-tags sense) serialize-char pos bv))
            (pos (serialize-list (sense-glosses sense)
                 (serialize-huffman-string sense-huffman-code) pos bv))
            (pos (serialize-string (sense-language sense) pos bv)))
       pos))
   (define (sense-size sense)
     (when (not (sense? sense)) (throw 'not-sense sense))
     (+ (list-size (sense-references sense) string-size)
        (list-size (sense-limits sense) string-size)
        (list-size (sense-infos sense) string-size)
        (list-size (sense-sources sense) source-size)
        (list-size (sense-tags sense) char-size)
        (list-size (sense-glosses sense)
                   (huffman-string-size sense-huffman-code))
        (string-size (sense-language sense))))
   (define (serialize-result result pos bv)
     (when (not (result? result)) (throw 'not-result result))
     (result-position-set! result pos)
     (let* ((pos (serialize-list (result-kanjis result)
                                 (serialize-huffman-string kanji-huffman-code) pos bv))
            (pos (serialize-list (result-readings result) serialize-reading pos bv))
            (pos (serialize-list (result-senses result) serialize-sense pos bv)))
       pos))
   (define (result-size result)
     (when (not (result? result)) (throw 'not-result result))
     (+ (list-size (result-kanjis result) (huffman-string-size kanji-huffman-code))
        (list-size (result-readings result) reading-size)
        (list-size (result-senses result) sense-size)))
   (define (trie-node-size trie)
     (apply + 1 (map trie-node-size (map cdr (trie-transitions trie)))))
   (let* ((header (string->utf8 "NANI_JMDICT001"))
          (header-size (bytevector-length header))
          (pointers (make-bytevector 12 0))
          (kanji-huffman-bv (serialize-huffman kanji-huffman))
          (kanji-huffman-size (bytevector-length kanji-huffman-bv))
          (reading-huffman-bv (serialize-huffman reading-huffman))
          (reading-huffman-size (bytevector-length reading-huffman-bv))
          (sense-huffman-bv (serialize-huffman sense-huffman))
          (sense-huffman-size (bytevector-length sense-huffman-bv))
          (results-size (list-size results result-size #:size? #f))
          (huffman-size (+ reading-huffman-size sense-huffman-size kanji-huffman-size))
          (results-bv (make-bytevector (+ header-size 12 kanji-huffman-size
                                          reading-huffman-size sense-huffman-size
                                          results-size 4))))
     (format #t "Number of nodes in kanjis: ~a~%"
       (trie-node-size kanji-trie))
     (format #t "Number of nodes in readings: ~a~%"
       (trie-node-size reading-trie))
     (format #t "Number of nodes in senses: ~a~%"
       (trie-node-size sense-trie))
     (serialize-list results serialize-result (+ header-size 12 huffman-size)
                     results-bv #:size? #f)
     ;; number of entries
     (serialize-int (length results) (+ header-size 12 huffman-size results-size)
                    results-bv)
     (let* ((results (list->array 1 results))
            (pos (bytevector-length results-bv))
            (kanji-bvs (serialize-trie kanji-trie results pos))
            (pos (car kanji-bvs))
            (reading-bvs (serialize-trie reading-trie results pos))
            (pos (car reading-bvs))
            (meaning-bvs (serialize-trie sense-trie results pos)))
       (bytevector-u32-set! pointers 0 (bytevector-length results-bv) (endianness big))
       (bytevector-u32-set! pointers 4 (car kanji-bvs) (endianness big))
       (bytevector-u32-set! pointers 8 (car reading-bvs) (endianness big))
       (bytevector-copy! header 0 results-bv 0 header-size)
       (bytevector-copy! pointers 0 results-bv header-size 12)
       (bytevector-copy! kanji-huffman-bv 0 results-bv (+ header-size 12) kanji-huffman-size)
       (bytevector-copy! reading-huffman-bv 0 results-bv
                         (+ header-size 12 kanji-huffman-size)
                         reading-huffman-size)
       (bytevector-copy! sense-huffman-bv 0 results-bv
                         (+ header-size 12 kanji-huffman-size reading-huffman-size)
                         sense-huffman-size)
       ;; give some feedback on the size of file's structures
       (format #t "huffmans are ~a bytes long~%" huffman-size)
       (format #t "results is ~a bytes long~%" (bytevector-length results-bv))
       (format #t "kanjis is ~a bytes long~%" (apply + (map bytevector-length (cdr kanji-bvs))))
       (format #t "readings is ~a bytes long~%" (apply + (map bytevector-length (cdr reading-bvs))))
       (format #t "senses is ~a bytes long~%" (apply + (map bytevector-length (cdr meaning-bvs))))
       (merge-bvs (append (list results-bv) (cdr kanji-bvs) (cdr reading-bvs)
                          (cdr meaning-bvs))))))
 (define (jmdict-entry-count file)
   (call-with-input-file file
     (lambda (port)
       (let* ((header (utf8->string (get-bytevector-n port 14)))
              (pointers (get-bytevector-n port 12))
              (kanji-pos (bytevector-u32-ref pointers 0 (endianness big))))
         (seek port (- kanji-pos 4) SEEK_SET)
         (bytevector-u32-ref (get-bytevector-n port 4) 0 (endianness big))))))

modules/nani/jmdict/trie.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani jmdict trie)
   #:use-module (nani trie)
   #:use-module (nani result)
   #:use-module (rnrs bytevectors)
   #:export (make-kanji-trie
             make-reading-trie
             make-meaning-trie))
 (define (make-key key)
   (apply append
     (map
       (lambda (c)
         (list (quotient c 16) (modulo c 16)))
       (bytevector->u8-list (string->utf8 key)))))
 (define (make-kanji-trie results)
   (let ((trie (make-empty-trie)))
     (let loop ((results results) (i 0))
       (if (null? results)
         trie
         (begin
           (for-each
             (lambda (key)
               (add-to-trie! trie (make-key key) i))
             (result-kanjis (car results)))
           (loop (cdr results) (+ i 1)))))))
 (define (make-reading-trie results)
   (let ((trie (make-empty-trie)))
     (let loop ((results results) (i 0))
       (if (null? results)
         trie
         (begin
           (for-each
             (lambda (reading)
               (for-each
                 (lambda (key)
                   (add-to-trie! trie (make-key key) i))
                 (reading-readings reading)))
             (result-readings (car results)))
           (loop (cdr results) (+ i 1)))))))
 (define (make-meaning-trie results)
   (let ((trie (make-empty-trie)))
     (let loop ((results results) (i 0))
       (if (null? results)
         trie
         (begin
           (for-each
             (lambda (meaning)
               (for-each
                 (lambda (key)
                   (add-to-trie! trie (make-key key) i))
                 (sense-glosses meaning)))
             (result-senses (car results)))
           (loop (cdr results) (+ i 1)))))))

modules/nani/jmdict/xml.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani jmdict xml)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (sxml ssax)
   #:use-module (nani frequency)
   #:use-module (sxml simple)
   #:use-module (nani result)
   #:use-module (nani jmdict entities)
   #:export (load-dic xml->results))
 (define (load-dic file)
   (xml->sxml (call-with-input-file file read-string)))
 (define (sxml->reading lst)
   (let loop ((reading (make-reading '() '() '())) (lst lst))
     (if (null? lst)
       reading
       (loop
         (match (car lst)
           (('reading r) (update-reading reading #:readings (cons r (reading-readings reading))))
           (('info r) (update-reading reading #:info (cons r (reading-info reading))))
           (('limit r) (update-reading reading #:kanjis (cons r (reading-kanjis reading))))
           (((? symbol? s) v) (throw 'unknown-content s v))
           ((? string? _) reading))
         (cdr lst)))))
 (define (sxml->source lst)
   (let loop ((source (make-source '() #f "" "")) (lst lst))
     (if (null? lst)
       source
       (loop
         (match (car lst)
           (('content c) (update-source source #:content (cons c (source-content source))))
           (('ls_wasei _) (update-source source #:wasei? #t))
           (('ls_type t) (update-source source #:type t))
           ((('xml . 'lang) l) (update-source source #:lang l))
           (((? symbol? s) v) (throw 'unknown-content s v))
           ((? list? l) (loop source l))
           ((? string? c) (update-source source #:content
                                         (cons c (source-content source)))))
         (cdr lst)))))
 (define (sxml->sense lst)
   (let loop ((sense (make-sense '() '() '() '() '() '() "eng")) (lst lst))
     (if (null? lst)
       sense
       (loop
         (match (car lst)
           (('ref (? string? r)) (update-sense sense #:references (cons r (sense-references sense))))
           (('limit (? string? r)) (update-sense sense #:limits (cons r (sense-limits sense))))
           (('info (? string? r)) (update-sense sense #:infos (cons r (sense-infos sense))))
           ((? source? s) (update-sense sense #:sources (cons s (sense-sources sense))))
           (('tag (? integer? r)) (update-sense sense #:tags (cons r (sense-tags sense))))
           (('gloss (? string? r)) (update-sense sense #:glosses (cons r (sense-glosses sense))))
           ((('xml . 'lang) (? string? l)) (update-sense sense #:language l))
           (((? symbol? s) v) (throw 'unknown-content s v))
           ((? list? l) (loop sense l))
           ((? string? _) sense))
         (cdr lst)))))
 (define (sxml->result lst frq)
   (let ((result
         (let loop ((result (make-result 0 0 '() '() '())) (lst lst))
           (if (null? lst)
             result
             (loop
               (match (car lst)
                 (('kanji kanji)
                  (update-result result #:kanjis (cons kanji (result-kanjis result))))
                 ((? reading? r)
                  (update-result result #:readings (cons r (result-readings result))))
                 ((? sense? s)
                  (update-result result #:senses (cons s (result-senses result))))
                 ((? string? _) result))
               (cdr lst))))))
     (let* ((word (if (null? (result-kanjis result))
                    (car (reading-readings (car (result-readings result))))
                    (car (result-kanjis result))))
            (entity (frequency-entity frq word))
            (sense1 (car (result-senses result)))
            (sense1 (if entity
                        (update-sense sense1
                          #:tags (cons (get-tag entity) (sense-tags sense1)))
                        sense1))
            (senses (cons sense1 (cdr (result-senses result)))))
       (update-result result
         #:points (get-points (update-result result #:senses senses))
         #:senses senses))))
 (define (sxml->element lst elem frq)
   (match elem
     ('ent_seq "")
     ('ke_pri "")
     ('re_nokanji "")
     ('re_pri "")
     ('ke_inf "")
     ('misc (if (and (= (length lst) 1) (string? (car lst)))
                `(tag ,(get-tag (car lst)))
                (throw 'invalid-misc lst)))
     ('re_restr (if (and (= (length lst) 1) (string? (car lst)))
                    `(limit ,(car lst))
                    (throw 'invalid-re_restr lst)))
     ('keb (if (and (= (length lst) 1) (string? (car lst)))
               `(kanji ,(car lst))
               (throw 'invalid-keb lst)))
     ('s_inf (if (null? (filter (lambda (s) (not (string? s))) lst))
                 `(info ,(apply string-append lst))
                 (throw 'invalid-s_inf lst)))
     ('dial (if (and (= (length lst) 1) (string? (car lst)))
                `(tag ,(get-tag (car lst)))
                (throw 'invalid-dial lst)))
     ('re_inf (if (and (= (length lst) 1) (string? (car lst)))
                  `(info ,(car lst))
                  (throw 'invalid-re_inf lst)))
     ('stagk (if (and (= (length lst) 1) (string? (car lst)))
                 `(limit ,(car lst))
                 (throw 'invalid-stagk lst)))
     ('stagr (if (and (= (length lst) 1) (string? (car lst)))
                 `(limit ,(car lst))
                 (throw 'invalid-stagr lst)))
     ('field (if (and (= (length lst) 1) (string? (car lst)))
                 `(tag ,(get-tag (car lst)))
                 (throw 'invalid-field lst)))
     ('ant (if (and (= (length lst) 1) (string? (car lst)))
               `(ref ,(car lst))
               (throw 'invalid-ant lst)))
     ('reb (if (and (= (length lst) 1) (string? (car lst)))
               `(reading ,(car lst))
               (throw 'invalid-reb lst)))
     ('r_ele (sxml->reading lst))
     ('k_ele (car (filter list? lst)))
     ('pos (if (and (= (length lst) 1) (string? (car lst)))
               `(tag ,(get-tag (car lst)))
               (throw 'invalid-pos lst)))
     ('xref (if (and (= (length lst) 1) (string? (car lst)))
                `(ref ,(car lst))
                (throw 'invalid-xref lst)))
     ('gloss (cons
               `(gloss ,(apply string-append (filter string? lst)))
               (filter list? lst)))
     ('lsource (sxml->source lst))
     ('sense (sxml->sense lst))
     ('entry (sxml->result lst frq))))
 (define (create-parser frq)
   (ssax:make-parser
     NEW-LEVEL-SEED
     (lambda (elem-gi attributes namespaces expected-content seed)
       (map
         (match-lambda
           ((k . v) (list k v)))
         (filter
           (match-lambda
             ((k . v) (not (member k '(g_type)))))
           attributes)))
     FINISH-ELEMENT
     (lambda (elem-gi attributes namespaces parent-seed seed)
       (if (equal? elem-gi 'JMdict)
           seed
           (let* ((seed (reverse seed))
                  (element (sxml->element seed elem-gi frq)))
             (cons element parent-seed))))
     CHAR-DATA-HANDLER
     (lambda (string1 string2 seed)
       (cons (string-append string1 string2) seed))))
 (define (xml->results port frq)
   (let ((results (filter result? ((create-parser frq) port '()))))
     (sort results (lambda (a b) (> (result-points a) (result-points b))))))

modules/nani/kanji/radk.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani kanji radk)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 peg)
   #:use-module (ice-9 rdelim)
   #:use-module (nani encoding parse)
   #:use-module (nani encoding serialize)
   #:use-module (rnrs bytevectors)
   #:use-module (sxml simple)
   #:export (parse-radk
             get-kanji-stroke
             get-rad-kanji
             get-rad-stroke
             serialize-radk
             kanji-count))
 ;; PEG parser for the radk file
 (define-peg-pattern comment none (and "#" (* (or "\t" (range #\x20 #\x10ffff))) "\n"))
 (define-peg-pattern space none " ")
 (define-peg-pattern return none "\n")
 (define-peg-pattern entry all
   (and (ignore "$") space char space num (? (and space name)) (ignore "\n")
        (+ (or char (ignore "\n")))))
 (define-peg-pattern num all (+ (or (range #\0 #\9))))
 (define-peg-pattern name none (+ (or (range #\0 #\9) (range #\a #\z) (range #\A #\Z))))
 (define-peg-pattern char all (and (range #\xff #\x10ffff)))
 (define-peg-pattern radk-doc body (* (or return comment entry)))
 ;; parse the file with the peg parser, to low-level alist structure
 (define (parse-radk file)
   (peg:tree (match-pattern radk-doc (call-with-input-file file read-string))))
 (define (get-rad-kanji content)
   (let loop ((result '()) (content content))
     (match content
       (() result)
       ((('entry ('char radical) ('num stroke) ('char kanji)) content ...)
        (loop (cons (list radical kanji) result)
              content))
       ((('entry ('char radical) ('num stroke) (('char kanji) ...)) content ...)
        (loop (cons (cons radical kanji) result)
              content)))))
 (define (get-rad-stroke content)
   (let loop ((result '()) (content content))
     (match content
       (() result)
       ((('entry ('char radical) ('num stroke) ('char kanji)) content ...)
        (loop (cons (cons radical (string->number stroke)) result)
              content))
       ((('entry ('char radical) ('num stroke) (('char kanji) ...)) content ...)
        (loop (cons (cons radical (string->number stroke)) result)
              content)))))
 ;; return an alist where keys are kanjis, and values the associated stroke count.
 (define (get-kanji-stroke file)
   (define strokes (xml->sxml (call-with-input-file file read-string)))
   (match strokes
     (('*TOP* _ ('kanjidic2 content ...))
      (map
        (lambda (entry)
          (let* ((literal (car (assoc-ref entry 'literal)))
                 (misc (assoc-ref entry 'misc))
                 (misc (filter list? misc))
                 (stroke (car (assoc-ref misc 'stroke_count))))
            (cons literal (string->number stroke))))
        (filter
          (lambda (entry)
            (and
              (list? entry)
              (equal? (car entry) 'character)))
          content)))))
 (define (serialize-radk rad-kanji rad-stroke kanji-stroke)
   (define (serialize-rad-kanji-element element pos bv)
     (match element
       ((radical kanji ...)
        (let* ((pos (serialize-string (radical-character radical) pos bv)))
          (serialize-string (string-join kanji "") pos bv)))))
   (define (rad-kanji-element-size element)
     (match element
       ((radical kanji ...)
        (+ (string-size (radical-character radical))
           (string-size (string-join kanji ""))))))
   (define (serialize-rad-kanji rad-kanji pos bv)
     ((serialize-list serialize-rad-kanji-element) rad-kanji pos bv))
   (define (rad-kanji-size rad-kanji)
     ((list-size rad-kanji-element-size) rad-kanji))
   (define (serialize-rad-stroke-element element pos bv)
     (match element
       ((radical . stroke)
        (let ((pos (serialize-string (radical-character radical) pos bv)))
          (serialize-char stroke pos bv)))))
   (define (rad-stroke-element-size element)
     (match element
       ((radical . stroke)
        (+ (string-size (radical-character radical)) (char-size stroke)))))
   (define (serialize-rad-stroke rad-stroke pos bv)
     ((serialize-list serialize-rad-stroke-element) rad-stroke pos bv))
   (define (rad-stroke-size rad-stroke)
     ((list-size rad-stroke-element-size) rad-stroke))
   (define (serialize-kanji-stroke-element element pos bv)
     (match element
       ((kanji . stroke)
        (let ((pos (serialize-string kanji pos bv)))
          (serialize-char stroke pos bv)))))
   (define (kanji-stroke-element-size element)
     (match element
       ((kanji . stroke)
        (+ (string-size kanji) (char-size stroke)))))
   (define (serialize-kanji-stroke kanji-stroke pos bv)
     ((serialize-list serialize-kanji-stroke-element) kanji-stroke pos bv))
   (define (kanji-stroke-size kanji-stroke)
     ((list-size kanji-stroke-element-size) kanji-stroke))
   (let* ((header (string->utf8 "NANI_RADK001"))
          (header-size (bytevector-length header))
          (bv (make-bytevector (+ header-size 12
                                  (rad-kanji-size rad-kanji)
                                  (rad-stroke-size rad-stroke)
                                  (kanji-stroke-size kanji-stroke)))))
     (bytevector-copy! header 0 bv 0 header-size)
     (let* ((pos header-size)
            (pos (serialize-rad-kanji rad-kanji pos bv))
            (pos (serialize-rad-stroke rad-stroke pos bv))
            (pos (serialize-kanji-stroke kanji-stroke pos bv)))
       bv)))
 (define (radical-character kanji)
   (match kanji
     ("???" "???")
     ("???" "????")
     ("???" "???")
     ("???" "???")
     ("???" "????")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     (_ kanji)))
 ;; parse a serialized file back to the guile structure
 (define (parse file)
   (define (parse-rad-kanji-element port)
     (let ((radical (parse-string port))
           (kanji-list (parse-string port)))
        (cons radical (string->list kanji-list))))
   (define (parse-rad-kanji port)
     ((parse-list parse-rad-kanji-element) port))
   (define (parse-rad-stroke-element port)
     (let ((radical (parse-string port))
           (stroke (parse-char port)))
        (cons radical stroke)))
   (define (parse-rad-stroke port)
     ((parse-list parse-rad-stroke-element) port))
   (define (parse-kanji-stroke-element port)
     (let ((kanji (parse-string port))
           (stroke (parse-char port)))
       (cons kanji stroke)))
   (define (parse-kanji-stroke port)
     ((parse-list parse-kanji-stroke-element) port))
   (call-with-input-file file
     (lambda (port)
       (let* ((header (utf8->string (get-bytevector-n port 12)))
              (rad-kanji (parse-rad-kanji port))
              (rad-stroke (parse-rad-stroke port))
              (kanji-stroke (parse-kanji-stroke port)))
         (list rad-kanji rad-stroke kanji-stroke)))))
 (define (get-kanji-list content)
   (let loop ((result '()) (content content))
     (match content
       (() result)
       (((_ kanji ...) content ...)
        (loop (append result (filter (lambda (k) (not (member k result))) kanji))
              content)))))
 (define (kanji-count file)
   (match (parse file)
     ((rad-kanji _ _)
      (length (get-kanji-list rad-kanji)))))

modules/nani/parse-result.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani parse-result)
   #:use-module (ice-9 binary-ports)
   #:use-module (rnrs bytevectors)
   #:export (parse-result-list
             parse-result-char
             parse-result-int
             parse-result-boolean
             parse-result-string))
 (define* (parse-result-list port parse-result-element)
   (let ((size (bytevector-u16-ref (get-bytevector-n port 2) 0 (endianness big))))
     (let loop ((result '()) (remaining size))
       (if (= remaining 0)
           (reverse result)
           (loop (cons (parse-result-element port) result) (- remaining 1))))))
 (define (parse-result-char port)
   (get-u8 port))
 (define (parse-result-int port)
   (bytevector-u32-ref (get-bytevector-n port 4) 0 (endianness big)))
 (define (parse-result-boolean port)
   (= (get-u8 port) 1))
 (define (parse-result-string port)
   (define (get-result-string port)
     (let loop ((lu8 '()) (char (get-u8 port)))
       (if (= char 0)
           lu8
           (loop (cons char lu8) (get-u8 port)))))
   (utf8->string (u8-list->bytevector (reverse (get-result-string port)))))

modules/nani/pitch/pitch.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2021 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani pitch pitch)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
   #:use-module (nani encoding huffman)
   #:use-module (nani encoding trie)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:export (make-pitch
             pitch?
             pitch-kanji
             pitch-reading
             pitch-accents
             serialize-pitch
             pitch-entry-count))
 (define-record-type pitch
   (make-pitch kanji reading accents)
   pitch?
   (kanji   pitch-kanji)
   (reading pitch-reading)
   (accents pitch-accents))
 (define (make-trie-key key)
   (append-map
     (lambda (c)
       (list (quotient c 16) (modulo c 16)))
     (bytevector->u8-list (string->utf8 key))))
 (define (get-pitch-trie pitches)
   (let ((trie (make-empty-trie)))
     (for-each
       (lambda (pitch)
         (let ((key (string-append (pitch-kanji pitch) (pitch-reading pitch))))
           (for-each
             (lambda (accent)
               (add-to-trie! trie (make-trie-key key) accent))
             (pitch-accents pitch))))
       pitches)
     (compress-trie trie)))
 (define (collapse-vals! trie)
   (let ((transitions (trie-transitions trie))
         (vals (map (match-lambda ((? string? s) s) ((? number? i) (number->string i)))
                    (trie-vals trie))))
     (trie-vals-set! trie (string-join vals ", "))
     (for-each collapse-vals! (map cdr transitions))))
 (define (collect-vals trie)
   (let ((transitions (trie-transitions trie))
         (vals (trie-vals trie)))
     (cons vals (append-map collect-vals (map cdr transitions)))))
 (define (serialize-pitch pitches)
   (let ((trie (get-pitch-trie pitches)))
     (collapse-vals! trie)
     (let* ((huffman (create-huffman (collect-vals trie)))
            (code (huffman->code huffman)))
       (let* ((header (string->utf8 "NANI_PITCH001"))
              (header-size (bytevector-length header))
              (huffman-bv (serialize-huffman huffman))
              (huffman-size (bytevector-length huffman-bv))
              (trie-size ((trie-size-single (huffman-string-size code)) trie))
              (result (make-bytevector (+ header-size 4 huffman-size trie-size))))
         (bytevector-copy! header 0 result 0 header-size)
         (bytevector-u32-set! result header-size (length pitches) (endianness big))
         (bytevector-copy! huffman-bv 0 result (+ header-size 4) huffman-size)
         ((serialize-trie-single (serialize-huffman-string code)
                                 (huffman-string-size code))
          trie (+ header-size 4 huffman-size) result)
         result))))
 (define (pitch-entry-count file)
   (call-with-input-file file
     (lambda (port)
       ;; header
       (get-bytevector-n port 13)
       ;; size
       (bytevector-u32-ref (get-bytevector-n port 4) 0 (endianness big)))))

modules/nani/pitch/wadoku.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani pitch wadoku)
   #:use-module (ice-9 match)
   #:use-module (nani pitch pitch)
   #:use-module (srfi srfi-1)
   #:use-module (sxml ssax)
   #:export (xml->pitch))
 (define (sxml->element lst elem)
   (let ((elem (match elem
                 ((_ . elem) elem)
                 (_ elem))))
     (match elem
       ('accent `(pitch . ,(car lst)))
       ('hira `(reading . ,(car lst)))
       ('orth (let ((kanji (filter string? lst)))
                (if (null? kanji) #f `(kanji . ,(car kanji)))))
       ('form
        `(form . ,(append-map (lambda (a) (if (list? a) a (list a))) lst)))
       ('reading (filter pair? lst))
       ('entry
         (let loop ((lst lst) (kanjis '()) (readings '()) (accents '()))
           (if (null? lst)
               (if (or (and (null? kanjis) (null? readings)) (null? accents))
                   #f
                   (append-map
                     (lambda (reading)
                       (map
                         (lambda (kanji)
                           (make-pitch kanji reading accents))
                         kanjis))
                     readings))
               (match (car lst)
                 (('form . f)
                  (loop (append f (cdr lst)) kanjis readings accents))
                 (('pitch . pitch)
                  (loop (cdr lst) kanjis readings (cons pitch accents)))
                 (('reading . reading)
                  (loop (cdr lst) kanjis (cons reading readings) accents))
                 (('kanji . kanji)
                  (loop (cdr lst) (cons kanji kanjis) readings accents))
                 (_ (loop (cdr lst) kanjis readings accents))))))
       (_ #f))))
 (define parser
   (ssax:make-parser
     NEW-LEVEL-SEED
     (lambda (elem-gi attributes namespaces expected-content seed)
       attributes)
     FINISH-ELEMENT
     (lambda (elem-gi attributes namespaces parent-seed seed)
       (if (equal? elem-gi 'entries)
           seed
           (let* ((seed (reverse seed))
                  (element (sxml->element seed elem-gi)))
             (cons element parent-seed))))
     CHAR-DATA-HANDLER
     (lambda (string1 string2 seed)
       (cons (string-append string1 string2) seed))))
 (define (xml->pitch port)
   (filter pitch? (apply append (filter list? (parser port '())))))

modules/nani/radk.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani radk)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 peg)
   #:use-module (ice-9 rdelim)
   #:use-module (nani parse-result)
   #:use-module (nani serialize)
   #:use-module (rnrs bytevectors)
   #:use-module (sxml simple)
   #:export (parse-radk
             get-kanji-stroke
             get-rad-kanji
             get-rad-stroke
             serialize-radk
             kanji-count))
 (define-peg-pattern comment none (and "#" (* (or "\t" (range #\x20 #\x10ffff))) "\n"))
 (define-peg-pattern space none " ")
 (define-peg-pattern return none "\n")
 (define-peg-pattern entry all
   (and (ignore "$") space char space num (? (and space name)) (ignore "\n")
        (+ (or char (ignore "\n")))))
 (define-peg-pattern num all (+ (or (range #\0 #\9))))
 (define-peg-pattern name none (+ (or (range #\0 #\9) (range #\a #\z) (range #\A #\Z))))
 (define-peg-pattern char all (and (range #\xff #\x10ffff)))
 (define-peg-pattern radk-doc body (* (or return comment entry)))
 (define (parse-radk file)
   (peg:tree (match-pattern radk-doc (call-with-input-file file read-string))))
 (define (get-rad-kanji content)
   (let loop ((result '()) (content content))
     (match content
       (() result)
       ((('entry ('char radical) ('num stroke) (('char kanji) ...)) content ...)
        (loop (cons (cons radical kanji) result)
              content)))))
 (define (get-rad-stroke content)
   (let loop ((result '()) (content content))
     (match content
       (() result)
       ((('entry ('char radical) ('num stroke) (('char kanji) ...)) content ...)
        (loop (cons (cons radical (string->number stroke)) result)
              content)))))
 (define (get-kanji-stroke file)
   (define strokes (xml->sxml (call-with-input-file file read-string)))
   (match strokes
     (('*TOP* _ ('kanjidic2 content ...))
      (map
        (lambda (entry)
          (let* ((literal (car (assoc-ref entry 'literal)))
                 (misc (assoc-ref entry 'misc))
                 (misc (filter list? misc))
                 (stroke (car (assoc-ref misc 'stroke_count))))
            (cons literal (string->number stroke))))
        (filter
          (lambda (entry)
            (and
              (list? entry)
              (equal? (car entry) 'character)))
          content)))))
 (define (serialize-radk rad-kanji rad-stroke kanji-stroke)
   (define (serialize-rad-kanji-element element pos bv)
     (match element
       ((radical kanji ...)
        (let* ((pos (serialize-string (radical-character radical) pos bv)))
          (serialize-string (string-join kanji "") pos bv)))))
   (define (rad-kanji-element-size element)
     (match element
       ((radical kanji ...)
        (+ (string-size (radical-character radical))
           (string-size (string-join kanji ""))))))
   (define (serialize-rad-kanji rad-kanji pos bv)
     (serialize-list rad-kanji serialize-rad-kanji-element pos bv))
   (define (rad-kanji-size rad-kanji)
     (list-size rad-kanji rad-kanji-element-size))
   (define (serialize-rad-stroke-element element pos bv)
     (match element
       ((radical . stroke)
        (let ((pos (serialize-string (radical-character radical) pos bv)))
          (serialize-char stroke pos bv)))))
   (define (rad-stroke-element-size element)
     (match element
       ((radical . stroke)
        (+ (string-size (radical-character radical)) (char-size stroke)))))
   (define (serialize-rad-stroke rad-stroke pos bv)
     (serialize-list rad-stroke serialize-rad-stroke-element pos bv))
   (define (rad-stroke-size rad-stroke)
     (list-size rad-stroke rad-stroke-element-size))
   (define (serialize-kanji-stroke-element element pos bv)
     (match element
       ((kanji . stroke)
        (let ((pos (serialize-string kanji pos bv)))
          (serialize-char stroke pos bv)))))
   (define (kanji-stroke-element-size element)
     (match element
       ((kanji . stroke)
        (+ (string-size kanji) (char-size stroke)))))
   (define (serialize-kanji-stroke kanji-stroke pos bv)
     (serialize-list kanji-stroke serialize-kanji-stroke-element pos bv))
   (define (kanji-stroke-size kanji-stroke)
     (list-size kanji-stroke kanji-stroke-element-size))
   (let* ((header (string->utf8 "NANI_RADK001"))
          (header-size (bytevector-length header))
          (bv (make-bytevector (+ header-size 12
                                  (rad-kanji-size rad-kanji)
                                  (rad-stroke-size rad-stroke)
                                  (kanji-stroke-size kanji-stroke)))))
     (bytevector-copy! header 0 bv 0 header-size)
     (let* ((pos header-size)
            (pos (serialize-rad-kanji rad-kanji pos bv))
            (pos (serialize-rad-stroke rad-stroke pos bv))
            (pos (serialize-kanji-stroke kanji-stroke pos bv)))
       bv)))
 (define (radical-character kanji)
   (match kanji
     ("???" "???")
     ("???" "????")
     ("???" "???")
     ("???" "???")
     ("???" "????")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     ("???" "???")
     (_ kanji)))
 (define (parse-result file)
   (define (parse-result-rad-kanji-element port)
     (let ((radical (parse-result-string port))
           (kanji-list (parse-result-string port)))
        (cons radical (string->list kanji-list))))
   (define (parse-result-rad-kanji port)
     (parse-result-list port parse-result-rad-kanji-element))
   (define (parse-result-rad-stroke-element port)
     (let ((radical (parse-result-string port))
           (stroke (parse-result-char port)))
        (cons radical stroke)))
   (define (parse-result-rad-stroke port)
     (parse-result-list port parse-result-rad-stroke-element))
   (define (parse-result-kanji-stroke-element port)
     (let ((kanji (parse-result-string port))
           (stroke (parse-result-char port)))
       (cons kanji stroke)))
   (define (parse-result-kanji-stroke port)
     (parse-result-list port parse-result-kanji-stroke-element))
   (call-with-input-file file
     (lambda (port)
       (let* ((header (utf8->string (get-bytevector-n port 12)))
              (rad-kanji (parse-result-rad-kanji port))
              (rad-stroke (parse-result-rad-stroke port))
              (kanji-stroke (parse-result-kanji-stroke port)))
         (list rad-kanji rad-stroke kanji-stroke)))))
 (define (get-kanji-list content)
   (let loop ((result '()) (content content))
     (match content
       (() result)
       (((_ kanji ...) content ...)
        (loop (append result (filter (lambda (k) (not (member k result))) kanji))
              content)))))
 (define (kanji-count file)
   (match (parse-result file)
     ((rad-kanji _ _)
      (length (get-kanji-list rad-kanji)))))

modules/nani/result.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani result)
   #:use-module (srfi srfi-9)
   #:export (make-result
             result?
             result-position
             result-position-set!
             result-points
             result-kanjis
             result-readings
             result-senses
             make-reading
             reading?
             reading-kanjis
             reading-info
             reading-readings
             make-sense
             sense?
             sense-references
             sense-limits
             sense-infos
             sense-sources
             sense-tags
             sense-glosses
             sense-language
             make-source
             source?
             source-content
             source-wasei?
             source-type
             source-lang
             update-result
             update-reading
             update-sense
             update-source))
 (define-record-type result
   (make-result position points kanjis readings senses)
   result?
   (position result-position result-position-set!) ; integer
   (points result-points) ; integer
   (kanjis result-kanjis) ; string-list
   (readings result-readings) ; reanding-list
   (senses result-senses)) ; sense-list
 (define-record-type reading
   (make-reading kanjis info readings)
   reading?
   (kanjis reading-kanjis) ; string-list
   (info reading-info) ; string-list
   (readings reading-readings)) ; string-list
 (define-record-type sense
   (make-sense references limits infos sources tags glosses language)
   sense?
   (references sense-references) ; string-list
   (limits sense-limits) ; string-list
   (infos sense-infos) ; string-list
   (sources sense-sources) ; source-list
   (tags sense-tags) ; integer-list
   (glosses sense-glosses) ; string-list
   (language sense-language)) ; string
 (define-record-type source
   (make-source content wasei? type lang)
   source?
   (content source-content) ; string-list
   (wasei? source-wasei?) ; boolean
   (type source-type) ; string
   (lang source-lang)) ; string
 (define* (update-result result
            #:key (points (result-points result))
                  (kanjis (result-kanjis result))
                  (readings (result-readings result))
                  (senses (result-senses result)))
   (make-result (result-position result) points kanjis readings senses))
 (define* (update-reading reading
            #:key (kanjis (reading-kanjis reading))
                  (info (reading-info reading))
                  (readings (reading-readings reading)))
   (make-reading kanjis info readings))
 (define* (update-sense sense
            #:key (references (sense-references sense))
                  (limits (sense-limits sense))
                  (infos (sense-infos sense))
                  (sources (sense-sources sense))
                  (tags (sense-tags sense))
                  (glosses (sense-glosses sense))
                  (language (sense-language sense)))
   (make-sense references limits infos sources tags glosses language))
 (define* (update-source source
            #:key (content (source-content source))
                  (wasei? (source-wasei? source))
                  (type (source-type source))
                  (lang (source-lang source)))
   (make-source content wasei? type lang))

modules/nani/result/frequency.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani result frequency)
   #:use-module (ice-9 rdelim)
   #:export (load-frequency
             frequency->score))
 (define (load-frequency file)
   (call-with-input-file file
     (lambda (port)
       (let loop ((frq '()) (i 1))
         (let* ((line (%read-line port))
                (line (car line)))
           (if (eof-object? line)
             frq
             (let ((content (string-split line #\tab)))
               (loop (cons (cons (cadr (cdr content)) i) frq) (+ i 1)))))))))
 (define (frequency->score frq word)
   (let ((freq (assoc-ref frq word)))
     (cond
       ((not freq) 0)
       ((< freq 501) 32)
       ((< freq 1001) 16)
       ((< freq 2001) 8)
       ((< freq 5001) 4)
       ((< freq 10001) 2)
       ((< freq 20001) 1)
       (else 0))))

modules/nani/result/jibiki.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani result jibiki)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (nani result frequency)
   #:use-module (nani result result)
   #:use-module (srfi srfi-9)
   #:use-module (sxml ssax)
   #:export (xml->results))
 (define (sxml->string lst)
   (if (string? lst)
       lst
       (let loop ((lst lst) (result ""))
         (if (null? lst)
             result
             (loop
               (cdr lst)
               (match (car lst)
                 (('lang . _) result)
                 (#f result)
                 ((? string? s) (string-append result s))
                 ((? list? l) (loop l result))))))))
 (define (gram->info gram)
   (match gram
     ("adjectif???" "adj. en ku")
     ("adjectif???" "adj. en na")
     ("adjectif?????????" "adj. en na (tari)")
     ("adjectif?????????" "adj. en na (nari)")
     ("contraction" "contr.")
     ("counter" "compteur")
     ("num??rique" "nombre")
     ("particule" "particule")
     ("postposition" "postpos.")
     ("verbe auxiliaire" "v. aux.")
     ("??? pronom" "pronom")
     ("??? adverbe" "adv.")
     ("??? onomatop??e" "onom.")
     ("?????? verbe auxiliaire" "v. aux.")
     ("?????? compteur" "compteur")
     ("??? verbe" "v.")
     ("??? verbe intransitif" "v.i.")
     ("??? verbe transitif" "v.t.")
     ("??? nom" "n.")
     ("??? adjectif" "adj.")
     ("???" "interj.")
     ("?????? interjection" "interj.")
     ("?????? expression" "expr.")
     ("?????? suffixe" "suf.")
     ("?????? suffixe conjonctif" "suf. conj.")
     ("?????? conjonction" "conj.")
     ("?????? pr??fixe" "pref.")
     ("??????" "adj. pr??nominal")
     ("?????? locution adverbiale" "loc. adv.")
     ("?????? locution conjonctive" "loc. conj.")
     ("?????? locution postpositive" "loc. post.")
     ("?????? mot compos??" "mot compos??")
     ("??" #f)
     ("" #f)))
 (define (info->info i)
   (match (sxml->string i)
     ("abbreviation" "abbreviation")
     ("archaism" "archa??sme")
     ("children's language" "langage des enfants")
     ("colloquialism" "familier")
     ("derogatory" "terme de m??pris")
     ("familiar language" "familier")
     ("female term or language" "langage des femmes")
     ("honorific or respectful (sonkeigo) language" "terme honorifique")
     ("humble (kenjougo) language" "terme humble")
     ("idiomatic expression" "idiom.")
     ("jocular, humorous term" "comique")
     ("male term or language" "langage des hommes")
     ("obscure term" "obscure")
     ("obsolete term" "obsol??te")
     ("onomatopoeic or mimetic word" "onom.")
     ("polite (teineigo) language" "terme poli")
     ("proverb" "proverbe")
     ("sensitive" "sensible")
     ("slang" "argot")
     ("vulgar expression or word" "vulgaire")
     ("word usually written using kana alone" "habituellement ??crit en kana")
     ("" #f)
     (() #f)
     (_ i)))
 (define (sxml->ref lst)
   (let loop ((lst lst) (ref '()))
     (if (null? lst)
         ref
         (loop
           (cdr lst)
           (match (car lst)
             (#f ref)
             (('jpn . jpn) (cons jpn ref)))))))
 (define (sxml->reading str)
   (make-reading '() '() (list str)))
 (define (sxml->source lst)
   (let loop ((lst lst) (source (make-source '() #f "")))
     (if (null? lst)
         source
         (loop
           (cdr lst)
           (match (car lst)
             ((? string? s)
              (update-source source
                #:content (cons s (source-content source))))
             (('lang . l)
              (update-source source #:lang l))
             ((? list? l)
              (loop l source)))))))
 (define (sxml->meaning lst)
   (let loop ((lst lst) (meaning (make-meaning '() '() '() '() '() "fr")))
     (if (null? lst)
         meaning
         (loop
           (cdr lst)
           (match (car lst)
             (#f meaning)
             (('n . _) meaning)
             (('info . info) (update-meaning meaning
                               #:infos (cons info (meaning-infos meaning))))
             (('content . c) (update-meaning meaning
                               #:glosses (append
                                           (map string-downcase
 					       (string-split c #\,))
                                           (meaning-glosses meaning))))
             ((? source? s)
              (update-meaning meaning
                #:sources (cons s (meaning-sources meaning))))
             ((? string? _) meaning)
             ((? list? l) (loop l meaning)))))))
 (define (sxml->result lst frq)
   (define result
     (let loop ((lst lst) (result (make-result 0 0 '() '() '())) (infos '())
                          (sources '()))
       (if (null? lst)
           (list result infos sources)
           (match (car lst)
             (#f (loop (cdr lst) result infos sources))
             (('id . _) (loop (cdr lst) result infos sources))
             (('identree . _) (loop (cdr lst) result infos sources))
             (('kanji . k)
              (loop (cdr lst)
                    (update-result result
                      #:kanjis (cons k (result-kanjis result)))
                    infos
                    sources))
             ((? reading? r)
              (loop
                (cdr lst)
                (update-result result
                  #:readings (cons r (result-readings result)))
                infos
                sources))
             ((? meaning? s)
              (loop
                (cdr lst)
                (update-result result
                  #:meanings (cons s (result-meanings result)))
                infos
                sources))
             ((? source? s)
              (loop (cdr lst) result infos (cons s sources)))
             (('info . info)
              (loop (cdr lst)
                    result
                    (cons info infos)
                    sources))
             ((? list? l)
              (match (loop l result infos sources)
                ((result infos sources)
                 (loop (cdr lst) result infos sources))))))))
   (match result
     ((result infos sources)
      (if (or (and (null? (result-readings result))
                   (null? (result-kanjis result)))
              (null? (result-meanings result)))
          #f
          (let* ((word (if (null? (result-kanjis result))
                           (car (reading-readings
                                  (car (result-readings result))))
                           (car (result-kanjis result))))
                 (score (frequency->score frq word))
                 (meanings (result-meanings result))
                 (meanings
                   (map
                     (lambda (s)
                       (update-meaning s
                         #:infos (append infos (meaning-infos s))
                         #:sources (append sources (meaning-sources s))))
                     meanings)))
            (update-result result
              #:score score
              #:meanings meanings))))))
 (define (sxml->element lst elem frq)
   (let ((elem (match elem
                 ((_ . elem) elem)
                 (_ elem))))
     (match elem
       ('vedette-romaji #f)
       ('vedette-hiragana (sxml->reading (sxml->string lst)))
       ('vedette-jpn `(kanji . ,(sxml->string lst)))
       ('vedette lst)
       ('forme lst)
       ('domaine (if (null? lst) #f
                     (let ((info (sxml->string lst)))
                       (if (or (not info) (string-null? info))
                           #f
                           `(info . ,info)))))
       ('gram (let ((info (gram->info (sxml->string lst))))
                (if (or (not info) (string-null? info))
                    #f
                    `(info . ,info))))
       ('??tiquettes lst)
       ('??tiquettes-sens lst)
       ('texte-sens `(content . ,(sxml->string lst)))
       ('sens (sxml->meaning lst))
       ('bloc-gram lst)
       ('s??mantique lst)
       ('article (sxml->result lst frq))
       ('registre (let ((info (sxml->string lst)))
                    (if (or (not info) (string-null? info))
                        #f
                        `(info . ,info))))
       ('litt??ralement
        (if (null? lst) #f (make-meaning
                             '() '() '() '("lit")
                             (list (sxml->string lst)) "fr")))
       ('etymologie (sxml->source lst))
       ('??tymologie (sxml->source lst))
       ('note (let ((info (sxml->string lst)))
                (if (or (not info) (string-null? info)) #f `(info . ,info))))
       ('info (let ((info (info->info (sxml->string lst))))
                (if (or (not info) (string-null? info)) #f `(info . ,info))))
       ('dialecte (let ((info (sxml->string lst)))
                    (if (or (not info) (string-null? info)) #f `(info . ,info))))
       ('en lst)
       ('eng lst)
       ('xref (sxml->ref lst))
       ('vr #f)
       ('romaji #f)
       ('romajidx #f)
       ('rt #f)
       ('ruby #f)
       ('vj #f)
       ('jpn `(jpn . ,(sxml->string lst)))
       ('??tiquettes-fran??ais #f)
       ('??tiquettes-sous-sens #f)
       ('texte-sous-sens #f)
       ('sous-sens #f)
       ('sous-bloc-gram #f)
       ('fran??ais #f)
       ('exemple #f)
       ('exemples #f))))
 (define (create-parser frq)
   (ssax:make-parser
     NEW-LEVEL-SEED
     (lambda (elem-gi attributes namespaces expected-content seed)
       attributes)
     FINISH-ELEMENT
     (lambda (elem-gi attributes namespaces parent-seed seed)
       (if (equal? elem-gi 'volume)
           (filter (lambda (a) a) seed)
           (let* ((seed (reverse seed))
                  (element (sxml->element seed elem-gi frq)))
             (cons element parent-seed))))
     CHAR-DATA-HANDLER
     (lambda (string1 string2 seed)
       (cons (string-append string1 string2) seed))))
 (define (xml->results port frq)
   (let ((results (filter result? ((create-parser frq) port '()))))
     (sort-results results)))

modules/nani/result/jmdict.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani result jmdict)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (nani result frequency)
   #:use-module (nani result result)
   #:use-module (sxml simple)
   #:use-module (sxml ssax)
   #:export (load-dic xml->results))
 (define (load-dic file)
   (xml->sxml (call-with-input-file file read-string)))
 (define (sxml->reading lst)
   (let loop ((reading (make-reading '() '() '())) (lst lst))
     (if (null? lst)
       reading
       (loop
         (match (car lst)
           (('reading r) (update-reading reading #:readings (cons r (reading-readings reading))))
           (('info r) (update-reading reading #:info (cons r (reading-info reading))))
           (('limit r) (update-reading reading #:kanjis (cons r (reading-kanjis reading))))
           (((? symbol? s) v) (throw 'unknown-content s v))
           ((? string? _) reading))
         (cdr lst)))))
 (define (sxml->source lst)
   (let loop ((source (make-source '() #f "")) (lst lst))
     (if (null? lst)
       source
       (loop
         (match (car lst)
           (('content c) (update-source source #:content (cons c (source-content source))))
           (('ls_wasei _) (update-source source #:wasei? #t))
           (('ls_type t) source); type is always "part" or nothing
           ((('xml . 'lang) l) (update-source source #:lang l))
           (((? symbol? s) v) (throw 'unknown-content s v))
           ((? list? l) (loop source l))
           ((? string? c) (update-source source #:content
                                         (cons c (source-content source)))))
         (cdr lst)))))
 (define (sxml->meaning lst)
   (let loop ((meaning (make-meaning '() '() '() '() '() "eng")) (lst lst))
     (if (null? lst)
       meaning
       (loop
         (match (car lst)
           (('ref (? string? r)) (update-meaning meaning #:references (cons r (meaning-references meaning))))
           (('limit (? string? r)) (update-meaning meaning #:limits (cons r (meaning-limits meaning))))
           (('info (? string? r)) (update-meaning meaning #:infos (cons r (meaning-infos meaning))))
           ((? source? s) (update-meaning meaning #:sources (cons s (meaning-sources meaning))))
           (('info (? string? r)) (update-meaning meaning #:infos (cons r (meaning-infos meaning))))
           (('gloss (? string? r)) (update-meaning meaning
                                     #:glosses
                                     (cons (string-downcase r)
                                           (meaning-glosses meaning))))
           ((('xml . 'lang) (? string? l)) (update-meaning meaning #:language l))
           (((? symbol? s) v) (throw 'unknown-content s v))
           ((? list? l) (loop meaning l))
           ((? string? _) meaning))
         (cdr lst)))))
 (define (sxml->result lst frq)
   (let ((result
         (let loop ((result (make-result 0 0 '() '() '())) (lst lst))
           (if (null? lst)
             result
             (loop
               (match (car lst)
                 (('kanji kanji)
                  (update-result result #:kanjis (cons kanji (result-kanjis result))))
                 ((? reading? r)
                  (update-result result #:readings (cons r (result-readings result))))
                 ((? meaning? s)
                  (update-result result #:meanings (cons s (result-meanings result))))
                 ((? string? _) result))
               (cdr lst))))))
     (let* ((word (if (null? (result-kanjis result))
                    (car (reading-readings (car (result-readings result))))
                    (car (result-kanjis result))))
            (score (frequency->score frq word))
            (meanings (result-meanings result)))
       (update-result result
         #:score score
         #:meanings meanings))))
 (define (field->info field)
   ;; TODO: translate depending on target language
   (match field
     ("agric" "agriculture")
     ("anat" "anatomy")
     ("archeol" "archeology")
     ("archit" "architecture")
     ("art" "art, aesthetics")
     ("astron" "astronomy")
     ("audvid" "audiovisual")
     ("aviat" "aviation")
     ("baseb" "baseball")
     ("biochem" "biochemistry")
     ("biol" "biology")
     ("bot" "botany")
     ("Buddh" "Buddhism")
     ("bus" "business")
     ("chem" "chemistry")
     ("Christn" "Christianity")
     ("cloth" "clothing")
     ("comp" "computing")
     ("cryst" "crystallography")
     ("ecol" "ecology")
     ("econ" "economics")
     ("elec" "electricity, elec. eng.")
     ("electr" "electronics")
     ("embryo" "embryology")
     ("engr" "engineering")
     ("ent" "entomology")
     ("finc" "finance")
     ("fish" "fishing")
     ("food" "food, cooking")
     ("gardn" "gardening, horticulture")
     ("genet" "genetics")
     ("geogr" "geography")
     ("geol" "geology")
     ("geom" "geometry")
     ("go" "go (game)")
     ("golf" "golf")
     ("gramm" "grammar")
     ("grmyth" "Greek mythology")
     ("hanaf" "hanafuda")
     ("horse" "horse racing")
     ("law" "law")
     ("ling" "linguistics")
     ("logic" "logic")
     ("MA" "martial arts")
     ("mahj" "mahjong")
     ("math" "mathematics")
     ("mech" "mechanical engineering")
     ("med" "medicine")
     ("met" "meteorology")
     ("mil" "military")
     ("music" "music")
     ("ornith" "ornithology")
     ("paleo" "paleontology")
     ("pathol" "pathology")
     ("pharm" "pharmacy")
     ("phil" "philosophy")
     ("photo" "photography")
     ("physics" "physics")
     ("physiol" "physiology")
     ("print" "printing")
     ("psy" "psychiatry")
     ("psych" "psychology")
     ("rail" "railway")
     ("Shinto" "Shinto")
     ("shogi" "shogi")
     ("sports" "sports")
     ("stat" "statistics")
     ("sumo" "sumo")
     ("telec" "telecommunications")
     ("tradem" "trademark")
     ("vidg" "video games")
     ("zool" "zoology")))
 (define (dial->info dial)
   (match dial
     ("bra" "Brazilian")
     ("hob" "Hokkaido-ben")
     ("ksb" "Kansai-ben")
     ("ktb" "Kantou-ben")
     ("kyb" "Kyoto-ben")
     ("kyu" "Kyuushuu-ben")
     ("nab" "Nagano-ben")
     ("osb" "Osaka-ben")
     ("rkb" "Ryuukyuu-ben")
     ("thb" "Touhoku-ben")
     ("tsb" "Tosa-ben")
     ("tsug" "Tsugaru-ben")))
 (define (misc->info misc)
   (match misc
     ("abbr" "abbreviation")
     ("arch" "archaism")
     ("char" "character")
     ("chn" "children's language")
     ("col" "colloquialism")
     ("company" "company name")
     ("creat" "creature")
     ("dated" "dated term")
     ("dei" "deity")
     ("derog" "derogatory")
     ("doc" "document")
     ("ev" "event")
     ("fam" "familiar language")
     ("fem" "female term or language")
     ("fict" "fiction")
     ("form" "formal or literary term")
     ("given" "given name or forename, gender not specified")
     ("group" "group")
     ("hist" "historical term")
     ("hon" "honorific or respectful (sonkeigo) language")
     ("hum" "humble (kenjougo) language")
     ("id" "idiomatic expression")
     ("joc" "jocular, humorous term")
     ("leg" "legend")
     ("m-sl" "manga slang")
     ("male" "male term or language")
     ("myth" "mythology")
     ("net-sl" "Internet slang")
     ("obj" "object")
     ("obs" "obsolete term")
     ("obsc" "obscure term")
     ("on-mim" "onomatopoeic or mimetic word")
     ("organization" "organization name")
     ("oth" "other")
     ("person" "full name of a particular person")
     ("place" "place name")
     ("poet" "poetical term")
     ("pol" "polite (teineigo) language")
     ("product" "product name")
     ("proverb" "proverb")
     ("quote" "quotation")
     ("rare" "rare")
     ("relig" "religion")
     ("sens" "sensitive")
     ("serv" "service")
     ("sl" "slang")
     ("station" "railway station")
     ("surname" "family or surname")
     ("uk" "word usually written using kana alone")
     ("unclass" "unclassified name")
     ("vulg" "vulgar expression or word")
     ("work" "work of art, literature, music, etc. name")
     ("X" "rude or X-rated term")
     ("yoji" "yojijukugo")))
 (define (pos->info pos)
   (match pos
     ("adj-f" "noun or verb acting prenominally")
     ("adj-i" "adjective (keiyoushi)")
     ("adj-ix" "adjective (keiyoushi) - yoi/ii class")
     ("adj-kari" "'kari' adjective (archaic)")
     ("adj-ku" "'ku' adjective (archaic)")
     ("adj-na" "adjectival nouns or quasi-adjectives (keiyodoshi)")
     ("adj-nari" "archaic/formal form of na-adjective")
     ("adj-no" "nouns which may take the genitive case particle 'no'")
     ("adj-pn" "pre-noun adjectival (rentaishi)")
     ("adj-shiku" "'shiku' adjective (archaic)")
     ("adj-t" "'taru' adjective")
     ("adv" "adverb (fukushi)")
     ("adv-to" "adverb taking the 'to' particle")
     ("aux" "auxiliary")
     ("aux-adj" "auxiliary adjective")
     ("aux-v" "auxiliary verb")
     ("conj" "conjunction")
     ("cop" "copula")
     ("ctr" "counter")
     ("exp" "expression")
     ("int" "interjection (kandoushi)")
     ("n" "noun (common) (futsuumeishi)")
     ("n-adv" "adverbial noun (fukushitekimeishi)")
     ("n-pr" "proper noun")
     ("n-pref" "noun, used as a prefix")
     ("n-suf" "noun, used as a suffix")
     ("n-t" "noun (temporal) (jisoumeishi)")
     ("num" "numeric")
     ("pn" "pronoun")
     ("pref" "prefix")
     ("prt" "particle")
     ("suf" "suffix")
     ("unc" "unclassified")
     ("v-unspec" "verb unspecified")
     ("v1" "Ichidan verb")
     ("v1-s" "Ichidan verb - kureru special class")
     ("v2a-s" "Nidan verb with 'u' ending (archaic)")
     ("v2b-k" "Nidan verb (upper class) with 'bu' ending (archaic)")
     ("v2b-s" "Nidan verb (lower class) with 'bu' ending (archaic)")
     ("v2d-k" "Nidan verb (upper class) with 'dzu' ending (archaic)")
     ("v2d-s" "Nidan verb (lower class) with 'dzu' ending (archaic)")
     ("v2g-k" "Nidan verb (upper class) with 'gu' ending (archaic)")
     ("v2g-s" "Nidan verb (lower class) with 'gu' ending (archaic)")
     ("v2h-k" "Nidan verb (upper class) with 'hu/fu' ending (archaic)")
     ("v2h-s" "Nidan verb (lower class) with 'hu/fu' ending (archaic)")
     ("v2k-k" "Nidan verb (upper class) with 'ku' ending (archaic)")
     ("v2k-s" "Nidan verb (lower class) with 'ku' ending (archaic)")
     ("v2m-k" "Nidan verb (upper class) with 'mu' ending (archaic)")
     ("v2m-s" "Nidan verb (lower class) with 'mu' ending (archaic)")
     ("v2n-s" "Nidan verb (lower class) with 'nu' ending (archaic)")
     ("v2r-k" "Nidan verb (upper class) with 'ru' ending (archaic)")
     ("v2r-s" "Nidan verb (lower class) with 'ru' ending (archaic)")
     ("v2s-s" "Nidan verb (lower class) with 'su' ending (archaic)")
     ("v2t-k" "Nidan verb (upper class) with 'tsu' ending (archaic)")
     ("v2t-s" "Nidan verb (lower class) with 'tsu' ending (archaic)")
     ("v2w-s" "Nidan verb (lower class) with 'u' ending and 'we' conjugation (archaic)")
     ("v2y-k" "Nidan verb (upper class) with 'yu' ending (archaic)")
     ("v2y-s" "Nidan verb (lower class) with 'yu' ending (archaic)")
     ("v2z-s" "Nidan verb (lower class) with 'zu' ending (archaic)")
     ("v4b" "Yodan verb with 'bu' ending (archaic)")
     ("v4g" "Yodan verb with 'gu' ending (archaic)")
     ("v4h" "Yodan verb with 'hu/fu' ending (archaic)")
     ("v4k" "Yodan verb with 'ku' ending (archaic)")
     ("v4m" "Yodan verb with 'mu' ending (archaic)")
     ("v4n" "Yodan verb with 'nu' ending (archaic)")
     ("v4r" "Yodan verb with 'ru' ending (archaic)")
     ("v4s" "Yodan verb with 'su' ending (archaic)")
     ("v4t" "Yodan verb with 'tsu' ending (archaic)")
     ("v5aru" "Godan verb - -aru special class")
     ("v5b" "Godan verb with 'bu' ending")
     ("v5g" "Godan verb with 'gu' ending")
     ("v5k" "Godan verb with 'ku' ending")
     ("v5k-s" "Godan verb - Iku/Yuku special class")
     ("v5m" "Godan verb with 'mu' ending")
     ("v5n" "Godan verb with 'nu' ending")
     ("v5r" "Godan verb with 'ru' ending")
     ("v5r-i" "Godan verb with 'ru' ending (irregular verb)")
     ("v5s" "Godan verb with 'su' ending")
     ("v5t" "Godan verb with 'tsu' ending")
     ("v5u" "Godan verb with 'u' ending")
     ("v5u-s" "Godan verb with 'u' ending (special class)")
     ("v5uru" "Godan verb - Uru old class verb (old form of Eru)")
     ("vi" "intransitive verb")
     ("vk" "Kuru verb - special class")
     ("vn" "irregular nu verb")
     ("vr" "irregular ru verb, plain form ends with -ri")
     ("vs" "noun or participle which takes the aux. verb suru")
     ("vs-c" "su verb - precursor to the modern suru")
     ("vs-i" "suru verb - included")
     ("vs-s" "suru verb - special class")
     ("vt" "transitive verb")
     ("vz" "Ichidan verb - zuru verb (alternative form of -jiru verbs)")))
 (define (re_inf->info i)
   (match i
     ("gikun" "gikun (meaning as reading) or jukujikun (special kanji reading)")
     ("ik" "word containing irregular kana usage")
     ("ok" "out-dated or obsolete kana usage")
     ("uK" "word usually written using kanji alone")))
 (define (sxml->element lst elem frq)
   (match elem
     ('ent_seq "")
     ('ke_pri "")
     ('re_nokanji "")
     ('re_pri "")
     ('ke_inf "")
     ('misc (if (and (= (length lst) 1) (string? (car lst)))
                (misc->info (car lst))
                (throw 'invalid-misc lst)))
     ('re_restr (if (and (= (length lst) 1) (string? (car lst)))
                    `(limit ,(car lst))
                    (throw 'invalid-re_restr lst)))
     ('keb (if (and (= (length lst) 1) (string? (car lst)))
               `(kanji ,(car lst))
               (throw 'invalid-keb lst)))
     ('s_inf (if (null? (filter (lambda (s) (not (string? s))) lst))
                 `(info ,(apply string-append lst))
                 (throw 'invalid-s_inf lst)))
     ('dial (if (and (= (length lst) 1) (string? (car lst)))
                (dial->info (car lst))
                (throw 'invalid-dial lst)))
     ('re_inf (if (and (= (length lst) 1) (string? (car lst)))
                  (re_inf->info (car lst))
                  (throw 'invalid-re_inf lst)))
     ('stagk (if (and (= (length lst) 1) (string? (car lst)))
                 `(limit ,(car lst))
                 (throw 'invalid-stagk lst)))
     ('stagr (if (and (= (length lst) 1) (string? (car lst)))
                 `(limit ,(car lst))
                 (throw 'invalid-stagr lst)))
     ('field (if (and (= (length lst) 1) (string? (car lst)))
                 (field->info (car lst))
                 (throw 'invalid-field lst)))
     ('ant (if (and (= (length lst) 1) (string? (car lst)))
               `(ref ,(car lst))
               (throw 'invalid-ant lst)))
     ('reb (if (and (= (length lst) 1) (string? (car lst)))
               `(reading ,(car lst))
               (throw 'invalid-reb lst)))
     ('r_ele (sxml->reading lst))
     ('k_ele (car (filter list? lst)))
     ('pos (if (and (= (length lst) 1) (string? (car lst)))
               (pos->info (car lst))
               (throw 'invalid-pos lst)))
     ('xref (if (and (= (length lst) 1) (string? (car lst)))
                `(ref ,(car lst))
                (throw 'invalid-xref lst)))
     ('gloss (cons
               `(gloss ,(apply string-append (filter string? lst)))
               (filter list? lst)))
     ('lsource (sxml->source lst))
     ('sense (sxml->meaning lst))
     ('entry (sxml->result lst frq))))
 (define (create-parser frq)
   (ssax:make-parser
     NEW-LEVEL-SEED
     (lambda (elem-gi attributes namespaces expected-content seed)
       (map
         (match-lambda
           ((k . v) (list k v)))
         (filter
           (match-lambda
             ((k . v) (not (member k '(g_type)))))
           attributes)))
     FINISH-ELEMENT
     (lambda (elem-gi attributes namespaces parent-seed seed)
       (if (equal? elem-gi 'JMdict)
           seed
           (let* ((seed (reverse seed))
                  (element (sxml->element seed elem-gi frq)))
             (cons element parent-seed))))
     CHAR-DATA-HANDLER
     (lambda (string1 string2 seed)
       (cons (string-append string1 string2) seed))))
 (define (xml->results port frq)
   (let ((results (filter result? ((create-parser frq) port '()))))
     (sort-results results)))

modules/nani/result/result.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani result result)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-9)
   #:use-module (nani encoding serialize)
   #:use-module (nani encoding trie)
   #:use-module (nani encoding huffman)
   #:export (make-result
             result?
             result-position
             result-position-set!
             result-score
             result-kanjis
             result-readings
             result-meanings
             make-reading
             reading?
             reading-kanjis
             reading-info
             reading-readings
             make-meaning
             meaning?
             meaning-references
             meaning-limits
             meaning-sources
             meaning-infos
             meaning-glosses
             meaning-language
             make-source
             source?
             source-content
             source-wasei?
             source-lang
             update-result
             update-reading
             update-meaning
             update-source
             serialize-result result-size
             serialize-reading reading-size
             serialize-meaning meaning-size
             serialize-source source-size
             serialize-dictionary
             dictionary-entry-count
             sort-results))
 (define-record-type result
   (make-result position score kanjis readings meanings)
   result?
   (position result-position result-position-set!) ; integer
   (score result-score) ; integer
   (kanjis result-kanjis) ; string-list
   (readings result-readings) ; reanding-list
   (meanings result-meanings)) ; meaning-list
 (define-record-type reading
   (make-reading kanjis info readings)
   reading?
   (kanjis reading-kanjis) ; string-list
   (info reading-info) ; string-list
   (readings reading-readings)) ; string-list
 (define-record-type meaning
   (make-meaning references limits sources infos glosses language)
   meaning?
   (references meaning-references) ; string-list
   (limits meaning-limits) ; string-list
   (sources meaning-sources) ; source-list
   (infos meaning-infos) ; string-list
   (glosses meaning-glosses) ; string-list
   (language meaning-language)) ; string
 (define-record-type source
   (make-source content wasei? lang)
   source?
   (content source-content) ; string-list
   (wasei? source-wasei?) ; boolean
   (lang source-lang)) ; string
 (define* (update-result result
            #:key (score (result-score result))
                  (kanjis (result-kanjis result))
                  (readings (result-readings result))
                  (meanings (result-meanings result)))
   (make-result (result-position result) score kanjis readings meanings))
 (define* (update-reading reading
            #:key (kanjis (reading-kanjis reading))
                  (info (reading-info reading))
                  (readings (reading-readings reading)))
   (make-reading kanjis info readings))
 (define* (update-meaning meaning
            #:key (references (meaning-references meaning))
                  (limits (meaning-limits meaning))
                  (sources (meaning-sources meaning))
                  (infos (meaning-infos meaning))
                  (glosses (meaning-glosses meaning))
                  (language (meaning-language meaning)))
   (make-meaning references limits sources infos glosses language))
 (define* (update-source source
            #:key (content (source-content source))
                  (wasei? (source-wasei? source))
                  (lang (source-lang source)))
   (make-source content wasei? lang))
 ;; Note how sources are not compressed, that's because they contain more weird characters
 ;; and represent only a very small fraction of the content, even after compression.
 (define (serialize-source source pos bv)
   (when (not (source? source)) (throw 'not-source source))
   (let* ((pos ((serialize-list serialize-string) (source-content source) pos bv))
          (pos (serialize-boolean (source-wasei? source) pos bv))
          (pos (serialize-string (source-lang source) pos bv)))
     pos))
 (define (source-size source)
   (when (not (source? source)) (throw 'not-source source))
   (+ ((list-size string-size) (source-content source))
      (boolean-size (source-wasei? source))
      (string-size (source-lang source))))
 (define (serialize-reading reading-huffman-code)
   (lambda (reading pos bv)
     (when (not (reading? reading)) (throw 'not-reading reading))
     (let* ((pos ((serialize-list serialize-string) (reading-kanjis reading) pos bv))
            (pos ((serialize-list serialize-string) (reading-info reading) pos bv))
            (pos ((serialize-list (serialize-huffman-string reading-huffman-code))
                  (reading-readings reading) pos bv)))
       pos)))
 (define (reading-size reading-huffman-code)
   (lambda (reading)
     (when (not (reading? reading)) (throw 'not-reading reading))
     (+ ((list-size string-size) (reading-kanjis reading))
        ((list-size string-size) (reading-info reading))
        ((list-size (huffman-string-size reading-huffman-code)) (reading-readings reading)))))
 (define (serialize-meaning meaning-huffman-code)
   (lambda (meaning pos bv)
     (when (not (meaning? meaning)) (throw 'not-meaning meaning))
     (let* ((pos ((serialize-list serialize-string) (meaning-references meaning) pos bv))
            (pos ((serialize-list serialize-string) (meaning-limits meaning) pos bv))
            (pos ((serialize-list serialize-source) (meaning-sources meaning) pos bv))
            (pos ((serialize-list (serialize-huffman-string meaning-huffman-code))
                  (meaning-infos meaning) pos bv))
            (pos ((serialize-list (serialize-huffman-string meaning-huffman-code))
                  (meaning-glosses meaning) pos bv))
            (pos (serialize-string (meaning-language meaning) pos bv)))
       pos)))
 (define (meaning-size meaning-huffman-code)
   (lambda (meaning)
     (when (not (meaning? meaning)) (throw 'not-meaning meaning))
     (+ ((list-size string-size) (meaning-references meaning))
        ((list-size string-size) (meaning-limits meaning))
        ((list-size source-size) (meaning-sources meaning))
        ((list-size (huffman-string-size meaning-huffman-code))
         (meaning-infos meaning))
        ((list-size (huffman-string-size meaning-huffman-code))
         (meaning-glosses meaning))
        (string-size (meaning-language meaning)))))
 (define (serialize-result kanji-huffman-code reading-huffman-code meaning-huffman-code)
   (lambda (result pos bv)
     (when (not (result? result)) (throw 'not-result result))
     (result-position-set! result pos)
     (let* ((pos ((serialize-list (serialize-huffman-string kanji-huffman-code))
                  (result-kanjis result) pos bv))
            (pos ((serialize-list (serialize-reading reading-huffman-code))
                  (result-readings result) pos bv))
            (pos ((serialize-list (serialize-meaning meaning-huffman-code))
                  (result-meanings result) pos bv))
            (pos (serialize-char (result-score result) pos bv)))
       pos)))
 (define (result-size kanji-huffman-code reading-huffman-code meaning-huffman-code)
   (lambda (result)
     (when (not (result? result)) (throw 'not-result result))
     (+ ((list-size (huffman-string-size kanji-huffman-code)) (result-kanjis result))
        ((list-size (reading-size reading-huffman-code)) (result-readings result))
        ((list-size (meaning-size meaning-huffman-code)) (result-meanings result)))))
 ;; creating tries
 (define (make-key key)
   (apply append
     (map
       (lambda (c)
         (list (quotient c 16) (modulo c 16)))
       (bytevector->u8-list (string->utf8 key)))))
 (define (make-kanji-trie results)
   (let ((trie (make-empty-trie)))
     (let loop ((results results) (i 0))
       (if (null? results)
         (compress-trie trie)
         (begin
           (for-each
             (lambda (key)
               (add-to-trie! trie (make-key key) i))
             (result-kanjis (car results)))
           (loop (cdr results) (+ i 1)))))))
 (define (make-reading-trie results)
   (let ((trie (make-empty-trie)))
     (let loop ((results results) (i 0))
       (if (null? results)
         (compress-trie trie)
         (begin
           (for-each
             (lambda (reading)
               (for-each
                 (lambda (key)
                   (add-to-trie! trie (make-key key) i))
                 (reading-readings reading)))
             (result-readings (car results)))
           (loop (cdr results) (+ i 1)))))))
 (define (make-meaning-trie results)
   (let ((trie (make-empty-trie)))
     (let loop ((results results) (i 0))
       (if (null? results)
         (compress-trie trie)
         (begin
           (for-each
             (lambda (meaning)
               (for-each
                 (lambda (key)
                   (add-to-trie! trie (make-key key) i))
                 (meaning-glosses meaning)))
             (result-meanings (car results)))
           (loop (cdr results) (+ i 1)))))))
 (define (update-trie-pos! trie results)
   (let* ((vals (trie-vals trie))
          (vals (map (lambda (i) (result-position (array-ref results i))) vals)))
     (trie-vals-set! trie vals))
   (for-each
     (match-lambda
       ((char . child)
        (update-trie-pos! child results)))
     (trie-transitions trie)))
 (define (serialize-dictionary results)
   (define kanji-huffman
     (let ((kanjis (apply append (map result-kanjis results))))
       (create-huffman kanjis)))
   (define kanji-huffman-code (huffman->code kanji-huffman))
   (define reading-huffman
     (let* ((readings (apply append (map result-readings results)))
            (readings (apply append (map reading-readings readings))))
       (create-huffman readings)))
   (define reading-huffman-code (huffman->code reading-huffman))
   (define meaning-huffman
     (let* ((meanings (apply append (map result-meanings results)))
            (infos (apply append (map meaning-infos meanings)))
            (glosses (apply append (map meaning-glosses meanings))))
       (create-huffman (append infos glosses))))
   (define meaning-huffman-code (huffman->code meaning-huffman))
   (define (trie-node-size trie)
     (apply + 1 (map trie-node-size (map cdr (trie-transitions trie)))))
   (let* ((header (string->utf8 "NANI_JMDICT003"))
          (header-size (bytevector-length header))
          (pointers (make-bytevector 16 0))
          (kanji-huffman-bv (serialize-huffman kanji-huffman))
          (kanji-huffman-size (bytevector-length kanji-huffman-bv))
          (reading-huffman-bv (serialize-huffman reading-huffman))
          (reading-huffman-size (bytevector-length reading-huffman-bv))
          (meaning-huffman-bv (serialize-huffman meaning-huffman))
          (meaning-huffman-size (bytevector-length meaning-huffman-bv))
          (serialize-trie (serialize-trie serialize-int int-size))
          (trie-size (trie-size int-size))
          (kanji-trie (make-kanji-trie results))
          (kanji-trie-size (trie-size kanji-trie))
          (reading-trie (make-reading-trie results))
          (reading-trie-size (trie-size reading-trie))
          (meaning-trie (make-meaning-trie results))
          (meaning-trie-size (trie-size meaning-trie))
          (trie-sizes (+ kanji-trie-size reading-trie-size meaning-trie-size))
          (results-size
            ((list-size (result-size kanji-huffman-code reading-huffman-code
                                     meaning-huffman-code)
                        #:size? #f)
             results))
          (huffman-size (+ reading-huffman-size meaning-huffman-size kanji-huffman-size))
          (pos-kanji (+ header-size 16 kanji-huffman-size reading-huffman-size
                        meaning-huffman-size results-size 4))
          (bv (make-bytevector (+ header-size 16 kanji-huffman-size
                                  reading-huffman-size
                                  meaning-huffman-size
                                  results-size 4 trie-sizes))))
     (format #t "Number of nodes in kanjis: ~a~%"
       (trie-node-size kanji-trie))
     (format #t "Number of nodes in readings: ~a~%"
       (trie-node-size reading-trie))
     (format #t "Number of nodes in meanings: ~a~%"
       (trie-node-size meaning-trie))
     ((serialize-list (serialize-result kanji-huffman-code reading-huffman-code
                                        meaning-huffman-code)
                      #:size? #f)
      results (+ header-size 16 huffman-size) bv)
     ;; Serializing results also updated result-pos for each of them
     (let ((results (list->array 1 results)))
       (update-trie-pos! kanji-trie results)
       (update-trie-pos! reading-trie results)
       (update-trie-pos! meaning-trie results))
     ;; number of entries
     (serialize-int (length results) (+ header-size 16 huffman-size results-size)
                    bv)
     (let* ((results (list->array 1 results))
            (pos pos-kanji)
            (pos (serialize-trie kanji-trie pos bv))
            (pos-reading pos)
            (pos (serialize-trie reading-trie pos bv))
            (pos-meaning pos)
            (pos (serialize-trie meaning-trie pos bv)))
       ;; Point to the trie structures
       (bytevector-u32-set!
         pointers 0
         (+ header-size 16 huffman-size results-size (int-size 0))
         (endianness big))
       ;; point to the kanji trie structure
       (bytevector-u32-set! pointers 4 pos-kanji (endianness big))
       ;; point to the reading trie structure
       (bytevector-u32-set! pointers 8 pos-reading (endianness big))
       ;; point to the meaning trie structure
       (bytevector-u32-set! pointers 12 pos-meaning (endianness big))
       ;; copy to result bytevector
       (bytevector-copy! header 0 bv 0 header-size)
       (bytevector-copy! pointers 0 bv header-size 16)
       (bytevector-copy! kanji-huffman-bv 0 bv (+ header-size 16) kanji-huffman-size)
       (bytevector-copy! reading-huffman-bv 0 bv
                         (+ header-size 16 kanji-huffman-size)
                         reading-huffman-size)
       (bytevector-copy! meaning-huffman-bv 0 bv
                         (+ header-size 16 kanji-huffman-size reading-huffman-size)
                         meaning-huffman-size)
       ;; give some feedback on the size of file's structures
       (format #t "huffmans are ~a bytes long~%" huffman-size)
       (format #t "results is ~a bytes long~%" results-size)
       (format #t "kanji trie is ~a bytes long~%" kanji-trie-size)
       (format #t "reading trie is ~a bytes long~%" reading-trie-size)
       (format #t "meaning trie is ~a bytes long~%" meaning-trie-size)
       bv)))
 (define (dictionary-entry-count file)
   (call-with-input-file file
     (lambda (port)
       (let* ((header (utf8->string (get-bytevector-n port 14)))
              (pointers (get-bytevector-n port 16))
              (end-pos (bytevector-u32-ref pointers 0 (endianness big))))
         (seek port (- end-pos 4) SEEK_SET)
         (bytevector-u32-ref (get-bytevector-n port 4) 0 (endianness big))))))
 (define (sort-results results)
   (define (get-string res)
     (if (null? (result-kanjis res))
         (car (reading-readings (car (result-readings res))))
         (car (result-kanjis res))))
   (sort
     results
     (lambda (a b)
       (cond
         ((> (result-score a) (result-score b)) #t)
         ((= (result-score a) (result-score b))
          (string>? (get-string a) (get-string b)))))))

modules/nani/result/wadoku.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani result wadoku)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (nani result frequency)
   #:use-module (nani result result)
   #:use-module (srfi srfi-9)
   #:use-module (sxml ssax)
   #:export (xml->results))
 (define (usg->infos lst)
   (let loop ((infos '()) (lst lst))
     (if (null? lst)
         infos
         (loop
           (match (car lst)
             (('reg . reg) (cons reg infos))
             (('type . type)
              (if (equal? type "abrev")
                  (cons type infos)
                  infos))
             ((? string? info) (cons info infos))
             (_ infos))
           (cdr lst)))))
 (define (ruigo->ref lst)
   (let loop ((ref #f) (lst lst))
     (match lst
       (() ref)
       ((('id id) lst ...)
        (loop id lst))
       (((a . b) lst ...)
        (loop (loop ref (list (list a b))) lst))
       (((? list? l) lst ...)
        (loop (loop ref l) lst)))))
 (define (merge-meanings s1 s2)
   (update-meaning s2
     #:references (append (meaning-references s1) (meaning-references s2))
     #:infos (append (meaning-infos s1) (meaning-infos s2))
     #:glosses (append (meaning-glosses s1) (meaning-glosses s2))))
 (define (sxml->meaning lst)
   (let loop ((meaning (make-meaning '() '() '() '() '() "ger")) (lst lst))
     (if (null? lst)
       meaning
       (loop
         (match (car lst)
           (#f meaning)
           ((? meaning? s)
            (merge-meanings s meaning))
           ((? source? s)
            (update-meaning meaning #:sources (cons s (meaning-sources meaning))))
           (('ref (? string? r))
            (update-meaning meaning #:references (cons r (meaning-references meaning))))
           (('info (? string? r))
            (update-meaning meaning #:infos (cons r (meaning-infos meaning))))
           (('infos (? string? r))
            (update-meaning meaning #:infos (cons r (meaning-infos meaning))))
           (('infos (? list? r))
            (update-meaning meaning #:infos (append r (meaning-infos meaning))))
           (('trans (? string? r))
            (update-meaning meaning #:glosses (cons (string-downcase r)
                                                (meaning-glosses meaning))))
           (('related . _) meaning)
           (('transcr . _) meaning)
           (('pitch . _) meaning)
           (((? symbol? s) v)
            (throw 'unknown-symbol s v))
           ((? list? l) (loop meaning l))
           ((? string? _) meaning))
         (cdr lst)))))
 ;; TODO
 (define (sxml->ref lst)
   (define (sxml->ref-name lst)
     (let loop ((result #f) (lst lst))
       (if (null? lst)
         result
         (loop
           (match (car lst)
             (('id . id) id)
             (((? symbol? s) . _) result)
             (((? symbol? s) _) result)
             ((? list? l) (loop result l))
             (_ result))
           (cdr lst)))))
   (let ((ref (sxml->ref-name lst)))
     (if (string? ref)
         `(ref ,ref)
         (throw 'no-ref ref 'from lst))))
 (define (sxml->source lst)
   (let loop ((source (make-source '() #f "")) (lst lst))
     (if (null? lst)
       source
       (loop
         (match (car lst)
           (('impli impli) (update-source source #:lang impli))
           (('foreign foreign)
            (update-source source
              #:content (if (list? foreign)
                            (append foreign (source-content source))
                            (cons foreign (source-content source)))))
           ((? list? l) (loop source l))
           (_ source))
         (cdr lst)))))
 (define (sxml->reading lst)
   (let loop ((reading (make-reading '() '() '())) (lst lst))
     (if (null? lst)
       reading
       (loop
         (match (car lst)
           (('reading r)
            (update-reading reading #:readings (cons r (reading-readings reading))))
           (_ reading))
         (cdr lst)))))
 (define (sxml->result sxml frq)
   (define (sxml->result-aux sxml)
     (let loop ((result (make-result 0 0 '() '() '())) (last-source #f) (lst sxml))
       (if (null? lst)
         result
         (match (car lst)
           (('kanji kanji)
            (loop
              (update-result result #:kanjis (cons kanji (result-kanjis result)))
              last-source (cdr lst)))
           ((? reading? reading)
            (loop
              (update-result result #:readings (cons reading (result-readings result)))
              last-source (cdr lst)))
           ((? meaning? meaning)
            (loop
              (update-result result
                #:meanings
                (cons
                  (if last-source
                      (update-meaning meaning
                        #:sources (cons last-source (meaning-sources meaning)))
                      meaning)
                  (result-meanings result)))
              last-source (cdr lst)))
           ((? list? l)
            (loop (loop result last-source l) last-source (cdr lst)))
           (_ (loop result last-source (cdr lst)))))))
   (let* ((result (sxml->result-aux sxml))
          (word (if (null? (result-kanjis result))
                    (car (reading-readings (car (result-readings result))))
                    (car (result-kanjis result))))
          (score (frequency->score frq word))
          (meanings (result-meanings result)))
     (update-result result
       #:score score
       #:meanings meanings)))
 (define (meishi->info lst)
   (match (assoc-ref lst 'suru)
     ("both" "N., mit suru intrans. od. trans.")
     ("intrans" "N., mit suru intrans.")
     ("trans" "N., mit suru trans.")))
 (define (keiyoushi->info lst)
   (cond
     ((equal? (assoc-ref lst 'ku) "true")
      "Adj. auf ???ku")
     ((equal? (assoc-ref lst 'shiku) "true")
      "Adj. auf -shiku")))
 (define (keiyoudoushi->info lst)
   (if (equal? (assoc-ref lst 'nari) "true")
       "Na.???Adj. mit nari"
       "Na.???Adj. mit na od. no"))
 (define (fukushi->info lst)
   (define (get attr)
     (match (assoc-ref lst attr)
       ("false" #f)
       ("true" #t)
       (v v)))
   (string-append
     "Adv"
     (if (get 'ni) ", mit ni und Adn. mit naru" "")
     (if (get 'to)
         (if (get 'naru)
             ", mit to und Adn. mit taru"
             ", mit to")
         "")
     (match (get 'suru)
       ("intrans" ", mit suru intrans. V.")
       ("trans" ", mit suru trans. V.")
       ("both" ", mit suru trans. od. intrans. V.")
       (_ ""))))
 (define (doushi->info lst)
   (define transitivity-str
     (match (assoc-ref lst 'transitivity)
       ("intrans" "intrans.")
       ("trans" "trans.")
       ("both" "trans. od. intrans.")))
   (define onbin (assoc-ref lst 'onbin))
   (match (assoc-ref lst 'level)
     ("kuru" (string-append "unregelm. " transitivity-str " V. auf ka"))
     ("ra" (string-append transitivity-str " V. auf -ra"))
     ("suru" (string-append transitivity-str " V. auf -suru"))
     ("1e" (string-append "1???st. " transitivity-str " V. auf -e"))
     ("1i" (string-append "1???st. " transitivity-str " V. auf -i"))
     ("2e" (string-append "2???st. " transitivity-str " V. auf -e bzw. -u"))
     ("2i" (string-append "2???st. " transitivity-str " V. auf -i bzw. -u"))
     ("4" (string-append "4???st. " transitivity-str " V."))
     ("5" (string-append "5-st. " transitivity-str " V."
             (match (assoc-ref lst 'godanrow)
               ("ba" (if onbin
                         " auf -ba mit regelm. Nasal-Onbin = ???nde"
                         " auf -ba"))
               ("ga" (if onbin
                         " auf -ga mit regelm. i-Onbin = ???ide"
                         " auf -ga"))
               ("ka_i_yu" (if onbin
                              " auf -ka mit Geminaten-Onbin = ???tte"
                              " auf -ka"))
               ("ka" (if onbin
                         " auf -ka mit i-Onbin = ???ite"
                         " auf -ka"))
               ("ma" (if onbin
                         " auf -ma regelm. Nasal-Onbin = ???nde"
                         " auf -ma"))
               ("na" (if onbin
                         " auf -na mit regelm. Nasal-Onbin = ???nde"
                         " auf -na"))
               ("ra_i" (if onbin
                           " auf -ra, Sonderform mit Reny????kei ???i"
                           " auf -ra"))
               ("ra" (if onbin
                         " auf -ra mit regelm. Geminaten-Onbin = ???tte"
                         " auf -ra"))
               ("sa" " auf -sa")
               ("ta" (if onbin
                         " auf -ta mit regelm. Geminaten-Onbin = ???tte"
                         " auf -ta"))
               ("wa" (if onbin
                         " auf -[w]a mit Geminaten-Onbin = ???tte"
                         " auf -[w]a"))
               ("wa_o" (if onbin
                           " auf -[w]a mit u-Onbin = ?????/??te"
                           " auf -[w]a"))
               (#f ""))))))
 (define (gram->info lst)
   (map
     (lambda (gram)
       (match gram
         (('daimeishi) "Pron.")
         (('doushi doushi ...) (doushi->info doushi))
         (('fukujoshi) "adv. Part.")
         (('fukushi) "Adv.")
         (('fukushi fukushi ...) (fukushi->info fukushi))
         (('jodoushi) "Hilfsv.")
         (('joshi) "Part.")
         (('kakarijoshi) "Themenpart.")
         (('kakujoshi) "Kasuspart.")
         (('kandoushi) "Interj.")
         (('kanji) "Kanji")
         (('keiyoudoushi) "Na.???Adj.")
         (('keiyoudoushi keiyoudoushi ...) (keiyoudoushi->info keiyoudoushi))
         (('keiyoushi) "Adj.")
         (('keiyoushi keiyoushi ...) (keiyoushi->info keiyoushi))
         (('meishi) "N.")
         (('meishi meishi ...) (meishi->info meishi))
         (('prefix) "Pr??f.")
         (('rengo) "Zus.")
         (('rentaishi) "Adn")
         (('setsuzokujoshi) "konjunktionale Part.")
         (('setsuzokushi) "Konj.")
         (('shuujoshi) "satzbeendende Part.")
         (('specialcharacter) "Sonderzeichen")
         (('suffix) "Suff.")
         (('wordcomponent) "Wortkomp.")))
     lst))
 (define (sxml->string lst)
   (define (sub-loop loop infos result lst l)
     (let ((result (loop infos result l)))
       (if (list? result)
           (loop (append infos (filter list? result))
                 (apply string-append (filter string? result))
                 lst)
           (loop infos result lst))))
   (let loop ((infos '()) (result "") (lst lst))
     (match lst
       (() (if (null? infos)
               result
               (append infos (list result))))
       ((? string? s)
        (loop infos (string-append result s) '()))
       (((? string? s) lst ...)
        (loop infos (string-append result s) lst))
       ((('prior . _) lst ...)
        (loop infos result lst))
       ((('options . _) lst ...)
        (loop infos result lst))
       ((('firstname . _) lst ...)
        (loop infos result lst))
       ((('ausn . _) lst ...)
        (loop infos result lst))
       ((('lang . _) lst ...)
        (loop infos result lst))
       ((('meta . _) lst ...)
        (loop infos result lst))
       ((('genki . genki) lst ...)
        ;(loop (cons `(info ,genki) infos) result lst))
        (loop infos result lst))
       ((('jlpt . jlpt) lst ...)
        (loop (cons `(info ,(string-append "jlpt-" jlpt)) infos) result lst))
       ((('ref . (? string? ref)) lst ...)
        (loop (cons `(ref ,ref) infos) result lst))
       ((('ref (? string? ref)) lst ...)
        (loop (cons `(ref ,ref) infos) result lst))
       ((('jap l) lst ...)
        (sub-loop loop infos result lst l))
       ((('foreign l) lst ...)
        (sub-loop loop infos result lst l))
       ((('transcr l) lst ...)
        (sub-loop loop infos result lst l))
       ((((? symbol? s) v) lst ...)
        (throw 'unsupported-symbol s v))
       ((((? symbol? s) . v) lst ...)
        (throw 'unsupported-symbol-pair s v))
       (((? list? l) lst ...)
        (sub-loop loop infos result lst l)))))
 (define (sxml->element lst elem frq)
   (let ((elem (match elem
                 ((_ . elem) elem)
                 (_ elem))))
     (match elem
       ('orth (let ((kanji (filter string? lst)))
                (if (null? kanji)
                    #f
                    `(kanji
                       ,(string-filter
                          (lambda (c)
                            ;; Remove characters that interfere with kanji
                            ;; based search
                            (not (member c '(#\??? #\??? #\??? #\??? #\??? #\??? #\???
                                             #\?? #\???))))
                          (car kanji))))))
       ('count #f)
       ('entry (sxml->result lst frq))
       ('hira `(reading ,(car lst)))
       ('hatsuon `(hatsuon ,(car lst)))
       ('accent `(pitch ,(car lst)))
       ('reading (sxml->reading lst))
       ('form lst)
       ('impli `(impli ,(car lst)))
       ('text (let loop ((text "") (lst lst))
                (match lst
                  (() text)
                  ((('hasPrecedingSpace . _) lst ...)
                   (loop (string-append " " text) lst))
                  ((('hasFollowingSpace . _) lst ...)
                   (string-append (loop text lst) " "))
                  (((? string? s) lst ...)
                   (loop (string-append text s) lst)))))
       ('famn (sxml->string lst))
       ('expl (sxml->string lst))
       ('expli (filter list? lst))
       ('abbrev (filter list? lst))
       ('token (filter string? lst))
       ('tr (sxml->string lst))
       ('transcr `(transcr ,lst))
       ('trans
         (append (filter list? lst)
                 (map (lambda (s) `(trans ,s)) (filter string? lst))))
       ('jap `(jap ,lst))
       ('emph lst)
       ('title (filter string? lst))
       ('transl (filter string? lst))
       ('topic (filter string? lst))
       ('iron (filter string? lst))
       ('specchar (filter string? lst))
       ('scientif (filter string? lst))
       ('wikide #f)
       ('wikija #f)
       ('link #f)
       ('ref (sxml->ref lst))
       ('sref (sxml->ref lst))
       ('etym (sxml->source lst))
       ('literal (sxml->string (list "???" (sxml->string lst) "???")))
       ('def (sxml->string (list "(" (sxml->string lst) ")")))
       ('date (sxml->string (list "(" (sxml->string lst) ")")))
       ('birthdeath (sxml->string (list "(" (sxml->string lst) ")")))
       ('descr (sxml->string (list "(" (sxml->string lst) ")")))
       ('bracket (sxml->string (list "[" (sxml->string lst) "]")))
       ('foreign (if (null? lst) #f `(foreign ,(car lst))))
       ('seasonword `(info ,(string-append "season: " (assoc-ref lst 'type))))
       ('usg `(infos . ,(usg->infos lst)))
       ('sense (sxml->meaning lst))
       ('steinhaus (let ((ref (sxml->string lst)))
                     (if (string? ref)
                         `(ref ,(sxml->string lst))
                         (throw 'not-steinhaus ref))))
       ('pos '()); TODO: actually find what info to use
       ('wordcomponent (cons 'wordcomponent lst))
       ('meishi (cons 'meishi lst))
       ('setsuzokushi (cons 'setsuzokushi lst))
       ('daimeishi (cons 'daimeishi lst))
       ('doushi (cons 'doushi lst))
       ('kandoushi (cons 'kandoushi lst))
       ('keiyoudoushi (cons 'keiyoudoushi lst))
       ('keiyoushi (cons 'keiyoushi lst))
       ('fukushi (cons 'fukushi lst))
       ('rengo (cons 'rengo lst))
       ('suffix (cons 'suffix lst))
       ('prefix (cons 'prefix lst))
       ('kanji (cons 'kanji lst))
       ('rentaishi (cons 'rentaishi lst))
       ('specialcharacter (cons 'specialcharacter lst))
       ('joshi (cons 'joshi lst))
       ('fukujoshi (cons 'fukujoshi lst))
       ('kakujoshi (cons 'kakujoshi lst))
       ('kakarijoshi (cons 'kakarijoshi lst))
       ('shuujoshi (cons 'shuujoshi lst))
       ('setsuzokujoshi (cons 'setsuzokujoshi lst))
       ('jokeiyoushi (cons 'jokeiyoushi lst))
       ('jodoushi (cons 'jodoushi lst))
       ('ruigos lst)
       ('ruigo (ruigo->ref lst))
       ('gramGrp (gram->info lst)))))
 (define (create-parser frq)
   (ssax:make-parser
     NEW-LEVEL-SEED
     (lambda (elem-gi attributes namespaces expected-content seed)
       attributes)
     FINISH-ELEMENT
     (lambda (elem-gi attributes namespaces parent-seed seed)
       (if (equal? elem-gi 'entries)
           seed
           (let* ((seed (reverse seed))
                  (element (sxml->element seed elem-gi frq)))
             (cons element parent-seed))))
     CHAR-DATA-HANDLER
     (lambda (string1 string2 seed)
       (cons (string-append string1 string2) seed))))
 (define (xml->results port frq)
   (let ((results (filter result? ((create-parser frq) port '()))))
     (sort-results results)))

modules/nani/serialize.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani serialize)
   #:use-module (rnrs bytevectors)
   #:export (merge-bvs
             serialize-list list-size
             serialize-char char-size
             serialize-int int-size
             serialize-boolean boolean-size
             serialize-string string-size))
 (define (merge-bvs bvs)
   (let* ((size (apply + (map bytevector-length bvs)))
          (bv (make-bytevector size 0)))
     (let loop ((bvs bvs) (pos 0))
       (unless (null? bvs)
         (let ((sz (bytevector-length (car bvs))))
           (bytevector-copy! (car bvs) 0 bv pos sz)
           (loop (cdr bvs) (+ pos sz)))))
     bv))
 (define* (serialize-list lst serialize pos bv #:key (size? #t))
   (when (not (list? lst)) (throw 'not-list lst))
   (when size?
     (bytevector-u16-set! bv pos (length lst) (endianness big)))
   (let loop ((lst lst) (pos (+ pos (if size? 2 0))))
     (if (null? lst)
       pos
       (loop (cdr lst) (serialize (car lst) pos bv)))))
 (define* (list-size lst size #:key (size? #t))
   (when (not (list? lst)) (throw 'not-list lst))
   (apply + (if size? 2 0) (map size lst)))
 (define (serialize-char int pos bv)
   (bytevector-u8-set! bv pos int)
   (+ pos 1))
 (define char-size (const 1))
 (define (serialize-int int pos bv)
   (bytevector-u32-set! bv pos int (endianness big))
   (+ pos 4))
 (define int-size (const 4))
 (define (serialize-boolean bool pos bv)
   (bytevector-u8-set! bv pos (if bool 1 0))
   (+ pos 1))
 (define boolean-size (const 1))
 (define (serialize-string str pos bv)
   (let ((sbv (string->utf8 str)))
     (bytevector-copy! sbv 0 bv pos (bytevector-length sbv))
     (bytevector-u8-set! bv (+ pos (bytevector-length sbv)) 0)
     (+ pos 1 (bytevector-length sbv))))
 (define (string-size str)
   (let ((sbv (string->utf8 str)))
     (+ 1 (bytevector-length sbv))))

modules/nani/tags.scm unknown status 2

 (define-module (nani tags)
   #:use-module (nani result)
   #:export (get-tag get-points))
 (define tags
   '("MA" "X" "abbr" "adj-i" "adj-ix" "adj-na" "adj-no" "adj-pn" "adj-t" "adj-f"
     "adv" "adv-to" "arch" "ateji" "aux" "aux-v" "aux-adj" "Buddh" "chem" "chn"
     "col" "comp" "conj" "cop" "ctr" "derog" "eK" "ek" "exp" "fam" "fem" "food"
     "geom" "gikun" "hon" "hum" "iK" "id" "ik" "int" "io" "iv" "ling" "m-sl"
     "male" "male-sl" "math" "meteor" "mil" "n" "n-adv" "n-suf" "n-pref" "n-t"
     "num" "oK" "obs" "obsc" "ok" "oik" "on-mim" "pn" "poet" "pol" "pref" "proverb"
     "prt" "physics" "quote" "rare" "sens" "sl" "suf" "uK" "uk" "unc" "yoji"
     "v1" "v1-s" "v2a-s" "v4h" "v4r" "v5aru" "v5b" "v5g" "v5k" "v5k-s" "v5m"
     "v5n" "v5r" "v5r-i" "v5s" "v5t" "v5u" "v5u-s" "v5uru" "vz" "vi" "vk" "vn"
     "vr" "vs" "vs-c" "vs-s" "vs-i" "kyb" "osb" "ksb" "ktb" "tsb" "thb" "tsug"
     "kyu" "rkb" "nab" "hob" "vt" "vulg" "adj-kari" "adj-ku" "adj-shiku"
     "adj-nari" "n-pr" "v-unspec" "v4k" "v4g" "v4s" "v4t" "v4n" "v4b" "v4m"
     "v2k-k" "v2g-k" "v2t-k" "v2d-k" "v2h-k" "v2b-k" "v2m-k" "v2y-k" "v2r-k"
     "v2k-s" "v2g-s" "v2s-s" "v2z-s" "v2t-s" "v2d-s" "v2n-s" "v2h-s" "v2b-s"
     "v2m-s" "v2y-s" "v2r-s" "v2w-s" "archit" "astron" "baseb" "biol" "bot"
     "bus" "econ" "engr" "finc" "geol" "law" "mahj" "med" "music" "Shinto"
     "shogi" "sports" "sumo" "zool" "joc" "anat" "Christn" "net-sl" "dated"
     "hist" "litf" "surname" "place" "unclass" "company" "product" "work"
     "person" "given" "station" "organization"
     ;; wadoku special
     "young" "thief" "secret" "baby" "stud" "sail" "fashion" "archeo"
     "rel" "color" "psy" "print" "aero" "politics" "anth" "biblio"
     "game" "agri" "alco" "demo" "train" "philo" "ethno" "photo" "trans"
     "telecom" "build" "sci" "school" "art" "hobby"
     "season-spring" "season-summer" "season-winter" "season-autumn"
     "season-newyear"
     "jlpt-1" "jlpt-2" "jlpt-3" "jlpt-4" "jlpt-5"
     "frq500" "frq1000" "frq2000" "frq5000" "frq10000" "frq20000"))
 (define (get-tag tag)
   (let ((val (member tag tags)))
     (if val (- (length val) 1) (throw 'unknown-tag tag))))
 (define (get-points result)
   (define (tag-point tag)
     (cond
       ;; frequency
       ((eq? tag (get-tag "frq500"))
 )
       ((eq? tag (get-tag "frq1000"))
 )
       ((eq? tag (get-tag "frq2000"))
 )
       ((eq? tag (get-tag "frq5000"))
 )
       ((eq? tag (get-tag "frq10000"))
 )
       ((eq? tag (get-tag "frq20000"))
 )
       ;; archaic term
       ((eq? tag (get-tag "arch"))
        -3)
       ;; children language
       ((eq? tag (get-tag "chn"))
        -1)
       ;; colloquialism
       ((eq? tag (get-tag "col"))
 )
       ;; expression
       ((eq? tag (get-tag "exp"))
 )
       ;; sonkeigo (honorific or respectful)
       ((eq? tag (get-tag "hon"))
        -1)
       ;; kenjougo (humble)
       ((eq? tag (get-tag "hum"))
        -1)
       ;; teineigo (polite)
       ((eq? tag (get-tag "pol"))
        -1)
       ;; irregular kanji
       ((eq? tag (get-tag "iK"))
        -2)
       ;; idiomatic expression
       ((eq? tag (get-tag "id"))
 )
       ;; slang
       ((member tag (list
                      (get-tag "sl")
                      (get-tag "m-sl")
                      (get-tag "male-sl")))
        -4)
       ;; outdated kanji
       ((eq? tag (get-tag "oK"))
        -2)
       ;; obsolete term
       ((eq? tag (get-tag "obs"))
        -5)
       ;; obscure term
       ((eq? tag (get-tag "obsc"))
        -10)
       ;; onomatopea
       ((eq? tag (get-tag "on-mim"))
 )
       ;; poetical term
       ((eq? tag (get-tag "poet"))
        -1)
       ((eq? tag (get-tag "proverb"))
 )
       ((eq? tag (get-tag "rare"))
        -3)
       ;; sensitive
       ((eq? tag (get-tag "sens"))
        -2)
       ;; dialect
       ((member tag (list
                      (get-tag "kyb")
                      (get-tag "osb")
                      (get-tag "ksb")
                      (get-tag "ktb")
                      (get-tag "tsb")
                      (get-tag "thb")
                      (get-tag "tsug")
                      (get-tag "kyu")
                      (get-tag "rkb")
                      (get-tag "nab")
                      (get-tag "hob")))
        -1)
       (else 0)))
   (let ((tags (apply append (map sense-tags (result-senses result)))))
     (apply + (map tag-point tags))))

modules/nani/trie.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani trie)
   #:use-module (nani serialize)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-9)
   #:export (make-trie
             trie?
             trie-position
             trie-position-set!
             trie-vals
             trie-vals-set!
             trie-transitions
             trie-transitions-set!
             make-empty-trie
             add-to-trie!
             compress-trie
             serialize-trie
             trie-size))
 (define-record-type trie
   (make-trie position vals transitions)
   trie?
   (position trie-position trie-position-set!) ; integer
   (vals trie-vals trie-vals-set!) ; list
   (transitions trie-transitions trie-transitions-set!)) ; array or alist
 (define (make-empty-trie)
   (make-trie 0 '() (make-array #f 16)))
 (define (add-to-trie! trie key value)
   (if (null? key)
     (trie-vals-set! trie (cons value (trie-vals trie)))
     (let ((next-trie (array-ref (trie-transitions trie) (car key))))
       (if next-trie
           (add-to-trie! next-trie (cdr key) value)
           (let ((next-trie (make-empty-trie)))
             (array-set! (trie-transitions trie) next-trie (car key))
             (add-to-trie! next-trie (cdr key) value))))))
 (define (convert-trie-transitions! trie)
   (define (get-new-transitions transitions)
     (let loop ((i 0) (tr '()))
       (if (= i 16)
         tr
         (let ((elem (array-ref transitions i)))
           (if elem
             (begin
               (convert-trie-transitions! elem)
               (loop (+ i 1) (cons (cons i elem) tr)))
             (loop (+ i 1) tr))))))
   (let* ((transitions (trie-transitions trie))
          (transitions (get-new-transitions transitions)))
     (trie-transitions-set! trie transitions)))
 (define (compress-trie trie)
   (define (compress-aux trie)
     (make-trie
       (trie-position trie)
       (trie-vals trie)
       (apply append
         (map
           (lambda (tr)
             (let ((trie (cdr tr)))
               (map
                 (lambda (tr2)
                   (cons (+ (car tr2) (* 16 (car tr)))
                         (compress-aux (cdr tr2))))
                 (trie-transitions trie))))
           (trie-transitions trie)))))
   (convert-trie-transitions! trie)
   (compress-aux trie))
 (define (pointer-size ptr)
 )
 (define (serialize-pointer ptr pos bv)
   (bytevector-u8-set! bv pos (car ptr))
   (bytevector-u32-set! bv (+ pos 1) (trie-position (cdr ptr)) (endianness big))
   (+ pos 5))
 (define (serialize-trie trie serialize size results pos)
   (define (serialize-trie-aux transitions pos)
     (let loop ((pos pos)
                (trs transitions)
                (bvs '()))
       (if (null? trs)
         (cons pos bvs)
         (let* ((next-trie (cdr (car trs)))
                (bv (get-trie-bv next-trie results pos))
                (pos (car bv))
                (bv (cdr bv)))
           (loop pos (cdr trs) (append bvs bv))))))
   (define (get-trie-bv trie results pos)
     (trie-position-set! trie pos)
     (let* ((vals-sz (size (trie-vals trie)))
            (trs-sz (list-size (trie-transitions trie) (const 5) #:size? #f))
            (sz (+ vals-sz 1 trs-sz))
            (bv (make-bytevector sz 0)))
       (serialize (trie-vals trie) 0 bv)
       (let* ((bvs (serialize-trie-aux
                     (trie-transitions trie)
                     (+ pos sz)))
              (next-pos (car bvs))
              (bvs (cdr bvs)))
         (bytevector-u8-set! bv vals-sz (length (trie-transitions trie)))
         (serialize-list (trie-transitions trie) serialize-pointer
                         (+ vals-sz 1) bv #:size? #f)
         (cons next-pos (cons bv bvs)))))
   (let* ((trie-bv (get-trie-bv trie results pos))
          (new-pos (car trie-bv))
          (trie-bv (merge-bvs (cdr trie-bv))))
     (bytevector-copy! trie-bv 0 results pos (bytevector-length trie-bv))
     new-pos))
 (define (trie-size trie size)
   (apply +
     (size (trie-vals trie))
     (list-size (trie-transitions trie) pointer-size #:size? #f)
     (map (lambda (trie) (trie-size trie size))
          (map cdr (trie-transitions trie)))))

modules/nani/wadoku/entities.scm unknown status 2

 (define-module (nani wadoku entities)
   #:use-module (nani result)
   #:use-module ((nani tags) #:prefix tag:)
   #:use-module (ice-9 match)
   #:export (get-tag hint->tag)
   #:re-export (tag:get-points))
 (define wadoku-entities
   `(("Aerodyn." . "aero")
     ("Agrochem." . "chem")
     ("??gypt. Gesch." . "hist")
     ("??gypt. Mythol." . "rel")
     ("Aktien" . "econ")
     ("Akupunktur" . "med")
     ("Akustik" . "music")
     ("American Football" . "sports")
     ("amerik. Gesch." . "hist")
     ("amerik. Pol." . "politics")
     ("amerik. Rechtsw." . "law")
     ("Anat." . "anat")
     ("Angeln" . "sports")
     ("Anime" . "work")
     ("Anthropol." . "anth")
     ("arab. Gesch." . "hist")
     ("Arch??ol." . "archeo")
     ("Archit." . "archit")
     ("Astrol." . "astron")
     ("Astron." . "astron")
     ("atmosph??r. Optik" . "physics")
     ("Atomphys." . "physics")
     ("Audio" . "music")
     ("Augenheilk." . "med")
     ("Autorennen" . "sports")
     ("Backw." . "food")
     ("Badminton" . "sports")
     ("Bahnhofsn." . "station")
     ("Bakteriol." . "biol")
     ("Ballet" . "music")
     ("Ballett" . "music")
     ("Ballsport" . "sports")
     ("Bankw." . "finc")
     ("Baseb." . "baseb")
     ("Baseball" . "baseb")
     ("Basketball" . "sports")
     ("Bauingenieurw." . "archit")
     ("Bautechnik" . "archit")
     ("Bauw." . "archit")
     ("Befestigungsw." . "archit")
     ("Beh??rde" . "law")
     ("Bergb." . "archit")
     ("Bergbau" . "archit")
     ("Bergn." . "place")
     ("Bergsteigen" . "sports")
     ("Bibel" . "Christn")
     ("Bibliotheksw." . "biblio")
     ("Bildhauerei" . "work")
     ("bild. Kunst" . "work")
     ("Billard" . "game")
     ("Biochem." . "biol")
     ("Biol." . "biol")
     ("Bodenkunde" . "agri")
     ("Bogenschie??en" . "sports")
     ("B??rse" . "econ")
     ("Bot." . "bot")
     ("Bowling" . "sports")
     ("Boxen" . "sports")
     ("Brauereiw." . "alco")
     ("Brettspiel" . "game")
     ("brit. Gesch." . "hist")
     ("brit. Rechtsw." . "law")
     ("Br??ckenbau" . "engr")
     ("Bsp." . "exp")
     ("Buchbinden" . "print")
     ("B??chereiw." . "biblio")
     ("Buchtitel" . "work")
     ("Buchw." . "biblio")
     ("Buddh." . "Buddh")
     ("Bud??" . "MA")
     ("B??d??" . "MA")
     ("Chem." . "chem")
     ("chin. Arch??ol." . "archeo")
     ("chin. Astron." . "astron")
     ("chin. Gesch." . "hist")
     ("chin. Gramm." . "ling")
     ("chin. Literaturw." . "work")
     ("chin. Mus." . "music")
     ("chin. Musikinstr." . "music")
     ("chin. Mythol." . "rel")
     ("chin. Philos." . "rel")
     ("chin. Phon." . "ling")
     ("chin. Poet." . "poet")
     ("chin. Pol." . "politics")
     ("chin. Theater" . "work")
     ("Chirurgie" . "med")
     ("Christent." . "Christn")
     ("Cocktail" . "alco")
     ("Computerling." . "comp")
     ("Curling" . "sports")
     ("Dammbau" . "engr")
     ("Demogr." . "demo")
     ("Diplomat." . "politics")
     ("Druckw." . "print")
     ("dtsch. Gesch." . "hist")
     ("dtsch. Gramm." . "ling")
     ("EDV" . "comp")
     ("Einzel-Kanji" . "ling")
     ("Eisenb." . "engr")
     ("Eishockey" . "sports")
     ("Eiskunstl." . "sports")
     ("Eiskunstlauf" . "sports")
     ("Eisschnelllauf" . "sports")
     ("Elektrochem." . "chem")
     ("Elektrot." . "engr")
     ("Embryol." . "biol")
     ("engl. Gesch." . "hist")
     ("Entwicklungsphysiol." . "biol")
     ("Entwicklungspsychol." . "psy")
     ("Ergonomie" . "engr")
     ("Ethik" . "philo")
     ("Ethnol." . "ethno")
     ("europ. Gesch." . "hist")
     ("Fahrrad" . "sports")
     ("Familienn." . "surname")
     ("Familienn.." . "surname")
     ("Farbe" . "color")
     ("F??rberei" . "build")
     ("Fechten" . "build")
     ("Fertigungstechnik" . "engr")
     ("Film" . "work")
     ("Filmtitel" . "work")
     ("Finanzw." . "finc")
     ("Firmenn." . "company")
     ("Fischerei" . "sports")
     ("Fischk." . "food")
     ("Flugw." . "engr")
     ("Flussn." . "place")
     ("Forstw." . "bot")
     ("Fotog." . "photo")
     ("Frachtw." . "trans")
     ("franz. Gesch." . "hist")
     ("Frisur" . "fashion")
     ("Funkt." . "physics")
     ("Fu??ball" . "sports")
     ("Gagaku" . "music")
     ("Garten" . "bot")
     ("Gartenk." . "bot")
     ("Gateball" . "sports")
     ("Gebietsn." . "place")
     ("Geldw." . "finc")
     ("Genetik" . "biol")
     ("Geogr." . "place")
     ("Geol." . "geol")
     ("Geom." . "geom")
     ("Geophys." . "physics")
     ("Gerberei" . "build")
     ("Gesch." . "hist")
     ("Gewichtheben" . "sports")
     ("Glasherst." . "build")
     ("Glaziol." . "sci")
     ("Go" . "game")
     ("Golf" . "sports")
     ("Gramm." . "ling")
     ("griech. Christent." . "Christn")
     ("griech. Gesch." . "hist")
     ("griech. Myth." . "rel")
     ("griech. Mythol." . "rel")
     ("griech. Theat." . "work")
     ("Gymnastik" . "sports")
     ("Handball" . "sports")
     ("Handel" . "econ")
     ("Handwerkskunst" . "build")
     ("Heraldik" . "sci")
     ("Hindu." . "rel")
     ("Hochsprung" . "sports")
     ("Hockey" . "sports")
     ("Holzbau" . "engr")
     ("Holzbearb." . "engr")
     ("Holzschnitt" . "engr")
     ("Hunderasse" . "zool")
     ("Hydrodynamik" . "physics")
     ("I Ging" . "rel")
     ("Ikebana" . "build")
     ("Immunol." . "med")
     ("ind. Gesch." . "hist")
     ("indian. Mythol." . "rel")
     ("ind. Mythol." . "rel")
     ("indones. Gesch." . "hist")
     ("ind. Philos." . "philo")
     ("Insektenk." . "zool")
     ("Inseln." . "place")
     ("Internet" . "comp")
     ("Islam" . "rel")
     ("islam. Mythol." . "rel")
     ("islam. Rechtsw." . "law")
     ("islam. Rel." . "rel")
     ("israel. Gesch." . "hist")
     ("ital. Gesch." . "hist")
     ("japan. Archit." . "archit")
     ("japan. Astrologie" . "aston")
     ("japan. bild. Kunst" . "work")
     ("japan. Christent." . "Christn")
     ("japan. Gesch." . "hist")
     ("japan. Gramm." . "ling")
     ("japan. Literaturw." . "work")
     ("japan. Med." . "med")
     ("japan. Mus." . "music")
     ("japan. Mythol." . "rel")
     ("japan. Philos." . "philo")
     ("japan. Pol." . "politics")
     ("japan. Schwimmen" . "sports")
     ("japan. Soziol." . "sci")
     ("japan. Sprachw." . "ling")
     ("J??ruri" . "music")
     ("Judent." . "rel")
     ("J??d??" . "MA")
     ("Kabuki" . "music")
     ("Kagura" . "music")
     ("Kalligraphie" . "build")
     ("Kanbun" . "ling")
     ("Kanji" . "ling")
     ("Kanp??" . "med")
     ("Karten" . "game")
     ("Kartenspiel" . "game")
     ("Kartogr." . "place")
     ("kath. Christent." . "Christn")
     ("Kend??" . "MA")
     ("Keramik" . "build")
     ("Kernphys." . "physics")
     ("Kfz-W." . "engr")
     ("KI" . "comp")
     ("Kleidung" . "fashion")
     ("Kochk." . "food")
     ("Konditoreiw." . "food")
     ("Konfuz." . "rel")
     ("korean. Gesch." . "hist")
     ("korean. Rel." . "rel")
     ("korean. Theater" . "work")
     ("Kosmetik" . "fashion")
     ("Kricket" . "sports")
     ("Kristallogr." . "physics")
     ("Krocket" . "sports")
     ("Kunst" . "work")
     ("Kunstgesch." . "hist")
     ("Kunst??? und Turmsprung" . "build")
     ("Ky??gen" . "music")
     ("Lack" . "work")
     ("L??ndern." . "place")
     ("Landw." . "agri")
     ("Leichtathl." . "sports")
     ("Liedtitel" . "work")
     ("Literaturw." . "work")
     ("Logik" . "math")
     ("Luftf." . "aero")
     ("Machinenb." . "engr")
     ("Mah-Jongg" . "mahj")
     ("Management" . "bus")
     ("Manga" . "work")
     ("m??nnl. Name" . "given")
     ("m??nnl. Vorn." . "given")
     ("m??nnl. Vorname" . "given")
     ("Mantik" . "rel")
     ("Marine" . "sail")
     ("Marketing" . "bus")
     ("Maschinenb." . "engr")
     ("Ma??" . "engr")
     ("Math." . "math")
     ("Mech." . "physics")
     ("Med." . "med")
     ("Meeresk." . "place")
     ("Meeresn." . "place")
     ("Meinungsforschung" . "politics")
     ("Messw." . "hobby")
     ("Metall." . "engr")
     ("Metallbearb." . "engr")
     ("Metallguss" . "engr")
     ("Meteor." . "meteor")
     ("mexikan. Kochk." . "food")
     ("Mikrobiol." . "biol")
     ("Milit." . "mil")
     ("Mineral." . "geol")
     ("M??belbau" . "build")
     ("Mode" . "fashion")
     ("Motorsport" . "sports")
     ("Mus." . "music")
     ("Muschelk." . "zool")
     ("Musikinstr." . "music")
     ("Mykol." . "bot")
     ("Mythol." . "rel")
     ("Nachrichtent." . "politics")
     ("N??hen" . "fashion")
     ("Naniwabushi" . "music")
     ("Naturmed." . "med")
     ("Naturph??n." . "physics")
     ("Naturphilos." . "philo")
     ("Neng??" . "hist")
     ("Netzwerktechnik" . "comp")
     ("Neurol." . "med")
     ("N??" . "music")
     ("nord. Mythol." . "rel")
     ("Numismatik" . "build")
     ("??kol." . "biol")
     ("Oper" . "music")
     ("Optik" . "physics")
     ("Org." . "organization")
     ("Origami" . "build")
     ("Ortsn." . "place")
     ("P??d." . "school")
     ("Pal??ontol." . "hist")
     ("Papierherst." . "build")
     ("Parapsych." . "psy")
     ("Patentw." . "engr")
     ("Pathol." . "med")
     ("pers. Gesch." . "hist")
     ("Pers??nlichk." . "person")
     ("Petrochem." . "chem")
     ("Pferderennen" . "sports")
     ("Pferdesport" . "sports")
     ("Pharm." . "med")
     ("Philos." . "philo")
     ("philos. Anthrop." . "anth")
     ("Phon." . "ling")
     ("Phys." . "physics")
     ("Physiol." . "anat")
     ("Poetik" . "poet")
     ("Pol." . "politics")
     ("Postw." . "telecom")
     ("Psych." . "psy")
     ("Quantenphys." . "physics")
     ("Radio" . "telecom")
     ("Radrennen" . "sports")
     ("Radsport" . "sports")
     ("Rakugo" . "music")
     ("Raumf." . "engr")
     ("Reaktort." . "engr")
     ("Rechnungsw." . "bus")
     ("Rechtsw." . "law")
     ("Redew." . "exp")
     ("Regelungstechnik" . "engr")
     ("Reiten" . "sports")
     ("Rel." . "rel")
     ("Rennsport" . "sports")
     ("Rhetorik" . "philo")
     ("Ringen" . "sports")
     ("r??m. Gesch." . "hist")
     ("r??m. Mythol." . "rel")
     ("Rudern" . "sports")
     ("Rugby" . "sports")
     ("Rundfunk" . "telecom")
     ("russ. Gesch." . "hist")
     ("R??stung" . "mil")
     ("Schach" . "game")
     ("Schie??sport" . "sports")
     ("Schiff" . "sail")
     ("Schiffbau" . "sail")
     ("Schifffahrt" . "sail")
     ("Schmuck" . "build")
     ("Schneckenk." . "zool")
     ("Schneiderei" . "fashion")
     ("Schuhe" . "fashion")
     ("Schule" . "school")
     ("Schwei??en" . "build")
     ("Schwert" . "mil")
     ("Schwimmen" . "sports")
     ("Seef." . "sail")
     ("Seen." . "place")
     ("Seerechtsw." . "law")
     ("Seew." . "sail")
     ("Segeln" . "sail")
     ("Seide" . "build")
     ("Seismol." . "physics")
     ("SF" . "work")
     ("Shingon" . "Buddh")
     ("Shint??" . "Shinto")
     ("Sh??gi" . "shogi")
     ("Ski" . "sports")
     ("Skispringen" . "sports")
     ("Softball" . "sports")
     ("Sozialpsych." . "psy")
     ("Soziol." . "sci")
     ("span. Gesch." . "hist")
     ("Spiel" . "game")
     ("Spiele-Titel" . "game")
     ("Spieltheorie" . "game")
     ("Spinnen" . "zool")
     ("Spinnenk." . "zool")
     ("Sport" . "sports")
     ("Sprache" . "ling")
     ("Sprachw." . "ling")
     ("Sprichw." . "ling")
     ("Stadtn." . "place")
     ("Stadtplanung" . "engr")
     ("Statistik" . "math")
     ("Steuerw." . "econ")
     ("Sticken" . "build")
     ("Stra??enbau" . "engr")
     ("Streckenkilometertafel" . "train")
     ("Stricken" . "build")
     ("Strukturalismus" . "philo")
     ("Sum??" . "sumo")
     ("Surfen" . "sports")
     ("Systemanalyse" . "engr")
     ("Systemtheorie" . "engr")
     ("taiwan. Pol." . "politics")
     ("Tanz" . "art")
     ("Tanzen" . "art")
     ("Taoismus" . "rel")
     ("Tauchen" . "sports")
     ("Technik" . "engr")
     ("Tee" . "hobby")
     ("Telegrafie" . "telecom")
     ("Telekom." . "telecom")
     ("Tempeln." . "place")
     ("Tennis" . "sports")
     ("Tenn??" . "surname")
     ("Textilt." . "engr")
     ("Theat." . "work")
     ("Theol." . "rel")
     ("tibet. Buddh." . "Buddh")
     ("Tiefb." . "engr")
     ("Tiermed." . "med")
     ("Tischtennis" . "sports")
     ("Tourismus" . "hobby")
     ("Tunnelbau" . "engr")
     ("t??rk. Gesch." . "hist")
     ("Turnen" . "sports")
     ("TV" . "telecom")
     ("TV-Prog." . "telecom")
     ("U-Bahn" . "train")
     ("Umwelt" . "biol")
     ("Univ.-N." . "place")
     ("Verhaltensbiol." . "biol")
     ("Verkehrsw." . "engr")
     ("Verlagsn." . "company")
     ("Verlagsw." . "econ")
     ("Versicherungsw." . "bus")
     ("Video" . "telecom")
     ("Videospiel" . "game")
     ("vietnam. Gesch." . "hist")
     ("Vogelk." . "zool")
     ("V??lkerk." . "ethno")
     ("V??lkerr." . "law")
     ("Volleyball" . "sports")
     ("Vorgesch." . "hist")
     ("VWL" . "econ")
     ("Waffenk." . "mil")
     ("Walfang" . "hobby")
     ("Wasserball" . "sports")
     ("Wasserbau" . "engr")
     ("Wassersport" . "sports")
     ("Weben" . "build")
     ("weibl. Name" . "given")
     ("weibl. Vorn." . "given")
     ("Weichtierk." . "zool")
     ("Wein" . "alco")
     ("Werbung" . "bus")
     ("Werktitel" . "work")
     ("Wintersport" . "sports")
     ("Wirtsch." . "econ")
     ("Wrestling" . "sports")
     ("Wz." . "exp")
     ("Yoga" . "sports")
     ("Z??hlw." . "finc")
     ("Zahnmed." . "med")
     ("Zeitschriftenn." . "work")
     ("Zeitungsn." . "work")
     ("Zeitungsw." . "print")
     ("Zellbiol." . "biol")
     ("Zen" . "rel")
     ("Zirkus" . "hobby")
     ("Zitat" . "exp")
     ("Zollw." . "bus")
     ("Zool." . "biol")))
 (define (hint->tag hint)
   (match hint
     ("Kansai-Dial." "ksb")
     ("Ky??to-Dial." "kyb")
     ("??saka-Dial." "osb")
     ("Kant??-Dial." "ktb")
     ("T??hoku-Dial." "thb")
     ("Tsugaru-Dial." "tsug")
     ("Ky??sh??-Dial." "kyu")
     ("Hokkaid??-Dial." "hob")
     ("altert??ml." "arch")
     ("arch." "arch")
     ("Edo-zeitl." "arch")
     ("ehrerb.-h??fl." "hon")
     ("h??fl.-ehrerb." "hon")
     ("besch.-h??fl." "hum")
     ("abwertend" "derog")
     ("etwas altmodisch" "obs")
     ("Gaunerjargon" "thief")
     ("Frauenspr. der Edo-Zeit" "arch")
     ("Geheimspr. der Gauner" "thief")
     ("hist." "hist")
     ("h??fl." "pol")
     ("kinderspr." "chn")
     ("M??nnersprache" "male")
     ("Medizinerjargon" "med")
     ("Milit??rjargon" "mil")
     ("obsol." "obs")
     ("onomat." "on-mim")
     ("poet." "poet")
     ("Polizeijargon" "law")
     ("Slang" "sl")
     ("veraltet" "arch")
     (_ #f)))
 (define (wadoku->tag-name wadoku-tag)
   (let ((tag (assoc-ref wadoku-entities wadoku-tag)))
     (or tag wadoku-tag)))
 (define (get-tag tag)
   (tag:get-tag (wadoku->tag-name tag)))

modules/nani/wadoku/pitch.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani wadoku pitch)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (nani frequency)
   #:use-module (nani huffman)
   #:use-module (nani result)
   #:use-module (nani trie)
   #:use-module (nani wadoku entities)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (sxml ssax)
   #:use-module (rnrs bytevectors)
   #:export (xml->pitch serialize-pitch pitch-entry-count))
 (define-record-type pitch
   (make-pitch kanjis accents)
   pitch?
   (kanjis  pitch-kanjis)
   (accents pitch-accents))
 (define (sxml->element lst elem)
   (let ((elem (match elem
                 ((_ . elem) elem)
                 (_ elem))))
     (match elem
       ('accent `(pitch ,(car lst)))
       ('orth (let ((kanji (filter string? lst)))
                (if (null? kanji) #f `(kanji . ,(car kanji)))))
       ('form
        `(form . ,(append-map (lambda (a) (if (list? a) a (list a))) lst)))
       ('reading (filter pair? lst))
       ('entry
         (let loop ((lst lst) (kanjis '()) (accents '()))
           (if (null? lst)
               (if (or (null? kanjis) (null? accents))
                   #f
                   (make-pitch kanjis accents))
               (match (car lst)
                 (('form . f) (loop (append f (cdr lst)) kanjis accents))
                 (('pitch . pitch) (loop (cdr lst) kanjis (cons pitch accents)))
                 (('kanji . kanji) (loop (cdr lst) (cons kanji kanjis) accents))
                 (_ (loop (cdr lst) kanjis accents))))))
       (_ #f))))
 (define parser
   (ssax:make-parser
     NEW-LEVEL-SEED
     (lambda (elem-gi attributes namespaces expected-content seed)
       attributes)
     FINISH-ELEMENT
     (lambda (elem-gi attributes namespaces parent-seed seed)
       (if (equal? elem-gi 'entries)
           seed
           (let* ((seed (reverse seed))
                  (element (sxml->element seed elem-gi)))
             (cons element parent-seed))))
     CHAR-DATA-HANDLER
     (lambda (string1 string2 seed)
       (cons (string-append string1 string2) seed))))
 (define (xml->pitch port)
   (filter pitch? (parser port '())))
 (define (make-trie-key key)
   (append-map
     (lambda (c)
       (list (quotient c 16) (modulo c 16)))
     (bytevector->u8-list (string->utf8 key))))
 (define (get-pitch-trie pitches)
   (let ((trie (make-empty-trie)))
     (for-each
       (lambda (pitch)
         (for-each
           (lambda (kanji)
             (for-each
               (lambda (accent)
                 (cond
                   ((string? accent)
                    (add-to-trie! trie (make-trie-key kanji) accent))
                   ((list? accent)
                    (add-to-trie! trie (make-trie-key kanji) (car accent)))
                   (else
                     (throw 'accent accent))))
               (pitch-accents pitch)))
           (pitch-kanjis pitch)))
       pitches)
     (compress-trie trie)))
 (define (collapse-vals! trie)
   (let ((transitions (trie-transitions trie))
         (vals (trie-vals trie)))
     (trie-vals-set! trie (string-join vals ", "))
     (for-each collapse-vals! (map cdr transitions))))
 (define (collect-vals trie)
   (let ((transitions (trie-transitions trie))
         (vals (trie-vals trie)))
     (cons vals (append-map collect-vals (map cdr transitions)))))
 (define (entry-number trie)
   (let ((transitions (trie-transitions trie))
         (vals (trie-vals trie)))
     (apply + (if (string-null? vals) 0 1)
            (map entry-number (map cdr transitions)))))
 (define (serialize-pitch pitches)
   (let ((trie (get-pitch-trie pitches)))
     (collapse-vals! trie)
     (let* ((huffman (create-huffman (collect-vals trie)))
            (code (huffman->code huffman))
            (entries (entry-number trie)))
       (let* ((header (string->utf8 "NANI_PITCH001"))
              (header-size (bytevector-length header))
              (huffman-bv (serialize-huffman huffman))
              (huffman-size (bytevector-length huffman-bv))
              (trie-size (trie-size trie (huffman-string-size code)))
              (result (make-bytevector (+ header-size 4 huffman-size trie-size))))
         (bytevector-copy! header 0 result 0 header-size)
         (bytevector-u32-set! result header-size entries (endianness big))
         (bytevector-copy! huffman-bv 0 result (+ header-size 4) huffman-size)
         (serialize-trie trie (serialize-huffman-string code)
                         (huffman-string-size code)
                         result (+ header-size 4 huffman-size))
         result))))
 (define (pitch-entry-count file)
   (call-with-input-file file
     (lambda (port)
       ;; header
       (get-bytevector-n port 13)
       ;; size
       (bytevector-u32-ref (get-bytevector-n port 4) 0 (endianness big)))))

modules/nani/wadoku/xml.scm unknown status 2

 ;;; Nani Project website
 ;;; Copyright ?? 2019 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (define-module (nani wadoku xml)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:use-module (nani frequency)
   #:use-module (nani result)
   #:use-module (nani wadoku entities)
   #:use-module (srfi srfi-9)
   #:use-module (sxml ssax)
   #:export (xml->results))
 (define-record-type usage
   (make-usage type reg content)
   usage?
   (type    usage-type)
   (reg     usage-reg)
   (content usage-content))
 (define (flatten lst)
   (match lst
     (() '())
     ((head lst ...)
      (if (list? head)
          (append (flatten head) (flatten lst))
          (cons head (flatten lst))))
     (lst (list lst))))
 (define* (update-usage usage #:key (type    (usage-type    usage))
                                    (reg     (usage-reg     usage))
                                    (content (usage-content usage)))
   (make-usage type reg content))
 ;; TODO
 (define (usage->tag usage)
   (let ((content (usage-content usage))
         (type (usage-type usage))
         (reg (usage-reg usage)))
     `(,@(if (string-null? content)
             (match type
               ("" '())
               ("time" '())
               ("hint" '())
               ("abrev" '(tag "abbr")))
             (match type
               ("dom" `((tag ,content)))
               ("time" `((tag "obs"))); always obsol.
               ("hint" (let ((tag (hint->tag content)))
                         (if tag `(tag ,tag) '())))))
       ,@(match reg
           ("" '())
           ("dial." '())
           ("lit" `((tag "litf")))
           ("kinderspr." `((tag "chn")))
           ("kleinkindspr." `((tag "baby")))
           ("jugendspr." `((tag "young")))
           ("besch.-h??fl." `((tag "hum")))
           ("coll" `((tag "col")))
           ("vulg." `((tag "vulg")))
           ("Slang" `((tag "sl")))
           ("poet." `((tag "poet")))
           ("hist." `((tag "hist")))
           ("hist" `((tag "hist")))
           ("obsol." `((tag "obs")))
           ("veraltet" `((tag "arch")))
           ("sch??lerspr." `((tag "stud")))
           ("studentenspr." `((tag "stud")))
           ("frauenspr." `((tag "fem")))
           ("gaunerspr." `((tag "thief")))
           ("geheimspr." `((tag "secret")))
           ("hofdamenspr." `((tag "fem") (tag "pol")))
           ("seemannsspr." `((tag "sail")))))))
 (define (usg->tag lst)
   (define (usg->usage lst)
     (let loop ((result (make-usage "" "" "")) (lst lst))
       (if (null? lst)
         result
         (loop
           (match (car lst)
             (('type . type) (update-usage result #:type type))
             (('reg . reg) (update-usage result #:reg reg))
             (((? symbol? s) . v)
              (throw 'unknow-usage-attr s v))
             ((? string? content) (update-usage result #:content content))
             ((? list? l) (loop result l))
             (_ result))
           (cdr lst)))))
   (usage->tag (usg->usage lst)))
 (define (ruigo->ref lst)
   (let loop ((ref #f) (lst lst))
     (match lst
       (() ref)
       ((('id id) lst ...)
        (loop id lst))
       (((a . b) lst ...)
        (loop (loop ref (list (list a b))) lst))
       (((? list? l) lst ...)
        (loop (loop ref l) lst)))))
 (define (merge-senses s1 s2)
   (update-sense s2
     #:references (append (sense-references s1) (sense-references s2))
     #:tags (append (sense-tags s1) (sense-tags s2))
     #:glosses (append (sense-glosses s1) (sense-glosses s2))))
 (define (sxml->sense lst)
   (let loop ((sense (make-sense '() '() '() '() '() '() "ger")) (lst lst))
     (if (null? lst)
       sense
       (loop
         (match (car lst)
           (#f sense)
           ((? sense? s)
            (merge-senses s sense))
           ((? source? s)
            (update-sense sense #:sources (cons s (sense-sources sense))))
           (('ref (? string? r))
            (update-sense sense #:references (cons r (sense-references sense))))
           (('tag (? string? r))
            (update-sense sense #:tags (cons (get-tag r) (sense-tags sense))))
           (('trans (? string? r))
            (update-sense sense #:glosses (cons r (sense-glosses sense))))
           (('related . _) sense)
           (('transcr . _) sense)
           (('pitch . _) sense)
           (((? symbol? s) v)
            (throw 'unknown-symbol s v))
           ((? list? l) (loop sense l))
           ((? string? _) sense))
         (cdr lst)))))
 ;; TODO
 (define (sxml->ref lst)
   (define (sxml->ref-name lst)
     (let loop ((result #f) (lst lst))
       (if (null? lst)
         result
         (loop
           (match (car lst)
             (('id . id) id)
             (((? symbol? s) . _) result)
             (((? symbol? s) _) result)
             ((? list? l) (loop result l))
             (_ result))
           (cdr lst)))))
   (let ((ref (sxml->ref-name lst)))
     (if (string? ref)
         `(ref ,ref)
         (throw 'no-ref ref 'from lst))))
 (define (sxml->source lst)
   (let loop ((source (make-source '() #f "" "")) (lst lst))
     (if (null? lst)
       source
       (loop
         (match (car lst)
           (('impli impli) (update-source source #:lang impli))
           (('foreign foreign)
            (update-source source
              #:content (if (list? foreign)
                            (append foreign (source-content source))
                            (cons foreign (source-content source)))))
           ((? list? l) (loop source l))
           (_ source))
         (cdr lst)))))
 (define (sxml->reading lst)
   (let loop ((reading (make-reading '() '() '())) (lst lst))
     (if (null? lst)
       reading
       (loop
         (match (car lst)
           (('reading r)
            (update-reading reading #:readings (cons r (reading-readings reading))))
           (_ reading))
         (cdr lst)))))
 (define (sxml->result sxml frq)
   (define (sxml->result-aux sxml)
     (let loop ((result (make-result 0 0 '() '() '())) (last-source #f) (lst sxml))
       (if (null? lst)
         result
         (match (car lst)
           (('kanji kanji)
            (loop
              (update-result result #:kanjis (cons kanji (result-kanjis result)))
              last-source (cdr lst)))
           ((? reading? reading)
            (loop
              (update-result result #:readings (cons reading (result-readings result)))
              last-source (cdr lst)))
           ((? sense? sense)
            (loop
              (update-result result
                #:senses
                (cons
                  (if last-source
                      (update-sense sense
                        #:sources (cons last-source (sense-sources sense)))
                      sense)
                  (result-senses result)))
              last-source (cdr lst)))
           ((? list? l)
            (loop (loop result last-source l) last-source (cdr lst)))
           (_ (loop result last-source (cdr lst)))))))
   (let* ((result (sxml->result-aux sxml))
          (word (if (null? (result-kanjis result))
                    (car (reading-readings (car (result-readings result))))
                    (car (result-kanjis result))))
          (entity (frequency-entity frq word))
          (sense1 (car (result-senses result)))
          (sense1 (if entity
                      (update-sense sense1
                        #:tags (cons (get-tag entity) (sense-tags sense1)))
                      sense1))
          (senses (cons sense1 (cdr (result-senses result)))))
     (update-result result
       #:points (tag:get-points (update-result result #:senses senses))
       #:senses senses)))
 (define (gram-tag lst)
   (map
     (lambda (attr)
       (match attr
         (('suru . suru)
          `(tag ,(string-append "suru-" suru)))
         (('ni . ni)
          `(tag ,(string-append "ni-" ni)))
         (('shiku . shiku)
          `(tag ,(string-append "shiku-" shiku)))
         (('ku . ku)
          `(tag ,(string-append "ku-" ku)))
         (('to . to)
          `(tag ,(string-append "to-" to)))
         (('no . no)
          `(tag ,(string-append "no-" no)))
         (('nari . nari)
          `(tag ,(string-append "nari-" nari)))
         (('taru . taru)
          `(tag ,(string-append "taru-" taru)))
         (('level . level)
          `(tag ,(string-append "level-" level)))
         (('godanrow . tr)
          `(tag ,(string-append "godanrow-" tr)))
         (('onbin . tr)
          `(tag ,(string-append "onbin-" tr)))
         (('transitivity . tr)
          `(tag ,(string-append "transitivity-" tr)))))
     lst))
 (define (sxml->string lst)
   (define (sub-loop loop tags result lst l)
     (let ((result (loop tags result l)))
       (if (list? result)
           (loop (append tags (filter list? result))
                 (apply string-append (filter string? result))
                 lst)
           (loop tags result lst))))
   (let loop ((tags '()) (result "") (lst lst))
     (match lst
       (() (if (null? tags)
               result
               (append tags (list result))))
       ((? string? s)
        (loop tags (string-append result s) '()))
       (((? string? s) lst ...)
        (loop tags (string-append result s) lst))
       ((('prior . _) lst ...)
        (loop tags result lst))
       ((('options . _) lst ...)
        (loop tags result lst))
       ((('firstname . _) lst ...)
        (loop tags result lst))
       ((('ausn . _) lst ...)
        (loop tags result lst))
       ((('lang . _) lst ...)
        (loop tags result lst))
       ((('meta . _) lst ...)
        (loop tags result lst))
       ((('genki . genki) lst ...)
        ;(loop (cons `(tag ,genki) tags) result lst))
        (loop tags result lst))
       ((('jlpt . jlpt) lst ...)
        (loop (cons `(tag ,(string-append "jlpt-" jlpt)) tags) result lst))
       ((('ref . (? string? ref)) lst ...)
        (loop (cons `(ref ,ref) tags) result lst))
       ((('ref (? string? ref)) lst ...)
        (loop (cons `(ref ,ref) tags) result lst))
       ((('jap l) lst ...)
        (sub-loop loop tags result lst l))
       ((('foreign l) lst ...)
        (sub-loop loop tags result lst l))
       ((('transcr l) lst ...)
        (sub-loop loop tags result lst l))
       ((((? symbol? s) v) lst ...)
        (throw 'unsupported-symbol s v))
       ((((? symbol? s) . v) lst ...)
        (throw 'unsupported-symbol-pair s v))
       (((? list? l) lst ...)
        (sub-loop loop tags result lst l)))))
 (define (sxml->element lst elem frq)
   (let ((elem (match elem
                 ((_ . elem) elem)
                 (_ elem))))
     (match elem
       ('orth (let ((kanji (filter string? lst)))
                (if (null? kanji) #f `(kanji ,(car kanji)))))
       ('entry (sxml->result lst frq))
       ('hira `(reading ,(car lst)))
       ('hatsuon `(hatsuon ,(car lst)))
       ('accent `(pitch ,(car lst)))
       ('reading (sxml->reading lst))
       ('form lst)
       ('impli `(impli ,(car lst)))
       ('text (let loop ((text "") (lst lst))
                (match lst
                  (() text)
                  ((('hasPrecedingSpace . _) lst ...)
                   (loop (string-append " " text) lst))
                  ((('hasFollowingSpace . _) lst ...)
                   (string-append (loop text lst) " "))
                  (((? string? s) lst ...)
                   (loop (string-append text s) lst)))))
       ('famn (sxml->string lst))
       ('expl (sxml->string lst))
       ('expli (filter list? lst))
       ('abbrev (filter list? lst))
       ('token (filter string? lst))
       ('tr (sxml->string lst))
       ('transcr `(transcr ,lst))
       ('trans
         (append (filter list? lst)
                 (map (lambda (s) `(trans ,s)) (filter string? lst))))
       ('jap `(jap ,lst))
       ('emph lst)
       ('title (filter string? lst))
       ('transl (filter string? lst))
       ('topic (filter string? lst))
       ('iron (filter string? lst))
       ('specchar (filter string? lst))
       ('scientif (filter string? lst))
       ('wikide #f)
       ('wikija #f)
       ('link #f)
       ('ref (sxml->ref lst))
       ('sref (sxml->ref lst))
       ('etym (sxml->source lst))
       ('literal (sxml->string (list "???" (sxml->string lst) "???")))
       ('def (sxml->string (list "(" (sxml->string lst) ")")))
       ('date (sxml->string (list "(" (sxml->string lst) ")")))
       ('birthdeath (sxml->string (list "(" (sxml->string lst) ")")))
       ('descr (sxml->string (list "(" (sxml->string lst) ")")))
       ('bracket (sxml->string (list "[" (sxml->string lst) "]")))
       ('foreign (if (null? lst) #f `(foreign ,(car lst))))
       ('seasonword `(tag ,(string-append "season-" (assoc-ref lst 'type))))
       ('usg (usg->tag lst))
       ('sense (sxml->sense lst))
       ('steinhaus (let ((ref (sxml->string lst)))
                     (if (string? ref)
                         `(ref ,(sxml->string lst))
                         (throw 'not-steinhaus ref))))
       ('pos '()); TODO: actually find what tag to use
       ('wordcomponent (cons `(tag "wordcomponent") (gram-tag lst)))
       ('meishi (cons `(tag "meishi") (gram-tag lst)))
       ('setsuzokushi (cons `(tag "setsuzokushi") (gram-tag lst)))
       ('daimeishi (cons `(tag "daimeishi") (gram-tag lst)))
       ('doushi (cons `(tag "doushi") (gram-tag lst)))
       ('kandoushi (cons `(tag "kandoushi") (gram-tag lst)))
       ('keiyoudoushi (cons `(tag "keiyoudoushi") (gram-tag lst)))
       ('keiyoushi (cons `(tag "keiyoushi") (gram-tag lst)))
       ('fukushi (cons `(tag "fukushi") (gram-tag lst)))
       ('rengo (cons `(tag "rengo") (gram-tag lst)))
       ('suffix (cons `(tag "suffix") (gram-tag lst)))
       ('prefix (cons `(tag "prefix") (gram-tag lst)))
       ('kanji (cons `(tag "kanji") (gram-tag lst)))
       ('rentaishi (cons `(tag "rentaishi") (gram-tag lst)))
       ('specialcharacter (cons `(tag "specialcharacter") (gram-tag lst)))
       ('joshi (cons `(tag "joshi") (gram-tag lst)))
       ('fukujoshi (cons `(tag "fukujoshi") (gram-tag lst)))
       ('kakujoshi (cons `(tag "kakujoshi") (gram-tag lst)))
       ('kakarijoshi (cons `(tag "kakarijoshi") (gram-tag lst)))
       ('shuujoshi (cons `(tag "shuujoshi") (gram-tag lst)))
       ('setsuzokujoshi (cons `(tag "setsuzokujoshi") (gram-tag lst)))
       ('jokeiyoushi (cons `(tag "jokeiyoushi") (gram-tag lst)))
       ('jodoushi (cons `(tag "jodoushi") (gram-tag lst)))
       ('ruigos lst)
       ('ruigo (ruigo->ref lst))
       ('gramGrp lst))))
 (define (create-parser frq)
   (ssax:make-parser
     NEW-LEVEL-SEED
     (lambda (elem-gi attributes namespaces expected-content seed)
       attributes)
     FINISH-ELEMENT
     (lambda (elem-gi attributes namespaces parent-seed seed)
       (if (equal? elem-gi 'entries)
           seed
           (let* ((seed (reverse seed))
                  (element (sxml->element seed elem-gi frq)))
             (cons element parent-seed))))
     CHAR-DATA-HANDLER
     (lambda (string1 string2 seed)
       (cons (string-append string1 string2) seed))))
 (define (xml->results port frq)
   (let ((results (filter result? ((create-parser frq) port '()))))
     (sort results (lambda (a b) (> (result-points a) (result-points b))))))

po/fr.po

 msgstr ""
 "Project-Id-Version: PACKAGE VERSION\n"
 "Report-Msgid-Bugs-To: \n"
 "POT-Creation-Date: 2020-06-05 15:21+0200\n"
 "POT-Creation-Date: 2020-06-25 02:57+0200\n"
 "PO-Revision-Date: 2020-06-15 14:56+0000\n"
 "Last-Translator: full name <fedora-account@lepiller.eu>\n"
 "Language-Team: French <https://translate.fedoraproject.org/projects/nani/"
 msgid "JMdict"
 msgstr "JMdict"
 #: tools/list.scm:55
 #: tools/list.scm:63
 msgid ""
 "Japanese/Dutch dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/anglais de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:54
 #: tools/list.scm:62
 msgid ""
 "Japanese/English dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/anglais de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:56
 #: tools/list.scm:64
 msgid ""
 "Japanese/French dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/fran??ais de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:53
 #, fuzzy
 msgid "Japanese/French dictionary from the Jibiki project."
 msgstr "Dictionnaire japonais/allemand de Wadoku."
 #: tools/list.scm:37
 msgid "Japanese/German dictionary from Wadoku."
 msgstr "Dictionnaire japonais/allemand de Wadoku."
 #: tools/list.scm:57
 #: tools/list.scm:65
 msgid ""
 "Japanese/German dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/allemand de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:58
 #: tools/list.scm:66
 msgid ""
 "Japanese/Hungarian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/hongrois de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:59
 #: tools/list.scm:67
 msgid ""
 "Japanese/Russian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/russe de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:60
 #: tools/list.scm:68
 msgid ""
 "Japanese/Slovenian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/slov??ne de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:61
 #: tools/list.scm:69
 msgid ""
 "Japanese/Spanish dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "Dictionnaire japonais/espagnol de l???Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:62
 #: tools/list.scm:70
 msgid ""
 "Japanese/Swedish dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "    aidera ?? mieux prononcer les mots, avec l'accent de hauteur du japonais\n"
 "    standard."
 #: tools/list.scm:55
 #, fuzzy
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "\tFailing to download one of these dictionaries will make the app unusable\n"
 "\tas you can't search for anything.  This dictionary can be searched for\n"
 "\tby kanji, reading (kana) and by French translation."
 msgstr ""
 "Ce dictionnaire vous permet d???effectuer des recherches sur la vue\n"
 "    principale de cette appli. Si vous n???en t??l??chargez aucun, l???appli\n"
 "    sera inutilisable puisque vous ne pourrez rien rechercher. Ce\n"
 "    dictionnaire permet d???effectuer des recherches par kanji, par\n"
 "    prononciation (kana) et par traduction allemande."
 #: tools/list.scm:39
 #, fuzzy
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "        Failing to download on of these dictionaries will make the app "
 "        Failing to download one of these dictionaries will make the app "
 "unusable\n"
 "        as you can't search for anything.  This dictionary can be searched "
 "for\n"
 "    dictionnaire permet d???effectuer des recherches par kanji, par\n"
 "    prononciation (kana) et par traduction allemande."
 #: tools/list.scm:64
 #: tools/list.scm:72
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "        Failing to download one of these dictionaries will make the app "

po/nani.pot

 msgstr ""
 "Project-Id-Version: PACKAGE VERSION\n"
 "Report-Msgid-Bugs-To: \n"
 "POT-Creation-Date: 2020-06-06 01:47+0200\n"
 "POT-Creation-Date: 2021-07-18 16:26+0200\n"
 "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
 "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\n"
 msgid "JMdict"
 msgstr ""
 #: tools/list.scm:55
 #: tools/list.scm:63
 msgid ""
 "Japanese/Dutch dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:54
 #: tools/list.scm:62
 msgid ""
 "Japanese/English dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:56
 #: tools/list.scm:64
 msgid ""
 "Japanese/French dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:53
 msgid "Japanese/French dictionary from the Jibiki project."
 msgstr ""
 #: tools/list.scm:37
 msgid "Japanese/German dictionary from Wadoku."
 msgstr ""
 #: tools/list.scm:57
 #: tools/list.scm:65
 msgid ""
 "Japanese/German dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:58
 #: tools/list.scm:66
 msgid ""
 "Japanese/Hungarian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:59
 #: tools/list.scm:67
 msgid ""
 "Japanese/Russian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:60
 #: tools/list.scm:68
 msgid ""
 "Japanese/Slovenian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:61
 #: tools/list.scm:69
 msgid ""
 "Japanese/Spanish dictionary from the Electronic Dictionary Research and "
 "Development Group."
 msgstr ""
 #: tools/list.scm:62
 #: tools/list.scm:70
 msgid ""
 "Japanese/Swedish dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "         words better, with a standard Japanese pitch accent."
 msgstr ""
 #: tools/list.scm:55
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "\tFailing to download one of these dictionaries will make the app unusable\n"
 "\tas you can't search for anything.  This dictionary can be searched for\n"
 "\tby kanji, reading (kana) and by French translation."
 msgstr ""
 #: tools/list.scm:39
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "        Failing to download on of these dictionaries will make the app "
 "        Failing to download one of these dictionaries will make the app "
 "unusable\n"
 "        as you can't search for anything.  This dictionary can be searched "
 "for\n"
 "        by kanji, reading (kana) and by German translation."
 msgstr ""
 #: tools/list.scm:64
 #: tools/list.scm:72
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "        Failing to download one of these dictionaries will make the app "

po/uk.po

 msgid "JMdict"
 msgstr "JMdict"
 #: tools/list.scm:55
 #: tools/list.scm:63
 msgid ""
 "Japanese/Dutch dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-???????????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:54
 #: tools/list.scm:62
 msgid ""
 "Japanese/English dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-?????????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:56
 #: tools/list.scm:64
 msgid ""
 "Japanese/French dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-?????????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:53
 msgid "Japanese/French dictionary from the Jibiki project."
 msgstr ""
 #: tools/list.scm:37
 msgid "Japanese/German dictionary from Wadoku."
 msgstr "????????????????-?????????????????? ?????????????? ?????? Wadoku."
 #: tools/list.scm:57
 #: tools/list.scm:65
 msgid ""
 "Japanese/German dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-?????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:58
 #: tools/list.scm:66
 msgid ""
 "Japanese/Hungarian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-?????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:59
 #: tools/list.scm:67
 msgid ""
 "Japanese/Russian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-???????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:60
 #: tools/list.scm:68
 msgid ""
 "Japanese/Slovenian dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-?????????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:61
 #: tools/list.scm:69
 msgid ""
 "Japanese/Spanish dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "????????????????-???????????????????? ?????????????? ?????? Electronic Dictionary Research and "
 "Development Group."
 #: tools/list.scm:62
 #: tools/list.scm:70
 msgid ""
 "Japanese/Swedish dictionary from the Electronic Dictionary Research and "
 "Development Group."
 "?????????????????? ???? ?? ????????????????????, ?? ?????? ?????????????? ?????????????? ????????, ?????? ???????????????????? ??????\n"
 "?????????????????? ?????????? ??????????, ?? ?????????????????????????? ???????????????????? ???????????????? ????????????????."
 #: tools/list.scm:55
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "\tFailing to download one of these dictionaries will make the app unusable\n"
 "\tas you can't search for anything.  This dictionary can be searched for\n"
 "\tby kanji, reading (kana) and by French translation."
 msgstr ""
 #: tools/list.scm:39
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "        Failing to download on of these dictionaries will make the app "
 "        Failing to download one of these dictionaries will make the app "
 "unusable\n"
 "        as you can't search for anything.  This dictionary can be searched "
 "for\n"
 "???????????????? ???? ???? ?????????????? ???????????? ?? ?????? ???????????? ??????????. ?? ?????????? ???????????????? ??????????\n"
 "???????????? ???? ????????????, ?????????????? ?????????????????? (????????) ???? ???????????????????? ??????????????????."
 #: tools/list.scm:64
 #: tools/list.scm:72
 msgid ""
 "This dictionary allows you to do searches on the main view of this app.\n"
 "        Failing to download one of these dictionaries will make the app "
 "multilingual,\n"
 "including Dutch, French, German and others."
 msgstr ""
 "???? ?????????????????? ???????? ???????????????? ???? ???????? ???????????????????? ???????????????? <a href=\"~a\""
 ">Creative Commons\n"
 "???? ?????????????????? ???????? ???????????????? ???? ???????? ???????????????????? ???????????????? <a href=\"~a"
 "\">Creative Commons\n"
 "Share-Alike</a>. ???? ???????? ?? ???????????????????? ?? ???????????????????? (????????????????????) ?? "
 "???????????????????????? ??????????, ??????????????\n"
 "????????????????????????, ??????????????????????, ?????????????????? ???? ???????????? ????????????."

radicals.mk

 RADK_MODULES=tools/radk.scm modules/nani/radk.scm modules/nani/serialize.scm
 RADK_MODULES=tools/radk.scm modules/nani/kanji/radk.scm modules/nani/encoding/serialize.scm
 DICOS+=dicos/radicals.nani
 DOWNLOADS+=dictionaries/radkfilex.utf8 dictionaries/kanjidic2.xml
 dictionaries/radkfilex.utf8:
 	wget ftp://ftp.monash.edu/pub/nihongo/kradzip.zip -O dictionaries/kradzip.zip
 	#wget ftp://ftp.monash.edu/pub/nihongo/kradzip.zip -O dictionaries/kradzip.zip
 	wget http://ftp.usf.edu/pub/ftp.monash.edu.au/pub/nihongo/kradzip.zip -O dictionaries/kradzip.zip
 	unzip dictionaries/kradzip.zip radkfilex -d dictionaries
 	iconv -f euc-jp -t utf-8 dictionaries/radkfilex > $@
 	rm dictionaries/radkfilex

tools/jibiki.scm unknown status 1

 ;;; Nani Project website
 ;;; Copyright ?? 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of the Nani Project website.
 ;;;
 ;;; The Nani Project website is free software; you can redistribute it and/or modify it
 ;;; under the terms of the GNU Affero General Public License as published by
 ;;; the Free Software Foundation; either version 3 of the License, or (at
 ;;; your option) any later version.
 ;;;
 ;;; The Nani Project website is distributed in the hope that it will be useful, but
 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ;;; GNU Affero General Public License for more details.
 ;;;
 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (use-modules (nani result result))
 (use-modules (nani result jibiki))
 (use-modules (nani result frequency))
 (use-modules (ice-9 match))
 (use-modules (ice-9 binary-ports))
 ;; Break these steps to try and let the GC reclaim these big objects
 (define (get-results1 input frq)
   (call-with-input-file input
     (lambda (port)
       (xml->results port frq))))
 (define (get-results input meaning-filter frq)
   (let* ((results (get-results1 input frq))
          (results (map (lambda (result)
                          (update-result
                            result
                            #:meanings (filter meaning-filter
                                             (result-meanings result))))
                        results))
          (results (filter (lambda (result) (not (null? (result-meanings result))))
                           results)))
     results))
 (define (compile input meaning-filter output)
   (let* ((results (get-results input meaning-filter
                                (load-frequency "dictionaries/frequency.tsv"))))
     (format #t "Number of entries in ~a: ~a~%" output (length results))
     (call-with-output-file output
       (lambda (port)
         (put-bytevector port
           (serialize-dictionary results))))))
 (match (command-line)
   ((_ cmd input output)
    (cond
     ((equal? cmd "build")
      (compile input (const #t) output))
     (else (format #t "Unknown cmd ~a.~%" cmd)))))

tools/jmdict.scm

 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (use-modules (nani jmdict trie))
 (use-modules (nani jmdict serialize))
 (use-modules (nani jmdict xml))
 (use-modules (nani frequency))
 (use-modules (nani trie))
 (use-modules (nani result))
 (use-modules (nani result frequency))
 (use-modules (nani result jmdict))
 (use-modules (nani result result))
 (use-modules (ice-9 match))
 (use-modules (ice-9 binary-ports))
     (lambda (port)
       (xml->results port frq))))
 (define (get-results input sense-filter frq)
 (define (get-results input meaning-filter frq)
   (let* ((results (get-results1 input frq))
          (results (map (lambda (result)
                          (update-result
                            result
                            #:senses (filter sense-filter
                                             (result-senses result))))
                            #:meanings (filter meaning-filter
                                             (result-meanings result))))
                        results))
          (results (filter (lambda (result) (not (null? (result-senses result))))
          (results (filter (lambda (result) (not (null? (result-meanings result))))
                           results)))
     results))
 (define (compile input sense-filter output)
   (let* ((results (get-results input sense-filter
                                (load-frequency "dictionaries/frequency.tsv")))
          (kanji-trie (compress-trie (make-kanji-trie results)))
          (reading-trie (compress-trie (make-reading-trie results)))
          (meaning-trie (compress-trie (make-meaning-trie results))))
 (define (compile input meaning-filter output)
   (let* ((results (get-results input meaning-filter
                                (load-frequency "dictionaries/frequency.tsv"))))
     (format #t "Number of entries in ~a: ~a~%" output (length results))
     (call-with-output-file output
       (lambda (port)
         (put-bytevector port
           (serialize-jmdict results kanji-trie reading-trie meaning-trie))))))
           (serialize-dictionary results))))))
 (define (print word dict)
   #t)
     ((equal? cmd "build")
      (if (equal? lang "e")
        (compile input (const #t) output)
        (compile input (lambda (sense) (equal? (sense-language sense) lang)) output)))
        (compile input (lambda (meaning) (equal? (meaning-language meaning) lang)) output)))
     (else (format #t "Unknown cmd ~a.~%" cmd))))
   ((_ "print" word input)
    (print word input)))

tools/list.scm

 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (use-modules (tools i18n))
 (use-modules (nani radk))
 (use-modules (nani jmdict serialize))
 (use-modules (nani wadoku pitch))
 (use-modules (nani kanji radk))
 (use-modules (nani result result))
 (use-modules (nani pitch pitch))
 (use-modules (gcrypt hash))
 (use-modules (ice-9 match))
 (use-modules (ice-9 format))
     `(_ "Japanese/German dictionary from Wadoku."))
   (define wadoku-description
     `(_ "This dictionary allows you to do searches on the main view of this app.
         Failing to download on of these dictionaries will make the app unusable
         Failing to download one of these dictionaries will make the app unusable
         as you can't search for anything.  This dictionary can be searched for
         by kanji, reading (kana) and by German translation."))
          and this dictionary will add information that will help you pronounce
          words better, with a standard Japanese pitch accent."))
   (define jibiki-synopsis
     `(_ "Japanese/French dictionary from the Jibiki project."))
   (define jibiki-description
     `(_ "This dictionary allows you to do searches on the main view of this app.
 	Failing to download one of these dictionaries will make the app unusable
 	as you can't search for anything.  This dictionary can be searched for
 	by kanji, reading (kana) and by French translation."))
   (define (jmdict-synopsis lang)
     (match lang
       ("e" `(_ "Japanese/English dictionary from the Electronic Dictionary Research and Development Group."))
              (if long?
                  wadoku-pitch-description
                  wadoku-pitch-synopsis))
             ((equal? (dico-type dico) "jibiki")
              (if long?
                  jibiki-description
                  jibiki-synopsis))
             ((equal? (dico-type dico) "jmdict")
              (let ((dico-lang (substring dico 7)))
                (if long?
     ((equal? file "radicals") "radk")
     ((and (> (string-length file) 6) (equal? (substring file 0 6) "JMdict"))
      "jmdict")
     ((equal? file "jibiki_fre") "jibiki")
     ((equal? file "wadoku_ger") "wadoku")
     ((equal? file "wadoku_pitch") "wadoku_pitch")))
   (cond
     ((equal? (dico-type (dico-name file)) "radk")
      (kanji-count file))
     ((member (dico-type (dico-name file)) '("jmdict" "wadoku"))
      (jmdict-entry-count file))
     ((member (dico-type (dico-name file)) '("jmdict" "wadoku" "jibiki"))
      (dictionary-entry-count file))
     ((equal? (dico-type (dico-name file)) "wadoku_pitch")
      (pitch-entry-count file))))

tools/radk.scm

 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (use-modules (nani radk))
 (use-modules (nani kanji radk))
 (use-modules (ice-9 match))
 (use-modules (ice-9 binary-ports))

tools/wadoku.scm

 ;;; You should have received a copy of the GNU Affero General Public License
 ;;; along with the Nani Project website.  If not, see <http://www.gnu.org/licenses/>.
 (use-modules (nani jmdict trie))
 (use-modules (nani jmdict serialize))
 (use-modules (nani wadoku xml))
 (use-modules (nani wadoku pitch))
 (use-modules (nani frequency))
 (use-modules (nani trie))
 (use-modules (nani result))
 (use-modules (nani pitch wadoku))
 (use-modules (nani pitch pitch))
 (use-modules (nani result frequency))
 (use-modules (nani result result))
 (use-modules (nani result wadoku))
 (use-modules (ice-9 match))
 (use-modules (ice-9 binary-ports))
     (lambda (port)
       (xml->results port frq))))
 (define (get-results input sense-filter frq)
 (define (get-results input meaning-filter frq)
   (let* ((results (get-results1 input frq))
          (results (map (lambda (result)
                          (update-result
                            result
                            #:senses (filter sense-filter
                                             (result-senses result))))
                            #:meanings (filter meaning-filter
                                             (result-meanings result))))
                        results))
          (results (filter (lambda (result) (not (null? (result-senses result))))
          (results (filter (lambda (result) (not (null? (result-meanings result))))
                           results)))
     results))
 (define (compile input sense-filter output)
   (let* ((results (get-results input sense-filter
                                (load-frequency "dictionaries/frequency.tsv")))
          (kanji-trie (compress-trie (make-kanji-trie results)))
          (reading-trie (compress-trie (make-reading-trie results)))
          (meaning-trie (compress-trie (make-meaning-trie results))))
 (define (compile input meaning-filter output)
   (let* ((results (get-results input meaning-filter
                                (load-frequency "dictionaries/frequency.tsv"))))
     (format #t "Number of entries in ~a: ~a~%" output (length results))
     (call-with-output-file output
       (lambda (port)
         (put-bytevector port
           (serialize-jmdict results kanji-trie reading-trie meaning-trie))))))
           (serialize-dictionary results))))))
 (define (get-pitch input)
   (call-with-input-file input
 (define (pitch input output)
   (let ((results (get-pitch input)))
     (format #t "~a results." (length results))
     (format #t "~a results.~%" (length results))
     (call-with-output-file output
       (lambda (port)
         (put-bytevector port