;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; SNAPL.SCM
; 1. DATA STRUCTURES
; 2. BASIC SNAPL COMMANDS
; 3. SNAPL UTILITIES
; 4. EXAMPLE   (look at this part)

;;;;;;;;;;;;;;;;;;
; 1. DATA STRUCTURES

(define pi 3.14159265358979323846264)

(define cls
  (lambda (env) (car env)))
(define x
  (lambda (env) (cadr env)))
(define y
  (lambda (env) (caddr env)))
(define dd
  (lambda (env) (cadddr env)))
(define dp
  (lambda (env) (car (cddddr env))))
(define theta
  (lambda (env) (cadr (cddddr env))))
(define move-env
  (lambda (x y env)
    (list (cls env) x y (dd env) (dp env) (theta env))))
(define turn-env
  (lambda (t env)
    (list (cls env) (x env) (y env)
          (dd env) (dp env)
          (+ (theta env)
             (atan (* (dp env) (sin t)) 
                   (* (dd env) (cos t)))))))

(define scale-env
  (lambda (sd sp env)
    (list (cls env) (x env) (y env)
          (* sd (dd env)) (* sp (dp env))
          (theta env))))

(define segment
  (lambda (cl x1 y1 dd dp theta)
    (if (< dd 0)
        (list cl x1 y1 (- dd) (- dp) (+ pi theta))
        (list cl x1 y1 dd dp theta))))

(define make-env
  (lambda (seg) seg))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 2. BASIC SNAPL COMMANDS.

(define mark
  (lambda (tail env rest)
    (let* ((cl (car tail))
           (d (eval (cadr tail)))
           (nx (+ (x env) 
                  (* d (dd env) (cos (theta env)))))
           (ny (+ (y env)
                  (* d (dd env) (sin (theta env))))))
      (cons
       (move-env nx ny env)
       (cons (segment cl (x env) (y env)
                      (* (dd env) d)
                      (* (dp env) d)
                      (theta env))
             rest)))))

(define skip
  (lambda (tail env rest)
    (let* ((d (eval (car tail)))
           (nx (+ (x env) 
                  (* d (dd env) (cos (theta env)))))
           (ny (+ (y env) 
                  (* d (dd env) (sin (theta env))))))
      (cons
       (move-env nx ny env)
       rest))))

(define turn
  (lambda (tail env rest)
    (cons
     (turn-env (eval (car tail)) env)
     rest)))

(define flip
  (lambda (tail env rest)
    (cons
     (scale-env 1 -1 env)
     rest)))

(define switch
  (lambda (tail env rest)
    (cond ((null? tail) (cons env rest))
          ((eq? (cls env) (caar tail))
           (snapl (cdar tail) env rest))
          (else
           (switch (cdr tail) env rest)))))

(define call
  (lambda (tail env rest)
    (snapl (eval (car tail)) env rest)))

(define snapl
  (lambda (exprlist env rest)
    (if (null? exprlist)
        (cons env rest)
        (let ((next ((eval (caar exprlist)) (cdar exprlist) env rest)))
          (snapl (cdr exprlist) (car next) (cdr next))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 3. SNAPL UTILITIES

(define snapl-transform
  (lambda (program segment rest)
    (cdr (snapl program (make-env segment) rest))))

(define snapl-edit
  (lambda (program segments)
    (if (null? segments)
        ()
        (snapl-transform program (car segments)
                         (snapl-edit program (cdr segments))))))

(define snapl-run
  (lambda (program)
    (snapl-edit
     program
     (list (segment 'init 0 0 100 100 0)))))

(define my-canvas%
  (class canvas%
    (inherit refresh)
    (inherit get-width)
    (inherit get-height)
    (public set-edges)
    (public get-edges)
    (public get-scale)
    (define edges ())
    (define scale 1.0)
    (define maxs (list 1 1))
    (define (set-edges stuff)
      (set! edges stuff)
      (set! maxs (get-max edges))
      (refresh))
    (define (get-edges) edges)
    (define (get-scale)
      (set! scale (* 0.5 (min (/ (get-width) (+ 50 (car maxs)))
                              (/ (get-height) (+ 50 (cadr maxs))))))
      scale)
    (super-instantiate ())))

(define my-pen (instantiate pen% ("BLACK" 2 'solid)))
(define no-brush (instantiate brush% ("BLACK" 'transparent)))

(define frame (instantiate frame% ("drawing example") 
                (width 300) (height 300)))
(define my-canvas
  (instantiate my-canvas% (frame)
    (paint-callback (lambda (canvas dc) 
                      (draw-edges canvas dc)))))

(define (draw-seg ox oy scale dc)
  (lambda (seg)
    (send dc draw-line
          (+ ox (* scale (x seg)))
          (+ oy (* scale (y seg)))
          (+ ox (* scale (+ (x seg) (* (dd seg) (cos (theta seg))))))
          (+ oy (* scale (+ (y seg) (* (dd seg) (sin (theta seg)))))))))

(define (get-max-helper mx my segs)
  (if (null? segs)
      (list mx my)
      (let* ((seg (car segs))
             (x1 (abs (x seg)))
             (y1 (abs (y seg)))
             (x2 (abs (+ (x seg) (* (dd seg) (cos (theta seg))))))
             (y2 (abs (+ (y seg) (* (dd seg) (sin (theta seg)))))))
        (get-max-helper
         (cond ((and (> x1 mx) (> x1 x2)) x1)
               ((> x2 mx) x2)
               (else mx))
         (cond ((and (> y1 my) (> y1 y2)) y1)
               ((> y2 my) y2)
               (else my))
         (cdr segs)))))

(define (get-max segs)
  (get-max-helper 0 0 segs))

(define (app f l)
  (if (not (null? l))
      (begin
        (f (car l))
        (app f (cdr l)))))

(define (draw-edges canvas dc)
  (send dc set-pen my-pen)
  (send dc set-brush no-brush)
  (app (draw-seg
        (/ (send canvas get-width) 2)
        (/ (send canvas get-height) 2)
        (send canvas get-scale)
        dc)
       (send canvas get-edges)))
 
(send frame show #t)

(define (snapl-show x)
  (send my-canvas set-edges x)
  (send frame show #t))

;;;;;;;;;;;;;;;;;;;;;;;
; 4. EXAMPLE

; put 60 degrees in a defined variable
(define angle60 (/ pi 3))

(define triangle
  '((turn (- angle60))
    (mark edge 1)
    (turn (* 2 angle60))
    (mark edge 1)
    (turn (* 2 angle60))
    (mark edge 1)))

(define breakup
  '((mark edge (/ 2 5))
    (skip (/ 1 5))
    (mark edge (/ 2 5))))

; Draw the triangle
(snapl-show (snapl-run triangle))