(load "evett-5.lisp")
(load "asterisk.lisp")

(defun ltk-wrapper (d)
  (let* ((n (make-hash-table))
         (i 0)
         j
         (width 100)
         rs)
    (maphash #'(lambda (k v)
                 (setf rs nil) (setf i 0)
                 (setf v (sort v #'(lambda (l r) (< (first l) (first r)))))
                 (setf j (length v))
                 (dolist (el v rs)
                   (setf rs (append rs (list (list (* i (/ width j)) (* (1+ i) (/ width j)) (discretize-color (first (last el)))))))
                   (incf i))
                 (setf (gethash k n) rs)) d)
    n))

(defun canvastest(lstolst cvs)
  (let* ((p0 (make-rectangle cvs (first (nth 0 lstolst)) 0 (second (nth 0 lstolst)) 25))
         (p1 (make-rectangle cvs (first (nth 1 lstolst)) 0 (second (nth 1 lstolst)) 25))
         (p2 (make-rectangle cvs (first (nth 2 lstolst)) 0 (second (nth 2 lstolst)) 25))
         (p3 (make-rectangle cvs (first (nth 3 lstolst)) 0 (second (nth 3 lstolst)) 25))
         (p4 (make-rectangle cvs (first (nth 4 lstolst)) 0 (second (nth 4 lstolst)) 25))
         (p5 (make-rectangle cvs (first (nth 5 lstolst)) 0 (second (nth 5 lstolst)) 25))
         (p6 (make-rectangle cvs (first (nth 6 lstolst)) 0 (second (nth 6 lstolst)) 25))
         (p7 (make-rectangle cvs (first (nth 7 lstolst)) 0 (second (nth 7 lstolst)) 25))
         (p8 (make-rectangle cvs (first (nth 8 lstolst)) 0 (second (nth 8 lstolst)) 25))
         (p9 (make-rectangle cvs (first (nth 9 lstolst)) 0 (second (nth 9 lstolst)) 25)))
    (configure p0 :fill (third (nth 0 lstolst)))
    (configure p1 :fill (third (nth 1 lstolst)))
    (configure p2 :fill (third (nth 2 lstolst)))
    (configure p3 :fill (third (nth 3 lstolst)))
    (configure p4 :fill (third (nth 4 lstolst)))
    (configure p5 :fill (third (nth 5 lstolst)))
    (configure p6 :fill (third (nth 6 lstolst)))
    (configure p7 :fill (third (nth 7 lstolst)))
    (configure p8 :fill (third (nth 8 lstolst)))
    (configure p9 :fill (third (nth 9 lstolst)))
    (format t "Pain~%")
    (pack cvs :fill :both)
    ))

(defun discretize-color (zerotoone)
  (labels ((between (x y) (and (<= x zerotoone) (< zerotoone y))))
    (cond
      ((between 0.00 0.10) :black)
      ((between 0.10 0.20) :darkgrey)
      ((between 0.20 0.30) :lightgrey)
      ((between 0.30 0.40) :red4)
      ((between 0.40 0.50) :red2)
      ((between 0.50 0.60) :green4)
      ((between 0.60 0.70) :green2)
      ((between 0.70 0.80) :blue4)
      ((between 0.80 0.90) :blue2)
      ((between 0.90 1.00) :darkgreen) 
      ((between 1.00 10.0) :white))))

(defparameter *x-freqs*
  '((1.46833  4)
    (1.476159 0)
    (1.4839879 18)
    (1.4918169 0)
    (1.4996458 0)
    (1.5074748 114)
    (1.5153037 0)
    (1.5231327 4106)
    (1.5309616 27)
    (1.5387906 0)))

(defparameter *y-freqs*
  '((1.46833  4)
    (1.476159  0)
    (1.4839879  18)
    (1.4918169  0)
    (1.4996458  0)
    (1.5074748  114)
    (1.5153037  0)
    (1.5231327  4106)
    (1.5309616  27)
    (1.5387906  0)))

(defparameter *sd-freqs*
  '((1  4024)
    (81/10  0)
    (76/5  235)
    (223/10  0)
    (147/5  7)
    (73/2  0)
    (218/5  0)
    (507/10  2)
    (289/5  0)
    (649/10  1)))

