[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
SICN and SICN Palette Tool Dialog-Items
- To: info-macl@cambridge.apple.com
- Subject: SICN and SICN Palette Tool Dialog-Items
- From: hohmann@zug.csmil.umich.edu
- Date: Wed, 01 Jul 92 07:26:58 -0400
Enclosed please find the source code for SICN and SICN Palette Tool dialog
items. If you find the source helpful, great. If not, please forgive me
for sending a long mail message.... ;-)
Couple of notes....
1. The example shown at the bottom won't work on your machine unless
you replace the name of the resource file listed with an appropriately
named and prepared resource file.
2. If you locate any bugs or otherwise extend/fix this code, please drop
me a line. The code is working for me so far, but I can't make any
promises....
-- Luke
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; PROJECT: SPIF
;;;
;;; MODULE : sicn-dialog-items.Lisp
;;;
;;; DESCRIPTION:
;;; A modest implementation of SICN and palette tools
;;;
;;;
;;; NOTES:
;;; - Thanks to Andrew Shalit for starting me off with some sample code
;;; way back in M(A)CL 1.2.2. And thanks to the current MCL team for
;;; letting me steal a lot of code from the ICON-DIALOG-ITEM example
;;; file.
;;;
;;; - Makes use of the oodles-of-utils stuff from Mike Engbar, but
;;; I probably am not using that pile of code as effectively as I can!
;;;
;;; L. Hohmann
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require :quickdraw)
(require :traps)
;; sicn-dialog-item --------------------------------------------------------
;;
;; if outline? is true then outline the dialog item with a box
;;
(defclass sicn-dialog-item (dialog-item)
((id :initarg :id :accessor id)
(index :initarg :index :accessor index)
(bitmap :initform nil :accessor bitmap)
(selected? :initform nil :accessor selected?)
(outline? :initarg :outline? :accessor outline?))
(:default-initargs
:view-size #@(18 18)
:outline? t
:id nil
:index nil
))
;; initialize-instance --------------------------------------------------------
;;
(defmethod initialize-instance :after ((self sicn-dialog-item) &rest initargs)
(declare (ignore initargs))
(unless (or (id self) (index self))
(spif-error "initialize-instance::sicn-dialog-item"
"id=~a index=~a and one is nil and neither should be!"
(id self) (index self))))
;; install-view-in-window --------------------------------------------------
;;
(defmethod install-view-in-window ((self sicn-dialog-item) win)
(declare (ignore win))
(initialize-bitmap self)
(call-next-method))
;; view-draw-contents --------------------------------------------------------
;;
(defmethod view-draw-contents ((self sicn-dialog-item))
(with-accessors ((bm bitmap)
(pos view-position))
self
(unless bm (error "bitmap not initialized"))
(rlet ((source-rect :rect
:topleft #@(0 0)
:bottomright #@(16 16))
(destination-rect :rect
:topleft (add-points pos #@(1 1))
:bottomright (add-points pos #@(17 17)))
(outline-rect :rect
:topleft pos
:bottomright (add-points pos #@(18 18))))
(copy-bits bm
(rref (wptr (view-window self)) windowRecord.portbits)
source-rect
destination-rect)
(when (selected? self)
(#_InvertRect destination-rect))
(when (outline? self)
(#_FrameRect outline-rect)))))
;; remove-view-from-window -------------------------------------------------
;;
(defmethod remove-view-from-window ((self sicn-dialog-item))
(without-interrupts
(dispose-record (bitmap self))
(setf (bitmap self) nil))
(call-next-method))
;; set-view-size --------------------------------------------------------
;; ignore and shodow this function because we keep these dialog items
;; a constant size
;;
(defmethod set-view-size ((self sicn-dialog-item) h &optional v)
(declare (ignore h v))
(invalidate-view self))
;; initialize-bitmap -------------------------------------------------
;;
(defmethod initialize-bitmap ((self sicn-dialog-item)
&aux handle handle-size new-bm)
(with-accessors ((id id)
(index index)
(bm bitmap))
self
(setf index (* index 32))
(without-interrupts
; this _getresource routine searched for the sicn in the resource
; file chain. this chain should include the soda.rsrc file, which
; is used in plandraw.lisp
(setf handle (get-resource "SICN" id))
(unless handle (error "sicn resource ~s not found." id))
(#_HNoPurge handle))
(unwind-protect
(progn
(setf handle-size (- (#_GetHandleSize handle) 32))
(unless (<= index handle-size)
(error "index ~s out of bounds for sicn with ~s entries"
(/ index 32)
(/ handle-size 32)))
(setf new-bm (make-bitmap 0 0 16 16))
(with-dereferenced-handles ((pointer handle))
(#_BlockMove (%inc-ptr pointer index) (%inc-ptr new-bm 14) 32))
(setf bm new-bm))
(unless bm
(when new-bm
(dispose-record new-bm :bitmap)))
(#_HPurge handle))))
(defmethod view-click-event-handler ((item sicn-dialog-item) where)
(declare (ignore where))
(let* ((pos (view-position item))
(inverted-p nil)) ;true when the mouse is over the icon
(with-focused-view (view-container item) ;Draw in the container's coordinates
(rlet ((temp-rect :rect ;temporarily allocate a rectangle
:topleft pos
:bottomright (add-points pos (view-size item))))
(without-interrupts
(#_InvertRect temp-rect) ;initially invert the icon.
(setq inverted-p t)
(loop ;loop until the button is released
(unless (mouse-down-p)
(when inverted-p ;if button released with mouse
; over the icon, run the action
(#_invertrect temp-rect)
(setq inverted-p nil)
(dialog-item-action item)
)
(return-from view-click-event-handler))
(if (#_PtInRect
(view-mouse-position (view-window item))
temp-rect) ;is mouse over the icon's rect?
(unless inverted-p ;yes, make sure it's inverted.
(#_invertrect temp-rect)
(setq inverted-p t))
(when inverted-p ;no, make sure it's not inverted.
(#_invertrect temp-rect)
(setq inverted-p nil)))))))))
(defmethod invert ((self sicn-dialog-item))
(let* ((pos (view-position self))
(mtop (point-v pos))
(mleft (point-h pos))
(mbottom (+ mtop 18))
(mright (+ mleft 18)))
; let the dialog do all the tracking in the dialogs grafport
(with-port (wptr (view-window self))
(rlet ((temp-rect :rect
:top mtop :left mleft :bottom mbottom :right mright))
(without-interrupts (#_InvertRect temp-rect)))))
(setf (selected? self) (not (selected? self))))
;; palette tools are bigger and always have an outline
;;
(defclass palette-tool (sicn-dialog-item)
((tool-name :initarg :tool-name :accessor tool-name)
(use-fn :initarg :use-fn :accessor use-fn)
)
(:default-initargs
:use-fn nil
:tool-name "A Palette Tool"
:view-size #@(24 24)))
(defmethod use-tool ((self palette-tool) item where)
(when (functionp (use-fn self))
(apply (use-fn self) self item where)))
;;-> dialog-item-draw palette-tool --------------------------------------------------
;;
;; DESCRIPTION : draws the palette tool, and inverts it if selected
;;
(defmethod view-draw-contents ((self palette-tool))
(with-accessors ((bm bitmap)
(pos view-position)
(size outline-size)
(sel? selected?))
self
(unless bm (error "bitmap not initialized"))
(rlet ((source-rect :rect
:topleft 0
:bottomright #@(16 16))
(destination-rect :rect
:topleft (add-points pos #@(4 4))
:bottomright (add-points pos #@(20 20)))
(outline-rect :rect
:topleft pos
:bottomright (add-points pos #@(24 24)))
(invert-rect :rect
:topleft (add-points pos #@(1 1))
:bottomright (add-points pos #@(23 23)))
)
(copy-bits bm
(rref (wptr (view-window self)) windowRecord.portbits)
source-rect destination-rect)
(#_FrameRect outline-rect)
(when sel?
(#_InvertRect invert-rect)))))
;;-> invert palette-tool ------------------------------------------------------------
;;
;; DESCRIPTION : toggles (via inverting) the palette tool
;;
(defmethod invert ((self palette-tool))
(let* ((pos (view-position self))
)
(with-port (wptr (view-window self))
(rlet ((temp-rect :rect
:topleft (add-points pos #@(1 1))
:bottomright (add-points pos #@(23 23))))
(without-interrupts
(#_InvertRect temp-rect))))
(setf (selected? self)
(not (selected? self)))))
;; dialog-item-action -------------------------------------------------
;;
;; the following standard methods are linked via generic functions to
;; the view-window that will contain a palette-tool
;;
;; these two functions work together to select a tool and return the
;; selected tool
;;
(defgeneric select-tool (view tool)
)
(defgeneric selected-tool (view)
)
(defmethod dialog-item-action ((self palette-tool))
(select-tool (view-window self) self)
(call-next-method))
#|------------------------------------------------------------------
; test code
(defclass test-sicn-dialog (dialog)
((selected-tool :initform nil :accessor selected-tool))
(:default-initargs
:window-title "Test sicn"))
(defmethod initialize-instance :after ((self test-sicn-dialog) &rest initargs)
(declare (ignore initargs))
(with-res-file ("ccl:SPIF;SPIF.rsrc")
(add-subviews self
(make-instance 'palette-tool
:view-nick-name 'arrow
:tool-name "Arrow (Select/Resize/Move Shapes)"
:id 128
:index 0
:use-fn 'test-use-tool
:view-position #@(20 20)))
(add-subviews self
(make-instance 'palette-tool
:view-nick-name 'box
:tool-name "Arrow (Select/Resize/Move Shapes)"
:id 128
:index 3
:use-fn 'test-use-tool
:view-position #@(43 20)))
(add-subviews self
(make-instance 'sicn-dialog-item
:view-nick-name 'eraser
:id 128
:index 1
:view-position #@(0 50)
:outline? t
:dialog-item-action 'test-eraser-action
))
))
(defun test-use-tool (palette-tool item where)
(format "~a is using item=[~a] at location ~a~%"
palette-tool item (point-string where)))
(defmethod select-tool ((self test-sicn-dialog) tool)
(format t "~a is selecting tool ~a~%" self tool)
(unless (eq tool (selected-tool self))
(when (selected-tool self)
(invert (selected-tool self)))
(setf (selected-tool self) tool)
(invert tool)))
(defun test-eraser-action (item)
(format t "action for ~a~%" item))
(make-instance 'test-sicn-dialog)
|#