;;;; it-lookup.lisp

(defpackage #:it-lookup-clim
  (:use #:clim #:clim-lisp #:it-lookup))

(in-package #:it-lookup-clim)
(declaim (optimize (debug 3)))

(define-application-frame
  it-lookup ()

  ((results :initform (make-instance 'it-lookup::it-results :query "amicus") 
            :accessor results)
   (cursor :initform 0 :accessor cursor))
  (:pointer-documentation t)
  (:panes
    (app :application
         :height 400 :width 600
         :incremental-redisplay t
         :double-buffering t
         ;:display-time nil
         :display-function #'display-app
         )
    (int :interactor :height 100 :width 600))
  (:layouts
    (default (horizontally () app int))))

(defun display-app (frame pane)
  (let ((history (stream-output-history pane)))
    (loop for element across (it-lookup::cases (results frame))
          do (add-output-record (with-output-to-output-record (pane)
                                  (terpri pane)   
                                  (it-lookup::format-result element pane)
                                  (terpri pane))
                                history))
    (climacs-flexichain-output-history:change-space-requirements history) 
    (clim:replay history pane)))

(define-presentation-type reference ())
(defmethod it-lookup::format-reference :around ((it-case it-lookup::it-case)
                                               (stream clim:extended-output-stream))
  (clim:with-text-style (stream '(:serif :bold 16))
    (with-output-as-presentation (stream it-case 'reference)
      (call-next-method))))

(defmethod it-lookup::format-reference :around ((it-case it-lookup::it-case)
                                               (stream sb-pretty:pretty-stream))
  (let ((real-stream (it-lookup::get-real-stream stream)))
    (terpri stream)
    (it-lookup::format-reference it-case real-stream)))

(defun display-data (&rest args)
  (get-data))

(defun get-data ()
  (return-from get-data)
  (let* ((pane (find-pane-named *application-frame* 'app))
         (history (stream-output-history pane)))
    (loop for element across (it-lookup::cases (results *application-frame*))
          for n from 0
          do (let ((record (clim:with-output-to-output-record (pane)
                             (it-lookup::format-result element pane)
                             (terpri pane))))
               #|(climb:ou history record n)|#))
    (climacs-flexichain-output-history:change-space-requirements history) 
    (clim:replay history pane)))

(defclass no-clear-output-history (climacs-flexichain-output-history:flexichain-output-history)
  ())

(defmethod clear-output-record ((h no-clear-output-history)))

(defmethod generate-panes :after ((fm frame-manager) (frame it-lookup))
  (let ((*application-frame* frame))
    (let ((pane (clim:find-pane-named frame 'app)))
      (unless pane (break))
      (setf (clim:stream-recording-p pane) nil)
      (setf (clim:stream-end-of-line-action pane) :allow)
      (change-class (clim:stream-output-history pane)
                    ;'climacs-flexichain-output-history:flexichain-output-history
                    'no-clear-output-history
                    :parent pane))))

(defun app-main ()
  (let* ((frame (make-application-frame 'it-lookup))
         (*application-frame* frame))
    (with-accessors ((results results)) frame
      (parse-results results
                     (run-query results)))
    (run-frame-top-level frame)))

(define-it-lookup-command (com-inspect :name t) ()
  (clouseau:inspector
    (clim:stream-output-history
      (clim:find-pane-named clim:*application-frame* 'app))))

(define-it-lookup-command (get-records :name t) ()
  (get-data))

(define-it-lookup-command (com-quit :name t) ()
  (frame-exit *application-frame*))

(defparameter *saved-cases* nil)
(defun save-case (case) (push case *saved-cases*))

(define-it-lookup-command (com-save :name t) ((it-case 'reference))
  (save-case it-case)
  it-case)

(define-it-lookup-command (com-prev :name t) ()
  (let ((results (results *application-frame*)))
    (with-accessors ((page it-lookup::page)) results
      (when (> page 0)
        (decf page)))
    (parse-results results
                   (run-query results))))

(define-it-lookup-command (com-next :name t) ()
  (let ((results (results *application-frame*)))
    (incf (it-lookup::page results))
    (parse-results results
                   (run-query results))))

(setf mcclim-truetype:*truetype-font-path* "/Library/Fonts/")
(app-main)