(defmodel sh
	     ((:scale x 1.4 1.6 .001)
	      (:scale y 1.4 1.6 .001)
	      (:scale sd .00001 .00025 .00001)
	      (:scale mu 1.5181932 15.181932 1.5181932)
	      (:scale tau 0.0036737733 0.036737733 0.0036737733))


    ((format t "Wut~%"))

    ((format t "Start!~%")
     (let* ((s (demo-seheult)) str (xf 0) (w (ltk-wrapper s)) (jj 0))
;       (maphash #'(lambda (k v)
;                    (canvastest v (intern (format nil "CANVAS~A" jj)))
;                    (incf jj)) w)
         
         



       
       (labels ((between (left right val) (and (<= left val) (<= val right))))
         
         (dotimes (i (length *x-freqs*) xf)
           (when (<= (value x) (car (nth i *x-freqs*)))
               (unless (< (1- i) 0)
                 (configure x :label (format nil "x (~A)" (second (nth (1- i) *x-freqs*))))
                 (return))))

         (format t "Frequency of x=~A is ~A~%" (value x) xf)
         
         (dolist (NANER (gethash 'x s))
           (when (between (first NANER) (second NANER) (value x))
             (configure x :troughcolor (intern (format nil "gray~A" (round (* 100 (first (last NANER)))))))
             (format t "Value: ~A~%" (round (* 100 (first (last NANER)))))))

         (dotimes (i (length *y-freqs*) xf)
           (when (<= (value y) (car (nth i *y-freqs*)))
               (unless (< (1- i) 0)
                 (configure y :label (format nil "y (~A)" (second (nth (1- i) *y-freqs*))))
                 (return))))
         
         (dolist (NANER (gethash 'y s))
           (if (between (first NANER) (second NANER) (value y))
               (configure y :troughcolor (intern (format nil "gray~A" (round (* 100 (first (last NANER)))))))))

         (dotimes (i (length *sd-freqs*) xf)
           (when (<= (value sd) (car (nth i *sd-freqs*)))
             (unless (< (1- i) 0)
               (configure sd :label (format nil "x (~A)" (second (nth (1- i) *sd-freqs*))))
               (return))))
         
         (dolist (NANER (gethash 'sd s))
           (if (between (first NANER) (second NANER) (value sd))
               (configure sd :troughcolor (intern (format nil "gray~A" (round (* 100 (first (last NANER)))))))))
         
         (dolist (NANER (gethash 'mu s))
           (if (between (first NANER) (second NANER) (value mu))
               (configure mu :troughcolor (intern (format nil "gray~A" (round (* 100 (first (last NANER)))))))))
         
         (dolist (NANER (gethash 'tau s))
           (if (between (first NANER) (second NANER) (value tau))
               (configure tau :troughcolor (intern (format nil "gray~A" (round (* 100 (first (last NANER)))))))))

         (format t "END~%"))))
         
#|    ((let
         ((s (demo-seheult)) str)
       (labels ((between (left right val) (and (<= left val) (<= val right))))
         
         (setf str (concatenate 'string str (format nil "Importance of ~3A=~5$ ~5$~%" 'x x (let ((i 1))
                                 (dolist (NANER (gethash 'x s))
                                   (if (between (first NANER) (second NANER) x)
                                       (return (first (last NANER)))
                                       (incf i)))))))
         
         (setf str (concatenate 'string str (format nil "Importance of ~3A=~5$ ~5$~%" 'y y (let ((i 1))
                                 (dolist (NANER (gethash 'y s))
                                   (if (between (first NANER) (second NANER) y)
                                       (return (first (last NANER)))                                                
                                       (incf i)))))))
         
         (setf str (concatenate 'string str (format nil "Importance of ~3A=~5$ ~5$~%" 'sd sd (let ((i 1))
                                  (dolist (NANER (gethash 'sd s))
                                    (if (between (first NANER) (second NANER) sd)
                                        (return (first (last NANER)))
                                        (incf i)))))))
         
         (setf str (concatenate 'string str (format nil "Importance of ~3A=~5$ ~5$~%" 'mu mu (let ((i 1))
                                  (dolist (NANER (gethash 'mu s))
                                    (if (between (first NANER) (second NANER) mu)
                                        (return (first (last NANER)))                                                
                                        (incf i)))))))
         
         (setf str (concatenate 'string str (format nil "Importance of ~3A=~5$ ~5$~%" 'tau tau (let ((i 1))
                                   (dolist (NANER (gethash 'tau s))
                                     (if (between (first NANER) (second NANER) tau)
                                         (return (first (last NANER)))
                                         (incf i)))))))
         (with-ltk ()
           (let ((c (make-instance 'message :text str :width 300)))
                                        ;           (setf (value c) str)
             (pack c)))
         (format t "~A ~%" str)
         str)))|#
  
  (format t "Woot~%"))

(defun new-random-seheult (min max min.sd max.sd
                           &optional
                           (mu 1.5181932) (tau 0.0036737733) (timespersd 10000) (filename "randomdata.dat"))
  (let ((x 0)
        (y 0)
        (tempval 0))
    (with-open-file (out filename
                         :direction :output
                         :if-exists :supersede)
      (format out "### splot '~a' index 0" filename)
      (dotimes (i (- max.sd min.sd))
        (format out ", '~a' index ~a" filename (+ i 1)))
      (dotimes (i (+ (- max.sd min.sd) 1))
                                        ;(format out "~%~%###SD: ~a~%" (+ i 1))
        (format out "~%~%###SD: ~a~%" (+ i min.sd))
        (dotimes (j timespersd)
          (setf x (+ (random (- max min)) min))
          (setf y (+ (random (- max min)) min))
          (handler-case
              (progn
                (setf tempval
                      (seheult x y (* (+ i 1)
                                      (expt 10 -5)) mu tau)))
            (floating-point-overflow ()
              (setf tempval 10)))
          (if (> tempval 10)
              (setf tempval 10))
          (format out "~a ~a ~a~%" x y tempval))))
    'done))

(defun seheult (x y sd &optional (mu 1.5181932)
                (tau 0.0036737733))
  (let* ((l (/ sd tau))
         (ll (* l l))
         (u (/ (- x y) (* sd (sqrt 2))))
         (z (* .5 (+ x y)))
         (v (/ (- z mu) (* tau (expt (+ 1 (* .5 ll)) .5))))
         (factor (* (/ (+ 1 ll) (* l (expt (+ 2 ll) .5)))
                    (exp (* (/ -1 (* 2 (+ 1 ll)))
                            (- (* u u) (* v v)))))))
    factor))

(defun handle-seheult (x y sd &optional  (mu 1.5181932)
                       (tau 0.0036737733) (maxallowed 10) (filename "sliderdata.dat"))
  (let (tempval)
    (handler-case
        (progn
          (setf tempval (seheult x y sd mu tau)))
      
      (floating-point-overflow ()
        (setf tempval maxallowed)))
    (if (> tempval maxallowed)
        (setf tempval maxallowed))
    (with-open-file (out filename
                         :direction :output
                         :if-exists :supersede)
      (format out "~a ~a ~a" x y tempval))
    tempval))

#|(require 'cgn)
(progn
  (use-package :cgn)
  (use-package :ltk))

(defun new-random-seheult (min max min.sd max.sd 
			   timespersd filename &optional
			   (mu 1.5181932) (tau 0.0036737733))
  (let ((x 0)
	(y 0)
	(tempval 0))
    (with-open-file (out filename
			 :direction :output
			 :if-exists :supersede)
      (format out "### splot '~a' index 0" filename)
      (dotimes (i (- max.sd min.sd))
	(format out ", '~a' index ~a" filename (+ i 1)))
      (dotimes (i (+ (- max.sd min.sd) 1))
	;(format out "~%~%###SD: ~a~%" (+ i 1))
	(format out "~%~%###SD: ~a~%" (+ i min.sd))
	(dotimes (j timespersd)
	  (setf x (+ (random (- max min)) min))
	  (setf y (+ (random (- max min)) min))
	  (handler-case
	      (progn
		(setf tempval 
		      (seheult x y (* (+ i 1)  
				      (expt 10 -5)) mu tau)))
	    (floating-point-overflow ()
	      (setf tempval 10)))
	  (if (> tempval 10)
	      (setf tempval 10))
	  (format out "~a ~a ~a~%" x y tempval))))
    'done))

(defun seheult (x y sd &optional (mu 1.5181932)
                (tau 0.0036737733))
  (let* ((l (/ sd tau))
         (ll (* l l))
         (u (/ (- x y) (* sd (sqrt 2))))
         (z (* .5 (+ x y)))
         (v (/ (- z mu) (* tau (expt (+ 1 (* .5 ll)) .5))))
         (factor (* (/ (+ 1 ll) (* l (expt (+ 2 ll) .5)))
                    (exp (* (/ -1 (* 2 (+ 1 ll)))
                            (- (* u u) (* v v)))))))
    factor))

(defun handle-seheult (x y sd filename &optional (mu 1.5181932)
		       (tau 0.0036737733) (maxallowed 10))
  (let (tempval)
    (handler-case
	(progn
	  (setf tempval (seheult x y sd mu tau)))
      
      (floating-point-overflow ()
	(setf tempval maxallowed)))
    (if (> tempval maxallowed)
	(setf tempval maxallowed))
    (with-open-file (out filename
			 :direction :output
			 :if-exists :supersede)
      (format out "~a ~a ~a" x y tempval))
    tempval))  

(defun sgui ()
  (with-ltk ()
    (let* ((f (make-instance 'frame))
	   (scalex (make-instance 'scale
				  :master f
				  :label "X-RI"
				  :digits 6
				  :troughcolor 'cyan
				  :resolution .001
				  :from 1.4
				  :to 1.6))
	   (scaley (make-instance 'scale
				  :master f
				  :label "Y-RI"
				  :troughcolor 'cyan
				  :resolution .001
				  :from 1.4
				  :to 1.6))
	   (scalesd (make-instance 'scale
				  :master f
				  :label "S.D."
				  :troughcolor 'cyan
				  :resolution .00001
				  :from .00001
				  :to .00025))
	   (f3 (make-instance 'frame))
	   (l2 (make-instance 'label
				  :master f3
				  :text "NOTE: It is not recommended to change the orange sliders."))
	   (scalemu (make-instance 'scale
				  :master f3
				  :label "mu"
				  :digits 9
				  :troughcolor 'orange
				  :resolution 1.5181932
				  :from 1.5181932
				  :to 15.181932))

	   (scaletau (make-instance 'scale
				  :master f3
				  :label "tau"
				  :digits 9
				  :troughcolor 'orange
				  :resolution 0.0036737733
				  :from 0.0036737733
				  :to 0.036737733))

	   (f2 (make-instance 'frame))
	   (l1 (make-instance 'label :master f2))
	   (b1 (make-instance 'button :master f2
			      :text "Seheultize me, Cap'n!"
			      :command 
			      (lambda ()
				(new-random-seheult 1.4 1.6 
						    (round (* 1.e5 (value scalesd))) 
						    (round (* 1.e5 (value scalesd))) 
						    10000 "random data" (value scalemu) (value scaletau))
				(setf (text l1) 
				      (format nil "Slider Data returns LR of: ~a."
					      (handle-seheult (value scalex) 
							      (value scaley)
							      (value scalesd)
							      "slider data"
							      (value scalemu) 
							      (value scaletau)
							      10)))
				(with-gnuplot ( 'linux )
				  (format-gnuplot "reset")
				  (format-gnuplot "set xlabel \"X - Refractive Index\"")
				  (format-gnuplot "set ylabel \"Y - Refractive Index\"")
				  (format-gnuplot "set zlabel \"Likelihood Ratio\"")
				  (format-gnuplot "set-view 65,15")
				  (set-title "Seheult Data")				  
				  (format-gnuplot "splot 'random data', 'slider data'")))))
	   )
      (pack f)
      (pack scalex :side :left)
      (pack scaley :side :left)
      (pack scalesd :side :right)
      (pack f3 :side :left)
      (pack l2)
      (pack scalemu :side :left)
      (pack scaletau :side :left)
      (pack f2 :side :bottom :after f)
      (pack l1)
      (pack b1)
      )))
|#