A question regarding small icons....

[Andrew L. M. Shalit <alms>]

Enclosed is some small-icon code which I wrote a long time ago.  I
don't think I ever finished it, but I did get pretty far.  It handles
getting the icons from resources, displaying them, clicking them, and
editing them (I think).

If you end up cleaning this up or extending it or porting it to
2.0, perhaps you could share it back with the net...

   -andrew

------cut here------

(defobject *small-icon-dialog-item* *user-dialog-item*)

(defobfun (exist *small-icon-dialog-item*) (init-list)
  (setf (getf init-list :dialog-item-size) #@(16 16))
  (usual-exist init-list)
  (let ((res-id (getf init-list :id nil))
        (index (getf init-list :index nil)))
    (unless (and index res-id)
      (error "for now you need to specify both :index and :id"))
    (have 'sicn-resource-reference
          (cons res-id index))
    (have 'my-sicn-bitmap nil)))

(defobfun (add-self-to-dialog *small-icon-dialog-item*) (the-dialog)
  (initialize-bitmap)
  (usual-add-self-to-dialog the-dialog))

(defobfun (dialog-item-draw *small-icon-dialog-item*) ()
  (let ((bitmap (objvar my-sicn-bitmap))
        (pos (dialog-item-position)))
    (unless bitmap
      (error "bitmap not initialized"))
    (rlet ((s-rect :rect
                   :topleft #@(0 0)
                   :bottomright #@(16 16))
           (d-rect :rect
                   :topleft pos
                   :bottomright (add-points pos #@(16 16))))
     (copy-bits bitmap
                (rref (ask (objvar my-dialog) (objvar wptr)) :window.portbits)
                s-rect
                d-rect))))

(defobfun (remove-self-from-dialog *small-icon-dialog-item*) ()
  (without-interrupts
   (dispose-record (objvar my-sicn-bitmap))
   (setf (objvar my-sicn-bitmap) nil))
  (usual-remove-self-from-dialog))

(defobfun (set-dialog-item-size *small-icon-dialog-item*) (h &optional v)
  (declare (ignore h v)))

(defobfun (dialog-item-click-event-handler *small-icon-dialog-item*) (where)
  (declare (object-variable my-dialog wptr)
           (ignore where))
  (let* ((inverted-p nil)
         (the-dialog my-dialog))
      (with-port (ask the-dialog wptr)
        (with-item-rect (rect (self))
          (_inverrect :ptr rect)
          (setq inverted-p t)
          (loop
            (unless (mouse-down-p)
              (when inverted-p
                (dialog-item-action)
                (_inverrect :ptr rect)
                (return-from dialog-item-click-event-handler)))
            (if (logbitp 8 (_PtInRect
                            :long (ask the-dialog (window-mouse-position))
                            :ptr rect
                            :word))
                (unless inverted-p
                  (_inverrect :ptr rect)
                  (setq inverted-p t))
                (when inverted-p
                  (_inverrect :ptr rect)
                  (setq inverted-p nil))))))))

(defobfun (initialize-bitmap *small-icon-dialog-item*) ()
  (let* ((temp (objvar sicn-resource-reference))
         (res-id (car temp))
         (index (cdr temp))
         (handle nil)
         (handle-size nil)
         (new-bm nil))
    (setq index (* index 32))
    (without-interrupts
     (setq handle (_getresource :ostype "SICN"
                                :word res-id
                                :ptr))
     (unless handle
       (error "SICN resource ~s not found." res-id))
     (_HNoPurge :a0 handle))
    (unwind-protect
      (progn
        (setq handle-size (- (_GetHandleSize :a0 handle :d0)
                             32))
        (unless (<= index handle-size)
          (error "index ~s out of bounds for SICN with ~s entries"
                 (/ index 32) (/ handle-size 32)))
        (setq new-bm (make-bitmap 0 0 16 16))
        (with-dereferenced-handles ((pointer handle))
          (_blockmove :a0 (%inc-ptr pointer index)
                      :a1 (%inc-ptr new-bm 14)
                      :d0 32))
        (setf (objvar my-sicn-bitmap) new-bm))
      (unless (objvar my-sicn-bitmap)
        (when new-bm (dispose-record new-bm :bitmap)))
      (_HPurge :a0 handle))))

#|
(proclaim '(special foo bar))
(setq foo (oneof *small-icon-dialog-item*
                 :index 2
                 :id -15616))

(setq bim (oneof *small-icon-dialog-item*
                 :index 0
                 :id -15616))

(ask bar (add-dialog-items bim))

(setq baz (oneof *small-icon-dialog-item*
                 :index 1
                 :id -15616))

(ask bar (add-dialog-items baz))
(setq bar (oneof *dialog*
                 :dialog-items (list foo)))

(ask foo (sicn-bitmap->vector (objvar my-sicn-bitmap)))

(ask foo (vector->sicn-bitmap
          (sicn-bitmap->vector (objvar my-sicn-bitmap))
          (objvar my-sicn-bitmap)))
                
|#

(defobject *sicn-editor* *user-dialog-item*)

(defobfun (exist *sicn-editor*) (init-list)
  (have 'my-sicn-bitmap (or (getf init-list :bitmap nil)
                            (error "woops!")))
  (setf (getf init-list :dialog-item-size) (make-point (* 16 5)
                                                       (* 16 5)))
  (usual-exist init-list))

(defobfun (dialog-item-draw *sicn-editor*) ()
  (let* ((bitmap (objvar my-sicn-bitmap))
         (row-value)
         (pos (dialog-item-position)))
    (with-item-rect (r (self))
      (_framerect :ptr r))
    (rlet ((r :rect
             :topleft pos
             :bottomright (add-points pos #@(4 4))))
      (_offsetrect :ptr r :long (make-point (* 16 5) -5))
    (dotimes (row 16)
      (setq row-value (%get-word bitmap (+ 14 (* row 2))))
      (_offsetrect :ptr r :long (make-point (* -16 5) 5))
      (do ((column 15 (- column 1)))
          ((< column 0))
        (if (logbitp column row-value)
            (_PaintRect :ptr r)
            (_EraseRect :ptr r))
        (_offsetrect :ptr r :long #@(5 0)))))))

(defun sicn-bitmap->vector (bitmap &optional (vector (make-array 16)))
  (setq bitmap (%inc-ptr bitmap 14))
  (dotimes (row 16)
    (setf (svref vector row)
          (%get-word bitmap row)))
  vector)

(defun vector->sicn-bitmap (vector &optional (sicn-bitmap (make-bitmap 0 0 16 16)))
  (dotimes (row 16)
    (%put-word sicn-bitmap
               (svref vector row)
               (+ 14 row)))
  sicn-bitmap)

(defun sicn-resource->vector (res-id index
                                     &optional (vector (make-sequence 'simple-vector 16))
                                     &aux handle handle-size)
  (without-interrupts
   (setq handle (_getresource :ostype "SICN"
                              :word res-id
                              :ptr))
   (unless handle
     (error "SICN resource ~s not found." res-id))
   (_HNoPurge :a0 handle))
  (unwind-protect
    (progn
      (setq handle-size (- (_GetHandleSize :a0 handle :d0)
                           32))
      (unless (<= index (/ handle-size 32))
        (error "index ~s out of bounds for SICN with ~s entries"
                 index handle-size))
      (with-dereferenced-handles ((pointer handle))
        (dotimes (row 16)
          (setf (svref vector row)
                (%inc-ptr pointer index)
                      :a1 (%inc-ptr new-bm 14)
                      :d0 32))
        (setf (objvar my-sicn-bitmap) new-bm))