;; find a path through a 10x10 maze using the A* search algorithm
;; knowledge engineer: 
;; date
;; comments

;; the fundametal position facts
(deftemplate position
  (slot type (allowed-symbols start goal block))
  (slot row)
  (slot column)
)

;; === maze rules ===============
(defrule success
  (declare (salience 550))                       ;; stop ASAP
  (position (type goal)(row ?gr)(column ?gc))
  (open ?pCost ?pVal ?sr ?sc $?path ?gr ?gc)
=>
  (printout t "We go from [" ?sr "," ?sc  "] to [" ?gr "," ?gc 
              "] in " ?pCost " moves on the path below:" crlf)
  (bind ?pos 1)
  (while (< ?pos (length$ $?path))
     (printout t " [" (nth$ ?pos $?path) "," (nth$ (+ 1 ?pos) $?path) "]")
     (bind ?pos (+ 2 ?pos)))
  (printout t crlf)
  (halt)
)               

;; --- heuristic - expected Manhattan distance to solution
(deffunction distance(?r1 ?c1 ?r2 ?c2)
  (return (+ (abs (- ?r1 ?r2))(abs (- ?c1 ?c2)))))

;; -- initialize open to start location
(defrule start
  (position (type start)(row ?sr)(column ?sc))
  (position (type goal) (row ?gr)(column ?gc))
=>
  (assert (open 0 (distance ?sr ?sc ?gr ?gc) ?sr ?sc)))

;; --- expand xurrent loc in all four directions (if indices OK)
;; --- will try to put epansion paths on open list (A* will check)
(defrule move
    (position (type goal)(row ?gr)(column ?gc))
?f<-(expand ?pCost ?pVal $?path ?r ?c)
=>
  (retract ?f)
  (if (< ?r 10) then
    (assert (put-open (+ 1 ?pCost)(distance (+ ?r 1) ?c ?gr ?gr)
                      $?path ?r ?c (+ ?r 1) ?c)))
  (if (> ?r 1) then
     (assert (put-open (+ 1 ?pCost)(distance (- ?r 1) ?c ?gr ?gr)
                       $?path ?r ?c (- ?r 1) ?c)))
  (if (< ?c 10) then
     (assert (put-open (+ 1 ?pCost)(distance ?r (+ ?c 1) ?gr ?gr)
                       $?path ?r ?c ?r (+ ?c 1))))
  (if (> ?c 1) then
     (assert (put-open (+ 1 ?pCost)(distance ?r (- ?c 1) ?gr ?gr)
                       $?path ?r ?c ?r (- ?c 1))))
)

;; --- immediately reject any path ending in blockeed position
(defrule blocked
    (declare (salience 600))
    (position (type block)(row ?r)(column ?c))
?f<-(put-open $? ?r ?c)
=>
  (retract ?f))

;;======== A star serach rules ==============
;; -- choose the open node with minimal value to expand
;;    also make it closed now
(defrule choose-open
?f<-(open ?pCost ?pVal $?path ?r ?c)
    (forall (open ?pcx ?pvx $?px ?rx ?cx)
            (test (>= (+ ?pcx ?pvx)(+ ?pCost ?pVal))))
=>
  (retract ?f)
  (assert (closed ?pCost ?pVal $?path ?r ?c)
          (expand ?pCost ?pVal $?path ?r ?c)))

;;-- put-open is for a new location
;;   just make it open
(defrule new-open-loc
    (declare (salience 500))
?f<-(put-open $?x ?r ?c)
    (not (open $? ?r ?c))
    (not (closed $? ?r ?c))
=>
  (retract ?f)
  (assert (open $?x ?r ?c)))

;;-- put-open is for a location already open
;;   if the new path is cheaper, drop the old & make the new open
;;     otherwise just forget it
(defrule already-open
    (declare (salience 500))
?f<-(put-open ?pCost1 ?val1 $?path1 ?r ?c)
?g<-(open ?pCost2 ?val2 $?path2 ?r ?c)
=>
  (if (< (+ ?pCost1 ?val1)(+ ?pCost2 ?val2))
   then (retract ?g ?f)
        (assert (open ?pCost1 ?val1 $?path1 ?r ?c))
   else (retract ?f)))

;;-- put-open is for a location already closed
;;   if the new path is cheaper, drop the old & make the new open
;;     otherwise just forget it
(defrule already-closed
    (declare (salience 500))
?f<-(put-open ?pCost1 ?val1 $?path1 ?r ?c)
?g<-(closed ?pCost2 ?val2 $?path2 ?r ?c)
=>
  (if (< (+ ?pCost1 ?val1)(+ ?pCost2 ?val2))
   then (retract ?g ?f)
        (assert (open ?pCost1 ?val1 $?path1 ?r ?c))
   else (retract ?f)))  

;;=== operational functions ========
;; --- start the search
(deffunction start ()
  (reset)
  (run 1000)
)

;; -- report failure when all other rules are exhausted!
(defrule no-path
  (declare (salience -10))
  (position (type start)(row ?sr)(column ?sc))
  (position (type goal) (row ?gr)(column ?gc))
=>
  (printout t "There was NO path from [" ?sr "'" ?sc " to [" ?gr "," ?gc "] !!" crlf))