From: Fred Gilham
Subject: Code for amusement
Date: 
Message-ID: <u7af0x9sko.fsf_-_@snapdragon.csl.sri.com>
Here's a program using common lisp with Garnet as the GUI toolkit.  It
lets you do Mandelbrot Set exploration.  The code is `inspired' by
code I found on the net by Mark Watson.

The performance on my P-II 300 under CMUCL is quite brisk.  I found
that it runs much faster on CMUCL than on Allegro CL 4.3.  It is one
of these examples where declarations make all the difference (an early
small version went from consing 200+MB to .5MB and from 40+ seconds to
3 seconds by adding declarations) so I'm wondering if I got the
declarations right for Allegro.  I even changed the long-floats to
short-floats for Allegro and it was still slow.

Because it uses Garnet pixmaps, this code depends on some fixes I made
to Garnet---the fixed version of Garnet is available at the CMUCL web
site under the ports directory.

The approach to color this program takes is simple-minded to put it
mildly.  I only tested it on 16-bit true-color displays.

;;;
;;; File: Mandelbrot.lisp
;;; Copyright Fred Gilham  Dec 1998.
;;; Permission granted to make any use you want of this code.
;;; Code not guaranteed to do anything right.
;;;
;;; Calculate and plot the Mandelbrot set.
;;; Left button on plot lets you select a region to expand.
;;; Middle button starts the expansion.
;;; Right button zooms out by a factor of 2.
;;;

(declaim (optimize (speed 3) (safety 1) (debug 3)))

;;;
;;; Window variables.
;;;
(defvar *w* nil)                  ; Top-level window.
(defvar *w-agg* nil)              ; Top-level aggregate.
(defvar *pixmap* nil)             ; Pixmap of mandelbrot set.
(defvar *pixarray* nil)           ; Array we plot points into.
(defvar *moving-rectangle* nil)   ; Feedback for selecting enlargement.
(defvar *outline-rectangle* nil)  ; Shows area to be enlarged.
(defvar *box-list* nil)           ; x, y, width, height of outline rectangle. 

;;;
;;; Initialize a plot window.
;;;
(defun init (&optional (title "Plot Window") (xsize 400) (ysize 400))
  (unless *w*     ; Only do it once.
    ;; Create window and aggregate.
    (setf *w* (create-instance nil inter:interactor-window
			       (:title title)
			       (:left 40) (:top 40)
			       (:width xsize) (:height ysize)
			       (:foreground-color opal:blue)
			       (:background-color opal:white))
	  *w-agg* (create-instance nil opal:aggregate))
    (s-value *w* :aggregate *w-agg*)
    (opal:update *w*)

    ;; Set up pixmap and pixarray
    (let ((width (g-value *w* :width))
	  (height (g-value *w* :height)))
      (setf *pixmap*
	    (create-instance nil opal:pixmap
			     (:image (opal:create-pixmap-image width height)))))
    (opal:add-component *w-agg* *pixmap*)
    (setf *pixarray* (g-value *pixmap* :pixarray))

    (create-feedback-rectangles)
    (create-interactors)))

;;;
;;; Create rectangles used to select area to zoom.
;;;
(defun create-feedback-rectangles ()
  (unless *moving-rectangle*

    (setf

     *moving-rectangle*
     (create-instance nil opal:rectangle
		      (:box (list 0 0 0 0))
		      (:left (o-formula (first (gvl :box))))
		      (:top (o-formula (second (gvl :box))))
		      (:width (o-formula (third (gvl :box))))
		      (:height (o-formula (fourth (gvl :box))))
		      #+nil (:line-style opal:dashed-line))

     *outline-rectangle*
     (create-instance nil opal:rectangle
		      (:visible nil)
		      (:left 0)
		      (:top 0)
		      (:width 0)
		      (:height 0)))

    (opal:add-components *w-agg* *moving-rectangle* *outline-rectangle*)))

;;;
;;; Create interactors that allow us to manipulate the plot.
;;;
(defun create-interactors ()

  ;; This lets us select an area of the plot to enlarge.
  (create-instance nil inter:two-point-interactor
		   (:window *w*)
		   (:start-event :leftdown)
		   (:start-action #'(lambda (i p)
				      (declare (ignore i p))
				      (s-value *outline-rectangle* :visible nil)))
		   (:start-where T)
		   (:final-function #'set-outline-rectangle)
		   (:feedback-obj *moving-rectangle*)
		   (:line-p nil)
		   (:min-height 0)
		   (:min-width 0))

  ;; This starts the enlargement.
  (create-instance nil inter:button-interactor
		   (:window *w*)
		   (:start-event :middledown)
		   (:start-where T)
		   (:continuous nil)
		   (:final-function #'redo-plot))

  ;; This zooms out by a factor of 2.
  (create-instance nil inter:button-interactor
		   (:window *w*)
		   (:start-event :rightdown)
		   (:start-where T)
		   (:continuous nil)
		   (:final-function #'zoom-out)))


;;;
;;; Callbacks for interactors.
;;;

(defun set-outline-rectangle (int box-list)
  (declare (ignore int))
  (when box-list
    (setf *box-list* box-list)
    (s-value *outline-rectangle* :left (first box-list))
    (s-value *outline-rectangle* :top (second box-list))
    (s-value *outline-rectangle* :width (third box-list))
    (s-value *outline-rectangle* :height (fourth box-list))
    (s-value *outline-rectangle* :visible t)))


(defun redo-plot (int obj)
  (declare (ignore int obj))
  (s-value *outline-rectangle* :visible nil)

  (let ((new-x (first *box-list*))
	(new-y (second *box-list*))
	(new-width (third *box-list*)))
    (declare (fixnum new-x new-y new-width))

    (setf
     *start-x* (- *start-x* (* *plot-width* (/ new-x *num-x-cells*)))
     *start-y* (- *start-y* (* *plot-width* (/  new-y *num-y-cells*)))
     *plot-width* (* *plot-width* (/ new-width *num-x-cells*)))

    (m)))


(defun zoom-out (int obj)
  (declare (ignore int obj))
  (s-value *outline-rectangle* :visible nil)

  ;; The following has the effect of
  ;; 1. Subtracting *plot-width*/2 from *start-x* and *start-y*
  ;;    to find the mid-point.
  ;; 2. Multiplying *plot-width* by 2.
  ;; 3. Adding the new *plot-width*/2 to *start-x* and *start-y*
  ;;    to find the new start points.
  (let ((delta (/ *plot-width* 2)))
    (declare (long-float delta))
    (setf *start-x* (+ *start-x* delta))
    (setf *start-y* (+ *start-y* delta))
    (setf *plot-width* (* *plot-width* 2)))

  (m))


;;; Function to plot a point in the pixmap.
(declaim (inline point))
(defun point (x y color)
  (declare (fixnum x y color))
  (setf (aref *pixarray* y x) color))


;;;
;;; Graphics parameters.
;;;
(declaim (fixnum *max-colors* *num-x-cells* *num-y-cells*))
(declaim (type (integer 0 1024) *iterations*))
(defparameter *iterations* 1024)
(defvar *max-colors* 65535)      ; Currently not used.
(defparameter *num-x-cells* 800)
(defparameter *num-y-cells* 650)

;;;
;;; The following is a rudimentary scheme to let us pick colors.  It
;;; assumes a true-color arrangement.  I've only tried it with 16-bit
;;; color.
;;;

(declaim (fixnum *black-index*))

;;; Set up the black colormap index.
(defvar *black-index* (g-value opal:black :colormap-index)) ; Get black's colormap index.

;;;
;;;  A green color scheme, merging into blues.
;;;
(declaim (type (integer 0 65535) *offset-index*))
(defparameter *offset-index* (g-value opal:green :colormap-index))

;;; Mangle the color index.
(declaim (inline f))
(defun f (i)
  (declare (type (integer 0 1024) i))
  (let* ((a (- *iterations* i))
	 (b (* a 10))
	 (c (+ b *offset-index*)))
    (declare (type (integer 0 1024) a)
	     (type (integer 0 10240) b)
	     (type (integer 0 65535) c))
    c))


;;;
;;; Plot parameters.
;;;
(declaim (long-float *start-x* *start-y* *plot-width*))
(defvar *start-x* 2.0l0)
(defvar *start-y* 1.6l0)
(defvar *plot-width* 3.2l0)

;;;
;;;  Function m is called to calculate the Mandelbrot set
;;; for complex points around the complex number zero.
;;;

(defun m ()

  ;; Set up window stuff.
  (init "Mandelbrot Plot" *num-x-cells* *num-y-cells*)
  (opal:raise-window *w*)

  ;; Do the plot.
  (let ((delta-x-cell (/ *plot-width* *num-x-cells*))
	(delta-y-cell (/ *plot-width*  *num-y-cells*))
	(x 0.0l0)
	(y 0.0l0)
	(z (complex 0l0 0l0)))
    (declare (long-float delta-x-cell delta-y-cell x y)
	     (type (complex long-float) z))
    (dotimes (ix *num-x-cells*)
      (declare (type (integer 0 2000) ix))
      (format t "~A " ix)
      (finish-output)
      ;; This lets us see the plot as it is made.
      (when (= (mod ix 50) 0)
	(opal:update *w* t))
      (setf x (- (* ix delta-x-cell) *start-x*))
      (dotimes (iy *num-y-cells*)
	(declare (type (integer 0 2000) iy))
	(setf y (- (* iy delta-y-cell) *start-y*))
	(setf z (complex x y))
	(point ix iy (dotimes (i *iterations* *black-index*)
		       (declare (type (integer 0 65535) i))
		       (setf z (+ (complex x y) (* z z)))
		       (when (> (+ (* (realpart z) (realpart z))
				   (* (imagpart z) (imagpart z)))
				4)
			 (return (f i))))))))
  (opal:update *w* t))


-- 
Fred Gilham                                             ······@csl.sri.com
King Christ, this world is all aleak, / And life preservers there are none,
And waves that only He may walk / Who dared to call Himself a man.
-- e. e. cummings, from Jehovah Buried, Satan Dead