;;;; it-lookup.lisp

 (in-package #:it-lookup)

 (declaim (optimize (debug 3)))

 ;;; "it-lookup" goes here. Hacks and glory await!

 
 (defparameter *post-url*  "http://www.corpusthomisticum.org/it/index.age")
 
 (defparameter *cookie-jar* (make-instance 'drakma:cookie-jar))
 

 (defun run-query (results)
   (with-accessors ((query query) (page page)) results
     (drakma:http-request *post-url*
                          :method :POST
                          :parameters `(("text" . ,query)
                                        ("Form.option.concordances" . "concordances")
                                        ("results.currentPage" . ,(prin1-to-string page)))
                          :cookie-jar *cookie-jar*)))

 
 (defclass it-case ()
   ((reference :initarg :reference :accessor case-reference)
    (text :initarg :text :accessor case-text)))
 

 (defun make-adjustable-vector (&optional (base-size 10))
   (make-array base-size :adjustable t :fill-pointer 0))
 
 (defun to-adjustable-vector (values)
   (let ((els (length values)))
     (make-array els
                 :adjustable t
                 :fill-pointer els
                 :initial-contents values)))
 
 (defclass it-results ()
   ((%query :initarg :query :accessor query :initform (make-adjustable-vector))
    (%page :initarg :page :accessor page :initform 1)
    (%cases :initarg :cases :accessor cases)))
 

 (defmethod initialize-instance :after ((object it-case) &key)
   (with-slots (reference text) object
     (when (arrayp reference)
       (setf reference (elt reference 0)))
     (when (plump:element-p reference)
       (setf reference (plump-dom:text reference)))
     (setf text (subseq text (+ (search reference text) (length reference))))

     (setf reference (string-right-trim '(#\space) reference))))

 
 (defmacro make-constructor (class &rest initargs)
   (let ((initarg-syms (mapcar #'(lambda (x) x (gensym)) initargs)))
     `(defun ,(intern (concatenate 'string (string 'make-) (string class))) ,initarg-syms
        (make-instance ',class ,@(loop for initarg in initargs
                                      for sym in initarg-syms
                                      nconc (list initarg sym))))))
 
 (make-constructor it-case :reference :text)

 (make-constructor it-results :query :cases)
 
 (defun parse-results (results query-result)
   (setf (cases results)
         (lquery:$ (initialize query-result)
                   "p[title]"
                   (:combine ".ref" (text))
                   (map-apply #'make-it-case))))

 (defgeneric format-reference (it-case stream)
   (:method ((it-case it-case) stream)
    (princ (case-reference it-case) stream)
    (fresh-line stream)))
 
 (defparameter *underlying-stream* nil)
 (defun get-real-stream (&optional default)
   (or *underlying-stream* default))

 
 (defun format-result (parsed-result &optional (stream t))

   (let ((real-stream stream))

     (pprint-logical-block (stream nil)

       (let ((*underlying-stream* real-stream))
         (format-reference parsed-result stream))

       (pprint-indent :block 4 stream)
       (pprint-newline :mandatory stream)

       (with-slots (text) parsed-result
         (pprint-logical-block (stream (tokens text))
           (loop
             (princ (pprint-pop) stream)
             (pprint-exit-if-list-exhausted)
             (princ #\space stream)
             (pprint-newline :fill stream)))))))

 
 (defun format-results (parsed-results &optional (stream t))
   (fresh-line stream)

   (loop :for parsed-result :across parsed-results
         :do (format-result parsed-result stream)

         :do (terpri stream)))
 
 (defmacro compose-funcs ((&rest funcs) &rest args)
   `(funcall (compose ,@funcs) ,@args))
 
 (defun main (args)

   (let ((results (make-instance 'it-results
                                 :query nil)))
 
     (format *terminal-io* "~&Index Thomisticus Query Utility v0.1~%")
 
     (when (cadr args)
       (setf (query results) (cadr args)))
 
     (mainloop results)))
 
 (defun mainloop (results)

   (handler-case

       (labels ((next-page () (incf (page results)))
                (prev-page ()
                  (with-accessors ((current-page page)) results
                    (when (> current-page 0)
                      (decf current-page))))
                (print-results (results)
                  (format *terminal-io* "~&Query: ~a, Page: ~3d~%"
                          (query results)
                          (page results)))
                (get-results (results)
                  (with-accessors ((page page) (query query)) results
                    (parse-results results
                                   (run-query results))
                    (format-results (cases results))))
                (do-action (action results)
                  (funcall action)
                  (get-results results)))
 

         (loop
           (format *terminal-io* "~&Query? ")
           (finish-output *terminal-io*)

           (let ((action (or (query results)
                             (read-line *terminal-io*))))

             (string-case action

               ("quit" (return-from mainloop))
               ("help"
                (format *terminal-io* "~&Help:~%~:{~4t~a: ~a~%~}~%Anything else searches.~%"
                        `(("next" "Next page of results")
                          ("prev" "Previous page of results")
                          ("quit" "Quits"))))
 

               ("prev"

                (do-action #'prev-page results))
 

               ("next"

                (do-action #'next-page results))
 
               (t (setf (query results)
                        action)
                  (get-results results)))
             (setf (query results) nil))))
 

     (end-of-file (c) (declare (ignore c)))
     (sb-sys:interactive-interrupt (c) (declare (ignore c)))))