;; a demonstration using rdnzl to collect ink on a Windows XP system
;; running tablet PC SDK. The application can be run by 
;; (mjnetrs)
;; in which case it opens a small window. You draw on the window.
;; then exit the window.

;; Richard Fateman, with help from David Poll  Oct 6, 2006.

(eval-when (compile eval load)
   (load "c:/lisp/rdnzl-0.10.6/load.lisp")

   (declaim (special window ink-overlay ink-collector all-strokes all-points))
  (use-package :rdnzl)
  (use-package :common-lisp-user))

;;(defpackage :mjnet (:use :rdnzl :cl :cl-user))
;;(in-package :mjnet) ;; mj = Mike Jurka, former student.

(enable-rdnzl-syntax)
(import-types "Microsoft.Ink" "InkOverlay" "InkCollectorStrokeEventHandler" "InkCollector")
(import-types "System.Windows.Forms" "Form" "Application" "MessageBox" "MainMenu" "MenuItem")
(import-type "System.Threading.Thread")
(import-type "System.Threading.ThreadStart")

;; bug in RDNZL .. doesn't allow this below instead of 2 lines above.
;;(import-types "System.Threading" "Thread" "ThreadStart")

(use-namespace "Microsoft.Ink")
(use-namespace "System.Windows.Forms")
(use-namespace "System.Threading")



