include kanjivg.mk

DICOS+=dicos/kanjivg.nani

DOWNLOADS+=dictionaries/kanjivg

dictionaries/kanjivg:

	git clone --depth 1 https://github.com/KanjiVG/kanjivg $@

dicos/kanjivg.nani: dictionaries/kanjivg tools/kanjivg.scm $(DICO_MODULES)

	guile -L modules tools/kanjivg.scm build $< $@

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

  #:use-module (ice-9 binary-ports)

  #:use-module (ice-9 match)

  #:use-module (nani encoding huffman)

  #:use-module (nani encoding serialize)

  #:use-module (nani encoding trie)

  #:use-module (rnrs bytevectors)

  #:use-module (srfi srfi-9)

  #:use-module (sxml simple)

  #:export (make-kanji

            kanji?

            kanji-position kanji-position-set!

            kanji-kanji

            kanji-elements

            kanji-strokes

            xml->kanji

            serialize-stroke stroke-size

            serialize-kanji kanji-size

            serialize-kanjivg

            kanjivg-entry-count))

(define-record-type <kanji>

  (make-kanji position kanji elements strokes)

  kanji?

  (position kanji-position kanji-position-set!)

  (kanji    kanji-kanji)

  (elements kanji-elements)

  (strokes  kanji-strokes))

(define-record-type <stroke>

  (make-stroke x y command)

  stroke?

  (x       stroke-x)

  (y       stroke-y)

  (command stroke-command))

