;;; -*- Mode:LISP; Package:(CALC USE (LISP)); Readtable:CL; Base:10 -*-


(defun get-points ()
  (do ()
      ((not (zerop (tv:mouse-buttons)))))
  (do ((mx tv:mouse-x)
       (my tv:mouse-y)
       (points '()))
      (())
    (tv:prepare-sheet (tv:main-screen)
      (do () ((zerop (tv:mouse-buttons)))
	(when (or (/= tv:mouse-x mx)
		  (/= tv:mouse-y my))
	  (push (cons mx my) points)
	  (si:%draw-line mx my (setq mx tv:mouse-x) (setq my tv:mouse-y)
			 tv:alu-ior nil tv:main-screen))))
    (do ((time-out (+ 60 (si:time))))
	((not (zerop (tv:mouse-buttons))))
      (if (> (si:time) time-out) (return-from get-points points))
      (setq mx tv:mouse-x
	    my tv:mouse-y)))))


(defun reduce-points (points)
  (let ((top 10000)
	(bottom 0)
	(left 10000)
	(right 0))
    (dolist (pt points)
      (let ((px (car pt))
	    (py (cdr pt)))
	(if (< px left) (setq left px))
	(if (> px right) (setq right px))
	(if (< py top) (setq top py))
	(if (> py bottom) (setq bottom py))))
;    (format t "~%t:~a  b:~a  l:~a  r:~a" top bottom left right)
    (let ((height  (- bottom top))
	  (width  (- right left)))
;      (format t "~%h:~a  w:~a" height width)
;    (zl:send tv:main-screen :draw-rectangle
;	    height width left top tv:alu-xor))
   
      (let ((cell-height (1+ (truncate height 3)))
	    (cell-width (1+ (truncate width 3))))
	(let ((last-cell 10.)
	      (reduced-points '()))
	  (dolist (pt points)
	    (let ((cell (+ (truncate (- (car pt) left)  cell-width)  ;x
		           (* 3 (truncate (- (cdr pt) top) cell-height)))))
	      (when (/= cell last-cell)
		(push cell reduced-points)
		(setq last-cell cell))))
	  reduced-points)))))
		  

(defvar *dictionary* (make-array 10.))

(defun lookup-entry (path &optional (tree *dictionary*))
  (do ((entry))
      ((null path)
       (values (aref tree 9.) tree path))
    (setq entry (aref tree (car path)))
    (when (null entry)
      (return (values entry tree path)))
    (pop path)
    (setq tree entry)))


(defun set-entry (path tree new-entry)
  (do ()
      ((null path)
       (setf (aref tree 9.) new-entry))
    (setq tree
	  (setf (aref tree (pop path))
		(make-array 10.)))))
    
    

(defun learn-entry (path)
  (multiple-value-bind (entry tree path)
      (lookup-entry path)
    (unless (y-or-n-p "~%It's a ~a, OK?" entry)
      (let ((new-entry (progn (format t "~%What is it? ")
			      (read))))
	(set-entry path tree new-entry)))))
	
      
(defun learn ()
  (do () (())
    (learn-entry (reduce-points (get-points)))))
  
(defun print-tree (&optional (tree *dictionary*) (stream t))
  (if (arrayp tree)
      (progn
	(format stream "#(")
	(dotimes (i 10.)
	  (print-tree (aref tree i) stream)
	  (format stream " "))
	(format stream ")"))
    (princ tree)))








(defvar *characters*
	'(
	  (1 . ((8 . 0) (7 . 15)))
	  (2 . ((0 . 0) (15 . 0) (15 . 8) (0 . 8) (0 . 15) (15 . 15)))
	  (3 . ((0 . 0) (15 . 0) (15 . 8) (0 . 8) (15 . 8) (15 . 15) (0 . 15)))
	  (4 . ((2 . 0) (0 . 8) (15 . 8) (12 . 8) (12 . 0) (12 . 15)))))


(defun draw-character (char w h x y &optional (sheet tv:main-screen))
  (draw-path (cdr (assoc char *characters*))
	     w h x y sheet))



(defun draw-path (points w h x y &optional (sheet tv:main-screen))
  (let ((x-step (/ w 16.0s0))
	(y-step (/ h 16.0s0)))
    (tv:prepare-sheet (sheet)
      (do ((pts (cddr points) (cdr pts))
	   (from (car points) to)
	   (to   (cadr points) (car pts)))
	  ((null pts)
	   (let ((from-x (+ x (truncate (* x-step (car from)))))
		 (from-y (+ y (truncate (* y-step (cdr from)))))
		 (to-x   (+ x (truncate (* x-step (car to)))))
		 (to-y   (+ y (truncate (* y-step (cdr to))))))
	     (tv:%draw-line from-x from-y to-x to-y tv:alu-ior t sheet)))
	(let ((from-x (+ x (truncate (* x-step (car from)))))
	      (from-y (+ y (truncate (* y-step (cdr from)))))
	      (to-x   (+ x (truncate (* x-step (car to)))))
	      (to-y   (+ y (truncate (* y-step (cdr to))))))
	  (tv:%draw-line from-x from-y to-x to-y tv:alu-ior nil sheet))))))