Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- (defun run-breadth (start goal moves)
- (declare (special *open*))
- (declare (special *closed*))
- (declare (special *goal*))
- (setq *open* (list (build-record start nil)))
- (setq *closed* nil)
- (setq *goal* goal)
- (breadth-first moves))
- ;;; These functions handle the creation and access of (state parent)
- ;;; pairs.
- (defun build-record (state parent) (list state parent))
- (defun get-state (state-tuple) (nth 0 state-tuple))
- (defun get-parent (state-tuple) (nth 1 state-tuple))
- (defun retrieve-by-state (state list)
- (cond ((null list) nil)
- ((equal state (get-state (car list))) (car list))
- (t (retrieve-by-state state (cdr list)))))
- (defun breadth-first (moves)
- (declare (special *open*))
- (declare (special *closed*))
- (declare (special *goal*))
- (cond ((null *open*) nil)
- (t (let ((state (car *open*)))
- (setq *closed* (cons state *closed*))
- (cond
- ;;; found solution: print path to it
- ((equal (get-state state) *goal*) (reverse (build-solution *goal*)))
- ;;; try next child state
- (t (setq *open*
- (append (cdr *open*)
- (generate-descendants (get-state state)
- moves)))
- (breadth-first moves)))))))
- (defun generate-descendants (state moves)
- (declare (special *open*))
- (declare (special *closed*))
- (cond ((null moves) nil)
- (t (let ((child (funcall (car moves) state))
- (rest (generate-descendants state (cdr moves))))
- (cond ((null child) rest)
- ((retrieve-by-state child rest) rest)
- ((retrieve-by-state child *open*) rest)
- ((retrieve-by-state child *closed*) rest)
- (t (cons (build-record child state) rest)))))))
- (defun build-solution (state)
- (declare (special *closed*))
- (cond ((null state) nil)
- (t (cons state (build-solution
- (get-parent
- (retrieve-by-state state *closed*)))))))
- (defvar *initial* '((0 2) (4 0) ((2 1) (3 1) (2 3)) ((0 0) (3 3)))) ;; ((Px Py) (Kx Ky) ((D1x D1y) (D2x D2y)(D3x D3y)) ((Z1x Z1y) (Z2x Z2y)(Z3x Z3y)))
- ;(defvar *initial* '((0 2) (4 0) ((2 1) (3 1) (3 3)) ((2 2) (3 2) (2 3)))) ;; plus test primer
- (setq king (car *initial*))
- (setq queen (car(cdr *initial*)))
- (setq ghostlist (car(cdr(cdr *initial*))))
- (setq dragonlist (car(cdr(cdr(cdr *initial*)))))
- (defun make-state (x y)
- (list x y)
- )
- (defun safe (state)
- (cond
- ((eq (safeFromDragons dragonlist state) nil) nil)
- ((or (< (car state) 0)(> (car state) 4)(< (car(cdr state)) 0)(> (car (cdr state)) 4)) nil)
- (t state)
- )
- )
- (defun safeFromDragons (dragonlist state)
- (cond
- ((null dragonlist) t)
- ((or (equal state (make-state (+ (car(car dragonlist)) 1)(car(cdr(car dragonlist)))))
- (equal state (make-state (- (car(car dragonlist)) 1)(car(cdr(car dragonlist)))))
- (equal state (make-state (car(car dragonlist))(+ (car(cdr(car dragonlist))) 1)))
- (equal state (make-state (car(car dragonlist))(- (car(cdr(car dragonlist))) 1)))
- (equal state (make-state (+ (car(car dragonlist)) 1)(+ (car(cdr(car dragonlist)))1)))
- (equal state (make-state (+ (car(car dragonlist)) 1)(- (car(cdr(car dragonlist)))1)))
- (equal state (make-state (- (car(car dragonlist)) 1)(+ (car(cdr(car dragonlist)))1)))
- (equal state (make-state (- (car(car dragonlist)) 1)(- (car(cdr(car dragonlist)))1))))
- nil)
- (t (safeFromDragons (cdr dragonlist) state))
- ))
- (defun gore (state)
- (safe (make-state (+ (car state) 1) (cadr state)))
- )
- (defun dolu (state)
- (safe (make-state (- (car state) 1) (cadr state)))
- )
- (defun levo (state)
- (safe (make-state (car state) (- (cadr state) 1)))
- )
- (defun desno (state)
- (safe (make-state (car state) (+ (cadr state) 1)))
- )
- (defun gore-desno (state)
- (safe (make-state (+ (car state) 1) (+ (cadr state) 1)))
- )
- (defun gore-levo (state)
- (safe (make-state (+ (car state) 1) (- (cadr state) 1)))
- )
- (defun dolu-desno (state)
- (safe (make-state (- (car state) 1) (+ (cadr state) 1)))
- )
- (defun dolu-levo (state)
- (safe (make-state (- (car state) 1) (- (cadr state) 1)))
- )
- (print(run-breadth king queen '(gore dolu levo desno gore-levo gore-desno dolu-levo dolu-desno)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement