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

  #:use-module (nani trie)

  #:use-module (rnrs bytevectors)

  #:export (serialize-jmdict))

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

         (sz (+ vals-sz 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)))

      (serialize-list (trie-transitions trie) serialize-pointer

                      vals-sz bv)

      (cons next-pos (cons bv bvs)))))

(define (serialize-pointer ptr pos bv)

  (bytevector-u8-set! bv pos (car ptr))

  (bytevector-u32-set! bv (+ pos 1) (trie-position (cdr ptr)) (endianness little))

  (+ pos 5))

(define (serialize-int int pos bv)

  (bytevector-u32-set! bv pos int (endianness little))

  (+ 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-u32-set! bv pos (bytevector-length sbv) (endianness little))

    (bytevector-copy! sbv 0 bv (+ pos 4) (bytevector-length sbv))

    (+ pos 4 (bytevector-length sbv))))

(define (string-size str)

  (let ((sbv (string->utf8 str)))

    (+ 4 (bytevector-length sbv))))

(define* (serialize-list lst serialize pos bv #:key (size? #t))

  (when (not (list? lst)) (throw 'not-list lst))

  (when size?

    (bytevector-u32-set! bv pos (length lst) (endianness little)))

  (let loop ((lst lst) (pos (+ pos (if size? 4 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? 4 0) (map size lst)))

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

(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-string pos bv))

         (pos (serialize-list (sense-glosses sense) serialize-string 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) string-size)

     (list-size (sense-glosses sense) string-size)

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

     (list-size (result-readings result) reading-size)

     (list-size (result-senses result) sense-size)))

(define (serialize-jmdict results kanji-trie reading-trie sense-trie)

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

         (header-size (bytevector-length header))

         (pointers (make-bytevector 12 0))

         (results-size (list-size results result-size #:size? #f))

         (results-bv (make-bytevector (+ header-size 12 results-size 0))))

    (serialize-list results serialize-result (+ header-size 12) results-bv #:size? #f)

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

           (pos (+ header-size 12 (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-copy! header 0 results-bv 0 header-size)

      (bytevector-copy! pointers 0 results-bv header-size 12)

      (merge-bvs (append (list results-bv) (cdr kanji-bvs) (cdr reading-bvs)

                         (cdr meaning-bvs))))))

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

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

  #:use-module (sxml simple)

  #:use-module (nani result)

  #:export (load-dic sxml->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))))

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

          (('wasei _) (update-source source #:wasei? #t))

          (('type t) (update-source source #:type t))

          (('lang l) (update-source source #:lang l))

          ((? list? l) (loop source l))

          ((? string? _) 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 (? string? r)) (update-sense sense #:tags (cons r (sense-tags sense))))

          (('gloss (? string? r)) (update-sense sense #:glosses (cons r (sense-glosses sense))))

          (('lang (? string? l)) (update-sense sense #:language l))

          ((? list? l) (loop sense l))

          ((? string? _) sense))

        (cdr lst)))))

(define (sxml->result lst)

  (let loop ((result (make-result 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)))))

(define (sxml->results sxml)

  (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) `(tag ,pos))

       (('dial pos) `(tag ,pos))

       (('field pos) `(tag ,pos))

       (('misc pos) `(tag ,pos))

       (('pos pos) `(tag ,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))

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

;;; 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-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 kanjis readings senses)

  result?

  (position result-position result-position-set!) ; 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) ; symbol-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 (kanjis (result-kanjis result))

                 (readings (result-readings result))

                 (senses (result-senses result)))

  (make-result (result-position result) 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))

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

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