Update more things
This commit is contained in:
parent
69c4976303
commit
9a61198f93
GPG Key ID:
5FD0394ADBD72730
120
accent.lisp
120
accent.lisp
@ -12,39 +12,39 @@ string."
|
||||
(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)))
|
||||
:test-not 'equalp)))
|
||||
(case (elt reading (1- (length reading)))
|
||||
((#\h #\H) 0) ;; 平板型
|
||||
((#\e #\E) (1- (length reading))) ;; 尾高型
|
||||
((#\l #\L) (1+ end)))))) ;; 中高型 or 頭高型
|
||||
((#\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)))))
|
||||
((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 "中高型")))
|
||||
((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. ょ)."
|
||||
@ -63,8 +63,8 @@ that STR is of the correct length for a word with LEN mora"
|
||||
(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))))))
|
||||
(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."
|
||||
@ -75,38 +75,38 @@ that STR is of the correct length for a word with LEN mora"
|
||||
(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))))))
|
||||
(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)))
|
||||
((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 ()
|
||||
(defun initialize-connection (&optional (db-path #P"myoji.sqlite"))
|
||||
"Initialize the connection to the myoji database."
|
||||
(mito:connect-toplevel :sqlite3 :database-name #P"myoji.sqlite")
|
||||
(mito:connect-toplevel :sqlite3 :database-name db-path)
|
||||
(mito:ensure-table-exists 'myoji))
|
||||
|
||||
(defun make-myoji (reading kanji &key accent-string accent-point)
|
||||
@ -118,11 +118,11 @@ ACCENT-STRING or 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)))
|
||||
(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)))
|
||||
: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)))
|
||||
|
||||
15
start.lisp
15
start.lisp
@ -1,10 +1,11 @@
|
||||
(ql:quickload '(:myoji-accent))
|
||||
|
||||
(myoji-accent/accent:initialize-connection)
|
||||
|
||||
(defparameter *interface* "localhost")
|
||||
(defparameter *port* 8080)
|
||||
(defparameter *debug* nil)
|
||||
(defparameter *db-path* (merge-pathnames
|
||||
(uiop:pathname-directory-pathname *load-truename*)
|
||||
"myoji.sqlite"))
|
||||
(defparameter *help* nil)
|
||||
|
||||
(defun parse-arguments (&optional (args (uiop:command-line-arguments)))
|
||||
@ -20,6 +21,9 @@
|
||||
(when (member (car arg) '("-p" "--port") :test 'equal)
|
||||
(require-arg arg)
|
||||
(setq *port* (parse-integer (second arg))))
|
||||
(when (member (car arg) '("-b" "--db") :test 'equal)
|
||||
(require-arg arg)
|
||||
(setq *db-path* (parse-integer (second arg))))
|
||||
(when (member (car arg) '("-d" "--debug") :test 'equal)
|
||||
(setq *debug* t))))
|
||||
args))
|
||||
@ -28,6 +32,7 @@
|
||||
(format t "usage: sbcl --load ~a~%" *load-pathname*)
|
||||
(format t " -h|--help print this message, then exit~%")
|
||||
(format t " -d|--debug enable debug output~%")
|
||||
(format t " -b|--db path to the database (takes an argument)~%")
|
||||
(format t " -p|--port the port to use (takes an argument)~%")
|
||||
(format t " -i|--interface the address to bind to (takes an argument)~%")
|
||||
(uiop:quit))
|
||||
@ -35,4 +40,8 @@
|
||||
(parse-arguments)
|
||||
(if *help*
|
||||
(print-help)
|
||||
(reblocks/server:start :interface *interface* :port *port* :debug *debug*))
|
||||
(progn
|
||||
(format t "Loading database from ~s~%" *db-path*)
|
||||
(myoji-accent/accent:initialize-connection *db-path*)
|
||||
(format t "Starting server on ~s:~s~%" *interface* *port*)
|
||||
(reblocks/server:start :interface *interface* :port *port* :debug *debug*)))
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user