;This LISP program is written for use with a parameter search program.  However predictions can be 
;directly claculated by setting the mismatch parmater (factor), the threshold parameter (tau), and the 
;noise parameter (noise) and then calling do-it with the number of trials requested -- eg. (do-it 1000)
;predictions will be returned for 30 seconds, 4 hours, and 24 hours ordered by serial position of
;input and of output.

(defvar probs (make-array '(5 5) :initial-contents
                          '((.753 .184 .049 .011 .003)
                            (.184 .572 .184 .049 .011)
                            (.049 .184 .534 .184 .049)
                            (.011 .049 .184 .572 .184)
                            (.003 .011 .049 .184 .753))))

(defvar data (make-array '(3 5 5) :initial-contents
                         '(((0.82	0.07	0.07	0.03	0.03)
(0.1	0.54	0.18	0.09	0.08)
(0.04	0.18	0.53	0.18	0.07)
(0.03	0.13	0.16	0.53	0.15)
(0.01	0.09	0.06	0.17	0.68))
((0.58	0.14	0.14	0.09	0.05)
(0.22	0.43	0.12	0.13	0.11)
(0.13	0.15	0.37	0.22	0.14)
(0.04	0.15	0.23	0.35	0.23)
(0.04	0.13	0.15	0.21	0.47))
((0.43	0.13	0.12	0.15	0.17)
(0.21	0.33	0.19	0.11	0.17)
(0.18	0.17	0.27	0.28	0.12)
(0.08	0.2	0.25	0.25	0.22)
(0.1	0.18	0.18	0.22	0.33)))))

(defvar misplace)
(defvar factor 1.50)
(defvar tau -0.900)
(defvar noise .5)
(defvar global)

(defun find-prob (time)
  (/ 1.0 (1+ (exp (/ (-  tau (+ 4.14 (* -0.5 (log time)))) noise)))))
  

(defun trial (mem)
  (setf misplace nil)
  (let ((recall (make-array '(5) :initial-element nil)))
  (do ((count (permut '(0 1 2 3 4)) (cdr count))
       (forget nil (cond ((>   (random 1.0) mem) (cons (car count) forget))
                         (t (place (car count) recall) forget))))
      ((null count) (complete recall (permut (append misplace forget)))))))

(defun place (item seq)
  (let ((prob  (random 1.0)))
  (do ((i 1 (1+ i))
       (tot (aref probs item 0) (+ tot (aref probs item i))))
      ((< prob tot) (try-place item (1- i) seq)))))

(defun try-place (targ pos seq)
  (cond ((null (aref seq pos))(setf (aref seq pos) targ))
        (t (setf misplace (cons targ misplace)))))

(defun permut (lis)
  (cond ((null lis) nil) (t
  (do* ((temp lis (remove (car result) temp :test 'equal :count 1))
       (result (list (nth (random (length temp)) temp))
               (cons (nth (random (length temp)) temp) result)))
       ((null (cdr temp)) result)))))

(defun complete (seq lis)
  (do ((i 0 (1+ i))
       (temp lis (cond ((null (aref seq i)) (setf (aref seq i) (car temp))(cdr temp))
                       (t temp))))
      ((equal i 5) seq)))

(defun do-it-help (n p type results)
  (do ((count 0 (1+ count))
       (result (trial p) (trial p)))
      ((equal count n) results)
    (do ((i 0 (1+ i)))
        ((equal i 5) nil)
      (setf (aref results type i (aref result i)) 
            (1+ (aref results type i (aref result i)))))))

(defun init-probs ()
  (do ((i 0 (1+ i))
       (lis nil (append lis
                            (do ((j 0 (1+ j))
                                 (tot 0 (+ tot (aref probs i j))))
                                ((equal j 5) (list tot))
                              (setf (aref probs i j) (/ 1 (1+ (exp (* factor (abs (- i j)))))))))))
      ((equal i 5) (nnormalize probs lis))))

(defun nnormalize (array lis)
  (do ((i 0 (1+ i))
       (temp lis (cdr temp)))
      ((eq i 5) array)
    (do ((j 0 (1+ j)))
        ((eq j 5) nil)
      (setf (aref array i j) (/ (aref array i j) (car temp))))))

(defun do-it (n) 
  (init-probs)
  (let (( results (make-array '(3 5 5) :initial-element 0)))
  (do-it-help n (find-prob 30) 0 results)
  (do-it-help n (find-prob 14400) 1 results)
  (do-it-help n (find-prob 86400) 2 results)
  (setf global results)))

(defun deviations (n)
  (do ((k 0 (1+ k))
       (grand 0 (+ grand 
  (do ((i 0 (1+ i))
       (tot 0 (+ tot (do ((j 0 (1+ j))
                          (sub 0 (+ sub (expt (- (aref data k i j) (/ (aref global k i j) n)) 2))))
                         ((equal j 5) sub)))))
      ((equal i 5) tot)))))
      ((equal k 3) (* 1000 grand))))

(defun optimize (n val)
  (setf noise val)
  (optimize-multidimensional 
   '((tau -0.85 .05)
     (factor 1.5 .1 0))
   (list 'do-it n)
   (list 'deviations n)))

(defun nnormalize (array lis)
  (do ((i 0 (1+ i))
       (temp lis (cdr temp)))
      ((equal i 5) nil)
      (setf (aref array i i) (- 1.5 (car temp)))))