129 lines
5.5 KiB
Common Lisp
129 lines
5.5 KiB
Common Lisp
(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)))
|