;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: numbered-datum-list.lsp
;;;;    System: 
;;;;    Author: Shawn Nicholson
;;;;   Created: June 24, 2002 10:59:47
;;;;   Purpose: Provides a Grid Widget which does simple
;;;;            grid-separated rows of information for a given list
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Tuesday, March 4, 2003 at 09:57:12 by nicholson
;;;; ---------------------------------------------------------------------------

(in-package :textual-case-display)


(defclass numbered-datum-list (cg:grid-widget)
  ((cg:column-sections :initform (make-columns))  ;;specialize the initforms for these slots
   (cg:row-sections :initform (make-rows))
   )
  (:documentation "A grid widget which provides a numbered list of the information
      in its datum-list slot"))



(defclass ndl-column (cg:grid-column) ())

(defclass ndl-number-column (ndl-column) ())
(defclass ndl-datum-column (ndl-column) 
  ())

(defclass ndl-row (cg:grid-row) 
  ((row-num :accessor row-num :initform 0 :initarg :row-num
            :documentation "The number of this row")
   (fact :accessor fact :initform nil :initarg :fact
         :documentation "A cache of the fact stored in this cell in order to keep display happening without
           refresh delays")
   (pprint-fact :accessor pprint-fact :initform nil :initarg :pprint-fact
                :documentation "A pretty formatted version of the fact - since pretty printing is kind of slow, we
                  don't want to be doing this on every refresh.  Only update this when the window is resized (since
                  pretty printing takes into account the amount of space in the column")
   (pidginized-fact :accessor pidginized-fact :initform nil :initarg :pidginized-fact
                    :documentation "A cache of the pidginized form of the fact")
   (pprint-pidgin-fact :accessor pprint-pidgin-fact :initform nil :initarg :pprint-pidgin-fact
                       :documentation "A pretty formatted version of the pidginized fact - since pretty printing is kind of slow, we
                  don't want to be doing this on every refresh.  Only update this when the window is resized (since
                  pretty printing takes into account the amount of space in the column"))
  )


(defun make-columns ()
  (list (make-instance 'cg:grid-column-section
          :name :ndl-fact-column
          :proportional t
          :scrollbars nil
          :subsections (list (make-instance 'ndl-datum-column
                               :name :ndl-case-fact
                               :proportional t
                               :size 100)))))
                               
                               
(defun make-rows ()
  (list (make-instance 'cg:grid-row-section
          :name :ndl-rows
          :proportional t
          :scrollbars t
          :subsections nil))
  )



(defun make-row-subsection (fact)
  (let ((pidgin-error-marker t)
         (pidgin-fact nil))
    
    (ignore-errors (setq pidgin-fact (fire:pidginize fact))
                   (setq pidgin-error-marker nil))
    (when pidgin-error-marker
      (setf pidgin-fact (fire::pidginize-default fact)))
                      
    (make-instance 'ndl-row
      :name :list-fact
      :proportional nil
      :minimum-size 25
      :size 25
      :fact fact
      :pprint-fact (pretty-print-to-string fact)
      :pidginized-fact pidgin-fact
      :pprint-pidgin-fact (pretty-print-to-string pidgin-fact))))



(defmethod get-selected-grid-element ((lst-grid numbered-datum-list))
  (multiple-value-bind (row-section column-section row column row-index column-index)
      (cg:focus-cell lst-grid)
    (declare (ignore row-section column-section column row-index column-index))
    (if row
        (fact row)
      nil)))

(defmethod expression-order ((expr t)) 0)
(defmethod expression-order ((expr list))
  (+ (length expr) (reduce '+ expr :key 'expression-order)))
(defun expression-order< (x y) (< (expression-order x) (expression-order y)))


(defmethod set-list-datum ((lst-grid numbered-datum-list) new-datum-list)
  (let ((row-section (cg:row-section lst-grid :ndl-rows))
        (sorted-datum-list (if new-datum-list 
                             (sort new-datum-list 'expression-order<)
                             nil)))
    (setf (cg:subsections row-section)
      (mapcar #'make-row-subsection sorted-datum-list))))
    

(defmethod add-list-datum ((lst-grid numbered-datum-list) new-datum-list)
  ;; Like set, only doesn't replace the old datum, instead adds to it
  (let ((row-section (cg:row-section lst-grid :ndl-rows))
        (sorted-datum-list (if new-datum-list 
                             (sort new-datum-list 'expression-order<)
                             nil)))
    (setf (cg:subsections row-section)
      (append (cg:subsections row-section)
              (mapcar #'make-row-subsection sorted-datum-list)))))


(defmethod delete-list-datum ((lst-grid numbered-datum-list) del-datum-list)
  ;; del-datum-list is a list of entities to be removed 
  (let ((row-section (cg:row-section lst-grid :ndl-rows)))
    (setf (cg:subsections row-section)
      (sort (set-difference (cg:subsections row-section)
                            del-datum-list
                            :test #'(lambda (datum-list-elem del-list-elem)
                                      (equal (fact datum-list-elem) del-list-elem)))
            'expression-order<
            :key 'fact))))

(defmethod datum-list-facts ((lst-grid numbered-datum-list))
  (mapcar #'fact (cg:subsections (cg:row-section lst-grid :ndl-rows))))


(defmethod get-background-color ((ndl t) (row t))
  cg:white)

(defmethod get-foreground-color ((ndl t) (row t))
  cg:black)


(defmethod cg:cell-background-color ((row ndl-row) (column ndl-column))
  (get-background-color (cg:parent (cg:parent row)) row))

(defmethod cg:cell-foreground-color ((row ndl-row) (column ndl-column))
  (get-foreground-color (cg:parent (cg:parent row)) row))


(defmethod get-printed-fact ((ndl t) (row ndl-row))
  (pprint-fact row))


(defmethod draw-cell-contents ((ndl t) (row ndl-row) (column ndl-datum-column)
                               cell-box stream)
  (let ((fact-display (get-printed-fact ndl row)))
    (when fact-display
      (let ((display-height (cg:draw-string-in-box stream fact-display 0 (length fact-display) cell-box :left :top nil t t))
            (f-color (get-foreground-color (cg:parent (cg:parent row)) row)))
        (when (or (> display-height (cg:size row))
                  (< 25 display-height (cg:size row)))
          (setf (cg:size row) (max 25 display-height)))
        (cg:with-foreground-color (stream f-color)
          (cg:draw-string-in-box stream fact-display 0 (length fact-display) cell-box :left :top nil t))))))


(defmethod cg:draw-cell ((row ndl-row)
                         (column ndl-datum-column)
                         row-num column-num cell-box stream)
  (declare (ignore column-num row-num))
  (draw-cell-contents (cg:parent (cg:parent row)) row column cell-box stream))



(defmethod refresh-list ((lst-grid numbered-datum-list))
  (invalidate-grid-rows (cg:subsections (cg:row-section lst-grid :ndl-rows)) lst-grid))

(defmethod invalidate-grid-rows (row-list (lst-grid numbered-datum-list))
  (let ((column (cg:subsection (cg:column-section lst-grid :ndl-fact-column) :ndl-case-fact)))
    (dolist (row row-list)
      (cg:invalidate-cell row column))))

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