;; LISP ROUTINES FOR CREATING A GRIDWORLD (ROADS AND OBJECTS) ;; -- VERSION WITH NO EXPLICIT TIMES IN FORMULAS ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *roadmap-knowledge* nil); will become a list of map ; facts when def-roadmap is run (defparameter *general-knowledge* nil); will become a list of general ; facts about object types; (defun def-roadmap (points roads) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Create a graph-like "roadmap", consisting of points (nodes) and ; connections (edges) beween pairs of points. The connections are ; labeled, where we think of these labels as road names; at most ; 2 edges impinging on a node may have any particular name. (Having ; 2 edges with the same name at a node means that we can follow ; a road through an "intersection" -- or, if these are the only ; 2 edges -- past a "point of interest", usually one where some ; object is located.) ; ; points: a list of distinct node names, such as Point1, Point2, ; Cross-roads1, Dead-end3, etc.; ; roads: a list of lists, each beginning with a road name, ; followed by a sequence of points that this road reaches; ; a road must not reach any point twice, because we want ; "taking road x from point y to point z" to correspond to ; a unique path; theoretically, 'points' may include points ; not reached by any road; a "minimalist" roadmap would be ; one that has just one point (where we place ME), and no ; roads. ; ; METHOD: ; 1. Check to make sure roads have at least one segment (i.e., ; 2 points), and roads are not self-intersecting; {a road ; is self-intersecting iff after removal of any duplicate ; points, the list of points defining the road is shorter}; ; Report any discrepancies between the points given as ; first argument and points occurring on roads; (however, ; such discrepancies are allowed); ; ; 2. Create a graph structure by attaching 'next' ; properties to points, where such a property consists ; of a list of (road-name adjacent-point) pairs; this can ; be done in an obvious way by sequentially processing ; the given roads; ; 3. Create the *roadmap-knowledge* list of facts about roads, ; points, and what points are on what roads. ; (let (pp name road-points point isolated-points unlisted-points rr ) (dolist (r roads); error checking (setq name (car r)) (setq pp (remove-duplicates (cdr r))) (when (< (length pp) 2) (format t "~%***Road ~a has no segments" name) (return-from def-roadmap 'ERROR-TERMINATION) ) (when (< (length pp) (length (cdr r))) (format t "~%***Road ~a self-intersects" name) (return-from def-roadmap 'ERROR-TERMINATION) ) (setq road-points (union pp road-points)) ) (setq isolated-points (set-difference points road-points)) (setq unlisted-points (set-difference road-points points)) (dolist (p road-points) (remprop p 'next)); cleanup for safety (dolist (p isolated-points) (remprop p 'next)); cleanup for safety (if isolated-points (format t "~%### ISOLATED POINTS: ~a" isolated-points) ) (if unlisted-points (format t "~%### UNLISTED POINTS ON ROADS: ~a" unlisted-points) ) (dolist (r roads); graph creation (setq name (pop r)) (dotimes (i (- (length r) 1)); number of road segments (setq point (pop r)) (push (list name (car r)) (get point 'next)) (push (list name point) (get (car r) 'next)) )) ; Create a roadmap knowledge list for the Motivated Explorer (ME): (setq *roadmap-knowledge* nil); for safety (dolist (r roads); predicate 'road' about each road-name (push (list 'road (car r)) *roadmap-knowledge*) ) (dolist (p (append road-points isolated-points)) ; predicate 'point' about each point (push (list 'point p) *roadmap-knowledge*) (setq rr (get p 'next)) (dolist (r rr); for each point p on a road r, say that p is on r (push (list 'is_on p (car r)) *roadmap-knowledge*) ; we could also add connection-knowledge between pairs of ; points, but we know that if p1 is on r and p2 is on r, ; then r connects p1 and p2 (though perhaps in multiple steps) )) )); end of def-roadmap ;; EXAMPLE OF CREATING ROADMAP: ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;; (def-roadmap '(a b c d e) '((r1 a b c d) (r2 b d))) ;; ;; ### ISOLATED POINTS: (E) ;; NIL ;; [2] CL-USER(29): (format t "~%~a" *roadmap-knowledge*) ;; ;; ((POINT E) (IS_ON A R1) (POINT A) (IS_ON B R1) (IS_ON B R1) ;; (IS_ON B R2) (POINT B) (IS_ON C R1) (IS_ON C R1) (POINT C) ;; (IS_ON D R1) (IS_ON D R2) (POINT D) (ROAD R2) (ROAD R1)) ;; NIL (defun def-object (obj-type properties) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; obj-type: an atomic identifier for a type, e.g., 'sasquatch'; ; properties: a list of abbreviated general properties such as ; '(is_animate is_furry (has_IQ 50)); ; This is expanded so as to produce a conditional whose ; antecedent applies the type predicate to a variable and ; whose consequent applies the given predicate in each ; property first to the variable and then to any additional ; arguments that are given; thus we will get ; ((sasquatch ?x) => (is_animate ?x)) ; ((sasquatch ?x) => (is_furry ?x)) ; ((sasquatch ?x) => (has_IQ ?x 50)) ; (Note: the originally planned temporal arguments have been ; omitted. These might still be added, but at this point it ; seems more convenient to omit them.) ; (let ((ante (list obj-type '?x)) conse) (dolist (p properties) (setq conse (if (atom p) (list p '?x) (cons (car p) (cons '?x (cdr p))) )) (push (list ante '=> conse) *general-knowledge*) ) )); end of def-object ;; EXAMPLE OF DEFINING AN OBJECT TYPE: ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;; [2] CL-USER(32): (def-object 'sasquatch '(is_animate is_furry (has_IQ 50))) ;; ;; [2] CL-USER(33): *general-knowledge* ;;(((SASQUATCH ?X) => (HAS_IQ ?X 50)) ((SASQUATCH ?X) => (IS_FURRY ?X)) ;; ((SASQUATCH ?X) => (IS_ANIMATE ?X))) (defun place-object (name obj-type point time-pt associated-things ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ curr-facts propos-attitudes) ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; We name an entity (of a specified type) and place it at ; some point in the Gridworld (and make the fact that it is of ; that type, and `is_at' that point part of the list that is ; the value of the `facts' property of `point'), at a specified ; 'time-pt' and we supply three kinds of additional information ; for it (where these become available to ME as knowledge "packets" ; if ME is at that point): ; - things that it currently "has" -- a list of typed entities ; such as ((key key1) (sword sword1) (banana banana3)); ; these may be regarded as *possessions* in the case of animate ; beings, or as contained or attached objects, in the case of ; inanimate objects such as trees or boxes; for example, ; a type predication like (key Key3) supplied under this ; heading means that the named entity has Key3, and that ; thing is a key; (see below for the representation of these ; facts); the type facts, possession facts, and `is_at' facts ; are all placed on the list comprising the `facts' property ; of `point'. ; - current-state facts about it; e.g., (hungry Grunt), or ; (likes Grunt Tweety); in this version we do not add time ; arguments, but directly associate the given facts with ; the 'facts' property of 'point'; ; - propositional attitudes such as (knows Grunt (has Robbie ; Banana)); another example: (wants Grunt (has Grunt Banana1)); ; it is even possible to have nested knowledge facts or goal ; facts such as (knows Grunt (knows Robbie (want Grunt (has ; Grunt Banana1)))), i.e., Grunt knows that Robbie knows that ; Grunt wants to have the banana; but such complex facts ; would more likely be produced by inference than by manual ; input. Again these facts are associated with the 'facts' ; property of 'point'. ; ; Note: `time-pt' is a number such as 0, but this is used in ; the present version of the code just to set *now*, not in any ; predicates (time remains implicit in predicates), ; ; type predication about 'name': (push (list obj-type name) (get point 'facts)) (push (list 'is_at name point) (get point 'facts)) ; set global *here* and *now* parameters if name is 'ME: (if (eq name 'ME) (setq *here* point *now* time-pt)) (dolist (p associated-things); the things that 'name' "has" (push p (get point 'facts)) (push (list 'is_at (second p) point) (get point 'facts)) (push (list 'has name (second p)) (get point 'facts)) ) (dolist (f curr-facts) (push f (get point 'facts)) ) (dolist (f propos-attitudes) (push f (get point 'facts)) ) ); end of place-object ;; EXAMPLE OF PLACING AN OBJECT: ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;; [3] CL-USER(52): (place-object 'Grunt 'sasquatch 'b 0 '((banana Banana1) ;; (key Key4)) '((hungry Grunt) (likes Grunt Tweety)) ;; '((knows Grunt (has ME Banana2)))) ;; ;; (format t "~%~a" (get 'Grunt 'facts)) ;; ;; ((KNOWS GRUNT (HAS ME BANANA2)) (LIKES GRUNT TWEETY) ;; (HUNGRY GRUNT) (HAS GRUNT KEY4) (HAS GRUNT BANANA1) ;; (IS_AT GRUNT B) (SASQUATCH GRUNT)) ;; NIL ;; [3] CL-USER(54): (format t "~%~a" (get 'Key4 'facts)) ;; ;; ((KEY KEY4)) ;; NIL ;; [3] CL-USER(55): (format t "~%~a" (get 'Banana2 'facts)) ;; ;; NIL ;; NIL ;; [3] CL-USER(56): (format t "~%~a" (get 'Banana1 'facts)) ;; ;; ((BANANA BANANA1)) ;; NIL