home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #27 / NN_1992_27.iso / spool / comp / lang / lisp / mcl / 1620 < prev    next >
Encoding:
Text File  |  1992-11-18  |  7.9 KB  |  205 lines
  1. Path: sparky!uunet!charon.amdahl.com!pacbell.com!sgiblab!zaphod.mps.ohio-state.edu!saimiri.primate.wisc.edu!ames!data.nas.nasa.gov!taligent!apple!cambridge.apple.com!dfoster@ils.nwu.edu
  2. From: dfoster@ils.nwu.edu
  3. Newsgroups: comp.lang.lisp.mcl
  4. Subject: bug using array dialog items
  5. Message-ID: <9211181632.AA08546@aristotle.ils.nwu.edu>
  6. Date: 18 Nov 92 16:32:46 GMT
  7. Sender: info-mcl-request@cambridge.apple.com
  8. Lines: 194
  9. Approved: comp.lang.lisp.mcl@Cambridge.Apple.C0M
  10.  
  11. Any suggestions about the following MCL 2.0 problem?
  12.  
  13.  
  14. ;;;  David Foster
  15. ;;;  The Institute for the Learning Sciences
  16. ;;;  dfoster@ils.nwu.edu
  17. ;;;
  18.  
  19. ;;;-----------------------------------------------------------------------
  20. ;;;  Bug: when setting the frame of an array dialog item to *white-color*,
  21. ;;;  the window refreshes don't work properly on the cells of the array
  22. ;;;  dialog item.  Cell contents go away, parts of cells covered by other
  23. ;;;  windows never are fixed, etc.
  24. ;;;-----------------------------------------------------------------------
  25.  
  26. ;;; required: code for "array-dialog-item", included in Examples Folder
  27.  
  28.  
  29. ;;;  To observe the problem, type (doit).  Play around with clicking on
  30. ;;;  cells, switching back and forth between windows, partially covering
  31. ;;;  highlighted cells with another window and then reactivating the
  32. ;;;  window, and so forth.
  33.  
  34.  
  35. ;;;----------------------array dialog item stuff (should be fine)  ---
  36. ;;;
  37. (eval-when (:compile-toplevel :load-toplevel :execute)
  38.   (export '(array-dialog-item table-array h-specifier v-specifier
  39. table-subscript
  40.             set-table-array set-h-specifier set-v-specifier
  41. set-table-subscript)))
  42.  
  43. (defclass array-dialog-item (table-dialog-item)
  44.   ((array :reader table-array :writer (setf table-array-slot))
  45.    (dimensions :accessor table-array-dimensions)
  46.    (h-specifier :reader h-specifier :writer (setf h-specifier-slot))
  47.    (v-specifier :reader v-specifier :writer (setf v-specifier-slot))
  48.    (table-subscript :reader table-subscript :writer (setf
  49. table-subscript-slot))))  
  50. (defmethod initialize-instance ((item array-dialog-item) &rest rest &key
  51.                                 (table-array #2a((0 0)(0 0)))
  52.                                 (h-specifier 0)
  53.                                 (v-specifier 1)
  54.                                 table-subscript table-dimensions)
  55.   (declare (dynamic-extent rest))
  56.   (let ((array-dimensions (array-dimensions table-array)))
  57.     (if (< (length array-dimensions) 2)
  58.       (error "Arrays for array-dialog-items must have two or more
  59. dimensions.
  60. Passed array is: ~s. Use sequence-dialog-items for vectors." table-array))
  61.     (if table-subscript
  62.       (unless (eql (length table-subscript) (length array-dimensions))
  63.         (error "table-subscript is the wrong length."))
  64.       (setq table-subscript
  65.             (make-list (length array-dimensions) :initial-element 0)))
  66.     (setq table-dimensions
  67.           (if table-dimensions
  68.             (require-type table-dimensions 'integer)
  69.             (make-point (elt array-dimensions h-specifier)
  70.                         (elt array-dimensions v-specifier))))
  71.     (setf (table-array-slot item) table-array
  72.           (table-array-dimensions item) array-dimensions
  73.           (h-specifier-slot item) h-specifier
  74.           (v-specifier-slot item) v-specifier
  75.           (table-subscript-slot item) table-subscript)
  76.     (apply #'call-next-method
  77.            item
  78.            :table-dimensions table-dimensions
  79.            rest)))
  80.  
  81. (defmethod cell-to-subscript ((item array-dialog-item) point)
  82.   (let ((table-subscript (table-subscript item)))
  83.     (setf (elt table-subscript (h-specifier item)) (point-h point))
  84.     (setf (elt table-subscript (v-specifier item)) (point-v point))
  85.     (if (apply #'array-in-bounds-p (table-array item) table-subscript)
  86.       table-subscript)))
  87.  
  88. (defmethod subscript-to-cell ((item array-dialog-item) subscript)
  89.   (let ((table-subscript (table-subscript item))
  90.         (h-specifier (h-specifier item))
  91.         (v-specifier (v-specifier item)))
  92.     (if (eq (length subscript) (length table-subscript))
  93.       (progn
  94.         (setf (elt table-subscript (h-specifier item)) (elt subscript
  95. h-specifier))
  96.         (setf (elt table-subscript (v-specifier item)) (elt subscript
  97. v-specifier))
  98.         (if (equal subscript table-subscript)
  99.           (make-point (elt subscript h-specifier) (elt subscript
  100. v-specifier)))))))
  101.  
  102. (defmethod cell-contents ((item array-dialog-item) h &optional v &aux
  103. subscript)
  104.   (if (setq subscript (cell-to-subscript item (make-point h v)))
  105.       (apply #'aref (table-array item) subscript)
  106.       ""))
  107.  
  108. (defun readjust-table-dimensions (item)
  109.   (let ((array-dimensions (array-dimensions (table-array item))))
  110.     (set-table-dimensions item
  111.                           (elt array-dimensions (h-specifier item))
  112.                           (elt array-dimensions (v-specifier item)))))
  113.  
  114. (defmethod set-h-specifier ((item array-dialog-item) dimension)
  115.   (setf (h-specifier-slot item) dimension)
  116.   (readjust-table-dimensions item)
  117.   dimension)
  118.  
  119. (defmethod set-v-specifier ((item array-dialog-item) dimension)
  120.   (setf (v-specifier-slot item) dimension)
  121.   (readjust-table-dimensions item)
  122.   dimension)
  123.  
  124. (defmethod set-table-array ((item array-dialog-item) new-array)
  125.   (let ((array-dimensions (array-dimensions new-array)))
  126.     (if (< (length array-dimensions) 2)
  127.       (error "Arrays for array-dialog-items must have two or more
  128. dimensions.
  129. Passed array is: ~s. Use sequence-dialog-items for vectors." new-array))
  130.     (setf (table-array-dimensions item) array-dimensions)
  131.     (setf (table-array-slot item) new-array)
  132.     (setf (h-specifier-slot item) 0)
  133.     (setf (v-specifier-slot item) 1)
  134.     (setf (table-subscript-slot item)
  135.           (make-sequence 'list (length array-dimensions) :initial-element
  136. 0))
  137.     (readjust-table-dimensions item)
  138.     new-array))
  139.  
  140. (defmethod set-table-subscript ((item array-dialog-item) new-subscript)
  141.   (if (apply #'array-in-bounds-p (table-array item) new-subscript)
  142.     (progn
  143.       (setf (table-subscript-slot item) new-subscript)
  144.       (readjust-table-dimensions item)
  145.       new-subscript)
  146.     (error "Subscript ~s Out of bounds" new-subscript)))
  147. ;;;-------------------------------------------------------------------------
  148. --
  149.  
  150.  
  151.  
  152. ;;;------------------------------------------ the test code...
  153. --------------
  154. ;;;
  155.  
  156. (defclass adi-1 (array-dialog-item) ())
  157.  
  158. (defparameter *y* 0)
  159.  
  160. (defun doit ()           ;;; execute this function
  161.   (setq *y* 0)
  162.   (setq w
  163.         (make-instance 'window
  164.           :view-size (make-point 400 190) ))
  165.   (setq a1
  166.         (make-instance 'adi-1
  167.              :table-array 
  168.              (make-array '(1 15) :initial-element "one..")
  169.              :view-position (make-point 0 0)
  170.              :view-size (make-point 48 165)
  171.              :table-vscrollp nil
  172.              :table-hscrollp nil
  173.              :view-font '("Geneva" 9   :PLAIN)
  174.              :view-container w
  175.              ))
  176.   (setq a2
  177.         (make-instance 'adi-1
  178.              :table-array 
  179.              (make-array '(1 15) :initial-element "two.........    ")
  180.              :view-position (make-point 60 0)
  181.              :table-vscrollp nil
  182.              :table-hscrollp nil
  183.              :view-size (make-point 148 165)
  184.              :view-font '("Geneva" 9   :PLAIN)
  185.              :view-container w
  186.              ))
  187.   (set-part-color a2 :frame *white-color*)  ;; *** here's the bugger ***
  188.   )
  189.  
  190. (defmethod view-click-event-handler ((i adi-1) where)
  191.   (let ((n (floor (/ (+ 1 (point-v where)) 12))))
  192.     (print n)
  193.     (cell-deselect a1 0 *y*)
  194.     (cell-deselect a2 0 *y*)
  195.     (setq *y* n)
  196.     (cell-select a1 0 n)
  197.     (cell-select a2 0 n)))    ;just makes the two behave like one
  198. _________________________________________________________________
  199. David Foster         |  A thought may be compared to a cloud
  200. Institute for the    |  shedding a shower of words.  
  201.  Learning Sciences   |                             - L. Vgotsky
  202. dfoster@ils.nwu.edu  |                           
  203. (708) 467-1771       |  [snicker] yeah, [snort] sure. 
  204.                      |                             - D. Foster
  205.