;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Written by Steve Wayde
;;; for Dr. Roger W. Webster
;;; 2/27/94
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;; given the current state,
;;;; the position of the hole,
;;;; and the position of both
;;;; pegs, determine if it is
;;;; a valid jump or move
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun jump (board hole peg1 peg2)
   (cond ((and (eq (nth hole board) 0) (eq (nth peg1 board) 1) (eq (nth peg2 board) 1))
              (setq board (substitute 1 0 board :start hole :end (1+ hole)))
              (setq board (substitute 0 1 board :start peg1 :end (1+ peg1)))
              (setq board (substitute 0 1 board :start peg2 :end (1+ peg2))) )
    
   )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; finds all of the 
;;; successors for the 
;;; current state
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun successors (board)
   (let (Alist counter board-length result item)
   (setq board-length (length board))
   (setq counter 0)
   (setq Alist '() )
   (loop
      (if (> counter board-length) (return T))
      (case counter
         ((0)  (setq result (jump board 0 1 3)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 0 2 5)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((1)  (setq result (jump board 1 3 6)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 1 4 8)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((2)  (setq result (jump board 2 4 7)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 2 5 9)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((3)  (setq result (jump board 3 1 0)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 3 7 12)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 3 6 10)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 3 4 5)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((4)  (setq result (jump board 4 7 11)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 4 8 13)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((5)  (setq result (jump board 5 8 12)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 5 4 3)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 5 2 0)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 5 9 14)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((6)  (setq result (jump board 6 7 8)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 6 3 1)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((7)  (setq result (jump board 7 4 2)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 7 8 9)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((8)  (setq result (jump board 8 7 6)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 8 4 1)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((9)  (setq result (jump board 9 8 7)) (if (not (null result)) (setq Alist (append Alist (list result))))
                 (setq result (jump board 9 5 2)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((10) (setq result (jump board 10 6 3)) (if (not (null result)) (setq Alist (append Alist (list result))))
                  (setq result (jump board 10 11 12)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((11) (setq result (jump board 11 7 4)) (if (not (null result)) (setq Alist (append Alist (list result))))
                  (setq result (jump board 11 12 13)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((12) (setq result (jump board 12  7 3)) (if (not (null result)) (setq Alist (append Alist (list result))))
                  (setq result (jump board 12 8 5)) (if (not (null result)) (setq Alist (append Alist (list result))))
                  (setq result (jump board 12 11 10)) (if (not (null result)) (setq Alist (append Alist (list result))))
                  (setq result (jump board 12 13 14)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((13) (setq result (jump board 13 12 11)) (if (not (null result)) (setq Alist (append Alist (list result))))
                  (setq result (jump board 13 8 4)) (if (not (null result)) (setq Alist (append Alist (list result)))))
         ((14) (setq result (jump board 14 13 12)) (if (not (null result)) (setq Alist (append Alist (list result))))     
                  (setq result (jump board 14 9 5)) (if (not (null result)) (setq Alist (append Alist (list result)))))
       )
    (setq counter (1+ counter))
  )
  (setq result Alist)
)
)

(defun get-width (treewin open)
  (let ( (level 1))
;;;  (if (or (eql heuristic 1) (eql heuristic 2) (eql heuristic 3))
                ;;; breadth first, sequence score, or places away
     (loop
	(if (null (gethash level (g-value treewin :node-levels)))
		(return level)
	     (setq level (+ 1 level)))
     )
	(setq level (- level 2))

     	(s-value treewin :max-width-oftree 
		(+ (- (length open) 1) level))
  )
)

(defun get-path (goal_node pointers view-tree treewin)
   (let (solution)
	(setq solution (extract_path goal_node pointers))
	(if view-tree 
	    (print-tree treewin (write-to-string solution) pointers))
	(print solution)
   )	
)

(defun extract_path (N pointers)
 	(COND ((equal N (list 0 0 0 0 0 0 0 0 0)) nil)
        	(T (APPEND (EXTRACT_PATH  (gethash N pointers) pointers)
                   (LIST N) )) )
 )


(defun select_best (lst fvalue goal_node) 
 	(cond ((eq (car lst) goal_node)(car lst))
        (T (better (car lst)(cdr lst) fvalue goal_node)) ) 
)
 
(defun better (elt lst fvalue goal_node)  ;;; this funct.  
  	(cond ((null lst) elt)
        ((< (gethash elt fvalue)(gethash (car lst) fvalue)) elt)  
      		((EQ (car lst) goal_node)(car lst))
        (T (better elt (cdr lst) fvalue goal_node)) )
 )

(defun insert (node lst val fvalue)  ;;;added extra parameter val
  (cond ((null lst)(list node))
	((< val (gethash (car lst) fvalue))
	 (cons node lst))
	(T (cons (car lst) (insert node (cdr lst) val fvalue))) ) 
)


(defun cdr_select (key lst)
	(cond   ( (null lst) 9999)
	        ( (eq key (caar lst)) (cdar lst) )
		(t (cdr_select key (cdr lst) ) )
        )

)
 
(defun put-successors-on-tree (L treewin pointers)
  (prog (x)
    loop  (cond ((NULL L) (return nil)))
	(put-leaf-on-tree treewin (car L) (gethash (car L) pointers) 5)
	(setq L (cdr L))
	(go loop)
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; heuristic which computes
;;; better heuristic values
;;; if the pegs are in the
;;; corner positions of the
;;; triangle.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun corners (N)
   (prog (result)
     (setq result 0)
     (if (eq (nth 0 N) 0) (setq result (+ 1 result)))
     (if (eq (nth 10 N) 0) (setq result (+ 1 result)))
     (if (eq (nth 14 N) 0) (setq result (+ 1 result)))
     (return result)
   )
)  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; heuristic which computes
;;; better heuristic values
;;; for having pegs in the 
;;; inside of the triangle.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun inside (N)
   (prog (result)
      (setq result 0)
      (if (eq (nth 4 N) 1) (setq result (+ 5 result)))
      (if (eq (nth 7 N) 1) (setq result (+ 5 result)))
      (if (eq (nth 8 N) 1) (setq result (+ 5 result)))
      (return result)
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; heuristic which computes
;;; good heuristic values for
;;; having pegs in the inside
;;; and in the corners of 
;;; the triangle.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun in-and-corners (N)
   (prog (result)
      (setq result 0)
      (if (eq (nth 4 N) 1) (setq result (+ 1 result)))
      (if (eq (nth 7 N) 1) (setq result (+ 1  result)))
      (if (eq (nth 8 N) 1) (setq result (+ 1  result)))
     (if (eq (nth 0 N) 0) (setq result (1+ result)))
     (if (eq (nth 10 N) 0) (setq result (1+ result)))
     (if (eq (nth 14 N) 0) (setq result (1+ result)))
      (return result)
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; counts the number of ones
;;; in the current state
;;; used to determine the 
;;; number of pegs left.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun count-ones (N)
    (let (count)
     (setq count 0)
     (loop
       (if (null N) (return count))
       (if (eq (first N) 1) (setq count (1+ count)))
       (setq N (rest N))
     )
   )
)
       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; heuristic which computes
;;; better values when the pegs
;;; are on the outside of the
;;; triangle.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun outside (N)
   (prog (result)
      (setq result 0)
      (if (eq (nth 0 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 1 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 2 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 3 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 5 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 6 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 9 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 10 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 11 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 12 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 13 N) 0) (setq result (+ 1 result)))
      (if (eq (nth 14 N) 0) (setq result (+ 1 result)))
      (return result)
  )
)



 (defun inside-corners (N)
   (prog (result)
      (setq result 0)
      (if (and (> (count-ones N) 1) (eq (nth 1 N) 0))
		 (setq result (+ 10 result)))
      (cond 
         ( (> (count-ones N) 10) (setq result  (outside N) ))
;         ( (> (count-ones N) 7)
;          (if (and (eq (nth 3 N) 1)  (eq (nth 6 N) 1) (eq (nth 7 N) 1))
;		 (setq result (1+ result)))
;          (if (and (eq (nth 5 N) 1)  (eq (nth 8 N) 1) (eq (nth 9 N) 1))
;		 (setq result (1+ result)))
;          (if (and (eq (nth 1 N) 1)  (eq (nth 3 N) 1) (eq (nth 4 N) 1)) 
;		(setq result (1+ result)))
;          (if (and (eq (nth 2 N) 1)  (eq (nth 4 N) 1) (eq (nth 5 N) 1))
;		 (setq result (1+ result))))
;        ( (> (count-ones N) 4)  (setq result (inside N)))
        (t (setq result (- (* (inside N) 3) (corners N))))
      )
      (return result)
  )
)


(defun solve (object-xx item-pressed)
 (let (work mywindow current-state treewin tree-on heuristic select-message)
 (setq mywindow (g-value object-xx :window))
 (setq tree-on (g-value mywindow :tree-on))
 (setq heuristic (g-value mywindow :heuristic))
 (setq select-message (g-value mywindow :select-message))
 (s-value select-message :STRING "Solving...")
 (s-value mywindow :select-message select-message)
 (opal:update mywindow)
 (setq current-state (g-value mywindow :current-state))
 (cond ((not (null tree-on)) (setf treewin (create-treewindow))
        (case heuristic
          ((1) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) t treewin 'outside)) (s-value treewin :title "Animation of Tree Nodes - Heuristic: Outside"))
          ((2) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) t treewin 'inside)) (s-value treewin :title "Animation of Tree Nodes - Heuristic: Inside"))
          ((3) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) t treewin 'corners)) (s-value treewin :title "Animation of Tree Nodes - Heuristic: Corners"))
          ((4) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) t treewin 'inside-corners)) (s-value treewin :title "Animation of Tree Nodes - Heuristic: Inside & Corners"))
        )
        (s-value mywindow :treewin treewin)
       )
       (t (case heuristic
          ((1) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) nil nil 'outside)))
          ((2) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) nil nil 'inside)))
          ((3) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) nil nil 'corners)))
          ((4) (setq work (best-first current-state '(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0) nil nil 'inside-corners)))
        )
       )

 )
 (s-value select-message :STRING "Done...")
 (s-value mywindow :select-message select-message)
 (opal:update mywindow)
 (print "Solution path")
 (if (listp work) (print work) (print "No Solution"))
 (s-value mywindow :move-list work)
 (if (listp work) (s-value mywindow :next-move (first work)))
 (opal:update mywindow)

))