#! /usr/local/bin/xmscm
;
; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xmandel.scm,v 1.7 1992/08/18 00:29:38 campbell Beta $
;
; Sample xmscm program for computing and displaying a Mandelbrot set
; (actually, the points _near_ the Mandelbrot set;  points in the set
; itself come out black).
;
;  Author: Larry Campbell (campbell@redsox.bsw.com)
; 
;  Copyright 1992 by The Boston Software Works, Inc.
;  Permission to use for any purpose whatsoever granted, as long
;  as this copyright notice remains intact.  Please send bug fixes
;  or enhancements to the above email address.

(require 'format)

(require 'x11)
(require 'xt)
(require 'xm)
(require 'xmsubs)
(require 'xevent)

(define call/cc call-with-current-continuation)		; save typing

(define origin '())			; center of area being drawn
(define depth '())			; how many iterations before giving up
(define width 0)			; width in pixels of drawing area
(define height 0)			; height in pixels of drawing area
(define magnification '())		; how much to magnify (zoom in)
(define pixmap '())			; pixmap into which we draw
(define continuation '())		; where the computation left off
(define work-proc-registered #f)	; whether a work proc is registered
(define window-origin '())		; coordinates of upper left corner
(define quantum '())			; how much real space each pixel represents
(define ncolors 16)			; how many colors to use


; Define widgets

(define top-level
  (if (defined? vs:top-level)
      (xt:app-create-shell "xmandel" "Xmandel"
			   xt:application-shell
			   (xt:display vs:top-level))
      (xt:initialize "xmandel" "Xmandel")))

(xt:set-values top-level xm:n-allow-shell-resize #t)

(define panel
  (xt:create-managed-widget
   "top" xm:form top-level))

(define controls
  (xt:create-managed-widget
   "control" xm:form panel
   xm:n-left-attachment xm:attach-form
   xm:n-top-attachment xm:attach-form
   xm:n-bottom-attachment xm:attach-form))

(define button-frame
  (xt:create-managed-widget
   "button-frame" xm:frame controls
   xm:n-left-attachment xm:attach-form
   xm:n-right-attachment xm:attach-form
   xm:n-top-attachment xm:attach-form))

(define button-box
  (xt:create-managed-widget
   "button-box" xm:row-column button-frame
   xm:n-orientation xm:vertical
   xm:n-num-columns 2
   xm:n-packing xm:pack-column))

(define reset-button
  (make-button
   "Reset" button-box
   (lambda (w)
     (origin-object 'set origin)
     (magnification-object 'set magnification)
     (depth-object 'set depth)
     (xt:set-values restart-button xm:n-sensitive #f))))

(define restart-button
  (make-button
   "Restart" button-box
   (lambda (w)
     (resize-handler drawing-area)
     #t)))

(define (value-change-handler w)
  (xt:set-values
   restart-button
   xm:n-sensitive
   (not
    (and
     (= origin (origin-object 'get))
     (= depth (depth-object 'get))
     (= magnification (magnification-object 'get))))))

(define paused #f)

(define pause-button
  (make-toggle-button
   "Pause" button-box
   (lambda (w)
     (let ((old-paused paused))
       (set! paused (xt:get-value w xm:n-set xt:boolean))
       (if (and old-paused (not paused))
	   (register-work-proc))))
   xm:n-shadow-thickness 2))

(define exit-button
  (make-button
   "Exit" button-box
   (lambda (w)
     (set! continuation '())
     (if (defined? vs:top-level)
	 (xt:unmap-widget top-level)
	 (quit)))))

(define param-frame
  (xt:create-managed-widget
   "param-frame" xm:frame controls
   xm:n-left-attachment xm:attach-form
   xm:n-right-attachment xm:attach-form
   xm:n-top-attachment xm:attach-widget
   xm:n-top-widget button-frame
   xm:n-bottom-attachment xm:attach-form))

(define param-box
  (xt:create-managed-widget
   "param-box" xm:row-column param-frame
   xm:n-orientation xm:vertical))

; This function creates an origin object, consisting of two sliders (one
; for the imaginary axis and one for the real axis), some state variables,
; and a method dispatch function.  The object responds to three messages:
;
;  (origin-object 'get)		returns complex origin defined by sliders
;  (origin-object 'set o)	sets sliders to specified origin
;  (origin-object 'rescale w h)	rescales sliders so they both appear in
;				 the middle and so the sliders exactly span
;				 the specified range (which is typically the
;				 drawing area)
;
(define (make-origin)
  (let* ((digits 3)
	 (mult (expt 10 digits))
	 (widget-value
	  (lambda (value)
	    (inexact->exact (round (* mult value)))))
	 (x-widget
	  (xt:create-managed-widget
	   "origin-x" xm:scale param-box
	   xm:n-orientation xm:horizontal
	   xm:n-minimum (widget-value -2)
	   xm:n-maximum (widget-value 2)
	   xm:n-value 0
	   xm:n-decimal-points digits
	   xm:n-show-value #t
	   xm:n-title-string (xm:string-create "Real origin")))
	 (y-widget
	  (xt:create-managed-widget
	   "origin-y" xm:scale param-box
	   xm:n-orientation xm:horizontal
	   xm:n-minimum (widget-value -2)
	   xm:n-maximum (widget-value 2)
	   xm:n-value 0
	   xm:n-decimal-points digits
	   xm:n-show-value #t
	   xm:n-title-string (xm:string-create "Imaginary origin"))))
    (letrec
	((self
	  (lambda (selector . args)
	    (case selector
	      ((get)
	       (let ((sx
		      (/ (xt:get-value x-widget xm:n-value xt:integer) mult))
		     (sy
		      (/ (xt:get-value y-widget xm:n-value xt:integer) mult)))
		 (make-rectangular sx sy)))
	      ((set)
	       (let ((x (real-part (car args)))
		     (y (imag-part (car args))))
		 (xt:set-values x-widget xm:n-value (widget-value x))
		 (xt:set-values y-widget xm:n-value (widget-value y)))
	       (value-change-handler x-widget)
	       (value-change-handler y-widget))
	      ((rescale)
	       (let* ((real-width (car args))
		      (real-height (cadr args))
		      (origin (self 'get))
		      (ox (real-part origin))
		      (oy (imag-part origin)))
		 (xt:set-values
		  x-widget xm:n-minimum (widget-value (- ox (/ real-width 2))))
		 (xt:set-values
		  x-widget xm:n-maximum (widget-value (+ ox (/ real-width 2))))
		 (xt:set-values
		  y-widget xm:n-minimum (widget-value (- oy (/ real-width 2))))
		 (xt:set-values
		  y-widget xm:n-maximum (widget-value (+ oy (/ real-width 2))))))
	      (else (error "invalid origin method" selector))))))
      (xt:add-callback x-widget xm:n-value-changed-callback value-change-handler)
      (xt:add-callback y-widget xm:n-value-changed-callback value-change-handler)
      self)))

(define origin-object (make-origin))

; This function creates a magnification object, which consists of a slider and
; a get method.
;
(define (make-magnification initial)
  (let* ((digits 4)
	 (mult (expt 10 digits))
	 (widget-value
	  (lambda (value)
	    (inexact->exact (round (* mult value)))))
	 (widget
	  (xt:create-managed-widget
	   "magnification" xm:scale param-box
	   xm:n-orientation xm:horizontal
	   xm:n-minimum (inexact->exact (* .1  mult))
	   xm:n-maximum (inexact->exact (* 40 mult))
	   xm:n-value (widget-value initial)
	   xm:n-decimal-points digits
	   xm:n-show-value #t
	   xm:n-title-string (xm:string-create "Magnification"))))
    (xt:add-callback widget xm:n-value-changed-callback value-change-handler)
    (lambda (selector . args)		; args not (yet) used
      (case selector
	((get) (/ (xt:get-value widget xm:n-value xt:integer) mult))
	((set) (xt:set-values widget xm:n-value (widget-value (car args))))
	(else (error "invalid origin method" selector))))))

(define magnification-object (make-magnification .1))

; This function creates and returns a depth object, which consists of a slider
; and a get method.
;
(define (make-depth initial)
  (let* ((widget
	  (xt:create-managed-widget
	   "depth" xm:scale param-box
	   xm:n-orientation xm:horizontal
	   xm:n-minimum 1
	   xm:n-maximum 200
	   xm:n-value initial
	   xm:n-decimal-points 0
	   xm:n-show-value #t
	   xm:n-title-string (xm:string-create "Depth"))))
    (xt:add-callback widget xm:n-value-changed-callback value-change-handler)
    (lambda (selector . args)		; args not (yet) used
      (case selector
	((get) (xt:get-value widget xm:n-value xt:integer))
	((set) (xt:set-values widget xm:n-value (car args)))
	(else (error "invalid origin method" selector))))))

(define depth-object (make-depth 20))
			    
(define drawing-frame
  (xt:create-managed-widget
   "frame" xm:frame panel))

(define drawing-area
  (xt:create-managed-widget
   "drawing-area" xm:drawing-area drawing-frame))

(xt:set-values
 drawing-frame
 xm:n-top-attachment xm:attach-form
 xm:n-bottom-attachment xm:attach-form
 xm:n-right-attachment xm:attach-form
 xm:n-left-attachment xm:attach-widget
 xm:n-left-widget controls)

(xt:realize-widget top-level)

(define xwindow (xt:window drawing-area))
(define xdisplay (xt:display drawing-area))
(define xgc1 (x:create-gc xdisplay '() x:gc-foreground 0 x:gc-background 1))
(define	xgc2 (x:create-gc xdisplay '() x:gc-foreground 1 x:gc-background 0))
(define display-colors (x:display-cells xdisplay 0))


;;; The cursor in the drawing area is a cross-hair.  If the user presses
;;; MB2 in the drawing area, we track motion events (until MB2 is released)
;;; and force the origin sliders to the point the cursor is on.

(x:define-cursor xdisplay (xt:window drawing-area) xc:crosshair)

(xt:add-event-handler
 drawing-area x:button-press-mask 0
 (lambda (widget event)
   (let ((button (x:get-event-field event x:button-event:button)))
     (if (= button 2)
	 (let* ((x (x:get-event-field event x:button-event:x))
		(y (x:get-event-field event x:button-event:y))
		(button-origin
		 (make-rectangular (+ (real-part window-origin)
				      (* quantum x))
				   (- (imag-part window-origin)
				      (* quantum y))))
		 (tracker
		  (lambda (widget event)
		    (let* ((x (x:get-event-field event x:motion-event:x))
			   (y (x:get-event-field event x:motion-event:y))
			   (new-origin
			    (make-rectangular (+ (real-part window-origin)
						 (* quantum x))
					      (- (imag-part window-origin)
						 (* quantum y)))))
		      (origin-object 'set new-origin)))))
	   (origin-object 'set button-origin)
	   (xt:add-event-handler drawing-area x:pointer-motion-mask 0 tracker)
	   (xt:add-event-handler
	    drawing-area x:button-release-mask 0
	    (lambda (widget event)
	      (let ((button (x:get-event-field event x:button-event:button)))
		(if (= button 2)
		    (xt:remove-event-handler
		     drawing-area x:pointer-motion-mask 0 tracker))))))))))
	      
(xt:set-values panel xm:n-width 600 xm:n-height 400)

(define cmap (x:default-colormap xdisplay 0))
(define private-colormap #f)

(define planes-n-colors
  (x:alloc-color-cells xdisplay cmap #t 0 ncolors))

(if (not planes-n-colors)		; if we couldn't allocate enuf cells
    (begin
      (set! cmap (x:create-colormap xdisplay (xt:window drawing-area) 0))
      (set! planes-n-colors (x:alloc-color-cells xdisplay cmap #t 0 ncolors))
      (set! private-colormap #t)))

(if (not planes-n-colors)
    (error "Failed utterly to allocate required 16 colors"))

(define base-pixel (car (reverse (cadr planes-n-colors))))

(let ((i base-pixel))
  (for-each
   (lambda (item)
     (let ((red (car item))
	   (green (cadr item))
	   (blue (caddr item)))
       (x:store-color xdisplay cmap i red green blue)
       (set! i (1+ i))))
   '((    0     0     0)		; colors - edit to taste (there
     (60000     0 65000)		; must be ncolors entries though)
     (40000     0 60000)
     (20000     0 55000)
     (15000     0 50000)
     (10000     0 45000)
     ( 8000     0 40000)
     ( 5000     0 35000)
     ( 1000     0 30000)
     (  500     0 25000)
     (    0     0 20000)
     (    0     0 15000)
     (    0     0 10000)
     (    0     0  8000)
     (    0     0  6000)
     (    0     0  4000))))

(if private-colormap
    (xt:add-event-handler
     drawing-area x:enter-window-mask 0
     (lambda (widget event)
       (x:install-colormap xdisplay cmap)
       (xt:add-event-handler
	drawing-area x:leave-window-mask 0
	(lambda (widget event)
	  (x:install-colormap
	   xdisplay
	   (x:default-colormap xdisplay 0)))))))

; The real (compute-intensive) work of computing the points to draw
; is performed in a work procedure called by Xt and registered with
; xt:add-work-proc (XtAddWorkProc).  The global variable "continuation"
; contains a continuation for the initiation  or resumption of this
; computation.  The work procedure calls compute-set (the first time)
; using call/cc and passing a continuation by which the Xt main loop
; can be resumed (so the program still handles user input).  compute-set
; computes for a while (currently 16 points) and then calls the
; continuation of the work proc with call/cc;   the work proc saves
; this continuation and the work proc resumes it each time it's
; called.  When compute-set finishes, it returns #t, which instructs
; the work proc to return #f, which instructs Xt to deregister it.
;
; There is also a global "paused" flag, which can be turned on by
; clicking a pause button -- useful if the machine's bogging down
; and you want to quit computing for a while.

(define (register-work-proc)
  (xt:add-work-proc work-proc)
  (set! work-proc-registered #t))

(define (work-proc)
  (cond ((null? continuation)			; computing not yet started
	 (set! continuation (call/cc compute-set))
	 #f)
	((or paused (eqv? #t continuation))	; computing finished or paused
	 (set! work-proc-registered #f)
	 #t)
	(else					; computing in progress
	 (continuation '())
	 #f)))

; To speed things up, we just compute points and store them by color in a vector,
; drawing the points and emptying the vector at the end of each row.
;
(define (compute-set contin)
  (set! origin (origin-object 'get))
  (set! depth (depth-object 'get))
  (set! magnification (magnification-object 'get))
  (set! quantum (/ 1 (* (min width height) magnification)))
  (let* ((lastcolor '())
	 (real-width (* width quantum))
	 (real-height (* height quantum))
	 (x-increment (make-rectangular quantum 0))
	 (y-increment (make-rectangular 0 quantum))
	 (points (make-vector ncolors '()))
	 (complex-zero (make-rectangular 0 0)))
    (set! window-origin (make-rectangular
			 (- (real-part origin) (/ real-width 2))
			 (+ (imag-part origin) (/ real-height 2))))
    (origin-object 'rescale real-width real-height)
    (do ((y 0 (1+ y))
	 (k0 window-origin (- k0 y-increment)))
	((=? y height) #t)
      (do ((x 0 (1+ x))
	   (k k0 (+ k x-increment)))
	  ((=? x width) #t)
	(let ((z complex-zero))
	  (do ((i 0 (1+ i)))
	      ((or (= i depth)
		   (>= (magnitude z) 4))
	       (let ((color
		      (modulo
		       (inexact->exact (truncate (magnitude z)))
		       ncolors))
		     (point (cons x y)))
		 (vector-set!
		  points color (cons point (vector-ref points color))))
	       #t)
	    (let ((term (+ z k)))
	      (set! z (* term term))))
	  (if (zero? (modulo x 16))		; every 16 points, let XtMainLoop run
	      (call/cc contin))))
      (do ((i 0 (1+ i)))			; end of row, draw saved points
	  ((= i ncolors) #t)
	(if (not (null? (vector-ref points i)))
	    (begin
	      (x:set-foreground xdisplay xgc2 (+ base-pixel i))
	      (if (xt:is-realized drawing-area)
		  (apply
		   x:draw-points
		   `(,xdisplay
		     ,(xt:window drawing-area)
		     ,xgc2 ,x:coord-mode-origin
		     ,@(vector-ref points i))))
	      (apply
	       x:draw-points
	       `(,xdisplay
		 ,pixmap ,xgc2 ,x:coord-mode-origin
		 ,@(vector-ref points i)))
	      (vector-set! points i '())))))))

; The resize handler allocates a new pixmap of the correct size and
; restarts the computation.
;
(define (resize-handler w)
  (set! height (xt:get-value w xt:n-height xt:unsigned-short))
  (set! width (xt:get-value w xt:n-width xt:unsigned-short))
  (if (not (null? pixmap))
      (x:free-pixmap xdisplay pixmap))
  (set! pixmap
	(x:create-pixmap
	 xdisplay '() width height
	 (x:display-depth xdisplay 0)))
  (x:fill-rectangle xdisplay pixmap xgc1 0 0 width height)
  (x:clear-area xdisplay xwindow 0 0 0 0 #t)
  (xt:set-values restart-button xm:n-sensitive #f)
  (set! continuation '())
  (if (not work-proc-registered)
      (register-work-proc)))

(resize-handler drawing-area)

; The expose handler just copies from the pixmap onto the window
;
(define (exposure-handler widget e)
  (let ((x (x:get-event-field e x:expose-event:x))
	(y (x:get-event-field e x:expose-event:y))
	(w (x:get-event-field e x:expose-event:width))
	(h (x:get-event-field e x:expose-event:height)))
    (x:copy-area xdisplay pixmap (xt:window widget)
		 xgc1 x y w h x y)))

(xt:add-event-handler drawing-area x:exposure-mask 0 exposure-handler)
(xt:add-callback drawing-area xm:n-resize-callback resize-handler)

(register-work-proc)

(if (not (defined? vs:top-level))
    (xt:main-loop))
