;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

;;; Standard window for hacking graphics.

(defflavor hack-window ()
	   (tv:stream-mixin
	    tv:borders-mixin
	    tv:graphics-mixin
	    tv:minimum-window))

(defparameter *hack-window-top*      0)
(defparameter *hack-window-left*     0)
(defparameter *hack-window-height* 500)
(defparameter *hack-window-width*  500)
(defparameter *hack-window-border-size* 2)

(defvar hack1 (make-instance 'hack-window
			     :borders     *hack-window-border-size*
			     :left        *hack-window-left*
			     :top         *hack-window-top*
			     :width       *hack-window-width*
			     :height      *hack-window-height*
			     :deexposed-typeout-action :expose
			     :save-bits t
			     :blinker-p nil))

(defmethod (hack-window :clear) ()
  (send self :draw-rectangle (send self :width) (send self :height) 0 0 tv:alu-andca))
			     
(defparameter *draw-window-top*  0)
(defparameter *draw-window-left* 0)
(defparameter *draw-window-height* 100)
(defparameter *draw-window-width*  100)
(defparameter *draw-window-border-size* 5)

(defvar draw-window (make-instance 'hack-window
			     :borders     *draw-window-border-size*
			     :left        *draw-window-left*
			     :top         *draw-window-top*
			     :width       *draw-window-width*
			     :height      *draw-window-height*
			     :deexposed-typeout-action :expose
			     :save-bits t
			     :blinker-p nil))

;;; Points

(defstruct (point
	     (:conc-name "POINT-")
	     (:callable-constructors nil)
	     (:constructor make-point (coordinate-system x y r theta))
	     (:print-function print-point))
  coordinate-system
  x
  y
  r
  theta)

