;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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))