;;;
;;; mandel.sc
;;;
(module schematic-user)
(include "schematic.sch")
(definep *mandel-images* (make-vector 64))
(definep *max-image* 0)
(definep *current-image* 0)
(definep *display* 0)
(definep *mozaic-size* 16)
(definep *pixel-size* 2)
(definep *mandel-canvas* 0)
(definep *drag* 0)
(definep *ddr* 0)
;;;
;;; For color
;;;
(definep (make-rgb r g b)
(format
#f "rgb:~a/~a/~a"
(number->string r 16) (number->string g 16) (number->string b 16)))
;;;
;;; A C routine which, given a string like "rgb:0/0/0", returns a
;;; pointer to XColor structure.
;;;
(define-c-external (parse-color TSCP) TSCP "StcTk_ParseColor")
(definep *black-color* (parse-color (make-rgb 0 0 0)))
(definep (generate-colors-vector n)
(let ((v (make-vector (+ (* 3 n) 1))))
(do ((i 0 (+ i 1)))
((= i n))
(vector-set!
v i (parse-color (make-rgb (- n 1 i) i 0))))
(do ((i 0 (+ i 1)))
((= i n))
(vector-set!
v (+ n i) (parse-color (make-rgb 0 (- n 1 i) i))))
(do ((i 0 (+ i 1)))
((= i n))
(vector-set!
v (+ n n i) (parse-color (make-rgb i 0 (- n 1 i)))))
(vector-set! v (+ n n n) *black-color*)
v))
(definep *colors-vector* (generate-colors-vector 16))
(definep *colors-multiplier* 8)
(definep *max-iter* (* *colors-multiplier* (vector-length *colors-vector*)))
;;;
;;;
;;;
(definep name-counter 0)
(definep (new-image-name)
(let ((c name-counter))
(set! name-counter (+ c 1))
(format #f "image~a" c)))
;;;
;;;
;;;
(define-in-line (make-rectangular r i)
(cons r i))
(define-in-line (real-part c)
(car c))
(define-in-line (imag-part c)
(cdr c))
;;;
;;; window class
;;; Lower-left and upper-right points are specified (by complex numbers)
;;; in LL and UR
;;; WIDTH and HEIGHT are integers which specify the size of the window
;;; NAME is the name of the Tk-window
;;;
;;;
;;; The last two slots are reserved for BEGIN-NEW-WINDOW and END-NEW-WINDOW
;;;
(definep (make-mandel-image-sub image-pointer image-name ll ur width height)
(vector image-pointer image-name ll ur width height (cons -1 -1)))
;;;
;;; Translate window relative (integer) coordinate into the coodinate
;;; in the complex plain.
;;; Given four integers I, J, WIDTH, HEIGHT and two complex numbers LL and
;;; UR (see below), calculate the complex number which corresponds to *.
;;;
;;;
;;; <---- Width ----->
;;; + +-----------+----+ ur
;;; | | | |
;;; HEIGHT | |J |
;;; | | | |
;;; | |<----I---->* |
;;; | | |
;;; | | |
;;; + +----------------+
;;; ll
;;;
(definep (calc-complex-coordinate i j ll ur width height)
(let ((llx (real-part ll))
(lly (imag-part ll))
(urx (real-part ur))
(ury (imag-part ur)))
;; * = (llx + (I/WIDTH) (urx - llx), lly + ((HEIGHT-J)/HEIGHT) (ury - lly))
(let ((cx (+ llx (/ (* i (- urx llx)) width)))
(cy (+ lly (/ (* (- height j) (- ury lly)) height))))
(make-rectangular cx cy))))
;;;
;;; For the performance sake, we implement main drawing routine in C.
;;; This routine takes:
;;; (1) I, J---window coodinate of the point to be plotted,
;;; (2) LLX, LLY, URX, URY---X and Y coordinates of Lower-Left and
;;; Upper-Right point of the image (in the complex plane)
;;; (3) WIDTH, HEIGHT---the size of the image
;;; (4) MAX-ITER---maximum number of iterations
;;;
(define-c-external (calc-complex-coordinate-and-calc-mandel
int int double double double double int int int)
int "calc_complex_coordinate_and_calc_mandel")
;;;
;;; In response to a mouse click, we prepare for creating a new image
;;;
(definep (begin-create-new-window self i j)
(vector-set! self 6 (cons i j)))
;;;
;;; This would be a method in Schematic
;;;
;;; When this method is called, lower left position has already been
;;; recorded in the 5th field of SELF by BEGIN-NEW-WINDOW method.
;;; At this point, we create a new window.
;;;
;;;
;;; (i1, j1) +-------------+
;;; | |
;;; | |
;;; | |
;;; +-------------+ (i2, j2)
;;;
(definep (finish-create-new-window self i2c j2c)
(let* ((ll (vector-ref self 2))
(ur (vector-ref self 3))
(width (vector-ref self 4))
(height (vector-ref self 5))
(ij (vector-ref self 6))
(i1 (adjust-x (car ij) width))
(j1 (adjust-y (cdr ij) height))
(i2 (adjust-x i2c width))
(j2 (adjust-y j2c height))
(di (- i2 i1))
(dj (- j2 j1))
(scale (floor (min (/ width di) (/ height dj)))))
(format #t "~s / ~s = ~s, ~s / ~s = ~s~%" width di (/ width di)
height dj (/ height dj))
(let* ((new-ll (calc-complex-coordinate i1 j2 ll ur width height))
(new-ur (calc-complex-coordinate i2 j1 ll ur width height))
(new-width (* scale di))
(new-height (* scale dj))
(new-image
(make-mandel-image
*mandel-canvas* new-ll new-ur new-width new-height)))
(first-set-mandel-image new-image)
(future (draw-mandel new-image *pixel-size*)))))
(definep (adjust-x x width)
(- x (/ (- 512 width) 2)))
(definep (adjust-y y height)
(- y (/ (- 512 height) 2)))
(definep (convert-x x width)
(+ x (/ (- 512 width) 2)))
(definep (convert-y y height)
(+ y (/ (- 512 height) 2)))
(definep (make-mandel-image canvas ll ur width height)
(let* ((image-name (new-image-name))
(im (make-image "create" "photo" image-name :width 512 :height 512))
(result (make-mandel-image-sub im image-name ll ur width height)))
result))
(definep (set-mandel-image self)
(let* ((im (vector-ref self 0))
(image-name (vector-ref self 1))
(ll (vector-ref self 2))
(ur (vector-ref self 3))
(width (vector-ref self 4))
(height (vector-ref self 5)))
(update-button
*display* "configure"
:text (format #f "~a / ~a" *current-image* *max-image*))
(update-canvas
*mandel-canvas* "create" "image"
(convert-x 1 width) (convert-y 1 height) :image image-name :anchor "nw")
(update-canvas
*mandel-canvas* "create" "rectangle"
(convert-x 0 width) (convert-y 0 height)
(convert-x (+ width 2) width) (convert-y (+ height 2) height)
:outline "black" :width 2)
(update-canvas
*mandel-canvas* "create" "rectangle"
(convert-x 0 width) (convert-y 0 height)
(convert-x (+ width 0) width) (convert-y (+ height 0) height)
:outline "gray" :width 1)))
(definep (first-set-mandel-image self)
(set! *max-image* (+ *max-image* 1))
(vector-set! *mandel-images* *max-image* self)
(set! *current-image* *max-image*)
(set-mandel-image (vector-ref *mandel-images* *current-image*)))
(definep (next-mandel-image)
(if (= *max-image* *current-image*)
(set! *current-image* 1)
(set! *current-image* (+ 1 *current-image*)))
*current-image*)
(definep (Start width height)
;; tell the window manager the title of the main window
(wm "title" "." "Schematic")
(label ".title" :text "Mandelbrot" :bd 4
:fg "Brown" :bg "yellow" :relief "ridge")
(label ".label" :text "Select a rectangle to zoom by mouse"
:bd 4 :fg "Black" :bg "palegreen4" :relief "sunken")
(frame ".bf")
(make-button ".bf.run" :text "Run" :command (plambda () (exit)))
(set! *mandel-canvas* (make-canvas ".c" :width width :height height))
(update-canvas
*mandel-canvas* "create" "rectangle" 0 0 512 512
:fill "pink" :outline "pink" :width 1)
(make-button ".bf.quit" :text "Quit"
:bg "RoyalBlue" :abg "red" :afg "blue"
:command (plambda () (exit)))
(make-button ".bf.select" :text "Select"
:bg "RoyalBlue" :abg "red" :afg "blue"
:command
(plambda ()
(set-mandel-image
(vector-ref *mandel-images* (next-mandel-image)))))
(set! *display*
(make-button
".bf.display" :text "1/1"
:bd 4 :fg "Brown" :bg "yellow" :relief "ridge"))
(pack ".bf.select" ".bf.display" ".bf.quit"
:side "left" :fill "both" :expand #t)
(set-int "cx1" 0)
(set-int "cy1" 0)
(set-int "cx2" 255)
(set-int "cy2" 255)
(bind ".c" "" "set cx1 %x")
(bind ".c" "" "set cy1 %y")
(bind ".c" ""
(plambda ()
(set! *ddr* (update-canvas *mandel-canvas* "create"
"rectangle"
(get-int "cx1") (get-int "cy1")
(get-int "cx1") (get-int "cy1")
:outline "palegreen4"
:width 3))
(set! *drag* 1)))
(bind ".c" "" "set cx2 %x")
(bind ".c" "" "set cy2 %y")
(bind ".c" ""
(plambda ()
(if (= *drag* 1)
(canvas-set-coords
*mandel-canvas*
*ddr* (get-int "cx1") (get-int "cy1")
(get-int "cx2") (get-int "cy2")))))
(bind ".c" "" "set cx2 %x")
(bind ".c" "" "set cy2 %y")
(bind ".c" ""
(plambda ()
(if (= *drag* 1)
(begin (set! *drag* 0)
(update-canvas *mandel-canvas* "delete" *ddr*)
(format #t "Zoom~%")
(format #t
"(x1,y1) = (~s,~s), (x2,y2) = (~s,~s)~%"
(get-int "cx1") (get-int "cy1")
(get-int "cx2") (get-int "cy2"))
(begin-create-new-window
(vector-ref *mandel-images* *current-image*)
(get-int "cx1") (get-int "cy1"))
(finish-create-new-window
(vector-ref *mandel-images* *current-image*)
(get-int "cx2") (get-int "cy2"))))))
(pack ".title" ".c" ".label" ".bf" :fill "both" :side "top" :expand #t)
(first-set-mandel-image
(make-mandel-image
*mandel-canvas* (make-rectangular -2.0 -2.0) (make-rectangular 2.0 2.0)
512 512))
(future
(draw-mandel (vector-ref *mandel-images* *current-image*) *pixel-size*)))
;;;
;;; SELF = mandel-window
;;; Fill a square of size SIZE at the point specified by (I, J).
;;; (I, J) is a pair of integer which specifies location RELATIVE
;;; in the canvas.
;;;
;;;
;;; Plot point (i, j)
;;;
;;;
;;; This would be a method in Schematic
;;;
(definep (plot-point self i j size)
;; this part is unncecessary if this is a class
(let ((cvs (vector-ref self 0))
(ll (vector-ref self 2))
(ur (vector-ref self 3))
(width (vector-ref self 4))
(height (vector-ref self 5)))
(let* ((m (calc-complex-coordinate-and-calc-mandel
i j (real-part ll) (imag-part ll)
(real-part ur) (imag-part ur) width height *max-iter*)))
(vector-ref *colors-vector*
(inexact->exact (/ m *colors-multiplier*))))))
;;;
;;;
;;;
(define-c-external (c-update-image-put-plane pointer int int int int int int
TSCP int int)
int "C_UpdateImagePutPlane")
;;;
;;; This procedure fills IM (image) according to the contents of COLORS
;;; VECTOR.
;;;
;;; COLORS is (NX-COLORS by NY-COLORS) vector
;;;
(define-in-line (fill-plane im x y dx dy nx ny colors nx-colors ny-colors)
(c-update-image-put-plane im x y dx dy nx ny colors nx-colors ny-colors))
;;;
;;; Fill N x M pixels plane by tiles each of which consists of
;;; SIZE x SIZE pixels. During drawing, we update the screen
;;; for every LINES-PER-UPDATE lines
;;;
(definep *vvvv* (make-vector (* 512 512) *black-color*))
(definep (plot-plane2 self n m size lines-per-update)
(let* ((vsize (* (inexact->exact (/ n size)) (inexact->exact (/ m size)))))
(let ((v *vvvv*)
(idx 0))
(do ((j 0 (+ j size)))
((>= j m))
(do ((i 0 (+ i size)))
((>= i n))
(vector-set! v idx (plot-point self i j size))
(set! idx (+ idx 1)))
;; Jth line has just been written. So we update line J - 3,
;; J - 2, J - 1, and J
(if (= 0 (modulo (+ j 1) lines-per-update))
(begin
(fill-plane (vector-ref self 0) 0 (- j (- lines-per-update 1))
size size n lines-per-update v n m)
(future (update))
(yield)))))))
;;;
;;;
;;;
(definep *lines-per-update* 4)
(definep (draw-mandel self size)
(let ((n (vector-ref self 4))
(m (vector-ref self 5)))
(plot-plane2 self n m size *lines-per-update*)))
;;;
;;; schematic-main
;;;
(definep (schematic-main args)
(if (= (length args) 3)
(begin (set! *pixel-size* (string->number (list-ref args 1)))
(set! *mozaic-size* (string->number (list-ref args 1)))))
(if (= (length args) 2)
(begin (set! *pixel-size* (string->number (list-ref args 1)))))
(Start 512 512)
;; blocks forever
(touch (make-future))
)