(defun make-point-cartesian (x y)
  (make-point 'cartesian x y nil nil))

(defun make-point-polar (r theta)
  (make-point 'polar nil nil r theta))

(defun primitive-spread-point (point receiver)
  (funcall receiver (point-coordinate-system point)
		    (point-x                 point)
		    (point-y                 point)
		    (point-r                 point)
		    (point-theta             point)))

(defun spread-point-cartesian (point receiver)
  (primitive-spread-point point
    #'(lambda (c x y r theta)
	(if (or (eq c 'cartesian) (eq c 'both))
	    (funcall receiver x y)
	  (let ((x (* r (cos theta)))
		(y (* r (sin theta))))
	    (setf (point-coordinate-system point) 'both
		  (point-x                 point) x
		  (point-y                 point) y)
	    (funcall receiver x y))))))

(defun spread-point-polar (point receiver)
  (primitive-spread-point point
    #'(lambda (c x y r theta)
	(if (or (eq c 'polar) (eq c 'both))
	    (funcall receiver r theta)
	  (let* ((r (sqrt (+ (* x x) (* y y))))
		 (theta (if (zerop r) 0 (atan y x))))
	    (setf (point-coordinate-system point) 'both
		  (point-r                 point) r
		  (point-theta             point) theta)
	    (funcall receiver r theta))))))

(defun print-point (point stream ignore)
  (si:printing-random-object (point stream :type)
    (primitive-spread-point point
      #'(lambda (c x y r theta)
	  (cond ((eq c 'both)      (format stream "~S<~D,~D;~D,~D>" c x y r theta))
		((eq c 'polar)     (format stream "~S<~D,~D>" c r theta))
		((eq c 'cartesian) (format stream "~S<~D,~D>" c x y)))))))

(defun real-height-and-width (window reciever)
  (funcall reciever (send window ':height) (send window ':width)))

(defun hack-height-and-width (window receiver)
  (real-height-and-width window
    #'(lambda (h w)
	(funcall receiver (truncate h 2) (truncate w 2)))))

(defun draw-points (window point-list alu scaling)
  (hack-height-and-width window
    #'(lambda (center-x center-y)
	(dolist (point point-list)
	  (spread-point-cartesian point
	    #'(lambda (px py)
		(send window ':draw-point (round (+ center-x (* scaling px)))
					  (round (- center-y (* scaling py))) alu)))))))

(defun draw-point-to-point (window point-list alu)
  (hack-height-and-width window
    #'(lambda (center-x center-y)
	(do ((start (first point-list)               end)
	     (end   (second point-list)      (first more))
	     (more  (rest (rest point-list))  (rest more)))
	    ((null end) nil)
	  (spread-point-cartesian start
	    #'(lambda (sx sy)
		(spread-point-cartesian end
		  #'(lambda (ex ey)
		      (send window ':draw-line (round (+ center-x sx)) (round (- center-y sy))
					       (round (+ center-x ex)) (round (- center-y ey))
					       alu nil)))))))))

(defun stars (window how-many)
  (hack-height-and-width window
    #'(lambda (x y)
	(let ((x1 (* x 2))
	      (y1 (* y 2)))
	(let ((point-list '()))
	  (dotimes (count how-many)
	    (push (make-point-cartesian (- x (random x1)) (- y (random y1)))
		  point-list))
	  (send window ':clear)
	  (draw-points window point-list tv:alu-ior 1))))))

(defun degrees (rads)
  (* rads 2 (/ pi 360.0)))

(defvar klingon-shape-list
  (list (list 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0)
        (list 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0)
	(list 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0)
	(list 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0)
	(list 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0)
	(list 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0)
	(list 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0)
	(list 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0)
	(list 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0)
	(list 0 0 0 0 1 0 0 1 1 0 0 1 0 0 0 0)
	(list 0 0 0 0 1 0 0 1 1 0 0 1 0 0 0 0)
	(list 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0)
	(list 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0)
	(list 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0)
	(list 0 0 1 0 0 0 0 1 1 0 0 0 0 1 0 0)
	(list 0 0 1 0 0 0 1 0 0 1 0 0 0 1 0 0)
	(list 0 0 1 0 0 0 1 0 0 1 0 0 0 1 0 0)
	(list 0 1 0 0 0 0 1 0 0 1 0 0 0 0 1 0)
	(list 0 1 0 0 1 1 1 1 1 1 1 1 0 0 1 0)
	(list 0 1 0 1 0 0 0 0 0 0 0 0 1 0 1 0)
	(list 1 0 1 0 0 0 0 0 0 0 0 0 0 1 0 1)
	(list 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
	(list 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)
	(list 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)
	))

(defvar enterprise-shape-list
  (list (list 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0)
        (list 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0)
	(list 0 0 0 0 1 1 0 0 0 0 1 1 0 0 0 0)
	(list 0 0 0 1 1 0 0 0 0 0 0 1 1 0 0 0)
	(list 0 0 0 1 1 0 0 0 0 0 0 1 1 0 0 0)
	(list 0 0 1 1 0 0 0 1 1 0 0 0 1 1 0 0)
	(list 0 0 1 1 0 0 1 0 0 1 0 0 1 1 0 0)
	(list 0 0 1 1 0 0 1 0 0 1 0 0 1 1 0 0)
	(list 0 0 1 1 0 0 0 1 1 0 0 0 1 1 0 0)
	(list 0 0 0 1 1 0 0 0 0 0 0 1 1 0 0 0)
	(list 0 0 0 1 1 0 0 0 0 0 0 1 1 0 0 0)
	(list 0 0 0 0 1 1 0 0 0 0 1 1 0 0 0 0)
	(list 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 1 1 0 0 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 1 1 0 0 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 1 1 0 0 0 0 0 1 1)
	(list 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
	(list 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
	(list 1 1 0 0 0 0 0 1 1 0 0 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 1 1 0 0 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
	(list 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
	))

(defun bit-shape->point-list (bit-list)
  (let ((point-list nil))
    (do ((row  (- (length bit-list)) (1+ row))
	 (rows bit-list (rest rows)))
	((null? rows) '())
      (do ((column (- (* (length (first rows)) 2)) (1+ column))
	   (bits   (first rows) (rest bits)))
	  ((null? bits) '())
	(when (= (first bits) 1)
	  (push (make-point-cartesian (1+ (* row 2)) (1+ (* column 2))) point-list)
	  (push (make-point-cartesian (1+ (* row 2)) (* column 2)) point-list)
	  (push (make-point-cartesian (* row 2) (1+ (* column 2))) point-list)
	  (push (make-point-cartesian (* row 2) (* column 2)) point-list))))
    point-list))

(defvar klingon-shape-points (bit-shape->point-list klingon-shape-list))
(defvar enterprise-shape-points (bit-shape->point-list enterprise-shape-list))

(defvar square-shape (list (make-point-cartesian 50 50)
			   (make-point-cartesian 50 -50)
			   (make-point-cartesian -50 -50)
			   (make-point-cartesian -50 50)
			   (make-point-cartesian 50 50)))

(defvar triangle-shape (list (make-point-polar 50 0)
			     (make-point-polar 50 (* (/ pi 3) 2))
			     (make-point-polar 50 (* (/ pi 3) 4))
			     (make-point-polar 50 0)))


(defun rotate-shape (shape d-theta)
  (labels (
    (rotate-point (p)
      (spread-point-polar p
	#'(lambda (r theta)
	    (make-point-polar r (+ d-theta theta))))))
    (map 'list #'rotate-point shape)))

(defun test-spin-shape (shape)
  (draw-points hack1 shape tv:alu-ior .5)
    (let ((shape shape)
	  (next-shape '()))
      (dotimes (count 64.)
	(setq next-shape (rotate-shape shape (/ pi 19.)))
	(without-interrupts
	  (draw-points hack1 shape tv:alu-andca .5)
	  (draw-points hack1 next-shape tv:alu-ior .5))
	(setq shape next-shape))))

(defun test-concurrency ()
  (send hack1 ':clear)
  (process-run-function '(:name "foo" :priority 1 :quantum 1) #'test-spin-shape square-shape)
  (process-run-function '(:name "bar" :priority 1 :quantum 1) #'test-spin-shape triangle-shape))

(defflavor meter-window (last-value
			 last-bottom-x
			 last-bottom-y
			 last-top-x
			 last-top-y
			 internal-computer
			 )
	   (tv:stream-mixin
	    tv:centered-label-mixin
	    tv:label-mixin
	    tv:borders-mixin
	    tv:graphics-mixin
	    tv:minimum-window)
  :settable-instance-variables)

(defparameter *meter-window-top*      0)
(defparameter *meter-window-left*     0)
(defparameter *meter-window-height* 50)
(defparameter *meter-window-width*  50)
(defparameter *meter-window-border-size* 1)

(defvar meter1 (make-instance 'meter-window
			     :borders     nil
			     :left        *meter-window-left*
			     :top         *meter-window-top*
			     :width       *meter-window-width*
			     :height      *meter-window-height*
			     :label       "Test"
			     :last-value  0
			     :blinker-p nil))

(defmethod (meter-window :clear) ()
  (send self :draw-rectangle (send self :height) (send self :width) 0 0 tv:alu-andca))

(defvar *overlap-ratio* .5)
(defvar *needle-ratio* 1.6)
(defconstant pi/2 (/ pi 2))

(defmethod (meter-window :draw-meter-and-create-computer) ()
  (let ((width (1- (send self :inside-width)))
	(height (1- (send self :inside-height))))
    (let ((center-x (truncate width 2))
	  (center-y (truncate height 2)))
      (let ((radius (min center-x center-y)))
	(let ((needle-source-y (+ radius center-y)))
	  (send self :draw-circle center-x center-y radius)
	  (labels ((magic-formula (ratio)
		     (- pi/2 (asin (/ ratio 2))))
		   (compute-radial-line-end (ratio theta)
		     (values (truncate (- center-x         (* ratio radius (cos theta))))
			     (truncate (- needle-source-y  (* ratio radius (sin theta)))))))
	    (let ((bottom-theta (magic-formula *overlap-ratio*)))
	      (send self :draw-circular-arc center-x needle-source-y
		    (truncate (* radius *overlap-ratio*))
		    (- pi/2 bottom-theta) (+ pi/2 bottom-theta)))
	    (let ((needle-maximum-theta (magic-formula *needle-ratio*)))
	      #'(lambda (percent)
		  (let ((valid-percent (max (min percent 1.) -1.)))
		    (let ((needle-theta (- pi/2 (* (- valid-percent) needle-maximum-theta))))
		      (values-values
			(compute-radial-line-end *overlap-ratio* needle-theta)
			(compute-radial-line-end *needle-ratio* needle-theta))))))))))))

(defmethod (meter-window :needle) (percent)
  (if tv:exposed-p
      (when (not (= percent last-value))
	(multiple-value-bind (bottom-x bottom-y top-x top-y)
	    (funcall internal-computer percent)
	  (without-interrupts
	    (send self :draw-line last-bottom-x last-bottom-y last-top-x last-top-y tv:alu-xor)
	    (send self :draw-line bottom-x bottom-y top-x top-y tv:alu-xor))
	  (setq last-value    percent
		last-bottom-x bottom-x
		last-bottom-y bottom-y
		last-top-x    top-x
		last-top-y    top-y)))
	  nil))

(defmethod (meter-window :redraw) ()
  (setq internal-computer (send self :draw-meter-and-create-computer))
  (multiple-value-setq (last-bottom-x last-bottom-y last-top-x last-top-y)
    (funcall internal-computer last-value))
  (send self :draw-line last-bottom-x last-bottom-y last-top-x last-top-y tv:alu-xor))

(defmethod (meter-window :after :expose) ()
  (send self :redraw))

(defun tick (meter-window)
  (let ((time (sin (* pi (/ (ash (time:fixnum-microsecond-time) -8.) 4000.0)))))
    (send meter-window :needle time)))


(defun test (tv:w)
  tv:(with-mouse-usurped
      (lock-sheet (main-screen)
	(lock-sheet (who-line-screen)
	  (without-interrupts
	    (let ((ms mouse-sheet) (sw selected-window))
	      (and (sheet-me-or-my-kid-p ms main-screen)
		   (setq mouse-sheet nil))
	      (send who-line-screen :deexpose)
	      (send main-screen     :deexpose)
	      (setq mouse-sheet ms)
	      (send who-line-screen :change-of-size-or-margins :right (- main-screen-height w))
	      (send main-screen     :change-of-size-or-margins :right (- main-screen-height w))
	      (mouse-set-sheet ms)
	      (send main-screen :expose)
	      (send who-line-screen :expose)
	      (and sw (send sw :select))))))))

;(defun meter (window x y radius)
;  (send window :draw-circle x y radius)
;  (let ((needle-source-y (+ y radius)))
;    (labels ((compute-visible-needle-end (ratio theta)
;	       (values (truncate (- x (* ratio radius (cos theta))))
;		       (truncate (- needle-source-y (* ratio radius (sin theta))))))
;	     (magic-formula (ratio)
;	       (- (/ pi 2) (asin (/ ratio 2)))))
;      (let ((bottom-theta  (magic-formula *overlap-ratio*)))
;	(send window :draw-circular-arc x needle-source-y
;	      (truncate (* radius *overlap-ratio*))
;	      (- (/ pi 2) bottom-theta) (+ (/ pi 2) bottom-theta)))
;      (let ((needle-pin-theta (magic-formula *needle-ratio*)))
;	(let (needle-bottom-x
;	      needle-bottom-y
;	      needle-top-x
;	      needle-top-y)
;	  (labels ((draw-needle ()
;		     (send window :draw-line
;			   needle-bottom-x
;			   needle-bottom-y
;			   needle-top-x
;			   needle-top-y tv:alu-xor))
;		   (compute-new-needle-value (percentage)
;		     (let ((needle-theta (- (/ pi 2)(* percentage needle-pin-theta))))
;		       (multiple-value-setq
;			 (needle-bottom-x needle-bottom-y)
;			 (compute-visible-needle-end *overlap-ratio* needle-theta))
;		       (multiple-value-setq
;			 (needle-top-x needle-top-y)
;			 (compute-visible-needle-end *needle-ratio* needle-theta)))))
;	    (compute-new-needle-value 0)
;	    (draw-needle)
;	    (lambda (new-percentage)
;	      (without-interrupts
;		(draw-needle)
;		(compute-new-needle-value new-percentage)
;		(draw-needle)))))))))

(defvar foo (make-instance 'tv::basic-frame))
(defvar bar (make-instance 'hack-window :superior foo))

(defvar foo (make-instance 'tv::basic-constraint-frame
			   ':panes
			   '((label-pane tv:window :blinker-p nil :label ""
					 :height 20
					 :width 100)
			     (data-pane tv:window :blinker-p nil :label ""))
			   ':constraints
			   '((main . ((only-strip)
				      ((only-strip :horizontal (:even)
					(label-pane data-pane)
					((label-pane :ask :pane-size)
					 (data-pane :even)))))))))
						  
(defflavor word-window (word)
	   (tv:borders-mixin
	    tv:minimum-window))

(defmethod (word-window :after :refresh) ()
  (send self :string-out-x-y-centered-explicit word))

(defvar foo (make-instance 'word-window