;;; This is the version witht the evals
;;; but now we strip out the evals for a while

(defvar *window*)
(defvar *state*)
(defvar *ops*)
(defvar *moves* 0)
(defvar *start-time*)
(defvar *dest*)
(defvar *prev-state*)
(defvar *state-space*)
(defvar *goal-success*)
(defvar *typing*)
(defvar *verbose* nil)
(defvar *instr* nil)
(defvar *legs*)
(defvar *execs*)
(defvar *offset* nil)

(defvar *main-path* '("acx" "ksfo" "fgx" "dibby"
                      "yng" "cutta" "mufti" "wiile"
                      "starg" "kpit"))
(defstruct state page lines route scratch mod nd discontinuity page-no)

(defun find-rest (item l)
  (cond
   ((null l) nil)
   ((equal (first l) item) l)
   (t (find-rest item (rest l)))))

(defun construct-rest (item l)
  (let ((h (find-rest item l)))
    (if h (rest h)
        (cons "DISCONTINUITY" l))))

(defun replace-discont (l s)
  (cond 
   ((null l) nil)
   ((equal (first l) "DISCONTINUITY") (cons s (rest l)))
   (t (cons (first l)(replace-discont (rest l) s)))))

(defun update-route (state key)
  (let* ((up-pos (+ (* (state-page-no state) 4) key))
         (new-segment (member (state-scratch state) (state-route state) :test #'string=))
         )
    (cond 
     ((null new-segment)
      (setf (state-route state) (append (subseq (state-route state) 0 up-pos) (list (state-scratch state) "DISCONTINUITY")
                                        (subseq (state-route state) up-pos))))
     ((< (+ (length new-segment) up-pos) (length (state-route state)))
      (setf (state-route state) (append (subseq (state-route state) 0 up-pos) new-segment))))
    (update-page state)))

(defun update-page (state)
  (setf (state-lines state)(subseq (state-route state) (* (state-page-no state) 4)))
  (when (> (length (state-lines state)) 4) (setf (state-lines state) (subseq (state-lines state) 0 4))))


(defun next-state (state action)
;  (when (or (listp action)
;            (member action (actions state)))
;  (when (eq (state-nd state) 'error)(setf (state-nd state) nil))
  (cond 
   ((eq action 'init)
    (setf (state-page state) 'init)
    (setf (state-lines state) '())
    (when (null (state-route state)) (setf (state-route state) *main-path*))
    (when (null (state-scratch state)) (setf (state-scratch state) "")))
   ((eq action 'legs)
    (when (not (eq (state-page state) 'legs))
      (setf (state-page state) 'legs)
      (setf (state-page-no state) 0)
      (update-page state)
    ))
   ((eq action 'route)
    (setf (state-page state) 'route)
    (setf (state-lines state) '("J16" "J1" "LOCAL")))
   ((and (eq action '1l) (equal (state-scratch state) "")(first (state-lines state)))
    (setf (state-scratch state)(first (state-lines state))))
   ((and (eq action '2l) (equal (state-scratch state) "")(second (state-lines state)))
    (setf (state-scratch state)(second (state-lines state))))
   ((and (eq action '3l) (equal (state-scratch state) "")(third (state-lines state)))
    (setf (state-scratch state)(third (state-lines state))))
   ((and (eq action '4l) (equal (state-scratch state) "")(fourth (state-lines state)))
    (setf (state-scratch state)(fourth (state-lines state))))
   ((and (eq action '1l)(eq (state-page state) 'legs)(first (state-lines state)))
    (update-route state 0)
    (setf (state-scratch state) "")
    (if (member "DISCONTINUITY" (state-lines state) :test #'equal)
      (setf (state-discontinuity state) '2l)
      (setf (state-discontinuity state) nil))
      (setf (state-mod state) t))
   ((and (eq action '2l)(eq (state-page state) 'legs)(second (state-lines state)))
    (update-route state 1)

    (setf (state-scratch state) "")
    (if (member "DISCONTINUITY" (state-lines state) :test #'equal)
      (setf (state-discontinuity state) '3l)
      (setf (state-discontinuity state) nil))
      (setf (state-mod state) t))
   ((and (eq action '3l)(eq (state-page state) 'legs)(third (state-lines state)))
    (update-route state 2)
    (setf (state-scratch state) "")
    (if (member "DISCONTINUITY" (state-lines state) :test #'equal)
      (setf (state-discontinuity state) '4l)
      (setf (state-discontinuity state) nil))
     (setf (state-mod state) t))
   ((and (eq action '4l)(eq (state-page state) 'legs)(fourth (state-lines state)))
    (update-route state 3)
    (setf (state-scratch state) "")
    (if (member "DISCONTINUITY" (state-lines state) :test #'equal)
      (setf (state-discontinuity state) '5l)
      (setf (state-discontinuity state) nil))
      (setf (state-mod state) t))
   ((eq action 'erase)
    (unless (eq (state-mod state) 'done)
    (setf (state-page state) 'init)
    (setf (state-lines state) '())
    (setf (state-route state) *main-path*)
    (setf (state-mod state) nil)
    (setf (state-nd state) nil)
    (setf (state-scratch state) "")
    (setf (state-discontinuity state) nil)))
   ((eq action 'check)
    (if (equal (state-route state) *dest*) (setf (state-nd state) t)
        (setf (state-nd state) 'error)))
   ((eq action 'exec)
;    (when (or (eq (state-nd state) t)(eq (state-nd state) 'error))
;      (setf (state-mod state) 'done)))

    (if (or (eq (state-nd state) t)(eq (state-nd state) 'error))
      (setf (state-mod state) 'done)
     
      (when (and (not (equal (state-route state) *main-path*))
                 (not (equal (state-route state) *dest*)))
        (setf (state-nd state) 'error
              (state-mod state) 'done))))
;       nil
;        (when (equal (state-route state) *dest*) 
;          (setf (state-nd state) t
;                (state-mod state) 'done))
       
          
   ((eq action 'clr)(setf (state-scratch state) ""))
   ((and (listp action)(eq (first action) 'ttype))
    (setf (state-scratch state) (concatenate 'string (state-scratch state) (second action))))
   ((and (eq action 'page-up) (eq (state-page state) 'legs)(> (state-page-no state) 0))
    (setf (state-page-no state) (1- (state-page-no state)))
    (update-page state))
   ((and (eq action 'page-down)(eq (state-page state) 'legs) (< (state-page-no state) (truncate (/ (length (state-route state)) 4))))
    (setf (state-page-no state) (1+ (state-page-no state)))
    (update-page state))
   )

  (when (null (state-scratch state)) (setf (state-scratch state) "")) 
  (when *verbose*
  (print action)
  (print state)
    )
  (setf *moves* (1+ *moves*))
;  (setf *ops* (permute-list (actions state)))
  state)
;)


(defun current-state (state)
  "Filters out the essential part of the current state. Not exactly elegant yet :("
  (cond 
        ((and (eq (state-nd state) 'error) (eq (state-mod state) 'done)) '("target" "error"))
        ((eq (state-nd state) 'error) '("check" "error"))
        ((not (eq (state-page state) 'legs)) (list  "page" (string (state-page state))))
        ((and (eq (state-nd state) t)(eq (state-mod state) 'done)) '("target" "achieved"))
        ((eq (state-nd state) t) '("check" "ok"))
        ((and (equal (state-scratch state) *dsc*)
              (equal (state-route state) *dsc-list*)
              (state-discontinuity state)) '("scratch" "discontinuity"))
        ((and (state-discontinuity state)(equal (state-scratch state) "")) '("discontinuity" "none")) ; (state-discontinuity state)))
        ((and (eq (state-mod state) t) (equal (state-route state) *dest*)) '("modification" "done"))
        ((and (string= (state-scratch state) *goal-dest*) *from* 
              (member *from* (state-lines state) :test #'string=))
         '("page" "from"))
        ((and (string= (state-scratch state) *goal-dest*) (null *from*)
              (equal (state-page-no state) 0)
              )
         '("page" "from"))
        ((and (string= (state-scratch state) *goal-dest*)
              *from* 
              (equal (state-page-no state) 0))
         '("page" "too-far-from"))
        ((string= (state-scratch state) *goal-dest*) '("scratch" "destination"))
        ((member (state-scratch state) (cons "minde" *main-path*) :test #'equal) (list "scratch" "error")) ; ((list "scratch" (state-scratch state)))
        ((not (equal (state-scratch state) "")) '("scratch" "error"))
        ((and 
          ; (> (state-page-no state) 0) 
          (or (member *goal-dest* (state-lines state) :test #'string=)
              (and *dsc* (null *from*) (equal (state-page-no state) 0))
              (and *from* *dsc* (member *from* (state-lines state) :test #'string=))))
          
         '("page" "dest"))
        ((= (state-page-no state) 2)
             '("page" "too-far-dest"))
        (t '("page" "legs")))

(defun update-window ()
  (if (and (stringp (first (current-state *state*)))(stringp (second (Current-state *state*))))
    (progn
    (add-text-to-exp-window :text (first (current-state *state*)) :x 50 :y 50 :width 100)
    (add-text-to-exp-window :text (second (current-state *state*)) :x 150 :y 50 :width 400))
    (format t "~% Warning: ~S is not a printable state~%" (current-state *state*)))
#|    (when (state-lines *state*)
      (dotimes (i (length (state-lines *state*)))
        (add-text-to-exp-window :text (nth i (state-lines *state*)) :x 50 :y (+ 100 (* 25 i)) :width 400)))
    (when (stringp (state-scratch *state*))
      (add-text-to-exp-window :text (state-scratch *state*) :x 50 :y 225 :width 400)) |#
    )
    

(defun play (&key (discont nil)(pageone t)(direct t)(copilot nil)(wrong nil))
  (setf *transition* nil *reflection* nil *mea* nil *retrieval* nil *prev-state* nil *goal-success* nil *typing* nil
        *dsc-list* nil *dsc* nil *legs* 0 *execs* 0)
  (let ((dest-pos nil))
    (cond ((and (null discont)(null wrong) copilot)
          (setf direct (> (random 3) 0)
                pageone t))
          ((and (null wrong) copilot)
           (setf pageone t direct t))
          ((and wrong copilot (null discont))
           (setf pageone t direct (> (random 9) 3)))
          ((and wrong copilot)
           (setf pageone t direct (> (random 9) 2))))
    (reset-pm-module (get-module :vision))
    (reset-production-compilation (get-module production-compilation))
  (let (
        (goal (new-name "GOAL")))
    (setf *window* (open-exp-window "SimpleFMS" :visible nil))
    (setf *state* (next-state (make-state) 'init))
    (when (or copilot (> (random 1.0) 0.111))
      (setf *state* (next-state *state* 'legs)))
;    (when (and (not direct) (chunk-p-fct 'step11)
;               (= (chunk-creation-time 'step11)  -600))
;      (print "*** Adding step 11 ***")
;      (eval `(sdp :creation-time ,(- (mp-time) 600) :references 8)))
    (cond ((and (null discont)(null wrong) copilot)
           (setf direct (> (random 3) 0)
                 pageone t))
          ((and (null wrong) copilot)
           (setf pageone t direct t))
          ((and wrong copilot (null discont))
           (setf pageone t direct (> (random 9) 3)))
          )

    (cond
     ((and (not discont) direct)   ; simple direct-to
      (setf dest-pos 0)
      (setf *dest* (nthcdr (if pageone (random 3) (+ 4 (random (- (length *main-path*) 5))))  (rest *main-path*)))
      (setf *goal-dest* (first *dest*))
      (setf *from* nil))
     ((and discont direct) ; simple discontinuity
      (setf *dest* (cons "minde" *main-path*))
      (setf dest-pos 0)
      (setf *dsc-list* (cons "minde" (cons "DISCONTINUITY" *main-path*)))
      (setf *dsc* (first *main-path*))
      (setf *goal-dest* (first *dest*))
      (setf *from* nil))
     ((and (not discont)(not direct))
      (let* ((candidate-from (if pageone '(0 1) '(2 4 5 6)))
             (frompos (nth (random (length candidate-from)) candidate-from))
             (destpos (if pageone (- 3 (random (- 2 frompos)))
                          (- (length *main-path*) (1+ (random (- (length *main-path*) (+ 3 frompos))))))))
        (setf dest-pos (1+ frompos))
        (setf *goal-dest* (nth destpos *main-path*))
        (setf *from* (nth frompos *main-path*))
        (setf *dest* (append (subseq *main-path* 0 (1+ frompos)) (subseq *main-path* destpos)))))
     ((and discont (not direct))
      (let* ((candidate-from (if pageone '(0) '(4)))
             (frompos (nth (random (length candidate-from)) candidate-from)))
        (setf *from* (nth frompos *main-path*))
        (setf dest-pos (1+ frompos))
        (setf *goal-dest* "minde")
        (setf *dest* (append (subseq *main-path* 0 (1+ frompos)) (list "minde") (subseq *main-path* (1+ frompos))))
        (setf *dsc-list* (append (subseq *main-path* 0 (1+ frompos)) (list "minde" "DISCONTINUITY") (subseq *main-path* (1+ frompos))))
        (setf *dsc* (nth (1+ frompos) *main-path*)))))
    (cond ((and (null discont)(null wrong) copilot)
           (if (> (random 3) 0)
             (setf (state-scratch *state*) *goal-dest*) ; destination is already in the scratchpad
             (progn
               (setf (state-mod *state*) t
                     (state-route *state*) *dest*)  ; modification is already done
               (update-page *state*))))
          ((and (null wrong) copilot)
           (if (> (random 9) 6)
             (setf (state-scratch *state*) *goal-dest*) ; destination is already in the scratchpad
             (progn
               (setf (state-mod *state*) t)  ; dest in 1l but discontinuity unresolved
               (setf (state-discontinuity *state*) '2l)
               (setf (state-scratch *state*) *goal-dest*)
               (update-route *state* 0)
               (setf (state-scratch *state*) ""))))
          ((and wrong copilot (null discont))
           (if (> (random 9) 5)
             (setf (state-scratch *state*) (concatenate 'string "A" *goal-dest*)) ; typo in scratchpad
             (progn
               (setf (state-mod *state*) t)
               (setf (state-scratch *state*) *goal-dest*)
               (update-route *state* (nth (random 3) (remove dest-pos '(0 1 2 3)))) ; simulate the pressing of a wrong line-key
               (setf (state-scratch *state*) ""))))
           ((and wrong copilot)
            (let ((pb
                   (nth (random 9)
                        (list
                         (list (make-state :page 'legs :lines '("monde" "DISCONTINUITY" "acx" "ksfo") :ROUTE '("monde" "DISCONTINUITY" "acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY '2L :PAGE-NO 0)
                               NIL
                               '("minde" "acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("acx" "ksfo" "fgx" "dibby") :ROUTE '("acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY NIL :PAGE-NO 0)
                               "acx"
                               '("acx" "minde" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("acx" "ksfo" "fgx" "dibby") :ROUTE '("acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY NIL :PAGE-NO 0)
                               "acx"
                               '("acx" "minde" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("minde" "DISCONTINUITY" "acx" "ksfo") :ROUTE '("minde" "DISCONTINUITY" "acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY '2L :PAGE-NO 0)
                               "acx"
                               '("acx" "minde" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("minde" "DISCONTINUITY" "acx" "ksfo") :ROUTE '("minde" "DISCONTINUITY" "acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY '2L :PAGE-NO 0)
                               "acx"
                               '("acx" "minde" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("acx" "minde" "DISCONTINUITY" "ksfo") :ROUTE '("acx" "minde" "DISCONTINUITY" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY '3L :PAGE-NO 0)
                               NIL
                               '("minde" "acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("acx" "minde" "DISCONTINUITY" "ksfo") :ROUTE '("acx" "minde" "DISCONTINUITY" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY '3L :PAGE-NO 0)
                               NIL
                               '("minde" "acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("acx" "ksfo" "fgx" "dibby") :ROUTE '("acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY NIL :PAGE-NO 0)
                               "acx"
                               '("acx" "minde" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))
                         (list (make-state :page 'legs :lines '("acx" "ksfo" "fgx" "dibby") :ROUTE '("acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit") :SCRATCH "" :MOD T :ND NIL :DISCONTINUITY NIL :PAGE-NO 0)
                               NIL
                               '("minde" "acx" "ksfo" "fgx" "dibby" "yng" "cutta" "mufti" "wiile" "starg" "kpit"))))))
              (setf *state* (first pb))
              (setf *from* (second pb))
              (setf *dest* (third pb))
              (setf *goal-dest* "minde"))))

                               
            
;    (print *dest*)
;    (print *from*)
;    (print *goal-dest*)
    (if *actr-enabled-p*
        (progn
          (eval `(add-dm (,goal isa goal task nil expl page expr ,(if (equal *instr* *instr-2*) 'init 'none) goal1l destination goal1r ,*goal-dest* 
                                goal2l ,(if *from* 'replace 'direct) goal2r ,(if *from* *from* "1") exp none)))
          (eval `(goal-focus ,goal))       
        (install-device *window*)
        (update-window)
        (proc-display)
        )
     (progn (update-window)
      (while (not (equal (current-state *state*) "target achieved"))
        (allow-event-manager window))))

)
))

(defmethod rpm-window-key-event-handler ((win rpm-window) key)
  (let ((action))
    (setf *response* (string (if (upper-case-p key) (char-downcase key) key)))
;    (print *response*)
    (cond
     ((and *typing* (equal *response* "z")) (setf action (list 'ttype *typing*)) (setf *typing* nil))
     (*typing* (setf *typing* (concatenate 'string *typing* *response*)))
     ((equal *response* "t") (setf *typing* ""))
     ((equal *response* "l") (setf action 'legs)(incf *legs*)) ; (print "L"))
     ((equal *response* "i") (setf action 'init))
     ((equal *response* "r") (setf action 'route))
     ((equal *response* "e") (setf action 'exec)(incf *execs*))
     ((equal *response* "n") (setf action 'check))
     ((equal *response* "x") (setf action 'erase))
     ((equal *response* "c") (setf action 'clr))
     ((equal *response* "1") (setf action '1l))
     ((equal *response* "2") (setf action '2l))
     ((equal *response* "3") (setf action '3l))
     ((equal *response* "4") (setf action '4l))
     ((equal *response* "u") (setf action 'page-up))
     ((equal *response* "d") (setf action 'page-down)))
;    (print action)
    (when action (setf *state* (next-state *state* action))
          
          (clear-exp-window)
          (update-window)
          (when *actr-enabled-p* 
            (proc-display :clear t)))))

(defun add-lists (l1 l2)
  (cond ((null l1) nil)
        (t (cons (+ (first l1)(first l2)) (add-lists (Rest l1)(rest l2))))))

(defun divide-lists (l1 l2)
  (cond ((null l1) nil)
        ((= (first l2) 0) (cons 0 (divide-lists (Rest l1)(rest l2))))
        (t (cons (/ (first l1)(first l2)) (divide-lists (Rest l1)(rest l2))))))



(defun do-it-12 (&optional instr f cntxt) ;; actually it is 72 with the new tasks
  (when instr (setf *instr* instr))
  (reload)
  
  (sgp :v nil)
  (let ((times nil)(moves nil)(corrects nil) (legs nil) (execs nil) block ct)
    (dotimes (i 36)
      (setf *start-time* (mp-time))
      (setf *moves* 0)
      (let ((j (mod i 12)))
        (when (= j 6)(setf block (permute-list '((play :pageone nil :direct t)
                                                 (play :pageone t :direct nil)
                                                 (play :pageone nil :direct nil))))
              (setf ct "hard"))
        (when (= j 9)(setf block (permute-list '((play :discont t :pageone nil :direct t)
                                                 (play :discont t :pageone t :direct nil)
                                                 (play :discont t :pageone nil :direct nil))))
              (setf ct "harddisc"))

        (when (= j 12)(setf block (permute-list '((c (play :copilot t))(c (play :copilot t))(c (play :copilot t))
                                                  (c (play :copilot t :discont t))(c (play :copilot t :discont t))(c (play :copilot t :discont t))
                                                  (w (play :copilot t :wrong t))(w (play :copilot t :wrong t))(w (play :copilot t :wrong t))
                                                  (w (play :copilot t :wrong t :discont t))(w (play :copilot t :wrong t :discont t))
                                                  (w (play :copilot t :wrong t :discont t))))))
;        (when (= j 12)(setf block (permute-list '((play :copilot t)(play :copilot t)(play :copilot t)
;                                                  (play :copilot t :discont t)(play :copilot t :discont t)(play :copilot t :discont t))))
;              (setf ct "copilot"))
;        (when (= j 18)(setf block (permute-list '((play :copilot t :wrong t)(play :copilot t :wrong t)(play :copilot t :wrong t)
;                                                  (play :copilot t :wrong t :discont t)(play :copilot t :wrong t :discont t)
;                                                  (play :copilot t :wrong t :discont t))))
;              (setf ct "wrongcopilot"))
              
        (cond ((< j 3)(play)(setf ct "direct"))
              ((< j 6)(play :discont t)(setf ct "discon"))
              ((< j 12) (eval (pop block)))
              (t (setf ct (if (eq (first (first block)) 'c) "vcopilot" "wrongcopilot"))
                 (eval (second (pop block)))))
      (run 120)  ; was (run 240) (run 300)
      (close-rpm-window *window*)
;      (close-exp-window)
      (if *goal-success* 
        (progn (push (- (mp-time) *start-time*) times) 
               (push 1 corrects)
               (push *moves* moves)
               (push *legs* legs)
               (push *execs* execs))
        (progn (push 0 times)
               (push 0 corrects)
               (push 0 moves)
               (push 0 legs)
               (push 0 execs)))

      (when f
        (format f "S~D ~D ~A ~A ~7,3F ~D~%"  (if *offset* (+ *offset* cntxt) cntxt)
                (1+ (floor (/ i 24))) (if (equal *instr* *instr-2*) "list" "operator")
                ct (- (mp-time) *start-time*) 
                (if *goal-success* 1 0))
      )))
    
        
    (print (Reverse times))
    (print (reverse moves))
    (print (Reverse corrects))
    (print (reverse legs))
    (print (reverse execs))
    (sdm isa operator task fms)
    (list (reverse times)(reverse moves)(reverse corrects)(reverse legs)(reverse execs))
    ))


(defun do-all (n &optional instr f)
  (let* ((result nil)
         (times (dotimes (i 36 result)(push 0 result)))
         (moves times)
         (corrects times)
         (times2 times)
         (legs times)
         (execs times)
         )
    (dotimes (i n)
      (format t "~%*** Trial ~S ***~%" i)
      (setf result (do-it-12 instr f  i ))
      (setf times (add-lists times (first result)))
      (setf times2 (add-lists times2 (mapcar #'(lambda (x) (* x x)) (first result))))
      (setf moves (add-lists moves (second result)))
      (setf corrects (add-lists corrects (third result)))
      (setf legs (add-lists legs (fourth result)))
      (setf execs (add-lists execs (fifth result))))
    (setf times2 (mapcar #'(lambda (x x2 n)
                             (if (> n 1)
                               (sqrt (/ (- (* n x2) (* x x)) (* n (1- n)))) 0))
                         times times2 corrects))
    (setf times (divide-lists times corrects))
    (setf moves (divide-lists moves corrects))

    (setf legs (divide-lists legs corrects))
    (setf execs (divide-lists execs corrects))

;    (setf corrects2 (mapcar #'(lambda (x)
;                                (sqrt (/ (- (* n x) (* x x)) (* n (1- n))))) corrects))
    (setf corrects (mapcar #'(lambda (x) (/ x n)) corrects))
    (format t "~%")
    (dolist (i times)(format t " ~5,1F ~%" i))
    (format t "~%")
    (dolist (i times2)(format t " ~5,1F ~%" i))
    (format t "~%")
    (format t "~%")
    (dolist (i corrects)(format t " ~6,3F ~%" i))
    (format t "~%")
 ;   (dolist (i corrects2)(format t " ~6,3F ~%" i))    
 ;   (format t "~%")
    (format t "~%")
    (dolist (i moves)(format t " ~5,1F ~%" i))
    (format t "~%")
    (dolist (i legs)(format t " ~5,1F ~%" i))
    (format t "~%")
    (dolist (i execs)(format t " ~5,1F ~%" i))))

(defun do-both (n &optional f)
  (do-all n *instr-1* f)
  (print "&&&&&&&&&&&&&&&&&&&&&&&")
  (do-all n *instr-2* f))

(defun do-both-file (n fname)
  (with-open-file (f fname :direction :output :if-exists :append :if-does-not-exist :create)
                  (do-both n f)))

(defun m ()
  (setf *offset* 0)
  (do-both-file 50 "model1-1-100.txt")
  (setf *offset* 50)
  (do-both-file 50 "model1-51-100.txt")
  (setf *offset* 100)
  (do-both-file 50 "model1-101-150.txt"))


(defun odd (n)
  (not (= (/ n 2)(truncate (/ n 2)))))





(defun repl-nil (x)(if (null x) "none" x))

(defun add-chunks (l)
  (dolist (x l)
    (when (and x (symbolp x)(null (get-chunk x))) (eval `(add-dm (,x isa chunk))))))

(defun parse-instr (in task &optional (retain 1.0))
  (dolist (x in)
    (let* ((forgetp (when (eq (first x) 'x) (pop x)))
           (name (pop x))
           (prel (repl-nil (caar x)))
           (prer (repl-nil (second (pop x))))
           (action (caar x))
           (arg (repl-nil (second (pop x))))
           (postl (repl-nil (caar x)))
           (postr (repl-nil (second (pop x)))))
      (when (or (null forgetp)(< (random 1.0) retain))
        (add-chunks (list prel prer action arg postl postr))
        (eval `(add-dm (,name isa operator task ,task prel ,prel prer ,prer action ,action arg ,arg postl ,postl postr ,postr id ,name)
                       )))
      (eval `(sdp  ,name :creation-time -600 :references 8))     
;      (eval `(sdp  ,name :creation-time -500000 :references 100))
      )
))

(setf *actr-enabled-p* t)

(defun find-chunk (s)
  (let ((result s))
    (dolist (x (chunks) result)
      (when (equal (string-upcase (string x))(string-upcase s)) (return x))))
  )

(defmethod stuff-visloc-buffer ((vis-mod vision-module))
  ;(unless *visual-location*
  
  (unless (buffer-read 'visual-location)
    (awhen (find-current-locs-with-spec vis-mod (default-spec vis-mod))
           ;; not needed (setf (stuffed vis-mod) t)
           (setf (loc-failure vis-mod) nil) ;; added NT 4/21/2005
          
           ;(setf *visual-location*
           (schedule-set-buffer-chunk 'visual-location
                                      (construct-location vis-mod 
                                                          (random-item (objs-max-slotval it 'tstamp))
                                                          (default-spec vis-mod))
                                      0
                                      :module :vision
                                      :requested nil
                                      :priority 10))))

(defstruct operator stuffed)


(defun create-operator (model-name)
  (declare (ignore model-name))
  (make-operator))

(defun reset-operator (instance)
  (format t "Resetting module operator~%")
  
  (sgp :do-not-harvest operator)
 ; (specify-compilation-buffer-type operator goal)

  
  )


(defun query-operator (instance buffer-name slot value)
  (format t "Query made of the operator module: ~S ~S ~S~%"  buffer-name slot value)
     (case slot
       (state
        (case value
          (busy
           nil)
          (free
           t)
          (error
              nil)
          (t
           (print-warning "Unknown state query ~S to test2 module" value)
           nil))
        )
       (buffer
        (if (eql value 'stuffed)
            (operator-stuffed instance)
            (print-warning "unknown buffer query ~S to test2 module" value)
          ))
       
       ))
#|
(defstruct eval stuffed)


(defun create-eval (model-name)
  (declare (ignore model-name))
  (make-eval))

(defun reset-eval (instance)
  (format t "Resetting module eval~%")
  
  (sgp :do-not-harvest eval)
 ; (specify-compilation-buffer-type eval goal)

  
  )


(defun query-eval (instance buffer-name slot value)
  (format t "Query made of the eval module: ~S ~S ~S~%"  buffer-name slot value)
     (case slot
       (state
        (case value
          (busy
           nil)
          (free
           t)
          (error
              nil)
          (t
           (print-warning "Unknown state query ~S to test2 module" value)
           nil))
        )
       (buffer
        (if (eql value 'stuffed)
            (eval-stuffed instance)
            (print-warning "unknown buffer query ~S to test2 module" value)
          ))
       
       ))
|#

;;; Bugfix????

(defmethod update-attended-loc ((vis-mod vision-module))
  ;; if we're tracking or moving around, ignore this 
  (when (or (tracked-obj vis-mod) (moving-attention vis-mod) 
            (eq 'BUSY (exec-s vis-mod)))
    (return-from update-attended-loc nil))
  ;; when do we update?
  ;; [1] when we're looking at an object and it's gone
  ;; [2] when we're looking at nothing and something appears 
  (when (or (and (currently-attended vis-mod)
                 (not (object-present-p vis-mod 
                                        (id (currently-attended vis-mod)))))
            (and (current-marker vis-mod)
                 (null (currently-attended vis-mod))
                 (within-move vis-mod (current-lof vis-mod))))
    
    ;;; Dan
    ;(queue-command
    ; :time (move-attn-latency vis-mod)
    ; :where :VISION
    ; :command 'encoding-complete
    ; :randomize t
    ; :params `(,(current-marker vis-mod) ,(last-scale vis-mod)))
    
    
    ;;; Dan
    (when (current-marker vis-mod) 
    (schedule-event-relative 
     (move-attn-latency vis-mod)
     'encoding-complete
     :destination :vision
     :module :vision
     :params `(,(current-marker vis-mod) ,(last-scale vis-mod))
     :details ;(format nil "~S ~S ~S" 'encoding-complete 
              ;  (id (current-marker vis-mod))
              ;  (last-scale vis-mod))
     (concatenate 'string "Encoding-complete "
       (symbol-name (id (current-marker vis-mod)))
       " " 
       (symbol-name (last-scale vis-mod)))
     :output 'medium)
    
    
    (change-state vis-mod :exec 'busy))))


(clear-all)




(define-module-fct 'operator '(operator) nil
  :version "1.0a1"
  :documentation "operator module"
  :creation #'create-operator
  :reset (list nil #'reset-operator)
  :query #'query-operator
  :request #'goal-style-request)

#|
(define-module-fct 'eval '(eval) nil
  :version "1.0a1"
  :documentation "eval module"
  :creation #'create-eval
  :reset (list nil #'reset-eval)
  :query #'query-eval
  :request #'goal-style-request)
|#
;;;;;********************************************************************************


(setf *instr-1* '(
    (x step1 (page init)(press "l")(page legs))
    (x step2 (page dest)(ttype destination)(scratch destination))
    (x step3 (page dest)(press-line destination)(scratch destination))
    (x step4 (page from)(press direct)(modification done))
    (x step5 (modification done)(press "n")(check ok))
    (x step6 (check ok)(press "e")(target achieved))
    (x step7 (discontinuity none)(press-line-after "DISCONTINUITY")(scratch discontinuity))
    (x step8 (scratch discontinuity)(press-line "DISCONTINUITY")(modification done))
    (x step9 (page legs)(press "d")(page dest))
    (x step10 (scratch destination)(press "u")(page from))
;;; step11 should be added when the first indirect comes up, but act-r6 doesn't allow me an add-dm later on
;    (x step11 (page from)(press-line-after replace)(modification done))
))

(setf *instr-2* '(
    (x step1 (page init)(press "l")(step one))
    (x step2 (step one)(ttype destination)(step two))
    (x step3 (step one)(press-line destination)(step two))
    (x step4 (step two)(press direct)(step three))
    (step3a (step three)(check-not "DISCONTINUITY")(four six))
    (x step5 (step four)(press "n")(step five))
    (x step6 (step five)(press "e")(target achieved))
    (x step7 (step six)(press-line-after "DISCONTINUITY")(step seven))
    (x step8 (step seven)(press-line "DISCONTINUITY")(step eight))
    (x step8a (step eight)(press "e")(step four))
    (x step9 (page legs)(press "d")(page dest))
    (x step10 (scratch destination)(press "u")(page from))
;;; step11 should be added when the first indirect comes up, but act-r6 doesn't allow me an add-dm later on
;    (x step11 (step two)(press-line-after replace)(step three))
))

(when (null *instr*)(setf *instr* *instr-2*))

;;;;;********************************************************************************


(define-model fms

(sgp :esc t :ans .2 :bll 0.5 :rt -0.7 :lf 1 :egs .1 :pl t :sa t :mas 3.0 :trace-detail low :DECLARATIVE-NUM-FINSTS 30
     :DECLARATIVE-FINST-SPAN 3000.0
     :visual-attention-latency 0.4
     :visual-finst-span 100.0 :alpha .4 :ut -10000 
     :epl t :pct t
;    :pm t :mp 10
     :g 120)
; rt was -0.5


(chunk-type goal task statel stater sc expl expr exp action arg eval goal1l goal1r goal2l goal2r)
(chunk-type operator task prel prer action arg postl postr id)
;(chunk-type evaluation task statel stater operator eval) ;;; chunk-type to keep track of state evaluations
(chunk-type dummy)
;(chunk-type eval operator eval exp)
(add-chunks '(check ok target achieved discontinuity scratch modification done error init legs route page destination dest from
              too-far-from too-far-dest fail ok))
(parse-instr *instr* 'fms .75)
;(parse-instr *instr* 'fms 1)
;(set-similarities (fail ok -0.1))

(add-dm (dummy isa dummy)(init isa chunk))
(sdp dummy :creation-time -100 :references 10000)

(p main*init
   =goal>
     isa goal
     task nil
==>
   =goal>
     task fms
   -retrieval>
   +visual>
     isa clear
   -operator>
;   -eval>
)


(p main*perceive-state-attend
   =goal>
     isa goal
     task =task
     statel nil
   ?visual-location>
     - state error
     state free
     buffer empty
   ?visual>
     state free
     buffer empty
==>
   +visual-location>
     isa visual-location
     :attended nil
     screen-x lowest
)

(p main*perceive-state-attend-found-l
   =goal>
     isa goal
     task =task
   ?visual>
     state free
     buffer empty
   =visual-location>
     isa visual-location
     < screen-x 150
==>
   =goal>
     statel nil
   +visual>
     isa move-attention
     screen-pos =visual-location
)

(p main*perceive-state-attend-found-r
   =goal>
     isa goal
     task =task
   ?visual>
     state free
     buffer empty
   =visual-location>
     isa visual-location
     > screen-x 149
==>
   =goal>
     stater nil
   +visual>
     isa move-attention
     screen-pos =visual-location
)


(p main*found-state-string-statel
   =goal>
     isa goal
     task =task
     statel nil
   ?visual>
     state free
;     - state error   ; not  necessary?
   =visual>
     isa text
     value =text
==>
   +visual-location>
     isa visual-location
     :attended nil
     > screen-x 149
   !bind! =state (find-chunk =text)
   =goal>
     statel =state)

(p main*found-state-string-stater
   =goal>
     isa goal
     task =task
     statel =any
     stater nil
   ?visual>
     state free
   =visual>
     isa text
     value =text
==>
   =goal>
     sc t
   !bind! =state (find-chunk =text)
   =goal>
     stater =state
   +visual>
     isa clear
)



(p main*retrieve-operator
   =goal>
     isa goal
     stater =any
     task =task
   ?retrieval>
     state free
     buffer empty
   ?operator>
      buffer empty
   !safe-eval! (null (dm-failed (get-module declarative))) ; tests - state error
==>
   =goal>
     eval nil
   +retrieval>
      isa operator
      task =task
      :recently-retrieved nil
)

(p main*retrieve-operator-after-fail
   =goal>
     isa goal
     stater =any
     eval fail
     task =task
   ?retrieval>
     state free
     buffer empty
     - state error
   =operator>
     isa operator
     task =task
     id =id
==>
   =goal>
     eval nil
   -operator>
   +retrieval>
      isa operator
      task =task
      - id =id
      :recently-retrieved nil
)

(p main*retrieve-operator-after-fail-new-op
   =goal>
     isa goal
     statel =statel
     stater =stater
     eval fail
     task =task
   ?retrieval>
     state free
     buffer empty
     - state error
   =operator>
     isa operator
     task nil
     id =id
     prel =prel
     prer =prer
==>
   =goal>
     eval nil
   =operator>
     task none
   +operator>
     isa operator
     prel =prel
     prer =prer
     postl unknown
     postr unknown
)

(p main*retrieve-operator-fail
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal1l =goal1l
     goal1r =goal1r
     goal2r =goal2r
     action nil
   ?retrieval>
     state error
   !safe-eval! (and (not (equal =stater =goal1r))(not (equal =stater =goal2r)))
==>
   +operator>
     isa operator
     prel =statel
     prer =stater
     postl unknown
     postr unknown
     !eval! (setf (dm-failed (get-module declarative)) nil)
)

(p main*retrieve-operator-fail-goalvar-1
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal1l =goal1l
     goal1r =stater
   ?retrieval>
     state error
==>
   +operator>
     isa operator
     prel =statel
     prer =goal1l
     postl unknown
     postr unknown
   !eval! (setf (dm-failed (get-module declarative)) nil)
)

(p main*retrieve-operator-fail-goalvar-2
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal2l =goal2l
     goal2r =stater
   ?retrieval>
     state error
==>
   +operator>
     isa operator
     prel =statel
     prer =goal2l
     postl unknown
     postr unknown
     !eval! (setf (dm-failed (get-module declarative)) nil)
)


(p main*found-applicable-operator-literal-literal
   =goal>
     isa goal
     task =task
     sc t
     statel =statel
     stater =stater
     goal1l =goal1l
     goal2l =goal2l
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr
   !safe-eval! (and (stringp =arg)(not (equal =goal1l =arg)) (not (equal =goal2l =arg)))
==> 
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr)    

(p main*found-applicable-operator-literal-goal1
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal1l =goal1l
     goal1r =arg
     sc t
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr)

(p main*found-applicable-operator-literal-goal2
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal2l =goal2l
     goal2r =arg
     sc t
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr)



(p main*found-applicable-operator-through-goal1-literal
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal1l =goal1l
     goal1r =stater
     sc t
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =goal1l
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr
   !safe-eval! (and (stringp =arg)(not (equal =goal1l =arg)))
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =goal1l
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr)

(p main*found-applicable-operator-through-goal2-literal
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal2l =goal2l
     goal2r =stater
     sc t
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =goal2l
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr
   !safe-eval! (and (stringp =arg)(not (equal =goal2l =arg)))
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =goal2l
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr)

(p main*found-applicable-operator-through-goal1-goal1
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal1l =goal1l
     goal1r =stater
     sc t
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =goal1l
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =stater
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =goal1l
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr)

(p main*found-applicable-operator-through-goal2-goal2
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal2l =goal2l
     goal2r =stater
     sc t
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =goal2l
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =stater
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =goal2l
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr)


(p main*found-applicable-operator-literal-literal-expectation
   =goal>
     isa goal
     task =task
     expl step   ;;; only allow when expl is a step which means no relationship to external state
     expl =statel
     expr =stater
     goal1l =goal1l
     goal2l =goal2l
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr
   !safe-eval! (and (stringp =arg)(not (equal =goal1l =arg)) (not (equal =goal2l =arg)))

==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr)

(p main*found-applicable-operator-literal-literal-step-init
   "special case for page init"
   =goal>
     isa goal
     task =task
     expl page
     expr init
     expl =statel
     expr =stater
     goal1l =goal1l
     goal2l =goal2l
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr
   !safe-eval! (and (stringp =arg)(not (equal =goal1l =arg)) (not (equal =goal2l =arg)))

==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr)

#|
(p main*found-applicable-operator-literal-literal-inferred-expectation
   =goal>
     isa goal
     task =task
     exp ok
;     expl step   ;;; only allow when expl is a step which means no relationship to external state
     expl =statel
     expr =stater
     goal1l =goal1l
     goal2l =goal2l
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr
   !safe-eval! (and (stringp =arg)(not (equal =goal1l =arg)) (not (equal =goal2l =arg)))

==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =arg
     postl =postl
     postr =postr)
|#

(p main*found-applicable-operator-literal-goal1-expectation
   =goal>
     isa goal
     task =task
     expl =statel
     expl step
     expr =stater
     goal1l =goal1l
     goal1r =arg
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr)

(p main*found-applicable-operator-literal-goal2-expectation
   =goal>
     isa goal
     task =task
     expl =statel
     expl step
     expr =stater
     goal2l =goal2l
     goal2r =arg
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr)
#|
(p main*found-applicable-operator-literal-goal1-inferred-expectation
   =goal>
     isa goal
     task =task
     exp ok
     expl =statel
 ;    expl step
     expr =stater
     goal1l =goal1l
     goal1r =arg
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal1l
     postl =postl
     postr =postr)

(p main*found-applicable-operator-literal-goal2-inferred-expectation
   =goal>
     isa goal
     task =task
     exp ok
     expl =statel
;     expl step
     expr =stater
     goal2l =goal2l
     goal2r =arg
   =retrieval>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr
==>     
  =goal>
    action =action
    arg =arg
    eval ok
;  +retrieval>
;    isa eval
;    operator =id
;    exp fail
  +operator>
     isa operator
     task =task
     prel =statel
     prer =stater
     id =id
     action =action
     arg =goal2l
     postl =postl
     postr =postr)

|#

(p main*found-operator-not-applicable-1
   =goal>
     isa goal
     task =task
     exp =exp
     expl =expl
     expr =expr
     statel =statel
     stater =stater
   =retrieval>
     isa operator
     task =task
     prel =prel
     prer =prer
     id =id
   !eval! (and (not (equal =statel =prel))(or (and (not (equal =exp 'ok))(not (or (equal =expl 'step)
                                                                                     (and (eq =expl 'page)(eq =expr 'init)))
                                                                                 ))(not (equal =expl =prel))))
==>

)

(p main*found-operator-not-applicable-2
   =goal>
     isa goal
     task =task
     exp =exp
     expl =expl
     expr =expr
     statel =statel
     stater =stater
     goal1r =goal1r
     goal2r =goal2r
   =retrieval>
     isa operator
     task =task
     prer =stater2
     id =id
   !eval! (and (not (equal =stater =goal1r))(not (equal =stater =goal2r))
               (not (equal =stater2 =stater))(or (and (not (equal =exp 'ok))(not (or (equal =expl 'step)
                                                                                     (and (eq =expl 'page)(eq =expr 'init)))
                                                                                 ))(not (equal =expr =stater2))))
==>

)

(p main*found-operator-not-applicable-3
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal1l =goal1l
     goal1r =stater
     expr =expr
   =retrieval>
     isa operator
     task =task
     prer =prer
     id =id
   !eval! (and (not (equal =goal1l =prer))(not (equal =expr =prer)))
==>
)

(p main*found-operator-not-applicable-4
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal2l =goal2l
     goal2r =stater
     expr =expr
   =retrieval>
     isa operator
     task =task
     prer =prer
     id =id
   !eval! (and (not (equal =goal2l =prer))(not (equal =expr =prer)))
==>
)
(p main*found-operator-not-applicable-5
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     goal2l =goal2l
     goal1l =goal1l
     expr =expr
   =retrieval>
     isa operator
     task =task
     arg =arg
     id =id
   !eval! (and (not (stringp =arg))(not (equal =goal2l =arg))(not (equal =goal1l =arg)))
==>
)

#|
(p main*found-eval
   =goal>
     isa goal
     eval nil
   =retrieval>
     isa eval
     eval =eval
     exp =exp
==>
   =goal>
     eval ok 
;     eval =eval   ; temporary because we can't deal with failed evals properly yet
     exp =exp)

(p main*eval-retrieval-failure
   =goal>
     isa goal
     action =action
     eval nil
   ?retrieval>
     state error
==>
   =goal>
     eval ok
     exp unknown
     !eval! (setf (dm-failed (get-module declarative)) nil)
     )
|#

(p main*implement-press
   =goal>
     isa goal
     stater =stater
     action press
     arg =key
     eval ok
   ?manual>
     state free
   !safe-eval! (stringp =key)
==>
   +manual>
     isa press-key
     key =key
   =goal>
     sc nil
     action nil
     arg nil
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
)

(p main*implement-press-fail
   =goal>
     isa goal
     stater =stater
     action press
     arg =key
     eval ok
   ?manual>
     state free
   !safe-eval! (not (stringp =key))
==>
   =goal>
     action nil
     arg nil
     eval fail
)


(p main*implement-type-start
   =goal>
     isa goal
     action ttype
     arg =string
     eval ok
==>
   !bind! =type (concatenate 'string "t" =string "Z")
   =goal>
     action type-cont
     arg =type
)

(p main*implement-type-go
   =goal>
     isa goal
     action type-cont
     - arg ""
     arg =string
     eval ok
   ?manual>
     state free
==>
   !bind! =key (subseq =string 0 1)
   !bind! =rest (subseq =string 1)
   +manual>
     isa press-key
     key =key
    =goal>
      arg =rest)

(p main*implement-type-done
   =goal>
     isa goal
     stater =stater
     action type-cont
     arg ""
   ?manual>
     state free
==>
   =goal>
     sc nil
     action nil
     arg nil
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
)

(defun find-key (s x &optional (next-line nil))
  (let ((line
         (cond ((equal (first (state-lines s)) x) 1)
               ((equal (second (state-lines s)) x) 2)
               ((equal (third (state-lines s)) x) 3)
               ((equal (fourth (state-lines s)) x) 4)
               (t nil))))
    (if line (nth (+ line (if next-line 0 -1)) '("1" "2" "3" "4" "5")) nil)))

(p main*implement-press-line
   =goal>
     isa goal
     action press-line
     arg =arg
     eval ok
   !safe-eval! (find-key *state* =arg)
==>
   !bind! =key (find-key *state* =arg)
   =goal>
     action press
     arg =key) 

(p main*implement-press-line-after
   =goal>
     isa goal
     action press-line-after
     arg =arg
     eval ok
   !safe-eval! (find-key *state* =arg)
==>
   !bind! =key (find-key *state* =arg t)
   =goal>
     action press
     arg =key) 

(p main*implement-press-line-fail
   =goal>
     isa goal
     action press-line
     arg =arg
     eval ok
   !safe-eval! (null (find-key *state* =arg))
==>
   =goal>
     eval fail
     action nil
     arg nil
)    

(p main*implement-press-line-after-fail
   =goal>
     isa goal
     action press-line-after
     arg =arg
     eval ok
   !safe-eval! (null (find-key *state* =arg))
==>
   =goal>
     eval fail
     action nil
     arg nil)
 
(spp (main*implement-press-line main*implement-press-line-after main*implement-press-line-fail main*implement-press-line-after-fail)
     :effort 1.0) ; time to scan the lines for a target

(p main*implement-check-not-ok
   =goal>
     isa goal
     statel =statel
     action check-not
     arg =arg
;     eval ok
   =operator>
     isa operator
     postl =postl
     postr =postr
   !safe-eval! (not (equal (find-chunk =arg) =statel))
==>
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
   =goal>
     action nil
     arg nil
     expl step
     expr =postl
   -operator>
)

(p main*implement-check-not-fail
   =goal>
     isa goal
     statel =statel
     action check-not
     arg =arg
;     eval ok
   =operator>
     isa operator
     postl =postl
     postr =postr
   !safe-eval! (equal (find-chunk =arg) =statel)
==>
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
   =goal>
     action nil
     arg nil
     expl step
     expr =postr
   -operator>
)


(p main*target-achieved
   =goal>
     isa goal
     statel target
     stater achieved
   ?operator>
     buffer empty
==>
   !eval! (setf *goal-success* t)
   -retrieval>
   -goal>)


(spp main*target-achieved :success t)

(p main*target-missed
   =goal>
     isa goal
     statel target
     stater error
==>
   -retrieval>
   -goal>)

(spp main*target-missed :success t :failure t)

;;;; Productions to guess an operator
#|
(defun guess-action (goal1l goal1r goal2l goal2r)
  (let*
    ((candidates '((press "n")(press "e")(press "l")(press "x")  
                   (press-line destination)
                   (ttype destination)
                   (press "u")
                   (press "d")
                   (press-line-after "DISCONTINUITY")
                   (press-line "DISCONTINUITY")
                   (press direct)
                   (press-line-after replace)
                   ))
     (pair (nth (random (length candidates)) candidates)))
    (setf *action* (first pair))
    (setf *op-arg* (second pair))
    (setf *arg* *op-arg*)
    (when (eq *op-arg* goal1l)(setf *arg* goal1r))
    (when (eq *op-arg* goal2l)(setf *arg* goal2r))
    (when (member *arg* '(destination replace direct)) (guess-action goal1l goal1r goal2l goal2r))
    ))
|#

(defun guess-action (goal1l goal1r goal2l goal2r)
  (let
    ((candidates '((press "l")(press "x")(press "r")))
     pair)
    (when (and (eq (state-page *state*) 'legs) (equal (state-scratch *state*) "")(not (state-mod *state*)))
      (setf candidates (append '((press-line destination)(ttype destination)) candidates)))
    (when (and (state-mod *state*) (not (state-discontinuity *state*)))
      (setf candidates (append '((press "e")(press "n")) candidates)))
    (when (and (eq (state-page *state*) 'legs)(not (equal (state-page-no *state*) 0)))
      (push '(press "u") candidates))
    (when (and (eq (state-page *state*) 'legs)(not (equal (state-page-no *state*) 2)))
      (push '(press "d") candidates))
    (when (and (state-discontinuity *state*) (equal (state-scratch *state*) ""))
      (push '(press-line-after "DISCONTINUITY") candidates))
    (when (and (state-discontinuity *state*) (not (equal (state-scratch *state*) "")))
      (push '(press-line "DISCONTINUITY") candidates))
    (when (and (not (equal (state-scratch *state*) ""))(not (state-mod *state*)))
      (setf candidates (append '((press direct)(press-line-after replace)) candidates)))
 ;   (print candidates)
    (setf pair (nth (random (length candidates)) candidates))
    (setf *action* (first pair))
    (setf *op-arg* (second pair))
    (setf *arg* *op-arg*)
    (when (eq *op-arg* goal1l)(setf *arg* goal1r))
    (when (eq *op-arg* goal2l)(setf *arg* goal2r))
    (when (member *arg* '(destination replace direct)) (guess-action goal1l goal1r goal2l goal2r))
    ))

(p operator*guess-action
   =goal>
     isa goal
     goal1l =goal1l
     goal1r =goal1r
     goal2l =goal2l
     goal2r =goal2r
   =operator>
     isa operator
     prel =prel
     prer =prer
     action nil
==>
   !eval! (guess-action =goal1l =goal1r =goal2l =goal2r)
   !bind! =action *action*
   !bind! =arg *arg*
   !bind! =op-arg *op-arg*
   =goal>
     action =action
     arg =arg
     eval ok
     exp fail
   =operator>
     id =operator
     action =action
     arg =op-arg
     )

#|
(p main*retrieve-operator-on-expectation
   =goal>
     isa goal
     eval ok
     exp ok
     action nil
     - eval fail
   =operator>
     isa operator
     postl =postl
     postr =postr
==>
   =goal>
     expl =postl
     expr =postr
     statel =postl
     stater =postr
   -operator>
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
)
|#
;;; If there is progress from the pre to the post condition
;;; the progress function gives the task name, otherwise none

(defun progress (prel prer postl postr)
  (let ((pre (hill-climb prel prer))
        (post (hill-climb postl postr)))
    (if (and (not (= pre 99))(> pre post)) 'ok 'fail)))

(defun hill-climb (l r)
  (let* ((right (if (equal r *goal-dest*) 'destination r))
         (result (length (member (list l right)
                                 '((target error)(check error)(page route)(page init)(scratch error)(page too-far-dest)
                                   (page legs)(page dest)(page too-far-from)(scratch destination)
                                   (page from)
                                   (discontinuity none)(scratch discontinuity)(modification done)(check ok)(target achieved))
                                 :test #'equal))))
    (if (= result 0) 99 result)))


(p main*found-state-string-stater-op-new
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     sc t
     - exp ok
     action nil
     - eval fail
   =operator>
      isa operator
      prel =prel
      prer =prer
      id =id
      action =action
      arg =arg
      postl unknown
      postr unknown
   !eval! (or (not (equal =statel =prel))(not (equal =stater =prer)))
==>
   !bind! =eval (progress =prel =prer =statel =stater)
   !bind! =progress (if (eq (progress =prel =prer =statel =stater) 'ok) 'fms 'none)
   !bind! =id2 (let ((ident (eval `(no-output (sdm isa operator task fms action ,=action arg ,=arg prel ,=prel prer ,=prer
                                           postl ,=statel postr ,=stater)))))
                (print (if ident (first ident) =operator)))
   =goal>
     expl =statel
     expr =stater
   =operator>
     task =progress
     postl =statel
     postr =stater
     id =id2
;   +eval>
;     isa eval
;     operator =id
;     eval =eval
;     exp ok
   -operator>
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
)

(p main*found-state-string-stater-op-2a
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     sc t
     - exp ok
     action nil
     - eval fail
   =operator>
      isa operator
      prel =prel
      prer =prer
      -  postl unknown
      postl =expl
      postr =expr
      id =id
   !eval! (or (not (equal =statel =expl))(not (equal =stater =expr)))
==>
;   !bind! =eval (progress =prel =prer =statel =stater)
   =goal>
     expl =expl
     expr =expr
;   +eval>
;     isa eval
;     operator =id
;     eval =eval
;     exp fail
   -operator>
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
)

(p main*found-state-string-stater-op-2b
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     sc t
     - exp ok
     action nil
     - eval fail
   =operator>
      isa operator
      prel =prel
      prer =prer
      postl =statel
      postr =stater
      id =id
==>
;   !bind! =eval (progress =prel =prer =statel =stater)
   =goal>
     expl =statel
     expr =stater
;   +eval>
;     isa eval
;     operator =id
;     eval =eval
;     exp ok
   -operator>
  !eval! (setf (dm-finsts (get-module declarative)) nil)  ; clear the dm-finsts
)

(p main*found-state-string-stater-op-nothing-happended
   =goal>
     isa goal
     task =task
     statel =statel
     stater =stater
     sc t
     - exp ok
     action nil
     - eval fail
   =operator>
      isa operator
      prel =statel
      prer =stater
      action =action
      postl unknown
==>
   =operator>
     task none
     postl =statel
     postr =stater
   +operator>
     isa operator
     prel =statel
     prer =stater
     postl unknown
     postr unknown
)


(spp :successes 5000 :efforts 400000)

(spp main*target-achieved :successes 5000 :efforts 0)
)