;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; NAME: graphics-lib.scm
;;
;; DESCRIPTION: 2D Graphic Library Routines (with stk animation support)
;;
;; AUTHOR: Dan Garcia - University of California at Berkeley
;; Copyright (C) Dan Garcia, 2001. All rights reserved.
;;
;; DATE: 2001-09-21
;;
;; UPDATE HIST:
;;
;; 2001-11-12: Changed length to lengthP so as not to clobber original
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATATYPE: POINT (P)
;; Constructors: mP "make new Point P"
;; Selectors: x "get x-coord from P"
;; y "get y-coord from P"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (x P) (car P))
(define (y P) (cadr P))
(define (mP x y) (list x y))
;;;;;;;;;;;;
;; CONSTANTS
;;;;;;;;;;;;
;; stk-specific numbers
(define *stk* (not (number? '1/999))) ;; stk returns #f, macgambit returns #t
(define *stk-fullpage* #f)
;; Window borders
(define *L* -200)
(define *R* 200)
(define *D* -200)
(define *U* 200)
(if *stk-fullpage* ;; STK-specific fullpage graphics
(begin
(eval '(define *L* (/ 612 -2)))
(eval '(define *D* (/ 792 -2)))
(eval '(define *U* (/ 612 2)))
(eval '(define *R* (/ 792 2)))
))
;; Window borders (in P format)
(define *NW* (mP *L* *U*))
(define *N* (mP 0 *U*))
(define *NE* (mP *R* *U*))
(define *W* (mP *L* 0 ))
(define *C* (mP 0 0 ))
(define *E* (mP *R* 0 ))
(define *SW* (mP *L* *D*))
(define *S* (mP 0 *D*))
(define *SE* (mP *R* *D*))
;; Window widths and height and largest radius circle
;; based at the origin
(define *Width* (- *R* *L*))
(define *Height* (- *U* *D*))
(define *Half-Height* (/ *Height* 2))
(define *Half-Width* (/ *Width* 2))
(define *Radius* (min *Half-Height* *Half-Width*))
;; For animating fractals
(define *unit-step* 1)
(define *penX* 0)
(define *penY* 0)
;; Numerical constants we'll use often
(define *sqrt3* (sqrt 3))
(define *sqrt3/2* (/ *sqrt3* 2))
(define *PI* 3.14159265)
;;;;;;;;;;;;;;;;
;; position-penP
;; Input: P [P] "Starting point"
;; Side-Effect: Position pen at point P
;;;;;;;;;;;;;;;;
(define (position-penP P)
(if *stk*
(begin
(set! *penX* (x P))
(set! *penY* (y P)))
(position-pen (x P) (y P))))
;;;;;;;;;;;;;
;; draw-lineP
;; Input: P1 [P] "Starting point"; P2 [P] "Ending point"
;; Side-Effect: Draw line from P1 to P2
;;;;;;;;;;;;;
(define (draw-lineP P1 P2)
(if *stk*
(begin
(.c 'create 'line
(+ *Half-Width* (x P1)) (- (* 1 *Half-Height*) (y P1))
(+ *Half-Width* (x P2)) (- (* 1 *Half-Height*) (y P2))
'-tag 'lines)
(set! *penX* (x P2))
(set! *penY* (y P2)))
(begin
(position-penP P1)
(draw-line-toP P2))))
;;;;;;;;;;;;;;;;
;; draw-line-toP
;; Input: P [P] "Ending point"
;; Side-Effect: Draw line from current-pen to P
;;;;;;;;;;;;;;;;
(define (draw-line-toP P)
(if *stk*
(begin
(.c 'create 'line
(+ *Half-Width* *penX*) (- (* 1 *Half-Height*) *penY*)
(+ *Half-Width* (x P)) (- (* 1 *Half-Height*) (y P))
'-tag 'lines)
(set! *penX* (x P))
(set! *penY* (y P)))
(draw-line-to (x P) (y P))))
;;;;;;;;;;;;;;;;
;; draw-poly-lineP
;; Input: allPs [list-of-P] "List of points"
;; Side-Effect: Draw poly-line from first point thru last point
;;;;;;;;;;;;;;;;
(define (draw-poly-lineP . allPs)
(define (helper Ps)
(if (null? Ps)
'done
(begin
(draw-line-toP (car Ps))
(helper (cdr Ps)))))
(position-penP (car allPs))
(helper (cdr allPs)))
;;;;;;;
;; negP
;; Input: P [P] "point"
;; Returns: Point which is the negation of P, i.e., -P
;;;;;;;
(define (negP P)
(mP (- (x P))
(- (y P))))
;;;;;;;
;; addP
;; Input: P1 [P] "first point"; P2 [P] "second point"
;; Returns: Point sum of P1 and P2, i.e., P1+P2
;;;;;;;
(define (addP P1 P2)
(mP (+ (x P1) (x P2))
(+ (y P1) (y P2))))
;;;;;;;
;; subP
;; Input: P1 [P] "first point"; P2 [P] "second point"
;; Returns: Point difference of P1 and P2, i.e., P1-P2
;;;;;;;
(define (subP P1 P2)
(addP P1 (negP P2)))
;;;;;;;;;
;; scaleP
;; Input: c [int] "scale factor"; P [P] "point"
;; Returns: Point which is scale of P by c
;;;;;;;;;
(define (scaleP c P)
(mP (* c (x P))
(* c (y P))))
;;;;;;;
;; avgP
;; Input: P1 [P] "first point"; P2 [P] "second point"
;; Returns: Point which is average of P1 and P2
;;;;;;;
(define (avgP P1 P2)
(scaleP 1/2 (addP P1 P2)))
;;;;;;;;;;
;; rot-90P
;; Input: P [P] "point"
;; Returns: Point which is P rotated about origin by 90 degrees
;;;;;;;;;;
(define (rot-90P P)
(mP (y P)
(- (x P))))
;;;;;;;;
;; coord
;; Input: P00 [P] "point simulating origin"
;; P01 [P] "point simulating the point [0,1]"
;; v [V] "Vector input"
;; Returns: Point which is the result of thinking of v
;; in the new coordinate system defined by P00
;; as the origin and P01 as 1 unit up the y axis
;;
;; This is a VERY powerful function, allowing you to
;; define new points with almost no need for any
;; standard graphics geometry (dot product, etc)
;;
;; Example: (avgP P1 P2) == (coord P1 P2 (mP 0 .5))
;;;;;;;;
(define (coord P00 P01 v)
(let* ((vY (subP P01 P00))
(vX (rot-90P vY)))
(addP P00
(addP (scaleP (x v) vX)
(scaleP (y v) vY)))))
;;;;;;;;;;
;; lin-interp
;; Input: x0 [float] "starting value"
;; x1 [float] "ending value"
;; t [int] "parameter"
;; Returns: Value (scalar) which is a linear combination of
;; x0 and x1 using the standard formula:
;; x(t) = x0 (1-t) + x1 (t)
;; I.e., x(0) = x0, x(1) = x1, x(1/2)=(x0+x1)/2
;;
;; This is a VERY powerful function, allowing you to
;; linearly interpolate between values x0 and x1
;; for animation.
;;
;; Example: (/ (+ x0 x1) 2) == (lin-interpP x0 x1 1/2)
;;;;;;;;
(define (lin-interp x0 x1 t)
(+ (* (- 1 t) x0)
(* t x1)))
;;;;;;;;;;
;; lin-interpP
;; Input: P0 [P] "starting point"
;; P1 [P] "ending point"
;; t [int] "parameter"
;; Returns: Point which is a linear combination of
;; P0 and P1 using the standard formula:
;; P(t) = P0 (1-t) + P1 (t)
;; I.e., P(0) = P0, P(1) = P1, P(1/2)=(P0+P1)/2
;;
;; This is a VERY powerful function, allowing you to
;; linearly interpolate between points P0 and P1
;; for animation.
;;
;; Example: (avgP P0 P1) == (lin-interpP P0 P1 1/2)
;;;;;;;;
(define (lin-interpP P0 P1 t)
(addP (scaleP (- 1 t) P0)
(scaleP t P1)))
;;;;;;;;;
;; square
;; Input: n [int] "number"
;; Returns: number squared
;;;;;;;;;
(define (square n) (* n n))
;;;;;;;;;
;; lengthP
;; Input: P1 [P] "first point"; P2 [P] "second point"
;; Returns: distance from P1 to P2
;;;;;;;;;
(define (lengthP P1 P2) ;; ddg 2001-11-12 changed name to lengthP
(let ((v (subP P2 P1))) ;; so as not to clobber original length!
(sqrt (+ (square (x v))
(square (y v))))))
;;;;;;;;;
;; orthog-length
;; Input: P1 [P] "first point"; P2 [P] "second point"
;; Returns: orthogonal length of P1 to P2
;;;;;;;;;
(define (orthog-length P1 P2)
(let ((v (subP P2 P1)))
(max (abs (x v)) (abs (y v)))))
;;;;;;;;;;;;;;;
;; draw-squareP
;; Input: C [P] "center"; r [int] "radius"
;; Side-Effect: Draw square of radius r centered at C
;;;;;;;;;;;;;;;
(define (draw-squareP C r)
(draw-poly-lineP (mP (- (x C) r) (- (y C) r))
(mP (+ (x C) r) (- (y C) r))
(mP (+ (x C) r) (+ (y C) r))
(mP (- (x C) r) (+ (y C) r))
(mP (- (x C) r) (- (y C) r))))
;;;;;;;;;;;;
;; draw-arcP
;; Input: C [P] "center"; P [P] "edge point";
;; degrees [int] "degrees of arc"; sides [int] "arc samples"
;; Side-Effect: Draw arc centered at C starting at P with angle = degrees
;;;;;;;;;;;;
(define (draw-arcP C P degrees sides)
(position-penP P)
(let ((tincr (/ (* degrees (/ *PI* 180)) sides)))
(define (draw-arc-lines seg t)
(if (= seg 0)
'done
(begin
(draw-line-toP (coord C P (mP (- (sin t)) (cos t))))
(draw-arc-lines (- seg 1) (+ t tincr)))))
(draw-arc-lines sides tincr)))
;;;;;;;;;;;;;;;
;; grow-fractal
;; Input: draw-proc [lambda] "proc takes n, draws fractal at level n"
;; step [float] "increment to add to level at each iteration"
;; max-level [int] "max level to draw fractal (assume start at 0)
;; Side-Effect: Draw fractal at level i from i = 1 to n
;;;;;;;;;;;;;;;
(define (grow-fractal draw-proc step max-level filename animate?)
(let ((max-frame (bl (bl (truncate (/ (+ max-level 1.0) step))))))
(define (grow-fractal-helper draw-proc i frame)
(if (> i max-level)
'done
(begin
(if (and (empty? filename) (not animate?))
(begin
(display `(Hit enter to display frame ,i of ,max-level))
(read)))
(if *stk*
(update 'idletasks))
(clear-graphics)
(draw-proc i)
(if (and *stk* (not (empty? filename)))
(dump-frame filename frame max-frame))
(if (and (not *stk*) (not animate?))
(graphics-text (word "Iteration: " i " / " max-level)
(+ *L* 10) (- *U* 20)))
(grow-fractal-helper draw-proc (+ step i) (+ frame 1)))))
(grow-fractal-helper draw-proc 0 1)))
;;;;;;;;;;;;;;;
;; animate-fractal
;; Input: draw-proc [lambda] "proc takes n, draws fractal at level n"
;; step [float] "increment to add to level at each iteration"
;; max-level [int] "max level to draw fractal (assume start at 0)
;; Side-Effect: Draw fractal at level i from i = 1 to n
;;;;;;;;;;;;;;;
(define (animate-fractal draw-proc step max-level)
(grow-fractal draw-proc step max-level "" #t))
;;;;;;;;;;;;;;;
;; dump-frame
;; Input: filename [word] "root file to write frame into WITHOUT extension"
;; frame [int] "frame (number from 1 to N) number"
;; max-frame [int] "max frame for number padding"
;; Side-Effect: Dump the current graphic frame to <filename>.gif
;;;;;;;;;;;;;;;
(define (dump-frame filename frame max-frame)
;; Dump frame to ps
(.c 'postscript '-file
(word filename (pad frame max-frame) ".ps"))
;; Convert to pnm
(system (word "echo \"\" | gs -sDEVICE=pnm -sOutputFile="
(word filename (pad frame max-frame) ".pnm ")
(word filename (pad frame max-frame) ".ps")))
;; Convert to gif
(system (word "cat "
(word filename (pad frame max-frame) ".pnm ")
"| pnmcut 106 196 400 400 | ppmtogif > "
(word filename (pad frame max-frame) ".gif")))
;; Remove the temp ps file
(system (word "rm " (word filename (pad frame max-frame) ".ps")))
;; Remove the temp pnm file
(system (word "rm " (word filename (pad frame max-frame) ".pnm"))))
;;;;;;;;;
;; pad
;; Input: n [int] "frame number"; biggest-n "largest frame number"
;; Returns: Number with the appropriate number of leading zeros added
;; such that the frames are numbered 00...001 through biggest-n
;;;;;;;;;
(define (pad n biggest-n)
(let ((n-count (count n))
(biggest-n-count (count biggest-n)))
(if (>= n-count biggest-n-count)
n
((repeated (lambda (m) (word 0 m))
(- biggest-n-count n-count)) n))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; DESCRIPTION: stk-specific 2D Graphic Library routines.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cond (*stk*
;; Create a canvas and show it
(canvas '.c '-height *height* '-width *width*)
(pack '.c)
;; Reset clear-graphics
(eval '(define clear-graphics
(lambda () (.c 'delete '-withtag 'lines))))
'done-loading-stk-specific-graphics-lib)
(else
'done-loading-graphics-lib))