;;; -*- Mode: Xbvl;; Syntax: Common-Lisp;; -*-
; Code adapté de Paradigms of Artificial Intelligence Programming de Peter Norvig

;;; File gpsplus.vlisp: version intermédiare de GPS

(include "gps")

;;; ============================== 

(de GPS (state goals ops)
 (let  ((*ops* (or ops *ops*)))
  ;General Problem Solver: 
  ; à partir d'un état atteindre les buts en utilisant *ops*.
  (find-all-if 'action-p
	       (achieve-all (cons '(start) state) goals nil))))

(de action-p (x)
  ; est-ce que x est de la forme (start) ou (executing ...) ?
  (or (equal x '(start)) (executing-p x)))

;;; ==============================

(de find-path (start end)
  ; chercher un chemein de start evrs end dans un labyrinthe
  (let ((results (GPS `((at ,start)) `((at ,end)))))
    (unless (null results)
      (cons start (mymapcar 'destination
                          (delete '(start) results
                                   ))))))

(de destination (action)
  ; trouve le Y dans (executing (move from X to Y)) 
  (fifth (second action)))

;;; ==============================
(defmacro myattach (var val)
  `(if (null ,var)(setq ,var (cons ,val nil)) (attach ,val ,var)))

(de make-block-ops (blocks)
  (let ((ops nil))
    (dolist (a blocks)
      (dolist (b blocks)
        (unless (equal a b)
          (dolist (c blocks)
            (unless (or (equal c a) (equal c b))
              (myattach ops (move-op a b c))))
          (myattach ops (move-op a 'table b))
          (myattach ops (move-op a b 'table)))))
    ops))

(de move-op (a b c)
  ; cré un opérateur pour mettre A de B vers C
  (op `(move ,a from ,b to ,c)
       `((space on ,a) (space on ,c) (,a on ,b))
       (move-ons a b c)
       (move-ons a c b)))

(de move-ons (a b c)
  (if (eq b 'table)
      `((,a on ,c))
      `((,a on ,c) (space on ,b))))

;;; ==============================

(de gpsplus ()
    (gps)
    (print '(find-path 1 25))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (print (find-path 1 25))
    (print '(find-path 1 5))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (print (find-path 1 5))
    (print '(equal (find-path 1 25)(reverse (find-path 25 1))))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (print (equal (find-path 1 25)(reverse (find-path 25 1))))    
    (print '(use (make-block-ops '(a b))))
    (print (use (make-block-ops '(a b))))

    (print '(GPS '((a on table)(b on table)(space on a)(space on b)(space on table))
		 '((a on b)(b on table))))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (printres (GPS '((a on table)(b on table)(space on a)(space on b)(space on table))
		 '((a on b)(b on table))))

    (print '(GPS '((a on b)(b on table)(space on a)(space on table))
		 '((b on a))))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (printres (GPS '((a on b)(b on table)(space on a)(space on table))
		 '((b on a))))

    (print '(use (make-block-ops '(a b c))))
    (print (use (make-block-ops '(a b c))))
    (print '(GPS '((a on b)(b on c)(c on table)(space on a)(space on table))
		 '((b on a)(c on b))))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (printres (GPS '((a on b)(b on c)(c on table)(space on a)(space on table))
		 '((b on a)(c on b))))

    (print '(GPS '((a on b)(b on c)(c on table)(space on a)(space on table))
		 '((c on b)(b on a))))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (printres (GPS '((a on b)(b on c)(c on table)(space on a)(space on table))
		 '((c on b)(b on a))))

    (print '(GPS '((c on a)(b on table)(a on table)(space on c)(space on b)(space on table))
		 '((c on table))))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (printres (GPS '((c on a)(b on table)(a on table)(space on c)(space on b)(space on table))
		 '((c on table))))

    (print '(GPS '((c on a)(a on table)(b on table)(space on c)(space on b)(space on table))
		 '((c on table)(a on b))))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (printres (GPS '((c on a)(a on table)(b on table)(space on c)(space on b)(space on table))
		 '((c on table)(a on b))))

 ;   (print "le probleme de Sussman :")
 ;   (print '(GPS '((c on a)(a on table)(b on table)(space on c)(space on b)(space on table))
;		 '((a on b)(b on c))))
;    (print "voulez-vous une trace ? (y/n)") 
;    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
;    (printres (GPS '((c on a)(a on table)(b on table)(space on c)(space on b)(space on table))
;		 '((a on b)(b on c))))

;    (print '(GPS '((c on a)(a on table)(b on table)(space on c)(space on b)(space on table))
;		 '((b on c)(a on b))))
;    (print "voulez-vous une trace ? (y/n)") 
;    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
;    (printres (GPS '((c on a)(a on table)(b on table)(space on c)(space on b)(space on table))
;		 '((b on c)(a on b))))

    (print '(use (attach (op 'taxi-son-to-school '(son-at-home have-money) '(son-at-school)
			     '(son-at-home have-money)) *school-ops*)))
    (use (attach (op 'taxi-son-to-school '(son-at-home have-money) '(son-at-school)
			     '(son-at-home have-money)) *school-ops*))
    (print '(GPS '(son-at-home have-money car-works) '(son-at-school have-money)))
    (print "voulez-vous une trace ? (y/n)") 
    (if (eq (tyi) 121)(debug 'gps)(undebug 'gps)) 
    (printres (GPS '(son-at-home have-money car-works) '(son-at-school have-money)))
    "that's all")