[Openmcl-devel] Fun with Clozure CL
Raffael Cavallaro
raffaelcavallaro at mac.com
Tue Oct 16 23:19:07 PDT 2007
Since I don't yet have the .cdb files for a certain Core ___
framework, I've dusted off some old code that does simple animation
using ns-bezier-path. I've added color cycling to make the animation a
bit more, shall we say psychedelic...
... oh, and the window does live resizing as it animates.
Just load this file and evaluate:
(ccl::animate)
You can play with the various parameters defined at the top of the
file (*min-sides* *max-sides* *step* *anim-cycles-for-full-color-
wheel* *bg-fg-color-offset-ratio* etc.) and see the different effects.
You'll have to reload the file and redo (ccl::animate) to pick up the
changes, but that's one of the benefits of CCL - loading/compiling is
so fast!
If anybody at Clozure happens to look at this let us know if anything
used here is now deprecated - this was originally a rewrite Gary did
of my simple animated version of tiny.lisp but that was three years
ago now and things may have changed. It works (at least, I've tested
it on a Core 2 Duo machine) but there may be stylistic cruft as the
cocoa bridge has been changing.
Thanks again to everybody at Clozure - I've really enjoyed using CCL
so far.
Everybody, I hope you have as much fun playing with this eye candy as
I did.
regards,
Ralph
------------- begin tiny-animate.lisp -----------------
;;;; -*- Mode: Lisp; Package: CCL -*-
;;;; tiny.lisp
;;;;
;;;; A fairly direct translation into Lisp of the Tiny application
(Chapter 4)
;;;; from "Building Cocoa Applications" by Garfinkel and Mahoney
;;;;
;;;; The original Tiny example was meant to illustrate the
programmatic use of
;;;; Cocoa without Interface Builder. Its purpose here is to
illustrate the
;;;; programmatic use of the Cocoa bridge.
;;;;
;;;; Copyright (c) 2003 Randall D. Beer
;;;;
;;;; This software is licensed under the terms of the Lisp Lesser GNU
Public
;;;; License , known as the LLGPL. The LLGPL consists of a preamble and
;;;; the LGPL. Where these conflict, the preamble takes precedence. The
;;;; LLGPL is available online at http://opensource.franz.com/preamble.html
.
;;;;
;;;; Please send comments and bug reports to <beer at eecs.cwru.edu>
;;;; Modified to animate the drawing of polygons by Raf Cavallaro
5-13-2004
;;;; Modifications also licensed under the LLGPL.
;;;; Raf Cavallaro can be reached at <raffaelcavallaro at mac.com>
;;;; Rewritten by Gary Byers 5-2004 to handle window closing properly
;;;; and to separate drawing and timer code.
;;;; Modified by Raffael Cavallaro 10-16-07 to cycle colors while
drawing
;;;; and to parameterize various options such as min and max polys,
;;;; animation timer delay, how quickly colors cycle, etc.
;;; Temporary package and module stuff
(in-package "CCL")
(declaim (optimize (speed 0) (safety 3) (debug 3) (space 0)
(compilation-speed 0)))
(defparameter *draw-in-main-thread* t)
(require "COCOA")
;; These parameters determine where we start and stop, and how we step
;; through the animation.
;; Don't change these until you know what you're doing -
;; specifically, min max and step need to satify the assertion below
(defparameter *min-sides* 3) ;; minimum polygon sides in animation
(defparameter *max-sides* 23) ;; maximum polygon sides in animation
(defparameter *step* 2)
(assert (= (mod (- *max-sides* *min-sides*) *step*) 0)
(*max-sides* *min-sides* *step*)
"~a is not a valid value for *step* when *min-sides* is ~a and *max-
sides* is ~a"
*step* *min-sides* *max-sides*)
(defparameter *anim-cycles-for-full-color-wheel* 12)
;; How many full animation cycles to go through the whole color wheel
(defun color-array-size ()
(* *anim-cycles-for-full-color-wheel*
(* 2 (truncate (- *max-sides* *min-sides*) *step*))))
(defparameter *color-array*
(let ((the-color-array (make-array (color-array-size) :element-type
'ns:ns-color)))
(loop for i from 0 below (color-array-size) do
(setf (aref the-color-array i)
(ccl::send (@class "NSColor")
:color-with-calibrated-hue (coerce (/ i (color-array-size))
'double-float)
:saturation 1.0d0 :brightness 1.0d0 :alpha 1.0d0)))
the-color-array))
;; Lets start with red-orange!
(defparameter *current-color-index* (truncate (color-array-size) 24))
;; hue values just in case you're curious:
;; 0.0/1.0 = red
;; 0.1 = yellow-orange
;; 0.2 = lime green
;; 0.3 = neutral green
;; 0.4 = blue-green
;; 0.5 = cyan
;; 0.6 = cobalt blue
;; 0.7 = ultramarine blue
;; 0.8 = violet
;; 0.9 = magenta
(defparameter *bg-fg-color-offset-ratio* 0.45) ;; color contrast of
near-complements
(defun background-foreground-offset () (truncate (* *bg-fg-color-
offset-ratio* (color-array-size))))
(defun current-background-color () (aref *color-array* *current-color-
index*))
(defun current-foreground-color ()
(aref *color-array* (mod (+ *current-color-index* (background-
foreground-offset)) (color-array-size))))
;; at each frame we move bg color one index forward in the color array
;; until we reach the end and then cycle back to 0
;; fg color is keyed to bg color in function current-foreground-color
above
(defun bump-colors ()
(if (< *current-color-index* (1- (color-array-size)))
(incf *current-color-index*)
(setf *current-color-index* 0)))
;; each frame is the rendering of a n-gon with all n vertices connected
;; the foreground and background colors change with each frame
(defparameter *frames-per-second* 24) ;; animation frame rate
(defparameter *animation-timer-delay* (coerce (/ *frames-per-second*)
'double-float))
(eval-when (:compile-toplevel :execute)
(use-interface-dir :carbon)
(use-interface-dir :cocoa))
;;; Define the AnimView class
(defclass anim-view (ns:ns-view)
((max :foreign-type :int ::accessor anim-view-max)
(min :foreign-type :int :accessor anim-view-min)
(step :foreign-type :int :accessor anim-view-step)
(numsides :foreign-type :int :accessor anim-view-numsides)
(down :foreign-type :<BOOL> :accessor anim-view-down))
(:metaclass ns:+ns-object))
(define-objc-method ((:<BOOL> is-opaque) anim-view)
t)
;;; It'd be nice if we could just use :INITFORM options to initialize
;;; these slots, but that's hard to do: SHARED-INITIALIZED would
generally
;;; use :INITFORMs to initialize slots that're otherwise unbound, but
;;; there isn't really a good way to tell whether a foreign slot's
;;; "unbound".
(define-objc-method ((:id :init-with-frame (:<NSR>ect r)) anim-view)
(let* ((v (send-super :init-with-frame r)))
(unless (%null-ptr-p v)
(setf (anim-view-max v) *max-sides*
(anim-view-min v) *min-sides*
(anim-view-step v) *step*
(anim-view-numsides v) 3))
v))
(defconstant short-pi (coerce pi 'short-float))
(defclass animation-window (ns:ns-window)
((thread-run-loop :foreign-type :id :accessor animation-window-
thread-run-loop)
(animation-timer :foreign-type :id :accessor animation-window-
animation-timer)
(close-ack :initform nil :accessor animation-window-close-ack))
(:metaclass ns:+ns-object))
;;; X, Y coordinates for cascading windows
(defparameter *next-animation-top* 100.0d0)
(defparameter *next-animation-left* 100.0d0)
;;; This does the animation, by adding the animation and close timers
;;; to the current thread's runloop and then running that runloop.
;;; The only input sources should be those timers; when the window
;;; closes, they'll be removed and the runloop will exit.
(defmethod animate-window ((self animation-window) view done)
(setf (animation-window-close-ack self) (make-semaphore))
(let* ((runloop (send (@class "NSRunLoop") 'current-run-loop)))
(setf (animation-window-thread-run-loop self) runloop)
(setf (animation-window-animation-timer self)
(make-objc-instance 'ns:ns-timer
:with-fire-date (send (@class "NSDate")
'distant-past)
:interval *animation-timer-delay*
:target view
:selector (@selector "doAnimation:")
:user-info (%null-ptr)
:repeats t))
(with-autorelease-pool
(send runloop
:add-timer
(animation-window-animation-timer self)
:for-mode #@"NSDefaultRunLoopMode")
(signal-semaphore done)
(send (the ns:ns-run-loop runloop) 'run))))
(defmethod start-animation ((self animation-window) view)
(let* ((created (make-semaphore)))
(process-run-function (format nil "Animation thread for window ~d"
(send self 'window-number))
#'animate-window
(%inc-ptr self 0)
view
created)
(wait-on-semaphore created)))
;;; Define the method that the animation thread uses to draw a anim-
view.
;;; NOTE: The (THE NS-COLOR ...) forms are currently necessary for full
;;; optimization because the SET message has a nonunique type
signature
;;; NOTE: The (@class XXX) forms will probably be replaced by
;;; (find-class 'XXX) once ObjC objects have been integrated
into CLOS
;;; Draw the demo view, constrained to the indicated rectangle.
(defmethod redraw-anim-view ((self anim-view) rect)
(declare (ignore rect))
(slet ((bounds (send self 'bounds)))
(let ((width (ns-width bounds))
(height (ns-height bounds))
(numsides (anim-view-numsides self)))
(macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5))
(Y (tt) `(* (1+ (cos ,tt)) height 0.5)))
;; Fill the view with current background color
(send (the ns-color
;; (send (@class ns-color) 'orange-color))
(current-background-color)) 'set)
(#_NSRectFill bounds)
;; Trace two polygons with N sides and connect all of the vertices
;; with cyan lines
(send (the ns-color (current-foreground-color)) 'set)
(loop for f from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi
numsides))
do
(loop
for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides))
do
(send (@class ns-bezier-path)
:stroke-line-from-point (ns-make-point (X f) (Y f))
:to-point (ns-make-point (X g) (Y g)))))))))
;;; The :draw-rect method should only be called on the main thread;
;;; it's called when needed by the Cocoa display mechanism, and
;;; ensures that (a) the graphics state is set up properly (b) the
;;; view is locked by the main thread. If *DRAW-IN-MAIN-THREAD* is
;;; false, we want all drawing to occur on the animation thread, so our
;;; :draw-rect method does nothing in that case.
(define-objc-method ((:void :draw-rect (:<NSR>ect rect))
anim-view)
(if *draw-in-main-thread*
(redraw-anim-view self rect)))
;;; Other threads can draw to the view, but they need to use
;;; lockFocusIfCanDraw: to atomically lock the view if it's
;;; currently visible.
;;; If we're able to draw to the view, we have to tell the
;;; window to flush the offscreen buffer to the screen.
(defmethod draw-from-other-thread ((view anim-view) &optional
(rectptr (%null-ptr)))
(when (send view 'lock-focus-if-can-draw)
(unwind-protect
(progn
(redraw-anim-view view rectptr)
(send (send view 'window) 'flush-window))
(send view 'unlock-focus))))
(define-objc-method ((:void :do-animation timer) anim-view)
(declare (ignore timer))
(slet ((view-bounds (send self 'bounds)))
(if *draw-in-main-thread*
(send self :set-needs-display t) ; force the main thread to
redraw the view
(draw-from-other-thread self view-bounds)) ; draw it ourselves
(let* ((down-p (anim-view-down self))
(step (anim-view-step self))
(numsides (anim-view-numsides self)))
(cond ((and (eql #$YES down-p) (<= numsides (anim-view-min self)))
(setf (anim-view-down self) #$NO))
((and (eql #$NO down-p) (>= numsides (anim-view-max self)))
(setf (anim-view-down self) #$YES))
((eql #$NO down-p)
(progn
(setf (anim-view-numsides self) (+ numsides step))
(bump-colors)))
(t
(progn
(setf (anim-view-numsides self) (- numsides step))
(bump-colors)))))))
(define-objc-method ((:void :stop-animation timer) animation-window)
(declare (ignore timer))
(send (animation-window-animation-timer self) 'invalidate)
(let* ((cfrunloop
(send (send (@class "NSRunLoop") 'current-run-loop) 'get-cf-
run-loop)))
(#_CFRunLoopStop cfrunloop))
(signal-semaphore (animation-window-close-ack self)))
(define-objc-method ((:void close) animation-window)
(let* ((timer (make-objc-instance 'ns:ns-timer
:with-fire-date (send (@class "NSDate") 'distant-past)
:interval 0.0d0
:target self
:selector (@selector "stopAnimation:")
:user-info (%null-ptr)
:repeats nil)))
;; Add the timer to the animation thread's run loop
(send (animation-window-thread-run-loop self)
:add-timer timer
:for-mode #@"NSDefaultRunLoopMode"))
;; Wait for it to acknowledge the close request
(wait-on-semaphore (animation-window-close-ack self))
;; Actually close the window ...
(send-super 'close))
;;; This performs the actions that would normally be performed by
loading
;;; a nib file. To avoid resource-contention errors, some of those
actions
;;; need to be performed on the main Cocoa event thread.
(defun animate (&key (n 1) (delay *animation-timer-delay*))
(declare (optimize (speed 2) (safety 1) (space 0) (compilation-
speed 0)))
(check-type n (integer 1))
(setq delay (coerce delay 'double-float))
(check-type delay (double-float (0.0d0)))
(with-autorelease-pool
(slet ((r (ns-make-rect 100.0d0 100.0d0 600.0d0 600.0d0)))
(let* ((*animation-timer-delay* delay))
(dotimes (i n)
(let ((w (make-instance
'animation-window
:with-content-rect r
:style-mask (logior #$NSTitledWindowMask
#$NSClosableWindowMask
#$NSMiniaturizableWindowMask
#$NSResizableWindowMask)
:backing #$NSBackingStoreBuffered
:defer t)))
(send w :set-title #@"Animation window")
(slet ((origin (ns-make-point *next-animation-left* *next-
animation-top*)))
(slet ((new-origin (send w :cascade-top-left-from-point origin)))
(setq *next-animation-left* (pref new-origin :<NSP>oint.x)
*next-animation-top* (pref new-origin :<NSP>oint.y)))
(let ((my-view (make-instance 'anim-view :with-frame r)))
(send w :set-content-view my-view)
(send w :set-delegate my-view)
(send w :make-key-and-order-front nil)
(start-animation w my-view)))))))))
------------ end tiny-animate.lisp -------------------
Raffael Cavallaro, Ph.D.
raffaelcavallaro at mac.com
More information about the Openmcl-devel
mailing list