bug using array dialog items

[dfoster@ils.nwu.edu]

Any suggestions about the following MCL 2.0 problem?

 
;;;  David Foster
;;;  The Institute for the Learning Sciences
;;;  dfoster@ils.nwu.edu
;;;

;;;-----------------------------------------------------------------------
;;;  Bug: when setting the frame of an array dialog item to *white-color*,
;;;  the window refreshes don't work properly on the cells of the array
;;;  dialog item.  Cell contents go away, parts of cells covered by other
;;;  windows never are fixed, etc.
;;;-----------------------------------------------------------------------

;;; required: code for "array-dialog-item", included in Examples Folder


;;;  To observe the problem, type (doit).  Play around with clicking on
;;;  cells, switching back and forth between windows, partially covering
;;;  highlighted cells with another window and then reactivating the
;;;  window, and so forth.


;;;----------------------array dialog item stuff (should be fine)  ---
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(array-dialog-item table-array h-specifier v-specifier
table-subscript
            set-table-array set-h-specifier set-v-specifier
set-table-subscript)))

(defclass array-dialog-item (table-dialog-item)
  ((array :reader table-array :writer (setf table-array-slot))
   (dimensions :accessor table-array-dimensions)
   (h-specifier :reader h-specifier :writer (setf h-specifier-slot))
   (v-specifier :reader v-specifier :writer (setf v-specifier-slot))
   (table-subscript :reader table-subscript :writer (setf
table-subscript-slot))))  
(defmethod initialize-instance ((item array-dialog-item) &rest rest &key
                                (table-array #2a((0 0)(0 0)))
                                (h-specifier 0)
                                (v-specifier 1)
                                table-subscript table-dimensions)
  (declare (dynamic-extent rest))
  (let ((array-dimensions (array-dimensions table-array)))
    (if (< (length array-dimensions) 2)
      (error "Arrays for array-dialog-items must have two or more
dimensions.
Passed array is: ~s. Use sequence-dialog-items for vectors." table-array))
    (if table-subscript
      (unless (eql (length table-subscript) (length array-dimensions))
        (error "table-subscript is the wrong length."))
      (setq table-subscript
            (make-list (length array-dimensions) :initial-element 0)))
    (setq table-dimensions
          (if table-dimensions
            (require-type table-dimensions 'integer)
            (make-point (elt array-dimensions h-specifier)
                        (elt array-dimensions v-specifier))))
    (setf (table-array-slot item) table-array
          (table-array-dimensions item) array-dimensions
          (h-specifier-slot item) h-specifier
          (v-specifier-slot item) v-specifier
          (table-subscript-slot item) table-subscript)
    (apply #'call-next-method
           item
           :table-dimensions table-dimensions
           rest)))

(defmethod cell-to-subscript ((item array-dialog-item) point)
  (let ((table-subscript (table-subscript item)))
    (setf (elt table-subscript (h-specifier item)) (point-h point))
    (setf (elt table-subscript (v-specifier item)) (point-v point))
    (if (apply #'array-in-bounds-p (table-array item) table-subscript)
      table-subscript)))

(defmethod subscript-to-cell ((item array-dialog-item) subscript)
  (let ((table-subscript (table-subscript item))
        (h-specifier (h-specifier item))
        (v-specifier (v-specifier item)))
    (if (eq (length subscript) (length table-subscript))
      (progn
        (setf (elt table-subscript (h-specifier item)) (elt subscript
h-specifier))
        (setf (elt table-subscript (v-specifier item)) (elt subscript
v-specifier))
        (if (equal subscript table-subscript)
          (make-point (elt subscript h-specifier) (elt subscript
v-specifier)))))))

(defmethod cell-contents ((item array-dialog-item) h &optional v &aux
subscript)
  (if (setq subscript (cell-to-subscript item (make-point h v)))
      (apply #'aref (table-array item) subscript)
      ""))

(defun readjust-table-dimensions (item)
  (let ((array-dimensions (array-dimensions (table-array item))))
    (set-table-dimensions item
                          (elt array-dimensions (h-specifier item))
                          (elt array-dimensions (v-specifier item)))))

(defmethod set-h-specifier ((item array-dialog-item) dimension)
  (setf (h-specifier-slot item) dimension)
  (readjust-table-dimensions item)
  dimension)

(defmethod set-v-specifier ((item array-dialog-item) dimension)
  (setf (v-specifier-slot item) dimension)
  (readjust-table-dimensions item)
  dimension)

(defmethod set-table-array ((item array-dialog-item) new-array)
  (let ((array-dimensions (array-dimensions new-array)))
    (if (< (length array-dimensions) 2)
      (error "Arrays for array-dialog-items must have two or more
dimensions.
Passed array is: ~s. Use sequence-dialog-items for vectors." new-array))
    (setf (table-array-dimensions item) array-dimensions)
    (setf (table-array-slot item) new-array)
    (setf (h-specifier-slot item) 0)
    (setf (v-specifier-slot item) 1)
    (setf (table-subscript-slot item)
          (make-sequence 'list (length array-dimensions) :initial-element
0))
    (readjust-table-dimensions item)
    new-array))

(defmethod set-table-subscript ((item array-dialog-item) new-subscript)
  (if (apply #'array-in-bounds-p (table-array item) new-subscript)
    (progn
      (setf (table-subscript-slot item) new-subscript)
      (readjust-table-dimensions item)
      new-subscript)
    (error "Subscript ~s Out of bounds" new-subscript)))
;;;-------------------------------------------------------------------------
--



;;;------------------------------------------ the test code...
--------------
;;;

(defclass adi-1 (array-dialog-item) ())

(defparameter *y* 0)

(defun doit ()           ;;; execute this function
  (setq *y* 0)
  (setq w
        (make-instance 'window
          :view-size (make-point 400 190) ))
  (setq a1
        (make-instance 'adi-1
             :table-array 
             (make-array '(1 15) :initial-element "one..")
             :view-position (make-point 0 0)
             :view-size (make-point 48 165)
             :table-vscrollp nil
             :table-hscrollp nil
             :view-font '("Geneva" 9   :PLAIN)
             :view-container w
             ))
  (setq a2
        (make-instance 'adi-1
             :table-array 
             (make-array '(1 15) :initial-element "two.........    ")
             :view-position (make-point 60 0)
             :table-vscrollp nil
             :table-hscrollp nil
             :view-size (make-point 148 165)
             :view-font '("Geneva" 9   :PLAIN)
             :view-container w
             ))
  (set-part-color a2 :frame *white-color*)  ;; *** here's the bugger ***
  )
 
(defmethod view-click-event-handler ((i adi-1) where)
  (let ((n (floor (/ (+ 1 (point-v where)) 12))))
    (print n)
    (cell-deselect a1 0 *y*)
    (cell-deselect a2 0 *y*)
    (setq *y* n)
    (cell-select a1 0 n)
    (cell-select a2 0 n)))    ;just makes the two behave like one
_________________________________________________________________
David Foster         |  A thought may be compared to a cloud
Institute for the    |  shedding a shower of words.  
 Learning Sciences   |                             - L. Vgotsky
dfoster@ils.nwu.edu  |                           
(708) 467-1771       |  [snicker] yeah, [snort] sure. 
                     |                             - D. Foster