Blinking sequence-dialog-item

[Bill St. Clair <bill>]

I worked up a simple patch to prevent blinking on set-table-sequence.
The contents of the table will still blink, but the border won't:

---------------------------------------------------------------------------

; set-table-dims-patch.lisp
; Patch to prevent blinking of TABLE-DIALOG-ITEM's
; on SET-TABLE-DIMENSIONS (which is called by SET-TABLE-SEQUENCE)

(in-package :ccl)

(require 'traps)
(require 'records)

(defun set-up-font-codes (new-ff new-ms)
  (let* ((port (%getport))
         (old-ff (%get-long port 68))
         (old-ms (%get-long port 72)))
    (if new-ff (%put-long port new-ff 68))
    (if new-ms (%put-long port new-ms 72))
    (values port old-ff old-ms)))

(defun restore-old-font-codes (port old-ff old-ms)
  (%put-long port old-ff 68)
  (%put-long port old-ms 72))

(defmacro with-font-codes (ff-code ms-code &rest body)
  (let ((port-sym (gensym))
        (ff-sym (gensym))
        (ms-sym (gensym)))
    `(multiple-value-bind
       (,port-sym ,ff-sym ,ms-sym)
       (set-up-font-codes ,ff-code ,ms-code)
       (unwind-protect
         (progn ,@body)
         (restore-old-font-codes ,port-sym ,ff-sym ,ms-sym)))))

(let ((*warn-if-redefine* nil))

(defobfun (set-table-dimensions *table-dialog-item*) (h &optional v 
                          &aux
                          (pt (make-point h v)) lh lv
                          (old-dims table-dimensions-iv)
                          (dh dialog-item-handle))
  (declare (object-variable table-dimensions-iv my-view table-hscrollp table-vscrollp))
  (setq h (point-h pt))
  (setq v (point-v pt))
  (setq table-dimensions-iv pt)
  (when my-dialog
    (with-focused-view my-view
      (with-font-codes (get-ff-code) (get-ms-code)
        (_LDoDraw :word nil :ptr dh)
        (if (or (%i> (point-h old-dims) h) (%i> (point-v old-dims) v))
            (scroll-to-cell #@(0 0)))
        (setq Lh (rref dh list.databounds.right))
        (setq Lv (rref dh list.databounds.bottom))
        (if (%i> Lh h)
            (_LDelColumn :word (%i- Lh h) :word 0 :ptr dh))
        (if (%i> Lv v)
            (_LDelRow :word (%i- Lv v) :word 0 :ptr dh))
        (if (%i< Lh h)
            (_LAddColumn :word (%i- h Lh) :word 0 :ptr dh))
        (if (%i< Lv v)
            (_LAddRow :word (%i- v Lv) :word 0 :ptr dh))
        (_LDoDraw :word -1 :ptr dh)
        (let ((pos (add-points (dialog-item-position) #@(1 1)))
              (size (subtract-points (dialog-item-size) #@(1 1))))
          (if table-hscrollp
            (setq size (subtract-points size #@(0 15))))
          (if table-vscrollp
            (setq size (subtract-points size #@(15 0))))
          (rlet ((rect :rect :topleft pos :bottomright (add-points pos size)))
            (_InvalRect :ptr rect))))))
  pt)

)