(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 arr( s )
  (with-ltk ()
    (let* ((w (ltk-wrapper s))
           (l0 (make-instance 'label :text "X"))
           (c0 (make-instance 'canvas :width 100 :height 25))
           (l1 (make-instance 'label :text "Y"))
           (c1 (make-instance 'canvas :width 100 :height 25))
           (l2 (make-instance 'label :text "SD"))
           (c2 (make-instance 'canvas :width 100 :height 25))
           (l3 (make-instance 'label :text "MU"))
           (c3 (make-instance 'canvas :width 100 :height 25))
           (l4 (make-instance 'label :text "TAU"))
           (c4 (make-instance 'canvas :width 100 :height 25)))
      (pack l0)
      (canvastest (gethash 'x w) c0)
      (pack l1)
      (canvastest (gethash 'y w) c1)
      (pack l2)
      (canvastest (gethash 'sd w) c2)
      (pack l3)
      (canvastest (gethash 'mu w) c3)
      (pack l4)
      (canvastest (gethash 'tau w) c4))))

(defun canvastest(lstolst cv)
  (let* ((p0 (make-rectangle cv (first (nth 0 lstolst)) 0 (second (nth 0 lstolst)) 25))
         (p1 (make-rectangle cv (first (nth 1 lstolst)) 0 (second (nth 1 lstolst)) 25))
         (p2 (make-rectangle cv (first (nth 2 lstolst)) 0 (second (nth 2 lstolst)) 25))
         (p3 (make-rectangle cv (first (nth 3 lstolst)) 0 (second (nth 3 lstolst)) 25))
         (p4 (make-rectangle cv (first (nth 4 lstolst)) 0 (second (nth 4 lstolst)) 25))
         (p5 (make-rectangle cv (first (nth 5 lstolst)) 0 (second (nth 5 lstolst)) 25))
         (p6 (make-rectangle cv (first (nth 6 lstolst)) 0 (second (nth 6 lstolst)) 25))
         (p7 (make-rectangle cv (first (nth 7 lstolst)) 0 (second (nth 7 lstolst)) 25))
         (p8 (make-rectangle cv (first (nth 8 lstolst)) 0 (second (nth 8 lstolst)) 25))
         (p9 (make-rectangle cv (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)))
    (pack cv)))

(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~%")
     (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))
                          

    ((format t "Start!~%")
     (let* ((s (demo-seheult)) str (xf 0)  (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)
         (format t "~A ~A~%" (value x) (car (nth i *x-freqs*)))
         (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))))
       
       (maphash #'(lambda (k v) (format t "~A=>~A~%" k v)) s)
       
       (dolist (NANER (gethash 'x s))
           (when (between (first NANER) (second NANER) (value x))
             (configure x :troughcolor (discretize-color (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 (discretize-color (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 "sd (~A)" (second (nth (1- i) *sd-freqs*))))
               (return))))
         
         (dolist (NANER (gethash 'sd s))
           (format t "Length of SD: ~A~%" (length (gethash 'sd s)))
           (format t "SD: ~A ~A ~A~%" (first NANER) (second NANER) (value sd))
           (if (between (first NANER) (second NANER) (value sd))
               (configure sd :troughcolor (discretize-color (first (last NANER))))))

         (dolist (NANER (gethash 'mu s))
           (format t "MU: ~A ~A ~A~%" (first NANER) (second NANER) (value mu))
           (if (between (first NANER) (second NANER) (value mu))
               (configure mu :troughcolor (discretize-color (first (last NANER))))))
         
         (dolist (NANER (gethash 'tau s))
           (if (between (first NANER) (second NANER) (value tau))
               (configure tau :troughcolor (discretize-color (first (last NANER))))))
         (arr s)
         (format t "END~%"))))
  
  (format t "Woot~%")
  (new-random-seheult 1.4 1.6 1 1 mu tau)
  (let (tempval)
    (handler-case
        (progn
          (setf tempval (sh-model x y sd mu tau)))
      
      (floating-point-overflow ()
        (setf tempval 10)))
    (if (> tempval 10)
        (setf tempval 10))
    (with-open-file (out "randomdata.dat"
                         :direction :output
                         :if-exists :append)
      (format out "~%~%~a ~a ~a" x y tempval))
    tempval)
  (format-gnuplot "set title 'Seheult Data'")
  (format-gnuplot "unset key")
  (set-labels "x-ri" "y-ri" "LR")
  (new-generate-thumbs 30 40 40 30)
  (format-gnuplot "splot 'randomdata.dat' index 0, 'randomdata.dat' index 1"))
  

(defmacro new-generate-thumbs (viewx viewy dx dy)
  `(progn
     (format-gnuplot "set terminal gif")
     (format-gnuplot "set size .6,.6")
     (dotimes (i 3)
       (format-gnuplot (format nil "set view ~A,~A" (+ ,viewx (* (1+ i) ,dx)) (+ ,viewy (* (1+ i) ,dy))))
       (format-gnuplot (format nil "set output \"~A.gif\"" i))
       (format-gnuplot "splot 'randomdata.dat' index 0, 'randomdata.dat' index 1"))
     (format-gnuplot "set terminal wxt")
     (format-gnuplot "set size 1,1")
     (format-gnuplot "set output")))

(defun new-random-seheult (min max min.sd max.sd
                           &optional
                           (mu 1.5181932) (tau 0.0036737733) (timespersd 5000) (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))