(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 (&optional (db-path #P"myoji.sqlite"))
  "Initialize the connection to the myoji database."
  (mito:connect-toplevel :sqlite3 :database-name db-path)
  (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)))