(define (strokes->elements strokes)

  "collect only top-level elements"

  (match strokes

    (() '())

    ((('http://www.w3.org/2000/svg:g ('@ attr ...) _ ...) strokes ...)

     (let loop ((attr attr))

       (match attr

         (() (strokes->elements strokes))

         ((('kvg:element element) _ ...)

          (cons element (strokes->elements strokes)))

         ((_ attr ...) (loop attr)))))

    (((_ ...) strokes ...)

     (strokes->elements strokes))))

(define (find-stroke kvg id)

  (match kvg

    (() #f)

    ((('http://www.w3.org/2000/svg:path ('@ attr ...)) kvg ...)

     (if (equal? (car (assoc-ref attr 'id)) id)

         (car (assoc-ref attr 'd))

         (find-stroke kvg id)))

    ((('http://www.w3.org/2000/svg:g ('@ _ ...) content ...) kvg ...)

     (or (find-stroke content id) (find-stroke kvg id)))

    (((? string? _) kvg ...)

     (find-stroke kvg id))))

(define (get-strokes strokes label id)

  (match label

    (() '())

    ((('http://www.w3.org/2000/svg:text ('@ ('transform transform)) num) label ...) 

     (let* ((xy (substring transform 15 (- (string-length transform) 1)))

            (xy (string-split xy #\ ))

            (x (car xy))

            (y (cadr xy)))

       (cons (make-stroke x y (find-stroke strokes (string-append id "-s" num)))

             (get-strokes strokes label id))))

    (((? string? _) label ...)

     (get-strokes strokes label id))))

(define (kvg-ref kvg elem)

  (assoc-ref kvg (symbol-append 'http://www.w3.org/2000/svg: elem)))

(define (xml->kanji port)

  (match (xml->sxml port #:namespaces '((kvg . "kvg")))

    (('*TOP* _ ('http://www.w3.org/2000/svg:svg ('@ _ ...) svg ...))

     (match (filter pair? svg)

       ((('http://www.w3.org/2000/svg:g ('@ _ ...) strokes ...)

         ('http://www.w3.org/2000/svg:g ('@ _ ...) labels ...))

        (let* ((elements (strokes->elements (filter pair? (kvg-ref strokes 'g))))

               (kanji (assoc-ref (assoc-ref (kvg-ref strokes 'g) '@) 'kvg:element))

               (kanji (if kanji (car kanji) #f))

               (id (car (assoc-ref (assoc-ref (kvg-ref strokes 'g) '@) 'id)))

               (strokes (get-strokes strokes labels id)))

          (make-kanji 0 kanji elements strokes)))))))

(define (serialize-stroke command-huffman-code)

  (lambda (stroke pos bv)

    (when (not (stroke? stroke)) (throw 'not-stroke stroke))

    (let* ((pos ((serialize-huffman-string command-huffman-code) (stroke-command stroke) pos bv))

           (pos ((serialize-huffman-string command-huffman-code) (stroke-x stroke) pos bv))

           (pos ((serialize-huffman-string command-huffman-code) (stroke-y stroke) pos bv)))

      pos)))

(define (stroke-size command-huffman-code)

  (lambda (stroke)

    (when (not (stroke? stroke)) (throw 'not-stroke stroke))

    (+ ((huffman-string-size command-huffman-code) (stroke-command stroke))

       ((huffman-string-size command-huffman-code) (stroke-x stroke))

       ((huffman-string-size command-huffman-code) (stroke-y stroke)))))

(define (serialize-kanji command-huffman-code)

  (lambda (kanji pos bv)

    (when (not (kanji? kanji)) (throw 'not-kanji kanji))

    (kanji-position-set! kanji pos)

    (let* ((pos ((serialize-list serialize-string) (kanji-elements kanji) pos bv))

           (pos ((serialize-list (serialize-stroke command-huffman-code))

                 (kanji-strokes kanji) pos bv)))

      pos)))

(define (kanji-size command-huffman-code)

  (lambda (kanji)

    (when (not (kanji? kanji)) (throw 'not-kanji kanji))

    (+ ((list-size string-size) (kanji-elements kanji))

       ((list-size (stroke-size command-huffman-code)) (kanji-strokes kanji)))))

(define (update-trie-pos! trie kanji)

  (let* ((vals (trie-vals trie))

         (vals (match vals

                 ((pos) (kanji-position (array-ref kanji pos)))

                 ((pos1 pos2) ; alias between ??? and ???, maybe others?

                  (kanji-position (array-ref kanji pos1)))

                 (() 0))))

    (trie-vals-set! trie vals))

  (for-each

    (match-lambda

      ((char . child)

       (update-trie-pos! child kanji)))

    (trie-transitions 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 kanji)

  (let ((trie (make-empty-trie)))

    (let loop ((kanji kanji) (i 0))

      (if (null? kanji)

          (compress-trie trie)

          (begin

            (add-to-trie! trie (make-key (kanji-kanji (car kanji))) i)

            (loop (cdr kanji) (+ i 1)))))))

(define (serialize-kanjivg results)

  (define command-huffman

    (let* ((strokes (apply append (map kanji-strokes results)))

           (commands (map stroke-command strokes))

           (x (map stroke-x strokes))

           (y (map stroke-y strokes)))

      (create-huffman (append commands x y))))

  (define command-huffman-code (huffman->code command-huffman))

  (let* ((header (string->utf8 "NANI_KANJIVG001"))

         (header-size (bytevector-length header))

         (command-huffman-bv (serialize-huffman command-huffman))

         (command-huffman-size (bytevector-length command-huffman-bv))

         (serialize-trie (serialize-trie-single serialize-int int-size))

         (trie-size (trie-size-single int-size))

         (kanji-trie (make-kanji-trie results))

         (kanji-trie-size (trie-size kanji-trie))

         (results-size

           ((list-size (kanji-size command-huffman-code)

                       #:size? #f)

            results))

         (bv (make-bytevector (+ header-size 4 command-huffman-size

                                 kanji-trie-size results-size))))

    (format #t "Number of kanji: ~a~%" (length results))

    ((serialize-list (serialize-kanji command-huffman-code)

                     #:size? #f)

     results (+ header-size 4 command-huffman-size kanji-trie-size) bv)

    (let ((results (list->array 1 results)))

      (update-trie-pos! kanji-trie results))

    (bytevector-copy! header 0 bv 0 header-size)

    (serialize-int (length results) (+ header-size) bv)

    (bytevector-copy! command-huffman-bv 0 bv (+ header-size 4)

                      command-huffman-size)

    (serialize-trie kanji-trie (+ header-size 4 command-huffman-size) bv)

    bv))

(define (kanjivg-entry-count file)

  (call-with-input-file file

    (lambda (port)

      (let* ((header (get-bytevector-n port 15))

             (size (get-bytevector-n port 4)))

        (bytevector-u32-ref size 0 (endianness big))))))

"POT-Creation-Date: 2021-07-29 21:50+0200\n"

#: tools/list.scm:71

#: tools/list.scm:70

#: tools/list.scm:72

#: tools/list.scm:61

#: tools/list.scm:45

#: tools/list.scm:73

#: tools/list.scm:74

#: tools/list.scm:75

#: tools/list.scm:76

#: tools/list.scm:77

#: tools/list.scm:78

#: tools/list.scm:87

#: tools/list.scm:89

#: tools/list.scm:90

#: tools/list.scm:88

#: tools/list.scm:39

msgid "Kanji writing visual help by the Kanjivg project."

msgstr ""

#: tools/list.scm:53

#: tools/list.scm:32

#: tools/list.scm:55

#: tools/list.scm:63

#: tools/list.scm:47

#: tools/list.scm:80

#: tools/list.scm:34

#: tools/list.scm:92

#: tools/list.scm:41

msgid ""

"This dictionary allows you to see how a kanji is written, what it is\n"

"composed of, and the order in which strokes are written."

msgstr ""

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

(use-modules (nani kanji kanjivg))

(use-modules (ice-9 match))

(use-modules (ice-9 binary-ports))

(define (get-files directory)

  (let loop ((dir (opendir (string-append directory "/kanji/"))) (svgs '()))

    (let ((entry (readdir dir)))

      (cond

        ((eof-object? entry) svgs)

        ((string-contains entry "-") (loop dir svgs))

        ((string-prefix? "000" entry) (loop dir svgs))

        ((string-suffix? ".svg" entry)

         (loop dir (cons (string-append directory "/kanji/" entry) svgs)))

        (else (loop dir svgs))))))

(match (command-line)

  ((_ cmd kanjivg-dir output)

   (cond

    ((equal? cmd "build")

     (let* ((results

              (map

                (lambda (file)

                  (call-with-input-file file

                    (lambda (port)

                      (let ((r (xml->kanji port)))

                        (unless (kanji-kanji r)

                          (pk 'no-kanji file))

                        r))))

                (sort (get-files kanjivg-dir) string<?))))

       (call-with-output-file output

         (lambda (port)

           (put-bytevector port

             (serialize-kanjivg (filter

                                  (lambda (r) (kanji-kanji r))

                                  results)))))))

    (else (format #t "Unknown cmd ~a.~%" cmd)))))

(use-modules ((nani kanji radk) #:prefix radk:))

(use-modules (nani kanji kanjivg))

  (define ksvg-synopsis

    `(_ "Kanji writing visual help by the Kanjivg project."))

  (define ksvg-description

    `(_ "This dictionary allows you to see how a kanji is written, what it is

composed of, and the order in which strokes are written."))

            ((equal? (dico-type dico) "ksvg")

             (if long?

                 ksvg-description

                 ksvg-synopsis))

    ((equal? file "kanjivg") "ksvg")

     (radk:kanji-count file))

    ((equal? (dico-type (dico-name file)) "ksvg")

     (kanjivg-entry-count file))

    ((equal? name "kanjivg") "")

    ((and (> (string-length name) 8) (equal? (substring name 0 8) "kanjidic"))

     (substring name 9))