(load "smm.ss")

(extend-syntax (class)
  [(class parameter-list
          ([var val] ...)
          super-expr
          ([method-name method-expr] ...)
          init ...)
   (lambda parameter-list
     (letrec ([var val] ...)
       (let* ([super super-expr]
              [this (append (list (cons 'method-name method-expr) ...)
                            super)])
           init ...
           this)))])


; From rhys' file
; ****** globals needed to set up TCL process and pipes
(define wish 'notyet)
(define from-wish 'notyet)   ; used for error messages from tcl
                             ; type (error-msg) to read
(define to-wish 'notyet)
(define wish-pid 'notyet)    ; not used but available
; *****************************************************
 
; ****** set up the canvas

(define init-graphics
  (case-lambda 
   (() (init-graphics 15 15 "Scheme Graphics"))
   ((x y) (init-graphics x y "Scheme Graphics"))
   ((x y name)
    (set! wish (process "wish"))
    (set! from-wish (car wish))  
    (set! to-wish (cadr wish))
    (set! wish-pid (caddr wish)) 
    ; (fprintf to-wish "tk_setPalette bisque~%")
    (fprintf to-wish "wm title . ~s~%" name)
    (fprintf to-wish "scrollbar .scroll -command ~s~%" ".chezcanvas yview")
    (fprintf to-wish 
             "scrollbar .xscroll -orient horizontal -command ~s~%" 
             ".chezcanvas xview")
    (fprintf to-wish 
             "canvas .chezcanvas -width ~sc -height ~sc -yscrollcommand ~s -xscrollcommand ~s~%"
             x y ".scroll set" ".xscroll set")
    (fprintf to-wish "pack .chezcanvas~%")
    (fprintf to-wish "pack .scroll -side right -fill y~%")
    (fprintf to-wish "pack .xscroll -side bottom -fill x~%"))))

; to make a postscript printable file of the canvas:
(define print-graphics  ; doesn't work
  (lambda (filename)
    (fprintf to-wish ".chezcanvas postscript -file ~c~%" filename)))

; and when we're done:
(define end-graphics 
  (lambda ()
    (fprintf to-wish "destroy .~%")))

; ************************************************************************

(define newsymbol
  (let ((count 0))
    (lambda ()
      (set! count (+ 1 count))
      (string->symbol (format "o~s" count)))))

(define wait
  (lambda (milliseconds)
    (fprintf to-wish "update idletasks~%")
    (fprintf to-wish "after ~s~%" milliseconds)))

; for animating colors
; 13x98 -- broken (RPJ)
;(define sleep
;    (foreign-procedure "sleep" (unsigned-32) unsigned-32))

; ************************************************************************


(define Shape
  (class ()
    ([name (newsymbol)]
     [base-color 0]
     [print-args
      (lambda (args)
        (for-each (lambda (i)
                    (cond
                     [(number? i) (fprintf to-wish "~sc " i)]
                     [(string? i) (fprintf to-wish i)(fprintf to-wish " ")]
                     [else (fprintf to-wish "~s " i)]))
                  args))])
    (Object)
    ([configure
      (method props
        (fprintf to-wish ".chezcanvas itemconfigure $~s -"name)
        (print-args props)
        (newline to-wish))]
     [create
      (method (shape values)
          (fprintf to-wish "set ~s [.chezcanvas create ~s " name shape)
          (print-args values)    
          (fprintf to-wish "]~%"))]
     [move
      (method (x y)
        (fprintf to-wish ".chezcanvas move $~s ~sc ~sc~%"
                 name (exact->inexact x) (exact->inexact y)))]
     [anchor
      (method (value)
         (call configure this 'anchor value))]
     [animate-hsv
      (method (steps)
        (let loop ((i 0))
          (when ( i steps)
                (wait 200)
                (call color this
                      (hsv-xcolor (exact->inexact (/ i steps)) 1.0 1.0))
                (loop (1+ i)))))]
     [color ; default fill color
      (method (value)
        (call configure this 'fill value))]  
     [delete (method ()
                     (fprintf to-wish ".chezcanvas delete $~s~%" name))])))

(define Text
  (class (x y string)
    ()
    (Shape)
    ([draw
      (method ()
        (call create super 'text
              (list x y (format "-text ~s -anchor sw" string))))]
     [font
      (method (value)
        (call configure super 'font value))]
     [justify
      (method (value) ;left, right, center
        (call configure super 'justify value))])))

(define Poly-line
  (class points
    ()
    (Shape)
    ([draw
      (method ()
        (call create super 'line points))]
     [smooth
      (method (yn)
        (call configure super 'smooth (if yn "on" "off")))]
     [splinesteps
      (method (value)
        (call configure super 'splinesteps value))]
     [joinstyle
      (method (value)
        (call configure super 'joinstyle value))]
     [arrow
      (method (yn)
        (call configure super 'arrow (if yn "last" "none")))]
     [width
      (method (value)
        (call configure super 'width value))])))

(define Line
  (class (x1 y1 x2 y2)
    ()
    (Poly-line x1 y1 x2 y2)
    ()))

(define Filled-shape
  (class ()
    ()
    (Shape)
    ([width
      (method (value)
              (call configure super 'width (exact->inexact value)))])))


(define Polygon
  (class points
    ()
    (Filled-shape)
    ([draw (method ()
                   (call create super 'polygon points))])))

(define Red-square
  (class (left top size)
    ()
    (Polygon left top left (+ top size) (+ left size) (+ top size) 
               (+ left size) top)
    ([draw
      (method ()
        (call draw super)
        (call color super 'red))])))


;******************************************************************

(define hsv->xcolor
  (lambda l
    (let ((hue (* 6.0 (car l)))
          (sat (cadr l))
          (val (caddr l))
          (rgb->xcolor
           (lambda l
             (string-append
              "#"
              (apply string-append 
                     (map (lambda (i)
                            (number->string
                             (inexact->exact (floor (* 65535.0 i)))
                             16))
                          l))))))
      (if (= sat 0) ; if gray
          (rgb->xcolor val val val)
          (let* ((i (inexact->exact (floor hue)))
                (frac (- hue i))
                (p (* val (- 1.0 sat)))
                (q (* val (- 1.0 (* sat frac))))
                (t (* val (- 1.0 (* sat (- 1.0 frac))))))
            (case i
              (0 (rgb->xcolor val t p))
              (1 (rgb->xcolor q val p))
              (2 (rgb->xcolor p val t))
              (3 (rgb->xcolor p q val))
              (4 (rgb->xcolor t p val))
              (5 (rgb->xcolor val p q))
              (else "error")))))))