home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / QD-fx-u.lisp < prev    next >
Encoding:
Text File  |  1992-07-10  |  15.4 KB  |  312 lines
  1. (in-package  :oou)
  2. (oou-provide :QD-fx-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; QD-fx-u.lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;         Rich Lynch (much faster version of wipe effects)
  11. ;;
  12. ;; utilites for various special effects
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. (oou-dependencies :records-u
  16.                   :macptr-u
  17.                   :QuickDraw-u
  18.                   :GWorld-view
  19.                   )
  20.  
  21. (export '(dissolve-o-rama wipe-o-rama iris-of-rama
  22.           map-pat-masks map-iris-masks
  23.           ))
  24.  
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. ;; dissolve effects
  27.  
  28. ;;Hex rep of special effect pattern lists (list of eight 8x8 1bit Patterns)
  29. ;; - the 1st two bytes (4 hex digits) are the number of patterns
  30. ;; - the remaning bytes are raw pattern data
  31. ;; - this format is the same as PAT# resources
  32. ;; - you can use ResEdit to create/view them by copying/pasting hex strings
  33. ;;   between Fred and ResEdit's hex editor (pretty convenient, eh?)
  34. ;;    - normally PAT#'s open into a nice template editor
  35. ;;    - to edit a PAT# in hex, option double-click
  36. ;;    - from the hex editor you can use select-all, copy, and paste
  37. (defvar *QD-fx-pats*
  38.   '(
  39.     :transporter  "000804200210800108404001100804208002108008200240040102084001200410800110048008024020200280044010010808400102108020048004204001080210"
  40.     :screen-door  "000880100240080120044008012004801002200480100240080110024008012004800801200480100240048010024008012002400801200480100120048010024008"
  41.     :waynes-world "000801808001010202011008081010202010080404080810100880404080800101802010102020404020040202040408080440202040408080400201010202040402"
  42.     :v-blind      "000880808080808080804040404040404040202020202020202010101010101010100808080808080808040404040404040402020202020202020101010101010101"
  43.     :h-blind      "0008FF0000000000000000FF0000000000000000FF0000000000000000FF0000000000000000FF0000000000000000FF0000000000000000FF0000000000000000FF"
  44.     ))
  45.  
  46. (defun map-pat-masks (fn mask-rect pat-hex-string)
  47.   (let ((pat-count (parse-integer pat-hex-string :end 4 :radix 16)))
  48.     (%stack-block ((pat-list_p (ceiling (length pat-hex-string) 2)))
  49.       (%put-hex-str pat-list_p pat-hex-string)
  50.       (%incf-ptr pat-list_p 2)
  51.       (let ((gw-view (make-instance 'GWorld-view
  52.                        :GW-depth 1
  53.                        :view-position (pref mask-rect :Rect.topLeft)
  54.                        :view-size     (subtract-points (pref mask-rect :Rect.botRight)
  55.                                                        (pref mask-rect :Rect.topLeft)))))
  56.         (GWorld-alloc gw-view)
  57.         (unwind-protect
  58.           (dotimes (i pat-count)
  59.             (with-focused-view gw-view
  60.               (#_FillRect mask-rect pat-list_p))
  61.             (with-locked-GWorld-view gw-view
  62.               (funcall fn (view-portBits gw-view)))
  63.             (%incf-ptr pat-list_p (rlength :Pattern)))
  64.           (GWorld-free gw-view))))))
  65.  
  66.  
  67. (defun copy-thru-pats (src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks pat-hex-string)
  68.   (rlet ((mask-rect :Rect
  69.                     :topLeft #@(0 0)
  70.                     :botRight (subtract-points (pref dest-rect :Rect.botRight)
  71.                                                (pref dest-rect :Rect.topLeft))))
  72.     (with-current-portBits cur-portBits
  73.       (flet ((off-copy (mask-portBits)
  74.                (#_CopyDeepMask src-portBits mask-portBits cur-portBits src-rect mask-rect dest-rect copy-mode copy-rgn)
  75.                (rlet ((finalTicks_p :longint))
  76.                  (#_Delay delay-ticks finalTicks_p))))
  77.         (declare (dynamic-extent #'off-copy))
  78.         (map-pat-masks #'off-copy mask-rect pat-hex-string)))))
  79.  
  80.  
  81. (defun dissolve-o-rama (src-portBits src-rect dest-rect
  82.                                      &key
  83.                                      (copy-mode     #$srcCopy)
  84.                                      (copy-rgn      (%null-ptr))
  85.                                      (delay-ticks   0)
  86.                                      (dissolve-type :transporter))
  87.   (copy-thru-pats src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks
  88.                   (getf *QD-fx-pats* dissolve-type (second *QD-fx-pats*))))
  89.                   
  90.  
  91.  
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93. ;; wipe effects
  94.  
  95.  
  96. (defun copy-thru-wipe (src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks wipe-direction wipe-count)
  97.   (let* ((src-size   (subtract-points (pref src-rect :rect.botright)  (pref src-rect :rect.topleft)))
  98.          (dst-size   (subtract-points (pref dest-rect :rect.botright) (pref dest-rect :rect.topleft)))
  99.          (src-width  (point-h src-size))
  100.          (src-height (point-v src-size))
  101.          (dst-width  (point-h dst-size))
  102.          (dst-height (point-v dst-size))
  103.          (src-dh 0)
  104.          (src-dv 0)
  105.          (dst-dh 0)
  106.          (dst-dv 0))
  107.     (decf wipe-count)
  108.     (rlet ((src-wipe :rect :topleft #@(0 0) :botright src-size)
  109.            (dst-wipe :rect :topleft #@(0 0) :botright dst-size)
  110.            (tick-count :longint))
  111.       (ecase wipe-direction
  112.         (:left-to-right
  113.          (setf src-dh (floor src-width wipe-count))
  114.          (pset src-wipe :rect.right src-dh)
  115.          (setf dst-dh (floor dst-width wipe-count))
  116.          (pset dst-wipe :rect.right dst-dh))
  117.         (:right-to-left
  118.          (setf src-dh (- (floor src-width wipe-count)))
  119.          (pset src-wipe :rect.left (+ src-width src-dh))
  120.          (setf dst-dh (- (floor dst-width wipe-count)))
  121.          (pset dst-wipe :rect.left (+ dst-width dst-dh)))
  122.         (:top-to-bottom
  123.          (setf src-dv (floor src-height wipe-count))
  124.          (pset src-wipe :rect.bottom src-dv)
  125.          (setf dst-dv (floor src-height wipe-count))
  126.          (pset dst-wipe :rect.bottom dst-dv))
  127.         (:bottom-to-top ;God knows who would want it...Raymie!
  128.          (setf src-dv (- (floor src-height wipe-count)))
  129.          (pset src-wipe :rect.top (+ src-height src-dv))
  130.          (setf dst-dv (- (floor dst-height wipe-count)))
  131.          (pset dst-wipe :rect.top (+ dst-height dst-dv))))
  132.       (with-current-portbits cur-portBits
  133.         (dotimes (i wipe-count)
  134.           (#_CopyBits src-portBits cur-portBits src-wipe dst-wipe copy-mode copy-rgn)
  135.           (#_Delay delay-ticks tick-count)
  136.           (incf (pref src-wipe :rect.left) src-dh)
  137.           (incf (pref src-wipe :rect.top) src-dv)
  138.           (incf (pref src-wipe :rect.right) src-dh)
  139.           (incf (pref src-wipe :rect.bottom) src-dv)
  140.           (incf (pref dst-wipe :rect.left) dst-dh)
  141.           (incf (pref dst-wipe :rect.top) dst-dv)
  142.           (incf (pref dst-wipe :rect.right) dst-dh)
  143.           (incf (pref dst-wipe :rect.bottom) dst-dv))
  144.         (ecase wipe-direction
  145.           (:left-to-right
  146.            (pset src-wipe :rect.right src-width)
  147.            (pset dst-wipe :rect.right dst-width))
  148.           (:right-to-left
  149.            (pset src-wipe :rect.left 0)
  150.            (pset dst-wipe :rect.left 0))
  151.           (:top-to-bottom
  152.            (pset src-wipe :rect.bottom src-height)
  153.            (pset dst-wipe :rect.bottom dst-height))
  154.           (:bottom-to-top
  155.            (pset src-wipe :rect.top 0)
  156.            (pset dst-wipe :rect.top 0)))
  157.         (#_CopyBits src-portBits cur-portBits src-wipe dst-wipe copy-mode copy-rgn)))))
  158.  
  159. (defun wipe-o-rama (src-portBits src-rect dest-rect
  160.                                  &key
  161.                                  (copy-mode      #$srcCopy)
  162.                                  (copy-rgn       (%null-ptr))
  163.                                  (delay-ticks    0)
  164.                                  (wipe-direction :left-to-right)
  165.                                  (wipe-count     10))
  166.   (copy-thru-wipe src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks wipe-direction wipe-count))
  167.  
  168.  
  169. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  170. ;; iris effects
  171.  
  172. (defun map-round-iris-masks (fn mask-rect iris-direction iris-count)
  173.   (let* ((mask-width  (- (pref mask-rect :Rect.right)  (pref mask-rect :Rect.left)))
  174.          (mask-height (- (pref mask-rect :Rect.bottom) (pref mask-rect :Rect.top)))
  175.          (diameter    (ceiling (max mask-width mask-height) (1- iris-count)))
  176.          (radius      (ceiling diameter 2))
  177.          (dr          (ecase iris-direction (:outward (- radius)) (:inward radius)))
  178.          (radius-arm (make-point radius radius))
  179.          (center (make-point (round (+ (pref mask-rect :Rect.right)  (pref mask-rect :Rect.left)) 2)
  180.                              (round (+ (pref mask-rect :Rect.bottom) (pref mask-rect :Rect.top))  2))))
  181.     (rlet ((iris-rect :Rect)
  182.            (last-iris :Rect))
  183.       (ecase iris-direction
  184.         (:outward (pset iris-rect :Rect.topLeft  (subtract-points center radius-arm))
  185.                   (pset iris-rect :Rect.botRight (add-points      center radius-arm))
  186.                   (pset last-iris :Rect.topLeft  #@(-1 -1))
  187.                   (pset last-iris :Rect.botRight #@(-2 -2)))
  188.         (:inward  (let ((nradius-arm (make-point (* iris-count radius) (* iris-count radius))))
  189.                     (pset iris-rect :Rect.topLeft (subtract-points center nradius-arm))
  190.                     (pset iris-rect :Rect.botRight (add-points center nradius-arm)))
  191.                   (pset last-iris :Rect.topLeft  #@(-16000 -16000))
  192.                   (pset last-iris :Rect.botRight #@(16000 16000))))
  193.       (let ((gw-view (make-instance 'GWorld-view
  194.                        :GW-depth 1
  195.                        :view-position (pref mask-rect :Rect.topLeft)
  196.                        :view-size     (subtract-points (pref mask-rect :Rect.botRight)
  197.                                                        (pref mask-rect :Rect.topLeft)))))
  198.         (GWorld-alloc gw-view)
  199.         (unwind-protect
  200.           (progn
  201.             (with-focused-view gw-view
  202.               (#_EraseRect mask-rect))
  203.             (dotimes (i (1- iris-count))
  204.               (with-focused-view gw-view
  205.                 (ecase iris-direction
  206.                   (:outward (#_FillOval  iris-rect *black-pattern*)
  207.                             (#_EraseOval last-iris))
  208.                   (:inward  (#_EraseRect mask-rect)
  209.                             (#_FillOval  last-iris *black-pattern*)
  210.                             (#_EraseOval iris-rect))))
  211.               (with-locked-GWorld-view gw-view
  212.                 (funcall fn (view-portBits gw-view)))
  213.               (pset last-iris :Rect iris-rect)
  214.               (#_InsetRect iris-rect dr dr))
  215.             
  216.             (with-focused-view gw-view
  217.               (ecase iris-direction
  218.                 (:outward  (#_FillOval last-iris *black-pattern*)
  219.                            (#_InvertRect mask-rect))
  220.                 (:inward   (#_FillOval last-iris *black-pattern*))))
  221.             (with-locked-GWorld-view gw-view
  222.               (funcall fn (view-portBits gw-view))))
  223.           (GWorld-free gw-view))))))
  224.  
  225. (defun copy-thru-round-iris (src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks iris-direction iris-count)
  226.   (rlet ((mask-rect :Rect
  227.                     :topLeft #@(0 0)
  228.                     :botRight (subtract-points (pref dest-rect :Rect.botRight)
  229.                                                (pref dest-rect :Rect.topLeft))))
  230.     (with-current-portBits cur-portBits
  231.       (flet ((off-copy (mask-portBits)
  232.                (#_CopyDeepMask src-portBits mask-portBits cur-portBits src-rect mask-rect dest-rect copy-mode copy-rgn)
  233.                (rlet ((finalTicks_p :longint))
  234.                  (#_Delay delay-ticks finalTicks_p))))
  235.         (declare (dynamic-extent #'off-copy))
  236.         (map-round-iris-masks #'off-copy mask-rect iris-direction iris-count)))))
  237.  
  238.  
  239. (defun map-square-iris-masks (fn mask-rect iris-direction iris-count)
  240.   (let* ((mask-width  (- (pref mask-rect :Rect.right)  (pref mask-rect :Rect.left)))
  241.          (mask-height (- (pref mask-rect :Rect.bottom) (pref mask-rect :Rect.top)))
  242.          (diameter    (ceiling (max mask-width mask-height) iris-count))
  243.          (radius      (ceiling diameter 2))
  244.          (dr          (ecase iris-direction (:outward (- radius)) (:inward radius)))
  245.          (radius-arm (make-point radius radius))
  246.          (center (make-point (round (+ (pref mask-rect :Rect.right)  (pref mask-rect :Rect.left)) 2)
  247.                              (round (+ (pref mask-rect :Rect.bottom) (pref mask-rect :Rect.top))  2))))
  248.     (rlet ((iris-rect :Rect)
  249.            (last-iris :Rect))
  250.       (ecase iris-direction
  251.         (:outward (pset iris-rect :Rect.topLeft  (subtract-points center radius-arm))
  252.                   (pset iris-rect :Rect.botRight (add-points center radius-arm))
  253.                   (pset last-iris :Rect.topLeft  #@(-1 -1))
  254.                   (pset last-iris :Rect.botRight #@(-2 -2)))
  255.         (:inward  (let ((nradius-arm (make-point (* iris-count radius) (* iris-count radius))))
  256.                     (pset iris-rect :Rect.topLeft (subtract-points center nradius-arm))
  257.                     (pset iris-rect :Rect.botRight (add-points center nradius-arm)))
  258.                   (pset last-iris :Rect mask-rect)
  259.                   (#_InsetRect iris-rect dr dr)))
  260.       (let ((gw-view (make-instance 'GWorld-view
  261.                        :GW-depth 1
  262.                        :view-position (pref mask-rect :Rect.topLeft)
  263.                        :view-size     (subtract-points (pref mask-rect :Rect.botRight)
  264.                                                        (pref mask-rect :Rect.topLeft)))))
  265.         (GWorld-alloc gw-view)
  266.         (unwind-protect
  267.           (progn
  268.             (with-focused-view gw-view
  269.               (#_EraseRect mask-rect))
  270.             (dotimes (i iris-count)
  271.               (with-focused-view gw-view
  272.                 (ecase iris-direction
  273.                   (:outward (#_FillRect  iris-rect *black-pattern*)
  274.                             (#_EraseRect last-iris))
  275.                   (:inward  (#_EraseRect mask-rect)
  276.                             (#_FillRect  last-iris *black-pattern*)
  277.                             (#_EraseRect iris-rect))))
  278.               (with-locked-GWorld-view gw-view
  279.                 (funcall fn (view-portBits gw-view)))
  280.               (pset last-iris :Rect iris-rect)
  281.               (#_InsetRect iris-rect dr dr)))
  282.           (GWorld-free gw-view))))))
  283.  
  284.  
  285. (defun copy-thru-square-iris (src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks iris-direction iris-count)
  286.   (rlet ((mask-rect :Rect
  287.                     :topLeft #@(0 0)
  288.                     :botRight (subtract-points (pref dest-rect :Rect.botRight)
  289.                                                (pref dest-rect :Rect.topLeft))))
  290.     (with-current-portBits cur-portBits
  291.       (flet ((off-copy (mask-portBits)
  292.                (#_CopyDeepMask src-portBits mask-portBits cur-portBits src-rect mask-rect dest-rect copy-mode copy-rgn)
  293.                (rlet ((finalTicks_p :longint))
  294.                  (#_Delay delay-ticks finalTicks_p))))
  295.         (declare (dynamic-extent #'off-copy))
  296.         (map-square-iris-masks #'off-copy mask-rect iris-direction iris-count)))))
  297.  
  298.  
  299. (defun iris-o-rama (src-portBits src-rect dest-rect
  300.                             &key
  301.                             (copy-mode      #$srcCopy)
  302.                             (copy-rgn       (%null-ptr))
  303.                             (delay-ticks    0)
  304.                             (iris-direction :outward)
  305.                             (iris-count     8)
  306.                             (iris-shape     :round))
  307.   (ecase iris-shape
  308.     (:round
  309.      (copy-thru-round-iris  src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks iris-direction iris-count))
  310.     (:square
  311.      (copy-thru-square-iris src-portBits src-rect dest-rect copy-mode copy-rgn delay-ticks iris-direction iris-count))))
  312.