Drawing text in color

[lynch@aristotle.ils.nwu.edu (Richard Lynch)]

I have made a specialization of sequence-dialog-item in 2.0 called
card-stack-dialog-item.  Everything is hunky-dory *except* the usage of
color.  Specifically, when I call the table-print-function surrounded by a
with-fore-color (see draw-cell-contents below), the color is mapped to less
than my monitor (Apple ColorMonitor) will support.  Ie, the colors are
mapped to 8-bit (maybe less) instead of 16-bit.

How *exactly* is the text drawn in a sequence-dialog-item.

Here is the code to demonstrate this.  Note that the 1 and 2 in the
card-stack-dialog-item are *not* blue, but black, while the 0 *is* green 
(at least on my monitor...your mileage may vary).

;;;;card-stack-dialog-items
;;;;Inspired by Michael S. Engber's code.
;;;;) MCMXCI Northwestern University Institute for the Learning Sciences
;;;;Richard Lynch
;;;;lynch@ils.nwu.edu

(require 'quickdraw)
(require 'traps)
(require 'records)

(export '(card-stack-dialog-item
          dh
          dv
          scroll-method
          visible-length
)        )

(defun font-descent (&optional font-spec)
  (second (multiple-value-list (font-info font-spec)))
)

(defun font-height (&optional font-spec)
  (let ((info (multiple-value-list (font-info font-spec))))
    (+ (first info) (fourth info))
) )

;;;;card-stack-dialog-item
(defclass card-stack-dialog-item (sequence-dialog-item)
  ((dh
     :documentation "Horizontal delta for each card."
     :accessor dh
     :initarg dh
     :initform 5
     :type 'integer
   )
   (dv
     :documentation "Vertical delta for each card."
     :accessor dv
     :initarg :dv
     :initform -16
     :type 'integer
   )
   (scroll-method
     :documentation "Determines algorithm for card movement.
Should be :rotate or :swap"
     :accessor scroll-method
     :initarg :scroll-method
     :initform :rotate
     :type 'keyword
   )
  )
  (:documentation "Card stacks a la Hypercard.")
  (:default-initargs
    :table-hscrollp nil
    :table-vscrollp nil
    :scroll-method :rotate
;Broken...
;    :visible-dimensions #@(1 3)
;this is here to force visible-dimensions...
     :cell-size #@(80 20)
  )
)

(defmethod initialize-instance :around ((stack card-stack-dialog-item)
&rest initargs)
  (let ((scroll-method (getf initargs :scroll-method nil)))
    (if (member scroll-method '(:rotate :swap))
      (call-next-method)
      (error "Invalid scroll-method ~A" scroll-method)
    )
) )

(defmethod visible-length ((stack card-stack-dialog-item))
  (let ((vis-dims (visible-dimensions stack)))
    (max (point-h vis-dims) (point-v vis-dims))
) )

(defmethod view-draw-contents ((stack card-stack-dialog-item))
  (let* ((max-index (visible-length stack))
         (first-cell (scroll-position stack))
         (first-index (cell-to-index stack first-cell))
         (last-index (1- (+ first-index max-index)))
         (last-cell (index-to-cell stack last-index))
        )
    (do* ((index last-index (1- index))
          (cell last-cell (index-to-cell stack index))
         )
         ((< index first-index))
      (draw-cell-contents stack cell)
) ) )

(defmethod redraw-cell ((stack card-stack-dialog-item) h &optional v)
  (let* ((cell (make-point h v))
         (index (cell-to-index stack cell))
         (dh (dh stack))
         (dv (dv stack))
         (offset (make-point dh dv))
         (nth-dh (* index dh))
         (nth-dv (* index dv))
         (nth-offset (make-point nth-dh nth-dv))
         (stack-topleft (view-position stack))
         (stack-bottomright (add-points stack-topleft (cell-size stack)))
         (OldClip (new-region))
         (NewClip (new-region))
         (temp (new-region))
        )
    (with-focused-view (view-container stack)
      (set-rect-region NewClip stack-topleft stack-bottomright)
      (offset-region NewClip nth-offset)
      (unless (= 0 index)
        (set-rect-region temp stack-topleft stack-bottomright)
        (offset-region temp (subtract-points nth-offset offset))
        (intersect-region NewClip temp NewClip)
      )
      (#_GetClip OldClip)
      (#_SetClip NewClip)
      (#_MoveTo :long (add-points stack-topleft (make-point nth-dh
nth-dv)))
      (draw-cell-contents stack cell)
      (#_SetClip OldClip)
    )
    (dispose-region OldClip)
    (dispose-region NewClip)
    (dispose-region temp)
) )

(defmethod draw-cell-contents ((stack card-stack-dialog-item) h &optional
v)
  (let* ((cell (make-point h v))
         (index (cell-to-index stack cell))
         (dh (dh stack))
         (dv (dv stack))
;         (offset (make-point dh dv))
         (nth-dh (* index dh))
         (nth-dv (* index dv))
         (nth-offset (make-point nth-dh nth-dv))
         (stack-topleft (view-position stack))
         (stack-bottomright (add-points stack-topleft (view-size stack)))
         (view (view-container stack))
         (card-topleft (add-points stack-topleft nth-offset))
         (card-bottomright (add-points stack-bottomright nth-offset))
         (card-region (new-region))
         (string (with-output-to-string (stream)
                   (funcall
                     (table-print-function stack)
                     (cell-contents stack cell)
                     stream
         )       ) )
         (string-len (length string))
         (card-left (point-h card-topleft))
         (card-right (point-h card-bottomright))
         (card-top (point-v card-topleft))
         (card-bottom (point-v card-bottomright))
         (card-center (floor (+ card-left card-right) 2))
         (half-string-len (floor string-len 2))
         (string-left (- card-center half-string-len))
         (font (cell-font stack cell))
         (string-height (font-height font))
         (string-descent (font-descent font))
         (string-top
           (if (> dv 0)
             (- card-bottom string-descent)
             (+ card-top string-height)
         ) )
        )
    (with-focused-view view
      (set-rect-region card-region card-topleft card-bottomright)
      (inset-region card-region 1 1)
      (when (part-color stack :body)
        (with-fore-color (part-color stack :body)
          (paint-region view card-region)
      ) )
      (with-fore-color (or (part-color stack :frame) *black-color*)
        (frame-region view card-region)
      )
      ;This is the problem area.***************************
      (with-fore-color (or (part-color stack cell) *black-color*)
        (#_MoveTo :word string-left :word string-top)
        (funcall (table-print-function stack) (cell-contents stack cell)
view)
      )
      (dispose-region card-region)
) ) )

#|
;Too bad this is not used for subview placement...
(defmethod view-default-position :around ((stack card-stack-dialog-item))
  (let* ((usual (call-next-method))
         (len (visible-length stack))
         (dv (dv stack))
        )
    (if (< dv 0)
      (add-points usual (make-point 0 (* len (- dv))))
      usual
) ) )
|#

(defmethod view-default-size ((stack card-stack-dialog-item))
  #@(80 60)
)

(defmethod view-contains-point-p ((stack card-stack-dialog-item) where)
  (let* ((stack-topleft (view-position stack))
         (stack-bottomright (add-points stack-topleft (view-size stack)))
         (max-index (1- (visible-length stack)))
         (dh (dh stack))
         (dv (dv stack))
        )
    (rlet ((rect :rect topleft stack-topleft :bottomright
stack-bottomright))
      (do* ((result (point-in-rect-p rect where) (point-in-rect-p rect
where))
            (index 0 (1+ index))
           )
           ((or result (= index max-index))
            result
           )
        (offset-rect rect dh dv)
) ) ) )

(defmethod view-click-event-handler ((stack card-stack-dialog-item) where)
  (let* ((stack-topleft (view-position stack))
         (stack-bottomright (add-points stack-topleft (view-size stack)))
         (max-index (1- (visible-length stack)))
         (dh (dh stack))
         (dv (dv stack))
        )
    (rlet ((rect :rect :topleft stack-topleft :bottomright
stack-bottomright))
      (do* ((result (point-in-rect-p rect where) (point-in-rect-p rect
where))
            (index 0 (1+ index))
           )
           ((or result (= index max-index))
            (when result
              (cell-select stack (index-to-cell stack index))
            )
           )
        (offset-rect rect dh dv)
) ) ) )

(defmethod cell-select ((stack card-stack-dialog-item) h &optional v)
  (let* ((cell (make-point h v))
         (index (cell-to-index stack cell))
         (sequence (table-sequence stack))
         temp
        )
    (if (= index 0)
      (when (dialog-item-action-function stack)
        (funcall (dialog-item-action-function stack) stack)
      )
      (progn
        (if (eq (scroll-method stack) :rotate)
          (set-table-sequence
            stack
            (nconc (subseq sequence index) (subseq sequence 0 index))
          )
          (progn
            (setq temp (nth index sequence))
            (setf (nth index sequence) (car sequence))
            (setf (car sequence) temp)
            (redraw-cell stack cell)
            (redraw-cell stack 0 0)
          )
        )
        (invalidate-view stack)
      )
    )
  )
)

(defmethod invalidate-view ((stack card-stack-dialog-item) &optional
(erase-p nil))
  (with-focused-view (view-container stack)
    (let* ((stack-topleft (view-position stack))
           (stack-bottomright (add-points stack-topleft (view-size stack)))
           (max-index (visible-length stack))
           (dh (dh stack))
           (dv (dv stack))
          )
      (rlet ((rect :rect :topleft stack-topleft :bottomright
stack-bottomright))
        (dotimes (index max-index)
          (when erase-p
            (#_EraseRect :ptr rect)
          )
          (#_InvalRect :ptr rect)
          (offset-rect rect dh dv)
) ) ) ) )

#|

(defparameter *regular-sequence* (make-instance 'sequence-dialog-item))

(defparameter *stack-sequence*
  (make-instance 'card-stack-dialog-item
    ;Don't blame me...It's not my fault...
    :view-position #@(43 64)
    :dialog-item-action #'ed-beep
) )

(defparameter *sample-dialog*
  (make-instance 'color-dialog
    :window-title "Sample Card Stack Dialog Item"
    :window-show nil
    :view-subviews
    (list
      *regular-sequence*
      *stack-sequence*
    )
  )
)

;:part-color-list as an initarg seems to be broken...
;:set-part-color only works after a subview has been installed.

(set-part-color *regular-sequence* :frame *red-color*)
(set-part-color *regular-sequence* :text *blue-color*)
(set-part-color *regular-sequence* :body *yellow-color*)
(set-part-color *regular-sequence* #@(0 0) *green-color*)

(set-part-color *stack-sequence* :frame *red-color*)
(set-part-color *stack-sequence* :text *blue-color*)
(set-part-color *stack-sequence* :body *yellow-color*)
(set-part-color *stack-sequence* #@(0 0) *green-color*)

(window-show *sample-dialog*)

|#

"TANSTAAFL" Rich lynch@aristotle.ils.nwu.edu