(def current-program (comp peek :callstack))

(defn current-line [state]
  (let [[program-name line# [& lines]] (current-program state)]
    (nth lines line#)))

(defn prev-line [state]
  (let [[program-name line# [& lines]] (current-program state)]
    (nth lines (dec line#))))

(defn current-program-name [state]
  (let [[program-name line# [& lines]] (current-program state)]
    program-name))



(defn goto-next-line 
  "Return a new state object where the latest function pointer has
  advanced one line forward."
  [state]
  (let [[program-name line# [& lines]] (current-program state)]
    ;; TODO: perhaps clear the "return" and/or "error" flags.
    (alter-val state :callstack
               (fn [stack]
                 (conj (pop stack) [program-name (inc line#) lines])))))


(defn end-of-program? [state]
  (let [[program-name line# [& lines]] (current-program state)]
    (<= (count lines) line#)))

(defn add-newline! [state program-name expr purpose]
   (let [new-line# (keyword (gensym "line"))]

     (swap! answer-library
            (constantly
             (for [[_ goal [_ name & lines :as program] :as entry] 
                   @answer-library]
               (if-not (= name program-name)
                 entry
                 ['to goal (apply conj
                                  ['program]
                                  program-name
                                  ['line new-line# expr]
                                  lines)])
               )))



     (swap! hacker-notebook #(conj %
                                   ['purpose new-line# expr purpose]))

     (assoc state :return true)
     ))



 (defn replace-line-here 
   "Replace the current line in the currently running program with
   expr, but don't alter the code for the program in the database."
   [expr state]
   (let [
         [_ line# _](current-line state)]

     (let [state*

     (alter-val state :callstack
                (fn [stack]
                  (conj (pop (vec stack))
                        (let [[_ _ lines :as top] (last stack)]
                          (conj (vec (take 2 top))
                                (for [[_line line## goal] lines]
                                  [_line line## (if (= line## line#) expr goal)]))))))]


       state*


       )))




 (defn replace-line!
   "Modify the program with the given name by replacing the line named
   line# with the expression in expr."
   [program-name line# expr]
   (swap! answer-library
          (constantly (for [[_to goal [_program name & lines :as program] :as entry] @answer-library]
                        (if-not (= name program-name)
                          entry

                          [_to goal (apply conj [_program name]
                                           (for [l lines]
                                             (if (= line# (second l))
                                               [(first l) (second l) expr] 
                                               l
                                               )

                                           ))]



                        )))))

(:error state)
(:return state)

(defn successful-return?
  "Returns true if the state is not in error mode, and if (pred
return-val) is true."
  ([state] (successful-return? state (comp not not)))
  ([state pred]
     (and (not (:error state))
          (pred (:return state)))))

(defn execute
  ([state] (execute state false))
  ([state silently?]

  (cond
   (:error state)
   (execute-bug-classifier state)

   (empty? (:callstack state)) state
   (end-of-program? state) (recur (alter-val state :callstack pop) silently?)

   :else
   (let [[program-name line# [& lines]] (peek (get state :callstack))
         goal (nth (current-line state) 2)
         state* (goto-next-line state)
         _ (when (and (not silently?)

                      (#{'make} (first goal))

                      ) (print-current-line! state))
         ]
     (cond (primitive-operator? goal)
           (recur (execute-primitive-operator state goal) silently?)

           (= 'have (first goal))
           (parse-existential state goal)

           :else
           ;; find and iterate over all canned subroutines
           ;; for solving this problem
           (let [
                 strategies
                 (->>
                  @answer-library
                  (map
                   (fn [answer]
                     (if-let
                         [ptn (pattern-match (take 2 answer) ['to goal])]
                       (pattern-bind ptn answer))))
                  (remove nil?)


                  (map
                   (fn [[_ _ [_ program-name & lines]]]
                     (alter-val state* :callstack
                                #(conj % [program-name 0 lines]))

                     ))
                  )

                 ]
             (if (empty? strategies)
               ;; TODO: ask the code-writer to code up a solution
               ;; TODO : call exec on this so that it gets
               ;; passed to the debugger before returning
               (execute-code-writer state)

               ;; TODO: Iteratively evaluate each strategy,
               ;; returning the first result without a fatal
               ;; error. If all results have fatal errors, throw
               ;; a fatal error.
               (execute (first strategies))

               )
             )
           )

     ))))


(defn hacker-solve
  ([scene expr & exprs]

     (let [state {:scene scene
                  :callstack [['USER_INPUT 0
                               (for [e (cons expr exprs)]
                                 ['line (gensym "line") e])
                               ]]}]
       (execute state)


       )))

(defn primitive-operator? [expr]
  (->> expr
       first
       #{'possibly
         'put-on
         'test-not=
         'test-place-for
         'test-cleared-top
         'test-on
         'add-newline!
         'until
         'assign
         'cannot
         'choose
         'and
         }))


(defn execute-primitive-operator [state [f & args :as expr]]
  (let [;;proceed one line forward in the current subroutine
        state* (goto-next-line state)]

    (cond
     (= f 'and)
     (do
       ;;(println "AND" (vec args))
       (assoc state* :return
              (every? successful-return?
                      (map (partial (eval 'hacker-solve) (:scene state))
                           args)))

     )

     (= f 'not)
     (assoc state* :return
            (not (successful-return?
            (execute (:scene state) (first args)))))

     (= f 'test-not=)
     (assoc state* :return (not (apply = args)))

     (= f 'choose)
     (execute-choice state* expr)

     (= f 'possibly)
     (assoc state* :return true) ;;; TODO: Protection mechanism

     (= f 'until)
     ((eval 'execute-until-loop) state (cons f args))

     (= f 'assign)
     ((eval 'execute-assign) state (cons f args))

     (= f 'cannot)
     (let [x ((eval 'hacker-solve) (:scene state) (first args))]
     (if (successful-return? x)
         (assoc state* :error [!failed-conditional (first args)]
                :return (:return x)
                ) state*
                  ))
     :else
     (apply (eval f) state* args))

  ))

(defn toppings
  "Return a list of names of objects on the given surface."
  [scene surface]
  (filter (fn [expr]
            (when-let
                [[f x y pos] expr]
              (and (= 'on f)
                   (= surface y) ;; todo: reference by name/object
                   )))
          (:facts scene)))


(defn vacancies
  ([scene surface object]
     (let [intervals (vacancies scene surface)
           width (get-in scene [:blocks object :width] 0)
           ]


       (->> intervals
            (filter (fn [[a b]] (<= width (- b a))))
            (map (fn [[a b]]
                   (if (Double/isInfinite b) a
                     (/ (+ a b (- width)) 2)
                     ))))))
  ([scene surface]
     (let [toppings (toppings scene surface)
           object-endpoints
           (map (fn [[_ obj _ n]]
                  [n (+ n (get-in scene [:blocks obj :width] 0))])
                (sort-by second toppings))


           left-endpoint (when object-endpoints
                           (apply min 0 (map first object-endpoints)))
           right-endpoint (when object-endpoints
                            (apply max Double/POSITIVE_INFINITY (map second object-endpoints)))


           fenceposts (flatten (concat [0]
                                       object-endpoints
                                       [(get-in scene [:blocks surface :width])]))

           ]

       (remove (partial apply =) ;; remove zero-width intervals
               (partition 2 fenceposts))

       )))


(defn test-place-for [state object surface]
  (assoc state :return
         (-> state
             :scene
             (vacancies surface object)
             first nil? not)))


(defn test-cleared-top [state surface]
  (assoc state :return
         (-> state
             :scene
             (toppings surface)
             empty?)))

(defn test-on [state x y]
  (->> state
       :scene
       :facts
       (filter (partial pattern-match ['on x y]))
       first
       (assoc state :return))
  )

(defn place-for? [scene object surface]
  (first (vacancies scene surface object)))

(defn put-on [state object surface]
  (println "* Putting" object "on" surface)
  (let [;;_ (println object surface)
        scene (get state :scene)
        tops (toppings scene object)

        ] 

    ;;;(println "PUT ON" object surface)
    (if-let [[_ stuff] (first tops)] ;; if the object has stuff on it
      ;; Can't move an object if it has stuff on it.
      (assoc state :error
             [!unsatisfied-prerequisite ['not ['on stuff object]]])

      (if-let [x (first (vacancies scene surface object))]
        (assoc state :scene
               (->
                scene
                ;; remove object from all other surfaces
                (alter-val :facts
                           (partial remove
                                    #(let [[fn x] %]
                                       (and (= 'on fn)
                                    (= x object)))))

                ;; place object on new surface
                (alter-val :facts
                           #(conj %
                                  (list 'on object surface x)
            ;;                      (list 'on object surface) ;; TODO: DXH DANGER HERE
                                  ))

                ))

        (assoc state :error
               [!fatal-error 'ERROR_NO_SPACE_ON_BLOCK surface])))))

(assign [:x :y] (on :x :y))

(defn unbound-vars
  "Returns a list of all variables in the expression."
  [expr]
  (if (coll? expr)
    (distinct (mapcat unbound-vars expr))
    (when (variable? expr) [expr])
    ))



(defn find-all-interpretations
  "Returns a list of all possible ways to bind the unbound variables
in expr to objects in state, without checking whether the bindings
make logical sense."
  ([state expr]
     (let [
           vars (unbound-vars expr)
           universe (-> state
                        :scene
                        :blocks
                        keys)
           ]

       (loop [open vars accumulated [expr]]

         (if (empty? open)
           accumulated
           (recur
            (rest open)
            (for [e accumulated
                  x universe]
              (pattern-bind {(first vars) x} e))))))))

(defn execute-assign [state expr]
  (let [[_assign variables expr*] expr
        state* (goto-next-line state)

        candidates (->> expr*
                        (find-all-interpretations state*)
                        (map (comp
                              (partial (eval 'hacker-solve) (:scene state*))
                              (partial vector 'test)))

                        (filter :return))


        candidate (when-let [x (first candidates)]
                    (->> x :return
                         (pattern-match expr*)
                         (filter-keys (set variables))))

        ;;_ (println "ASSIGN" expr* (->> expr* (find-all-interpretations state)))

        ]
    (assoc state* :return candidate)


    ))

(defn parse-existential [state goal]
  (if-let [[_ vars expr] goal]

    (let [matching-facts
          (map (comp #(pattern-align % expr) second)
                  @blocksworld-knowledge)]

      (assoc state :return
             (some (comp not nil?) matching-facts)))))

(defn parse-in-environment
  "If the fact has any qualifications or environmental conditions,
  returns a (potentially empty) list of all the ways of making them
  hold. Otherwise, returns a singleton list containing fact."
  [state fact]


  (let [[_fact goal & environment] fact]
    (if-let [e (first environment)]
      (let [;;_ (clojure.pprint/pprint ["ENV" fact e] )
            [_have vars condition & exprs :as existential] e
            ]   
        ;; SEARCHING FOR SOLUTIONS TO EXISTENTIAL QUANTIFIER
      (->> @blocksworld-knowledge
           (map (fn [[_fact x :as entry]]

                  (when-let [bind (pattern-match* condition x)]
                    (if-let [e (first exprs)]
                      (let [reverse-bind (exchange-keyvals (apply dissoc bind vars))
                            command (pattern-bind reverse-bind (pattern-bind bind (thread-in goal e)))

                            ;_ (println [condition x (pattern-match* condition x)])
                            ]

                        (apply (eval (first command)) (rest command))

                        )
                      goal)

                    )
                  ))

           (remove nil?)           
           ))

           [goal]

  )))

(defn execute-bug-classifier [state]


  (cond
   (= !failed-conditional (first (:error state)))
   state

   (= !fatal-error (first (:error state)))
   state

   :prerequisite-missing
   (let [_   (println "error" (:error state))
         [_ line# goal :as badline] (prev-line state)
         matching-prereqs
         (->> @blocksworld-knowledge
              (map (fn [answer]
                     (when-let [ptn (pattern-match 
                                        (take 2 (second answer))
                                        ['prerequisite goal])]
                       (pattern-bind ptn answer)

                            )))
              (remove nil?)
              )

         test-prereqs
         (for [fact* (take 2 matching-prereqs)
               fact (find-all-interpretations state fact*)]
           (let [[_fact [_prereq _ goal*] & preconditions] fact]

             ;; TODO: LESS KLUDGY PRECONDITION CHECK
             (when (or (empty? preconditions)
                       (successful-return?
                        (hacker-solve (:scene state)
                                      (first preconditions))))
               [(hacker-solve (:scene state) ['test goal*]) goal*])

             ))      
         ]
       ;; (map (partial take 2) @blocksworld-knowledge))

     (if-let [bug-cause (some (fn [[ret goal]] (and (successful-return? ret not) goal))
                              (remove nil? test-prereqs))]

       (execute-patch (assoc state :error ['!prerequisite-missing (current-program-name state) (second (prev-line state))  bug-cause]))

       (alter-val state :error (partial vector !fatal-error)))


     ;;state

     )))

(defn find-program-by-name [program-name]
  (->> @answer-library
       (map (fn [[_ _ [_ name & _ :as program]]]
              (when (= name program-name)
                program)))
       (some identity)))


(defn refresh-program
  "Replace the top program on the stack with its most up-to-date
  version, and reset the function pointer to the start of that
  program."  
  [variables state]


  (if-let [[_ program-name & lines]
        (pattern-bind (exchange-keyvals variables)
                      (find-program-by-name (current-program-name state)))
        ]


    (-> state
        (alter-val :callstack
                   (fn [stack]
                     (conj (pop stack) 
                           [program-name 0 (map vec lines)])))

        (dissoc :error)
        )


    state
    ))

(defn current-program-bindings
  "Return a list of bindings made by the top function pointer on the stack."
  [state]
  (let [program (current-program state)
        [_ _ & lines]  (find-program-by-name (first program))]
    (pattern-match* (nth program 2) lines)
    ))

(defn execute-patch [state]
  (println "patching error: " (:error state))

  (let [[bug-type program-name line# arg :as error] (:error state)
        variables (current-program-bindings state)
        var-error (pattern-bind variables error)
        matching-patches
        (->> @patch-types
             (map (fn [answer]
                    (when-let [ptn (pattern-match
                                  (take 2 (second answer))
                                  ['patch var-error])]
                      (pattern-bind ptn answer))))
             (remove nil?)

             )


        ]

    (if-not variables
      (assoc state :error [!fatal-error "Patcher can't unbind variables."])
      (-> (some identity matching-patches) ;; TODO: search over /all/ patches
          second
          (nth 2)
          ((partial hacker-solve (:scene state)))
          :return
          (when (execute (refresh-program variables state)))
          )

        )))