;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: expression-glyph-pane.lsp
;;;;    System: 
;;;;    Author: Shawn Nicholson
;;;;   Created: November 14, 2002 13:05:02
;;;;   Purpose: 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Sunday, November 17, 2002 at 22:14:56 by nicholson
;;;; ---------------------------------------------------------------------------

(in-package :text-editor-case-display)

(defclass mouse-movement-recorder ()
  ((last-obj-under-mouse :accessor last-obj-under-mouse :initform nil
                         :documentation "A record of the last object found under 
                            the mouse")
   (obj-to-be-dragged :accessor obj-to-be-dragged :initform nil)
   (obj-being-dragged :accessor obj-being-dragged :initform nil
                      :documentation "A handle to the object being dragged")
   (obj-selected :accessor obj-selected :initform nil)
   (selected-expression-word :accessor selected-expression-word :initform nil)
   (new-dragged-elem-screen-box :accessor new-dragged-elem-screen-box :initform nil
                                :documentation "The new screenbox as you drag an item")
   (initial-cursor-pos :accessor initial-cursor-pos :initform nil
                       :documentation "The position of the cursor when it's first
                         clicked on an object")
   (left-dist :accessor left-dist :initform nil
              :documentation "The distance from the initial placement of the mouse 
                 to the left edge of the object it was clicked on")
   (top-dist :accessor top-dist :initform nil
             :documentation "The distance from the initial placement of the mouse 
                 to the top edge of the object it was clicked on")
   ))

(defclass expression-display-pane (cg:dialog)
  ((display-gridlines? :accessor display-gridlines? :initform nil :initarg :display-gridlines?)
   (pidginize? :accessor pidginize? :initform nil :initarg :pidginize?)
   (expressions :accessor expressions :initform nil :initarg :expressions
                :documentation "A list of the expression objects (each of type
                  expression-glyphs)")
   (win-height :accessor win-height :initform nil
               :documentation "A record of the height of the window so I can grab the height
                that the window *was* just before a resize-window event - since ACL stupidly
                does all the resize operations BEFORE they call resize-window - so by the time
                you get your hands on that method - the original information is already gone")
   (win-width :accessor win-width :initform nil)
   
   (mouse-recorder :accessor mouse-recorder :initform (make-instance 'mouse-movement-recorder))
   ))


(defmethod initialize-instance :after ((expr-pane expression-display-pane) &rest initargs)
  (setf (cg:transparent-character-background expr-pane) t)
  (setf (win-height expr-pane) (cg:interior-height expr-pane))
  (setf (win-width expr-pane) (cg:interior-width expr-pane))
  expr-pane)

(defun make-expression-display-window (&rest initargs &key (name :expr-display) 
                                             (background-color cg:white)
                                             (class 'expression-display-pane)
                                             (owner (cg:screen cg:*system*))
                                             &allow-other-keys)
  (let ((other-initargs (remove-keywords '(:class :name :background-color
                                             :owner) initargs)))
    (apply #'cg:make-window (append (list name                              
                                          :class class
                                          :owner owner
                                          :background-color background-color)
                                    other-initargs))))


(defmethod assign-expressions (expr-list (expr-pane expression-display-pane)
                                         &key (class 'expression-glyph))
  (setf (expressions expr-pane) (mapcar #'(lambda (expr)
                                            (make-instance class :expression expr))
                                  expr-list))
  (cg:invalidate expr-pane))

    

(defmethod get-expression-width ((win expression-display-pane) screen-width left)
  (let ((cur-font-char-width (cg:stream-string-width win "W")))
    (ceiling (* 1.75 (/ screen-width cur-font-char-width)))))

(defparameter *space-expression-height* 20)


(defmethod display-gridline ((win expression-display-pane) line-left line-right)
  (when (display-gridlines? win)
    (let ((left-x (cg:position-x line-left))
          (right-x (cg:position-x line-right))
          (y (- (cg:position-y line-left) 2)))
      (cg:with-foreground-color (win cg:light-gray)
        (cg:draw-line win (cg:make-position left-x y)
                      (cg:make-position right-x y))))))    
         
(defmethod redisplay-expressions ((win expression-display-pane) box)
  (let ((last-bottom-value nil))
    (dolist (expr (expressions win))
      (let ((sbox (screen-box expr))
            (screen-bottom? (and last-bottom-value
                                 (contained-in-box? last-bottom-value box))))
        (when (and (not screen-bottom?)
                   (> (cg:top sbox) (cg:bottom box)))
          (return-from redisplay-expressions))
        (when (or (boxes-intersect? box sbox)
                  screen-bottom?)
          (redisplay-expression expr win))
        (display-gridline win (cg:box-bottom-left sbox) (cg:box-bottom-right sbox))
        (setf last-bottom-value (cg:box-bottom-left sbox))))))

        
(defmethod compute-expression-screen-boxes ((win expression-display-pane) &key (force-refresh? nil))
  (let* ((left-border-width 5)
         (top-border-width 10)
         (expr-width-pixel (- (cg:width win) (* 2 left-border-width)))
         (max-expr-char-width (get-expression-width win expr-width-pixel left-border-width))
         (curr-top top-border-width))
    (dolist (expr (expressions win))
      (setf curr-top (compute-screen-box expr win left-border-width curr-top max-expr-char-width)))))


(defmethod cg:redisplay-window ((win expression-display-pane) &optional box)
  (call-next-method)
  (compute-expression-screen-boxes win)
  (redisplay-expressions win box))
  
  

(defmethod cg:resize-window ((win expression-display-pane) position)
  ;; I specialize this because they don't seem to invalidate the window 
  ;;  when they resize it
  ;; if the bottom of the last expression was higher than the 
  ;;  bottom of the original window - and is still higher than
  ;;  the new bottom - we don't need to resize
  (let ((bottom-expr (screen-box (first (last (expressions win))))))
    (when bottom-expr
      (let ((last-exp-bottom (+ 5 (cg:bottom bottom-expr)))
            (original-height (win-height win)))
        (when (or (not (= (win-width win) (cg:interior-width win)))
                  (not (and (< last-exp-bottom original-height)
                            (< last-exp-bottom (cg:interior-height win)))))
          (cg:invalidate win))))
    (setf (win-height win) (cg:interior-height win))
    (setf (win-width win) (cg:interior-width win))))




;;;;;
;;;; Mouse Events
;;;

(defun retrieve-mouse-over-object (win cursor-pos)
  (let ((obj (find-if #'(lambda (expr-box)
                          (contained-in-box? cursor-pos expr-box))
                      (expressions win) :key 'screen-box)))
    obj))



(defmethod drag-expression-glyph ((win expression-display-pane) 
                                  (expr expression-glyph)
                                  cursor-pos)
  (let* ((orig-screen-box (screen-box expr))
         (new-screen-box (adjust-box-on-position orig-screen-box cursor-pos
                                                 (left-dist (mouse-recorder win))
                                                 (top-dist (mouse-recorder win))))
         (last-moved-screen-box (new-dragged-elem-screen-box (mouse-recorder win))))
    (when last-moved-screen-box
      (cg:redisplay-window win last-moved-screen-box))
    (setf (new-dragged-elem-screen-box (mouse-recorder win)) new-screen-box)
    (draw-dragged-expression expr win (cg:top new-screen-box) (cg:left new-screen-box)
                             (cg:width new-screen-box) (cg:height new-screen-box))))


(defun moved-far-enough? (cursor-pos win)
  (or (> (abs (- (cg:position-y cursor-pos)
                 (cg:position-y (initial-cursor-pos (mouse-recorder win)))))
         10)
      (> (abs (- (cg:position-x cursor-pos)
                 (cg:position-x (initial-cursor-pos (mouse-recorder win)))))
         10)))


(defmethod cg:mouse-moved ((win expression-display-pane) buttons cursor-pos)
  (call-next-method)
  (let ((expr (retrieve-mouse-over-object win cursor-pos)))
    (when (and expr (not (equal expr (last-obj-under-mouse (mouse-recorder win)))))
      (setf (last-obj-under-mouse (mouse-recorder win)) expr))
    (when (and (eq buttons cg:left-mouse-button)
               (obj-to-be-dragged (mouse-recorder win))
               (moved-far-enough? cursor-pos win))
      (setf (obj-being-dragged (mouse-recorder win)) (obj-to-be-dragged (mouse-recorder win)))
      (setf (obj-to-be-dragged (mouse-recorder win)) nil))
    (when (and (obj-being-dragged (mouse-recorder win))
               (moved-far-enough? cursor-pos win))
      (drag-expression-glyph win (obj-being-dragged (mouse-recorder win)) cursor-pos))))


(defmethod highlight ((expr expression-glyph))
  (setf (highlighted? expr) t))

(defmethod unhighlight ((expr expression-glyph))
  (setf (highlighted? expr) nil))

(defmethod unhighlight-highlighted-expression ((win expression-display-pane))
  (let ((h-expr (find-if 'highlighted? (expressions win))))
    (when h-expr
      (unhighlight h-expr)
      (cg:invalidate win :box (screen-box h-expr)))))

(defmethod highlight-expression ((win expression-display-pane) cursor-pos)
  (let ((expr (retrieve-mouse-over-object win cursor-pos)))
    (unless (highlighted? expr)
      (unhighlight-highlighted-expression win)
      (highlight expr)
      (cg:invalidate win :box (screen-box expr)))))

(defmethod get-expression-display-form ((win expression-display-pane) expr)
  (if (pidginize? win)
    (pidgin-expression expr)
    (pprint-expression expr (pprint-form-width expr))))


(defmethod find-string-pos ((win expression-display-pane) expr cursor-pos)
  ;; Returns 6 values - 
  ;;  1st - binary indicating whether the spot was found or not
  ;;  2nd - the position in the string where the mouse was clicked
  ;;  3rd - the position of the closest whitespace before the found position
  ;;  4th - the position of the closest whitespace after the found position
  ;;  5th - the windows X-coord position of the pre-whitespace
  ;;  6th - the windows X-coord position of the post-whitespace
  ;;  7th - the windows Y-coord position of the selected word
  (let ((x-pos (cg:position-x cursor-pos))
        (y-pos (cg:position-y cursor-pos))
        (expr-box (expression-screen-box expr))
        (expr-str (get-expression-display-form win expr)))
    (let* ((dist-down (- y-pos (cg:top expr-box)))
           (line-no (truncate dist-down (cg:line-height win)))
           (y-pos (+ (cg:top expr-box) (* line-no (cg:line-height win))))
           (width-so-far 5)
           (line-counter 0)
           (search-done? nil)
           (spot-found? nil)
           (spot-pos 0)
           (pre-word-space-marker 0)
           (pre-word-x-pos 5)
           (post-word-space-marker 0)
           (post-word-x-pos 0))
      (do ((i 0 (+ i 1)))
          (search-done?
           (values spot-found? spot-pos pre-word-space-marker post-word-space-marker
                   pre-word-x-pos post-word-x-pos y-pos))
        (let* ((char (elt expr-str i))
               (char-width (cg:stream-char-width win char)))
          (when (and (>= width-so-far x-pos)
                     (= line-counter line-no)
                     (not spot-found?))
            (setf spot-found? t)
            (setf spot-pos i))
          (cond ((= i (length expr-str))
                 (setf post-word-space-marker i)
                 (setf post-word-x-pos width-so-far)
                 (setf search-done? t))
                ((and (not spot-found?)
                      (eq char #\space))
                 (setf width-so-far (+ width-so-far char-width))
                 (setf pre-word-x-pos width-so-far)
                 (setf pre-word-space-marker i))
                ((and spot-found? 
                      (or (eq char #\space)
                          (eq char #\newline)))
                 (setf search-done? t)
                 (setf post-word-x-pos width-so-far)
                 (setf post-word-space-marker i)
                 (cond ((eq char #\newline)
                        (incf line-counter)
                        (setf width-so-far 5))
                       (t
                        (setf width-so-far (+ width-so-far char-width)))))
                ((eq char #\newline)
                 (incf line-counter)
                 (setf width-so-far 5))
                (t
                 (setf width-so-far (+ width-so-far char-width)))))))))

(defun extract-word (str)
  (let ((right-trimmed (string-right-trim '(#\space #\newline) str)))
    (string-left-trim '(#\space) right-trimmed)))

(defun fully-strip (str)
  (let ((right-trimmed (string-right-trim '(#\space #\) #\newline) str)))
    (string-left-trim '(#\( #\space) right-trimmed)))

(defmethod highlight-word-in-expression ((win expression-display-pane) expr cursor-pos)
  (let ((expr-box (expression-screen-box expr)))
    (when (and (contained-in-box? cursor-pos expr-box)
               (expression expr))
      (redisplay-expression expr win)
      (display-gridline win (cg:box-bottom-left (screen-box expr)) (cg:box-bottom-right (screen-box expr)))
      (let ((expr-disp (get-expression-display-form win expr)))
        (multiple-value-bind (found-pos pos word-start word-end start-x end-x top-y)
            (find-string-pos win expr cursor-pos)
          (when found-pos
            (let* ((word (subseq expr-disp word-start word-end))
                   (stripped-word (extract-word word))
                   (word-fill-box (cg:make-box-relative start-x top-y (- end-x start-x)
                                                        (cg:line-height win)))
                   (word-box (cg:make-box-relative start-x top-y (- end-x start-x)
                                                   (cg:line-height win))))
              (setf (selected-expression-word (mouse-recorder win)) (fully-strip stripped-word))
              (cg:with-foreground-color (win cg:black)
                (cg:fill-box win word-fill-box))
              (cg:with-foreground-color (win cg:white)
                (cg:draw-string-in-box win stripped-word nil nil word-box :top :left)))))))))             


(defmethod select-left-mouse-click ((win expression-display-pane) buttons cursor-pos)
  (let ((expr (retrieve-mouse-over-object win cursor-pos)))
    (unless expr
      (setf (obj-selected (mouse-recorder win)) nil)
      (unhighlight-highlighted-expression win))
    (when expr
      (when (highlighted? expr)
        (highlight-word-in-expression win expr cursor-pos))
      (highlight-expression win cursor-pos)
      (setf (obj-to-be-dragged (mouse-recorder win)) expr)
      (setf (obj-selected (mouse-recorder win)) expr)
      (setf (initial-cursor-pos (mouse-recorder win)) cursor-pos)
      (setf (left-dist (mouse-recorder win)) (abs (- (cg:position-x cursor-pos)
                                                     (cg:left (screen-box expr)))))
      (setf (top-dist (mouse-recorder win)) (abs (- (cg:position-y cursor-pos)
                                                    (cg:top (screen-box expr))))))))
  
(defmethod cg:mouse-left-down ((win expression-display-pane) buttons cursor-pos)
  (call-next-method)
  (select-left-mouse-click win buttons cursor-pos))


(defun move-expr-to-position (expr win pos)
  (let* ((original-position (position expr (expressions win) :test 'equal))
         (exprs (delete expr (expressions win) :test 'equal))
         (new-pos (if (> pos original-position)
                    (- pos 1)
                    pos)))
    (setf (expressions win) (insert expr exprs new-pos))))
    
(defmethod determine-new-position (cursor-pos (win expression-display-pane))
  (let* ((expr-at-pos (retrieve-mouse-over-object win cursor-pos))
         (expr-position (position expr-at-pos (expressions win)))
         (sbox (screen-box expr-at-pos))
         (box-midpoint (+ (cg:top sbox) 
                          (ceiling (/ (- (cg:bottom sbox) (cg:top sbox)) 2)))))
    (if (> (cg:position-y cursor-pos) box-midpoint)
      (+ expr-position 1)
      expr-position)))
    

(defmethod move-expression ((win expression-display-pane) cursor-pos)
  ;; handle border cases special
  (let ((dragged-expr (obj-being-dragged (mouse-recorder win))))
  (cond ((<= (cg:position-y cursor-pos) 10)
         (move-expr-to-position dragged-expr win 0))
        ((>= (cg:position-y cursor-pos) 
             (cg:bottom (screen-box (first (last (expressions win))))))
         (move-expr-to-position dragged-expr win (length (expressions win))))
        (t
         (move-expr-to-position dragged-expr win (determine-new-position cursor-pos win))))))

(defmethod cg:mouse-left-up ((win expression-display-pane) buttons cursor-pos)
  (call-next-method)
  (when (obj-being-dragged (mouse-recorder win))
    (move-expression win cursor-pos)
    (cg:invalidate win))
  (setf (obj-to-be-dragged (mouse-recorder win)) nil)
  (setf (obj-being-dragged (mouse-recorder win)) nil))

;;;;;;;;;;;;;;;;;;;;
;;; Key Events


(defmethod insert-space ((win expression-display-pane) pos)
  (let ((space (make-instance 'expression-glyph)))
    (setf (expressions win)
      (insert space (expressions win) pos))
    (cg:invalidate win)))

(defmethod remove-space ((win expression-display-pane) pos)
  (let ((space-pos (- pos 1)))
    (unless (< space-pos 0)
      (let ((prev-expr (nth space-pos (expressions win))))
        (when (null (expression prev-expr))
          (setf (expressions win)
            (delete prev-expr (expressions win) :test 'equal))
          (cg:invalidate win))))))

(defmethod highlight-next-expression ((win expression-display-pane) expr)
  (let ((pos (+ 1 (position expr (expressions win)))))
    (unless (>= pos (length (expressions win)))
      (unhighlight expr)
      (cg:invalidate win :box (screen-box expr))
      (setf (obj-selected (mouse-recorder win)) nil)
      (let ((next-expr (nth pos (expressions win))))
        (setf (obj-selected (mouse-recorder win)) next-expr)
        (highlight next-expr)
        (cg:invalidate win :box (screen-box next-expr))))))
    
(defmethod highlight-prev-expression ((win expression-display-pane) expr)
  (let ((pos (- (position expr (expressions win)) 1)))
    (unless (< pos 0)
      (unhighlight expr)
      (cg:invalidate win :box (screen-box expr))
      (let ((prev-expr (nth pos (expressions win))))
        (setf (obj-selected (mouse-recorder win)) prev-expr)
        (highlight prev-expr)
        (cg:invalidate win :box (screen-box prev-expr))))))


;; I would have preferred to use the key-down event - however enter key 
;;  doesn't seem to trigger a key-down event
(defmethod cg:virtual-key-up ((win expression-display-pane) buttons key-code)
  (call-next-method)
  (let ((selected-expr (obj-selected (mouse-recorder win))))
    (when (null selected-expr)
      (cond ((eq key-code cg:vk-return)
             (insert-space win (length (expressions win))))
            ((eq key-code cg:vk-backspace)
             (remove-space win (length (expressions win))))
            (t )))
    (when selected-expr
      (cond ((eq key-code cg:vk-return)
             (insert-space win (position selected-expr (expressions win))))
            ((eq key-code cg:vk-backspace)
             (remove-space win (position selected-expr (expressions win))))
            ((eq key-code cg:vk-down)
             (highlight-next-expression win selected-expr))
            ((eq key-code cg:vk-up)
             (highlight-prev-expression win selected-expr))
            (t
             )))))


;;;;;;;;;;;;;;;;;;;;;;

(defmethod edit-expression ((win expression-display-pane))
  (format t "Editing expression~%"))

(defmethod information-about-word ((win expression-display-pane))
  (format t "Info about word~%"))

(defmethod cg:shortcut-commands ((win expression-display-pane) menu)
  (declare (ignore menu))
  (list (make-instance 'cg:menu-item
          :title "Edit Expression"
          :value 'edit-expression)
        (make-instance 'cg:menu-item
          :title (format nil "Information about ~A" (selected-expression-word (mouse-recorder win)))
          :value 'information-about-word)))


(defmethod select-right-mouse-click ((win expression-display-pane) buttons cursor-pos)
  (let ((expr (retrieve-mouse-over-object win cursor-pos)))
    (unless expr
      (setf (obj-selected (mouse-recorder win)) nil)
      (unhighlight-highlighted-expression win))
    (when expr
      (highlight-word-in-expression win expr cursor-pos)
      (highlight-expression win cursor-pos)
      (setf (obj-to-be-dragged (mouse-recorder win)) expr)
      (setf (obj-selected (mouse-recorder win)) expr)
      (setf (initial-cursor-pos (mouse-recorder win)) cursor-pos)
      (setf (left-dist (mouse-recorder win)) (abs (- (cg:position-x cursor-pos)
                                                     (cg:left (screen-box expr)))))
      (setf (top-dist (mouse-recorder win)) (abs (- (cg:position-y cursor-pos)
                                                    (cg:top (screen-box expr))))))))

(defmethod cg:mouse-right-down ((win expression-display-pane) buttons cursor-pos)
  (select-right-mouse-click win buttons cursor-pos)
  (call-next-method))



;;;;;;;;;;;;;;;;;;
;;; Testing

(defun l1 ()
  '((data::causes-PropProp (data::isa (data::homeheatingsystemfn data::foobar) data::recirculatedwaterheating) 
                           (data::transportees data::waterflow data::heat))
    (data::isa data::foo data::bar)
    nil
    nil
    (data::shawn data::is data::programming data::this)
    (data::what data::do data::you data::know?)))

(defun test-expression-display (&rest initargs &key (width 500) (height 300) 
                                      &allow-other-keys)
  (let* ((other-initargs (remove-keywords '(:width :height) initargs))
         (w1 (apply 'make-expression-display-window (append (list :width width
                                                                  :height height)
                                                            other-initargs))))
      (assign-expressions (l1) w1)
      (setf (display-gridlines? w1) t)
      w1))
    



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of Code