[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:


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.



------------- 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  
;;;; 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  
;;;; 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  
;;;; 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  
     (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))  
			  :saturation 1.0d0 :brightness 1.0d0 :alpha 1.0d0)))

;; 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  

(defun  background-foreground-offset () (truncate (* *bg-fg-color- 
offset-ratio* (color-array-size))))

(defun current-background-color () (aref *color-array* *current-color- 

(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  

(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*)  

(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)

;;; It'd be nice if we could just use :INITFORM options to initialize
;;; these slots, but that's hard to do: SHARED-INITIALIZED would  
;;; 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))

(defconstant short-pi (coerce pi 'short-float))

(defclass animation-window (ns:ns-window)
   ((thread-run-loop :foreign-type :id :accessor animation-window- 
    (animation-timer :foreign-type :id :accessor animation-window- 
    (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")  
                               :interval *animation-timer-delay*
                               :target view
                               :selector (@selector "doAnimation:")
                               :user-info (%null-ptr)
                               :repeats t))
         (send runloop
               (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))
			  (%inc-ptr self 0)
     (wait-on-semaphore created)))

;;; Define the method that the animation thread uses to draw a anim- 
;;; NOTE: The (THE NS-COLOR ...) forms are currently necessary for full
;;;       optimization because the SET message has a nonunique type  
;;; 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  
		  for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides))
		  (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))
     (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)
            (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)
		   (setf (anim-view-numsides self) (+ numsides step))
		   (setf (anim-view-numsides self) (- numsides step))

(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- 
     (#_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  
;;; a nib file.  To avoid resource-contention errors, some of those  
;;; 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)))
       (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
			  :with-content-rect r
			  :style-mask (logior #$NSTitledWindowMask
			  :backing #$NSBackingStoreBuffered
			  :defer t)))
		  (send w :set-title #@"Animation window")
		  (slet ((origin (ns-make-point *next-animation-left* *next- 
			(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