[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

A WDEF Lisp!



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

    :)