home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
x
/
xscm105.zip
/
xscm
/
xmandel.scm
< prev
next >
Wrap
Text File
|
1992-08-29
|
17KB
|
511 lines
#! /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))