(in-package #:myoji-accent/accent)

(defun high-accent-char-p (char)
  "Return non-nil if CHAR is a character representing a high accent in an accent
string."
  (or (equalp char #\h)
      (equalp char #\e)))

(defun accent-point (reading)
  "Parse the reading string READING and return its accent point."
  (let ((start (position-if #'high-accent-char-p reading))
        (end (position-if #'high-accent-char-p reading :from-end t)))
    ;; ensure we have an actual accent point
    (when (and start end (not (find #\h reading :start start :end end
                                    :test-not 'equalp)))
      (case (elt reading (1- (length reading)))
            ((#\h #\H) 0)                     ;; 平板型
            ((#\e #\E) (1- (length reading))) ;; 尾高型
            ((#\l #\L) (1+ end)))))) ;; 中高型 or 頭高型

(defun accent-string (mora point)
  "Return an accent string for a word of MORA mora that has an accent of POINT."
  (cond
   ((not (typep point `(integer 0 ,mora))) nil)
   ((= mora 1)
    (format nil "~[l~;h~]e" point))
   ((zerop point)
    (format nil "l~a" (make-string (1- mora) :initial-element #\h)))
   ((= point 1)
    (format nil "h~a" (make-string (1- mora) :initial-element #\l)))
   ((= point mora)
    (format nil "l~ae" (make-string (1- mora) :initial-element #\h)))
   (t
    (format nil "l~a~a"
            (make-string (1- point) :initial-element #\h)
            (make-string (- mora point) :initial-element #\l)))))

(defun accent-name (length point)
  "Return the name of the accent for a word of length LENGTH with accent point
POINT."
  (cond
   ((or (not point)
        (> point length)) "不規則")
   ((zerop point) "平板型")
   ((= point 1) "頭高型")
   ((= point length) "尾高型")
   (t "中高型")))

(defun small-kana-p (char)
  "Return non-nil if char is a small kana character (e.g. ょ)."
  (find char "ゃゅょャュョ" :test 'eql))

(defun char-hl-p (char)
  "Return non-nil if CHAR is an h or l (the letters, case insensitive)."
  (or (equalp char #\l)
      (equalp char #\h)))

(defun valid-accent-string-p (str &optional len)
  "Return non-nil if STR is a valid accent string. If LEN is non-nil, also check
that STR is of the correct length for a word with LEN mora"
  (if (and (not (zerop (length str)))
           (equalp #\e (elt str (1- (length str)))))
      (and (null (find-if-not #'char-hl-p str :end (1- (length str))))
           (member (elt str (1- (length str))) '(#\l #\h #\e) :test 'equalp)
           (or (not len) (= len (1- (length str)))))
    (and (every #'char-hl-p str)
         (or (not len) (= len (length str))))))

(defun count-word-mora (word)
  "Count the number of mora in WORD. Word should consist only of kana."
  (count-if-not #'small-kana-p word))

(defun accent-html (reading as)
  "Generate HTML to render READING with the accent string AS."
  (let ((*print-pretty* nil))
    (if (not (valid-accent-string-p as (count-word-mora reading)))
        reading
      (spinneret:with-html-string
       (loop for char-i below (length reading)
             for char = (char-downcase (elt reading char-i))
             for next-char = (when (< (1+ char-i) (length reading))
                               (char-downcase (elt reading (1+ char-i))))
             for acc-i = 0 then (if (not (small-kana-p char))
                                    (1+ acc-i)
                                  acc-i)
             for this-accent = (char-downcase (elt as acc-i))
             for next-accent = (when (< (1+ acc-i) (length as))
                                 (char-downcase (elt as (1+ acc-i))))
             do
             (:span :class
                    (format nil "tone-~a~@[~*-change~]~@[~* tone-end-change~]"
                            this-accent
                            (and next-accent (not (eql next-accent #\e))
                                 (not (small-kana-p next-char))
                                 (not (eql this-accent next-accent)))
                            (eql next-accent #\e))
                    char))))))

(mito:deftable myoji ()
               ((reading :col-type :binary)
                (kanji :col-type :binary)
                (accent-string :col-type :binary)
                (accent-point :col-type :unsigned)
                (accent-name :col-type :binary)
                (accent-html :col-type :binary)))

(defun initialize-connection ()
  "Initialize the connection to the myoji database."
  (mito:connect-toplevel :sqlite3 :database-name #P"myoji.sqlite")
  (mito:ensure-table-exists 'myoji))

(defun make-myoji (reading kanji &key accent-string accent-point)
  "Create a myoji with READING and KANJI.  You must supply exactly one of
ACCENT-STRING or ACCENT-POINT."
  (assert (or (and accent-string (not accent-point))
              (and (not accent-string) accent-point))
          (accent-string accent-point)
          "Exactly one of ACCENT-STRING or ACCENT-POINT must be provided.")
  (if accent-string
      (setq accent-point (accent-point accent-string))
    (setq accent-string (accent-string (count-word-mora reading)
                                       accent-point)))
  (make-instance 'myoji :reading reading :kanji kanji
                 :accent-string accent-string
                 :accent-point accent-point
                 :accent-name (accent-name (count-word-mora reading)
                                           accent-point)
                 :accent-html (accent-html reading accent-string)))