lat/lat.lisp

;;;; lat.lisp

(in-package #:lat)

;;; "lat" goes here. Hacks and glory await!

#|
Задать вопрос, получить ответ.
Показать результат.

state: problems more-problems current-problem
mode: show check

request: type answer
|#

(defstruct (request (:conc-name))
  mode
  answer)

(defun show-finish (id)
  (djula:render-template* "finish-exercise.html" nil :id id :menu (menu)))

(defun show-mistake (problem answers id)
  (djula:render-template* "mistake.html" nil :id id :problem (corrected-answer-to-html problem answers) :menu (menu)))

(defun show-ok (problem id)
  (djula:render-template* "ok.html" nil :id id :problem (answer-to-html problem) :menu (menu)))

(defun prefix (problem)
  (getf problem :prefix))

(defun suffix (problem)
  (getf problem :suffix))

(defun show-problem (problem id)
  (djula:render-template* "ex-show.html" nil :problem (problem-to-html problem) :id id :menu (menu `(:exercise ,id))))

; (defvar *server* (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port 12345)))

(djula:add-template-directory (asdf:system-relative-pathname "lat" "templates/"))

(hunchentoot:define-easy-handler (home :uri "/lat") ()
  (unless hunchentoot:*session*
    (hunchentoot:start-session))
  (djula:render-template* "base.html" nil :menu (menu)))

(hunchentoot:define-easy-handler serve-exercise ((mode :request-type :both) (answer :parameter-type '(list string) :request-type :post))
  (let* ((uri (hunchentoot:request-uri*))
         (exercise-id (if (and (eql (search "/lat/" uri) 0)
                               (> (length uri) 5)) ; should always be true 
                          (subseq uri 5)
                          nil)))
    (when (null exercise-id)
      (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
      (return-from serve-exercise))
    (let ((problems (make-instance 'cl-containers:basic-queue)))
      (with-open-file (in (asdf:system-relative-pathname "lat" (format nil "exercises/~A.txt" exercise-id))
                          :direction :input
                          :if-does-not-exist nil)
        (when (null in)
          (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+)
          (return-from serve-exercise))
        (loop for line = (read-line in nil)
              while line
              do (cl-containers:insert-item problems (parse-problem line)))
        (if hunchentoot:*session*
            (progn
              (let ((request (make-request :mode mode :answer answer)))
                (if (or (string= mode "check")
                        (string= mode "show"))
                    (exercise request (hunchentoot:session-value 'problems) (hunchentoot:session-value 'id))
                    (progn
                      (setf (hunchentoot:session-value 'problems) problems)
                      (setf (hunchentoot:session-value 'exercise-id) "p1e1")
                      (setf (mode request) "show")
                      (exercise request (hunchentoot:session-value 'problems) (hunchentoot:session-value 'id))))))
            (hunchentoot:redirect "/lat"))))))

(push (hunchentoot:create-regex-dispatcher "/lat/p\\d+e\\d*" 'serve-exercise) hunchentoot:*dispatch-table*)
(push (hunchentoot:create-regex-dispatcher "/lat/e\\d+[a-z]?" 'serve-exercise) hunchentoot:*dispatch-table*)

(hunchentoot:define-easy-handler (test :uri "/test") ()
  (hunchentoot:start-session)
  (hunchentoot:redirect "/"))


(hunchentoot:define-easy-handler (p0 :uri "/lat/p0") ()
  (djula:render-template* "units/p0.html" nil :menu (menu '(:lesson 0))))

(hunchentoot:define-easy-handler (p2 :uri "/lat/p2") ()
  (djula:render-template* "units/p2-accents.html" nil :menu (menu '(:lesson 2))))

(hunchentoot:define-easy-handler (p1 :uri "/lat/p1") ()
  (djula:render-template* "units/p1-accents.html" nil :menu (menu '(:lesson 1))))

(hunchentoot:define-easy-handler (p3 :uri "/lat/p3") ()
  (djula:render-template* "unit.html" nil :unit "units/p3.txt" :menu (menu '(:lesson 3))))

(hunchentoot:define-easy-handler (p4 :uri "/lat/p4") ()
  (djula:render-template* "unit.html" nil :unit "units/p4.txt" :menu (menu '(:lesson 4))))

(defun normalize-answer (string)
  (with-output-to-string (s)
    (loop for c across (string-downcase string)
          with remembered
          do (if (find c '(#\COMBINING_MACRON #\= #\_))
                 (when remembered
                   (write-char (case remembered
                                 (#\a  #\LATIN_SMALL_LETTER_A_WITH_MACRON)
                                 (#\e  #\LATIN_SMALL_LETTER_E_WITH_MACRON)
                                 (#\i  #\LATIN_SMALL_LETTER_I_WITH_MACRON)
                                 (#\o  #\LATIN_SMALL_LETTER_O_WITH_MACRON)
                                 (#\u  #\LATIN_SMALL_LETTER_U_WITH_MACRON)
                                 (t remembered))
                               s)
                   (setf remembered nil))
                 (progn
                   (when remembered
                     (write-char remembered s))
                   (if (find c "aeiou")
                       (setf remembered c)
                       (progn
                         (setf remembered nil)
                         (write-char c s)))))
          finally (when remembered
                    (write-char remembered s)))))

(defun fails (answers problem)
  (let ((keys (loop for (tag . content) in problem
                    when (eq tag :blank)
                    collect (or (getf content :regexp) (normalize-answer (getf content :key))))))
    (loop for answer in answers
          for key in keys
          for i from 0
          unless (cl-ppcre:scan key (normalize-answer answer))
          collect i)))

(defun exercise (request problems id)
  (cond ((string= (mode request) "show")
         (if (cl-containers:empty-p problems)
             (show-finish id)
             (show-problem (cl-containers:first-element problems) id)))
        ((string= (mode request) "check")
         (let ((problem (cl-containers:dequeue problems)))
           (if (fails (answer request) problem)
               (progn
                 (cl-containers:enqueue problems problem)
                 (show-mistake problem (answer request) id))
               (show-ok problem id))))))

(defun gap-to-html (gap-content number stream)
  (format stream "<input type=\"text\" name=\"answer\" id=answer~D oninput=\"add_macrons(this)\">~@[ <em>(~A)</em> ~]"
          number
          (getf gap-content :hint)))

(defun problem-to-html (problem)
  (with-output-to-string (s)
    (loop for (tag . content) in problem
          with gap-number = 0
          do (case tag
               (:text (loop for word in (split-sequence:split-sequence #\Space (first content))
                            do (write-string (add-stress word) s)
                            (write-char #\Space s)
                            finally (unread-char #\Space s)))
               (:blank (gap-to-html content gap-number s) (incf gap-number))))))

(defun answer-to-html (problem)
  (with-output-to-string (s)
    (loop for (tag . content) in problem
          do (case tag
               (:text (write-string (first content) s))
               (:blank (format s "<strong>~A</strong>" (getf content :key)))))))

(defun corrected-answer-to-html (problem answers)
  (let ((fails (fails answers problem)))
    (with-output-to-string (s)
      (loop with gap-number = 0
            for (tag . content) in problem
            do (case tag
                 (:text (write-string (first content) s))
                 (:blank (if (member gap-number fails)
                             (format s "<s>~A</s> <strong>~A</strong>" (elt answers gap-number) (getf content :key))
                             (format s "<strong>~A</strong>" (getf content :key)))
                  (incf gap-number)))))))

(defun get-immediate-bracket (string start)
  (if (or (>= start (length string))
          (not (char= (char string start) #\[)))
      (values nil start)
      (let ((end (position #\] string :start start)))
        (when (null end)
          (error "Unmatched [."))
        (values (subseq string (1+ start) end) (1+ end)))))

(defun parse-problem (string)
  (let ((start 0)
        result)
    (nreverse (loop
                (when (>= start (length string))
                  (return result))
                (let ((blank (position #\_ string :start start)))
                  (unless blank
                    (return (cons (list :text (subseq string start))
                                  result)))
                  (unless (= blank start)
                    (push (list :text (subseq string start blank)) result))
                  (multiple-value-bind (args next-start) (let ((args '())
                                                               (next-start (1+ blank))
                                                               arg)
                                                           (loop
                                                             (multiple-value-setq (arg next-start) (get-immediate-bracket string next-start))
                                                             (when (null arg)
                                                               (return (values (nreverse args) next-start)))
                                                             (push arg args)))
                    (setf start next-start)
                    (cond ((null args) (error "Key not provided."))
                          ((null (rest args)) (push (list :blank :key (first args)) result))
                          ((null (nthcdr 2 args)) (push (list :blank
                                                              :key (first args)
                                                              :hint (second args))
                                                        result))
                          ((null (nthcdr 3 args)) (push (list :blank
                                                              :key (first args)
                                                              :hint (second args)
                                                              :regexp (third args))
                                                        result))
                          (t (error "Too much arguments for a blank.")))))))))

(defun add-stress (word)
  (if (member word '("illīc" "adhūc" "addūc" "tantōn") :test #'string-equal)
      (concatenate 'string
                   (subseq word 0 (1- (length word)))
                   (list #\COMBINING_ACUTE_ACCENT (char word (1- (length word)))))
      (flet ((vowelp (c) (find c "aeiouāēīōū" :test #'char-equal))

             (short-vowel-p (c) (find c "aeiou" :test #'char-equal))
             (mutap (c) (find c "bcdfgpt" :test #'char-equal))
             (liquidap (c) (find c "rlmn" :test #'char-equal)))
        (flet ((get-vowel (start)
                 (loop for i from start downto 0
                       when (and (vowelp (char word i))
                                 (or (zerop i)
                                     (char-not-equal (char word (1- i)) #\q)))
                       do (return i)
                       finally (return nil))))
          (let* ((vowel-1 (get-vowel (1- (length word))))
                 (vowel-2 (and vowel-1 (get-vowel (1- vowel-1))))
                 (vowel-3 (and vowel-2 (get-vowel (1- vowel-2)))))
            (if (and vowel-3
                     (short-vowel-p (char word vowel-2))
                     (or (and (= (- vowel-1 vowel-2) 1))
                         (and (= (- vowel-1 vowel-2) 2)
                              (not (find (char word (1+ vowel-2)) "jz" :test #'char-equal)))
                         (and (= (- vowel-1 vowel-2) 3)
                              (mutap (char word (1+ vowel-2)))
                              (liquidap (char word (+ vowel-2 2))))))
                (concatenate 'string
                             (subseq word 0 (1+ vowel-3))
                             (list #\COMBINING_ACUTE_ACCENT)
                             (subseq word (1+ vowel-3)))
                word))))))

(defun add-stresses (text)
  (flet ((latin-letter-p (c) (string= (cl-unicode:script c) "Latin"))
         )
    (with-output-to-string (s)
      (loop with start = 0
        for word-start = (position-if #'latin-letter-p text :start start)
        for word-end = (and word-start (position-if (complement #'latin-letter-p) text :start word-start))
        do (write-string (subseq text start word-start) s)
        (when word-start
          (write-string (add-stress (subseq text word-start word-end)) s))
        (setf start word-end)
        while (and word-start word-end)
        finally (when start
                  (write-string (subseq text start) s))))))

(defun emit-html (parsed-markup &optional stream)
  (if (atom parsed-markup)
      (princ parsed-markup stream)
      (let ((head (first parsed-markup))
            (body (rest parsed-markup)))
        (macrolet ((do-body ()
                     '(dolist (item body)
                        (emit-html item stream))))
          (ecase head
            (:body (do-body))
            (:p (write-line "<p>" stream) (do-body) (write-line "</p>" stream))
            (:e (write-string "<em>" stream) (do-body) (write-string "</em>" stream))
            (:b (write-string "<strong>" stream) (do-body) (write-string "</strong>" stream))
            (:h1 (write-line "<h1>" stream) (do-body) (write-line "</h1>" stream))
            (:h2 (write-line "<h2>" stream) (do-body) (write-line "</h2>" stream))
            (:h3 (write-line "<h3>" stream) (do-body) (write-line "</h3>" stream))
            (:la (write-string (add-stresses (with-output-to-string (s)
                                               (emit-html (first body) s)))
                               stream)))))))

(defun unit2html (file)
  (let ((path (merge-pathnames file (asdf:system-source-directory "lat"))))
    (with-output-to-string (s)
      (emit-html (com.gigamonkeys.markup:parse-file path) s))))

(djula::def-filter :unit2html (file)
  (unit2html file))

(defparameter *toc* '((:type :lesson :id 0 :title "Алфавит и произношение")
                      (:type :lesson :id 1 :title "Quid facis?")
                      (:type :exercise :lesson 1 :uri "/lat/p1e1")
                      (:type :lesson :id 2 :title "Quid vīs?")
                      (:type :exercise :lesson 2 :uri "/lat/p2e1")
                      (:type :lesson :id 3 :title "Fac! Nōlī facere!")
                      (:type :exercise :lesson 3 :id "3a" :uri "/lat/p3e1")
                      (:type :exercise :lesson 3 :id "3b" :uri "/lat/p3e2")
                      (:type :lesson :id 4 :title "Vīs facere sed nōn facis")
                      (:type :exercise :lesson 4)
                      ))

(defun toc-item-type (description)
  (getf description :type))

(defun toc-exercise-lesson (exercise)
  (getf exercise :lesson))

(defun toc-item-id (item)
  (or (getf item :id )
      (and (eql (toc-item-type item) :exercise)
           (toc-exercise-lesson item))))

(defun toc-item-default-uri (item)
  (ecase (toc-item-type item)
    (:lesson (format nil "/lat/p~D" (toc-item-id item)))
    (:exercise (format nil "/lat/e~A" (toc-item-id item)))))

(defun toc-item-uri (item)
  (or (getf item :uri)
      (toc-item-default-uri item)))

(defun toc-item-title (item)
  (getf item :title))

(defun toc-item-full-title (item)
  (case (toc-item-type item)
    (:lesson (format nil "~:[Урок ~D.~;Вводный урок.~*~] ~A" (zerop (toc-item-id item)) (toc-item-id item) (toc-item-title item)))
    (:exercise (format nil "Упражнение ~A" (toc-item-id item)))))

(defparameter *menu-classes*
  '((:lesson "menu-button-lesson")
    (:exercise "menu-button-exercise")))

;; current: (:lesson 1)
(defun menu (&optional current)
  (loop for item in *toc*
        collect `((:href . ,(toc-item-uri item))
                  (:title . ,(toc-item-full-title item))
                  (:class . ,(format nil "~A~:[~; menu-button-current~]"
                                     (second (assoc (toc-item-type item) *menu-classes*))
                                     (equal (list (toc-item-type item)
                                                  (toc-item-id item))
                                            current)))
                  (:text . ,(toc-item-id item)))))

#+nil (with-open-file (in (asdf:system-relative-pathname "lat" "templates/units/p2.html") 
                  :direction :input)
  (with-open-file (out (asdf:system-relative-pathname "lat" "templates/units/p2-accents.html")
                       :direction :output
                       :if-exists :supersede)
    (loop for line = (read-line in nil)
          while line
          do (write-line (add-stresses line) out))))