;; prototype for creating a thread
(defun create-thread(fun)		;function of no arguments, call as (create-thread #'thefun)
  ;; return a .NET thread
  (new "Thread" (new "ThreadStart" fun)))

(defun start (thethread)		;
  [Start thethread])

(defun run-thread(fun) ; all together
  (start (create-thread fun)))
  
(defparameter all-strokes nil)		; A stack that will hold all strokes
(defparameter all-points nil) ; A stack that will hold all strokes as lists of xy points

(defun handle-stroke (&rest args)  ;; should be 2 args: object event
  (print "stroke event")
  (push args  all-strokes) 
  ;;WHAT WE DO HERE TO EXTRACT INK AND PROCESS IT
  ;; we could just wait until later to decode this, e.g. 
  ;; (mapcar #'(lambda(r)(decode-stroke-to-points (cadr r)))all-strokes)
 (push (decode-stroke-to-points (cadr args))all-points) ;; just the second arg matters here
 )

(defun decode-stroke-to-points (container)
 (let ((netarray
	(invoke  (property container "Stroke") "GetPoints") ) ;; get array of points
       (list-of-points nil))
   (do-rdnzl-array (v netarray (nreverse list-of-points))
     (push (cons  (property v "X")(property v "Y")) list-of-points))))

;; Really, we could save up the containers and look at the points only when
;; we cared to do so. Or we could just alias the array of points to
;; an array in lisp. (in Allegro, an ole:safearray, I think.)

;; mjnetrs  Reads Strokes via .NET.  It opens up a window, allows
;; the user to write any number of strokes on it.
;; The strokes are stored as the value of the global variable all-strokes.
;; The strokes are also stored as lists of xy points in the global variable all-points.
;; As written, the lisp system does not get control of the processing until
;; the window is killed (by clicking on [x]).
;; A more useful program would take the strokes and do something with them and
;; leave the window up.

(defun mjnetrs()  ;; read strokes
  (let ((ink-collector (new "InkCollector")) 
	(window (new "Form"))
	(menu (new "MainMenu")))
    (setf [%Menu window] menu)  ;for fun, create a menu
    [Add [%MenuItems menu] (new "MenuItem" "Hello")] ;put a menu item in there
    ;; in lisp we could do the same as above by..
    ;;    (setf (property window "Menu") menu)
    ;;    (invoke (property menu "MenuItems") "Add" (new "MenuItem" "Hello"))

    (setf [%Enabled ink-collector] nil)
    [CreateControl window]
    (setf [%Handle ink-collector] [%Handle window])
    (setf [%Enabled ink-collector] t)
    [+Stroke ink-collector (new "InkCollectorStrokeEventHandler" 
				#'handle-stroke)			      
			      ]
    [Application.Run window] 
    [ToString [%Strokes [%Ink ink-collector]]]	
    ))

#|  This is what the above code we are modeling looks like in C#

 public delegate void InkCollectorStrokeEventHandler(
     object sender,
     InkCollectorStrokeEventArgs e );
     public event InkCollectorStrokeEventHandler Stroke;

     
 |#




#| What to do with this ink stuff next.  

a. figure out a timing aspect
to it so you have, say, 500ms to draw a character and it fades
(slowly?) from the screen.  

b. when the character fades, recognize it
and post it somewhere, e.g. next to previous character on clipboard?
devise some feedback, alternatives, corrections 

c. put some buttons on the menu.  

1. digits 2. roman a-z 3. roman A-Z 4. sin cos log 5. math
symbols 6. Greek 

multiple choice: any or all of the above in recogition  set.

learning mode:  use the learning setup from MSW, perhaps?

|#

#| ;begin comment

;Some multiprocessing examples.
(use-package :multiprocessing)
(require :process)

;(defun bar()(dotimes (i 10)(print (* 10 i) (process-sleep 0.5))))
;(defun foo()(dotimes (i 10)(print i)       (process-sleep 0.5)))

;(list (process-run-function "barproc" #'bar)(process-run-function "fooproc" #'foo))
;; look at the console window to see approximately interwoven numbers 0,1,2,3  and 0,10,20,30 ..

(defun lookatstrokes()
  (let ((r 0)
	(as 0))
    (loop (setf as (length all-strokes))
      (cond ((= as r) (mp::process-sleep 0.1))
	    (t (setf r as)
	       (format t "~%I see ~a strokes now" as))))))


(setf strokewatcher-process (mp:process-run-function "strokewatcher" #'lookatstrokes))
       
;; to kill, try (process-kill strokewatcher-process)
;; however, this won't work in the window because the computer
;; is not watching it.
(setf strokewin-process (process-run-function "strokewin" #'mjnetrs))

;; one solution would seem to be to set up another process to look at input
;; from the user, like this

(setf interact (process-run-function "interact-process" #'break "look at lisp environment here"))

;; but even that doesn't work.  The interact-process doesn't read its input until
;; the stroke-handler is called, and then all the lisp processes seems to get run.

;; attempting to move the window process out of the main process doesn't
;; help.

(require :cg)
(use-package :cg)
(cg::initialize-cg)

(defun set-up-procs()
(progn
  (setf strokewin-process 
    (make-process :name "strokewin" :initial-bindings cg.base:*default-cg-bindings*))
  (process-preset strokewin-process #'mjnetrs)
  (setf interact (process-run-function "interact-process" #'break "look at lisp environment here"))
  (setf strokewatcher-process (process-run-function "strokewatcher" #'lookatstrokes))))

(defun kill-procs()
  (mapc #'lambda(r)(process-kill r)
	(list strokewin-process interact strokewatcher-process)))

;; just open a window

(defun makewindow() 
  (let ((window  (new "Form")))
    [Application.Run window];; this does not return until window is killed..
    window))


;; minimal code
(defun mjnetrs()  ;; read strokes
  (let ((ink-overlay (new "InkOverlay")) 
	(window (new "Form"))	)
    (setf [%Enabled ink-overlay] nil)
    [CreateControl window]
    (setf [%Handle ink-overlay] [%Handle window])
    (setf [%Enabled ink-overlay] t)
    [+Stroke ink-overlay (new "InkCollectorStrokeEventHandler" #'handle-stroke)]
    [Application.Run window]  ))

;; maybe the thing to do is to have a handler for "mouse/pen not in window"
;; to stop waiting for ink input??

|#



;; possibly useful utilities.

(defun bound-stroke(h);  h is a list of xy points from decode-stroke-to-points. ( (x1 . y1) ...)
  ;; return 2 points [lisp pairs] ( (xmin . ymin) (xmax . ymax) )
  (let ((xmax -1000000) ; exceeds points on window
	(xmin  1000000)
	(ymax -1000000)
	(ymin  1000000)
	(x 0)(y 0))
    (declare(fixnum xmax xmin ymax ymin x y))
    (dolist (p h)
      (setf x (car p) y (cdr p))
      (if (< x xmin)(setf xmin x))
      (if (> x xmax)(setf xmax x))

      (if (< y ymin)(setf ymin y))
      (if (> y ymax)(setf ymax y))
      )
    `( (,xmin ., ymin) (,xmax .,ymax)))) 

;; if you have many strokes, you can append them together, or do this

;; hlist  a list of strokes

(defun bound-stroke-list (hlist)
  (bound-stroke (mapcar #'bound-stroke hlist)))

(defun norm-stroke (h box) ;; box is ((xmin . ymin) (xmax ymax)) from bound-stroke
  ;; return a normalized stroke so that it fits in ((0 . 0) (1 . 1))
  ;; what if width or height is 0? replace divisor with 1.
  
  (let* ((xmin (caar box))
	 (ymin (cdar box))
	 (xmax (caadr box))
	 (ymax (cdadr box))
	 (xdist (* 1.0 (max 1(- xmax xmin))))
	 (ydist (* 1.0 (max 1(- ymax ymin)))))
    
    (loop for p in h collect
      (let ((x (car p))
	    (y (cdr p)))
	(cons (/ (- x xmin) xdist)
	      (/ (- y ymin) ydist))))))


;; using cg:position etc.
(defun norm-strokecg (h box &optional (scale 100)) ;; h a list of positions, box a cg:box
  ;; return a normalized stroke so that it fits in ((0 . 0) (10000 . 10000)) ; that's 10,000
  ;; what if width or height is 0? replace divisor with 1.
  
  (let* ((xmin (box-left box));; small x is at the left
	 (ymin (box-top box)) ;; small y is at the upper . yes, this might be upside down
	 (xmax (box-right box))
	 (ymax (box-bottom box))
	 (xdist (max 1(- xmax xmin)))
	 (ydist (max 1(- ymax ymin))))
    
    (loop for p in h collect
      (let ((x (position-x p))
	    (y (position-y p)))
	(make-position (truncate (* scale (- x xmin)) xdist)
		       (truncate (* scale (- y ymin)) ydist))))))


(defun bound-strokecg(h);  h is a list of xy positions from decode-stroke-to-positions.
  ;; return a box (xmin  . ymin) (xmax . ymax) )
  (let ((xmax -1000000) ; exceeds points on window
	(xmin  1000000)
	(ymax -1000000)
	(ymin  1000000)
	(x 0)(y 0))
    (declare(fixnum xmax xmin ymax ymin x y))
    (dolist (p h)
      (setf x (position-x p) y (position-y p))
      (if (< x xmin)(setf xmin x))
      (if (> x xmax)(setf xmax x))

      (if (< y ymin)(setf ymin y))
      (if (> y ymax)(setf ymax y))
      )
    ;; left top right bottom
    (make-box  xmin ymin xmax ymax ))) ; y bigger at bottom of screen

(defun decode-stroke-to-points (container)
  (let ((netarray
	 [GetPoints [%Stroke container])
	 ;;(invoke  (property container "Stroke") "GetPoints") ;; get array of points
	 )
       (list-of-points nil))
    (do-rdnzl-array (v netarray (nreverse list-of-points))
      (push (cons [%X v][%Y v]) list-of-points)
     ;;(push (cons  (property v "X")(property v "Y")) list-of-points)
      ))

(defun decode-stroke-to-positions (container)
  ;; take a stroke and make a list of cg:positions
  (let ((netarray
	 [GetPoints [%Stroke container])
	 ;;(invoke  (property container "Stroke") "GetPoints") ;; get array of points
	 )
       (list-of-points nil))
    (do-rdnzl-array (v netarray (nreverse list-of-points))
      (push (make-position [%X v][%Y v]) list-of-points)
      ))

;;; note: for cg,  (draw-polyline window list-of-positions) works to connect the dots..

;;  [ToString ss]
	 
(disable-rdnzl-syntax)