(in-package "USER")
;;; The Checkered Room Problem from TinyMUD
;;; State is a list
;;;
;;; ( room[p1] room[p2] room[bj] room[bt] room[wj] room[wt] )
;;;
;;; A garment is in room play1 if worn by p1, and play2 if worn by p2
;;;
(defvar *rooms* '(play1 play2 start foyer white black restroom checkered))
(defvar *objects* '(bj bt wj wt))
(defvar *start* '(start start foyer foyer foyer foyer))
(defvar play1 0)
(defvar play2 1)
(defvar bj 2)
(defvar bt 3)
(defvar wj 4)
(defvar wt 5)
(defun room1 (state) (nth play1 state))
(defun room2 (state) (nth play2 state))
(defun room-of (obj state) (nth (eval obj) state))
(defun roombj (state) (nth 2 state))
(defun roombt (state) (nth 3 state))
(defun roomwj (state) (nth 4 state))
(defun roomwt (state) (nth 5 state))
(defun locno (player) (eval player))
;;; The predicate cango implements the rules for moving from one room
;;; to another
(defun cango (player state toroom)
(let ((room (room-of player state))
(hasbj (eq (roombj state) player))
(hasbt (eq (roombt state) player))
(haswj (eq (roomwj state) player))
(haswt (eq (roomwt state) player)))
(cond
; From start, can go only to foyer
((eq room 'start)
(eq toroom 'foyer))
; From Foyer can go to three rooms under certain conditions
((eq room 'foyer)
(cond
((eq toroom 'start)
(not (or hasbj haswj hasbt haswt)))
((eq toroom 'white)
(and haswj haswt))
((eq toroom 'black)
(and hasbj hasbt))))
; From white room or black room
((member room '(white black))
(cond
((member toroom '(foyer restroom)) t)
((eq toroom 'checkered)
(or (and hasbt haswj) (and haswt hasbj)))))
; From restroom
((eq room 'restroom)
(cond
((eq toroom 'white) haswj)
((eq toroom 'black) hasbj)))
; From checkered room
((eq room 'checkered)
(member toroom '(white black))))))
;;; cango-rooms: given a player and a state, return a list of rooms
(defun cango-rooms (player state)
(mapcan
#'(lambda (r)
(and (cango player state r) (list r)))
*rooms*))
(defun can-takeoff-obj (player state object)
(or
(and
(eq player 'play1)
(eq (room-of object state) 'play1))
(and
(eq player 'play2)
(eq (room-of object state) 'play2))))
(defun can-takeoff (player state)
(mapcan
#'(lambda (obj)
(and (can-takeoff-obj player state obj) (list obj)))
*objects*))
(defun can-puton-obj (player state object)
(and
(eq (room-of object state) (room-of player state))
(cond
((eq object 'wj) (not (eq (room-of 'bj state) player)))
((eq object 'wt) (not (eq (room-of 'bt state) player)))
((eq object 'bj) (not (eq (room-of 'wj state) player)))
((eq object 'bt) (not (eq (room-of 'wt state) player))))))
(defun can-puton (player state)
(mapcan
#'(lambda (obj)
(and (can-puton-obj player state obj) (list obj)))
*objects*))
(defun moves (state)
(list
(list 'move 'play1 (cango-rooms 'play1 state))
(list 'move 'play2 (cango-rooms 'play2 state))
(list 'puton 'play1 (can-puton 'play1 state))
(list 'puton 'play2 (can-puton 'play2 state))
(list 'takeoff 'play1 (can-takeoff 'play1 state))
(list 'takeoff 'play2 (can-takeoff 'play2 state))))
(defun move-player (player state new-room)
(cond
((eq player 'play1)
(cons new-room (cdr state)))
(t
(cons (car state) (cons new-room (cddr state))))))
(defun wear (player state object)
(let ((p1l (room1 state))
(p2l (room2 state))
(bjl (roombj state))
(btl (roombt state))
(wjl (roomwj state))
(wtl (roomwt state)))
(cond
((eq object 'bj) (setf bjl player))
((eq object 'bt) (setf btl player))
((eq object 'wj) (setf wjl player))
((eq object 'wt) (setf wtl player)))
(list p1l p2l bjl btl wjl wtl)))
(defun takeoff (player state object)
(let ((p1l (room1 state))
(p2l (room2 state))
(bjl (roombj state))
(btl (roombt state))
(wjl (roomwj state))
(wtl (roomwt state)))
(cond
((eq object 'bj) (setf bjl (room-of player state)))
((eq object 'bt) (setf btl (room-of player state)))
((eq object 'wj) (setf wjl (room-of player state)))
((eq object 'wt) (setf wtl (room-of player state))))
(list p1l p2l bjl btl wjl wtl)))
(defun new-states (state)
(mapcan 'append
(list
(mapcar
#'(lambda (r) (move-player 'play1 state r))
(cango-rooms 'play1 state))
(mapcar
#'(lambda (r) (move-player 'play2 state r))
(cango-rooms 'play2 state))
(mapcar
#'(lambda (obj) (wear 'play1 state obj))
(can-puton 'play1 state))
(mapcar
#'(lambda (obj) (wear 'play2 state obj))
(can-puton 'play2 state))
(mapcar
#'(lambda (obj) (takeoff 'play1 state obj))
(can-takeoff 'play1 state))
(mapcar
#'(lambda (obj) (takeoff 'play2 state obj))
(can-takeoff 'play2 state)))))
(defun goalp (state)
(or
(eq (room1 state) 'checkered)
(eq (room2 state) 'checkered)))
First we search from that state to the goal, then we redefine the goalp function and search from the original start state to the intermediate state.
My estimate of the lower bound is 322,482,861 nodes searched to find the whole 15 move solution from the start state.
;;; Sun Common Lisp, Development Environment 4.0.0 , 6 July 1990 ;;; Sun-4 Version for SunOS 4.0.x and sunOS 4.1 > (compile-file "mud") #P"/usr2/mlm/mud.sbin" > (load "mud") > (load "dfs") > (load "bfs") > *start* (START START FOYER FOYER FOYER FOYER) > (new-states *start*) ((FOYER START FOYER FOYER FOYER FOYER) (START FOYER FOYER FOYER FOYER FOYER)) > (setq *int-state* '(foyer foyer play1 play1 play2 play2)) (FOYER FOYER PLAY1 PLAY1 PLAY2 PLAY2) > (moves *int-state*) ((MOVE PLAY1 (BLACK)) (MOVE PLAY2 (WHITE)) (PUTON PLAY1 NIL) (PUTON PLAY2 NIL) (TAKEOFF PLAY1 (BJ BT)) (TAKEOFF PLAY2 (WJ WT))) > (new-states *int-state*) ((BLACK FOYER PLAY1 PLAY1 PLAY2 PLAY2) (FOYER WHITE PLAY1 PLAY1 PLAY2 PLAY2) (FOYER FOYER FOYER PLAY1 PLAY2 PLAY2) (FOYER FOYER PLAY1 FOYER PLAY2 PLAY2) (FOYER FOYER PLAY1 PLAY1 FOYER PLAY2) (FOYER FOYER PLAY1 PLAY1 PLAY2 FOYER)) > (dfs *int-state* 9 1000000) (389943 67979 389976) ; branching factor 5.73 (389,976 / 67,979) ((FOYER FOYER PLAY1 PLAY1 PLAY2 PLAY2) (BLACK FOYER PLAY1 PLAY1 PLAY2 PLAY2) (RESTROOM FOYER PLAY1 PLAY1 PLAY2 PLAY2) (RESTROOM WHITE PLAY1 PLAY1 PLAY2 PLAY2) (RESTROOM RESTROOM PLAY1 PLAY1 PLAY2 PLAY2) (RESTROOM RESTROOM RESTROOM PLAY1 PLAY2 PLAY2) (RESTROOM RESTROOM RESTROOM PLAY1 RESTROOM PLAY2) (RESTROOM RESTROOM RESTROOM PLAY1 PLAY1 PLAY2) (WHITE RESTROOM RESTROOM PLAY1 PLAY1 PLAY2) (CHECKERED RESTROOM RESTROOM PLAY1 PLAY1 PLAY2)) > (defun goalp (state) (equal state *int-state*)) ;;; Warning: Redefining FUNCTION GOALP which used to be defined in "mud.lisp" GOALP > (dfs *start* 6 1000000) (827 154 849) ; branching factor 5.51 (849 / 154) ((START START FOYER FOYER FOYER FOYER) (FOYER START FOYER FOYER FOYER FOYER) (FOYER FOYER FOYER FOYER FOYER FOYER) (FOYER FOYER PLAY1 FOYER FOYER FOYER) (FOYER FOYER PLAY1 PLAY1 FOYER FOYER) (FOYER FOYER PLAY1 PLAY1 PLAY2 FOYER) (FOYER FOYER PLAY1 PLAY1 PLAY2 PLAY2)) > (* 827 389943) 322482861 ; estimated total nodes to find solution 322 million
;;; Sun Common Lisp, Development Environment 4.0.0 , 6 July 1990 ;;; Sun-4 Version for SunOS 4.0.x and sunOS 4.1 > (load "mud") ;;; Loading binary file "mud.sbin" #P"/usr2/mlm/mud.sbin" > (load "bfs") ;;; Loading binary file "bfs.sbin" #P"/usr2/mlm/bfs.sbin" > (bfs *start* 500) ;;; Expanding Dynamic Memory ;;; GC: 508032 words [2032128 bytes] of dynamic storage in use. ;;; 212862 words [851448 bytes] of free storage available before a GC. ;;; 933756 words [3735024 bytes] of free storage available if GC is disabled. ;;; GC: 508032 words [2032128 bytes] of dynamic storage in use. ;;; 212862 words [851448 bytes] of free storage available before a GC. ;;; 933756 words [3735024 bytes] of free storage available if GC is disabled. ;;; Expanding Dynamic Memory ;;; GC: 767254 words [3069016 bytes] of dynamic storage in use. ;;; 215784 words [863136 bytes] of free storage available before a GC. ;;; 1198822 words [4795288 bytes] of free storage available if GC is disabled. ;;; GC: 767254 words [3069016 bytes] of dynamic storage in use. ;;; 215784 words [863136 bytes] of free storage available before a GC. ;;; 1198822 words [4795288 bytes] of free storage available if GC is disabled. ;;; Expanding Dynamic Memory (501 500 2657) ; branching factor 5.31 (2657 / 500) NIL