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