From 9a61198f93ef9d343ee6786ac9a38e8df8f0863a Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Sun, 18 May 2025 00:59:35 +0900 Subject: [PATCH] Update more things --- accent.lisp | 120 ++++++++++++++++++++++++++-------------------------- start.lisp | 15 +++++-- 2 files changed, 72 insertions(+), 63 deletions(-) diff --git a/accent.lisp b/accent.lisp index 299e0af..d0a5aa3 100644 --- a/accent.lisp +++ b/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))) diff --git a/start.lisp b/start.lisp index 1058762..4430c55 100644 --- a/start.lisp +++ b/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*)))