[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
A WDEF Lisp!
- To: info-mcl@cambridge.apple.com
- Subject: A WDEF Lisp!
- From: language@skdad.usask.ca
- Date: 11 Feb 1993 23:38:52 -0600
Here's an example of how to write a WDEF in lisp. This same
technique can be used to make LDEF's, CDEF's, etc and I've
provided the tweek-it routine to let you do that stuff yourself.
-john
;; file tweek-it.lisp
;; a WDEF Written in Lisp!
;; Copyright (C) 1993 by John Montbriand. All Rights Reserved.
;; You may freely re-distribute/use this file, or portions
;; of this file (viz. the tweek-it routine), but, if you do,
;; please keep this notice with whatever you re-distribute.
;; Thanx, john
;;
;; Use this at your own risk: since I'm giving you the right
;; to use my code, in exchange, by using it, you agree to take
;; responsibility for any problems you may have because of it...
(require 'resources)
(require 'quickdraw)
;; tweek-it
;; ...sets up a tweeked resource that points to your user procedure
;; for the specified type of definition procedure (MDEF, WDEF, LDEF...)
;; user-proc is a pointer to your Lisp routine which should have the correct
;; stack setup for the definition procedure being implemented.
;; tweek-it simply sets a pointer in the resource to point to
;; your Lisp defined defproc.
;; The resource is formatted as a jmp abs.l 68000 instruction:
;; "4EF9 0000 0000"
;; tweek-it sets the second and third words (the jump address) to
;; point to your Lisp procedure (which must be a defpascal function)
;; so when your WDEF/LDEF/anythingDEF gets called all the resource
;; does is bounce the PC to your Lisp routine.
;;
;; IMPORTANT: If the requested resource doesn't exist, a new one is
;; added to the current resource file--this might cause some virus
;; protection schemes to become active.
;;
(defun tweek-it (type id user-proc)
(prog ((the-rsrc (get-resource type id t)))
(if (macptrp the-rsrc)
(%hput-long the-rsrc (%ptr-to-int user-proc) 2)
(let ((tweek (#_NewHandle 6)))
(%hput-word tweek #x4EF9 0)
(%hput-long tweek (%ptr-to-int user-proc) 2)
(add-resource tweek type id :name "tweeked resource")))))
;; preserve-current-port ensures
(defmacro preserve-current-port ((gp) &body body)
"executes body preserving the current port"
`(rlet ((,gp :GrafPtr))
(#_GetPort current-port)
(let ((result (progn ,@body)))
(#_SetPort (%get-ptr ,gp))
result)))
; lisp-window-definition: a window definition written entirly in Lisp.
; it's a smaller version of a window with the
; features:
; - title in 9 point geneva font, left justified.
; - the drag region is on all sides instead of just the title bar.
; - the grow icon is in the struct region, not the content region.
; resource: WDEF=4
; procid: (* 4 16) = 64 (multiply the resource id by 16)
; variations (add on to the procid when creating a window)
; 0 -- window with a grow box (procid = 64)
; 1 -- has no grow box (procid = 65)
; for more information about WDEFs, see the section on
; "defining your own windows" in inside macintosh,
; and see technical note 290.
(defconstant kMyWDEFid 4 "resource id for our WDEF") ; define the ID
(defpascal lisp-window-definition (:word varCode :ptr theWindow :word message
:long param :long)
"A custom window definition in lisp!"
(preserve-current-port (current-port)
(rlet ((window-manager-port :GrafPtr)
(content :rect) ; our content rectangle--window's portRect
(structure :rect) ; structure rect--contains the content rect
(grow :rect) ; grow box coordinates
(go-away :rect)) ; go-away box coordinates
(#_getwmgrport window-manager-port) ; wmgr port is where we draw
(with-port theWindow
;; everything's in global coordinates in the window-manager-port
;; so we calculate all our part locations in global coordinates.
(copy-record (pref theWindow windowrecord.port.portrect) :rect content)
(#_LocalToGlobal content) ; topLeft
(#_LocalToGlobal (%inc-ptr content 4)) ; botRight
(copy-record content :rect structure)
(inset-rect structure -5 -5)
(setf (rref structure rect.top) (- (rref structure rect.top) 8))
(copy-record structure :rect grow)
(setf (rref grow rect.topLeft) (rref content rect.botRight))
(setf (rref go-away rect.topleft)
(add-points (rref structure rect.topleft) #@(4 2)))
(setf (rref go-away rect.botRight)
(add-points (rref structure rect.topleft) #@(14 11))))
(cond
((= message #$wDraw) ; DRAW THE WINDOW MESSAGE
(if (pref theWindow WindowRecord.visible)
(let ((draw-option (#_LoWord param)));; see TN-290
(cond
((= draw-option 0)
(with-port (%get-ptr window-manager-port)
(let ((temp (new-region))
(drag-region (new-region))
(title-end 0))
;; draw the frame
(set-rect-region drag-region structure)
(set-rect-region temp content)
(xor-region drag-region temp drag-region)
(dispose-region temp)
(#_FrameRgn drag-region)
(inset-region drag-region 1 1)
(#_EraseRgn drag-region)
(dispose-region drag-region)
;; draw the title
(#_TextFont #$geneva)
(#_TextSize 9)
(with-returned-pstrs ((title "insert-title-here"))
(#_GetWTitle theWindow title)
(setq title-end
(if (pref theWindow WindowRecord.goAwayFlag)
(+ (rref go-away Rect.right)
(#_StringWidth title) 4)
(+ (rref structure Rect.left)
(#_StringWidth title) 7)))
(if (pref theWindow WindowRecord.goAwayFlag)
(#_MoveTo (+ (rref go-away Rect.right) 2)
(+ (rref structure Rect.top) 10))
(#_MoveTo (+ (rref structure Rect.left) 5)
(+ (rref structure Rect.top) 10)))
(#_DrawString title))
(#_TextFont #$systemFont)
(#_TextSize 12)
;; draw the highlighting
(if (pref theWindow WindowRecord.hilited)
(progn
;; draw the go-away box, if there is one
(if (pref theWindow WindowRecord.goAwayFlag)
(#_FrameRect go-away))
(if (= varCode 0)
(#_PaintRect grow))
(#_MoveTo (+ (rref structure Rect.left) 2)
(+ (rref structure Rect.top) 2))
(#_LineTo (+ (rref structure Rect.left) 2)
(- (rref structure Rect.bottom) 3))
(#_LineTo (- (rref structure Rect.right) 3)
(- (rref structure Rect.bottom) 3))
(#_LineTo (- (rref structure Rect.right) 3)
(+ (rref structure Rect.top) 2))
(dotimes (i 5)
(#_MoveTo title-end (+ (rref go-away Rect.top) (* i 2)))
(#_LineTo (- (rref structure Rect.right) 3)
(+ (rref go-away Rect.top) (* i 2)))))))))
;; toggle the go-away box by inverting it
((= draw-option #$wInGoAway)
(with-port (%get-ptr window-manager-port)
(inset-rect go-away 1 1)
(#_InvertRect go-away))))))
0)
((= message #$wHit) ; HIT-TEST WINDOW MESSAGE
(let ((where (make-point param)))
(cond
((point-in-rect-p content where) #$wInContent)
((and (= varCode 0)
(point-in-rect-p grow where)) #$wInGrow)
((and (pref theWindow WindowRecord.goAwayFlag)
(point-in-rect-p go-away where)) #$wInGoAway)
((point-in-rect-p structure where) #$wInDrag)
(t #$wNoHit))))
((= message #$wCalcRgns) ; CALCULATE REGIONS MESSAGE
(set-rect-region (pref theWindow windowrecord.contRgn) content)
(set-rect-region (pref theWindow windowrecord.strucRgn) structure)
0)
((= message #$wGrow) ; DRAW GROW IMAGE FRAME MESSAGE
(rlet ((grow-content :rect)
(grow-structure :rect))
(copy-record (%int-to-ptr param) :rect grow-content)
(copy-record grow-content :rect grow-structure)
(inset-rect grow-structure -5 -5)
(setf (rref grow-structure rect.top)
(- (rref grow-structure rect.top) 8))
(with-port (%get-ptr window-manager-port)
(#_FrameRect grow-structure)
(inset-rect grow-content -1 -1)
(#_FrameRect grow-content)))
0)
((= message #$wDrawGIcon) ; DRAW GROW ICON MESSAGE
; normally we'd draw the grow icon here, but since it's
; not in the content region, we draw the grow icon in the
; #$wDraw part (see above)
0)
((= message #$wNew) ; INITIALIZE MESSAGE
; initialize any structures set up specifically for this window
0)
((= message #$wDispose) ; DISPOSE MESSAGE
; undo whatever you did in #$wNew...
0)
(t 0)))))
;; before creating any windows using the above window definition
;; procedure, we have to add a tweeked WDEF resource that points
;; to it in the current resource file.
;; WARNING: if you don't already have the WDEF in your resource
;; file, some virus protection programs might give you some grief.
;; the thing to do if this happens is either (a) add the resource
;; to MCL yourself (read about what tweek-it does) or (b) disable
;; your virus protection init for a short while.
(tweek-it "WDEF" kMyWDEFid lisp-window-definition)
;; I'm defining a tweeked-window class here to set the
;; ccl::grow-icon-p slot when a growable window is created,
;; since this isn't done automatically. plus they're a descendant
;; of fred-windows so you can try 'em out.
(defclass tweeked-window (fred-window) ())
(defmethod initialize-instance ((self tweeked-window)
&key (procid (* kMyWDEFid 16)))
(call-next-method)
(if (= procid (* kMyWDEFid 16))
(setf (slot-value self 'ccl::grow-icon-p) t)))
;; here's some example windows:
#|
(setq *wp-one* (make-instance 'tweeked-window
:procid (* kMyWDEFid 16)
:view-position #@(116 84)
:view-size #@(231 87)
:window-title "A MCL2 WDEF in action!"
:close-box-p nil))
(setq *wp-two* (make-instance 'tweeked-window
:procid (* kMyWDEFid 16)
:view-position #@(168 125)
:view-size #@(231 87)
:window-title "A WDEF in Lisp!"))
(setq *wp-three* (make-instance 'tweeked-window
:procid (1+ (* kMyWDEFid 16))
:view-position #@(207 159)
:view-size #@(231 87)
:window-title "MCL2 WDEF in action!"))
(ed-insert-with-undo *wp-one*
"A growable window with no close box....")
(fred-update *wp-one*)
(ed-insert-with-undo *wp-two*
"A growable window with a close box....")
(fred-update *wp-two*)
(ed-insert-with-undo *wp-three*
"A statically sized window with a close box....")
(fred-update *wp-three*)
|#
;; end of file tweek-it.lisp
:)