(declare (usual-integrations))

(define *window-width* 170)
(define *window-height* 150)
(define *max-x* 4.0)
(define *min-x* -4.0)
(define *max-y* 4.0)
(define *min-y* -4.0)
(define *window* #f)
(define *pixel-double* #t)
(define *show-progress* #t)		; show progress of display?

;; for 2 inputs, 1 output!
;; Displays the classifier encoded by the function get-point which
;; is given two numbers x and y, in the range [min-x max-x] [min-y max-y]
;; returns a value in the range 0 to 1.
;; Training is a list of training points, which may be null.
(define (draw-classifier get-point training . graphics)
  (begin
    (display* "Drawing classifier...")
    (let* ((step-x (/ (- *max-x* *min-x*) *window-width*))
	   (step-y (/ (- *max-y* *min-y*) *window-height*))
	   (step-x-half (/ step-x 2))
	   (step-y-half (/ step-y 2))
	   (g (if (not (null? graphics))
		  (car graphics)
		  (begin
		    (let ((gtmp (if *pixel-double*
				    (graphics-create (* 2 *window-width*)
						     (* 2 *window-height*))
				    (graphics-create *window-width*
						     *window-height*))))
		      (if *window*
			  (graphics-close *window*))
		      (set! *window* gtmp)
		      (if *pixel-double*
			  (graphics-operation gtmp 'resize-window (* 2 *window-width*) (* 2 *window-height*))
			  (graphics-operation gtmp 'resize-window *window-width* *window-height*))
		      (graphics-set-coordinate-limits gtmp *min-x* *min-y* *max-x* *max-y*)
		      (graphics-enable-buffering gtmp)
		      (graphics-clear gtmp)
		      gtmp)))))
      (do ((y *min-y* (+ y step-y))
	   (lines 0 (+ lines 1)))
	  ((> lines *window-height*)
	   (if *show-progress* (graphics-flush g))
	   'ok)
	(if (and *show-progress* (zero? (remainder lines 10))) 
	    (graphics-flush g))
	(do ((x *min-x* (+ x step-x))
	     (cols 0 (+ cols 1)))
	    ((> cols *window-width*)
	     'ok)
	  (let* ((val (get-point x y))	; the value of the classifier in the range 0 to 1
		 (color (list (round->exact (* val 255))
			      0
			      (round->exact (* (- 1.0 val) 255)))))
	    (graphics-set-color g color)
	    (graphics-draw-point g x y)
	    (if *pixel-double*
		(begin (graphics-draw-point g (+ x step-x-half) y)
		       (graphics-draw-point g (+ x step-x-half) (+ y step-y-half))
		       (graphics-draw-point g x (+ y step-y-half)))))))
      (draw-axes g 1.0 1.0)
      ;; Draw training data, if given
      (for-each (lambda (s)
		  (let* ((features (cdr s)) ; the features without filtering
			 (x (first features))
			 (y (second features))
			 (out (data-point-class s)))
		    (if (> out 0.5)
			(graphics-set-color g '(255 255 255))
			(graphics-set-color g '(0 0 0)))
		    (graphics-draw-point g x y)
		    (if *pixel-double*
			(begin (graphics-draw-point g (+ x step-x-half) y)
			       (graphics-draw-point g (+ x step-x-half) (+ y step-y-half))
			       (graphics-draw-point g x (+ y step-y-half))
			       (graphics-draw-point g (- x step-x-half) y)
			       (graphics-draw-point g (- x step-x-half) (+ y step-y-half))
			       (graphics-draw-point g (+ x step-x) y)
			       (graphics-draw-point g (+ x step-x) (+ y step-y-half))
			       (graphics-draw-point g x (- y step-y-half))
			       (graphics-draw-point g (+ x step-x-half) (- y step-y-half))
			       (graphics-draw-point g x (+ y step-y))
			       (graphics-draw-point g (+ x step-x-half) (+ y step-y))
			       ))))
		training)
      (graphics-flush g)
      'ok
      )))

;;; Interface to the different types of classifiers
			   
;; The neural net get-point function
(define (neural-get-point x1 x2)
  (let ((in (data-point-features (make-data-point '() (list x1 x2)))))
    ;;(display* "Trying with input " in " ...")
    (let ((out (make-neural-prediction in)))
      ;;(display* "Output is " out ".")
      out)))

;; The id-tree net get-point function
(define (id-get-point x1 x2)
  (let ((in (data-point-features (make-data-point '() (list x1 x2)))))
    ;;(display* "Trying with input " in " ...")
    (let ((out (make-id-prediction in)))
      ;;(display* "Output is " out ".")
      (if (equal? *id-class0* out)
	  0 1) )))

;; The nearest-neighbor net get-point function
(define (nn-get-point x1 x2)
  (let* ((in (data-point-features (make-data-point '() (list x1 x2))))
	 (out (make-nn-prediction in)))
    (if (eq? *nn-class0* out)
	0 1)))

;; The svm get-point function
(define (svm-get-point x1 x2)
  (let ((in (data-point-features (make-data-point '() (list x1 x2)))))
    ;;(display* "Trying with input " in " ...")
    (let ((out (make-svm-prediction in)))
      ;;(display* "Output is " out ".")
      ;; map into a [0,1] range, with 0->0.5, -1->0, 1->0
      (max 0 (min 1 (+ 0.5 (* 0.5 out)))))))

(define (draw-axes g unit-x unit-y)
  (let ((small-x (* 3.0 (/ (- *max-x* *min-x*) *window-width*)))
	(small-y (* 3.0 (/ (- *max-y* *min-y*) *window-height*)))
	(y-limit (max (abs *max-y*) (abs *min-y*)))
	(x-limit (max (abs *max-x*) (abs *min-x*))))
    (graphics-set-color g '(0 0 0))
    (graphics-draw-line g 0 *min-y* 0 *max-y*)
    (graphics-draw-line g *min-x* 0 *max-x* 0)
    (do ((y unit-y (+ y unit-y)))
	((> y y-limit)
	 'ok)
      (graphics-draw-line g (- small-x) y small-x y)
      (graphics-draw-line g (- small-x) (- y) small-x (- y)))
    (do ((x unit-x (+ x unit-x)))
	((> x x-limit)
	 'ok)
      (graphics-draw-line g x (- small-y) x small-y)
      (graphics-draw-line g (- x) (- small-y) (- x) small-y))
    (graphics-flush g)))


(define (graphics-set-color g c)
  (let ((color (if (string=? 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=? microcode-id/operating-system-name "nt")
      (make-graphics-device 'win32 width height 'standard)
      (if (string=? 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))))