├── .gitignore ├── README.md ├── assets ├── fig-agents-plans.png ├── fig-mary-strength.png ├── fig-relational.png ├── fig-scenes-dynamic.png ├── fig-scenes-static.png ├── fig-splash.png ├── icon-cogs.png └── icon-nn.png └── domains ├── d1-probabilistic-reasoning ├── prompt.scm └── world-model.scm ├── d2-relational-reasoning ├── prompt.scm ├── visualizations.ipynb └── world-model.scm ├── d3-grounded-visual-reasoning ├── dynamic-scenes │ ├── prompt-examples.scm │ └── world-model.scm └── static-scenes │ ├── prompt-examples.scm │ └── world-model.scm └── d4-goal-directed-reasoning ├── prompt-examples.scm └── world-model.scm /.gitignore: -------------------------------------------------------------------------------- 1 | # General 2 | .DS_Store 3 | .AppleDouble 4 | .LSOverride 5 | 6 | # Icon must end with two \r 7 | Icon 8 | 9 | # Thumbnails 10 | ._* 11 | 12 | # Files that might appear in the root of a volume 13 | .DocumentRevisions-V100 14 | .fseventsd 15 | .Spotlight-V100 16 | .TemporaryItems 17 | .Trashes 18 | .VolumeIcon.icns 19 | .com.apple.timemachine.donotpresent 20 | 21 | # Directories potentially created on remote AFP share 22 | .AppleDB 23 | .AppleDesktop 24 | Network Trash Folder 25 | Temporary Items 26 | .apdisk 27 | 28 | .vscode 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # From Word Models to World Models: Translating from Natural Language to the Probabilistic Language of Thought 2 | 3 | Full paper: https://arxiv.org/abs/2306.12672 4 | 5 | ### Abstract 6 | 7 | How does language inform our downstream thinking? In particular, how do humans make meaning from language — and how can we leverage a theory of linguistic meaning to build machines that think in more human-like ways? 8 | In this paper, we propose _rational meaning construction_, a computational framework for language-informed thinking that combines neural models of language with probabilistic models for rational inference. We frame linguistic meaning as a context-sensitive mapping from natural language into a _probabilistic language of thought_ (PLoT) — a general-purpose symbolic substrate for probabilistic, generative world modeling. Our architecture integrates two powerful computational tools that have not previously come together: we model thinking with _probabilistic programs_, an expressive representation for flexible commonsense reasoning; and we model meaning construction with _large language models_ (LLMs), which support broad-coverage translation from natural language utterances to code expressions in a probabilistic programming language. 9 | We illustrate our framework in action through examples covering four core domains from cognitive science: probabilistic reasoning, logical and relational reasoning, visual and physical reasoning, and social reasoning about agents and their plans. In each, we show that LLMs can generate context-sensitive translations that capture pragmatically-appropriate linguistic meanings, while Bayesian inference with the generated programs supports coherent and robust commonsense reasoning. We extend our framework to integrate cognitively-motivated symbolic modules (physics simulators, graphics engines, and goal-directed planning algorithms) to provide a unified commonsense thinking interface from language. Finally, we explore how language can drive the construction of world models themselves. 10 | We hope this work will help to situate contemporary developments in LLMs within a broader cognitive picture of human language and intelligence, providing a roadmap towards AI systems that synthesize the insights of both modern and classical computational perspectives. 11 | 12 | ### What code is included in this repository? 13 | This repo is an archival collection of code files that were used to generate the examples in our paper. For now, this code is intended to be run manually in the playground settings described below. However, as next steps, we believe our framework naturally suggests many kinds of concrete implementations that function end-to-end as natural dialogue systems capable of complex, probabilistic reasoning. 14 | 15 | # Framework overview 16 | 17 | **Meaning function**: Context-sensitive mapping from natural language to code expressions. 18 | 19 | **Inference function**: Sample-based probabilistic inference engine over possible worlds described by a generative model. 20 | 21 | ## Experimenting with a meaning function 22 | 23 | For the examples we present in our paper, we use OpenAI's Codex model to play the role of the meaning function. Everywhere that a symbol appears indicates a translation produced by Codex. To reproduce these translations, you can use the [OpenAI Playground](https://platform.openai.com/playground) (account required to access) or the [ChatGPT interface](https://chat.openai.com/). For each domain, the `prompt.scm` file contains the text that was used for prompting. Note that while these translations contain fragments of Church code, they are not executable without the rest of the world model; instead, `condition` and `query` statements from these files can be added to the relevant sections of each `world-model.scm` file detailed below. 24 | 25 | ## Experimenting with an inference function 26 | 27 | In our paper, we used a probabilistic programming languguage called [Church](https://v1.probmods.org) to play the role of the inference function. Everywhere that a symbol appears indicates a computation that was performed with Church's probabilistic inference engine. To reproduce these inferences, you can use the [Church Play Space](https://v1.probmods.org/play-space.html). For each domain, the `world-model.scm` file contains generative model in Church that can be pasted directly into the editor. 28 | 29 | # Domains 30 | 31 | Splash figure 32 | 33 | ## Probabilistic reasoning 34 | 35 | Code: [[Domain 1] Probabilistic reasoning](domains/d1-probabilistic-reasoning) 36 | 37 | As an introductory example, we consider the Bayesian Tug-of-War (Gerstenberg & Goodman, 2012; Goodman et al., 2014). We start with a generative model of a tournament in which players of varying strengths compete in a series of matches as part of fluid teams. Each player has a latent strength value randomly sampled from a Gaussian distribution (with parameters arbitrarily chosen as μ = 50 and σ = 20). As an observer, our goal is to infer the latent strength of each individual based on their win/loss record. However, players sometimes don’t pull at their full strength and each player has a different intrinsic “laziness” value (uniformly sampled from the interval [0, 1]) that describes how likely they are to be lethargic in a given match. 38 | 39 | As a simple example, suppose we observe two matches. In the first match, Tom won against John. In the second match, John and Mary won against Tom and Sue. We can encode both of these observations as the following Church conditioning statement. 40 | 41 | ``` 42 | (condition 43 | (and 44 | ;; Condition: Tom won against John. 45 | (won-against '(tom) '(john)) 46 | ;; Condition: John and Mary won against Tom and Sue. 47 | (won-against '(john mary) '(tom sue)))) 48 | ``` 49 | 50 | Based on the fact that Tom won against John, we might expect Tom to be stronger than John. Therefore, the fact that John and Mary won against Tom and Sue suggests that Mary's strength is above average. We can replicate this probabilistic inference with the following Church query: 51 | 52 | ``` 53 | ;; Query: How strong is Mary? 54 | (strength 'mary) 55 | ``` 56 | 57 | mary-strength 58 | 59 | This is just a simple example of the kinds of probabilistic inferences we can make in the Bayesian tug-of-war. In our paper, we consider more complex observations (e.g., "Josh has a propensity to slack off") and inferences (e.g., "Is Gabe stronger than the weakest player on the faculty team?"), before scaling up to new domains of reasoning. 60 | 61 | ## Relational reasoning 62 | 63 | Code: [[Domain 2] Relational reasoning](domains/d2-relational-reasoning) 64 | 65 | Next, we consider _relational reasoning_ characteristic of "good old fashioned" AI systems like Prolog. Our domain of interest is **kinship**: tree-structured relationships between people in a family. Our world model is a probabilistic generative model over family trees, and our conditioning and query statements are propositions about relations between people (e.g., "Charlie is the grandfather of Dana"). Through the examples in our paper, we illustrate how our approach of translating from natural language to the probabilistic language-of-thought fluidly integrates both exact (logical) and fuzzy (probabilistic) reasoning in a way that comes naturally to people, but that has so far proven elusive for both traditional deductive programming systems and purely statistical language models. 66 | 67 | Relational reasoning figure 68 | 69 | ## Grounded visual reasoning 70 | 71 | Code: [[Domain 3] Grounded visual reasoning](domains/d3-grounded-visual-reasoning) 72 | 73 | How can we flexibly relate language to our more general perceptual and physical reasoning? By incorporating external graphics and physics engines, these sections blueprint how computational models that ground linguistic meaning in a probabilistic language-of-thought can interface with other cognitive modules for perception and physical reasoning. 74 | 75 | ### Static scenes 76 | In [static-scenes](domains/d3-grounded-visual-reasoning/static-scenes), we extend our framework to integrate a graphics rendering engine to relate linguistic meanings to visual knowledge. Our world model is a probabilistic generative model over objects on a tabletop. Conditioning statements convey information about the type, color, number, and other properties of these objects; queries are questions about the contents of the scene (e.g., "Are there more red objects or green ones?"). 77 | 78 | Static scenes figure 79 | 80 | ### Dynamic scenes 81 | Next, in [dynamic-scenes](domains/d3-grounded-visual-reasoning/dynamic-scenes), we integrate a physics simulation engine to further interface between language and intuitive, probabilistic physical reasoning. We extend our tabletop world model to include information about object masses and velocities. Based on the initial world state, we iteratively run a simple Newtonian dynamics model to compute a timeseries of trajectories. Conditioning statements encode information about both initial world states (e.g., "The red ball is pretty heavy") and events (e.g., "The red ball hits the blue one"). Queries invoke inferences about these world states (e.g., "How fast does the blue ball move after the collision?"). 82 | 83 | Dynamic scenes figure 84 | 85 | ## Goal-directed reasoning 86 | 87 | Code: [[Domain 4] Goal-directed reasoning reasoning](domains/d4-goal-directed-reasoning) 88 | 89 | In our final example, we explore language about other social beings – agents who want things, chase goals, and plan how to act in the world around them. We consider a gridworld domain based on C. L. Baker, Tenenbaum, and Saxe (2007) involving agents with different preferences and goals who are making lunch plans. We extend our framework to include a _model-based planner_ that supports inferences about agents' actions (e.g., "Lio loves sushi but hates pizza; where do you think they will go?"). We also illustrate how our probabilistic framing supports _inverse planning_: making inferences about agents' value functions and the state of the world, given observed actions (e.g., "Gabe was just biking East on Barlow Street; do you think the pizza place is open? Do you think he likes pizza?"). All of these inferences fall out of the same underlying generative model, which unifies these distinct observations about people and the world in language with respect to a formal model of how agents tend to behave. 90 | 91 | Goal-directed reasoning figure 92 | 93 | 94 | -------------------------------------------------------------------------------- /assets/fig-agents-plans.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/fig-agents-plans.png -------------------------------------------------------------------------------- /assets/fig-mary-strength.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/fig-mary-strength.png -------------------------------------------------------------------------------- /assets/fig-relational.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/fig-relational.png -------------------------------------------------------------------------------- /assets/fig-scenes-dynamic.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/fig-scenes-dynamic.png -------------------------------------------------------------------------------- /assets/fig-scenes-static.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/fig-scenes-static.png -------------------------------------------------------------------------------- /assets/fig-splash.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/fig-splash.png -------------------------------------------------------------------------------- /assets/icon-cogs.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/icon-cogs.png -------------------------------------------------------------------------------- /assets/icon-nn.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gabegrand/world-models/0017479c9340e1c26b8b86cff88ec7dd1faa91b6/assets/icon-nn.png -------------------------------------------------------------------------------- /domains/d1-probabilistic-reasoning/prompt.scm: -------------------------------------------------------------------------------- 1 | ;; -- WORLD MODEL -- 2 | ;; This Church program models a tug-of-war game between teams of players. 3 | ;; Each player has a strength, with strength value 50 being about average. 4 | (define strength (mem (lambda (player) (gaussian 50 20)))) 5 | 6 | ;; Each player has an intrinsic laziness frequency. 7 | (define laziness (mem (lambda (player) (uniform 0 1)))) 8 | 9 | ;; The team's strength is the sum of the players' strengths. 10 | ;; When a player is lazy in a match, they pull with half their strength. 11 | (define (team-strength team) 12 | (sum 13 | (map (lambda (player) 14 | (if (flip (laziness player)) 15 | (/ (strength player) 2) 16 | (strength player))) 17 | team))) 18 | 19 | ;; The winner of the match is the stronger team. 20 | ;; Returns true if team-1 won against team-2, else false. 21 | (define (won-against team-1 team-2) 22 | (> (team-strength team-1) (team-strength team-2))) 23 | 24 | ;; -- UTILITY FUNCTIONS -- 25 | (define (count bool-list) 26 | (sum (map boolean->number bool-list))) 27 | 28 | (define (argmax f lst) 29 | (if (null? (cdr lst)) 30 | (car lst) 31 | (let ((higher-items (filter (lambda (x) (> (f x) (f (car lst)))) (cdr lst)))) 32 | (if (null? higher-items) 33 | (car lst) 34 | (argmax f higher-items))))) 35 | 36 | (define (argmin f lst) 37 | (if (null? (cdr lst)) 38 | (car lst) 39 | (let ((lower-items (filter (lambda (x) (< (f x) (f (car lst)))) (cdr lst)))) 40 | (if (null? lower-items) 41 | (car lst) 42 | (argmin f lower-items))))) 43 | 44 | ;; -- TRANSLATION EXAMPLE 1 -- 45 | ;; Condition: Alice won against Bob. 46 | (condition (won-against '(alice) '(bob))) 47 | 48 | ;; Condition: John and Mary won against Tom and Sue. 49 | (condition (won-against '(john mary) '(tom sue))) 50 | 51 | ;; Query: If Mary played against Tom, who would win? 52 | (query (won-against '(mary) '(tom))) 53 | 54 | ;; Certain statements are underspecified and require some interpretation. For example: 55 | ;; Condition: Sue is very strong. 56 | (condition (> (strength 'sue) 75)) 57 | 58 | ;; We can `define` new constructs that are useful for translation. For example: 59 | ;; Condition: Bob is stronger than John. 60 | (define (stronger-than? player-1 player-2) 61 | (> (strength player-1) (strength player-2))) 62 | (condition (stronger-than? 'bob 'john)) 63 | 64 | ;; Query: Is Sue stronger than Mary? 65 | (query (stronger-than? 'sue 'mary)) 66 | 67 | ;; Condition: A couple of the players are stronger than John. 68 | (condition (>= (count (map (lambda (player) (stronger-than? player 'john) players)) 2))) 69 | 70 | ;; Condition: Sue, Mary, and Bob are all stronger than John. 71 | (condition (all (map (lambda (player) (stronger-than? player 'john))))) 72 | 73 | ;; -- TRANSLATION EXAMPLE 2 -- 74 | -------------------------------------------------------------------------------- /domains/d1-probabilistic-reasoning/world-model.scm: -------------------------------------------------------------------------------- 1 | ;; -- Tug-of-war in Church -- 2 | ;; Author: Gabe Grand (grandg@mit.edu) 3 | ;; Adapted from https://v1.probmods.org/conditioning.html#example-reasoning-about-the-tug-of-war 4 | 5 | ;; -- WORLD MODEL -- 6 | (define (run-world-model) 7 | (rejection-query 8 | 9 | ;; This Church program models a tug-of-war game between teams of players. 10 | ;; Each player has a strength, with strength value 50 being about average. 11 | (define strength (mem (lambda (player) (gaussian 50 20)))) 12 | 13 | ;; Each player has an intrinsic laziness frequency. 14 | (define laziness (mem (lambda (player) (uniform 0 1)))) 15 | 16 | ;; The team's strength is the sum of the players' strengths. 17 | ;; When a player is lazy in a match, they pull with half their strength. 18 | (define (team-strength team) 19 | (sum 20 | (map (lambda (player) 21 | (if (flip (laziness player)) 22 | (/ (strength player) 2) 23 | (strength player))) 24 | team))) 25 | 26 | ;; The winner of the match is the stronger team. 27 | ;; Returns true if team-1 won against team-2, else false. 28 | (define (won-against team-1 team-2) 29 | (> (team-strength team-1) (team-strength team-2))) 30 | 31 | ;; -- CONDITIONING STATEMENTS -- 32 | (condition 33 | (and 34 | ;; Condition: Tom won against John. 35 | (won-against '(tom) '(john)) 36 | ;; Condition: John and Mary won against Tom and Sue. 37 | (won-against '(john mary) '(tom sue)))) 38 | 39 | ;; -- QUERY STATEMENT -- 40 | ;; Query: How strong is Mary? 41 | (strength 'mary) 42 | )) 43 | 44 | ;; -- UTILITY FUNCTIONS -- 45 | (define (count bool-list) 46 | (sum (map boolean->number bool-list))) 47 | 48 | (define (argmax f lst) 49 | (if (null? (cdr lst)) 50 | (car lst) 51 | (let ((higher-items (filter (lambda (x) (> (f x) (f (car lst)))) (cdr lst)))) 52 | (if (null? higher-items) 53 | (car lst) 54 | (argmax f higher-items))))) 55 | 56 | (define (argmin f lst) 57 | (if (null? (cdr lst)) 58 | (car lst) 59 | (let ((lower-items (filter (lambda (x) (< (f x) (f (car lst)))) (cdr lst)))) 60 | (if (null? lower-items) 61 | (car lst) 62 | (argmin f lower-items))))) 63 | 64 | ;; -- VISUALIZE QUERY -- 65 | (density (repeat 1000 run-world-model) "Mary's strength" true) 66 | -------------------------------------------------------------------------------- /domains/d2-relational-reasoning/prompt.scm: -------------------------------------------------------------------------------- 1 | ;; -- GENERAL UTILITIES -- 2 | ;; Membership test that returns true instead of literal list 3 | (define (member? a b) 4 | (if (member a b) true false)) 5 | 6 | ;; Shuffle a list. Relies on items in the list being unique. 7 | (define (shuffle-unique lst) 8 | (if (null? lst) 9 | () 10 | (let* ((n (random-integer (length lst))) 11 | (x (list-ref lst n))) 12 | (cons x (shuffle-unique (difference lst (list x))))))) 13 | 14 | ;; Convenience method for accessing properties in association lists 15 | (define (lookup obj key) 16 | (if (assoc key obj) (rest (assoc key obj)) ())) 17 | 18 | ;; Geometric distribution 19 | (define (bounded-geometric p n max-n) 20 | (if (>= n max-n) 21 | n 22 | (if (flip p) 23 | n 24 | (bounded-geometric p (+ 1 n) max-n)))) 25 | 26 | ;; Shallow flatten 27 | (define (shallow-flatten x) 28 | (cond ((null? x) '()) 29 | ((pair? x) (append (car x) (shallow-flatten (cdr x)))) 30 | (else (list x)))) 31 | 32 | ;; -- NAMING -- 33 | ;; All the names that can be used in the conversational context. 34 | (define ALL-NAMES '(avery blake charlie dana)) 35 | 36 | ;; Replace unknown names with "other" (for histograms) 37 | (define (mask-other names) 38 | (map (lambda (name) 39 | (cond 40 | ((null? name) name) 41 | ((member? name ALL-NAMES) name) 42 | (else "other"))) 43 | names)) 44 | 45 | ;; -- WORLD MODEL -- 46 | ;; Generates unique person ids of the format (person-0, person-1, ...) 47 | (define PERSON-PREFIX "person-") 48 | (define new-person-id (make-gensym PERSON-PREFIX)) 49 | (define (id->idx person-id) 50 | (string->number (string-slice (stringify person-id) (string-length PERSON-PREFIX)))) 51 | 52 | ;; Randomly assign a gender 53 | (define person->gender (mem (lambda (person-id) 54 | (uniform-draw '(male female))))) 55 | 56 | ;; Randomly-ordered list of person names 57 | (define NAMES (shuffle-unique ALL-NAMES)) 58 | (define person->name (mem (lambda (person-id) 59 | (list-ref NAMES (id->idx person-id))))) 60 | 61 | ;; Person node in tree 62 | (define (person person-id parent-1-id parent-2-id) (list 63 | (pair 'person-id person-id) 64 | (pair 'name person-id) 65 | (pair 'gender (person->gender person-id)) 66 | (pair 'parent-1-id parent-1-id) 67 | (pair 'parent-2-id parent-2-id))) 68 | 69 | ;; Generate the full tree 70 | ;; Max tree size is 1 + (sum_{n=0}^{n=MAX-DEPTH} 2 * MAX-WIDTH^n) 71 | (define MAX-WIDTH 3) 72 | (define MAX-DEPTH 2) 73 | (define PARTNER-PROBABILITY 0.5) 74 | (define (generate-tree root-primary-id root-secondary-id depth) 75 | (let* ( 76 | ;; Create the primary parent 77 | (parent-1-id (new-person-id)) 78 | (parent-1 (person parent-1-id root-primary-id root-secondary-id))) 79 | (if (flip PARTNER-PROBABILITY) 80 | ;; Case: parent-1 has partner 81 | (let* ( 82 | ;; Create the secondary parent 83 | (parent-2-id (new-person-id)) 84 | (parent-2 (person parent-2-id () ())) 85 | 86 | ;; Link the parents with a partner relation 87 | (parent-1 (append parent-1 (list (pair 'partner-id parent-2-id)))) 88 | (parent-2 (append parent-2 (list (pair 'partner-id parent-1-id)))) 89 | 90 | ;; Generate children 91 | (n-children (if (>= depth MAX-DEPTH) 0 (bounded-geometric 0.5 0 MAX-WIDTH))) 92 | (child-trees (repeat n-children (lambda () (generate-tree parent-1-id parent-2-id (+ depth 1))))) 93 | 94 | ;; Update the parents to point to the children 95 | (child-ids (map (lambda (t) (lookup (first t) 'person-id)) child-trees)) 96 | (parent-1 (append parent-1 (list (pair 'child-ids child-ids)))) 97 | (parent-2 (append parent-2 (list (pair 'child-ids child-ids))))) 98 | (append (list parent-1) (list parent-2) (shallow-flatten child-trees))) 99 | 100 | ;; Case: parent-1 has no partner 101 | (list parent-1)))) 102 | 103 | ;; Generate the global tree. 104 | (define T (generate-tree () () 0)) 105 | 106 | ;; Assign names randomly to (some of) the people in the tree. 107 | (define (add-names-to-tree tree names) 108 | (if (null? tree) () 109 | (let* 110 | ;; Probability of addding a name to the first person 111 | ((p (min 1.0 (/ (length names) (length tree)))) 112 | (person (first tree))) 113 | (if (flip p) 114 | ;; Name the person 115 | (let 116 | ((named-person (update-list person 1 (pair 'name (first names))))) 117 | (cons named-person (add-names-to-tree (rest tree) (rest names)))) 118 | ;; Don't name the person 119 | (cons person (add-names-to-tree (rest tree) names)))))) 120 | 121 | ;; Update the tree with the name information. 122 | (define T (add-names-to-tree T NAMES)) 123 | 124 | ;; -- CORE TREE UTILITIES -- 125 | 126 | ;; Returns all instances of person with property `key` equal to `value` 127 | (define filter-by-property 128 | (mem (lambda (key value) 129 | (filter (lambda (p) (equal? (lookup p key) value)) T)))) 130 | 131 | ;; Returns the unique instance of person with name. 132 | (define get-person-by-name 133 | (mem (lambda (name) 134 | (let 135 | ((results (filter-by-property 'name name))) 136 | (if (null? results) () (first results)))))) 137 | 138 | ;; People without a name can be referenced directly by person-id. 139 | (define get-person-by-id 140 | (mem (lambda (person-id) 141 | (if (null? person-id) 142 | () 143 | (let ((idx (id->idx person-id))) 144 | (if (>= idx (length T)) () (list-ref T idx))))))) 145 | 146 | ;; Get a person object either by name or person-id. 147 | (define get-person 148 | (mem (lambda (person-ref) 149 | (cond 150 | ((null? person-ref) ()) 151 | ((member? person-ref NAMES) (get-person-by-name person-ref)) 152 | (else (get-person-by-id person-ref)))))) 153 | 154 | ;; Get a property of a person. 155 | (define get-property 156 | (mem (lambda (name key) 157 | (lookup (get-person name) key)))) 158 | 159 | ;; List of all the people in the tree with names. 160 | (define named-people (filter (lambda (person) (not (null? person))) (map get-person NAMES))) 161 | 162 | ;; -- CONCEPTUAL SYSTEM -- 163 | 164 | ;; Gets the partner of a person. 165 | (define (partner-of name) 166 | (get-property (get-property name 'partner-id) 'name)) 167 | 168 | ;; Gets the parents of a person. 169 | (define (parents-of name) 170 | (let* ((parent-1-id (get-property name 'parent-1-id)) 171 | (parent-1-name (get-property parent-1-id 'name)) 172 | (parent-2-id (get-property name 'parent-2-id)) 173 | (parent-2-name (get-property parent-2-id 'name))) 174 | (list parent-1-name parent-2-name))) 175 | 176 | ;; Gets the grandparents of a person. 177 | (define (grandparents-of name) 178 | (let ((parent-1 (first (parents-of name)))) 179 | (parents-of parent-1))) 180 | 181 | ;; Gets the children of a person. 182 | (define (children-of name) 183 | (let ((child-ids (get-property name 'child-ids))) 184 | (map (lambda (child-id) (get-property child-id 'name)) child-ids))) 185 | 186 | ;; Gets the siblings of a person. 187 | (define (siblings-of name) 188 | (let* ((parent-1-id (get-property name 'parent-1-id)) 189 | (child-ids (get-property parent-1-id 'child-ids)) 190 | (child-names (map (lambda (child-id) (get-property child-id 'name)) child-ids))) 191 | (filter (lambda (child-name) (not (equal? child-name name))) child-names))) 192 | 193 | ;; -- QUANTIFIERS -- 194 | ;; predicate :: name -> boolean 195 | 196 | (define (map-tree predicate) 197 | (map (lambda (x) (predicate (lookup x 'name))) T)) 198 | 199 | (define (filter-tree predicate) 200 | (filter (lambda (x) (predicate (lookup x 'name))) T)) 201 | 202 | (define (exists predicate) 203 | (some (map-tree predicate))) 204 | 205 | ;; -- BOOLEAN RELATIONS -- 206 | (define (partner-of? name_a name_b) 207 | (equal? name_a (partner-of name_b))) 208 | 209 | (define (parent-of? name_a name_b) 210 | (member? name_a (parents-of name_b))) 211 | 212 | (define (father-of? name_a name_b) 213 | (and (equal? (get-property name_a 'gender) 'male) 214 | (parent-of? name_a name_b))) 215 | 216 | (define (mother-of? name_a name_b) 217 | (and (equal? (get-property name_a 'gender) 'female) 218 | (parent-of? name_a name_b))) 219 | 220 | (define (grandparent-of? name_a name_b) 221 | (member? name_a (grandparents-of name_b))) 222 | 223 | (define (grandfather-of? name_a name_b) 224 | (and (equal? (get-property name_a 'gender) 'male) 225 | (grandparent-of? name_a name_b))) 226 | 227 | (define (grandmother-of? name_a name_b) 228 | (and (equal? (get-property name_a 'gender) 'female) 229 | (grandparent-of? name_a name_b))) 230 | 231 | (define (child-of? name_a name_b) 232 | (member? name_a (children-of name_b))) 233 | 234 | (define (son-of? name_a name_b) 235 | (and (equal? (get-property name_a 'gender) 'male) 236 | (child-of? name_a name_b))) 237 | 238 | (define (daughter-of? name_a name_b) 239 | (and (equal? (get-property name_a 'gender) 'female) 240 | (child-of? name_a name_b))) 241 | 242 | (define (sibling-of? name_a name_b) 243 | (member? name_a (siblings-of name_b))) 244 | 245 | (define (brother-of? name_a name_b) 246 | (and (equal? (get-property name_a 'gender) 'male) 247 | (sibling-of? name_a name_b))) 248 | 249 | (define (sister-of? name_a name_b) 250 | (and (equal? (get-property name_a 'gender) 'female) 251 | (sibling-of? name_a name_b))) 252 | 253 | ;; -- TRANSLATION EXAMPLE 1 -- 254 | ;; Condition: Ryan's partner is Taylor. 255 | (condition (partner-of? 'ryan 'taylor)) 256 | 257 | ;; Condition: Taylor is the mother of Sam. 258 | (condition (mother-of? 'taylor 'sam)) 259 | 260 | ;; Condition: Sam's father is Ryan. 261 | (condition (father-of? 'ryan 'sam)) 262 | 263 | ;; Condition: Sam has two siblings. 264 | (condition (= (length (siblings-of 'sam)) 2)) 265 | 266 | ;; Condition: Sam has a brother. 267 | (condition 268 | (exists (lambda (x) 269 | (brother-of? x 'sam)))) 270 | 271 | ;; Condition: Payton's partner has a kid named Kyle. 272 | (condition 273 | (exists (lambda (x) (and 274 | (partner-of? x 'payton) 275 | (child-of? 'kyle x))))) 276 | 277 | ;; Condition: Payton's partner has a sister who has a son named Sam. 278 | (condition 279 | (exists (lambda (x) (and 280 | (partner-of? x 'payton) 281 | (exists (lambda (y) (and 282 | (sister-of? y x) 283 | (son-of? 'sam y)))))))) 284 | 285 | ;; Query: Who are Sam's parents? 286 | (query (parents-of 'sam)) 287 | 288 | ;; Query: How many children does Kyle have? 289 | (query (length (children-of 'kyle))) 290 | 291 | ;; Query: Who is Ryan's grandfather? 292 | (query 293 | (filter-tree 294 | (lambda (x) (grandfather-of? x 'ryan)))) 295 | 296 | ;; Query: Does Taylor have a sister? 297 | (query 298 | (exists (lambda (x) 299 | (sister-of? x 'taylor)))) 300 | 301 | ;; Query: Which of Sam's parents is the daughter of Taylor? 302 | (query 303 | (filter-tree 304 | (lambda (x) (and 305 | (parent-of? x 'sam) 306 | (daughter-of? x 'taylor))))) 307 | 308 | ;; -- TRANSLATION EXAMPLE 2 -- 309 | -------------------------------------------------------------------------------- /domains/d2-relational-reasoning/world-model.scm: -------------------------------------------------------------------------------- 1 | ;; -- Kinship in Church -- 2 | ;; Author: Gabe Grand (grandg@mit.edu) 3 | ;; With help from Alex Lew and Lio Wong. 4 | 5 | ;; -- GENERAL UTILITIES -- 6 | ;; Membership test that returns true instead of literal list 7 | (define (member? a b) 8 | (if (member a b) true false)) 9 | 10 | ;; Shuffle a list. Relies on items in the list being unique. 11 | (define (shuffle-unique lst) 12 | (if (null? lst) 13 | () 14 | (let* ((n (random-integer (length lst))) 15 | (x (list-ref lst n))) 16 | (cons x (shuffle-unique (difference lst (list x))))))) 17 | 18 | ;; Convenience method for accessing properties in association lists 19 | (define (lookup obj key) 20 | (if (assoc key obj) (rest (assoc key obj)) ())) 21 | 22 | ;; Geometric distribution 23 | (define (bounded-geometric p n max-n) 24 | (if (>= n max-n) 25 | n 26 | (if (flip p) 27 | n 28 | (bounded-geometric p (+ 1 n) max-n)))) 29 | 30 | ;; Shallow flatten 31 | (define (shallow-flatten x) 32 | (cond ((null? x) '()) 33 | ((pair? x) (append (car x) (shallow-flatten (cdr x)))) 34 | (else (list x)))) 35 | 36 | ;; -- NAMING -- 37 | ;; All the names that can be used in the conversational context. 38 | (define ALL-NAMES '(avery blake charlie dana)) 39 | 40 | ;; Replace unknown names with "other" (for histograms) 41 | (define (mask-other names) 42 | (map (lambda (name) 43 | (cond 44 | ((null? name) name) 45 | ((member? name ALL-NAMES) name) 46 | (else "other"))) 47 | names)) 48 | 49 | ;; -- WORLD MODEL -- 50 | (define (run-world-model) 51 | (rejection-query 52 | 53 | ;; Generates unique person ids of the format (person-0, person-1, ...) 54 | (define PERSON-PREFIX "person-") 55 | (define new-person-id (make-gensym PERSON-PREFIX)) 56 | (define (id->idx person-id) 57 | (string->number (string-slice (stringify person-id) (string-length PERSON-PREFIX)))) 58 | 59 | ;; Randomly assign a gender 60 | (define person->gender (mem (lambda (person-id) 61 | (uniform-draw '(male female))))) 62 | 63 | ;; Randomly-ordered list of person names 64 | (define NAMES (shuffle-unique ALL-NAMES)) 65 | (define person->name (mem (lambda (person-id) 66 | (list-ref NAMES (id->idx person-id))))) 67 | 68 | ;; Person node in tree 69 | (define (person person-id parent-1-id parent-2-id) (list 70 | (pair 'person-id person-id) 71 | (pair 'name person-id) 72 | (pair 'gender (person->gender person-id)) 73 | (pair 'parent-1-id parent-1-id) 74 | (pair 'parent-2-id parent-2-id))) 75 | 76 | ;; Generate the full tree 77 | ;; Max tree size is 1 + (sum_{n=0}^{n=MAX-DEPTH} 2 * MAX-WIDTH^n) 78 | (define MAX-WIDTH 3) 79 | (define MAX-DEPTH 2) 80 | (define PARTNER-PROBABILITY 0.5) 81 | (define (generate-tree root-primary-id root-secondary-id depth) 82 | (let* ( 83 | ;; Create the primary parent 84 | (parent-1-id (new-person-id)) 85 | (parent-1 (person parent-1-id root-primary-id root-secondary-id))) 86 | (if (flip PARTNER-PROBABILITY) 87 | ;; Case: parent-1 has partner 88 | (let* ( 89 | ;; Create the secondary parent 90 | (parent-2-id (new-person-id)) 91 | (parent-2 (person parent-2-id () ())) 92 | 93 | ;; Link the parents with a partner relation 94 | (parent-1 (append parent-1 (list (pair 'partner-id parent-2-id)))) 95 | (parent-2 (append parent-2 (list (pair 'partner-id parent-1-id)))) 96 | 97 | ;; Generate children 98 | (n-children (if (>= depth MAX-DEPTH) 0 (bounded-geometric 0.5 0 MAX-WIDTH))) 99 | (child-trees (repeat n-children (lambda () (generate-tree parent-1-id parent-2-id (+ depth 1))))) 100 | 101 | ;; Update the parents to point to the children 102 | (child-ids (map (lambda (t) (lookup (first t) 'person-id)) child-trees)) 103 | (parent-1 (append parent-1 (list (pair 'child-ids child-ids)))) 104 | (parent-2 (append parent-2 (list (pair 'child-ids child-ids))))) 105 | (append (list parent-1) (list parent-2) (shallow-flatten child-trees))) 106 | 107 | ;; Case: parent-1 has no partner 108 | (list parent-1)))) 109 | 110 | ;; Generate the global tree. 111 | (define T (generate-tree () () 0)) 112 | 113 | ;; Assign names randomly to (some of) the people in the tree. 114 | (define (add-names-to-tree tree names) 115 | (if (null? tree) () 116 | (let* 117 | ;; Probability of addding a name to the first person 118 | ((p (min 1.0 (/ (length names) (length tree)))) 119 | (person (first tree))) 120 | (if (flip p) 121 | ;; Name the person 122 | (let 123 | ((named-person (update-list person 1 (pair 'name (first names))))) 124 | (cons named-person (add-names-to-tree (rest tree) (rest names)))) 125 | ;; Don't name the person 126 | (cons person (add-names-to-tree (rest tree) names)))))) 127 | 128 | ;; Update the tree with the name information. 129 | (define T (add-names-to-tree T NAMES)) 130 | 131 | ;; -- CORE TREE UTILITIES -- 132 | 133 | ;; Returns all instances of person with property `key` equal to `value` 134 | (define filter-by-property 135 | (mem (lambda (key value) 136 | (filter (lambda (p) (equal? (lookup p key) value)) T)))) 137 | 138 | ;; Returns the unique instance of person with name. 139 | (define get-person-by-name 140 | (mem (lambda (name) 141 | (let 142 | ((results (filter-by-property 'name name))) 143 | (if (null? results) () (first results)))))) 144 | 145 | ;; People without a name can be referenced directly by person-id. 146 | (define get-person-by-id 147 | (mem (lambda (person-id) 148 | (if (null? person-id) 149 | () 150 | (let ((idx (id->idx person-id))) 151 | (if (>= idx (length T)) () (list-ref T idx))))))) 152 | 153 | ;; Get a person object either by name or person-id. 154 | (define get-person 155 | (mem (lambda (person-ref) 156 | (cond 157 | ((null? person-ref) ()) 158 | ((member? person-ref NAMES) (get-person-by-name person-ref)) 159 | (else (get-person-by-id person-ref)))))) 160 | 161 | ;; Get a property of a person. 162 | (define get-property 163 | (mem (lambda (name key) 164 | (lookup (get-person name) key)))) 165 | 166 | ;; List of all the people in the tree with names. 167 | (define named-people (filter (lambda (person) (not (null? person))) (map get-person NAMES))) 168 | 169 | ;; -- CONCEPTUAL SYSTEM -- 170 | 171 | ;; Gets the partner of a person. 172 | (define (partner-of name) 173 | (get-property (get-property name 'partner-id) 'name)) 174 | 175 | ;; Gets the parents of a person. 176 | (define (parents-of name) 177 | (let* ((parent-1-id (get-property name 'parent-1-id)) 178 | (parent-1-name (get-property parent-1-id 'name)) 179 | (parent-2-id (get-property name 'parent-2-id)) 180 | (parent-2-name (get-property parent-2-id 'name))) 181 | (list parent-1-name parent-2-name))) 182 | 183 | ;; Gets the grandparents of a person. 184 | (define (grandparents-of name) 185 | (let ((parent-1 (first (parents-of name)))) 186 | (parents-of parent-1))) 187 | 188 | ;; Gets the children of a person. 189 | (define (children-of name) 190 | (let ((child-ids (get-property name 'child-ids))) 191 | (map (lambda (child-id) (get-property child-id 'name)) child-ids))) 192 | 193 | ;; Gets the siblings of a person. 194 | (define (siblings-of name) 195 | (let* ((parent-1-id (get-property name 'parent-1-id)) 196 | (child-ids (get-property parent-1-id 'child-ids)) 197 | (child-names (map (lambda (child-id) (get-property child-id 'name)) child-ids))) 198 | (filter (lambda (child-name) (not (equal? child-name name))) child-names))) 199 | 200 | ;; -- QUANTIFIERS -- 201 | ;; predicate :: name -> boolean 202 | 203 | (define (map-tree predicate) 204 | (map (lambda (x) (predicate (lookup x 'name))) T)) 205 | 206 | (define (filter-tree predicate) 207 | (filter (lambda (x) (predicate (lookup x 'name))) T)) 208 | 209 | (define (exists predicate) 210 | (some (map-tree predicate))) 211 | 212 | ;; -- BOOLEAN RELATIONS -- 213 | (define (partner-of? name_a name_b) 214 | (equal? name_a (partner-of name_b))) 215 | 216 | (define (parent-of? name_a name_b) 217 | (member? name_a (parents-of name_b))) 218 | 219 | (define (father-of? name_a name_b) 220 | (and (equal? (get-property name_a 'gender) 'male) 221 | (parent-of? name_a name_b))) 222 | 223 | (define (mother-of? name_a name_b) 224 | (and (equal? (get-property name_a 'gender) 'female) 225 | (parent-of? name_a name_b))) 226 | 227 | (define (grandparent-of? name_a name_b) 228 | (member? name_a (grandparents-of name_b))) 229 | 230 | (define (grandfather-of? name_a name_b) 231 | (and (equal? (get-property name_a 'gender) 'male) 232 | (grandparent-of? name_a name_b))) 233 | 234 | (define (grandmother-of? name_a name_b) 235 | (and (equal? (get-property name_a 'gender) 'female) 236 | (grandparent-of? name_a name_b))) 237 | 238 | (define (child-of? name_a name_b) 239 | (member? name_a (children-of name_b))) 240 | 241 | (define (son-of? name_a name_b) 242 | (and (equal? (get-property name_a 'gender) 'male) 243 | (child-of? name_a name_b))) 244 | 245 | (define (daughter-of? name_a name_b) 246 | (and (equal? (get-property name_a 'gender) 'female) 247 | (child-of? name_a name_b))) 248 | 249 | (define (sibling-of? name_a name_b) 250 | (member? name_a (siblings-of name_b))) 251 | 252 | (define (brother-of? name_a name_b) 253 | (and (equal? (get-property name_a 'gender) 'male) 254 | (sibling-of? name_a name_b))) 255 | 256 | (define (sister-of? name_a name_b) 257 | (and (equal? (get-property name_a 'gender) 'female) 258 | (sibling-of? name_a name_b))) 259 | 260 | ;; -- CONDITIONING STATEMENTS -- 261 | (condition 262 | (and 263 | ;; Condition: Avery has a sister named Blake. 264 | (sister-of? 'blake 'avery) 265 | 266 | ;; Condition: Charlie is Dana's grandfather. 267 | (grandfather-of? 'charlie 'dana) 268 | 269 | )) 270 | 271 | ;; -- QUERY STATEMENT -- 272 | ;; Query: Who are Dana's parents? 273 | (parents-of 'dana) 274 | 275 | ;; Uncomment to return tree object (useful for debugging) 276 | ;; T 277 | 278 | )) 279 | 280 | ;; -- VISUALIZE QUERY -- 281 | (hist (mask-other (flatten (repeat 10 run-world-model)))) 282 | 283 | ;; Compute a single output (useful for debugging) 284 | ;; (run-world-model) 285 | -------------------------------------------------------------------------------- /domains/d3-grounded-visual-reasoning/dynamic-scenes/prompt-examples.scm: -------------------------------------------------------------------------------- 1 | ;; Condition: The objects are all balls. 2 | (condition (all (map (lambda (o) ((is_shape? 'sphere) o)) all_objects))) 3 | 4 | ;; Condition: Everything is a ball. 5 | (condition (all (map (lambda (o) ((is_shape? 'sphere) o)) all_objects))) 6 | 7 | ;; Condition: Imagine the red thing is a block, and is somewhat heavy. 8 | (condition (exists_object (lambda (object) 9 | (and 10 | ((is_color? red) object) 11 | ((is_shape? 'cube) object) 12 | (> (get_attribute object 'mass) 2) 13 | )))) 14 | 15 | ;; Condition: There is a blue ball, and it is quite heavy. 16 | (condition (exists_object (lambda (object) 17 | (and 18 | ((is_color? blue) object) 19 | ((is_shape? 'sphere) object) 20 | (> (get_attribute object 'mass) 3.5) 21 | )))) 22 | 23 | ;; Condition: Now, the red block is very light. 24 | (condition (exists_object (lambda (object) 25 | (and 26 | ((is_color? red) object) 27 | ((is_shape? 'cube) object) 28 | (< (get_attribute object 'mass) 1) 29 | )))) 30 | 31 | ;; Condition: A blue ball is somewhat light. 32 | (condition (exists_object (lambda (object) 33 | (and 34 | ((is_color? red) object) 35 | ((is_shape? 'cube) object) 36 | (< (get_attribute object 'mass) 2) 37 | )))) 38 | 39 | ;; Condition: Imagine the red block gets pushed lightly to the right. 40 | (condition (exists_object (lambda (object) 41 | (and 42 | ((is_color? red) object) 43 | ((is_shape? 'cube) object) 44 | (< (get_attribute object 'initial_push_force) 2) 45 | )))) 46 | 47 | ;; Condition: Now, imagine a red ball is pushed hard to the right. 48 | (condition (exists_object (lambda (object) 49 | (and 50 | ((is_color? red) object) 51 | ((is_shape? 'sphere) object) 52 | (> (get_attribute object 'initial_push_force) 6) 53 | )))) 54 | 55 | ;; Condition: A red block hits a blue block. 56 | (condition 57 | (exists_object (lambda (object_1) 58 | (exists_object (lambda (object_2) 59 | (exists_event (lambda (event) 60 | (and 61 | ((is_color? red) object_1) 62 | ((is_shape? 'cube) object_1) 63 | ((is_color? blue) object_2) 64 | ((is_shape? 'cube) object_2) 65 | (is_subject_of_event? event object_1) 66 | (is_object_of_event? event object_2) 67 | (is_event? 'is_hitting event)) 68 | ))))))) 69 | 70 | ;; Query: What's the final velocity of the red block after it is hit? 71 | (query (last (map 72 | (lambda (event) (get_attribute event 'subject_final_v)) 73 | (filter_events 74 | (lambda (e) 75 | (and 76 | (is_event? 'is_colliding e) 77 | (event_subject_is? e (lambda (o) 78 | (and 79 | ((is_color? red) o) 80 | ((is_shape? 'cube) o)))))))))) -------------------------------------------------------------------------------- /domains/d3-grounded-visual-reasoning/dynamic-scenes/world-model.scm: -------------------------------------------------------------------------------- 1 | ;; -- Physical Events in Church -- 2 | ;; Author: Lio Wong (zyzzyva@mit.edu) 3 | 4 | (define (get_attribute obj key) 5 | (if (assoc key obj) (rest (assoc key obj)) ())) 6 | 7 | (define (member? a b) 8 | (if (member a b) true false)) 9 | (define concatenate 10 | (lambda (list-1 list-2) 11 | (if (null? list-1) 12 | list-2 13 | (cons (car list-1) (concatenate (cdr list-1) list-2))))) 14 | 15 | (define (pairs x l) 16 | (define (aux accu x l) 17 | (if (null? l) 18 | accu 19 | (let ((y (car l)) 20 | (tail (cdr l))) 21 | (aux (cons (cons x y) accu) x tail)))) 22 | (aux '() x l)) 23 | 24 | (define (cartesian_product l m) 25 | (define (aux accu l) 26 | (if (null? l) 27 | accu 28 | (let ((x (car l)) 29 | (tail (cdr l))) 30 | (aux (append (pairs x m) accu) tail)))) 31 | (aux '() l)) 32 | 33 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Generative domain theory: dynamic scenes. Collision detection. 34 | (define get_num_objects 2) 35 | (define OBJECT_DEFAULT_RADIUS 1) 36 | (define GRAVITY 9.8) 37 | (define DELTA_T 0.5) 38 | 39 | (define get_initial_color 40 | (lambda (obj_id) 41 | (if (eq? obj_id 'obj-0) 42 | (list 255 0 0) 43 | (list 0 0 255)))) 44 | 45 | (define choose_mass 46 | (mem (lambda (obj_id) 47 | (abs (gaussian 5 3))))) 48 | 49 | (define choose_shapes 50 | (mem (lambda (scene-id) (uniform-draw (list 'sphere 'block))))) 51 | 52 | (define min_x -3) 53 | (define max_x 3) 54 | (define mid_x (+ (/ (- max_x min_x) 2) min_x)) 55 | (define get_initial_x 56 | (lambda (obj_id) 57 | (if (eq? obj_id 'obj-0) 58 | min_x 59 | mid_x))) 60 | 61 | (define min_force 0) 62 | (define max_force 10) 63 | (define mid_force (+ (/ (- max_force min_force) 2) min_force)) 64 | (define choose_initial_force 65 | (mem (lambda (obj_id) 66 | (if (eq? obj_id 'obj-0) 67 | (abs (gaussian mid_force 3)) 68 | 0 69 | )))) 70 | 71 | (define static_friction_constant (lambda (shape) 72 | (if (eq? shape 'sphere) 73 | 0.02 74 | 0.05) 75 | )) 76 | (define kinetic_friction_constant (lambda (shape) 77 | (if (eq? shape 'sphere) 78 | 0.01 79 | 0.02) 80 | )) 81 | (define normal_force (lambda (m) (* m GRAVITY))) 82 | (define force_after_friction (lambda (f v shape m) 83 | (if (> (abs v) 0) 84 | (- f (* (kinetic_friction_constant shape) (normal_force m))) 85 | (if (< f (* (static_friction_constant shape) (normal_force m))) 0 (- f (* (kinetic_friction_constant shape) (normal_force m))) 86 | )))) 87 | 88 | (define newtons_second (lambda (f m) (/ f m))) 89 | (define v_next (lambda (v_prev a_prev delta_t) 90 | (let ((v_temp (+ v_prev (* a_prev delta_t)))) 91 | (if (>= (* v_prev v_temp) 0) v_temp 0)) 92 | )) 93 | (define x_next (lambda (x_prev v_prev delta_t) (+ x_prev (* v_prev delta_t)))) 94 | (define initial_object_state (mem (lambda (obj_id scene_id) 95 | (let ((obj_shape (choose_shapes scene_id))) 96 | (let ((obj_mass (choose_mass obj_id))) 97 | (let ((obj_color (get_initial_color obj_id))) 98 | (let ((initial_x (get_initial_x obj_id))) 99 | (let ((initial_push_force (choose_initial_force obj_id))) 100 | (let ((initial_force (force_after_friction initial_push_force 0 obj_shape obj_mass))) 101 | (list 102 | (pair 'object_id obj_id) 103 | (pair 'object_radius OBJECT_DEFAULT_RADIUS) 104 | (pair 'shape obj_shape) 105 | (pair 'mass obj_mass) 106 | (pair 'color obj_color) 107 | (pair 'x initial_x) 108 | (pair 'initial_push_force initial_push_force) 109 | (pair 'f initial_force) 110 | (pair 't 0) 111 | (pair 'a_prev (newtons_second initial_force obj_mass)) 112 | (pair 'a (newtons_second initial_force obj_mass)) 113 | (pair 'v_0 0) 114 | (pair 'v (v_next 0 (newtons_second initial_force obj_mass) DELTA_T))) 115 | ))))))))) 116 | (define obj_id_gensym (make_gensym "obj-")) 117 | (define generate_initial_state 118 | (mem (lambda (scene_id total_objects) 119 | (if (= total_objects 1) 120 | (list (initial_object_state (obj_id_gensym) scene_id)) 121 | (cons (initial_object_state (obj_id_gensym) scene_id) (generate_initial_state scene_id (- total_objects 1))))))) 122 | 123 | (define generate_initial_scene_event_state (mem (lambda (scene_id total_objects) 124 | (pair 0 125 | (list 126 | (pair 'scene_states (generate_initial_state scene_id total_objects)) 127 | (pair 'event_states []) 128 | )) 129 | ) 130 | )) 131 | 132 | (define event_id_gensym (make_gensym "event-")) 133 | (define circle_intersect? (lambda (subject_x subject_radius object_x object_radius) 134 | (let ((square_circle_distance (expt (- subject_x object_x) 2))) 135 | (let ((square_radii (expt (+ subject_radius object_radius) 2))) 136 | (leq square_circle_distance square_radii))) 137 | )) 138 | (define elastic_collision_subject_v (lambda (subject_m subject_v object_m object_v) 139 | (/ (+ (* 2 (* object_m object_v)) (* subject_v (- subject_m object_m))) (+ subject_m object_m)) 140 | )) 141 | 142 | (define get_collision_events (lambda (time scene_event_state_for_time) 143 | (let ((scene_event_state (get_attribute scene_event_state_for_time time))) 144 | (let ((scene_state (get_attribute scene_event_state 'scene_states))) 145 | (if (= (length scene_state) 1) 146 | () 147 | (fold (lambda (event events) (if (equal? event ()) events (cons event events))) () 148 | (let ((paired_object_states (cartesian_product scene_state scene_state))) 149 | (map (lambda (paired_objects) 150 | 151 | (let ((event_subject (get_attribute (first paired_objects) 'object_id))) 152 | (let ((event_object (get_attribute (cdr paired_objects) 'object_id))) 153 | (if (eq? event_subject event_object) () 154 | (let ((subject_v (get_attribute (first paired_objects) 'v))) 155 | (let ((subject_x (get_attribute (first paired_objects) 'x))) 156 | (let ((subject_m (get_attribute (first paired_objects) 'mass))) 157 | (let ((subject_radius (get_attribute (first paired_objects) 'object_radius))) 158 | (let ((object_v (get_attribute (cdr paired_objects) 'v))) 159 | (let ((object_x (get_attribute (cdr paired_objects) 'x))) 160 | (let ((object_m (get_attribute (cdr paired_objects) 'mass))) 161 | (let ((object_radius (get_attribute (cdr paired_objects) 'object_radius))) 162 | (if (circle_intersect? subject_x subject_radius object_x object_radius) 163 | (list 164 | (pair 'event-id (event_id_gensym)) 165 | (pair 'event_time time) 166 | (pair 'event_predicates (list 'is_colliding)) 167 | (pair 'event_subject event_subject) 168 | (pair 'event_object event_object) 169 | (pair 'subject_initial_v subject_v) 170 | (pair 'subject_final_v (elastic_collision_subject_v subject_m subject_v object_m object_v)) 171 | (pair 'object_initial_v object_v) 172 | ) 173 | ())))))))))) 174 | ))) 175 | paired_object_states))) 176 | ))))) 177 | 178 | 179 | (define generate_next_object_state (lambda (current_time event_state) (lambda (prev_object_state) 180 | (let ((obj_id (cdr (assoc 'object_id prev_object_state)))) 181 | (let ((collision_events (fold (lambda (event events) (if (equal? (get_attribute event 'event_subject) obj_id) (cons event events) events)) () event_state))) 182 | (if (> (length collision_events) 0) 183 | (generate_collision_event_state current_time obj_id prev_object_state (car collision_events)) 184 | (generate_no_collision_event_state current_time obj_id prev_object_state) 185 | ) 186 | ))))) 187 | 188 | (define generate_collision_event_state (lambda (current_time obj_id prev_object_state collision_event) 189 | (let ((obj_radius (cdr (assoc 'object_radius prev_object_state)))) 190 | (let ((obj_mass (cdr (assoc 'mass prev_object_state)))) 191 | (let ((obj_color (cdr (assoc 'color prev_object_state)))) 192 | (let ((obj_shape (cdr (assoc 'shape prev_object_state)))) 193 | (let ((v_prev (cdr (assoc 'v prev_object_state)))) 194 | (let ((a_prev (cdr (assoc 'a_prev prev_object_state)))) 195 | (let ((x_prev (cdr (assoc 'x prev_object_state)))) 196 | (let ((v (get_attribute collision_event 'subject_final_v))) 197 | (let ((x (x_next x_prev v 1))) 198 | (list 199 | (pair 'object_id obj_id) 200 | (pair 'object_radius obj_radius) 201 | (pair 'shape obj_shape) 202 | (pair 'color obj_color) 203 | (pair 'mass obj_mass) 204 | (pair 'x x) 205 | (pair 'f 0) 206 | (pair 't (* current_time DELTA_T)) 207 | (pair 'a_prev 0) 208 | (pair 'a 0) 209 | (pair 'v_0 0) 210 | (pair 'v v)) 211 | ))))) 212 | )))) 213 | )) 214 | 215 | (define generate_no_collision_event_state (lambda (current_time obj_id prev_object_state) 216 | (let ((obj_radius (cdr (assoc 'object_radius prev_object_state)))) 217 | (let ((obj_mass (cdr (assoc 'mass prev_object_state)))) 218 | (let ((obj_color (cdr (assoc 'color prev_object_state)))) 219 | (let ((obj_shape (cdr (assoc 'shape prev_object_state)))) 220 | (let ((v_prev (cdr (assoc 'v prev_object_state)))) 221 | (let ((a_prev_no_friction (cdr (assoc 'a_prev prev_object_state)))) 222 | (let ((a_prev (newtons_second (force_after_friction 0 v_prev obj_shape obj_mass) obj_mass))) 223 | (let ((x_prev (cdr (assoc 'x prev_object_state)))) 224 | (let ((v (v_next v_prev a_prev DELTA_T))) 225 | (let ((x (x_next x_prev v_prev DELTA_T))) 226 | (list 227 | (pair 'object_id obj_id) 228 | (pair 'object_radius obj_radius) 229 | (pair 'shape obj_shape) 230 | (pair 'color obj_color) 231 | (pair 'mass obj_mass) 232 | (pair 'x x) 233 | (pair 'f (force_after_friction 0 v_prev obj_shape obj_mass)) 234 | (pair 't (* current_time DELTA_T)) 235 | (pair 'a_prev a_prev) 236 | (pair 'a 0) 237 | (pair 'v_0 0) 238 | (pair 'v v)) 239 | ))))) 240 | )))) 241 | ))) 242 | 243 | (define generate_next_scene_state (lambda (prev_scene_state event_state next_time) 244 | (map (generate_next_object_state next_time event_state) prev_scene_state))) 245 | 246 | (define generate_next_scene_event_state_time (lambda (next_time scene_event_state_for_times) 247 | (let ((prev_scene_event_state (get_attribute scene_event_state_for_times (- next_time 1)))) 248 | (let ((prev_scene_state (get_attribute prev_scene_event_state 'scene_states))) 249 | (let ((event_state (get_collision_events (- next_time 1) scene_event_state_for_times))) 250 | 251 | (pair next_time (list 252 | (pair 'scene_states (generate_next_scene_state prev_scene_state event_state next_time)) 253 | (pair 'event_states event_state) 254 | )) 255 | ))))) 256 | 257 | (define generate_next_scene_event_states 258 | (lambda (current_time prev_scene_event_states_for_times) 259 | (cons (generate_next_scene_event_state_time current_time prev_scene_event_states_for_times) prev_scene_event_states_for_times) 260 | )) 261 | 262 | (define generate_scene_event_states_for_times (mem (lambda (scene_id total_objects total_time) 263 | (if (= total_time 0) 264 | (list 265 | (generate_initial_scene_event_state scene_id total_objects) 266 | ) 267 | (let ((prev_scene_event_states (generate_scene_event_states_for_times scene_id total_objects (- total_time 1)))) 268 | (generate_next_scene_event_states total_time prev_scene_event_states) 269 | ))))) 270 | 271 | (define max_time 9) 272 | 273 | (define base_states_for_times (generate_scene_event_states_for_times 'this_scene get_num_objects max_time)) 274 | 275 | ;;;;;;;;;;;;;;;;;;;;;;;;;;Derived predicates. 276 | (define objects_in_scene (lambda (base_states_for_times) 277 | (let ((initial_base_states_at_time (cdr (assoc 0 (cdr base_states_for_times))))) 278 | (let ((base_state (cdr (assoc 'scene_states initial_base_states_at_time)))) 279 | base_state 280 | )) 281 | )) 282 | (define red (list 255 0 0)) 283 | (define blue (list 0 0 255)) 284 | (define is_color? (lambda (color) (lambda (object) (equal? (cdr (assoc 'color object)) color)))) 285 | (define is_shape? (lambda (shape) (lambda (object) (equal? (cdr (assoc 'shape object)) shape)))) 286 | 287 | (define all_objects (objects_in_scene base_states_for_times)) 288 | (define (exists_object predicate) 289 | (some (map predicate (objects_in_scene base_states_for_times)))) 290 | 291 | (define (filter_objects predicate) 292 | (map 293 | (lambda (o) (get_attribute o 'object_id)) 294 | (filter predicate (objects_in_scene base_states_for_times)))) 295 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 296 | (define QUICKLY_THRESHOLD 2) 297 | (define SLOWLY_THRESHOLD 2) 298 | 299 | (define is_moving_events (mem (lambda (base_states_for_times) 300 | (fold (lambda (base_state_for_time these_events) 301 | (let ((current_time (car base_state_for_time))) 302 | (let ((base_state (cdr (assoc 'scene_states (cdr base_state_for_time))))) 303 | (fold (lambda (obj_state these_events) 304 | (let ((obj_id (cdr (assoc 'object_id obj_state)))) 305 | (let ((obj_velocity (cdr (assoc 'v obj_state)))) 306 | (let ((obj_speed (abs obj_velocity))) 307 | (if (> obj_speed 0) 308 | ;; 309 | (let ((event_predicates 310 | (if (> obj_speed QUICKLY_THRESHOLD) 311 | (list 'is_moving 'is_quickly) 312 | (if (< obj_speed SLOWLY_THRESHOLD) 313 | (list 'is_moving 'is_slowly) 314 | (list 'is_moving) 315 | )) 316 | )) 317 | (cons 318 | (list 319 | (pair 'event-id (event_id_gensym)) 320 | (pair 'event_time current_time) 321 | (pair 'event_predicates event_predicates) 322 | (pair 'event_subject obj_id) 323 | (pair 'event_speed obj_speed) 324 | ) 325 | these_events)) 326 | these_events 327 | 328 | ))))) 329 | these_events base_state)))) 330 | () base_states_for_times)))) 331 | 332 | (define is_resting_events (mem (lambda (base_states_for_times) 333 | (fold (lambda (base_state_for_time these_events) 334 | (let ((current_time (car base_state_for_time))) 335 | (let ((base_state (cdr (assoc 'scene_states (cdr base_state_for_time))))) 336 | (fold (lambda (obj_state these_events) 337 | (let ((obj_id (cdr (assoc 'object_id obj_state)))) 338 | (let ((obj_velocity (cdr (assoc 'v obj_state)))) 339 | (let ((obj_speed (abs obj_velocity))) 340 | (if (= obj_speed 0) 341 | ;; 342 | (let ((event_predicates 343 | (list 'is_resting))) 344 | (cons 345 | (list 346 | (pair 'event-id (event_id_gensym)) 347 | (pair 'event_time current_time) 348 | (pair 'event_predicates event_predicates) 349 | (pair 'event_subject obj_id) 350 | (pair 'event_speed obj_speed) 351 | ) 352 | these_events)) 353 | these_events 354 | 355 | ))))) 356 | these_events base_state)))) 357 | () base_states_for_times)))) 358 | 359 | (define is_colliding_events (mem (lambda (base_states_for_times) 360 | (fold (lambda (base_state_for_time these_events) 361 | (let ((current_time (car base_state_for_time))) 362 | (let ((event_states (cdr (assoc 'event_states (cdr base_state_for_time))))) 363 | (fold (lambda (event_state these_events) 364 | (let ((subject_initial_speed (abs (get_attribute event_state 'subject_initial_v)))) 365 | (let ((subject_final_speed (abs (get_attribute event_state 'subject_final_v)))) 366 | (let ((object_initial_speed (abs (get_attribute event_state 'object_initial_v)))) 367 | (let ((cause_subject_object_event (and (> subject_initial_speed 0) (= object_initial_speed 0)))) 368 | (let 369 | ((event_predicates 370 | (if (and cause_subject_object_event (eq? subject_final_speed 0)) 371 | (list 'is_launching 'is_hitting 'is_colliding) 372 | (if (> subject_initial_speed 0) 373 | (list 'is_hitting 'is_colliding) 374 | (list 'is_colliding) 375 | ) 376 | ))) 377 | 378 | (cons (list 379 | (pair 'event-id (get_attribute event_state 'event-id)) 380 | (pair 'event_time (get_attribute event_state 'event_time)) 381 | (pair 'event_predicates event_predicates) 382 | (pair 'event_subject (get_attribute event_state 'event_subject)) 383 | (pair 'event_object (get_attribute event_state 'event_object)) 384 | (pair 'subject_initial_v (get_attribute event_state 'subject_initial_v )) 385 | (pair 'subject_final_v (get_attribute event_state 'subject_final_v )) 386 | (pair 'object_initial_v (get_attribute event_state 'object_initial_v )) 387 | ) these_events)))))) 388 | ) these_events event_states) 389 | ))) 390 | () base_states_for_times) 391 | 392 | ))) 393 | 394 | 395 | 396 | (define events_in_scene (concatenate 397 | (is_colliding_events base_states_for_times) 398 | (concatenate 399 | (is_moving_events base_states_for_times) 400 | (is_resting_events base_states_for_times)))) 401 | 402 | 403 | (define is_event? (lambda (event_predicate event) (member? event_predicate (get_attribute event 'event_predicates)))) 404 | 405 | (define is_subject_of_event? (lambda (event object ) (equal? 406 | (get_attribute event 'event_subject) 407 | (get_attribute object 'object_id) 408 | ))) 409 | 410 | (define is_object_of_event? (lambda (event object ) (equal? 411 | (get_attribute event 'event_object) 412 | (get_attribute object 'object_id) 413 | ))) 414 | 415 | (define event_subject_is? (lambda (event predicate) (member? 416 | (get_attribute event 'event_subject) 417 | (filter_objects predicate) 418 | ))) 419 | (define event_object_is? (lambda (event predicate) (member? 420 | (get_attribute event 'event_object) 421 | (filter_objects predicate) 422 | ))) 423 | 424 | (define (exists_event predicate) 425 | (some (map predicate events_in_scene))) 426 | 427 | (define (filter_events predicate) 428 | (filter predicate events_in_scene)) -------------------------------------------------------------------------------- /domains/d3-grounded-visual-reasoning/static-scenes/prompt-examples.scm: -------------------------------------------------------------------------------- 1 | ;; Condition: There's a blue thing. 2 | (condition (> (length ((filter-color blue) (objects-in-scene 'this-scene))) 0)) 3 | 4 | ;; Condition: There's at least two blue plates. 5 | (condition (>= (length 6 | ((filter-color blue) 7 | ((filter-shape 'plate) 8 | (objects-in-scene 'scene)))) 9 | 2)) 10 | 11 | ;; Condition: There's many blue plates. 12 | (condition (>= (length 13 | ((filter-color blue) 14 | ((filter-shape 'plate) 15 | (objects-in-scene 'scene)))) 16 | 5)) 17 | 18 | ;; Condition: There's exactly two plates and there's also a yellow thing. 19 | (condition 20 | (and (= (length ((filter-shape 'plate) (objects-in-scene 'scene))) 2) 21 | (> (length ((filter-color yellow) (objects-in-scene 'scene))) 0))) 22 | 23 | ;; Query: Is there a mug? 24 | (query (> (length ((filter-shape 'mug) (objects-in-scene 'this-scene))) 0)) -------------------------------------------------------------------------------- /domains/d3-grounded-visual-reasoning/static-scenes/world-model.scm: -------------------------------------------------------------------------------- 1 | ;; -- Visual Reasoning in Church -- 2 | ;; Author: Lio Wong (zyzzyva@mit.edu) 3 | 4 | ;; Objects have a shape attribute, which is a choice of cube, sphere, or cylinder shape categories. 5 | (define choose-shape 6 | (mem (lambda (obj-id) 7 | (pair 'shape (uniform-draw '(mug can bowl)))))) 8 | 9 | ;; Objects have a color attribute that is drawn from a predefined set of RGB values. 10 | (define choose-color 11 | (mem (lambda (obj-id) 12 | (pair 'color (uniform-draw (list 13 | (list 255 0 0) 14 | (list 0 0 255) 15 | (list 0 255 0) 16 | (list 255 255 0) 17 | )))))) 18 | ;; An object is an object ID, and the object's attribute types and their values. 19 | (define object (mem (lambda (obj-id) (list 20 | (pair 'object-id obj-id) 21 | (choose-shape obj-id) 22 | (choose-color obj-id))))) 23 | 24 | ;; Scenes can have a maximum of 12 objects. 25 | (define max-objects 12) 26 | ;; The number of objects in a scene tends to be not too large, and is capped at the maximum number of objects. 27 | (define choose-num-objects 28 | (mem (lambda (scene-id) (floor (min max-objects (* max-objects (exponential 1))))))) 29 | 30 | ;; Then, for each object we intend to generate, generate an object indexical, and associate it with a choice of attributes. 31 | (define obj-id-gensym (make-gensym "obj-")) 32 | (define (generate-n-objects scene-id total-objects) 33 | (if (= total-objects 0) 34 | (list (object (obj-id-gensym))) 35 | (cons (object (obj-id-gensym)) (generate-n-objects scene-id (- total-objects 1))))) 36 | (define objects-in-scene (mem (lambda (scene-id) (generate-n-objects scene-id (choose-num-objects scene-id))))) 37 | 38 | 39 | ;; An object is red if it is of this continuous color value. 40 | (define red (list 255 0 0)) 41 | ;; An object is blue if it is of this continuous color value. 42 | (define blue (list 0 0 255)) 43 | ;; An object is green if it is of this continuous color value. 44 | (define green (list 0 255 0)) 45 | ;; An object is yellow if it is of this continuous color value. 46 | (define yellow (list 255 255 0)) 47 | 48 | ;; Check if an object is of a given shape. 49 | (define is-shape? (lambda (shape) (lambda (object) (equal? (cdr (assoc 'shape object)) shape)))) 50 | ;; Check if an object is of a given named color. 51 | (define is-color? (lambda (color) (lambda (object) (equal? (cdr (assoc 'color object)) color)))) 52 | 53 | ;; Select only objects from the scene of a given color. 54 | (define filter-color(lambda (color) (lambda (object-list) (filter (is-color? color) object-list)))) 55 | 56 | ;; Select only objects from the scene of a given shape. 57 | (define filter-shape (lambda (shape) (lambda (object-list) (filter (is-shape? shape) object-list)))) -------------------------------------------------------------------------------- /domains/d4-goal-directed-reasoning/prompt-examples.scm: -------------------------------------------------------------------------------- 1 | ;; Condition: Bob likes pizza. 2 | (condition (> (restaurant_utility 'bob 'pizza) 0)) 3 | 4 | ;; Condition: Bob really likes pizza. 5 | (condition (> (restaurant_utility 'bob 'pizza) 10)) 6 | 7 | ;; Condition: Bob does not like pizza, and he actually despises vegetables. 8 | (condition 9 | (and (< (restaurant_utility 'bob 'pizza) 0) 10 | (< (restaurant_utility 'bob 'vegetarian) 10))) 11 | 12 | ;; Condition: The pizza place is not open. 13 | (condition (not (is_open 'pizza))) 14 | 15 | ;; Condition: Bob walked North on Danner. 16 | (condition (exists_action 'bob (lambda (action) 17 | (and 18 | (is_subject_of_action? action 'bob) 19 | (is_action? action 'is_walking) 20 | (is_action? action 'north) 21 | (is_preposition_of_action? action 'on) 22 | (is_location_of_action? action 'danner))))) 23 | 24 | ;; Query: Does Bob like vegetarian food? 25 | (query (> (restaurant_utility 'bob 'vegetarian) 0)) 26 | 27 | ;; Condition: Where is Bob going? 28 | (query (get_actions 'bob (lambda (action) 29 | (and (is_subject_of_action? action 'bob) 30 | (is_action? action 'is_going))))) 31 | 32 | ;; Query: Where will Bob go to for lunch? 33 | (query (get_location (first 34 | (get_actions 'bob (lambda (action) 35 | (and (and 36 | (is_subject_of_action? action 'bob) 37 | (is_action? action 'is_going)) 38 | (is_preposition_of_action? action 'to))))))) -------------------------------------------------------------------------------- /domains/d4-goal-directed-reasoning/world-model.scm: -------------------------------------------------------------------------------- 1 | ;; -- Planning in Church -- 2 | ;; Author: Lio Wong (zyzzyva@mit.edu) 3 | 4 | (define gridworld (list 5 | (list 'ames 'lawn 'lawn 'lawn 'sushi) 6 | (list 'ames 'lawn 'lawn 'lawn 'danner) 7 | (list 'office 'barlow 'barlow 'barlow 'danner) 8 | (list 'ames 'lawn 'lawn 'lawn 'danner) 9 | (list 'ames 'lawn 'lawn 'lawn 'vegetarian) 10 | (list 'pizza 'carson 'carson 'carson 'danner) 11 | )) 12 | (define restaurants (list 'sushi 'pizza 'vegetarian)) 13 | 14 | (define initial_x 1) 15 | (define initial_y 3) 16 | 17 | 18 | (define has_bike (mem (lambda (agent-id) (flip)))) 19 | (define available_motions (mem (lambda (agent-id) (if (has_bike agent-id) (list 'is_walking 'is_biking) (list 'is_walking))))) 20 | (define directions (list 'west 'east 'north 'south)) 21 | (define available_actions (mem (lambda (agent-id) (cons (pair 'stay 'stay) (cartesian_product (available_motions agent-id) directions))))) 22 | 23 | (define is_open (mem (lambda (restaurant_type) (flip)))) 24 | (define POSITIVE_UTILITY_MEAN 10) 25 | (define NEGATIVE_UTILITY_MEAN -10) 26 | (define UTILITY_VARIANCE 1) 27 | (define restaurant_utility (mem (lambda (agent-id restaurant_type) 28 | (uniform-draw 29 | (list 30 | (gaussian POSITIVE_UTILITY_MEAN UTILITY_VARIANCE) 31 | (gaussian NEGATIVE_UTILITY_MEAN UTILITY_VARIANCE) 32 | ))))) 33 | 34 | (define motion_utility (mem (lambda (agent-id location_type motion_type) 35 | (case location_type 36 | (('lawn) (case motion_type 37 | (('is_biking) -1) 38 | (('is_walking) -0.2) 39 | (('is_staying) 0) 40 | (else 0)) 41 | ) 42 | (else (case motion_type 43 | (('is_biking) -0.01) 44 | (('is_walking) -0.2) 45 | (('is_staying) 0) 46 | (else 0))) 47 | )))) 48 | 49 | (define food_utility (mem (lambda (agent-id location_type) 50 | (case location_type 51 | (('lawn) 0) 52 | (('ames) 0) 53 | (('barlow) 0) 54 | (('carson) 0) 55 | (('danner) 0) 56 | (('office) 0) 57 | (else 58 | (if (is_open location_type) (restaurant_utility agent-id location_type) NEGATIVE_UTILITY_MEAN)) 59 | )))) 60 | 61 | (define utility_function (mem (lambda (agent-id gridworld state_x state_y action) 62 | (let ((location_type (get_gridworld_at gridworld state_x state_y))) 63 | (let ((motion_type (car action))) 64 | (let ((state_food_utility (food_utility agent-id location_type))) 65 | (let ((state_motion_utility (motion_utility agent-id location_type motion_type))) 66 | (+ state_food_utility state_motion_utility)))))))) 67 | 68 | (define get_gridworld_at (lambda (gridworld x y) 69 | (list-elt (list-elt gridworld y) x) 70 | )) 71 | (define x_increment (lambda (direction) 72 | (case direction 73 | (('west) -1) 74 | (('east) 1) 75 | (('north) 0) 76 | (('south) 0) 77 | (('stay) 0) 78 | ))) 79 | (define y_increment (lambda (direction) 80 | (case direction 81 | (('north) -1) 82 | (('south) 1) 83 | (('west) 0) 84 | (('east) 0) 85 | (('stay) 0) 86 | ))) 87 | (define gridworld_max_x (lambda (gridworld) (length (list-elt gridworld 1)))) 88 | (define gridworld_max_y (lambda (gridworld) (length gridworld))) 89 | (define gridworld_transition (lambda (gridworld current_x current_y action) 90 | (let ((direction (cdr action))) 91 | (let ((next_x (if (>= current_x (gridworld_max_x gridworld)) current_x (+ (x_increment direction) current_x)))) 92 | (let ((next_x (if (< next_x 1) current_x next_x))) 93 | (let ((next_y (if (>= current_y (gridworld_max_y gridworld)) current_y (+ (y_increment direction) current_y)))) 94 | (let ((next_y (if (< next_y 1) current_y next_y))) 95 | (let ((next_state (get_gridworld_at gridworld next_x next_y))) 96 | (list next_state next_x next_y) 97 | )))))))) 98 | 99 | (define value_function (mem (lambda (agent-id curr_iteration gridworld state_x state_y) 100 | (if (equal? curr_iteration -1) 0 101 | (let ((prev_optimal_action_value (optimal_action_value agent-id (- curr_iteration 1) gridworld state_x state_y))) 102 | (cdr prev_optimal_action_value)) 103 | )))) 104 | 105 | (define available_actions_to_values (mem (lambda (agent-id curr_iteration gridworld state_x state_y) 106 | (map (lambda (action) 107 | (let ((utility (utility_function agent-id gridworld state_x state_y action))) 108 | (let ((next_state (gridworld_transition gridworld state_x state_y action))) 109 | (let ((next_state_x (second next_state))) 110 | (let ((next_state_y (third next_state))) 111 | (let ((next_state_value (value_function agent-id curr_iteration gridworld next_state_x next_state_y))) 112 | (pair action (+ utility next_state_value)) 113 | )))))) 114 | (available_actions agent-id)) 115 | ))) 116 | 117 | (define optimal_action_value (mem (lambda (agent-id curr_iteration gridworld state_x state_y) 118 | (let ((actions_to_values (available_actions_to_values agent-id curr_iteration gridworld state_x state_y))) 119 | (max_cdr actions_to_values) 120 | ) 121 | ))) 122 | 123 | (define MAX_ITERATIONS 20) 124 | (define should_terminate (mem (lambda (agent-id gridworld state_x state_y) 125 | (if (<= (value_function agent-id MAX_ITERATIONS gridworld initial_x initial_y) 0) true 126 | (let ((location_type (get_gridworld_at gridworld state_x state_y))) 127 | (let ((state_food_utility (food_utility agent-id location_type))) 128 | (> state_food_utility 0))))))) 129 | 130 | 131 | 132 | (define optimal_policy_from_initial_state (mem (lambda (agent-id gridworld state_x state_y) 133 | (if (should_terminate agent-id gridworld state_x state_y) () 134 | (let ((curr_optimal_action_value (optimal_action_value agent-id MAX_ITERATIONS gridworld state_x state_y))) 135 | (let ((curr_optimal_action (car curr_optimal_action_value))) 136 | (let ((next_state (gridworld_transition gridworld state_x state_y curr_optimal_action))) 137 | (let ((next_state_x (second next_state))) 138 | (let ((next_state_y (third next_state))) 139 | (let ((remaining_policy (optimal_policy_from_initial_state agent-id gridworld next_state_x next_state_y))) 140 | (cons curr_optimal_action remaining_policy) 141 | )))))))))) 142 | 143 | (define trajectory_from_initial_state (mem (lambda (agent-id gridworld state_x state_y) 144 | (if (should_terminate agent-id gridworld state_x state_y) () 145 | (let ((curr_optimal_action_value (optimal_action_value agent-id MAX_ITERATIONS gridworld state_x state_y))) 146 | (let ((curr_optimal_action (car curr_optimal_action_value))) 147 | (let ((next_state (gridworld_transition gridworld state_x state_y curr_optimal_action))) 148 | (let ((next_state_location (first next_state))) 149 | (let ((next_state_x (second next_state))) 150 | (let ((next_state_y (third next_state))) 151 | (let ((remaining_trajectory (trajectory_from_initial_state agent-id gridworld next_state_x next_state_y))) 152 | (cons next_state_location remaining_trajectory)) 153 | )))))))))) 154 | 155 | (define optimal_policy (mem (lambda (agent-id gridworld initial_state_x initial_state_y) 156 | (cons (pair 'start 'start) (optimal_policy_from_initial_state agent-id gridworld initial_state_x initial_state_y))))) 157 | 158 | (define optimal_trajectory (mem (lambda (agent-id gridworld initial_state_x initial_state_y) 159 | (cons (get_gridworld_at gridworld initial_state_x initial_state_y) (trajectory_from_initial_state agent-id gridworld initial_state_x initial_state_y)) 160 | ))) 161 | 162 | (define optimal_policy_with_trajectory (mem (lambda (agent-id gridworld initial_state_x initial_state_y) 163 | (zip (optimal_policy agent-id gridworld initial_state_x initial_state_y) (optimal_trajectory agent-id gridworld initial_state_x initial_state_y)) 164 | ))) 165 | 166 | (define get_terminal_goal_state (mem (lambda (agent-id gridworld initial_state_x initial_state_y) 167 | (last (optimal_trajectory agent-id gridworld initial_state_x initial_state_y))))) 168 | 169 | (define trajectory_has_location_type? (mem (lambda (agent-id location_type gridworld initial_state_x initial_state_y) 170 | (member? location_type (optimal_trajectory agent-id gridworld initial_state_x initial_state_y)) 171 | ))) 172 | (define policy_has_motion_type? (mem (lambda (agent-id motion_type gridworld initial_state_x initial_state_y) 173 | (let ((policy_motions (map (lambda (action) (first action)) (optimal_policy agent-id gridworld initial_state_x initial_state_y)))) 174 | (member? motion_type policy_motions) 175 | )))) 176 | (define policy_and_trajectory_has_motion_at_location? (mem (lambda (agent-id motion_type location_type gridworld initial_state_x initial_state_y) 177 | (let ((policy_motions (map (lambda (action) (first action)) (optimal_policy agent-id gridworld initial_state_x initial_state_y)))) 178 | (let ((trajectory (optimal_trajectory agent-id gridworld initial_state_x initial_state_y))) 179 | (let ((motions_at_locations (zip policy_motions trajectory))) 180 | (member? (list motion_type location_type) motions_at_locations) 181 | )))))) 182 | 183 | (define motion_at_location? (mem (lambda (agent-id motion_type location_type gridworld initial_state_x initial_state_y) 184 | (let ((policy_motions (map (lambda (action) (first action)) (optimal_policy agent-id gridworld initial_state_x initial_state_y)))) 185 | (let ((trajectory (optimal_trajectory agent-id gridworld initial_state_x initial_state_y))) 186 | (let ((motions_at_locations (zip policy_motions trajectory))) 187 | motions_at_locations 188 | )))))) 189 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 190 | ;; Derived predicates. 191 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 192 | (define action_id_gensym (make_gensym "action-")) 193 | (define is_going_to_actions (mem (lambda (agent-id) 194 | (let ((action_states (optimal_policy_with_trajectory agent-id gridworld initial_x initial_y))) 195 | (let ((final_location (last (last action_states)))) 196 | (list (list 197 | (pair 'action_id (action_id_gensym)) 198 | (pair 'action_subject agent-id) 199 | (pair 'action_predicates (list 'is_going (list 'to final_location))) 200 | (pair 'action_preposition 'to) 201 | (pair 'action_location final_location) 202 | ))))))) 203 | 204 | (define is_going_on_actions (mem (lambda (agent-id) 205 | (let ((action_states (optimal_policy_with_trajectory agent-id gridworld initial_x initial_y))) 206 | (fold (lambda (action_state these_actions) 207 | (let ((action_location (last action_state))) 208 | (let ((action_manner (first (first action_state)))) 209 | (let ((action_direction (cdr (first action_state)))) 210 | (cons 211 | (list 212 | (pair 'action_id (action_id_gensym)) 213 | (pair 'action_subject agent-id) 214 | (pair 'action_predicates (list 'is_going action_manner action_direction (list 'on action_location))) 215 | (pair 'action_preposition 'on) 216 | (pair 'action_location action_location) 217 | ) 218 | these_actions) 219 | )))) 220 | () action_states) 221 | )))) 222 | 223 | (define actions_in_scene (mem (lambda (agent-id) (concatenate (is_going_to_actions agent-id) (is_going_on_actions agent-id))))) 224 | (define is_action? (lambda (action action_predicate) (member? action_predicate (lookup action 'action_predicates)))) 225 | (define is_subject_of_action? (lambda (action entity) (eq? 226 | (lookup action 'action_subject) 227 | entity 228 | ))) 229 | 230 | (define is_preposition_of_action? (lambda (action preposition) (eq? 231 | (lookup action 'action_preposition) 232 | preposition 233 | ))) 234 | (define is_location_of_action? (lambda (action location) (eq? 235 | (lookup action 'action_location) 236 | location 237 | ))) 238 | 239 | (define get_location (lambda (action) 240 | (lookup action 'action_location) 241 | )) 242 | 243 | (define (exists_action agent-id predicate) 244 | (some (map predicate (actions_in_scene agent-id)))) 245 | 246 | (define (get_actions agent-id predicate) 247 | (fold (lambda (action these_actions) (if (predicate action) (cons action these_actions) these_actions)) 248 | () (actions_in_scene agent-id)) 249 | ) --------------------------------------------------------------------------------