PAGES=blog.scm data.scm documentation.scm e404.scm feeds.scm index.scm mentions.scm

        modules/nani/jmdict/entities.scm modules/nani/frequency.scm

LANGS=fr

all: $(addprefix po/, $(addsuffix /LC_MESSAGES/nani.mo, $(LANGS))) $(WEB_FILES)

	@$(MAKE) dictionaries/JMdic_e.xml dictionaries/JMdic.xml dictionaries/frequency.tsv

# Download JMdict dictionaries from ERDRG

	dl_filename="$(shell echo "$@" | rev | cut -c5- | rev)"; \

	wget http://ftp.monash.edu/pub/nihongo/"$$dl_filename".gz -O "$$dl_filename.gz"; \

	gunzip "$$dl_filename.gz"; \

	sed -i -e 's|<|\&\<;|g' -e 's|>|\&\>;|g' "$$dl_filename"; \

	sed -i -e 's|&\([^;]\+\);|\1|g' "$$dl_filename"; \

	cp "$$dl_filename" "$@"

# Download frequency analysis run on Wikipedia in 2015

# https://en.wiktionary.org/wiki/Wiktionary:Frequency_lists/Japanese2015_10000

dictionaries/frequency.tsv:

	wget --no-check-certificate \

        https://namakajiri.net/data/wikipedia-20150422-lemmas.tsv -O $@.tmp

	sed -i 's| ||g' $@.tmp

	mv $@.tmp $@

dicos/JMdict_%.nani: dictionaries/JMdict.sxml tools/jmdict.scm dictionaries/frequency.tsv $(DICO_MODULES)

dicos/JMdict_e.nani: dictionaries/JMdict_e.sxml tools/jmdict.scm dictionaries/frequency.tsv $(DICO_MODULES)

;;; 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 '()))

        (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))

                                (string->number (car content)))

                          frq)))))))))

(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))))

;;; 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))

