138 lines
5.0 KiB
Common Lisp
138 lines
5.0 KiB
Common Lisp
(in-package #:myoji-accent/index)
|
||
|
||
(defapp index
|
||
:prefix "/"
|
||
:name "日本人の姓のアクセント")
|
||
|
||
(defwidget index-page ()
|
||
((last-search :initform nil
|
||
:type '(or string null)
|
||
:documentation "The last received query.")
|
||
(myoji-list :initform nil
|
||
:type 'list
|
||
:documentation "List of myoji that where returned by the last
|
||
search.")))
|
||
|
||
(defparameter *pitch-color* "red"
|
||
"The color of pitch accent lines.")
|
||
|
||
(defmethod reblocks/dependencies:get-dependencies ((widget index-page))
|
||
(append
|
||
(list
|
||
(reblocks-lass:make-dependency
|
||
`(.index-page
|
||
:width "50%"
|
||
:margin auto
|
||
:margin-top "15%"
|
||
(|#page-title|
|
||
:text-align "center"
|
||
:font-size xxx-large
|
||
:margin-bottom "20px")
|
||
(|#description|
|
||
:text-align "center"
|
||
:font-size x-large
|
||
:margin-bottom "30px")
|
||
(|#search-form|
|
||
:margin auto
|
||
:width "70%"
|
||
:display flex
|
||
(|#query-input|
|
||
:font-size xx-large
|
||
:width "100%"
|
||
:flex auto)
|
||
(|#submit-button|
|
||
:margin-left "5px"
|
||
:font-size x-large))
|
||
(|#error-message|
|
||
:margin-top "20px"
|
||
:font-size x-large
|
||
:text-align center
|
||
:color "red")
|
||
(|#entry-list|
|
||
:margin-top "20px"
|
||
(.myoji-entry
|
||
:font-size x-large
|
||
:text-align center
|
||
((:parent (:not :first-child))
|
||
:margin-top "10px")))
|
||
(.accented
|
||
(span.tone-h
|
||
:border-top "1px" solid ,*pitch-color*)
|
||
(span.tone-l
|
||
:border-bottom "1px" solid ,*pitch-color*)
|
||
(span.tone-h-change
|
||
:border solid ,*pitch-color*
|
||
:border-width "1px" "1px" "0px" "0px")
|
||
(span.tone-l-change
|
||
:border solid ,*pitch-color*
|
||
:border-width "0px" "1px" "1px" "0px")
|
||
(span.tone-end-change
|
||
:border-right "1px")))))
|
||
(call-next-method)))
|
||
|
||
(defun empty-query-p (query)
|
||
"Return non-nil if QUERY is empty or contains only spaces."
|
||
(null (set-difference (coerce query 'list) '(#\Ideographic_Space #\Space
|
||
#\No-break_Space #\Tab)
|
||
:test 'eql)))
|
||
|
||
(defmethod handle-search ((widget index-page) &key query)
|
||
(if (empty-query-p query)
|
||
(setf (slot-value widget 'last-search) nil
|
||
(slot-value widget 'myoji-list) nil)
|
||
(let ((myoji-list
|
||
(union (mito:retrieve-dao 'myoji-accent/accent:myoji :kanji query)
|
||
(mito:retrieve-dao 'myoji-accent/accent:myoji :reading query))))
|
||
(setf (slot-value widget 'last-search) query
|
||
(slot-value widget 'myoji-list) myoji-list)))
|
||
(reblocks/widget:update widget))
|
||
|
||
(defmethod reblocks/widget:render ((widget index-page))
|
||
(with-slots (last-search myoji-list) widget
|
||
(with-html
|
||
(:div :id "page-title"
|
||
"日本人の姓のアクセント")
|
||
(:div :id "description"
|
||
"アクセントを知りたい"
|
||
(:ruby "姓" (:rp "（") (:rt "せい") (:rp "）"))
|
||
"／"
|
||
(:ruby "名字" (:rp "（") (:rt "みょうじ") (:rp "）"))
|
||
"・"
|
||
(:ruby "苗字" (:rp "（") (:rt "みょうじ") (:rp "）"))
|
||
"（last name／family name／surname）を"
|
||
(:ruby "平仮名" (:rp "（") (:rt "ひらがな") (:rp "）"))
|
||
"か漢字で入力してください。")
|
||
(with-html-form (:POST #'(lambda (&key query &allow-other-keys)
|
||
(handle-search widget :query query))
|
||
:id "search-form")
|
||
(:input :id "query-input"
|
||
:type "text"
|
||
:name "query"
|
||
:placeholder "（例：さかぐち／坂口）"
|
||
:value (or (slot-value widget 'last-search) ""))
|
||
(:input :id "submit-button"
|
||
:type "submit"
|
||
:value "検索"))
|
||
(cond
|
||
(myoji-list
|
||
(:div :id "entry-list"
|
||
(dolist (myoji myoji-list)
|
||
(with-accessors ((kanji myoji-kanji)
|
||
(accent-point myoji-accent-point)
|
||
(accent-name myoji-accent-name)
|
||
(accent-html myoji-accent-html))
|
||
myoji
|
||
(:div :class "myoji-entry"
|
||
(format nil "~a " kanji)
|
||
(:raw (format nil "→ <span class=accented>~a</span>"
|
||
accent-html))
|
||
(format nil " [~a] (~a)" accent-point accent-name))))))
|
||
(last-search
|
||
(:div :id "error-message"
|
||
"該当する苗字がみつかりませんでした。"))))))
|
||
|
||
(defmethod reblocks/page:init-page ((app index) (url-path string) expire-at)
|
||
(declare (ignorable url-path expire-at))
|
||
(setf (reblocks/page:get-title) "日本人の姓のアクセント")
|
||
(make-instance 'index-page))
|