(define *WINDOW* #f)			; display window
(define *WINDOW-WIDTH* 500)		; pixels
(define *WINDOW-HEIGHT* 500)		; pixels

;;;---------------------------------------------------------------
;;; Display 

(define (OPEN-WINDOW size)
  (set! *window* (graphics-create *window-width* *window-height*))
  (graphics-set-coordinate-limits *window* 0 0 size size)
  )

(define (CLEAR-WINDOW)
  (graphics-clear *window*)
  (graphics-set-color *window* '(0 0 0)))
    
;;; pos-list = ((x y) (x y) ...)
(define (DISPLAY-POLYGON pos-list)
  (define (draw-polygon window posl)
    (for-each
     (lambda (v1 v2)
       (graphics-draw-line window (car v1) (cadr v1) (car v2) (cadr v2)))
     (cons (car (last posl)) 
	   (butlast posl))
     posl
     ))
  (draw-polygon *window* pos-list))

(define (DISPLAY-FILLED-CIRCLE x y radius)

  (define (circle-polygon n)
    (let* ((pi (atan 0 -1))
	   (step (/ pi n)))
      (do ((angle 0 (+ angle step))
	   (points '()))
	  ((>= angle (* 2 pi)) (apply append (reverse points)))
	(set! points (cons (list (+ x (* radius (cos angle))) 
				 (+ y (* radius (sin angle))))
			   points)))))
      
  (if (string-ci=? microcode-id/operating-system-name "nt")
      (graphics-operation *window* 'fill-polygon (list->vector (circle-polygon 20)))
      (if (string-ci=? microcode-id/operating-system-name "unix")
	  (graphics-operation *window* 'fill-circle x y radius)
	  (error "Unknown system")))
  )

(define (DISPLAY-ARROW start end size)
  ;; Draw shaft of arrow
  (graphics-draw-line *window* (car start) (cadr start) (car end) (cadr end))
  (let* ((d (* size 0.707))
	 (vect (v- end start))		; vector along shaft of arrow
	 (reverse (v* (- d) (vunit vect))) ; a delta of -d along shaft vector
	 (perp (v* d (vperp vect)))	; perp to shaft, length d
	 (right (v+ end (v+ reverse perp))) ; right of arrow head
	 (left (v+ end (v+ reverse (v* -1 perp)))) ; left of arrow head
	 )
    ;; Draw arrow head
    (graphics-draw-line *window* (car end) (cadr end) (car left) (cadr left))
    (graphics-draw-line *window* (car end) (cadr end) (car right) (cadr right))
    ))

(define (v+ x y) (map + x y))
(define (v- x y) (map - x y))
(define (v. x y) (apply + (map * x y)))
(define (vmag x) (v. x x))
(define (v* c x) (map (lambda (i) (* c i)) x))
(define (vunit x) (v* (/ 1.0 (sqrt (vmag x))) x))
(define (vperp x) 
  (let ((vu (vunit x))) (list (- (cadr vu)) (car vu))))


;;;---------------------------------------------------------------
;;; Graphics...

(define (graphics-set-color g c)
  (let ((color (if (string-ci=? microcode-id/operating-system-name "nt")
		   c
		   (rgb->x-string c))))
    (graphics-operation g 'set-foreground-color color)))

(define (rgb->x-string c)
  (list->string (cons #\# (append (int->hex-chars (first c)) 
				  (int->hex-chars (second c))
				  (int->hex-chars (third c))))))

(define (int->hex-chars i)
  (let ((hex-list '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 
                    #\8 #\9 #\A #\B #\C #\D #\E #\F)))
    (cons (list-ref hex-list (floor->exact (/ i 16)))
	  (list (list-ref hex-list (remainder i 16))))))

(define (int->list i)
  (let ((dec-list '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))
    (define (helper left)
      (if (= 0 left)
	  '()
	  (append (helper (floor->exact (/ left 10)))
		  (list (list-ref dec-list (remainder left 10))))))
    (let ((res (helper i)))
      (if (null? res)
	  '(#\0)
	  res))))

(define (graphics-create width height)
  (if (string-ci=? microcode-id/operating-system-name "nt")
      (make-graphics-device 'win32 width height 'standard)
      (if (string-ci=? microcode-id/operating-system-name "unix")
	  (make-graphics-device 
	   'x #f (list->string (append (int->list width) (list #\x) (int->list height))) #f)
	  (make-graphics-device #f))))