(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) '(2)))

      (((h1 h2) . weight)

       (append '(1) (serialize h1) (serialize h2) '(2)))

      ((((? 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)))

    ("anat" . 173)

    ("frq500" . 174)

    ("frq1000" . 175)

    ("frq2000" . 176)

    ("frq5000" . 177)

    ("frq10000" . 178)

    ("frq20000" . 179)))

  #:use-module (nani huffman)

         (trs-sz (list-size (trie-transitions trie) (const 5) #:size? #f))

         (sz (+ vals-sz 1 trs-sz))

      (bytevector-u8-set! bv vals-sz (length (trie-transitions trie)))

                      (+ vals-sz 1) bv #:size? #f)

(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-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-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))))

  (define (serialize-huffman-string huffman-code)

    (lambda (str pos bv)

      (let ((sbv (huffman-encode huffman-code str)))

        (bytevector-copy! sbv 0 bv (+ pos 4) (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)))))

  (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)))))

         (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))

         (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 0))))

    (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)

      (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)

      (format #t "huffmans are ~a bytes long~%" huffman-size)

  #:use-module (nani frequency)

(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 (update-sense sense1 #:tags (cons entity (sense-tags sense1))))

           (senses (cons sense1 (cdr (result-senses result)))))

      (update-result result #:points (get-points (update-result result #:senses senses))))))

(define (get-points result)

  (let ((tags (apply append (map sense-tags (result-senses result)))))

    (apply + (map (lambda (tag)

                    (cond

                      ;; frequency

                      ((eq? tag (get-entity "frq500"))

                       32)

                      ((eq? tag (get-entity "frq1000"))

                       16)

                      ((eq? tag (get-entity "frq2000"))

                       8)

                      ((eq? tag (get-entity "frq5000"))

                       4)

                      ((eq? tag (get-entity "frq10000"))

                       2)

                      ((eq? tag (get-entity "frq20000"))

                       1)

                      ;; archaic term

                      ((eq? tag (get-entity "arch"))

                       -3)

                      ;; children language

                      ((eq? tag (get-entity "chn"))

                       -1)

                      ;; colloquialism

                      ((eq? tag (get-entity "col"))

                       5)

                      ;; expression

                      ((eq? tag (get-entity "exp"))

                       1)

                      ;; sonkeigo (honorific or respectful)

                      ((eq? tag (get-entity "hon"))

                       -1)

                      ;; kenjougo (humble)

                      ((eq? tag (get-entity "hum"))

                       -1)

                      ;; teineigo (polite)

                      ((eq? tag (get-entity "pol"))

                       -1)

                      ;; irregular kanji

                      ((eq? tag (get-entity "iK"))

                       -2)

                      ;; idiomatic expression

                      ((eq? tag (get-entity "id"))

                       3)

                      ;; slang

                      ((member tag (list

                                     (get-entity "sl")

                                     (get-entity "m-sl")

                                     (get-entity "male-sl")))

                       -4)

                      ;; outdated kanji

                      ((eq? tag (get-entity "oK"))

                       -2)

                      ;; obsolete term

                      ((eq? tag (get-entity "obs"))

                       -5)

                      ;; obscure term

                      ((eq? tag (get-entity "obsc"))

                       -10)

                      ;; onomatopea

                      ((eq? tag (get-entity "on-mim"))

                       1)

                      ;; poetical term

                      ((eq? tag (get-entity "poet"))

                       -1)

                      ((eq? tag (get-entity "proverb"))

                       1)

                      ((eq? tag (get-entity "rare"))

                       -3)

                      ;; sensitive

                      ((eq? tag (get-entity "sens"))

                       -2)

                      ;; dialect

                      ((member tag (list

                                     (get-entity "kyb")

                                     (get-entity "osb")

                                     (get-entity "ksb")

                                     (get-entity "ktb")

                                     (get-entity "tsb")

                                     (get-entity "thb")

                                     (get-entity "tsug")

                                     (get-entity "kyu")

                                     (get-entity "rkb")

                                     (get-entity "nab")

                                     (get-entity "hob")))

                       -1)

                      (else 0)))

                  tags))))

(define (sxml->results sxml frq)

  (sort

    (foldt

      (lambda (xml)

        (match xml

         (('ent_seq _) "")

         (('ke_pri _) "")

         (('re_pri _) "")

         (('pri _) "")

         (('keb kanji) `(kanji ,kanji))

         (('ke_inf _) "")

         (('k_ele lst ...) (car (filter list? lst)))

         (('reb reading) `(reading ,reading))

         (('re_nokanji _ ...) "")

         (('re_restr r) `(limit ,r))

         (('re_inf r) `(info ,r))

         (('r_ele lst ...) (sxml->reading lst))

         (('ant pos) `(ref ,pos))

         (('dial pos) `(tag ,(get-entity pos)))

         (('field pos) `(tag ,(get-entity pos)))

         (('misc pos) `(tag ,(get-entity pos)))

         (('pos pos) `(tag ,(get-entity pos)))

         (('xref pos) `(ref ,pos))

         (('g_type _ ...) "")

         (('gloss (? string? g)) xml)

         (('gloss (? list? g)) g)

         (('gloss attr g) (cons `(gloss ,g) attr))

         (('stagk k) `(limit ,k))

         (('stagr r) `(limit ,r))

         (('s_inf r) `(info ,r))

         (('lsource lst ...) (sxml->source lst))

         (('sense lst ...) (sxml->sense lst))

         (('entry lst ...) (sxml->result lst frq))

         (('JMdict lst ...) lst)

         (('xml:lang l) `(lang ,l))

         (('ls_wasei _) '(wasei #t))

         (('ls_type t) `(type ,t))

         (('@ lst ...) lst)

         (('*TOP* _ l) (filter result? l))

         (('*PI* _ ...) #f)))

      (lambda (a) a)

      sxml)

    (lambda (a b) (< (result-points a) (result-points b)))))

            result-points

  (make-result position points kanjis readings senses)

  (points result-points) ; integer

           #:key (points (result-points result))

                 (kanjis (result-kanjis result))

  (make-result (result-position result) points kanjis readings senses))

;;; 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/>.

(use-modules (nani frequency))

  (let* ((frq (load-frequency "dictionaries/frequency.tsv"))

         (sxml (if (equal? (substring input (- (string-length input) 4)) ".xml")

                 (call-with-input-file input read)))

         (results (sxml->results sxml frq))