├── DAYDREAMERUpdate.pdf ├── INSTALL ├── LICENSE ├── README.md ├── compat.cl ├── dd.cl ├── dd_cntrl.cl ├── dd_compile.cl ├── dd_epis.cl ├── dd_gen.cl ├── dd_get.cl ├── dd_kb.cl ├── dd_macros.cl ├── dd_mutation.cl ├── dd_night.cl ├── dd_reversal.cl ├── dd_ri.cl ├── dd_rule1.cl ├── dd_rule2.cl ├── dd_utils.cl ├── gate_compile.cl ├── gate_cx.cl ├── gate_get.cl ├── gate_instan.cl ├── gate_macros.cl ├── gate_main.cl ├── gate_obs.cl ├── gate_prove.cl ├── gate_read_pr.cl ├── gate_test.cl ├── gate_ty.cl ├── gate_unify.cl ├── gate_utils.cl ├── hello_world.cl ├── inputemployment1.txt ├── inputlovers1.txt ├── inputlovers2.txt ├── inputlovers3.txt ├── inputrecovery3.txt ├── loop.cl ├── outputhelloworld.txt ├── outputlovers1.txt └── outputtest.txt /DAYDREAMERUpdate.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eriktmueller/daydreamer/8acb2f37ef4deae1da83b8cc7fb17375ea53a576/DAYDREAMERUpdate.pdf -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | This directory contains the Daydreamer and GATE programs as described 2 | in the book: 3 | 4 | Mueller, Erik T. (1990). Daydreaming in humans and machines: A 5 | computer model of the stream of thought. Norwood, NJ: Ablex. 6 | 7 | This code is subject to the LICENSE in this directory. 8 | 9 | To run Daydreamer and GATE, start up a Common Lisp in this directory. 10 | 11 | This code runs best compiled. 12 | To compile GATE, do (load "gate_compile"). 13 | To compile Daydreamer, do (load "dd_compile"). 14 | 15 | Then, to run the LOVERS1 experience, a rationalization daydream, and a 16 | revenge daydream, type (load "dd"). 17 | 18 | Alternatively: 19 | To run a GATE test suite, do (load "gate_test"). 20 | 21 | To load GATE, do (load "gate_get"). 22 | 23 | To load Daydreamer, first load GATE and then do (load "dd_get"). Then 24 | to run Daydreamer, type (daydreamer). 25 | 26 | As of 2004-12-20, this has been tested under: 27 | Allegro Common Lisp 6.2 28 | Allegro Common Lisp 7.0 29 | 30 | END 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | {description} 294 | Copyright (C) {year} {fullname} 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | {signature of Ty Coon}, 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | 341 | -------------------------------------------------------------------------------- /compat.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains: 10 | ; Compatibility functions for T2.8/T3 (Scheme) code running under Common Lisp 11 | ; 12 | ; 19990429: begun 13 | ; 19990503: more work 14 | ; 15 | ;******************************************************************************* 16 | 17 | (setq else t) 18 | (setq *repl-wont-print* nil) 19 | (defun t-or-nil (a) (if a 't nil)) 20 | (defmacro string->symbol (a) `(intern ,a)) 21 | (defmacro symbol->string (a) `(symbol-name ,a)) 22 | (defmacro string-length (a) `(length ,a)) 23 | (defmacro string-empty? (a) `(= (length ,a) 0)) 24 | (defmacro string-slice (a b c) `(subseq ,a ,b ,c)) 25 | (defmacro substring (a b c) `(subseq ,a ,b ,c)) 26 | (defmacro string-nthtail (a b) `(subseq ,a ,b (length ,a))) 27 | (defmacro nthchdr (a b) `(subseq ,a ,b (length ,a))) 28 | (defmacro string-downcase! (a) `(string-downcase ,a)) 29 | (defmacro string-write (a b) `(write-string ,b ,a)) 30 | (defmacro map-string! (a b) `(map `string ,a ,b)) 31 | (defmacro string-equal? (a b) `(string-equal ,a ,b)) 32 | (defmacro chdr (a) `(subseq ,a 1 (length ,a))) 33 | (defmacro nthchar (a b) `(elt ,a ,b)) 34 | (defmacro digit? (a b) `(digit-char-p ,a ,b)) 35 | (defmacro string-append (&rest args) `(concatenate 'string ,@args)) 36 | (defmacro any? (a b) `(t-or-nil (some ,a ,b))) 37 | (defmacro any (a b) `(some ,a ,b)) 38 | (defmacro null? (a) `(null ,a)) 39 | (defmacro eq? (a b) `(eql ,a ,b)) 40 | (defmacro alikeq? (a b) `(equalp ,a ,b)) 41 | (defmacro neq? (a b) `(not (eql ,a ,b))) 42 | (defmacro memq? (a b) `(t-or-nil (member ,a ,b))) 43 | (defmacro memq (a b) `(member ,a ,b)) 44 | (defmacro gen-id (symbol) `(gensym ,symbol)) 45 | (defmacro div (a b) `(/ ,a ,b)) 46 | (defmacro procedure? (x) `(functionp ,x)) 47 | (defmacro number? (x) `(numberp ,x)) 48 | (defmacro flonum? (x) `(floatp ,x)) 49 | (defmacro fixnum->flonum (x) x) 50 | (defmacro symbol? (x) `(symbolp ,x)) 51 | (defmacro pair? (a) `(consp ,a)) 52 | (defmacro string? (a) `(stringp ,a)) 53 | (defmacro uppercase? (x) `(upper-case-p ,x)) 54 | (defmacro delq! (a b) `(delete ,a ,b)) 55 | (defmacro append! (a b) `(nconc ,a ,b)) 56 | (defmacro ascii->char (x) `(code-char ,x)) 57 | (defmacro assq (a b) `(assoc ,a ,b)) 58 | (defmacro increment-me (a) `(setq ,a (+ ,a 1))) 59 | (defmacro string-posq (a b) `(position ,a ,b)) 60 | (defmacro nth-elem (a b) `(nth ,b ,a)) 61 | (defmacro newline (a) `(terpri ,a)) 62 | (defmacro -1+ (a) `(+ -1 ,a)) 63 | (defmacro fl+ (a b) `(+ ,a ,b)) 64 | (defmacro fl- (a b) `(- ,a ,b)) 65 | (defmacro fl* (a b) `(* ,a ,b)) 66 | (defmacro fl/ (a b) `(/ ,a ,b)) 67 | (defmacro fl< (a b) `(< ,a ,b)) 68 | (defmacro fl> (a b) `(> ,a ,b)) 69 | (defmacro fl>= (a b) `(>= ,a ,b)) 70 | (defmacro fl<= (a b) `(<= ,a ,b)) 71 | (defmacro fl= (a b) `(> ,a ,b)) 72 | (defmacro file-exists? (a) `(probe-file ,a)) 73 | (defmacro comment (a) nil) 74 | (defmacro mem? (a b c) `(t-or-nil (member ,b ,c :test ,a))) 75 | (defmacro mem (a b c) `(member ,b ,c :test ,a)) 76 | (defmacro every? (a b) `(t-or-nil (every ,a ,b))) 77 | (defmacro tlast (a) `(car (last ,a 1))) 78 | (defun standard-input () *standard-input*) 79 | (defun standard-output () *standard-output*) 80 | (defun string-head (x) (char x 0)) 81 | (defun walkcdr (fn x) 82 | (yloop (initial (rest x)) 83 | (ywhile rest) 84 | (ydo (apply fn (list rest)) 85 | (setq rest (cdr rest))))) 86 | 87 | ; End of file. 88 | -------------------------------------------------------------------------------- /dd.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Daydreamer 4 | ; Version 3.5 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ;******************************************************************************* 10 | 11 | ; 12 | ; Traces in book: 13 | ; lovers1 - "I want to be going out with someone..." 14 | ; revenge1 - "I am a movie star..." 15 | ; rationalization1 - "He would go to Cairo..." 16 | ; rationalization2 - "I remember the time my being turned down by Irving..." 17 | ; rationalization3 - "Anyway, I was well dressed..." 18 | ; roving1 - "I remember the time Steve told me..." 19 | ; recovery2 = oseren? - "I have to call him..." 20 | ; recovery3 - "I have the UCLA Alumni directory..." 21 | ; revenge3 - "I remember the time I got even with..." 22 | ; computer-serendipity - "I remember the time Harold and I broke the ice..." 23 | ; 24 | ; Additional traces in dissertation: 25 | ; employment1 (dissertation only) - "I want to have enough money..." 26 | ; 27 | ; 28 | ; all -- every rule in a complete DAYDREAMER run 29 | ; always -- rule should always be loaded in any run 30 | ; employment1-revenge 31 | ; mut -- action mutations 32 | ; mut-alone -- action mutations only 33 | ; mut4 -- action mutation example 4 34 | ; mut5 -- action mutation example 5 35 | ; rain --- Can be used in conjunction with recovery3 36 | ; unused -- rule is currently never used 37 | ; 38 | 39 | (setq *gate-load-options* '(always 40 | lovers1 41 | rationalization1 42 | rationalization2 43 | rationalization3 44 | revenge1)) 45 | 46 | (load "gate_get.cl") 47 | (load "dd_get.cl") 48 | (daydreamer) 49 | 50 | ; End of file. 51 | -------------------------------------------------------------------------------- /dd_compile.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Daydreamer 4 | ; Version 3.5 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ;******************************************************************************* 10 | 11 | (setq *question-mark-atom* '?) 12 | (load "compat.cl") 13 | (load "loop.cl") 14 | (load "gate_macros.cl") 15 | (load "dd_macros.cl") 16 | 17 | (compile-file "dd_cntrl.cl") 18 | (compile-file "dd_epis.cl") 19 | (compile-file "dd_gen.cl") 20 | (compile-file "dd_mutation.cl") 21 | (compile-file "dd_night.cl") 22 | (compile-file "dd_reversal.cl") 23 | (compile-file "dd_ri.cl") 24 | (compile-file "dd_utils.cl") 25 | (compile-file "dd_rule1.cl") 26 | (compile-file "dd_rule2.cl") 27 | 28 | ; End of file. 29 | -------------------------------------------------------------------------------- /dd_get.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Daydreamer 4 | ; Version 3.5 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ;******************************************************************************* 10 | 11 | (progn 12 | (setq *dd-version* "DAYDREAMER 3.5, Common Lisp version of 2004-12-20") 13 | (format t "=======================~%") 14 | (format t "Loading ~A...~%" *dd-version*) 15 | (format t "=======================~%") 16 | nil) 17 | 18 | (load "dd_macros") 19 | (load "dd_cntrl") 20 | (load "dd_epis") 21 | (load "dd_mutation") 22 | (load "dd_night") 23 | (load "dd_reversal") 24 | (load "dd_ri") 25 | (load "dd_rule1") 26 | (load "dd_rule2") 27 | (load "dd_utils") 28 | 29 | (do-interest #'interest) 30 | 31 | (setq *subsets* *gate-load-options*) 32 | 33 | (cond 34 | ((memq? 'lovers3 *gate-load-options*) 35 | (setq *gate-input* (open "inputlovers3.txt"))) 36 | ((memq? 'lovers2 *gate-load-options*) 37 | (setq *gate-input* (open "inputlovers2.txt"))) 38 | ((memq? 'lovers1 *gate-load-options*) 39 | (setq *gate-input* (open "inputlovers1.txt"))) 40 | ((memq? 'employment1 *gate-load-options*) 41 | (setq *gate-input* (open "inputemployment1.txt"))) 42 | ((memq? 'recovery3-alone *gate-load-options*) 43 | (setq *gate-input* (open "inputrecovery3.txt")))) 44 | 45 | (epmem-init) 46 | 47 | (load "dd_kb.cl") 48 | (load "dd_gen.cl") 49 | 50 | (setq *gen-stream* (make-gen-stream *gate-dbg*)) 51 | 52 | (format t "=======================~%") 53 | (format t "Welcome to ~A~%" *dd-version*) 54 | (format t "=======================~%") 55 | 56 | ; End of file. 57 | -------------------------------------------------------------------------------- /dd_macros.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Daydreamer 4 | ; Version 3.5 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ;******************************************************************************* 10 | 11 | (defmacro define-initial-fact (subsets spec) 12 | `(if (loadable-subsets? ',subsets) 13 | (let ((temp (ob$create ',spec))) 14 | (setq *initial-facts* (cons temp *initial-facts*)) 15 | temp) 16 | nil)) 17 | 18 | ; 19 | ; Episode definition 20 | ; 21 | ; (define-episode 22 | ; ( [ | nil] ...)) 23 | ; 24 | ; Todo: A define-episode pretty-printer (full obs are too cumbersome) 25 | ; 26 | ; Plan-thresh and reminding-thresh must include the rule index. 27 | ; 28 | (defmacro define-episode (subsets indices 29 | plan-thresh reminding-thresh 30 | episode-defn) 31 | `(if (loadable-subsets? ',subsets) 32 | (let ((ep-context (cx$create)) 33 | (ep nil) 34 | ; If indices are present, only the top-level goal of episode 35 | ; is retrievable. 36 | (hidden? (not (nil? ',indices))) 37 | (temp nil)) 38 | (ndbg-roman-nl *gate-dbg* rule "Defining episode...") 39 | (setq ep (ob$get (episode-defn->stored-episode ',episode-defn 40 | ep-context 41 | hidden?) 42 | 'episode)) 43 | (if hidden? 44 | (progn 45 | (ob$set ep 'plan-threshold *infinite-thresh*) 46 | (ob$set ep 'reminding-threshold 1) 47 | (yloop (yfor index in ',indices) 48 | (ydo (if (symbol? index) 49 | (setq temp (ob$name->ob index)) 50 | (setq temp (ob$fcreate index))) 51 | (if (null? temp) 52 | (progn 53 | (error "Trouble with defining ~A" index) 54 | (ndbg-roman-nl *gate-dbg* rule "Ignored.")) 55 | (progn 56 | (epmem-store ep temp t t))))))) 57 | (if ,plan-thresh (ob$set ep 'plan-threshold ,plan-thresh)) 58 | (if ,reminding-thresh 59 | (ob$set ep 'reminding-threshold ,reminding-thresh)) 60 | ep) 61 | nil)) 62 | 63 | (defmacro with-no-dbg (&rest rest) 64 | `(unwind-protect 65 | (progn 66 | (do-interest #'disinterest) 67 | ,@rest) 68 | (do-interest #'interest))) 69 | 70 | (defmacro self-type-ok? (rule self) 71 | `(or (null? (ob$gets ,rule 'self-type)) 72 | (any? (lambda (x) (ty$instance-of? ,self x)) 73 | (ob$gets ,rule 'self-type)))) 74 | 75 | (defmacro define-rule (name subsets spec) 76 | (if (loadable-subsets? subsets) 77 | (let ((rule (ob$name->ob name)) 78 | (ruleob (ob$create spec))) 79 | (if rule 80 | (progn 81 | ; (if (not (memq? rule *rules*)) 82 | ; (add-rule rule)) 83 | (rule-destroy-chaining rule) 84 | (ob$remove-all rule) 85 | (ob$concatenate! rule ruleob) 86 | (rule-create-chaining rule) 87 | (ndbg-roman *gate-dbg* rule "~A redefined " name)) 88 | (progn 89 | (if (nil? name) 90 | (progn 91 | (setq rule (ob$create-empty)) 92 | (ob$concatenate! rule ruleob)) 93 | (progn 94 | (setq rule (ob$create-empty)) 95 | (ob$add-name rule name) 96 | (ob$concatenate! rule ruleob))) 97 | (ob$set rule 'accessible? t) 98 | (add-rule rule))) 99 | (check-rule rule (ob$name rule)) 100 | (list 'quote (ob$name rule))) 101 | (list 'quote 'rule-not-loaded))) 102 | 103 | (defmacro possible-unify? (ob1 ob2) 104 | `(or (special? ,ob1) 105 | (special? ,ob2) 106 | (var? ,ob1) 107 | (var? ,ob2) 108 | (eq? (ob$ty ,ob1) (ob$ty ,ob2)))) 109 | 110 | (defmacro ri-pathelt-rule (x) 111 | `(car ,x)) 112 | 113 | (defmacro ri-pathelt-subgoalnum (x) 114 | `(cadr ,x)) 115 | 116 | (defmacro ri-pathelt-episodes (x) 117 | `(cddr ,x)) 118 | 119 | (defmacro ri-pathelt-make (rule subgoalnum episodes) 120 | `(cons ,rule (cons ,subgoalnum ,episodes))) 121 | 122 | (defmacro chain-rule (x) 123 | `(car ,x)) 124 | 125 | (defmacro chain-num (x) 126 | `(cadr ,x)) 127 | 128 | (defmacro old-backward-chain-rules (goal-obj) 129 | `(if (ob$get ,goal-obj 'plan-rule) 130 | (ob$gets (ob$get ,goal-obj 'plan-rule) 'backward-chain) 131 | *rules*)) 132 | 133 | (defmacro backward-chain-rules (goal-obj) 134 | `(if (ob$get ,goal-obj 'plan-rule) 135 | (yloop (initial (result nil) 136 | (subgoalnum (ob$get ,goal-obj 'plan-subgoalnum))) 137 | (yfor chain-num in (ob$gets (ob$get ,goal-obj 'plan-rule) 138 | 'backward-chain-nums)) 139 | (ydo (if (eq? subgoalnum (cadr chain-num)) 140 | (setq result (cons (car chain-num) result)))) 141 | (yresult result)) 142 | *rules*)) 143 | 144 | (defmacro forward-chain-rules (goal-obj) 145 | `(if (ob$get ,goal-obj 'inference-rule) 146 | (ob$gets (ob$get ,goal-obj 'inference-rule) 'forward-chain) 147 | *rules*)) 148 | 149 | (defmacro define-gen (type args . body) 150 | `(let ((ty (ob$name->ob ',type))) 151 | (if (null? ty) 152 | (format t "define-gen: unknown type: ~A~%" ',type) 153 | (ob$set ty 154 | 'gen 155 | ,`(lambda (con stream switches context bp) ,@body))))) 156 | 157 | (defmacro define-no-gen (type) 158 | `(ob$set (ob$name->ob ',type) 159 | 'gen 160 | 'no-gen)) 161 | 162 | (defmacro strength (ob) 163 | `(let ((found (ob$get ,ob 'strength))) 164 | (if (flonum? found) 165 | found 166 | *default-strength*))) 167 | 168 | (defmacro set-strength (ob str) 169 | `(ob$set ,ob 'strength ,str)) 170 | 171 | ; Doesn't affect linkages, so how does this offset really work 172 | ; in the long run!? 173 | (defmacro offset-strength (ob offset) 174 | `(set-strength ,ob (fl+ ,offset (strength ,ob)))) 175 | 176 | (defmacro delay-dbgs (context . body) 177 | `(let ((string1 nil) (xxcontext ,context) (temp nil)) 178 | (if *linearized?* 179 | (ndbg-roman-nl *gate-dbg* rule 180 | "Debugging being delayed for broadcast at a later time.")) 181 | (setq string1 182 | (with-output-to-string (stream1) 183 | (let ((old-gate-dbg *gate-dbg*) 184 | (old-gen-stream *gen-stream*)) 185 | (unwind-protect 186 | (progn 187 | (setq *gate-dbg* stream1) 188 | (setq *gen-stream* (make-gen-stream *gate-dbg*)) 189 | (setq temp (progn ,@body))) 190 | (setq *gate-dbg* old-gate-dbg) 191 | (setq *gen-stream* old-gen-stream))))) 192 | (ob$set xxcontext 'sprout-trace (list string1)) 193 | (if *linearized?* (ndbg-roman-nl *gate-dbg* rule "Debugging resumed.")) 194 | (if (not *linearized?*) (cx$print-sprout-trace xxcontext)) 195 | temp)) 196 | 197 | (defmacro no-gen (&rest body) 198 | `(let ((old *global-switches*) 199 | (temp nil)) 200 | (setq *global-switches* (cons '(no-gen t) *global-switches*)) 201 | (setq temp (progn ,@body)) 202 | (setq *global-switches* old) 203 | temp)) 204 | 205 | (defmacro gen-future-assumption (&rest body) 206 | `(let ((old *global-switches*) 207 | (temp nil)) 208 | (setq *global-switches* 209 | (cons '(tense past-subjunctive) 210 | (cons '(what-if t) *global-switches*))) 211 | (setq temp (progn ,@body)) 212 | (setq *global-switches* old) 213 | temp)) 214 | 215 | (defmacro gen-past-assumption (&rest body) 216 | `(let ((old *global-switches*) 217 | (temp nil)) 218 | (setq *global-switches* 219 | (cons '(tense past-perfect) 220 | (cons '(what-if t) *global-switches*))) 221 | (setq temp (progn ,@body)) 222 | (setq *global-switches* old) 223 | temp)) 224 | 225 | (defmacro gen-relaxation (context . body) 226 | `(let ((old *global-switches*) 227 | (temp nil)) 228 | (setq *global-switches* 229 | (cons (if (altern? ,context) 230 | '(tense past-subjunctive) 231 | '(tense present)) 232 | (cons '(relaxation t) *global-switches*))) 233 | (setq temp (progn ,@body)) 234 | (setq *global-switches* old) 235 | temp)) 236 | 237 | (defmacro me-belief-path? (x) 238 | `(null? (cdr ,x))) 239 | 240 | (defmacro not-me-belief-path? (x) 241 | `(cdr ,x)) 242 | 243 | (defmacro define-phrase (pattern . concepts) 244 | `(progn (setq *phrases* 245 | (cons (cons ,pattern 246 | ',(map 'list (lambda (x) (ob$create x)) 247 | concepts)) 248 | *phrases*)) 249 | nil)) 250 | 251 | (defmacro candidate-create (rule bd episodes) 252 | `(cons ,rule (cons ,bd ,episodes))) 253 | 254 | (defmacro candidate-rule (candidate) 255 | `(car ,candidate)) 256 | 257 | (defmacro candidate-bd (candidate) 258 | `(cadr ,candidate)) 259 | 260 | (defmacro candidate-episodes (candidate) 261 | `(cddr ,candidate)) 262 | 263 | (defmacro thresh (value threshold) 264 | `(if (fl< ,value ,threshold) 265 | 0.0 266 | ,value)) 267 | 268 | (defmacro bd-append (bd1 bd2) 269 | `(cons 't (append (cdr ,bd1) (cdr ,bd2)))) 270 | 271 | (defmacro bd-append-ai (bd1 bd2) 272 | `(yloop (initial (result (cons 't (copy-list (cdr ,bd1))))) 273 | (yfor elem in (cdr ,bd2)) 274 | (ydo (if (or (var? (cadr elem)) 275 | (analogy-instantiatible? (cadr elem))) 276 | (setq result (append! result (list elem))))) 277 | (yresult result))) 278 | 279 | ; End of file. 280 | -------------------------------------------------------------------------------- /dd_mutation.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Daydreamer 4 | ; Version 3.5 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; 1/12/86: Began adding code for action mutation 10 | ; 7/22/86: Redid mutations to use serendipity mechanism 11 | ; 9/25/86: Got rid of flavors 12 | ; 13 | ;******************************************************************************* 14 | 15 | (defun mutations (action context) 16 | (yloop (initial (result nil) 17 | (bd nil)) 18 | (yfor mut in *mutations*) 19 | (ydo (if (setq bd (ob$unify (car mut) action *empty-bd*)) 20 | (setq result (cons (ob$instantiate (cadr mut) bd) 21 | result)))) 22 | (yresult result))) 23 | 24 | ; 25 | ; Returns NIL or T. 26 | ; 27 | (defun action-mutations (top-level-goal backtrack-wall) 28 | ; For now, only attempt mutations once for a given top-level goal. 29 | (if (null? (ob$get top-level-goal 'run-mutations?)) 30 | (progn 31 | (ob$add top-level-goal 'run-mutations? t) 32 | (ndbg-roman-nl *gate-dbg* rule "Action mutations for ~A" top-level-goal) 33 | (yloop 34 | (initial (mutated-actions nil) (result nil)) 35 | (yfor leaf in (cx$leaf-descendants backtrack-wall)) 36 | (yuntil result) 37 | (ydo 38 | (ndbg-roman-nl *gate-dbg* rule "Trying leaf context ~A" leaf) 39 | (if (null? (ob$get leaf 'mutations-tried?)) 40 | (progn 41 | (ob$set leaf 'mutations-tried? t) 42 | (yloop 43 | (yfor ob in (cx$get-all-ty leaf *active-goal-ob*)) 44 | ; Note that planning loops do not result in failed goals. 45 | ; They just leave unplanned active goals. 46 | (ydo 47 | (if (ty$instance? (ob$get ob 'obj) 'action) 48 | (progn 49 | (ndbg-roman-nl *gate-dbg* rule "Mutating action goal ~A" ob) 50 | (setq mutated-actions (mutations (ob$get ob 'obj) 51 | leaf)) 52 | (yloop 53 | (yfor mutated-action in mutated-actions) 54 | (ydo (if (action-mutation top-level-goal leaf mutated-action 55 | ob) 56 | (setq result t))))))))))) 57 | (yresult result))) 58 | nil)) 59 | 60 | ; 61 | ; See if a given action mutation pans out (via serendipity mechanism). 62 | ; First try serendipity from the supergoal of the action goal. 63 | ; If that doesn't work, try serendipity from the top (well, actually 64 | ; the subgoal of the daydreaming goal). 65 | ; Todo: we might also want to invoke serendipity for other tasks as well! 66 | ; 67 | ; Returns T or NIL. 68 | ; 69 | (setq *action-mutations?* nil) 70 | 71 | (defun action-mutation (daydreaming-goal leaf mutated-action 72 | mutated-action-goal) 73 | (ndbg-roman-nl *gate-dbg* rule "Trying mutated action ~A" mutated-action) 74 | (unwind-protect 75 | (let ((bottom-goal (ob$fcreate `(SUCCEEDED-GOAL obj ,mutated-action)))) 76 | (setq *action-mutations?* t) 77 | (if (serendipity-recognize-apply daydreaming-goal 78 | (goal-supergoal mutated-action-goal leaf) 79 | (bottom-rules mutated-action) bottom-goal) 80 | t 81 | (let ((subgoal (dd-goal-subgoal daydreaming-goal))) 82 | (if nil ; was subgoal 83 | (if (serendipity-recognize-apply daydreaming-goal subgoal 84 | (bottom-rules mutated-action) 85 | bottom-goal) 86 | t 87 | nil) 88 | nil)))) 89 | (setq *action-mutations?* nil))) 90 | 91 | ; 92 | ; What follows is code that is not currently being used. 93 | ; 94 | 95 | ; 96 | ; Action mutation generation 97 | ; 98 | 99 | (defun type-mutations (action) 100 | (ndbg-roman-nl *gate-dbg* rule "Find type mutations for ~A" action) 101 | (let ((mutation1 (ob$copy action)) 102 | (mutation2 (ob$copy action))) ; need to copy w/o links 103 | (cond 104 | ((ty$instance? action 'ptrans) 105 | (ob$set mutation1 'type *mtrans-ob*) 106 | (ob$set mutation2 'type *atrans-ob*) 107 | (list action mutation1 mutation2)) 108 | ((ty$instance? action 'mtrans) 109 | (ob$set mutation1 'type *ptrans-ob*) 110 | (ob$set mutation2 'type *atrans-ob*) 111 | (list action mutation1 mutation2)) 112 | ((ty$instance? action 'atrans) 113 | (ob$set mutation1 'type *mtrans-ob*) 114 | (ob$set mutation2 'type *ptrans-ob*) 115 | (list action mutation1 mutation2)) 116 | (else nil)))) 117 | 118 | (defun normalize-action! (action context) 119 | (cond 120 | ((ty$instance? action 'ptrans) 121 | (normalize-ptrans! action context)) 122 | ((ty$instance? action 'mtrans) 123 | (normalize-mtrans! action context)) 124 | ((ty$instance? action 'atrans) 125 | (normalize-atrans! action context)) 126 | (else action))) 127 | 128 | (defun normalize-ptrans! (action context) 129 | (let ((from (ob$get action 'from)) 130 | (to (ob$get action 'to)) 131 | (obj (ob$get action 'obj))) 132 | (cond 133 | ((eq? from 'some-object) 134 | (ob$set action from *location-var*)) 135 | ((and from (not (ty$instance? from 'location)) 136 | (ty$instance? from 'person)) 137 | (ob$set action 'from (object->location from context)))) 138 | (cond 139 | ((eq? to 'some-object) 140 | (ob$set action to *location-var*)) 141 | ((and to (not (ty$instance? to 'location)) 142 | (ty$instance? to 'person)) 143 | (ob$set action 'to (object->location to context)))) 144 | (cond 145 | ((eq? obj 'some-object) 146 | (ob$set action to *phys-obj-var*)) 147 | ((and obj (not (ty$instance? obj 'phys-obj)) 148 | (ty$instance? obj 'mental-obj)) 149 | (ob$set action 'obj 150 | (ob$fcreate `(PHYS-OBJ obj ,obj))))) 151 | action)) 152 | 153 | (defun normalize-mtrans! (action context) 154 | (let ((from (ob$get action 'from)) 155 | (to (ob$get action 'to)) 156 | (obj (ob$get action 'obj))) 157 | (cond 158 | ((eq? from 'some-object) 159 | (ob$set action from *person-var*)) 160 | ((and from (not (ty$instance? from 'person)) 161 | (ty$instance? from 'location)) 162 | (ob$set action 'from (location->object from 163 | context)))) 164 | (cond 165 | ((eq? to 'some-object) 166 | (ob$set action to *person-var*)) 167 | ((and to (not (ty$instance? to 'person)) 168 | (ty$instance? to 'location)) 169 | (ob$set action 'to (location->object to context)))) 170 | (cond 171 | ((eq? obj 'some-object) 172 | (ob$set action to *mental-obj-var*)) 173 | ((and obj (not (ty$instance? obj 'mental-obj)) 174 | (ty$instance? obj 'phys-obj)) 175 | (ob$set action 'obj 176 | (ob$fcreate `(MENTAL-OBJ obj ,obj))))) 177 | action)) 178 | 179 | (defun normalize-atrans! (action context) 180 | (let ((from (ob$get action 'from)) 181 | (to (ob$get action 'to)) 182 | (obj (ob$get action 'obj))) 183 | (cond 184 | ((eq? from 'some-object) 185 | (ob$set action from *person-var*)) 186 | ((and from (not (ty$instance? from 'person)) 187 | (ty$instance? from 'location)) 188 | (ob$set action 'from (location->object from context)))) 189 | (cond 190 | ((eq? to 'some-object) 191 | (ob$set action to *person-var*)) 192 | ((and to (not (ty$instance? to 'person)) 193 | (ty$instance? to 'location)) 194 | (ob$set action 'to (location->object to context)))) 195 | (cond 196 | ((eq? obj 'some-object) 197 | (ob$set action to *phys-obj-var*)) 198 | ((and obj (not (ty$instance? obj 'phys-obj)) 199 | (ty$instance? obj 'mental-obj)) 200 | (ob$set action 'obj 201 | (ob$fcreate `(PHYS-OBJ obj ,obj))))) 202 | action)) 203 | 204 | ; generates list of substitution binding lists for each possible permutation 205 | ; of a list of objects 206 | (defun permutation-substs (objs) 207 | (yloop (initial (result nil) 208 | (perms (permute-list objs))) 209 | (yfor perm in perms) 210 | (ydo (yloop (initial (bd nil)) 211 | (yfor elem1 in objs) 212 | (yfor elem2 in perm) 213 | (ydo (setq bd (cons (list elem1 elem2) bd))) 214 | (yresult (setq result (cons (cons 't bd) result))))) 215 | (yresult result))) 216 | 217 | (defun permute-list (lst) 218 | (cond 219 | ((null? (cdr lst)) (list lst)) 220 | (else (yloop (initial (result1 nil) 221 | (result2 nil)) 222 | (yfor elem1 in lst) 223 | (ydo (setq result2 (permute-list (delq elem1 lst))) 224 | (yloop (yfor elem2 in result2) 225 | (ydo (setq result1 (cons (cons elem1 elem2) 226 | result1))))) 227 | (yresult result1))))) 228 | 229 | (defun permutation-mutations (action) 230 | (ndbg-roman-nl *gate-dbg* rule "Find permutation mutations for ~A" action) 231 | (yloop (initial (result nil)) 232 | (yfor subst in (cdr (permutation-substs (objects-in action)))) 233 | ; cdr is intended to remove the identity substitution--it 234 | ; may end up as last, though. 235 | (ydo (setq result (cons (ob$subst action subst nil nil nil) result))) 236 | (yresult result))) 237 | 238 | (defun substitution-mutations (action) 239 | (ndbg-roman-nl *gate-dbg* rule "Find substitution mutations for ~A" action) 240 | (if (ob$literal? action) 241 | (list action) 242 | (yloop (initial (result (list (ob$create-empty))) 243 | (ob1 nil) 244 | (ob2 nil) 245 | (temp nil)) 246 | (yfor sv in (ob$pairs action)) 247 | ; have to add other instan code to handle literal and type obs right? 248 | (ydo (if (ty$instance? (slots-value sv) 'object) 249 | (progn 250 | ; (setq ob1 (ob$copy (tlast result))) 251 | (setq ob2 (ob$copy (tlast result))) 252 | (yloop (yfor ob in result) 253 | (ydo (ob$add ob (slots-name sv) (slots-value sv)))) 254 | ; (ob$add ob1 (slots-name sv) *me*) 255 | (ob$add ob2 (slots-name sv) 'some-object) 256 | (setq result (cons ob2 result))) 257 | (progn 258 | (setq temp (substitution-mutations (slots-value sv))) 259 | (yloop (initial (new-result nil)) 260 | (yfor ob1 in temp) 261 | (ydo (yloop (yfor ob2 in result) 262 | (ydo (setq ob2 (ob$copy ob2)) 263 | (ob$add ob2 (slots-name sv) ob1) 264 | (setq new-result (append! new-result 265 | (list ob2)))))) 266 | (yresult (setq result new-result)))))) 267 | (yresult result)))) 268 | 269 | (setq *mutation-timeout* 4) 270 | 271 | (defun replan-mut (goal) 272 | (let ((sprout (cx$sprout (ob$get goal 'top-context)))) 273 | (ob$set sprout 'mutations-tried? t) 274 | (list sprout))) 275 | 276 | (defun redo-plans-with-mutations? (top-level-goal leaf) 277 | (ndbg-roman-nl *gate-dbg* rule "Redo plans with mutations") 278 | (yloop (initial (sprouted-contexts nil)) 279 | (yfor ob in (cx$get-all-ty leaf *active-goal-ob*)) 280 | (ydo (if (eq? (ob$get ob 'top-level-goal) top-level-goal) 281 | (setq sprouted-contexts (append 282 | (run-mutation-plans ob top-level-goal 283 | (ob$get ob 'top-context)) sprouted-contexts)))) 284 | (yresult sprouted-contexts))) 285 | 286 | (defun mutation-result? (fact context) 287 | (ol-path fact nil *dependency-ob* 'backward 288 | context (lambda (dummy ob) (mutation-action? ob context)) nil)) 289 | 290 | (defun mutation-action? (ob context) 291 | (ob$get ob 'mutant)) 292 | 293 | (defun run-mutation-plans (goal top-level-goal context) 294 | (ndbg-roman-nl *gate-dbg* rule "Trying mutation plans for ~A in ~A" 295 | goal context) 296 | (let ((goal-obj (ob$get goal 'obj)) (bds nil) 297 | (sprouted-context nil) (sprouted-contexts nil)) 298 | (yloop 299 | (initial (bds nil)) 300 | (yfor mutated-plan-context in (ob$get top-level-goal 301 | 'mutation-plan-contexts)) 302 | (ydo (setq bds (cx$retrieve mutated-plan-context goal-obj)) 303 | ; was retrieve-all; why, I don't know--retrieve always retrieves all 304 | (yloop 305 | (yfor bd in bds) 306 | (ydo (if (mutation-result? (car bd) mutated-plan-context) 307 | (progn 308 | (ndbg-roman *gate-dbg* rule "Mutation plan") 309 | (ndbg-roman *gate-dbg* rule " for ~A in ~A" 310 | goal context) 311 | (ndbg-newline *gate-dbg* rule) 312 | (setq sprouted-context (cx$sprout context)) 313 | (delay-dbgs sprouted-context 314 | (ob$set sprouted-context 'mutations-tried? t) 315 | ; the above is to prevent mutations being tried on 316 | ; any leaves which already involve mutations. 317 | (ob$removes sprouted-context 'timeout) 318 | (setq sprouted-contexts (cons sprouted-context 319 | sprouted-contexts)) 320 | ; The below splices in a plan resulting from an 321 | ; inference chain from another context! 322 | (inference-chain->plan-trc mutated-plan-context 323 | sprouted-context (car bd) 324 | goal bd top-level-goal 325 | *active-goal-ob*))))))) 326 | (yresult sprouted-contexts)))) 327 | 328 | (defun inference-chain->plan-trc (inf-context plan-context fact goal 329 | bd top-level-goal goal-type) 330 | ; Plan instantiate now returns nil if goal equals top-level-goal 331 | ; so this will have to be rewritten. 332 | (let ((root-goal (plan-instantiate goal bd plan-context top-level-goal 333 | *me-belief-path* nil)) 334 | (dependencies (ol-get fact *dependency-ob* 'backward inf-context)) 335 | (intends nil)) 336 | (yloop (yfor dependency in dependencies) 337 | (ydo (setq intends 338 | (ob$fcreate `(INTENDS linked-from ,root-goal 339 | linked-to 340 | ,(inference-chain->plan-trc1 341 | inf-context plan-context 342 | (ob$get dependency 'linked-to) 343 | top-level-goal goal-type) 344 | rule ,(ob$get dependency 'rule) 345 | seq? t))) 346 | (cx$assert plan-context intends))) 347 | root-goal)) 348 | 349 | (defun inference-chain->plan-trc1 (inf-context plan-context fact 350 | top-level-goal goal-type) 351 | (let ((goal (ob$fcreate `(NOTYPE obj ,fact))) 352 | (dependencies (ol-get fact *dependency-ob* 'backward inf-context)) 353 | (intends nil)) 354 | (ob$add goal 'type goal-type) 355 | (yloop (yfor dependency in dependencies) 356 | (ydo (setq intends 357 | (ob$fcreate `(INTENDS linked-from ,goal 358 | linked-to 359 | ,(inference-chain->plan-trc1 360 | inf-context plan-context 361 | (ob$get dependency 'linked-to) 362 | top-level-goal goal-type) 363 | rule ,(ob$get dependency 'rule) 364 | seq? t))) 365 | (cx$assert plan-context intends))) 366 | (cx$assert plan-context goal) 367 | goal)) 368 | 369 | ; End of file. 370 | -------------------------------------------------------------------------------- /dd_night.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Daydreamer 4 | ; Version 3.5 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains: 10 | ; DAYDREAMER*: A computer model of night dreaming and overdetermined daydreaming 11 | ; 12 | ; 9/9/88: First version written 13 | ; 12/17/88: Debugged, modified, and wrote English generation routines. 14 | ; 15 | ;******************************************************************************* 16 | 17 | ;******************************************************************************* 18 | ; Some utilities 19 | ;******************************************************************************* 20 | 21 | ; Turn off ob warnings 22 | (disinterest 'ob-warn 'all) 23 | 24 | (setq *reality* (cx$create)) 25 | 26 | (defun pod (ob) 27 | (if (ob? ob) 28 | (progn 29 | (ob$pr ob *gate-dbg* *ob-print-options*) 30 | (newline *gate-dbg*)) 31 | (format *gate-dbg* "~A~%" ob)) 32 | *repl-wont-print*) 33 | 34 | ;******************************************************************************* 35 | ; Top-level functions for DAYDREAMER* 36 | ;******************************************************************************* 37 | 38 | (defun daydreamer-star () 39 | (run-night-sample)) 40 | 41 | (defun run-night-sample () 42 | (run-night (list *test-reversal-goal* *test-revenge-goal*))) 43 | 44 | (defun run-night (dd-goals) 45 | (let 46 | ((qplans-es nil) 47 | (all-rules nil) 48 | (metaphors nil) 49 | (metaphor-goal nil) 50 | (metaphor-qplans)) 51 | (ndbg-roman-nl *gate-dbg* night 52 | "----------------------------------------------------------") 53 | (ndbg-roman-nl *gate-dbg* night "DAYDREAMER* version of 19990506") 54 | (ndbg-roman-nl *gate-dbg* night "Generating plans for daydreaming goals...") 55 | (setq qplans-es 56 | (map 'list (lambda (goal) (qplan-generate goal)) 57 | dd-goals)) 58 | (setq all-rules 59 | (map-app (lambda (qplans) (map-app (lambda (qplan) (car qplan)) qplans)) 60 | qplans-es)) 61 | (ndbg-roman-nl *gate-dbg* night "All rules = ~A" all-rules) 62 | (ndbg-roman-nl *gate-dbg* night "Selecting metaphor script...") 63 | (setq metaphors (select-metaphor all-rules)) 64 | (if (not (null? metaphors)) 65 | (progn 66 | (ndbg-roman-nl *gate-dbg* night 67 | "Selecting first metaphor from among: ~A" metaphors) 68 | (setq metaphor-goal 69 | (ob$fcreate 70 | `(ACTIVE-GOAL 71 | obj ,(ob$instantiate-o (ob$get (caar metaphors) 'goal) 72 | *empty-me-bd*)))) 73 | (ndbg-roman-nl *gate-dbg* night "Generating plans for metaphor...") 74 | (setq metaphor-qplans (qplan-generate metaphor-goal)) 75 | (setq *metaphor-qplans* metaphor-qplans)) 76 | (ndbg-roman-nl *gate-dbg* night "No metaphors found")) 77 | nil)) 78 | 79 | ; Old test routines 80 | (defun night-test () 81 | (setq *reversal-qplans* (qplan-generate *test-reversal-goal*)) 82 | (setq *revenge-qplans* (qplan-generate *test-revenge-goal*)) 83 | (setq *ranger-qplans* (qplan-generate *test-ranger-goal*)) 84 | (night-pp) 85 | ) 86 | 87 | (defun night-pp () 88 | (ndbg-roman-nl *gate-dbg* night "") 89 | (pretty-print *reversal-qplans* *gate-dbg*) 90 | (ndbg-roman-nl *gate-dbg* night "") 91 | (pretty-print *revenge-qplans* *gate-dbg*) 92 | (ndbg-roman-nl *gate-dbg* night "") 93 | (pretty-print *ranger-qplans* *gate-dbg*) 94 | (ndbg-roman-nl *gate-dbg* night "") 95 | ) 96 | 97 | ;******************************************************************************* 98 | ; Quick planning 99 | ;******************************************************************************* 100 | 101 | ; 102 | ; Possible mods to qplan: 103 | ; 104 | ; Optional unification 105 | ; Optional instantiation 106 | ; 107 | 108 | ; 109 | ; Returns: 110 | ; (qplan1 qplan2 qplan3 ...) 111 | ; where a qplan = 112 | ; ((rule1 rule2 rule3 ...) -- list of all rules used in qplan 113 | ; qqplan) 114 | ; where a qqplan = 115 | ; (rule qqplan1 qqplan2 ... qqplann) 116 | ; where rule has n subgoals 117 | ; A qqplan can be NIL if there are no plans 118 | ; 119 | (defun qplan-generate (goal) 120 | (ndbg-roman-nl *gate-dbg* night "Running quickplanner on:") 121 | (pod goal) 122 | (gn goal) 123 | (yloop (initial (result nil) 124 | (plans nil)) 125 | (yfor top-rule in (top-rules (ob$get goal 'obj))) 126 | (ydo (if (setq plans (qplan-generate1 top-rule (list top-rule))) 127 | (setq result (append! result plans)))) 128 | (yresult 129 | (progn 130 | (ndbg-roman-nl *gate-dbg* night "Generated plans =") 131 | (qplans-print result) 132 | (qplans-gen result (ob$get goal 'obj) nil) 133 | (qplans-gen result (ob$get goal 'obj) t) 134 | result)))) 135 | 136 | ; 137 | ; Returns: 138 | ; NIL (if rule is NIL) -or- 139 | ; (qplan1 qplan2 qplan3 ...) 140 | ; 141 | (defun qplan-generate1 (rule rules-in-path) 142 | ; (ndbg-roman-nl *gate-dbg* night "qplan-generate1 for ~A" rule) 143 | (cond 144 | ((nil? rule) nil) 145 | (else 146 | (yloop 147 | (initial (result nil) (qplans-es nil)) 148 | (yfor rules in (subrules rule rules-in-path)) 149 | (ydo 150 | ; rules = (subrule1 subrule2 ... subrulen) 151 | ; Generate qplans for each subrule 152 | ; (ndbg-roman-nl *gate-dbg* night "rules = ") 153 | ; (pretty-print rules *gate-dbg*) 154 | ; (ndbg-roman-nl *gate-dbg* night "") 155 | (setq qplans-es 156 | (map 'list (lambda (r) (qplan-generate1 r (cons r rules-in-path))) 157 | rules)) 158 | ; (ndbg-roman-nl *gate-dbg* night "qplans-es =") 159 | ; (pretty-print qplans-es *gate-dbg*) 160 | ; (ndbg-roman-nl *gate-dbg* night "") 161 | ; qplans-es = ((qplan1.1 qplan1.2) (qplan2.1)) 162 | ; -or- qplans-es = (nil (qplan2.1)) 163 | ; Take the cross product 164 | (if (and (null? (cdr qplans-es)) 165 | (null? (car qplans-es))) 166 | nil 167 | (setq qplans-es (cross-product (embed-nils qplans-es)))) 168 | ; qplans-es = ((qplan1.1 qplan2.1) (qplan1.2 qplan2.1)) 169 | ; -or- qplans-es = ((nil qplan2.1)) 170 | ; (ndbg-roman-nl *gate-dbg* night "(crossed) qplans-es =") 171 | ; (pretty-print qplans-es *gate-dbg*) 172 | ; (ndbg-roman-nl *gate-dbg* night "") 173 | ; qplans-es = ((qplan1.1 qplan2.1) (qplan1.1 qplan2.1)) 174 | (yloop 175 | (initial (rules-used nil) (qqplan nil)) 176 | (yfor qplans in qplans-es) 177 | (ydo 178 | ; qplans = (qplan1.1 qplan2.1) 179 | ; Convert the qplans for subrules into a single qplan for rule 180 | ; (ndbg-roman-nl *gate-dbg* night "qplans =") 181 | ; (pretty-print qplans *gate-dbg*) 182 | ; (ndbg-roman-nl *gate-dbg* night "") 183 | (setq rules-used 184 | (cons rule (map-app (lambda (qplan) 185 | (if (nil? qplan) 186 | nil 187 | (qplan-get-rules-used qplan))) 188 | qplans))) 189 | (setq qqplan (cons rule (map 'list (lambda (qplan) 190 | (if (nil? qplan) 191 | nil 192 | (qplan-get-qqplan qplan))) 193 | qplans))) 194 | ; (ndbg-roman-nl *gate-dbg* night "rules-used = ~A" rules-used) 195 | ; (ndbg-roman-nl *gate-dbg* night "qqplan =") 196 | ; (pretty-print qqplan *gate-dbg*) 197 | ; (ndbg-roman-nl *gate-dbg* night "") 198 | (setq result (cons (list rules-used qqplan) result)) 199 | ; (ndbg-roman-nl *gate-dbg* night "result =") 200 | ; (pretty-print result *gate-dbg*) 201 | ; (ndbg-roman-nl *gate-dbg* night "") 202 | ))) 203 | (yresult result))))) 204 | 205 | (defun embed-nils (lst) 206 | (yloop 207 | (initial (result nil)) 208 | (yfor elem in lst) 209 | (ydo 210 | (if (not (nil? elem)) 211 | (setq result (append result (list elem))) 212 | (setq result (append result '((nil)))))) 213 | (yresult result))) 214 | 215 | (defun qplan-get-rules-used (qplan) 216 | (if qplan 217 | (car qplan) 218 | nil)) 219 | 220 | (defun qplan-get-qqplan (qplan) 221 | (if qplan 222 | (cadr qplan) 223 | nil)) 224 | 225 | ; 226 | ; Returns: 227 | ; ((subrule1 subrule2 ... subrulen) 228 | ; (subrule1 subrule2 ... subrulen) 229 | ; ...) 230 | ; if rule has n subgoals 231 | ; 232 | (defun subrules (rule omit-rules) 233 | ; (ndbg-roman-nl *gate-dbg* night "Getting subrules for ~A" rule) 234 | (yloop 235 | (initial 236 | (subrule nil) (subgoalnum nil) 237 | (result (list-of-n nil (ob$get rule 'number-of-subgoals)))) 238 | (yfor chain-num in (ob$gets rule 'backward-chain-nums)) 239 | (ydo 240 | (setq subrule (car chain-num)) 241 | (setq subgoalnum (cadr chain-num)) 242 | (if (and (plan? subrule) 243 | (not (memq? subrule omit-rules))) 244 | (setf (nth-elem result subgoalnum) 245 | (cons subrule (nth-elem result subgoalnum))))) 246 | (yresult 247 | ; For each subgoal having no rules, insert a single nil 248 | (yloop 249 | (initial (i 0)) 250 | (ywhile (< i (ob$get rule 'number-of-subgoals))) 251 | (ydo (if (nil? (nth-elem result i)) 252 | (setf (nth-elem result i) '(nil)) 253 | nil) 254 | (setq i (+ 1 i)))) 255 | ; Return the cross product 256 | (setq result (cross-product result)) 257 | ; (ndbg-roman-nl *gate-dbg* night "Returning ~A" result) 258 | result))) 259 | 260 | (defun list-of-n (elem n) 261 | (yloop 262 | (initial (result nil) (i 0)) 263 | (ywhile (< i n)) 264 | (ydo (setq result (cons elem result)) 265 | (setq i (+ 1 i))) 266 | (yresult result))) 267 | 268 | ; 269 | ; (cross-product '((a b) (c d))) => ((a c) (a d) (b c) (b d)) 270 | ; (cross-product '((a b) ()) => () 271 | ; (cross-product '((a b) (nil)) => ((a nil) (b nil)) 272 | ; (cross-product '((nil) (nil)) => ((nil nil)) 273 | ; Preserves order of elements, but not order of lists 274 | ; 275 | (defun cross-product (lst) 276 | (cond 277 | ((nil? lst) nil) 278 | ((nil? (cdr lst)) 279 | (map 'list (lambda (elem) (list elem)) 280 | (car lst))) 281 | (else 282 | (yloop 283 | (initial (result nil)) 284 | (yfor rest-cross in (cross-product (cdr lst))) 285 | (ydo 286 | (yloop 287 | (yfor elem in (car lst)) 288 | (ydo (setq result (cons (cons elem rest-cross) result))))) 289 | (yresult result))))) 290 | 291 | ;******************************************************************************* 292 | ; Qplan printing 293 | ;******************************************************************************* 294 | 295 | (defun qplans-es-print (qplans-es) 296 | (yloop 297 | (yfor qplans in qplans-es) 298 | (ydo (qplans-print qplans)))) 299 | 300 | (defun qplans-print (qplans) 301 | (yloop 302 | (yfor qplan in qplans) 303 | (ydo (qplan-print qplan)))) 304 | 305 | (defun qplan-print (qplan) 306 | (let ((rules (car qplan)) 307 | (qqplan (cadr qplan))) 308 | (qqplan-print qqplan 0))) 309 | 310 | (defun qqplan-print (qqplan indent) 311 | (cond 312 | ((nil? qqplan) 313 | (print-spaces *gate-dbg* indent) 314 | (ndbg-roman-nl *gate-dbg* night "~A" 'LEAF)) 315 | (else 316 | (print-spaces *gate-dbg* indent) 317 | (ndbg-roman-nl *gate-dbg* night "~A" (car qqplan)) 318 | (yloop 319 | (yfor subqqplan in (cdr qqplan)) 320 | (ydo (qqplan-print subqqplan (+ 1 indent))))))) 321 | 322 | ;******************************************************************************* 323 | ; Qplan generation: 324 | ; Generate the plan in English. 325 | ; Also, instantiate it. 326 | ; Todo: Later on, we would use the full-blown DAYDREAMER planner to instantiate 327 | ; a plan. 328 | ;******************************************************************************* 329 | 330 | (defun qplans-es-gen (qplans-es topgoal english) 331 | (yloop 332 | (yfor qplans in qplans-es) 333 | (ydo (qplans-gen qplans topgoal english)))) 334 | 335 | (defun qplans-gen (qplans topgoal english) 336 | (yloop 337 | (yfor qplan in qplans) 338 | (ydo (qplan-gen qplan topgoal english)))) 339 | 340 | (defun qplan-gen (qplan topgoal english) 341 | (let ((rules (car qplan)) 342 | (qqplan (cadr qplan))) 343 | (ndbg-roman-nl *gate-dbg* night "----") 344 | (qqplan-gen qqplan 0 topgoal english) 345 | (ndbg-roman-nl *gate-dbg* night "----"))) 346 | 347 | (defun qqplan-gen (qqplan indent goal english) 348 | (cond 349 | ((nil? qqplan) 350 | ;(print-spaces *gate-dbg* indent) 351 | ;(ndbg-roman-nl *gate-dbg* night "~A" 'LEAF) 352 | ) 353 | (else 354 | (let ((subgoals (rule-embedded-subgoals (car qqplan))) 355 | (bd nil)) 356 | (if goal 357 | (setq bd (ob$unify (ob$get (car qqplan) 'goal) goal *empty-bd*)) 358 | (setq bd *empty-bd*)) 359 | (if (nil? bd) 360 | nil 361 | ;(ndbg-roman-nl *gate-dbg* night "(Does not unify.)") 362 | (progn 363 | (setq qqplan (cdr qqplan)) 364 | (yloop 365 | (initial (subgoal nil) (subqqplan nil)) 366 | (ywhile (or (not (null? subgoals)) 367 | (not (null? qqplan)))) 368 | (ydo (setq subgoal nil) 369 | (if (not (null? subgoals)) 370 | (progn (setq subgoal (car subgoals)) 371 | (setq subgoal (ob$instantiate-o subgoal bd)) 372 | (qplan-gen-subgoal subgoal indent english) 373 | (setq subgoals (cdr subgoals)))) 374 | (if (not (null? qqplan)) 375 | (progn 376 | (setq subqqplan (car qqplan)) 377 | (qqplan-gen subqqplan (+ 1 indent) subgoal english) 378 | (setq qqplan (cdr qqplan)))))))))))) 379 | 380 | (defun qplan-gen-subgoal (subgoal indent english) 381 | (print-spaces *gate-dbg* indent) 382 | (if english 383 | (gn subgoal) 384 | (pod subgoal))) 385 | 386 | ;******************************************************************************* 387 | ; Metaphor selection 388 | ;******************************************************************************* 389 | 390 | ; 391 | ; Returns ((rule1 occurrences1) (rule2 occurrences2) ...) 392 | ; where (eq? (ob$get rulei 'script) t) 393 | ; Order of list is rules with greater occurrences to less 394 | ; occurrences. 395 | ; If occurrences = (length rules) then we have found a 396 | ; bona fide intersection. 397 | ; 398 | (defun select-metaphor (rules) 399 | (uniquify-count-occurrences-and-sort 400 | (map-app (lambda (rule) (find-scripts-above rule)) rules))) 401 | 402 | ; (A A B B B C) => 403 | ; ((B 3) (A 2) (C 1)) 404 | (defun uniquify-count-occurrences-and-sort (lst) 405 | (yloop 406 | (initial (result nil) 407 | (entry nil)) 408 | (yfor elem in lst) 409 | (ydo (if (setq entry (mem (lambda (x y) (eq? x (car y))) elem result)) 410 | (progn 411 | (setq entry (car entry)) 412 | (setf (cadr entry) (+ 1 (cadr entry)))) 413 | (setq result (cons (list elem 1) result)))) 414 | (yresult (sort result (lambda (a b) (> (cadr a) (cadr b))))))) 415 | 416 | (defun find-scripts-above (rule) 417 | (find-scripts-above1 rule (list rule))) 418 | 419 | (defun find-scripts-above1 (rule rules-in-path) 420 | (yloop 421 | (initial (result nil)) 422 | (yfor superrule in (ob$gets rule 'forward-chain)) 423 | (ydo 424 | (if (and (plan? superrule) 425 | (not (memq? superrule rules-in-path))) 426 | (if (ob$get superrule 'script) 427 | (setq result (cons superrule result)) 428 | (setq result 429 | (append result 430 | (find-scripts-above1 superrule 431 | (cons superrule 432 | rules-in-path))))))) 433 | (yresult result))) 434 | 435 | ; End of file. 436 | -------------------------------------------------------------------------------- /dd_reversal.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Daydreamer 4 | ; Version 3.5 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; 1/26/86: Reversal algorithm 10 | ; 9/24/86: Removed sends 11 | ; 9/28/86: Rewrote for new undo-causes 12 | ; 13 | ;******************************************************************************* 14 | 15 | ; 16 | ; Failure Reversal 17 | ; 18 | 19 | (defun reversal (goal rev context top-level-goal rule bd) 20 | (let ((failed-goals (ob$gets rev 'obj))) 21 | (ndbg-roman-nl *gate-dbg* rule 22 | "Reversal for ~A in ~A, top-level-goal = ~A" 23 | failed-goals context top-level-goal) 24 | (if (inferred-top-level-goal? (car failed-goals)) 25 | (reverse-undo-causes failed-goals context top-level-goal rule bd goal) 26 | nil))) 27 | 28 | (defun reverse-alterns (failed-goal context top-level-goal rule bd goal) 29 | (let ((sprouted-contexts nil) 30 | (intends nil) 31 | (old-top-level-goal (ob$get failed-goal 'top-level-goal)) 32 | (planning-path nil) 33 | (activation-context nil) 34 | (termination-context nil)) 35 | (ndbg-roman-nl *gate-dbg* rule "Reverse alterns for ~A in ~A top = ~A" 36 | failed-goal context top-level-goal) 37 | (setq activation-context (ob$get old-top-level-goal 'activation-context)) 38 | (setq termination-context (ob$get old-top-level-goal 39 | 'termination-context)) 40 | (setq planning-path 41 | (memq activation-context (reverse (cons termination-context 42 | (cx$ancestors 43 | termination-context))))) 44 | (yloop 45 | (initial (rest planning-path) 46 | (sprouted-context nil)) 47 | (yuntil (null? (cdr rest))) 48 | (ydo 49 | (yloop 50 | (yfor child in (prune-possibilities (cx$children (car rest)))) 51 | (ydo (if (neq? child (cadr rest)) 52 | (progn 53 | (delay-dbgs 'to-be-set 54 | (rule-fire-msg rule "coded plan" context bd nil goal) 55 | (ndbg-roman-nl *gate-dbg* rule "Reverse alterns") 56 | (setq sprouted-context 57 | (reversal-sprout-alternative child old-top-level-goal 58 | context top-level-goal 1.0 t)) 59 | (setq xxcontext sprouted-context) 60 | (setq sprouted-contexts 61 | (cons sprouted-context sprouted-contexts))))))) 62 | (setq rest (cdr rest)))) 63 | sprouted-contexts)) 64 | 65 | (defun reversal-sprout-alternative (old-context old-top-level-goal 66 | new-context new-top-level-goal 67 | ordering do-intends?) 68 | ; Sprout an alternative past context 69 | (ndbg-roman-nl *gate-dbg* rule "Reversal sprout alternative") 70 | (let ((result (sprout-alternative-past old-context old-top-level-goal 71 | new-context new-top-level-goal)) 72 | (sprouted-context nil)) 73 | (setq sprouted-context (car result)) 74 | (setq old-top-level-goal (cadr result)) 75 | (set-ordering sprouted-context ordering) 76 | ; Bring in all emotions? 77 | ; I don't think this is needed. Emotions are always in *reality*. 78 | ; (add-emotions sprouted-context new-context) 79 | ; Bring in the top-level goal (Would be done by above, if above 80 | ; were done). 81 | (no-gen (cx$assert sprouted-context new-top-level-goal)) 82 | ; 83 | ; Make old top-level-goal actually be a subgoal of the 84 | ; current REVERSAL top-level-goal. 85 | ; Left over task slots associated with old top-level goal 86 | ; shouldn't make any difference (except maybe for clarity 87 | ; in debugging). We can clear them here if we want. 88 | (if do-intends? 89 | (cx$assert sprouted-context 90 | (ob$fcreate `(INTENDS linked-from ,new-top-level-goal 91 | linked-to ,old-top-level-goal 92 | rule Reversal-Plan)))) 93 | sprouted-context)) 94 | 95 | (setq *reverse-leaf-thresh* 0.5) 96 | 97 | ; Ordering of sprouted-contexts is in inverse proportion to 98 | ; the realities of the leafs from which those contexts were 99 | ; derived. Lower reality assumptions are better candidates 100 | ; for replanning. 101 | (defun reverse-leafs (old-top-level-goal context top-level-goal rule bd goal) 102 | (let ((sprouted-contexts nil) 103 | (sprouted-context nil) 104 | (intends nil) 105 | (old-context nil) 106 | (leafs (get-leafs old-top-level-goal *intends-ob* 'forward 107 | (ob$get old-top-level-goal 108 | 'termination-context)))) 109 | (ndbg-roman-nl *gate-dbg* rule "Reverse leafs for ~A in ~A top = ~A" 110 | old-top-level-goal context top-level-goal) 111 | (yloop 112 | (yfor leaf in leafs) 113 | (ydo (if (fl< (strength (ob$get leaf 'obj)) *reverse-leaf-thresh*) 114 | (progn 115 | (setq old-context (ob$get leaf 'activation-context)) 116 | ; Sprout an alternative past context 117 | (delay-dbgs 'to-be-set 118 | (rule-fire-msg rule "coded plan" context bd nil goal) 119 | (ndbg-roman-nl *gate-dbg* rule "Reverse leafs") 120 | (setq sprouted-context 121 | (reversal-sprout-alternative old-context 122 | old-top-level-goal 123 | context 124 | top-level-goal 125 | (fl/ 1.0 (strength 126 | (ob$get leaf 'obj))) 127 | t)) 128 | (setq xxcontext sprouted-context)) 129 | (setq sprouted-contexts (cons sprouted-context 130 | sprouted-contexts)) 131 | ; Retract the leaf objective (so we have to plan for 132 | ; it instead of shakily assuming its truth) 133 | (cx$retract sprouted-context (ob$get leaf 'obj)))))) 134 | sprouted-contexts)) 135 | 136 | ; 137 | ; REVERSE-UNDO-CAUSES: 138 | ; 139 | 140 | (setq *next-prule-number* 1) 141 | 142 | (setq *new-personal-goals* nil) 143 | 144 | ; Treating multiple failed-goals required a cross product of the 145 | ; negated leaf causes with which I am not prepared to deal. 146 | (defun reverse-undo-causes (failed-goals context top-level-goal rule bd goal) 147 | (let ((sprouted-contexts nil) (sprouted-context nil) 148 | (intends nil) 149 | (leaf-causes (get-leaf-causes (car failed-goals) 150 | (ob$get (car failed-goals) 151 | 'termination-context))) 152 | (failed-goal-obj (ob$get (car failed-goals) 'obj)) 153 | (old-top-level-goal (ob$get (car failed-goals) 'top-level-goal)) 154 | (backwards-planning-path nil) (old-context nil) (rand nil) 155 | (new-rule nil) 156 | (uor-obj nil) (predictor nil) (p-goal-uid nil) (input-states nil) 157 | (cfg-term-ctxt (ob$get (car failed-goals) 'termination-context)) 158 | (path nil) (prev-context nil)) 159 | (ndbg-roman-nl *gate-dbg* rule "Reverse undo causes for ~A in ~A top = ~A" 160 | (car failed-goals) context top-level-goal) 161 | (setq old-context (ob$get old-top-level-goal 'activation-context)) 162 | (setq backwards-planning-path 163 | (reverse (memq old-context 164 | (reverse (cons cfg-term-ctxt 165 | (cx$ancestors cfg-term-ctxt)))))) 166 | (if (null? backwards-planning-path) 167 | (error "Null backwards planning path.")) 168 | (ndbg-roman-nl *gate-dbg* rule "Bckwds plng path = ~A" 169 | backwards-planning-path) 170 | (yloop 171 | (yfor leaf-cause in leaf-causes) 172 | (ydo 173 | (ndbg-roman-nl *gate-dbg* rule "Considering leaf cause ~A" leaf-cause) 174 | (if (ty$instance? leaf-cause 'not) 175 | (progn 176 | (if (ty$instance? (ob$get leaf-cause 'obj) 'long-term-state) 177 | (progn 178 | (setq *new-personal-goals* 179 | (cons (ob$get leaf-cause 'obj) *new-personal-goals*)) 180 | (activate-top-level-goal 181 | (ob$fcreate `(ACTIVE-GOAL obj ,(ob$get leaf-cause 'obj))) 182 | *reality-lookahead* *empty-bd* 183 | (ob$fcreate `(RULE emotion (POS-EMOTION strength ,(strength goal) ))))) 184 | (progn 185 | ; set up rand object 186 | (setq rand (ob$fcreate '(RAND))) 187 | (yloop 188 | (yfor leaf-cause1 in leaf-causes) 189 | (ydo 190 | (if (neq? leaf-cause1 leaf-cause) 191 | (progn 192 | (setq uor-obj (ob$fcreate '(ROR))) ; was UOR, but gets killed by vblz 193 | (ob$add uor-obj 'obj leaf-cause1) 194 | (ob$add uor-obj 'obj (ob$fcreate `(ACTIVE-GOAL obj ,leaf-cause1))) 195 | (setq predictor (predicting-state leaf-cause1)) 196 | (if predictor 197 | (progn 198 | (ob$add uor-obj 'obj predictor) 199 | (ob$add uor-obj 'obj (ob$fcreate `(ACTIVE-GOAL obj ,predictor))))) 200 | (ob$add rand 'obj uor-obj))))) 201 | ; set up rules 202 | (setq p-goal-uid 203 | (string->symbol (string-append "PRESERVATION" 204 | (fixnum->string 205 | *next-prule-number*)))) 206 | (setq new-rule 207 | (ob$fcreate `(RULE subgoal ,rand 208 | goal (ACTIVE-GOAL 209 | obj (PRESERVATION obj ,failed-goal-obj 210 | uid ',p-goal-uid)) 211 | is 'inference-only 212 | plausibility 0.9))) 213 | (setq new-rule 214 | (ob$variabilize new-rule #'varize-object? nil *link-slots* nil)) 215 | (ob$add-unique-name new-rule 216 | (string->symbol 217 | (string-append "PRESERVATION-INF." 218 | (fixnum->string 219 | *next-prule-number*)))) 220 | (add-rule-print new-rule) 221 | (setq new-rule 222 | (ob$fcreate `(RULE subgoal ,(ob$get leaf-cause 'obj) 223 | goal (PRESERVATION obj ,failed-goal-obj 224 | uid ',p-goal-uid) 225 | is 'plan-only 226 | plausibility 0.9))) 227 | (setq new-rule 228 | (ob$variabilize new-rule #'varize-object? nil *link-slots* nil)) 229 | (ob$add-unique-name new-rule 230 | (string->symbol 231 | (string-append "PRESERVATION-PLAN." 232 | (fixnum->string 233 | *next-prule-number*)))) 234 | (add-rule-print new-rule) 235 | (increment-me *next-prule-number*) 236 | ; replan 237 | (setq input-states nil) 238 | (setq path backwards-planning-path) 239 | (setq old-context nil) 240 | (yloop (ydo (setq prev-context old-context) 241 | (setq old-context (car path)) 242 | (setq input-states (union input-states 243 | (cx$input-states old-context))) 244 | (setq path (cdr path))) 245 | (ywhile path)) 246 | ; (yuntil 247 | ; (prog1 248 | ; (progn 249 | ; (cx$assert-many old-context input-states) 250 | ; (not (show rand old-context *empty-bd* *me-belief-path*))) 251 | ; (cx$retract-many old-context input-states))) 252 | ; (if (null? prev-context) 253 | ; (progn 254 | ; (error "null prev context") 255 | ; (setq prev-context (ob$get (car failed-goals) 256 | ; 'termination-context)))) 257 | ; This line added for new alg. 258 | (setq old-context (ob$get old-top-level-goal 'activation-context)) 259 | ; Sprout an alternative past context 260 | (delay-dbgs 'to-be-set 261 | (rule-fire-msg rule "coded plan" context bd nil goal) 262 | (ndbg-roman-nl *gate-dbg* rule "Reverse undo cause") 263 | (setq sprouted-context 264 | (reversal-sprout-alternative old-context old-top-level-goal 265 | context top-level-goal 266 | 1.0 t)) 267 | (setq xxcontext sprouted-context) 268 | (no-gen (cx$assert-many sprouted-context input-states)) 269 | (setq sprouted-contexts (cons sprouted-context 270 | sprouted-contexts))))))))) 271 | sprouted-contexts)) 272 | 273 | (defun cx$input-states (cx) 274 | (yloop (initial (result nil)) 275 | (yfor ob in (cx$get-all cx)) 276 | (ydo (if (ob$get ob 'input-state?) 277 | (setq result (cons ob result)))) 278 | (yresult result))) 279 | 280 | (defun cx$assert-many (cx obs) 281 | (yloop (yfor ob in obs) 282 | (ydo (cx$assert cx ob)))) 283 | 284 | (defun cx$retract-many (cx obs) 285 | (yloop (yfor ob in obs) 286 | (ydo (cx$retract cx ob)))) 287 | 288 | (defun predicting-state (state) 289 | (let ((pred (ob$get (ob$ty state) 'predictor))) 290 | (if pred 291 | (ob$fcreate `((quote ,pred))) 292 | nil))) 293 | 294 | ; Merges emotions and whatever they are connected to into another 295 | ; context. 296 | (defun add-emotions (to-context from-context) 297 | (ndbg-roman-nl *gate-dbg* rule "Add emotions") 298 | (yloop (initial (deps nil)) 299 | (yfor ob in (cx$get-all from-context)) 300 | (ydo (if (ty$instance? ob 'emotion) 301 | (progn 302 | (cx$assert to-context ob) 303 | (setq deps (get-links ob *dependency-ob* from-context)) 304 | (yloop (yfor dep in deps) 305 | (ydo (cx$assert to-context dep) 306 | (cx$assert to-context (ob$get dep 'linked-to)))) 307 | (setq deps (get-links-from ob *dependency-ob* from-context)) 308 | (yloop (yfor dep in deps) 309 | (ydo (cx$assert to-context dep) 310 | (cx$assert to-context 311 | (ob$get dep 'linked-from))))))))) 312 | 313 | ; Returns a fresh alternative past context (an alternative of old-context) 314 | ; which includes only planning structure with which we are concerned 315 | ; (old-top-level-goal) modified to be part of a new top-level goal 316 | ; (new-top-level-goal), state facts true at that time in the past, and 317 | ; having the specified context (new-context) as an effective parent. 318 | ; My, isn't this description clear! 319 | ; ---> This can also be used to sprout an alternative future (as in 320 | ; earthquake), so the name is misleading. Todo: change it. 321 | (defun sprout-alternative-past (old-context old-top-level-goal 322 | new-context new-top-level-goal) 323 | ; Copy the old starting context from which we wish to explore an 324 | ; alternative past 325 | (ndbg-roman-nl *gate-dbg* rule "Sprout alternative") 326 | (no-gen (let ((sprouted-context (cx$copy old-context nil))) 327 | ; Make this alternative past be a (pseudo) sprout of the 328 | ; new context in which we wish to carry out this past 329 | ; exploration. 330 | (cx$pseudo-sprout-of sprouted-context new-context) 331 | ; Declare this context as an alternative past (for 332 | ; inverted emotional responses) if necessary. 333 | ; Fix generational tense on this context 334 | ; (There is no analogous 'what if' here?) 335 | (if (not (dd-goal? old-top-level-goal)) ; criterion for past/future 336 | (progn 337 | (set-altern sprouted-context) 338 | (ob$set sprouted-context 'gen-switches 339 | '((tense conditional-present-perfect))))) 340 | ; Get rid of all emotions. 341 | (gc-emotions sprouted-context) 342 | ; Get rid of any planning structure not on behalf of the 343 | ; old top-level goal which we will be replanning. 344 | (gc-plans sprouted-context (list old-top-level-goal)) 345 | ; The following is a kludge (as if other things weren't!). 346 | ; Top-level goal outcomes clobber the goal status globally; 347 | ; therefore we must recopy it here and set it back to 348 | ; being an ACTIVE-GOAL. 349 | (if (or (ty$instance? old-top-level-goal 'succeeded-goal) 350 | (ty$instance? old-top-level-goal 'failed-goal)) 351 | (progn 352 | ; (ndbg-roman-nl *gate-dbg* rule "The case of the resolved goal.") 353 | (setq old-top-level-goal 354 | (replace-linked-ob old-top-level-goal 355 | sprouted-context *me-belief-path* 356 | *empty-bd*)) 357 | (cx$retract sprouted-context old-top-level-goal) 358 | (ob$set old-top-level-goal 'type *active-goal-ob*) 359 | (cx$assert sprouted-context old-top-level-goal))) 360 | ; Change all remaining planning structure to be on behalf 361 | ; of new-top-level-goal. 362 | ; Without replace-linked-ob this would clobber the top-level goals 363 | ; on things which are shared with the original episode contexts. 364 | ; Todo: altern would be to have a cx$copy that copies obs and yet 365 | ; preserves links. 366 | (yloop (yfor ob in (cx$get-all sprouted-context)) 367 | (ydo (if (ty$instance? ob 'goal) 368 | (progn 369 | (setq ob (replace-linked-ob ob sprouted-context 370 | *me-belief-path* *empty-bd*)) 371 | (ob$set ob 'top-level-goal new-top-level-goal))))) 372 | ; Also, fix up activation contexts to be here. This isn't 373 | ; strictly necessary (?) because failure reversal (which uses 374 | ; that slot so far) will never get run on these trcs... 375 | (yloop (yfor ob in (cx$get-all-ty sprouted-context *active-goal-ob*)) 376 | (ydo (ob$set ob 'activation-context sprouted-context))) 377 | (list sprouted-context old-top-level-goal)))) 378 | 379 | ; 380 | ; Garbage collect away any planning structure not on behalf of any of 381 | ; the specified top-level-goals. 382 | ; (May want to use this other than from sprout-alternative-past in order 383 | ; to unclutter contexts.) 384 | ; 385 | ; Note: the INTENDS removal is a bit brute force but it probably works. 386 | ; 387 | ; Todo: Has to be extended also to get rid of relative planning 388 | ; structure--- (BELIEVE MS1 (ACTIVE-GOAL ...)) 389 | ; 390 | (defun gc-plans (context top-level-goals) 391 | (ndbg-roman-nl *gate-dbg* rule 392 | "Gc plans for ~A in ~A" top-level-goals context) 393 | (yloop (initial (deps nil)) 394 | (yfor ob in (cx$get-all context)) 395 | (ydo (if (and (ty$instance? ob 'goal) 396 | (not (memq? (ob$get ob 'top-level-goal) 397 | top-level-goals))) 398 | (progn 399 | (setq deps (get-links ob *intends-ob* context)) 400 | (yloop (yfor dep in deps) 401 | (ydo (cx$retract context dep))) 402 | (cx$retract context ob)))))) 403 | 404 | (defun gc-plans1 (context top-level-goals) 405 | (ndbg-roman-nl *gate-dbg* rule 406 | "Gc plans for ~A in ~A" top-level-goals context) 407 | (yloop (initial (deps nil)) 408 | (yfor ob in (cx$get-all context)) 409 | (ydo (if (and (ty$instance? ob 'goal) 410 | ; (not (memq? ob top-level-goals)) 411 | (memq? (ob$get ob 'top-level-goal) top-level-goals)) 412 | (progn 413 | (setq deps (get-links ob *intends-ob* context)) 414 | (yloop (yfor dep in deps) 415 | (ydo (cx$retract context dep))) 416 | ; Don't clobber the top-level goal itself. 417 | (if (not (memq? ob top-level-goals)) 418 | (cx$retract context ob))))))) 419 | 420 | (defun gc-emotions (context) 421 | (ndbg-roman-nl *gate-dbg* rule "Gc emotions in ~A" context) 422 | (yloop (initial (deps nil)) 423 | (yfor ob in (cx$get-all context)) 424 | (ydo (if (ty$instance? ob 'emotion) 425 | (progn 426 | (setq deps (get-links ob *dependency-ob* context)) 427 | (yloop (yfor dep in deps) 428 | (ydo (cx$retract context dep))) 429 | (setq deps (get-links-from ob *dependency-ob* context)) 430 | (yloop (yfor dep in deps) 431 | (ydo (cx$retract context dep))) 432 | (cx$retract context ob)))))) 433 | 434 | ; End of file. 435 | -------------------------------------------------------------------------------- /gate_compile.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ;******************************************************************************* 10 | 11 | (setq *question-mark-atom* '?) 12 | 13 | (load "compat.cl") 14 | (load "loop.cl") 15 | (load "gate_macros.cl") 16 | 17 | (compile-file "compat.cl") 18 | (compile-file "loop.cl") 19 | (compile-file "gate_macros.cl") 20 | (compile-file "gate_cx.cl") 21 | (compile-file "gate_instan.cl") 22 | (compile-file "gate_main.cl") 23 | (compile-file "gate_prove.cl") 24 | (compile-file "gate_read_pr.cl") 25 | (compile-file "gate_ty.cl") 26 | (compile-file "gate_utils.cl") 27 | (compile-file "gate_unify.cl") 28 | 29 | ; End of file. 30 | -------------------------------------------------------------------------------- /gate_get.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains: 10 | ; Load GATE. 11 | ; 12 | ;******************************************************************************* 13 | 14 | (setq *question-mark-atom* '?) 15 | 16 | (progn 17 | (setq *gate-version* "GATE 2.3, Common Lisp version of 2004-12-20") 18 | (format t "=======================~%") 19 | (format t "Loading ~A...~%" *gate-version*) 20 | (format t "=======================~%") 21 | nil) 22 | 23 | (load "compat") 24 | 25 | (setq *gate-input* *standard-input*) 26 | (setq *gate-output* *standard-output*) 27 | (setq *gate-dbg* *standard-output*) 28 | (setq *gate-warn-dbg* t) 29 | (setq *gen-stream* nil) 30 | 31 | (if (not (boundp '*gate-load-options*)) 32 | (setq *gate-load-options* nil) 33 | nil) 34 | 35 | (load "loop") 36 | (load "gate_macros") 37 | 38 | (load "gate_main") 39 | (load "gate_ty") 40 | (load "gate_cx") 41 | (load "gate_instan") 42 | (load "gate_prove") 43 | (load "gate_read_pr") 44 | (load "gate_unify") 45 | (load "gate_utils") 46 | 47 | (load "gate_obs.cl") 48 | 49 | (interest 'ob-warn 'all) 50 | (interest 'context 'all) 51 | 52 | (format t "=======================~%") 53 | (format t "Welcome to ~A~%" *gate-version*) 54 | (format t "=======================~%") 55 | 56 | ; End of file. 57 | -------------------------------------------------------------------------------- /gate_instan.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains the instantiator for obs 10 | ; 11 | ; 10/13/84: Original version written 12 | ; 6/30/85: Added *modify*, *expand* 13 | ; 1/6/86: Changed specials to obs 14 | ; 1/29/86: Added omit-proc 15 | ; 1/30/86: Added variables-in 16 | ; 9/24/86: Got rid of flavors 17 | ; 9/29/86: Updated to new instantiation algorithm with cycle preservation 18 | ; 19 | ;******************************************************************************* 20 | 21 | (setq *found-obs* nil) 22 | (setq *instan-obs* nil) 23 | 24 | (setq *any-unbound?* nil) 25 | 26 | (defun ob$instantiate (template bindings) 27 | (ob$instantiate1 template bindings 100 nil nil)) 28 | 29 | (defun ob$instantiate1 (template bindings depth omit-slots include-slots) 30 | (setq *instan-obs* nil) 31 | (setq *any-unbound?* nil) 32 | (ob$instantiate2 template bindings depth 33 | omit-slots include-slots nil nil nil)) 34 | 35 | ; 36 | ; substit: a binding list of pairs. Each pair has the thing (ob or otherwise) 37 | ; to substitute and the thing to substitute it with. 38 | ; 39 | (defun ob$subst (ob substit depth omit-slots include-slots) 40 | (setq *instan-obs* nil) 41 | (setq *any-unbound?* nil) 42 | (ob$instantiate2 ob *empty-bd* depth 43 | omit-slots include-slots substit nil nil)) 44 | 45 | ; 46 | ; variabilize?: a predicate determining whether an ob should be abstracted 47 | ; and converted into a unique variable. Multiple occurences of the same ob 48 | ; will become the same variable. 49 | ; 50 | (defun ob$variabilize (ob variabilize? depth omit-slots include-slots) 51 | (setq *instan-obs* nil) 52 | (setq *any-unbound?* nil) 53 | (ob$instantiate2 ob *empty-bd* depth omit-slots 54 | include-slots '(t) variabilize? nil)) 55 | 56 | (defun ob$varize (ob variabilize?) 57 | (setq *instan-obs* nil) 58 | (setq *any-unbound?* nil) 59 | (ob$instantiate2 ob *empty-bd* 100 nil 60 | nil '(t) variabilize? nil)) 61 | 62 | ; 63 | ; omit-proc: a predicate determining whether an ob should be returned 64 | ; as is, without instantiation. 65 | ; 66 | (defun ob$instan-omit (ob bd omit-proc depth omit-slots include-slots) 67 | (setq *instan-obs* nil) 68 | (setq *any-unbound?* nil) 69 | (ob$instantiate2 ob bd depth omit-slots include-slots nil nil omit-proc)) 70 | 71 | (setq *instantiate-omit-obs* nil) 72 | 73 | (defun ob$instantiate-dbg (template bindings depth 74 | omit-slots include-slots substit abstract 75 | omit-proc) 76 | (ndbg-begin) 77 | (ndbg *gate-dbg* instantiate "Call ob$instantiate3: ~A ~A~%" 78 | template bindings) 79 | (let ((result (ob$instantiate3 template bindings depth 80 | omit-slots include-slots substit abstract 81 | omit-proc))) 82 | (ndbg *gate-dbg* instantiate "Return from ob$instantiate3: ~A~%" result) 83 | (ndbg-end) 84 | result)) 85 | 86 | ; 87 | ; This should never be called from the top-level, at least without not 88 | ; first doing (setq *instan-obs* nil) and (setq *any-unbound?* nil). 89 | ; 90 | 91 | (defun ob$instantiate3 (template bindings depth 92 | omit-slots include-slots substit abstract 93 | omit-proc) 94 | (cond 95 | ((let ((found (assq template *instan-obs*))) 96 | (if found 97 | (cdr found) 98 | nil))) 99 | ((and depth (< depth 0)) 100 | template) 101 | ((and omit-proc (funcall omit-proc template)) template) 102 | ((not (ob? template)) template) 103 | ((var? template) 104 | (let ((found (bd-hyper-lookup (variable-name template) bindings))) 105 | (if found 106 | (cond 107 | ((var? found) 108 | (setq *any-unbound?* t) 109 | ; (ndbg *gate-dbg* ob-warn "(?~A binding cycle)~%" 110 | ; (variable-name found)) 111 | found) 112 | ((and (ob? found) (vars-in? found)) 113 | (ob$instantiate2 found bindings (if depth (-1+ depth) nil) 114 | omit-slots 115 | include-slots substit abstract omit-proc)) 116 | (else found)) 117 | (progn 118 | (setq *any-unbound?* t) 119 | ; (ndbg *gate-dbg* ob-warn "(?~A unbound)~%" 120 | ; (variable-name template)) 121 | template)))) 122 | ((special? template) 123 | (ob$instan-special template bindings (if depth (-1+ depth) nil) 124 | omit-slots include-slots 125 | substit abstract omit-proc)) 126 | (else ; (ob? template) 127 | (let ((result-ob (ob$create-empty))) 128 | (setq *instan-obs* (cons (cons template result-ob) *instan-obs*)) 129 | (yloop 130 | (initial (rest (ob$pairs template)) 131 | (substitution nil)) 132 | (ywhile rest) 133 | (ydo (if (and (not (memq? (slots-name (car rest)) omit-slots)) 134 | (not (memq? (slots-name (car rest)) 135 | *permanent-ignore-slots*)) 136 | (not (null? (slots-value (car rest)))) ; todo 137 | (if include-slots 138 | (memq? (slots-name (car rest)) include-slots) 139 | t)) 140 | (progn 141 | (setq substitution (bd-lookup (slots-value (car rest)) substit)) 142 | (ob$add result-ob (slots-name (car rest)) 143 | (cond 144 | (substitution substitution) 145 | ((and abstract 146 | (funcall abstract (slots-value (car rest)))) 147 | (let ((uniqvar 148 | (make-var (gen-id "var") 149 | (ty$get-major-type 150 | (ob$ty (slots-value (car rest))))))) 151 | (setq substit (bd-bind! (slots-value (car rest)) 152 | uniqvar substit)) 153 | uniqvar)) 154 | (else 155 | (if (or (memq? (slots-value (car rest)) 156 | *instantiate-omit-obs*) 157 | (and (ob? (slots-value (car rest))) 158 | (ob$literal? (slots-value (car rest))))) 159 | (slots-value (car rest)) 160 | (ob$instantiate2 (slots-value (car rest)) 161 | bindings (if depth (-1+ depth) 162 | nil) 163 | omit-slots include-slots substit 164 | abstract omit-proc))))))) 165 | (setq rest (cdr rest))) 166 | (yresult result-ob)))))) 167 | 168 | (defun ob$instan-special (template bindings depth omit-slots include-slots 169 | substit abstract omit-proc) 170 | (cond 171 | ((ty$instance? template 'uor) 172 | (ob$instantiate2 (ob$get template 'obj) bindings depth omit-slots 173 | include-slots substit abstract omit-proc)) 174 | ((ty$instance? template 'uand) 175 | (cond 176 | ((any (lambda (elem) (if (not (ob? elem)) elem nil)) 177 | (ob$gets template 'obj))) 178 | (else 179 | (yloop 180 | (initial (result nil) 181 | (found nil)) 182 | (yfor elem in (ob$gets template 'obj)) 183 | (yuntil result) 184 | (ydo 185 | (if (and (var? elem) 186 | (setq found (bd-hyper-lookup (variable-name elem) bindings))) 187 | (cond 188 | ((var? found) 189 | (setq *any-unbound?* t) 190 | ; (ndbg *gate-dbg* ob-warn "(?~A binding cycle)~%" 191 | ; (variable-name found)) 192 | (setq result found)) 193 | ((and (ob? found) (vars-in? found)) 194 | (setq result (ob$instantiate2 found bindings depth omit-slots 195 | include-slots substit abstract 196 | omit-proc))) 197 | (else 198 | (setq result (ob$instantiate2 found bindings depth omit-slots 199 | include-slots substit abstract 200 | omit-proc)))))) 201 | (yresult 202 | (if result 203 | result 204 | (if (any? (lambda (elem) (and (ob? elem) (not (var? elem)))) 205 | (ob$gets template 'obj)) 206 | (let ((result-ob (ob$create-empty))) 207 | (setq *instan-obs* (cons (cons template result-ob) 208 | *instan-obs*)) 209 | (yloop 210 | (initial (result nil)) 211 | (yfor elem in (ob$gets template 'obj)) 212 | (ydo 213 | (if (and (ob? elem) (not (var? elem))) 214 | (progn 215 | (setq result (ob$instantiate2 elem bindings depth 216 | omit-slots include-slots 217 | substit abstract 218 | omit-proc)) 219 | (yloop 220 | (yfor pair in (ob$pairs result)) 221 | (ydo 222 | ; Todo: something about type here. 223 | (ob$add result-ob (slots-name pair) 224 | (slots-value pair)))) 225 | (if (ob? result) 226 | (ob$destroy result) 227 | (error "~A not ob to destroy" result)))))) 228 | ; Todo: should not always destroy? What if result 229 | ; isn't a copy? 230 | result-ob) 231 | (ob$copy template)))))))) 232 | ((ty$instance? template 'unot) 233 | (ob$fcreate `(UNOT obj ,(ob$get template 'obj)))) 234 | ((ty$instance? template 'udist) 235 | (ob$fcreate `(UDIST obj ,(ob$get template 'obj)))) 236 | ((ty$instance? template 'uproc) 237 | 'uproc-answer-true) 238 | ((ty$instance? template 'uselect) 239 | (let ((ob (ob$instantiate2 (ob$get template 'pattern) 240 | bindings depth omit-slots 241 | include-slots substit abstract omit-proc))) 242 | (if (ob? ob) 243 | (ob$get ob (ob$get template 'slot)) 244 | ob))) 245 | ((ty$instance? template 'ucode) 246 | (let ((old-ob-bindings *ob-bindings*) 247 | (result nil)) 248 | (setq *ob-bindings* bindings) 249 | (setq result (eval (ob$get template 'proc))) 250 | (setq *ob-bindings* old-ob-bindings) 251 | result)) 252 | ((ty$instance? template 'ubind!) 253 | (let ((result (ob$instantiate2 (ob$get template 'pattern) bindings 254 | depth omit-slots 255 | include-slots substit abstract omit-proc))) 256 | (bd-bind! (variable-name (ob$get template 'var)) 257 | result 258 | bindings) 259 | result)) 260 | (else (error "~A unknown special" template)))) 261 | 262 | ; 263 | ; 264 | ; ob$instantiate!: 265 | ; 266 | ; This version of instantiate does not copy anything. 267 | ; It simply replaces all bound variables with their values. 268 | ; 269 | 270 | (defun ob$instantiate! (template bindings) 271 | (ob$instantiate1! template bindings nil)) 272 | 273 | (defun ob$instantiate1! (template bindings depth) 274 | (ob$instantiate2! template bindings depth nil nil)) 275 | 276 | (defun ob$instantiate2! (template bindings depth ob slot-name) 277 | (cond 278 | ((var? template) 279 | (let ((found (assq (variable-name template) (cdr bindings)))) 280 | (if found 281 | (progn 282 | (ob$remove ob slot-name template) 283 | (ob$add ob slot-name (cadr found)) 284 | (cadr found)) 285 | (progn 286 | (ndbg *gate-dbg* ob-warn 287 | "Warning: No binding for ~A in instantiate.~%" 288 | template) 289 | template)))) 290 | ((ob? template) 291 | (yloop 292 | (initial (rest (ob$pairs template))) 293 | (ywhile rest) 294 | (ydo (if (and (ob? (slots-value (car rest))) 295 | (ob$literal? (slots-value (car rest)))) 296 | (slots-value (car rest)) 297 | (if (number? depth) 298 | (if (> depth 1) 299 | (ob$instantiate2! (slots-value (car rest)) 300 | bindings 301 | (-1+ depth) 302 | template 303 | (slots-name (car rest))) 304 | (slots-value (car rest))) 305 | (ob$instantiate2! (slots-value (car rest)) 306 | bindings 307 | nil 308 | template 309 | (slots-name (car rest))))) 310 | (setq rest (cdr rest))) 311 | (yresult template))) 312 | (else template))) 313 | 314 | ; 315 | ; Copies an ob down to the given depth. Does NOT replace variables 316 | ; with their values the way ob-instantiate does. 317 | ; 318 | ; (coding assistance from Sergio Alvarado) 319 | ; 320 | 321 | (defun ob$copy (self) 322 | (setq *found-obs* nil) 323 | (copy-ob1 self 1 '(top-context))) 324 | 325 | (defun ob$copy-deep (self) 326 | (setq *found-obs* nil) 327 | (copy-ob1 self 1000 nil)) 328 | 329 | (defun copy-ob (template) 330 | (setq *found-obs* nil) 331 | (copy-ob1 template 1 nil)) 332 | 333 | (defun ob$copy-omit (ob slots) 334 | (setq *found-obs* nil) 335 | (copy-ob1 ob 1 slots)) 336 | 337 | (defun copy-ob1 (template depth omit-slots) 338 | (cond 339 | ((var? template) template) 340 | ((ob? template) 341 | (cond 342 | ((let ((found (assq template *found-obs*))) 343 | (if found 344 | (cadr found) 345 | nil))) 346 | (else 347 | (yloop 348 | (initial (new-ob (ob$create-empty))) 349 | (yfor sv in (ob$pairs template)) 350 | (ydo (if (not (memq? (slots-name sv) omit-slots)) 351 | (ob$add new-ob 352 | (slots-name sv) 353 | (if (and (ob? (slots-value sv)) 354 | (ob$literal? (slots-value sv))) 355 | (slots-value sv) 356 | (if (number? depth) 357 | (if (> depth 1) 358 | (copy-ob1 (slots-value sv) 359 | (-1+ depth) 360 | omit-slots) 361 | (slots-value sv)) 362 | (copy-ob1 (slots-value sv) 363 | nil 364 | omit-slots)))))) 365 | (yresult (progn 366 | (push (list template new-ob) *found-obs*) 367 | new-ob)))))) 368 | (else template))) 369 | 370 | (defun vars-in? (ob) 371 | (setq *found-vars* nil) 372 | (vars-in1? ob)) 373 | 374 | (setq *vars-in-ignores* 375 | '(linked-to linked-from linked-to-of linked-from-of 376 | analogical-episode main-motiv termination-context 377 | failure-context)) 378 | 379 | (defun vars-in1? (ob) 380 | (if (memq? ob *found-vars*) 381 | nil 382 | (progn 383 | (setq *found-vars* (cons ob *found-vars*)) 384 | (cond 385 | ((and (ob? ob) (ob$literal? ob)) nil) 386 | ((ob? ob) 387 | (yloop (initial (result nil)) 388 | (yfor sv in (ob$pairs ob)) 389 | (ywhile (not result)) 390 | (ydo (if (and (not (cx? (slots-value sv))) 391 | (not (memq? (slots-name sv) 392 | *vars-in-ignores*)) 393 | (not (memq? (slots-name sv) 394 | *permanent-ignore-slots*))) 395 | (if (and (var? (slots-value sv)) 396 | (not (memq? (slots-value sv) result))) 397 | (setq result t) 398 | (setq result (vars-in1? (slots-value sv)))))) 399 | (yresult result))) 400 | (else nil))))) 401 | 402 | (setq *found-vars* nil) 403 | 404 | (defun variables-in (ob omit-slots) 405 | (setq *found-vars* nil) 406 | (variables-in1 ob omit-slots)) 407 | 408 | (defun variables-in1 (ob omit-slots) 409 | (if (memq? ob *found-vars*) 410 | nil 411 | (progn 412 | (setq *found-vars* (cons ob *found-vars*)) 413 | (cond 414 | ((and (ob? ob) (ob$literal? ob)) nil) 415 | ((ob? ob) 416 | (yloop (initial (result nil)) 417 | (yfor sv in (ob$pairs ob)) 418 | (ydo (if (and (not (memq? (slots-name sv) omit-slots)) 419 | (not (cx? (slots-value sv)))) 420 | (if (and (var? (slots-value sv)) 421 | (not (memq? (slots-value sv) result))) 422 | (setq result (cons (slots-value sv) result)) 423 | (setq result (union result (variables-in1 (slots-value 424 | sv) omit-slots)))))) 425 | (yresult result))) 426 | (else nil))))) 427 | 428 | ; End of file. 429 | -------------------------------------------------------------------------------- /gate_macros.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ;******************************************************************************* 10 | 11 | (defmacro fixnum->string (n) `(format nil "~A" ,n)) 12 | 13 | (defmacro dbg (dbg-var . rest) 14 | `(progn 15 | (cond 16 | ((eq? ,dbg-var t) 17 | (format t ,@rest)) 18 | (,dbg-var 19 | (format ,dbg-var ,@rest)) 20 | (else nil)))) 21 | 22 | (defmacro if-interested-in (key . rest) 23 | `(if (and (assq ',key *ndbg-interests*) 24 | (or (memq? 'all (assq ',key *ndbg-interests*)) 25 | (any? (lambda (x) (memq? x *ndbg-items*)) 26 | (cdr (assq ',key *ndbg-interests*))))) 27 | (progn ,@rest) 28 | nil)) 29 | 30 | (defmacro ndbg (dbg-stream key . rest) 31 | `(progn 32 | (if (and (assq ',key *ndbg-interests*) 33 | (or (memq? 'all (assq ',key *ndbg-interests*)) 34 | (any? (lambda (x) (memq? x *ndbg-items*)) 35 | (cdr (assq ',key *ndbg-interests*))))) 36 | (cond 37 | ((eq? ,dbg-stream t) 38 | ; (format (standard-output) "~&") 39 | ; (ndbg-indentation (standard-output)) 40 | (format (standard-output) ,@rest) 41 | t) 42 | (,dbg-stream 43 | ; (format ,dbg-stream "~&") 44 | ; (ndbg-indentation ,dbg-stream) 45 | (format ,dbg-stream ,@rest) 46 | t) 47 | (else nil)) 48 | nil))) 49 | 50 | (defmacro ndbg-if (key form) 51 | `(if (and (assq ',key *ndbg-interests*) 52 | (or (memq? 'all (assq ',key *ndbg-interests*)) 53 | (any? (lambda (x) (memq? x *ndbg-items*)) 54 | (cdr (assq ',key *ndbg-interests*))))) 55 | ,form)) 56 | 57 | (defmacro length-one? (x) 58 | `(and ,x (null? (cdr ,x)))) 59 | 60 | (defmacro nil? (x) 61 | `(or (null? ,x) 62 | (eq? ,x 'nil))) 63 | 64 | (defmacro pc (context-abbr) 65 | `(cx$print (eval (symbolconc 'CX. ,context-abbr)))) 66 | 67 | (defmacro pca (context-abbr) 68 | `(cx$print-ancestors (eval (symbolconc 'CX. ,context-abbr)))) 69 | 70 | (defmacro mem-empty-unify (ob obs context) 71 | `(mem (lambda (x y) 72 | (bd-and-empty-bd? (ob$unify-cx x y *empty-bd* ,context))) 73 | ,ob ,obs)) 74 | 75 | (defmacro mem-empty-unify? (ob obs context) 76 | `(mem? (lambda (x y) 77 | (bd-and-empty-bd? (ob$unify-cx x y *empty-bd* ,context))) 78 | ,ob ,obs)) 79 | 80 | (defmacro mem-unify (ob obs context) 81 | `(mem (lambda (x y) (ob$unify-cx x y *empty-bd* ,context)) ,ob ,obs)) 82 | 83 | (defmacro mem-unify? (ob obs context) 84 | `(mem? (lambda (x y) (ob$unify-cx x y *empty-bd* ,context)) ,ob ,obs)) 85 | 86 | (defmacro del-unify! (ob obs context) 87 | `(del! (lambda (x y) (ob$unify-cx x y *empty-bd* ,context)) ,ob ,obs)) 88 | 89 | (defmacro retrieve-bd->ob (bd) 90 | `(map 'list (lambda (x) (car x)) ,bd)) 91 | 92 | (defmacro cx? (x) 93 | `(and (ob? ,x) 94 | (eq? (ob$ty ,x) *cx-ob*))) 95 | 96 | (defmacro touchable-fact? (fact) 97 | `(not (ty$instance? ,fact 'causal-link))) 98 | 99 | (defmacro ob$instantiate2 (template bindings depth 100 | omit-slots include-slots substit abstract 101 | omit-proc) 102 | `(if *unify-debugging?* 103 | (ob$instantiate-dbg ,template ,bindings ,depth 104 | ,omit-slots ,include-slots ,substit ,abstract 105 | ,omit-proc) 106 | (ob$instantiate3 ,template ,bindings ,depth 107 | ,omit-slots ,include-slots ,substit ,abstract 108 | ,omit-proc))) 109 | 110 | ; 111 | ; (ob? obj): 112 | ; 113 | ; Determine if an arbitrary Lisp object is an ob. 114 | ; 115 | (defmacro ob? (obj) `(typep ,obj 'obr)) 116 | 117 | (defmacro enforce-ob (obj routine) 118 | `(if (not (ob? ,obj)) 119 | (setq ,obj (error "~A: ~A not ob" ,routine ,obj)))) 120 | 121 | (defmacro ob$ty (ob) 122 | `(ob$get ,ob 'type)) 123 | 124 | (defmacro ty? (x) 125 | `(and (ob? ,x) 126 | (eq? (ob$ty ,x) *ty-ob*))) 127 | 128 | (defmacro path->slot-name (path) 129 | `(tlast ,path)) 130 | 131 | (defmacro var? (x) 132 | `(and (ob? ,x) 133 | (ty$instance? ,x 'uvar))) 134 | 135 | (defmacro special? (x) 136 | `(and (ob? ,x) 137 | (ty$instance? ,x 'uspecial))) 138 | 139 | (defmacro car-eq? (x y) 140 | `(and (pair? ,x) (eq? (car ,x) ,y))) 141 | 142 | (defmacro variable-name (x) 143 | `(ob$get ,x 'name)) 144 | 145 | (defmacro variable-type (x) 146 | `(ob$get ,x 'unifies-with)) 147 | 148 | ; Setters: For consistency, access to slots in obr is done through 149 | ; these macros. 150 | 151 | (defmacro set-obr-obnames (ob val) 152 | `(setf (obr-obnames ,ob) ,val)) 153 | 154 | (defmacro set-obr-slots (ob val) 155 | `(setf (obr-slots ,ob) ,val)) 156 | 157 | (defmacro set-obr-literal (ob val) 158 | `(setf (obr-literal ,ob) ,val)) 159 | 160 | ; 161 | ; Accessor functions for elements of the (obr-slots self) instance variable, 162 | ; which contains a triple of 163 | ; slot-name 164 | ; slot-value (a single value--multiple values for a slot require 165 | ; multiple entries in (obr-slots self)) 166 | ; 167 | 168 | (defmacro slots-name (slots) `(car ,slots)) 169 | 170 | (defmacro slots-value (slots) `(cadr ,slots)) 171 | 172 | (defmacro with-unhidden-default (&rest body) 173 | `(unwind-protect 174 | (progn (setq *hidden-default* nil) 175 | ,@body) 176 | (setq *hidden-default* t))) 177 | 178 | ; 179 | ; ob$create-empty: create a new empty ob 180 | ; 181 | (defmacro ob$create-empty () 182 | '(ob$create-named-empty nil)) 183 | 184 | (defmacro ndbg-newline (stream key) 185 | `(if-interested-in ,key (do-newline ,stream))) 186 | 187 | (defmacro ndbg-large-roman-font (stream key) 188 | `(if-interested-in ,key (begin-large-roman-font ,stream))) 189 | 190 | (defmacro ndbg-large-bold-font (stream key) 191 | `(if-interested-in ,key (begin-large-bold-font ,stream))) 192 | 193 | (defmacro ndbg-roman-font (stream key) 194 | `(if-interested-in ,key (begin-roman-font ,stream))) 195 | 196 | (defmacro ndbg-bold-font (stream key) 197 | `(if-interested-in ,key (begin-bold-font ,stream))) 198 | 199 | (defmacro ndbg-italic-font (stream key) 200 | `(if-interested-in ,key (begin-italic-font ,stream))) 201 | 202 | (defmacro ndbg-slanted-font (stream key) 203 | `(if-interested-in ,key (begin-slanted-font ,stream))) 204 | 205 | (defmacro ndbg-end-font (stream key) 206 | `(if-interested-in ,key (end-font ,stream))) 207 | 208 | (defmacro ndbg-roman (stream key . rest) 209 | `(if-interested-in ,key 210 | (begin-roman-font ,stream) 211 | (ndbg ,stream ,key ,@rest) 212 | (end-font ,stream))) 213 | 214 | (defmacro ndbg-roman-nl (stream key . rest) 215 | `(if-interested-in ,key 216 | (begin-roman-font ,stream) 217 | (ndbg ,stream ,key ,@rest) 218 | (end-font ,stream) 219 | (do-newline ,stream))) 220 | 221 | (defmacro ob$create (spec) 222 | `(ob$readlist ,spec)) 223 | 224 | (defmacro ob$fcreate (spec) 225 | `(ob$freadlist ,spec)) 226 | 227 | (defmacro special-priority? (ob1 ob2) 228 | `(cond 229 | ((not (special? ,ob1)) nil) 230 | ((not (special? ,ob2)) t) 231 | ((eq? (ob$ty ,ob1) (ob$ty ,ob2)) t) 232 | (else (memq? ,ob2 (memq ,ob1 *special-priorities*))))) 233 | ; REALLY: one should really be memq? and the other memq. 234 | 235 | (defmacro old-special-priority? (ob1 ob2) 236 | `(cond 237 | ((not (special? ,ob1)) nil) 238 | ((not (special? ,ob2)) t) 239 | ((ty$instance? ,ob1 'uor) t) 240 | ((and (ty$instance? ,ob1 'uand) 241 | (ty$instance? ,ob2 'uor)) 242 | nil) 243 | ((ty$instance? ,ob1 'uand) t) 244 | ((and (ty$instance? ,ob1 'unot) 245 | (or (ty$instance? ,ob2 'uor) 246 | (ty$instance? ,ob2 'uand))) 247 | nil) 248 | ((ty$instance? ,ob1 'unot) t) 249 | ((and (ty?instance? ,ob1 'uproc) 250 | (or (ty$instance? ,ob2 'uor) 251 | (ty$instance? ,ob2 'uand) 252 | (ty$instance? ,ob2 'unot))) 253 | nil) 254 | (else t))) 255 | 256 | (defmacro var-ty$instance? (x y) 257 | `(if (null? ,y) 258 | t 259 | (and (ob? ,x) 260 | (ty$instance-of? ,x ,y)))) 261 | 262 | (defmacro type-compatible-vars? (var1 var2) 263 | `(or *relax-unify-var* 264 | (null? (variable-type ,var1)) 265 | (null? (variable-type ,var2)) 266 | (memq? (variable-type ,var1) (ty$supertypes* (variable-type ,var2))) 267 | (memq? (variable-type ,var2) (ty$supertypes* (variable-type ,var1))))) 268 | 269 | (defmacro with-inverse-setting-default-off (&rest body) 270 | `(let ((result nil)) 271 | (inverse-setting-default-off) 272 | (setq result (progn ,@body)) 273 | (inverse-setting-default-on) 274 | result)) 275 | 276 | (defmacro bd-bind (var value bindings) 277 | `(if ,var ; this is for ob$unify-var which might pass a null var name. 278 | (cons 't (cons (list ,var ,value) (cdr ,bindings))) 279 | ,bindings)) 280 | 281 | (defmacro bd-bind! (var value bindings) 282 | ; (if (null? bindings) (error "bd-bind!: null bindings)) 283 | `(setf (cdr ,bindings) (cons (list ,var ,value) (cdr ,bindings)))) 284 | 285 | (defmacro bd-lookup (var bindings) 286 | `(and ,bindings 287 | (let ((found (assq ,var (cdr ,bindings)))) 288 | (if found (cadr found) nil)))) 289 | 290 | (defmacro bd-hyper-lookup (var bd) 291 | `(bd-hyper-lookup1 ,var ,bd nil nil)) 292 | 293 | ; 294 | ; Extra level to print debugging information. 295 | ; Should never be used from the top-level. 296 | ; 297 | (defmacro ob$unify2 (ob1 ob2 bindings ignore-slots) 298 | `(if *unify-debugging?* 299 | (ob$unify-dbg ,ob1 ,ob2 ,bindings ,ignore-slots) 300 | (ob$unify0 ,ob1 ,ob2 ,bindings ,ignore-slots))) 301 | 302 | ; 303 | ; Top-level unifier call 304 | ; 305 | (defmacro ob$unify1 (ob1 ob2 bindings ignore-slots) 306 | `(let ((already-matched *already-matched*) 307 | (result nil)) 308 | (setq *diff?* nil) 309 | (setq *already-matched* (cons t nil)) 310 | (setq result (ob$unify2 ,ob1 ,ob2 ,bindings ,ignore-slots)) 311 | (setq *already-matched* already-matched) 312 | result)) 313 | 314 | ; 315 | ; Top-level diffifier call 316 | ; 317 | (defmacro ob$diff1 (ob1 ob2 bindings ignore-slots) 318 | `(let ((already-matched *already-matched*) 319 | (result nil)) 320 | (setq *diff?* t) 321 | (setq *already-matched* (cons t nil)) 322 | (setq result (ob$unify2 ,ob1 ,ob2 ,bindings ,ignore-slots)) 323 | (setq *already-matched* already-matched) 324 | result)) 325 | 326 | ; 327 | ; Top-level unifier call 328 | ; 329 | (defmacro ob$unify (ob1 ob2 bindings) 330 | `(ob$unify1 ,ob1 ,ob2 ,bindings nil)) 331 | 332 | ; 333 | ; Top-level diffifier call 334 | ; 335 | (defmacro ob$diff (ob1 ob2 bindings) 336 | `(ob$diff1 ,ob1 ,ob2 ,bindings nil)) 337 | 338 | ; 339 | ; Top-level unifier calls (with context) 340 | ; 341 | (defmacro ob$unify-cx (ob1 ob2 bindings context) 342 | `(progn 343 | (setq *unify-context* ,context) 344 | (ob$unify1 ,ob1 ,ob2 ,bindings nil))) 345 | 346 | (defmacro ob$unify-cx1 (ob1 ob2 bindings ignore-slots context) 347 | `(progn 348 | (setq *unify-context* ,context) 349 | (ob$unify1 ,ob1 ,ob2 ,bindings ,ignore-slots))) 350 | 351 | ; 352 | ; ob$compare: Compare two obs and produce a substitution 353 | ; binding list containing differences. 354 | ; 355 | 356 | (defmacro ob$compare (source target ignore-slots) 357 | `(let ((already-matched *already-matched*) 358 | (result nil)) 359 | (setq *already-matched* (cons t nil)) 360 | (setq result (ob$compare1 ,source 361 | ,target 362 | *empty-bd* 363 | ,ignore-slots 364 | (lambda (source target) 365 | (cond 366 | ((and (ty? source) 367 | (ty? target)) 368 | (ty$least-common-supertype source target)) 369 | ((and (ob$ty source) 370 | (ob$ty target)) 371 | (ty$least-common-supertype (ob$ty source) 372 | (ob$ty target))) 373 | (else nil))))) 374 | (setq *already-matched* already-matched) 375 | result)) 376 | 377 | ; End of file. 378 | -------------------------------------------------------------------------------- /gate_main.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains: 10 | ; OB slot-filler objects 11 | ; 12 | ; 10/13/84: Original version written 13 | ; 1/24/86: Added path functions, got rid of weblists 14 | ; 1/28/86: Changed add to use append-end instead of cons 15 | ; 9/25/86: Converted to be independent of flavors 16 | ; 11/02/86: Added add-unique-name 17 | ; 18 | ;******************************************************************************* 19 | 20 | (defun is-var? (x) (var? x)) 21 | 22 | ; Global list of obs 23 | (setq *obs* nil) 24 | 25 | ; Global list of obnames 26 | (setq *obnames* nil) 27 | 28 | ; 29 | ; OBR 30 | ; 31 | 32 | (defun print-ob (ob stream depth) 33 | (declare (ignore depth)) 34 | (ob$print-self ob stream)) 35 | 36 | (defstruct (obr (:print-function print-ob)) 37 | "OB representation structure" 38 | (obnames nil) ; list of symbols which may be used to name the ob 39 | (slots nil) ; list of (slot-name slot-value) 40 | (literal nil) ; whether the ob is a literal ob 41 | ) 42 | 43 | (defun ob$print-self (self stream) 44 | (cond 45 | ((ty? self) 46 | (format stream "#{~A}" (car (obr-obnames self)))) 47 | ((var? self) (format stream "#{~A: ?~A:~A}" 48 | (car (obr-obnames self)) 49 | (variable-name self) 50 | (if (variable-type self) 51 | (car (obr-obnames (variable-type self))) 52 | nil))) 53 | (else 54 | (format stream "#{~A: " (car (obr-obnames self))) 55 | (ob$sprint self stream) 56 | (format stream "}")))) 57 | 58 | (setq *hidden-default* t) 59 | 60 | (setq *next-ob-number* 1) 61 | 62 | ; 63 | ; ob$create-named-empty: create an empty ob with the specified name 64 | ; 65 | (defun ob$create-named-empty (name) 66 | (let ((self (make-obr))) 67 | (setq *obs* (cons self *obs*)) 68 | (if name 69 | (ob$add-name self name) 70 | (ob$add-unique-name 71 | self 72 | (string->symbol 73 | (string-append "OB." 74 | (prog1 75 | (fixnum->string *next-ob-number*) 76 | (increment-me *next-ob-number*)))))) 77 | self)) 78 | 79 | (defun ob$destroy (self) 80 | (if (obr-node self) 81 | (error "Sure enough, node of ~A isn't nil!" self)) 82 | (ob$remove-all self) 83 | (yloop (yfor obname in (obr-obnames self)) 84 | (ydo (ob$remove-name self obname))) 85 | (setq *obs* (delq! self *obs*))) 86 | 87 | ; 88 | ; Inverse slots 89 | ; 90 | 91 | (setq *inverse-slot-list* nil) 92 | 93 | ; 94 | ; A primary slot is any that does not have an inverse or one that 95 | ; was explicitly defined as a primary slot in a primary/secondary 96 | ; declaration. 97 | ; 98 | (defun primary-slot? (slot-name) 99 | (or (not (not (assq slot-name *inverse-slot-list*))) 100 | (yloop (initial (rest *inverse-slot-list*) 101 | (result nil)) 102 | (ywhile rest) 103 | (yuntil result) 104 | (ydo (if (eq? slot-name (cadr (car rest))) 105 | (setq result (car (car rest)))) 106 | (setq rest (cdr rest))) 107 | (yresult (null? result))))) 108 | 109 | (defun inverse-slot (slot-name) 110 | (let ((found (assq slot-name *inverse-slot-list*))) 111 | (if found 112 | (cadr found) 113 | (yloop (initial (rest *inverse-slot-list*) 114 | (result nil)) 115 | (ywhile rest) 116 | (yuntil result) 117 | (ydo (if (eq? slot-name (cadr (car rest))) 118 | (setq result (car (car rest)))) 119 | (setq rest (cdr rest))) 120 | (yresult result))))) 121 | 122 | (defun ob$decl-has-inverse (primary-slot-name) 123 | (ob$decl-inverses primary-slot-name 124 | (string->symbol 125 | (string-append 126 | (symbol->string primary-slot-name) 127 | "-OF")))) 128 | 129 | (defun used-as-primary? (primary) 130 | (and (primary-slot? primary) 131 | (any? (lambda (ob) 132 | (any? (lambda (slot) (eq? primary (slots-name slot))) 133 | (ob$pairs ob))) 134 | *obs*))) 135 | 136 | ; 137 | ; (ob$decl-inverses primary-slot-name secondary-slot-name): 138 | ; 139 | ; Declare a primary-slot/secondary-slot pair. Simply warns if the 140 | ; declaration has already been performed. 141 | ; 142 | (defun ob$decl-inverses (primary secondary) 143 | (if (not (used-as-primary? secondary)) 144 | (if (and (primary-slot? primary) 145 | (eq? (inverse-slot primary) secondary)) 146 | (ndbg *gate-dbg* ob-warn 147 | "Warning: Duplicate primary/secondary declaration ~A ~A~%" 148 | primary secondary) 149 | (cond 150 | ((inverse-slot primary) 151 | (error "~A already has an inverse of ~A." primary 152 | (inverse-slot primary))) 153 | ((inverse-slot secondary) 154 | (error "~A already has an inverse of ~A." primary 155 | (inverse-slot secondary))) 156 | (else (setq *inverse-slot-list* (cons (list primary secondary) 157 | *inverse-slot-list*)) t))) 158 | (progn 159 | (format *gate-output* 160 | "~&~A has already been used as a primary slot name.~%" 161 | secondary) 162 | (format *gate-output* "Declaration not performed.~%")))) 163 | 164 | (defun decl-primary-secondaries (lst) 165 | (map 'list 166 | (lambda (pair) (ob$decl-inverses (car pair) (cadr pair))) 167 | lst)) 168 | 169 | ; 170 | ; This function is not perfect. If one desires duplicate pairs, this 171 | ; will not create them. 172 | ; 173 | (defun enforce-inverses () 174 | (map 'list 175 | (lambda (ob) 176 | (if t 177 | (map 'list 178 | (lambda (slot) 179 | (let ((inv (inverse-slot (slots-name slot)))) 180 | (if (and inv 181 | (ob? (slots-value slot)) 182 | (null? (memq? ob (ob$gets 183 | (slots-value slot) inv)))) 184 | (ob$basic-add 185 | (slots-value slot) inv ob)))) 186 | (ob$pairs ob)))) 187 | *obs*)) 188 | 189 | ; 190 | ; (ob$add-name ob obname): 191 | ; 192 | ; Associate another obname with the ob. This new obname may be 193 | ; used to refer to the ob, as may any obnames previously defined. 194 | ; 195 | ; Todo: a separate *obnames* for non "OB." names would speed things up. 196 | ; Alternatively, use hash tables. 197 | ; 198 | (defun ob$add-name (self obname) 199 | (if (not (memq? obname (obr-obnames self))) 200 | (progn 201 | (if (ob? obname) 202 | (progn 203 | (setq obname (ob$name obname)) 204 | (ndbg *gate-dbg* ob-warn 205 | "Warning: Probable obname redefinition.~%"))) 206 | (if (not (symbol? obname)) 207 | (setq obname (error "ob$add-name: ~A not symbol" obname))) 208 | (yloop 209 | (ywhile (assq obname *obnames*)) 210 | (ydo 211 | (let ((new-obname 212 | (string->symbol 213 | (string-append 214 | (symbol->string obname) "X")))) 215 | (ndbg *gate-dbg* ob-warn 216 | "Warning: Obname ~A already used--using ~A instead.~%" 217 | obname new-obname) 218 | (setq obname new-obname)))) 219 | (setq *obnames* (cons (list obname self) *obnames*)) 220 | (set-obr-obnames self (cons obname (obr-obnames self))) 221 | obname) 222 | (progn 223 | (ndbg *gate-dbg* ob-warn 224 | "Warning: Obname ~A already in effect for specified ob.~%" 225 | obname) 226 | obname))) 227 | 228 | ; This assumes obname is already determined to be unique. We assume that 229 | ; we are able to generate unique "OB." names above. This assumes the 230 | ; user does not create such names also. 231 | (defun ob$add-unique-name (self obname) 232 | (setq *obnames* (cons (list obname self) *obnames*)) 233 | (set-obr-obnames self (cons obname (obr-obnames self))) 234 | obname) 235 | 236 | (defun ob$remove-name (self obname) 237 | (set-obr-obnames self (delq! obname (obr-obnames self))) 238 | (setq *obnames* (del! (lambda (x y) (eq? x (car y))) obname *obnames*)) 239 | (if (null? (obr-obnames self)) 240 | (ob$add-unique-name 241 | self 242 | (string->symbol 243 | (string-append "OB." 244 | (prog1 245 | (fixnum->string *next-ob-number*) 246 | (increment-me *next-ob-number*))))))) 247 | 248 | ; 249 | ; (ob$name->ob obname): 250 | ; 251 | ; Return the ob referred to by a obname. If there is no ob associated 252 | ; with the given obname, nil is returned. 253 | ; 254 | (defun ob$name->ob (obname) 255 | (let ((found (assq obname *obnames*))) 256 | (if found (cadr found) nil))) 257 | 258 | ; 259 | ; (ob$name ob): 260 | ; 261 | ; Return a (actually, the most recently defined) obname for an ob. 262 | ; 263 | (defun ob$name (self) 264 | (car (obr-obnames self))) 265 | 266 | ; 267 | ; (ob$names ob): 268 | ; 269 | (defun ob$names (self) 270 | (obr-obnames self)) 271 | 272 | ; 273 | ; The automatic setting of inverses can be disabled. Currently, 274 | ; inverse setting is turned off only during load of a ob dump. 275 | ; 276 | 277 | (setq *inverse-setting?* t) 278 | 279 | (defun inverse-setting-on () 280 | (let ((previous *inverse-setting?*)) 281 | (setq *inverse-setting?* t) 282 | previous)) 283 | 284 | (defun inverse-setting-off () 285 | (let ((previous *inverse-setting?*)) 286 | (setq *inverse-setting?* nil) 287 | previous)) 288 | 289 | (defun restore-inverse-setting (val) 290 | (setq *inverse-setting?* val)) 291 | 292 | ; 293 | ; (ob$add ob slot-name slot-value): 294 | ; 295 | ; Add a slot value to an ob. If slot-value is an ob, the inverse slot addition 296 | ; is performed. 297 | ; 298 | 299 | (defun ob$add (self slot-name slot-value) 300 | (enforce-ob self "ob$add") 301 | (ob$add1 self slot-name slot-value) 302 | slot-value) 303 | 304 | ; 305 | ; (ob$padd ob slot-path slot-value): 306 | ; 307 | ; Allows a path to be used. 308 | ; 309 | 310 | (defun ob$padd (self slot-path slot-value) 311 | (enforce-ob self "ob$padd") 312 | (if (pair? slot-path) 313 | (ob$add1 314 | (path->ob self slot-path) 315 | (path->slot-name slot-path) 316 | slot-value) 317 | (ob$add1 self slot-path slot-value)) 318 | slot-value) 319 | 320 | (defun path->ob (ob path) 321 | (if (cdr path) 322 | (path->ob (ob$get ob (car path)) 323 | (cdr path)) 324 | ob)) 325 | 326 | ; 327 | ; (ob$remove ob slot-name slot-value): 328 | ; 329 | ; Remove the specified value from the specified slot. If slot-value is a 330 | ; ob, the inverse slot removal is performed. 331 | ; 332 | 333 | (defun ob$remove (self slot-name slot-value) 334 | (enforce-ob self "ob$remove") 335 | (ob$remove1 self slot-name slot-value) 336 | slot-value) 337 | 338 | (defun ob$premove (self slot-path slot-value) 339 | (enforce-ob self "ob$premove") 340 | (if (pair? slot-path) 341 | (ob$remove1 342 | (path->ob self slot-path) 343 | (path->slot-name slot-path)) 344 | (ob$add1 self slot-path slot-value)) 345 | slot-value) 346 | 347 | ; 348 | ; (ob$gets ob slot-name): 349 | ; 350 | ; Return all values of a slot. 351 | ; 352 | 353 | (defun ob$gets (self slot-name) 354 | (enforce-ob self "ob$gets") 355 | (if (eq? slot-name 'obname) 356 | (obr-obnames self) 357 | (yloop (initial (result nil) 358 | (rest (obr-slots self))) 359 | (ywhile rest) 360 | (ydo (if (eq? slot-name (slots-name (car rest))) 361 | (setq result 362 | (append! result (list (slots-value (car rest)))))) 363 | (setq rest (cdr rest))) 364 | (yresult result)))) 365 | 366 | ; 367 | ; (ob$get-many ob slot-names): 368 | ; 369 | ; Return values of several slots. 370 | ; 371 | 372 | (defun ob$get-many (self slot-names) 373 | (enforce-ob self "ob$get-many") 374 | (yloop (initial (result nil) 375 | (rest (obr-slots self))) 376 | (ywhile rest) 377 | (ydo (if (memq? (slots-name (car rest)) slot-names) 378 | (setq result (append! result (list (slots-value (car rest)))))) 379 | (setq rest (cdr rest))) 380 | (yresult result))) 381 | 382 | (defun ob$concatenate (&rest obs) 383 | (yloop 384 | (initial (result (ob$create-empty))) 385 | (yfor ob in obs) 386 | (ydo 387 | (yloop 388 | (yfor sv in (ob$pairs ob)) 389 | (ydo (ob$add1 result (slots-name sv) (slots-value sv))))) 390 | (yresult result))) 391 | 392 | (defun ob$concatenate! (&rest obs) 393 | (yloop 394 | (initial (result (car obs))) 395 | (yfor ob in (cdr obs)) 396 | (ydo 397 | (yloop 398 | (yfor sv in (ob$pairs ob)) 399 | (ydo (ob$add1 result (slots-name sv) (slots-value sv))))) 400 | (yresult result))) 401 | 402 | ; 403 | ; ob$pairs: get all the slot-name slot-value pairs of an ob 404 | ; 405 | (defun ob$pairs (self) (obr-slots self)) 406 | 407 | (defun ob$slot-names (self) 408 | (yloop 409 | (initial (result nil)) 410 | (yfor pair in (ob$pairs self)) 411 | (ydo 412 | (if (not (memq? (car pair) result)) 413 | (setq result (append result (list (car pair)))))) 414 | (yresult result))) 415 | 416 | (defun make-into-obname (obj) (if (ob? obj) (ob$name obj) obj)) 417 | 418 | (defun ob$basic-add (self slot-name slot-value) 419 | (if (eq? slot-name 'obname) 420 | (ob$add-name self slot-value) 421 | (set-obr-slots self (append! (obr-slots self) 422 | (list (list slot-name slot-value)))))) 423 | 424 | (defun ob$literal? (self) (obr-literal self)) 425 | 426 | (defun ob$set-literal (self val) 427 | (set-obr-literal self val)) 428 | 429 | (defun ob$add1 (self slot-name slot-value) 430 | (ob$basic-add self slot-name slot-value) 431 | (if *inverse-setting?* 432 | (let ((inv (inverse-slot slot-name))) 433 | (if (and inv (ob? slot-value)) 434 | ; If slot-name has an inverse and slot-value is a ob, 435 | ; perform inverse setting 436 | (ob$basic-add slot-value inv self))))) 437 | 438 | ; 439 | ; (ob$get ob slot-name): 440 | ; 441 | ; Return a unique value of a slot. If there is more than one value for the 442 | ; slot, an arbitrary one is returned. 443 | ; 444 | 445 | (defun ob$get (self slot-name) 446 | (enforce-ob self "ob$get") 447 | (if (eq? slot-name 'obname) 448 | (car (obr-obnames self)) 449 | (let ((found (assq slot-name (obr-slots self)))) 450 | (if found (slots-value found) nil)))) 451 | 452 | (defun ob$pget (self slot-path) 453 | (enforce-ob self "ob$pget") 454 | (if (pair? slot-path) 455 | (ob$get (path->ob self slot-path) 456 | (path->slot-name slot-path)) 457 | (if (eq? slot-path 'obname) 458 | (car (obr-obnames self)) 459 | (let ((found (assq slot-path (obr-slots self)))) 460 | (if found (slots-value found) nil))))) 461 | 462 | ; 463 | ; (ob$set ob slot-name slot-value): 464 | ; 465 | ; If it is desired to restrict slot values to a unique entry, this 466 | ; method removes all slot values from a slot, then sets the unique entry. 467 | ; Inverses are affected similarly. 468 | ; 469 | 470 | (defun ob$set (self slot-name slot-value) 471 | (enforce-ob self "ob$set") 472 | (if (eq? slot-name 'obname) 473 | (progn 474 | (ob$add-name self slot-value) 475 | slot-value) 476 | (yloop 477 | (initial (values (ob$gets self slot-name))) 478 | (ywhile values) 479 | (ydo 480 | (ob$remove1 self slot-name (car values)) 481 | (setq values (cdr values))) 482 | (yresult 483 | (ob$add1 self slot-name slot-value) 484 | slot-value)))) 485 | 486 | (defun ob$pset (self slot-path slot-value) 487 | (enforce-ob self "ob$pset") 488 | (if (pair? slot-path) 489 | (ob$set (path->ob self slot-path) 490 | (path->slot-name slot-path) 491 | slot-value) 492 | (yloop (initial (values (ob$gets self slot-path))) 493 | (ywhile values) 494 | (ydo (ob$remove1 self slot-path (car values)) 495 | (setq values (cdr values))) 496 | (yresult 497 | (ob$add1 self slot-path slot-value)))) 498 | slot-value) 499 | 500 | ; This function is never used? 501 | (defun ob$set1 (self slot-name slot-value) 502 | (yloop (initial (values (ob$gets self slot-name))) 503 | (ywhile values) 504 | (ydo (ob$remove1 self slot-name (car values)) 505 | (setq values (cdr values))) 506 | (yresult (ob$add1 self slot-name slot-value))) 507 | slot-value) 508 | 509 | (defun ob$removes (self slot-name) 510 | (map 'list 511 | (lambda (slot) 512 | (if (eq? (slots-name slot) slot-name) 513 | (ob$remove1 self (slots-name slot) 514 | (slots-value slot)))) 515 | (obr-slots self)) 516 | self) 517 | 518 | (defun ob$remove-all (self) 519 | (map 'list 520 | (lambda (slot) 521 | (ob$remove1 self (slots-name slot) 522 | (slots-value slot))) 523 | (obr-slots self)) 524 | self) 525 | 526 | (defun ob$remove1 (self slot-name slot-value) 527 | (ob$basic-remove self slot-name slot-value) 528 | (if *inverse-setting?* 529 | (let ((inv (inverse-slot slot-name))) 530 | (if (and inv (ob? slot-value)) 531 | ; If slot-name has an inverse and slot-value is an ob, 532 | ; perform inverse removal. 533 | (ob$basic-remove slot-value inv self))))) 534 | 535 | (defun ob$basic-remove (self slot-name slot-value) 536 | (if (eq? slot-name 'obname) 537 | (ob$remove-name self slot-value) 538 | (yloop (initial (rest (obr-slots self)) (found nil)) 539 | (ywhile rest) 540 | (yuntil found) 541 | (ydo (if (and (eq? slot-name (slots-name (car rest))) 542 | (eq? slot-value (slots-value (car rest)))) 543 | (progn 544 | (setq found t) 545 | (set-obr-slots self (delq! (car rest) (obr-slots self))))) 546 | (setq rest (cdr rest))) 547 | (yresult (if (null? found) 548 | (progn 549 | (error "~A slot of ~A has no ~A value." 550 | slot-name self slot-value) 551 | nil)))))) 552 | 553 | ; End of file. 554 | -------------------------------------------------------------------------------- /gate_obs.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ;******************************************************************************* 10 | 11 | ; 12 | ; Type definitions for specials 13 | ; 14 | (ty$create 'UVAR nil '(prop (name unifies-with) ())) 15 | (ty$create 'USPECIAL nil nil) 16 | (ty$create 'UAND '(USPECIAL) '(prop (obj) ())) 17 | (ty$create 'UOR '(USPECIAL) '(prop (obj) ())) 18 | (ty$create 'UNOT '(USPECIAL) '(prop (obj) ())) 19 | (ty$create 'UDIST '(USPECIAL) '(prop (obj) ())) ; 'distinct' 20 | (ty$create 'UPROC '(USPECIAL) '(prop (proc) ())) 21 | (ty$create 'UEMPTY-SLOTS '(USPECIAL) '(prop (slots) ())) 22 | (ty$create 'UIGNORE-SLOTS '(USPECIAL) '(prop (slots pattern) ())) 23 | (ty$create 'UPATH '(USPECIAL) '(prop (path pattern) ())) 24 | (ty$create 'UOLPATH '(USPECIAL) '(prop (link direction pattern) ())) 25 | (ty$create 'UEVAL '(USPECIAL) '(prop (proc) ())) 26 | ; 27 | ; The below are used mostly for instantiation. 28 | ; 29 | (ty$create 'USELECT '(USPECIAL) '(prop (pattern slot) ())) 30 | (ty$create 'UCODE '(USPECIAL) '(prop (proc) ())) 31 | (ty$create 'UBIND! '(USPECIAL) '(prop (var pattern) ())) 32 | 33 | (setq *special-priorities* 34 | (list ^UOR ^UAND ^UNOT ^UDIST ^UPROC ^UEMPTY-SLOTS 35 | ^UIGNORE-SLOTS ^UPATH ^UOLPATH)) 36 | 37 | (ty$create 'PRULE nil '(nil (subgoal goal) ())) 38 | 39 | (ty$create 'RULEOPER nil '(prop (obj) ())) 40 | (ty$create 'RAND '(RULEOPER) nil) 41 | (ty$create 'RSEQ '(RULEOPER) nil) 42 | (ty$create 'ROR '(RULEOPER) nil) 43 | (ty$create 'RNOT '(RULEOPER) nil) 44 | (ty$create 'RTRUE '(RULEOPER) nil) 45 | (ty$create 'RFALSE '(RULEOPER) nil) 46 | (ty$create 'RCODE '(RULEOPER) nil) 47 | 48 | ; End of file. 49 | -------------------------------------------------------------------------------- /gate_prove.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains the OB theorem prover 10 | ; 11 | ; 2/23/87: First version written 12 | ; 13 | ;******************************************************************************* 14 | 15 | (setq *prules* nil) 16 | 17 | (defun ob$add-prule (prule) 18 | (setq *prules* (cons prule *prules*))) 19 | 20 | (defun ob$remove-prule (prule) 21 | (setq *prules* (delq! prule *prules*))) 22 | 23 | ;******************************************************************************* 24 | ; 25 | ; ob$prove: 26 | ; 27 | ; pattern - concept, possibly containing variables (i.e., a query), to prove 28 | ; bd - binding list with respect to which the proof is to be performed 29 | ; max-number - the maximum number of solutions that are to be generated 30 | ; 31 | ; ob$prove1: 32 | ; 33 | ; pfacts - context containing the 'facts' which may be used in the proof 34 | ; prules - list of obs which are the 'prules' which may be used in the proof 35 | ; ignore-slots - list of slots to ignore 36 | ; 37 | ; Sample rules demonstrating the use of ROR, RAND, and RNOT: 38 | ; 39 | ; (ob$fcreate '(PRULE subgoal (ROR obj (PTRANS actor ?Person to ?Location) 40 | ; obj (LIVES-IN actor ?Person loc ?Location)) 41 | ; goal (PROX actor ?Person loc ?Location))) 42 | ; 43 | ; A solution is an augmented binding list. Since web-prove can generate 44 | ; several solutions, the result is a list of augmented binding lists. Thus, 45 | ; ob$prove returns either: 46 | ; 47 | ; 1) NIL if con cannot be proved 48 | ; 2) list of augmented binding lists if con can be proved 49 | ; 50 | ; Still to do: 51 | ; Add negation 52 | ; 53 | ;******************************************************************************* 54 | 55 | (setq *proof-failures* nil) 56 | 57 | (defun ob$prove (pattern bd max-number) 58 | (ob$prove1 pattern bd max-number *prules* *pfacts* nil)) 59 | 60 | (defun ob$prove1 (pattern bd max-number prules pfacts ignore-slots) 61 | (setq *proof-failures* nil) 62 | (ob$prove2 pattern bd max-number prules pfacts ignore-slots)) 63 | 64 | (defun ob$prove2 (pattern bd max-number prules pfacts ignore-slots) 65 | (cond 66 | ((ty$instance? pattern 'rand) 67 | (ob$prove-all (ob$gets pattern 'obj) 68 | bd max-number prules pfacts ignore-slots)) 69 | ((ty$instance? pattern 'ror) 70 | (ob$prove-any (ob$gets pattern 'obj) 71 | bd max-number prules pfacts ignore-slots)) 72 | ((ty$instance? pattern 'rnot) 73 | (if (ob$prove2 (ob$get pattern 'obj) 74 | bd max-number 75 | prules pfacts ignore-slots) 76 | nil 77 | bd)) 78 | (else 79 | (yloop 80 | (initial (result 81 | (map 'list (lambda (elem) (cons nil (cdr elem))) 82 | (cx$retrieve-bd pfacts pattern bd))) 83 | (new-bd nil) 84 | (result1 nil)) 85 | (yfor prule in prules) 86 | (ywhile (< (length result) max-number)) 87 | (ydo 88 | (if (setq new-bd (ob$unify1 (ob$get prule 'goal) pattern bd 89 | ignore-slots)) 90 | (progn 91 | (if (setq result1 92 | (ob$prove2 (ob$instantiate (ob$get prule 'subgoal) new-bd) 93 | bd max-number prules pfacts ignore-slots)) 94 | (setq result (append! result 95 | (map 'list 96 | (lambda (elem) 97 | (cons t ;(cons prule (car elem)) 98 | (cdr elem))) 99 | result1))))))) 100 | (yresult 101 | (if (and (null? result) (not (memq? pattern *proof-failures*))) 102 | (setq *proof-failures* (cons (list pattern bd) *proof-failures*))) 103 | result))))) 104 | 105 | (defun ob$prove-all (prove-obs bd max-number prules pfacts ignore-slots) 106 | (let ((bd-list (ob$prove2 (car prove-obs) 107 | bd max-number prules pfacts ignore-slots))) 108 | (if (null? (cdr prove-obs)) 109 | bd-list 110 | (yloop (yfor bd in bd-list) 111 | (initial (result nil)) 112 | (ydo 113 | (setq result 114 | (append! result (ob$prove-all (cdr prove-obs) 115 | bd max-number prules 116 | pfacts ignore-slots)))) 117 | (yresult result))))) 118 | 119 | (defun ob$prove-any (prove-obs bd max-number prules pfacts ignore-slots) 120 | (yloop 121 | (initial (result nil)) 122 | (yfor elem in prove-obs) 123 | (yuntil result) 124 | (ydo 125 | (setq result (ob$prove2 elem bd max-number prules pfacts ignore-slots))) 126 | (yresult result))) 127 | 128 | ; End of file. 129 | -------------------------------------------------------------------------------- /gate_test.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; 2/23/87: First version written 10 | ; 20041220: Added tests 11 | ; 12 | ;******************************************************************************* 13 | 14 | (setq *question-mark-atom* '?) 15 | (load "gate_get.cl") 16 | 17 | (setq *test-succeeded* 0) 18 | (setq *test-total* 0) 19 | 20 | (defmacro test (a b) 21 | `(let ((a1 ,a)) 22 | (setq *test-total* (+ *test-total* 1)) 23 | (if (equal a1 ,b) 24 | (progn 25 | (format t "SUCCEEDED ~A~%" ',a) 26 | (setq *test-succeeded* (+ *test-succeeded* 1))) 27 | (progn 28 | (format t "FAILED ~A~%" ',a) 29 | (format t "==>~%") 30 | (format t "~A~%" a1) 31 | (format t "instead of~%") 32 | (format t "~A~%" ,b))))) 33 | 34 | (test 35 | (ty$fcreate 'PERSON nil '(name age occupation)) 36 | (ob$name->ob 'PERSON)) 37 | 38 | (test 39 | (ob$fcreate '(PERSON name "Karen" age 27 occupation 'DOCTOR obname Karen1)) 40 | (ob$name->ob 'Karen1)) 41 | 42 | (test 43 | (ob$fcreate '(PERSON name "Jim" age 31 occupation 'COMPOSER obname Jim1)) 44 | (ob$name->ob 'Jim1)) 45 | 46 | (test 47 | ^Karen1 48 | (ob$name->ob 'Karen1)) 49 | 50 | (test 51 | ^Jim1 52 | (ob$name->ob 'Jim1)) 53 | 54 | (test 55 | (ob$get ^Karen1 'name) 56 | "Karen") 57 | 58 | (test 59 | (ob$get ^Jim1 'age) 60 | 31) 61 | 62 | (test 63 | (ob$get ^Jim1 'occupation) 64 | 'COMPOSER) 65 | 66 | (test 67 | (ob$set ^Jim1 'age 32) 68 | 32) 69 | 70 | (test 71 | (ob$get ^Jim1 'age) 72 | 32) 73 | 74 | (test 75 | (ty$fcreate 'ACTION nil '(actor from to obj)) 76 | (ob$name->ob 'ACTION)) 77 | 78 | (test 79 | (ty$fcreate 'STATE nil nil) 80 | (ob$name->ob 'STATE)) 81 | 82 | (test 83 | (ty$fcreate 'ATRANS '(ACTION) '(actor from to obj)) 84 | (ob$name->ob 'ATRANS)) 85 | 86 | (test 87 | (ty$fcreate 'MTRANS '(ACTION) '(actor from to obj)) 88 | (ob$name->ob 'MTRANS)) 89 | 90 | (test 91 | (ty$fcreate 'PTRANS '(ACTION) '(actor from to obj)) 92 | (ob$name->ob 'PTRANS)) 93 | 94 | (test 95 | (ty$fcreate 'LIVES-IN '(STATE) '(actor loc)) 96 | (ob$name->ob 'LIVES-IN)) 97 | 98 | (test 99 | (ty$fcreate 'MAGAZINE nil '(name)) 100 | (ob$name->ob 'MAGAZINE)) 101 | 102 | (test 103 | (ob$fcreate '(ATRANS actor Jim1 104 | from Jim1 105 | to Karen1 106 | obj (MAGAZINE name "Ear Magazine") 107 | obname Atrans1)) 108 | (ob$name->ob 'Atrans1)) 109 | 110 | (test 111 | (ob$fcreate '(PERSON name "Peter" age 26 occupation 'MUSICIAN obname Peter1)) 112 | (ob$name->ob 'Peter1)) 113 | 114 | (test 115 | (ob$fcreate '(MTRANS actor Jim1 116 | from Jim1 117 | to Peter1 118 | obj Atrans1 119 | obname Mtrans1)) 120 | (ob$name->ob 'Mtrans1)) 121 | 122 | (test 123 | (ty$instance? ^Atrans1 'ACTION) 124 | t) 125 | 126 | (test 127 | (ty$instance? ^Atrans1 'ATRANS) 128 | t) 129 | 130 | (test 131 | (ty$instance? ^Atrans1 'MTRANS) 132 | nil) 133 | 134 | (test 135 | (ty$instance? ^Atrans1 'PERSON) 136 | nil) 137 | 138 | (test 139 | (ty$instance? ^Mtrans1 'MTRANS) 140 | t) 141 | 142 | (progn 143 | (setq pattern (ob$fcreate '(MTRANS actor ?Person1 144 | from ?Person1 145 | to ?Person2 146 | obj ?Anything))) 147 | *repl-wont-print*) 148 | 149 | (test 150 | (setq bd (ob$unify pattern ^Mtrans1 *empty-bd*)) 151 | `(T (ANYTHING ,^Atrans1) 152 | (PERSON2 ,^Peter1) 153 | (PERSON1 ,^Jim1))) 154 | 155 | (test 156 | (ob->list (ob$instantiate pattern bd)) 157 | '(MTRANS actor Jim1 158 | from Jim1 159 | to Peter1 160 | obj Atrans1)) 161 | 162 | (test 163 | (ty$fcreate 'POSS '(STATE) '(actor obj)) 164 | (ob$name->ob 'POSS)) 165 | 166 | (test 167 | (ty$fcreate 'INFERENCE nil '(if then)) 168 | (ob$name->ob 'INFERENCE)) 169 | 170 | (progn 171 | (setq *infs* 172 | (list (ob$fcreate '(INFERENCE if (ATRANS actor ?Person1 173 | from ?Person1 174 | to ?Person2 175 | obj ?Object) 176 | then (POSS actor ?Person2 177 | obj ?Object))))) 178 | *repl-wont-print*) 179 | 180 | (defun forward-inferences (cd) 181 | (yloop (initial (bd nil) (result nil)) 182 | (yfor inf in *infs*) 183 | (ydo (if (setq bd (ob$unify (ob$get inf 'if) cd *empty-bd*)) 184 | (setq result (cons (ob$instantiate (ob$get inf 'then) bd) 185 | result)))) 186 | (yresult result))) 187 | 188 | (test 189 | (ob->list (car (forward-inferences ^Atrans1))) 190 | `(POSS actor Karen1 191 | obj Ob.39)) 192 | 193 | (test 194 | (ty$fcreate 'LOCATION nil '()) 195 | (ob$name->ob 'LOCATION)) 196 | 197 | (test 198 | (ty$fcreate 'STORE '(LOCATION) '()) 199 | (ob$name->ob 'STORE)) 200 | 201 | (test 202 | (ob$fcreate '(STORE obname Store1)) 203 | (ob$name->ob 'Store1)) 204 | 205 | (test 206 | (ty$fcreate 'PROX '(STATE) '(actor loc)) 207 | (ob$name->ob 'PROX)) 208 | 209 | (progn 210 | (setq *prules* 211 | (list 212 | (ob$create '(PRULE subgoal (ROR obj (PTRANS actor ?Person 213 | to ?Location) 214 | (LIVES-IN actor ?Person 215 | loc ?Location)) 216 | goal (PROX actor ?Person 217 | loc ?Location))))) 218 | *repl-wont-print*) 219 | 220 | (progn 221 | (setq *pfacts* (cx$create)) 222 | (cx$assert *pfacts* (ob$fcreate '(PTRANS actor Jim1 to Store1))) 223 | *repl-wont-print*) 224 | 225 | (test 226 | (ob->list 227 | (ob$prove (ob$fcreate '(PROX actor ?Person loc Store1)) *empty-bd* 999)) 228 | `((t (person Jim1)))) 229 | 230 | (ty$create 'FATHER-OF nil '(nil (actor obj) ())) 231 | (ty$create 'MOTHER-OF nil '(nil (actor obj) ())) 232 | (ty$create 'GRANDFATHER-OF nil '(nil (actor obj) ())) 233 | (ty$create 'GRANDPARENT-OF nil '(nil (actor obj) ())) 234 | 235 | (setq *prules* nil) 236 | 237 | (ob$add-prule 238 | (ob$fcreate 239 | '(PRULE 240 | obname Grandfather-Rule 241 | subgoal (ROR 242 | obj (RAND obj (FATHER-OF actor ?Person1 243 | obj ?Person3) 244 | obj (FATHER-OF actor ?Person3 245 | obj ?Person2)) 246 | obj (RAND obj (FATHER-OF actor ?Person1 247 | obj ?Person3) 248 | obj (MOTHER-OF actor ?Person3 249 | obj ?Person2))) 250 | goal (GRANDFATHER-OF actor ?Person1 obj ?Person2)))) 251 | 252 | (ob$add-prule 253 | (ob$fcreate 254 | '(PRULE 255 | obname Grandparent-Rule 256 | subgoal (GRANDFATHER-OF actor ?Person1 obj ?Person2) 257 | goal (GRANDPARENT-OF actor ?Person1 obj ?Person2)))) 258 | 259 | (setq *pfacts* (cx$create)) 260 | 261 | (ob$fcreate '(PERSON name "Roger" obname Schank)) 262 | (ob$fcreate '(PERSON name "Michael" obname Dyer)) 263 | (ob$fcreate '(PERSON name "Wendy" obname Lehnert)) 264 | (ob$fcreate '(PERSON name "Margot" obname Flowers)) 265 | (ob$fcreate '(PERSON name "Jack" obname Hodges)) 266 | (ob$fcreate '(PERSON name "Erik" obname Mueller)) 267 | (ob$fcreate '(PERSON name "Uri" obname Zernik)) 268 | 269 | (cx$assert *pfacts* (ob$fcreate '(FATHER-OF actor Schank 270 | obj Flowers))) 271 | 272 | (cx$assert *pfacts* (ob$fcreate '(MOTHER-OF actor Flowers 273 | obj Hodges))) 274 | 275 | (cx$assert *pfacts* (ob$fcreate '(FATHER-OF actor Dyer 276 | obj Mueller))) 277 | 278 | (cx$assert *pfacts* (ob$fcreate '(FATHER-OF actor Dyer 279 | obj Zernik))) 280 | 281 | (cx$assert *pfacts* (ob$fcreate '(MOTHER-OF actor Lehnert 282 | obj Dyer))) 283 | 284 | (cx$assert *pfacts* (ob$fcreate '(FATHER-OF actor Schank 285 | obj Lehnert))) 286 | 287 | (test 288 | (ob->list 289 | (ob$prove1 (ob$fcreate '(GRANDFATHER-OF actor Schank obj Dyer)) 290 | *empty-bd* 10 *prules* *pfacts* nil)) 291 | `((t (person3 lehnert)))) 292 | 293 | (test 294 | (ob->list 295 | (ob$prove1 (ob$fcreate '(GRANDFATHER-OF actor Schank obj ?Person)) 296 | *empty-bd* 10 *prules* *pfacts* nil)) 297 | `((t (person hodges) (person3 flowers)) 298 | (t (person dyer) (person3 lehnert)))) 299 | 300 | (format t "~A of ~A tests succeeded.~%" *test-succeeded* *test-total*) 301 | 302 | ; End of file. 303 | -------------------------------------------------------------------------------- /gate_ty.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains the type mechanism with simple inheritance 10 | ; 11 | ; 6/29/85: Original version written 12 | ; 1/24/86: Added major types 13 | ; 9/23/86: Rewrote to be flavorless 14 | ; 15 | ;******************************************************************************* 16 | 17 | (ob$decl-inverses 'isa 'isa-of) 18 | ;(ob$decl-inverses 'type 'type-of) 19 | 20 | (defun ty$instance? (self type-name) 21 | (if (not (ob? self)) 22 | (progn (error "ty$instance?: ~A not ob" self) 23 | (ndbg-roman-nl *gate-dbg* ob-warn 24 | "Warning: ty$instance?: ~A not ob" self) 25 | nil) 26 | (and (ty? (ob$get self 'type)) 27 | (or (eq? type-name (ob$get self 'type)) 28 | (any? (lambda (x) (memq? type-name (ob$names x))) 29 | (ty$supertypes* (ob$get self 'type))))))) 30 | 31 | (defun ty$instance-of? (self type) 32 | (and (ty? (ob$get self 'type)) 33 | (memq? type (ty$supertypes* (ob$get self 'type))))) 34 | 35 | ; 36 | ; ppformat = ( ) 37 | ; 38 | 39 | (defun ty$create (name parent-names ppformat) 40 | (let* ((temp nil) 41 | (parents 42 | (map 'list (lambda (x) 43 | (setq temp (ob$name->ob x)) 44 | (if (null? temp) 45 | (error "ty$create ~A: ~A not defined yet.~%" name x) 46 | temp)) 47 | parent-names)) 48 | (type 49 | (ty$new name parents))) 50 | (cond 51 | (ppformat (ob$set type 'ppformat ppformat)) 52 | (parents (ob$set type 'ppformat (ob$get (car parents) 'ppformat))) 53 | (t (ob$set type 'ppformat 54 | '(prop (actor from to obj) (actor from to obj))))) 55 | type)) 56 | 57 | (defun ty$fcreate (name parent-names slots) 58 | (ty$create name parent-names (list nil slots nil))) 59 | 60 | (defun ty$new (name supertypes) 61 | (let ((type (ob$create-named-empty name)) 62 | (temp nil)) 63 | (ob$set type 'type *ty-ob*) 64 | (setq *types* (cons type *types*)) 65 | (yloop 66 | (yfor supertype in supertypes) 67 | (ydo (ob$add type 'isa supertype))) 68 | ; Exemplars are used by the DAYDREAMER generator. 69 | (setq temp (ob$create-empty)) 70 | (ob$add temp 'type type) 71 | (ob$set-literal type t) 72 | (ob$add type 'exemplar temp) 73 | ; Return new type 74 | type)) 75 | 76 | ; This is way recursive! 77 | (setq *ty-ob* (ob$create-named-empty 'ty)) 78 | (ob$set *ty-ob* 'ppformat '(nil (exemplar))) 79 | (ob$set-literal *ty-ob* t) 80 | 81 | (setq *types* (list *ty-ob*)) 82 | (ob$set *ty-ob* 'type *ty-ob*) 83 | 84 | (defun ty$major-type (type-name) 85 | (ob$set (ob$name->ob type-name) 'major-type? t)) 86 | 87 | (defun ty$display () 88 | (yloop (yfor type in *types*) 89 | (ydo (ob$unhide type)))) 90 | 91 | (defun ty$supertypes (self) 92 | (ob$gets self 'isa)) 93 | 94 | (defun ty$subtypes (self) 95 | (ob$gets self 'isa-of)) 96 | 97 | (defun ty$supertypes* (self) 98 | (yloop (initial (result nil) 99 | (x nil)) 100 | (yfor type in (ob$gets self 'isa)) 101 | (ydo (setq x (ty$supertypes* type)) 102 | (if (not (null? x)) 103 | (setq result (union result x)))) 104 | (yresult (cons self result)))) 105 | 106 | (defun ty$supertype-of? (self type) 107 | (memq? type (ty$supertypes* self))) 108 | 109 | (defun ty$subtypes* (self) 110 | (yloop (initial (result nil)) 111 | (yfor type in (ob$gets self 'isa-of)) 112 | (ydo (setq result (append result (ty$subtypes* type)))) 113 | (yresult (cons self result)))) 114 | 115 | (defun ty$subtype-of? (self type) 116 | (memq? type (ty$subtypes* self))) 117 | 118 | (defun ty$least-common-supertype (type1 type2) 119 | (yloop (initial (supertypes*2 (ty$supertypes* type2)) 120 | (result nil)) 121 | (yfor supertype1 in (ty$supertypes* type1)) 122 | (yuntil result) 123 | (ydo (if (memq? supertype1 supertypes*2) 124 | (setq result supertype1))) 125 | (yresult result))) 126 | 127 | (defun ty$basic-type-distance (ancestor type) 128 | (let ((position (position ancestor (ty$supertypes* type)))) 129 | (if position (+ 1 position) *max-fixnum*))) 130 | 131 | (defun ty$distance (type1 type2) 132 | (let ((lcs (ty$least-common-supertype type1 type2))) 133 | (if lcs 134 | (min (ty$basic-type-distance lcs type1) 135 | (ty$basic-type-distance lcs type2)) 136 | *max-fixnum*))) 137 | 138 | (defun ty$get-major-type (self) 139 | (yloop (initial (result nil)) 140 | (yfor type in (ty$supertypes* self)) 141 | (ywhile (not result)) 142 | (ydo (setq result (if (ob$get type 'major-type?) 143 | type 144 | nil))) 145 | (yresult (if result result self)))) 146 | 147 | ; End of file. 148 | -------------------------------------------------------------------------------- /gate_unify.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; This file contains the OB unifier 10 | ; 11 | ; 10/13/84: Original version written 12 | ; 1/24/85: Upgraded to full unifier 13 | ; 6/30/85: Added *instance-of*, ob$compare 14 | ; 9/3/85: Added loop checking in unifier 15 | ; 1/6/86: Changed special forms to obs 16 | ; 1/24/86: Commented out compile-web-pattern, added relaxation to ob-unify-var 17 | ; 1/26/86: Added variable-value 18 | ; 9/24/86: Removed flavors 19 | ; 9/29/86: Updated to new unification algorithm 20 | ; 11/2/86: Added UDIST, changed ob$unify-var 21 | ; 22 | ;******************************************************************************* 23 | 24 | (setq *unify-debugging?* nil) 25 | (setq *relax-unify-var* nil) 26 | 27 | ; 28 | ; Empty binding list 29 | ; 30 | (setq *empty-bd* '(t)) 31 | 32 | (defun bd-and-empty-bd? (bd) 33 | (if bd 34 | (if (null? (cdr bd)) 35 | bd 36 | nil) 37 | nil)) 38 | 39 | (defun empty-bd? (bd) 40 | (if (null? (cdr bd)) 41 | bd 42 | nil)) 43 | 44 | (defun non-empty-bd? (bd) 45 | (if (cdr bd) bd nil)) 46 | 47 | ; 48 | ; (bd-lookup var bindings): 49 | ; Look up the value of a variable in a binding list returned by ob$unify. 50 | ; 51 | (defun bd-create () (cons t nil)) 52 | 53 | (defun bd-hyper-lookup1 (var bd vars first-level) 54 | (if (memq? var vars) 55 | first-level 56 | (let ((val (bd-lookup var bd))) 57 | (if (var? val) 58 | (bd-hyper-lookup1 (variable-name val) 59 | bd 60 | (cons var vars) 61 | (if first-level first-level val)) 62 | val)))) 63 | 64 | (defun variable-hyper-lookup (variable bindings) 65 | (bd-hyper-lookup (variable-name variable) bindings)) 66 | 67 | ;(defun variable-hyper-lookup (variable bindings) 68 | ; (let ((found (assq (variable-name variable) 69 | ; (cdr bindings)))) 70 | ; (if found 71 | ; (if (var? (cadr found)) 72 | ; (variable-hyper-lookup1 (cadr found) bindings 73 | ; (list (variable-name variable))) 74 | ; (cadr found)) 75 | ; nil))) 76 | 77 | ;(defun variable-hyper-lookup1 (variable bindings names) 78 | ; (if (memq? (variable-name variable) names) 79 | ; nil 80 | ; (let ((found (assq (variable-name variable) 81 | ; (cdr bindings)))) 82 | ; (if found 83 | ; (if (var? (cadr found)) 84 | ; (variable-hyper-lookup1 (cadr found) bindings 85 | ; (cons (variable-name variable) names)) 86 | ; (cadr found)) 87 | ; variable)))) 88 | 89 | ;(defun bd-hyper-lookup1 (var bindings) 90 | ; (let ((found (assq var (cdr bindings)))) 91 | ; (if found 92 | ; (if (var? (cadr found)) 93 | ; (bd-hyper-lookup (variable-name (cadr found)) bindings) 94 | ; (cadr found)) 95 | ; var))) 96 | 97 | ; 98 | ; Variables 99 | ; 100 | ; Examples of macro translation: 101 | ; ?Self --> (UVAR name 'self unifies-with PERSON) 102 | ; ?Person1 --> (UVAR name 'person1 unifies-with PERSON)) 103 | ; ?Silly:Person --> (UVAR name 'silly unifies-with PERSON) 104 | ; ?:Person --> (UVAR unifies-with PERSON) 105 | ; ?? --> (UVAR) 106 | ; ?Notatype --> (UVAR name 'notatype) 107 | ; 108 | 109 | (defun make-var (name type) 110 | (cond 111 | ((and name type) 112 | (ob$fcreate `(UVAR 113 | name (QUOTE ,name) 114 | unifies-with ,type))) 115 | (type 116 | (ob$fcreate `(UVAR 117 | unifies-with ,type))) 118 | (name 119 | (ob$fcreate `(UVAR 120 | name (QUOTE ,name)))) 121 | (else (ob$fcreate '(UVAR))))) 122 | 123 | (defun variable-value (var bd) 124 | (bd-lookup (variable-name var) bd)) 125 | 126 | ; 127 | ; (ob$unify ob1 ob2 bindings): 128 | ; 129 | ; Unifier for obs 130 | ; (Looping check code taken from the rhapsody matcher by Scott Turner). 131 | ; 132 | 133 | (setq *already-matched* nil) 134 | 135 | (setq *diff?* nil) 136 | 137 | (defun ob$unify-dbg (ob1 ob2 bindings ignore-slots) 138 | (ndbg-begin) 139 | (ndbg *gate-dbg* unify "Call ob$unify: ~A ~A ~A ~A~%" 140 | ob1 ob2 bindings ignore-slots) 141 | (let ((result (ob$unify0 ob1 ob2 bindings ignore-slots))) 142 | (ndbg *gate-dbg* unify "Return from ob$unify: ~A~%" result) 143 | (ndbg-end) 144 | result)) 145 | 146 | ; 147 | ; List of slots which unification should always ignore. 148 | ; 149 | (setq *permanent-ignore-slots* '(top-context value weight offset decay 150 | plan-rule plan-subgoalnum 151 | ;;;; no no no linked-to-of linked-from-of 152 | input-state? 153 | inference-rule 154 | indexes)) 155 | 156 | (setq *unify-context* nil) 157 | 158 | ; 159 | ; This could be made faster by doing types first. Actually, types 160 | ; are done first anyway because they are the first slot. 161 | ; 162 | (defun ob$unify0 (ob1 ob2 bindings ignore-slots) 163 | (if (memq? ob2 (bd-lookup ob1 *already-matched*)) 164 | bindings 165 | (progn 166 | (bd-bind! ob1 167 | (cons ob2 (bd-lookup ob1 *already-matched*)) 168 | *already-matched*) 169 | ; The below would introduce a semantics which does not conform 170 | ; to unification asymmetry. 171 | ; (bd-bind! ob2 172 | ; (cons ob1 (bd-lookup ob2 *already-matched*)) 173 | ; *already-matched*) 174 | (let ((result 175 | (cond 176 | ((eq? ob1 ob2) bindings) 177 | ((or (special? ob1) 178 | (special? ob2)) 179 | (if (special-priority? ob1 ob2) 180 | (ob$unify-special ob1 ob2 bindings ignore-slots nil) 181 | (ob$unify-special ob2 ob1 bindings ignore-slots t))) 182 | ((var? ob1) 183 | (ob$unify-var ob1 ob2 bindings ignore-slots nil)) 184 | ((var? ob2) 185 | (ob$unify-var ob2 ob1 bindings ignore-slots t)) 186 | ((and (ob? ob1) (ob$literal? ob1)) nil) 187 | ((and (ob? ob2) (ob$literal? ob2)) nil) 188 | ((and (ob? ob1) (ob? ob2)) 189 | (yloop (initial (unified-slot-indices nil) 190 | (ob2-slots (ob$pairs ob2)) 191 | (constant-slot-index nil) 192 | (last-constant-value nil) 193 | (new-bindings nil) 194 | (found? nil)) 195 | (yfor cur in (ob$pairs ob1)) ; was reverse 196 | (ywhile bindings) 197 | (ydo (if (and (not (memq? (car cur) ignore-slots)) 198 | (not (memq? (car cur) *permanent-ignore-slots*))) 199 | (progn 200 | (setq constant-slot-index 0) 201 | (setq new-bindings nil) 202 | (setq found? nil) 203 | (setq last-constant-value nil) 204 | (yloop (yfor constant-slot-value in ob2-slots) 205 | (yuntil found?) 206 | (ydo 207 | (if (and (eq? (car cur) (slots-name constant-slot-value)) 208 | (not (memq? constant-slot-index unified-slot-indices)) 209 | (setq last-constant-value (slots-value constant-slot-value)) 210 | (setq new-bindings 211 | (if (eq? (cadr cur) (slots-value constant-slot-value)) 212 | bindings 213 | (ob$unify2 (cadr cur) (slots-value constant-slot-value) 214 | bindings ignore-slots)))) 215 | (progn 216 | (setq found? t) 217 | (setq unified-slot-indices 218 | (cons constant-slot-index unified-slot-indices)))) 219 | (increment-me constant-slot-index))) 220 | (if found? 221 | (setq bindings new-bindings) 222 | (if *diff?* 223 | (setq bindings (bd-bind (slots-name cur) 224 | (list 225 | (cadr cur) 226 | last-constant-value) 227 | bindings)) 228 | (setq bindings nil)))))) 229 | (yresult bindings))) 230 | (else nil)))) 231 | (if result 232 | result 233 | (progn 234 | (bd-bind! ob1 235 | (delq! ob2 (bd-lookup ob1 *already-matched*)) 236 | *already-matched*) 237 | (bd-bind! ob2 238 | (delq! ob1 (bd-lookup ob2 *already-matched*)) 239 | *already-matched*) 240 | nil)))))) 241 | 242 | (defun ob$unify-special (ob1 ob2 bindings ignore-slots reverse?) 243 | (cond 244 | ((ty$instance? ob1 'uand) 245 | (yloop (yfor item in (ob$gets ob1 'obj)) 246 | (ywhile bindings) 247 | (ydo (setq bindings 248 | (if reverse? 249 | (ob$unify2 ob2 item bindings ignore-slots) 250 | (ob$unify2 item ob2 bindings ignore-slots)))) 251 | (yresult bindings))) 252 | ((ty$instance? ob1 'uor) 253 | (yloop (yfor item in (ob$gets ob1 'obj)) 254 | (initial (new-bindings nil)) 255 | (yuntil new-bindings) 256 | (ydo (setq new-bindings 257 | (if reverse? 258 | (ob$unify2 ob2 item bindings ignore-slots) 259 | (ob$unify2 item ob2 bindings ignore-slots)))) 260 | (yresult new-bindings))) 261 | ((ty$instance? ob1 'unot) 262 | (if (if reverse? 263 | (ob$unify2 ob2 (ob$get ob1 'obj) bindings ignore-slots) 264 | (ob$unify2 (ob$get ob1 'obj) ob2 bindings ignore-slots)) 265 | nil 266 | bindings)) 267 | ((ty$instance? ob1 'udist) 268 | (let ((val1 (if (not (var? (ob$get ob1 'obj))) 269 | (ob$get ob1 'obj) 270 | (bd-hyper-lookup (variable-name (ob$get ob1 'obj)) 271 | bindings))) 272 | (val2 (if (not (var? ob2)) 273 | ob2 274 | (bd-hyper-lookup (variable-name ob2) bindings)))) 275 | (if (and (ob? val1) (ob? val2) 276 | (not (var? val1)) (not (var? val2))) 277 | (if (neq? val1 val2) bindings nil) 278 | bindings))) 279 | ((ty$instance? ob1 'uproc) 280 | (if (eq? ob2 'uproc-answer-true) 281 | bindings 282 | (ob$unify-proc ob2 (ob$get ob1 'proc) bindings))) 283 | ((ty$instance? ob1 'uempty-slots) 284 | (if (every? (lambda (slot-name) 285 | (null? (ob$gets ob2 slot-name))) 286 | (ob$get ob1 'slots)) 287 | bindings 288 | nil)) 289 | ((ty$instance? ob1 'uignore-slots) 290 | (if reverse? 291 | (ob$unify2 ob2 (ob$get ob1 'pattern) bindings 292 | (append ignore-slots (ob$get ob1 'slots))) 293 | (ob$unify2 (ob$get ob1 'pattern) ob2 bindings 294 | (append ignore-slots (ob$get ob1 'slots))))) 295 | ((ty$instance? ob1 'upath) 296 | (ob$path ob2 (ob$get ob1 'pattern) 297 | (ob$get ob1 'path) bindings)) 298 | ((ty$instance? ob1 'uolpath) 299 | (ol-path ob2 (ob$get ob1 'pattern) (ob$get ob1 'link) 300 | (ob$get ob1 'direction) 301 | *unify-context* 302 | nil 303 | bindings)) 304 | ((ty$instance? ob1 'ueval) 305 | (ob$eval (ob$get ob1 'proc) bindings)) 306 | ((ty$instance? ob1 'ucode) 307 | bindings) ; for now 308 | (else (error "ob$unify: unknown special!! ~A" ob1)))) 309 | 310 | ; The (else t) above basically ignores prioritization of: 311 | ; (ty$instance? ,ob1 'uempty-slots) 312 | ; (ty$instance? ,ob1 'uignore-slots) 313 | ; (ty$instance? ,ob1 'upath) 314 | ; (ty$instance? ,ob1 'uolpath) 315 | 316 | (defun ob$unify-proc (ob2 proc bd) 317 | (setq ob2 (ob$concretize ob2 bd)) 318 | (if (concretized? ob2) 319 | (if (funcall proc ob2) 320 | bd 321 | nil) 322 | bd)) 323 | 324 | (defun ob$concretize (ob bd) 325 | (cond 326 | ((var? ob) 327 | (ob$concretize-var ob bd)) 328 | ((and (ob? ob) 329 | (ty$instance? ob 'uand)) 330 | (ob$concretize-and ob bd)) 331 | (else ob))) 332 | 333 | (defun ob$concretize-and (and-ptn bd) 334 | (yloop (yfor item in (ob$gets and-ptn 'obj)) 335 | (initial (result nil)) 336 | (yuntil result) 337 | (ydo (if (var? item) 338 | (setq result (ob$concretize-var item bd)))) 339 | (yresult (if (null? result) 340 | (progn 341 | (format *gate-output* 342 | "Warning: ob$concretize-and unsuccessful.~%") 343 | and-ptn) 344 | result)))) 345 | 346 | (defun ob$concretize-var (var bd) 347 | (let ((found (bd-lookup (variable-name var) bd))) 348 | (if found found var))) 349 | 350 | (defun concretized? (var) 351 | (not (var? var))) 352 | 353 | ; 354 | ; Question mark atom should never get to here. 355 | ; 356 | ; This routine no longer checks if the types match right even if the variable 357 | ; is already bound. This used to be used to handle prebound typed ?Self, but 358 | ; now the self-type slot of rules serves this function. 359 | ; 360 | 361 | (defun ob$unify-var (ob1 ob2 bindings ignore-slots reverse?) 362 | (let ((val1 (bd-lookup (variable-name ob1) bindings)) 363 | (val2 nil)) 364 | ; was (if val1 (setq ob1 val1)) 365 | (if (and val1 (not (var? val1))) 366 | (setq ob1 val1)) 367 | (if (var? ob2) 368 | (progn 369 | (setq val2 (bd-lookup (variable-name ob2) bindings)) 370 | (if (and val2 (not (var? val2))) 371 | (setq ob2 val2)))) 372 | ; was (if val2 (setq ob2 val2)) 373 | (cond 374 | ((and (var? ob1) (var? ob2)) 375 | (if (type-compatible-vars? ob1 ob2) 376 | (if *diff?* 377 | bindings 378 | (bd-bind (variable-name ob2) ob1 379 | (bd-bind (variable-name ob1) ob2 bindings))) 380 | nil)) 381 | ((var? ob1) 382 | (if (var-ty$instance? ob2 (variable-type ob1)) 383 | (if *diff?* 384 | bindings 385 | (bd-bind (variable-name ob1) ob2 bindings)) 386 | nil)) 387 | ((var? ob2) 388 | (if (var-ty$instance? ob1 (variable-type ob2)) 389 | (if *diff?* 390 | bindings 391 | (bd-bind (variable-name ob2) ob1 bindings)) 392 | nil)) 393 | (else ;(and (not (var? ob1)) (not (var? ob2))) 394 | (if reverse? 395 | (ob$unify2 ob2 ob1 bindings ignore-slots) 396 | (ob$unify2 ob1 ob2 bindings ignore-slots)))))) 397 | 398 | ; 399 | ; This is the old incomprehensible version. 400 | ; 401 | (defun ob$old-unify-var (ob1 ob2 bindings ignore-slots reverse?) 402 | (if *relax-unify-var* 403 | (if (null? (variable-name ob1)) 404 | bindings 405 | (let ((found (bd-lookup (variable-name ob1) bindings))) 406 | (if found 407 | (ob$unify2 found ob2 bindings ignore-slots) 408 | (if (var? ob2) 409 | (progn 410 | (setq found (bd-lookup (variable-name ob2) bindings)) 411 | (if found 412 | (ob$unify2 ob1 found bindings ignore-slots) ; ? 413 | (bd-bind (variable-name ob1) ob2 bindings))) 414 | (bd-bind (variable-name ob1) ob2 bindings))))) 415 | (progn 416 | (if (and (variable-type ob1) 417 | (not (var? ob2)) 418 | (not (ty$instance-of? ob2 (variable-type ob1)))) 419 | nil 420 | (if (null? (variable-name ob1)) 421 | bindings ; but should do type compatibility check 422 | (let ((found (bd-lookup (variable-name ob1) bindings))) 423 | (if found 424 | (ob$unify2 found ob2 bindings ignore-slots) 425 | (if (var? ob2) 426 | (progn 427 | (setq found (bd-lookup (variable-name ob2) bindings)) 428 | (if found 429 | (ob$unify2 ob1 found bindings ignore-slots) ; ? 430 | (if (type-compatible-vars? ob1 ob2) 431 | (bd-bind (variable-name ob1) ob2 bindings) nil))) 432 | ; should check type compatibility in above line, 433 | ; but only if both variables are typed. 434 | (if (variable-type ob1) 435 | (if (ty$instance-of? ob2 (variable-type ob1)) 436 | (bd-bind (variable-name ob1) ob2 bindings) 437 | nil) 438 | (bd-bind (variable-name ob1) ob2 bindings)))))))))) 439 | 440 | (setq *max-breadth* 10) 441 | 442 | (defun ob$path (from-constant to-ptn links bindings) 443 | (yloop (initial 444 | (result nil) 445 | (count 0) 446 | (next-obs (ob$get-many from-constant links))) 447 | (yuntil 448 | (or result 449 | (if (> count *max-breadth*) 450 | (progn 451 | (ndbg *gate-dbg* ob-warn 452 | "Exceeded max breadth in ob$path.~%") 453 | t) 454 | nil))) 455 | (ywhile next-obs) 456 | (ydo 457 | (yloop (yfor next-ob in next-obs) 458 | (yuntil result) 459 | (ydo (setq result (ob$unify to-ptn next-ob bindings)))) 460 | (if (null? result) 461 | (setq next-obs 462 | (walk-append 463 | (lambda (ob) (ob$get-many ob links)) 464 | next-obs))) 465 | (increment-me count)) 466 | (yresult result))) 467 | 468 | (setq *uniquified-obs* nil) 469 | 470 | ; 471 | ; The following function seems to be ineffectual. Maybe all references 472 | ; to these obs are not being deleted? 473 | ; 474 | (defun gc-uniquified-obs () 475 | (yloop (yfor ob in *uniquified-obs*) 476 | (ydo (ob$destroy ob))) 477 | (setq *uniquified-obs* nil)) 478 | 479 | (defun ob$compare1 (source target substit ignore-slots proc) 480 | (if (memq? target (bd-lookup source *already-matched*)) 481 | substit 482 | (progn 483 | (bd-bind! source 484 | (cons target (bd-lookup source *already-matched*)) 485 | *already-matched*) 486 | (bd-bind! target 487 | (cons source (bd-lookup target *already-matched*)) 488 | *already-matched*) 489 | (let ((result 490 | (cond 491 | ((eq? source target) substit) 492 | ((and (ob? source) 493 | (and (ob$literal? source) (not (ty? source)))) nil) 494 | ((and (ob? target) 495 | (and (ob$literal? target) (not (ty? target)))) nil) 496 | ((eq? (bd-lookup source substit) target) substit) 497 | ((and (ob? source) 498 | (not (ty? source)) 499 | (ob? target) 500 | (not (ty? target))) 501 | (yloop (initial (compared-slot-indices nil) 502 | (target-slots (ob$pairs target)) 503 | (target-slot-index nil) 504 | (new-substit nil) 505 | (save-substit substit) 506 | (found? nil) 507 | (proc-result nil)) 508 | (yfor cur in (ob$pairs source)) ; was reverse 509 | (ywhile substit) 510 | (ydo (if (and (not (memq? (car cur) ignore-slots)) 511 | (not (memq? (car cur) *permanent-ignore-slots*))) 512 | (progn 513 | (setq target-slot-index 0) 514 | (setq new-substit nil) 515 | (setq found? nil) 516 | (yloop (yfor target-slot-value in target-slots) 517 | (yuntil found?) 518 | (ydo (if (and (eq? (car cur) (slots-name target-slot-value)) 519 | (not (memq? target-slot-index compared-slot-indices)) 520 | (setq new-substit (if (eq? (cadr cur) 521 | (slots-value target-slot-value)) 522 | substit 523 | (ob$compare1 (cadr cur) 524 | (slots-value 525 | target-slot-value) 526 | substit 527 | ignore-slots 528 | proc)))) 529 | (progn 530 | (setq found? t) 531 | (setq compared-slot-indices 532 | (cons target-slot-index 533 | compared-slot-indices)))) 534 | (increment-me target-slot-index))) 535 | (if found? 536 | (setq substit new-substit) 537 | (setq substit nil))))) 538 | (yresult (if (null? substit) 539 | (if (setq proc-result (funcall proc source target)) 540 | (cons 't (cons (list source target proc-result) 541 | (cdr save-substit))) 542 | nil) 543 | substit)))) 544 | ((and (ty? source) (ty? target)) 545 | (let ((proc-result (funcall proc source target))) 546 | (if proc-result 547 | (cons 't (cons (list source target proc-result) (cdr substit))) 548 | nil))) 549 | (else nil)))) 550 | (if result 551 | result 552 | (progn 553 | (bd-bind! source 554 | (delq! target (bd-lookup source *already-matched*)) 555 | *already-matched*) 556 | (bd-bind! target 557 | (delq! source (bd-lookup target *already-matched*)) 558 | *already-matched*) 559 | nil)))))) 560 | 561 | ; End of file. 562 | -------------------------------------------------------------------------------- /gate_utils.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; GATE 4 | ; Version 2.3 5 | ; 6 | ; Copyright 1984, 1985, 1986, 1987, 1988, 1999, 2004 Erik T. Mueller. 7 | ; All Rights Reserved. 8 | ; 9 | ; 10/13/84: A few utility functions and other initialization 10 | ; 1/6/86: Added new variable syntax 11 | ; 9/27/86: Removed flavors 12 | ; 13 | ;******************************************************************************* 14 | 15 | (defun make-typed-var (name) 16 | (cond 17 | ((eq? name *question-mark-atom*) 18 | (make-var nil nil)) 19 | ((eq? name 'self) 20 | (make-var name *person-ob*)) 21 | ((eq? name 'other) 22 | (make-var name *person-ob*)) 23 | (else (let* ((str (symbol->string name)) 24 | (len (string-length str)) 25 | (last-char (nthchar str (- len 1)))) 26 | (if (digit? last-char 10) 27 | (make-var name 28 | (ob$name->ob 29 | (string->symbol 30 | (string-slice str 0 (- len 1))))) 31 | (make-var name (ob$name->ob name))))))) 32 | 33 | (setq *bell-char* (ascii->char 7)) 34 | (setq *esc-char* (ascii->char 27)) 35 | (setq *del-char* (ascii->char 127)) 36 | (setq *cr-char* (ascii->char 13)) 37 | (setq *cntrl-z-char* (ascii->char 26)) 38 | (setq *cntrl-rb-char* (ascii->char 29)) 39 | 40 | (defun string-truncate (str len) 41 | (string-slice str 0 (min (string-length str) len))) 42 | 43 | ; 44 | ; NDBG: New Debugging Mechanism 45 | ; 46 | ; For use in the program: 47 | ; 48 | ; (ndbg-begin) - Start a new indentation level 49 | ; (ndbg-add-item rule) - Add item to list of current items 50 | ; (ndbg *dbg-stream* keyname "Message~%") - Print a debugging message 51 | ; (ndbg-remove-item rule) - Remove item to list of current items 52 | ; (ndbg-end) - End indentation level 53 | ; 54 | ; For use at debugging time: 55 | ; 56 | ; (interest 'keyname . items) - Show debugging info for keyname 57 | ; when any item is present in current items, or if an item 58 | ; is 'all, always 59 | ; (disinterest 'keyname . items) - Stop debugging info for keyname 60 | ; and items 61 | ; (interests) - Show current interests 62 | ; (ndbg-reset) - Reset indenting level back to zero 63 | ; 64 | 65 | (setq *ndbg-interests* nil) 66 | (setq *ndbg-level* 0) 67 | (setq *ndbg-items* nil) 68 | (setq *ndbg-indentation* 1) 69 | (setq *ndbg-max-indentation* 50) 70 | 71 | (defun ndbg-add-item (item) 72 | (setq *ndbg-items* (cons item *ndbg-items*))) 73 | 74 | (defun ndbg-remove-item (item) 75 | (setq *ndbg-items* (delq! item *ndbg-items*))) 76 | 77 | (defun ndbg-indentation (stream) 78 | (yloop (initial (cnt (min (* *ndbg-level* *ndbg-indentation*) 79 | *ndbg-max-indentation*))) 80 | (ywhile (> cnt 0)) 81 | (ydo (format stream " ") 82 | (setq cnt (- cnt 1))))) 83 | 84 | (defun ndbg-begin () 85 | (setq *ndbg-level* (+ *ndbg-level* 1))) 86 | 87 | (defun ndbg-end () 88 | (setq *ndbg-level* (- *ndbg-level* 1))) 89 | 90 | (defun ndbg-reset () (setq *ndbg-level* 0)) 91 | 92 | ; Use (interest 'unify ^rule) and (interest 'show ^rule) 93 | ; to get full debugging info for a rule. (And use disinterest 94 | ; to turn off). 95 | 96 | (defun interest (key &rest items) 97 | (let ((found (assq key *ndbg-interests*))) 98 | (if found 99 | (yloop (yfor item in items) 100 | (ydo (if (memq? item (cdr found)) 101 | (format *gate-output* 102 | "Item ~A key ~A already an interest~%" 103 | item key) 104 | (setf (cdr found) (cons item (cdr found)))))) 105 | (setq *ndbg-interests* (cons (cons key items) *ndbg-interests*))) 106 | (interests))) 107 | 108 | (defun disinterest (key &rest items) 109 | (let ((found (assq key *ndbg-interests*))) 110 | (if found 111 | (yloop (yfor item in items) 112 | (ydo (if (not (memq? item (cdr found))) 113 | (format *gate-output* 114 | "Item ~A key ~A not an interest~%" 115 | item key) 116 | (setf (cdr found) (delq! item (cdr found)))))) 117 | (format *gate-output* "Key ~A not found at all~%" key)) 118 | (interests))) 119 | 120 | (defun interests () *ndbg-interests*) 121 | (defun items () *ndbg-items*) 122 | 123 | (defun write-comments (comments stream) 124 | (let ((max-length (+ 2 (apply 'max 125 | (map 'list string-length comments))))) 126 | (write-dashes-stream max-length stream) 127 | (yloop (yfor comment1 in comments) 128 | (ydo (dbg stream " ~A~%" comment1))) 129 | (write-dashes-stream max-length stream))) 130 | 131 | (defun write-dashes-stream (number stream) 132 | (yloop (initial (count 1)) 133 | (ywhile (<= count number)) 134 | (ydo (format stream "-") 135 | (increment-me count))) 136 | (newline stream)) 137 | 138 | (defun new-filename (atm) 139 | (let* ((name (string-downcase! (symbol->string (gen-id atm)))) 140 | (filename (string-append "tmp." name))) 141 | (yloop 142 | (ywhile (file-exists? filename)) 143 | (ydo 144 | (dbg *gate-warn-dbg* "-") 145 | (setq filename (string-append filename "a"))) 146 | (yresult filename)))) 147 | 148 | (set-macro-character #\? 149 | (lambda (stream ch) 150 | (let ((read-in (read stream t nil t)) 151 | (colon-pos nil) 152 | (str nil)) 153 | (setq str (symbol->string read-in)) 154 | (cond 155 | ((setq colon-pos (string-posq #\+ str)) 156 | (ob$fcreate 157 | `(UAND 158 | obj (UPROC 159 | proc (QUOTE ,(string->symbol 160 | (string-append (nthchdr str (1+ colon-pos)) "?")))) 161 | obj ,(make-typed-var 162 | (string->symbol (substring str 0 colon-pos)))))) 163 | ((setq colon-pos (string-posq #\: str)) 164 | (if (= colon-pos 0) 165 | (make-var nil 166 | (ob$name->ob (string->symbol 167 | (nthchdr str (1+ colon-pos))))) ; e.g. for ?:person 168 | (make-var (string->symbol (substring str 0 colon-pos)) 169 | (ob$name->ob 170 | (string->symbol (nthchdr str (1+ colon-pos))))))) 171 | (else (make-typed-var read-in))))) 172 | t) 173 | 174 | (set-macro-character #\^ 175 | (lambda (stream ch) 176 | (let ((name (read stream t nil t)) 177 | (ob nil)) 178 | (setq ob (ob$name->ob name)) 179 | (if ob 180 | (list 'quote ob) 181 | (progn 182 | (format t "No such ob ^~A~%" name) 183 | (list 'quote *repl-wont-print*))))) 184 | t) 185 | 186 | (set-macro-character #\! 187 | (lambda (stream ch) 188 | (let ((name (read stream t nil t)) 189 | (ob nil)) 190 | (setq ob (ob$name->ob name)) 191 | (if ob 192 | (progn 193 | (po ob) 194 | (list 'quote *repl-wont-print*)) 195 | (progn (format t "No such ob ^~A~%" name) 196 | (list 'quote *repl-wont-print*))))) 197 | t) 198 | 199 | (defun interrogate (string) 200 | (format (standard-output) string) 201 | (let ((response (read (standard-input)))) 202 | (read-line (standard-input)) 203 | (cond ((or (eq? 'y response) 204 | (eq? 'yes response)) t) 205 | ((or (eq? 'n response) 206 | (eq? 'no response)) nil) 207 | (else (format (standard-output) 208 | "Please type 'y' or 'n' as a response.~%") 209 | (interrogate string))))) 210 | 211 | (defun arg-value (arg-name init-plist default) 212 | (let ((found (assq arg-name init-plist))) 213 | (if (and found (neq? (cadr found) 'none)) 214 | (cadr found) 215 | (if (eq? default 'required) 216 | (error "Required make-instance argument ~A not supplied" 217 | arg-name) 218 | default)))) 219 | 220 | (defun walk-append (proc lst) 221 | (yloop (initial (result nil)) 222 | (ywhile lst) 223 | (ydo (setq result (append! result (funcall proc (car lst)))) 224 | (setq lst (cdr lst))) 225 | (yresult result))) 226 | 227 | (defun with-default (val default) 228 | (if val val default)) 229 | 230 | (defun random-integer (from to) 231 | (cond ((= to from) to) 232 | ((< to from) (random-integer to from)) 233 | (else (+ from (random (1+ (- to from))))))) 234 | 235 | (defun random-element (x) 236 | (nth-elem x (random-integer 0 (-1+ (length x))))) 237 | 238 | (defun randomize (x) 239 | (yloop (initial (result nil) 240 | (elem nil)) 241 | (ywhile x) 242 | (ydo (setq elem (random-element x)) 243 | (setq x (delq elem x)) 244 | (setq result (cons elem result))) 245 | (yresult result))) 246 | 247 | (defun force-flonum (x) 248 | (if (flonum? x) x (fixnum->flonum x))) 249 | 250 | (defun random-real (from to) 251 | (setq *large-integer* (random-integer 4 20)) 252 | (cond ((= to from) to) 253 | ((< to from) (random-real to from)) 254 | (else 255 | (+ from 256 | (* (- to from) 257 | (/ (force-flonum (random-integer 0 *large-integer*)) 258 | (force-flonum *large-integer*))))))) 259 | 260 | ; End of file. 261 | -------------------------------------------------------------------------------- /hello_world.cl: -------------------------------------------------------------------------------- 1 | ;******************************************************************************* 2 | ; 3 | ; Sample use of Daydreamer 4 | ; 5 | ;******************************************************************************* 6 | 7 | ; Load Gate and Daydreamer. 8 | 9 | (setq *gate-load-options* '(sample)) 10 | (load "gate_get.cl") 11 | (load "dd_get.cl") 12 | 13 | ; Define types and objects. 14 | 15 | (ty$fcreate 'FILE '(OBJECT) '(name)) 16 | (ty$fcreate 'HACK '(NEED) '(strength)) 17 | (ty$fcreate 'FTP '(ACTION) '(actor obj)) 18 | (ob$fcreate '(FILE name "the Daydreamer source code" obname File1)) 19 | 20 | ; Define needs. 21 | 22 | (setq *needs* (list (ob$fcreate '(HACK)) (ob$fcreate '(ENTERTAINMENT)))) 23 | 24 | ; Define concern initiation, planning, and action effect rules. 25 | 26 | (define-rule Hack-Theme (sample) 27 | (RULE subgoal (UAND (HACK) (UPROC 'Less-Need-Thresh?)) 28 | goal (ACTIVE-GOAL (HACK strength (UPROC 'Need-Satisfied?))) 29 | is 'inference-only 30 | emotion (POS-EMOTION strength 0.6) 31 | inf-comments '(if "level of satisfaction of HACK need below" 32 | "threshold" 33 | then "ACTIVE-GOAL to HACK") 34 | plausibility 1.0)) 35 | 36 | (define-rule Hack-Plan (sample) 37 | (RULE subgoal (FTP actor ?Self obj File1) 38 | goal (HACK) 39 | plan-comments '(if "ACTIVE-GOAL to HACK" 40 | then "ACTIVE-GOAL to FTP Daydreamer source code") 41 | is 'plan-only 42 | plausibility 1.0)) 43 | 44 | (define-rule Ftp-Plan (sample) 45 | (RULE subgoal (RTRUE) 46 | goal (FTP actor ?Self obj ?File) 47 | plan-comments '(if "ACTIVE-GOAL to FTP" 48 | then "ACTIVE-GOAL for RTRUE") 49 | is 'action-plan 50 | plausibility 1.0)) 51 | 52 | ; Define English generation rules. 53 | 54 | (define-gen HACK nil 55 | (gen-need-obj con stream switches context bp 'hack " some code")) 56 | 57 | (define-gen FTP nil 58 | (let ((subject (ob$gets con 'actor))) 59 | (gen-subject subject stream switches context bp) 60 | (gen-verb 'download subject stream switches (neg? con)) 61 | (gen (ob$get con 'obj) stream switches context bp) 62 | subject)) 63 | 64 | ; Run Daydreamer. 65 | 66 | (daydreamer) 67 | -------------------------------------------------------------------------------- /inputemployment1.txt: -------------------------------------------------------------------------------- 1 | end 2 | end 3 | My boss fires me. 4 | end 5 | end 6 | end 7 | He gives me a newspaper. 8 | A job opening is listed in the newspaper. 9 | end 10 | end 11 | end 12 | end 13 | end 14 | He offers me a job. 15 | end 16 | -------------------------------------------------------------------------------- /inputlovers1.txt: -------------------------------------------------------------------------------- 1 | end 2 | Harrison Ford is at the Nuart. 3 | end 4 | end 5 | end 6 | He introduces himself to me. 7 | end 8 | end 9 | end 10 | He declines. 11 | end 12 | end 13 | end 14 | end 15 | end 16 | end 17 | end 18 | end 19 | end 20 | end 21 | end 22 | end 23 | end 24 | end 25 | end 26 | end 27 | end 28 | end 29 | end 30 | end 31 | end 32 | end 33 | end 34 | end 35 | end 36 | end 37 | end 38 | end 39 | end 40 | end 41 | end 42 | end 43 | end 44 | end 45 | end 46 | end 47 | end 48 | end 49 | end 50 | end 51 | end 52 | end 53 | end 54 | end 55 | end 56 | end 57 | end 58 | end 59 | end 60 | end 61 | end 62 | end 63 | end 64 | end 65 | end 66 | -------------------------------------------------------------------------------- /inputlovers2.txt: -------------------------------------------------------------------------------- 1 | Robert Redford is at UCLA shooting a film. 2 | end 3 | end 4 | -------------------------------------------------------------------------------- /inputlovers3.txt: -------------------------------------------------------------------------------- 1 | end 2 | A cute guy buys some Boston Lettuce. 3 | He smiles at me. 4 | end 5 | end 6 | end 7 | end 8 | Guy introduces himself to me. 9 | end 10 | end 11 | Guy accepts. 12 | Guy gives me his address. 13 | end 14 | He gives me groceries. 15 | end 16 | It is Friday night. 17 | end 18 | end 19 | Guy goes to Chan Dara. 20 | end 21 | end 22 | The waitor serves Guy. 23 | end 24 | The waitor serves me. 25 | end 26 | -------------------------------------------------------------------------------- /inputrecovery3.txt: -------------------------------------------------------------------------------- 1 | end 2 | end 3 | Carol Burnett went to UCLA. 4 | Carol's telephone number is in the Alumni directory. 5 | end 6 | end 7 | end 8 | end 9 | end 10 | end 11 | end 12 | end 13 | end 14 | end 15 | end 16 | end 17 | end 18 | end 19 | end 20 | end 21 | end 22 | end 23 | end 24 | end 25 | end 26 | end 27 | end 28 | end 29 | end 30 | end 31 | end 32 | end 33 | end 34 | end 35 | end 36 | end 37 | end 38 | end 39 | end 40 | end 41 | end 42 | end 43 | end 44 | end 45 | end 46 | end 47 | end 48 | end 49 | end 50 | end 51 | end 52 | end 53 | end 54 | end 55 | end 56 | end 57 | end 58 | end 59 | end 60 | end 61 | end 62 | end 63 | end 64 | end 65 | end 66 | end 67 | end 68 | end 69 | end 70 | end 71 | end 72 | end 73 | end 74 | end 75 | end 76 | end 77 | end 78 | end 79 | end 80 | end 81 | end 82 | end 83 | end 84 | end 85 | end 86 | end 87 | end 88 | end 89 | end 90 | end 91 | end 92 | end 93 | end 94 | end 95 | end 96 | end 97 | end 98 | end 99 | end 100 | end 101 | end 102 | end 103 | end 104 | end 105 | end 106 | end 107 | end 108 | end 109 | end 110 | -------------------------------------------------------------------------------- /outputhelloworld.txt: -------------------------------------------------------------------------------- 1 | ; International Allegro CL Trial Edition Port: 4292 Pid: 13131 2 | CL-USER> (load "hello_world") 3 | ; Loading /home/erik/programs/daydreamer/latest/hello_world.cl 4 | ; Loading /home/erik/programs/daydreamer/latest/gate_get.cl 5 | ======================= 6 | Loading GATE 2.3, Common Lisp version of 2004-12-20... 7 | ======================= 8 | ; Fast loading /home/erik/programs/daydreamer/latest/compat.fasl 9 | ; Fast loading /home/erik/programs/daydreamer/latest/loop.fasl 10 | ; Fast loading 11 | ; /home/erik/programs/daydreamer/latest/gate_macros.fasl 12 | ; Fast loading /home/erik/programs/daydreamer/latest/gate_main.fasl 13 | ; Fast loading /home/erik/programs/daydreamer/latest/gate_ty.fasl 14 | ; Fast loading /home/erik/programs/daydreamer/latest/gate_cx.fasl 15 | ; Fast loading 16 | ; /home/erik/programs/daydreamer/latest/gate_instan.fasl 17 | ; Fast loading /home/erik/programs/daydreamer/latest/gate_prove.fasl 18 | ; Fast loading 19 | ; /home/erik/programs/daydreamer/latest/gate_read_pr.fasl 20 | ; Fast loading /home/erik/programs/daydreamer/latest/gate_unify.fasl 21 | ; Fast loading /home/erik/programs/daydreamer/latest/gate_utils.fasl 22 | ; Loading /home/erik/programs/daydreamer/latest/gate_obs.cl 23 | ======================= 24 | Welcome to GATE 2.3, Common Lisp version of 2004-12-20 25 | ======================= 26 | ; Loading /home/erik/programs/daydreamer/latest/dd_get.cl 27 | ======================= 28 | Loading DAYDREAMER 3.5, Common Lisp version of 2004-12-20... 29 | ======================= 30 | ; Loading /home/erik/programs/daydreamer/latest/dd_macros.cl 31 | ; Fast loading /home/erik/programs/daydreamer/latest/dd_cntrl.fasl 32 | ; Fast loading /home/erik/programs/daydreamer/latest/dd_epis.fasl 33 | ; Fast loading 34 | ; /home/erik/programs/daydreamer/latest/dd_mutation.fasl 35 | ; Fast loading /home/erik/programs/daydreamer/latest/dd_night.fasl 36 | ; Fast loading 37 | ; /home/erik/programs/daydreamer/latest/dd_reversal.fasl 38 | ; Fast loading /home/erik/programs/daydreamer/latest/dd_ri.fasl 39 | ; Fast loading /home/erik/programs/daydreamer/latest/dd_rule1.fasl 40 | ; Fast loading /home/erik/programs/daydreamer/latest/dd_rule2.fasl 41 | ; Fast loading /home/erik/programs/daydreamer/latest/dd_utils.fasl 42 | ; Loading /home/erik/programs/daydreamer/latest/dd_kb.cl 43 | Warning: CONCRETE? is defined more than once as `operator' in file 44 | /home/erik/programs/daydreamer/latest/dd_kb.cl. 45 | ; Loading /home/erik/programs/daydreamer/latest/dd_gen.cl 46 | ======================= 47 | Welcome to DAYDREAMER 3.5, Common Lisp version of 2004-12-20 48 | ======================= 49 | Adding rule HACK-THEME 50 | Adding rule HACK-PLAN 51 | Adding rule FTP-PLAN 52 | DAYDREAMER 3.5, Common Lisp version of 2004-12-20 53 | Initialize DAYDREAMER 54 | Performing first-time initialization 55 | Creating primal reality... 56 | Assert #{OB.285: (ROMANTIC-INTEREST obj MOVIE-STAR1......)} in CX.3 57 | 58 | Creating initial reality context... 59 | #{CX.3: (CX)} --> #{CX.4: (CX)} 60 | Assert #{OB.1575: (HACK strength 0.1)} in CX.4 61 | Assert #{OB.1576: (ENTERTAINMENT strength 0.1......)} in CX.4 62 | State changes from SUSPENDED to DAYDREAMING 63 | Run inferences in #{CX.4: (CX)}, bp = (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 64 | ****************** 65 | HACK-THEME HACK-THEME fired as inference in CX.4 66 | ------------------------------------------------------- 67 | IF level of satisfaction of HACK need below 68 | threshold 69 | THEN ACTIVE-GOAL to HACK 70 | ------------------------------------------------------- 71 | 72 | ?SELF = #{ME: (FEMALE-PERSON first-name "Sarah"......)} 73 | ****************** 74 | Activate top-level goal #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} in #{CX.4: (CX)} 75 | Assert #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} in CX.4 76 | ================================================== 77 | I want to hack some code. 78 | ================================================== 79 | Add dependency from #{OB.1601: (POS-EMOTION strength 0.6)} to #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} in #{CX.4: (CX)} 80 | Assert #{OB.1602: (DEPENDENCY linked-from (POS-EMOTION...)......)} in CX.4 81 | Assert #{OB.1601: (POS-EMOTION strength 0.6)} in CX.4 82 | ================================================== 83 | I feel interested in hacking some code. 84 | ================================================== 85 | Personal goal concern OB.1599: HACK motiv 0.6 status RUNABLE 86 | Running emotion-driven control loop... 87 | :Switching to new top-level goal #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} 88 | ----------------------CX.4-------------------- 89 | Running rules for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} 90 | setting last sprout concept = #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} in #{CX.3: (CX)} 91 | Run inferences in #{CX.4: (CX)}, bp = (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 92 | Running p-goals in #{CX.4: (CX)} 93 | Running plans in #{CX.4: (CX)} for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} bp (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 94 | Run plan for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} in #{CX.4: (CX)} 95 | Try fact plans 96 | Try rules and episodes 97 | Find candidate rules for obj #{OB.1600: (HACK strength (UPROC proc ......))} in #{CX.4: (CX)} 98 | Order candidates ((#{HACK-PLAN: (RULE subgoal (FTP actor ?Self......)......)} 99 | (T 100 | (SELF 101 | #{ME: (FEMALE-PERSON first-name "Sarah"......)})))) 102 | Run generic plan #{HACK-PLAN: (RULE subgoal (FTP actor ?Self......)......)} for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} in #{CX.4: (CX)} 103 | #{CX.4: (CX)} --> #{CX.5: (CX)} 104 | Debugging being delayed for broadcast at a later time. 105 | HACK-PLAN Debugging resumed. 106 | Pruning possibilities from (#{CX.5: (CX)}) 107 | :----------------------CX.5-------------------- 108 | Running rules for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} 109 | setting last sprout concept = #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} in #{CX.4: (CX)} 110 | Broadcasting delayed debugs. 111 | ****************** 112 | HACK-PLAN fired as plan 113 | for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} 114 | in CX.4 sprouting CX.5 115 | ------------------------------------------------------- 116 | IF ACTIVE-GOAL to HACK 117 | THEN ACTIVE-GOAL to FTP Daydreamer source code 118 | ------------------------------------------------------- 119 | 120 | ?SELF = #{ME: (FEMALE-PERSON first-name "Sarah"......)} 121 | Assert #{OB.1609: (ORDERING)} in CX.5 122 | Instantiate and activate subgoals 123 | Activate subgoal for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} obj #{OB.1610: (FTP actor ME obj FILE1)} in #{CX.5: (CX)} 124 | Assert #{OB.1612: (INTENDS linked-from (ACTIVE-GOAL...)......)} in CX.5 125 | Assert #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} in CX.5 126 | ================================================== 127 | I have to download the Daydreamer source code. 128 | ================================================== 129 | End of delayed broadcast. 130 | Run inferences in #{CX.5: (CX)}, bp = (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 131 | Running p-goals in #{CX.5: (CX)} 132 | Running plans in #{CX.5: (CX)} for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} bp (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 133 | Run plan for #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} in #{CX.5: (CX)} 134 | Try rules and episodes 135 | Find candidate rules for obj #{OB.1610: (FTP actor ME obj FILE1)} in #{CX.5: (CX)} 136 | Order candidates ((#{FTP-PLAN: (RULE subgoal (RTRUE) goal ......)} 137 | (T 138 | (FILE 139 | #{FILE1: (FILE name "the Daydreamer source code"......)}) 140 | (SELF 141 | #{ME: (FEMALE-PERSON first-name "Sarah"......)})))) 142 | Run generic plan #{FTP-PLAN: (RULE subgoal (RTRUE) goal ......)} for #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} in #{CX.5: (CX)} 143 | #{CX.5: (CX)} --> #{CX.6: (CX)} 144 | Debugging being delayed for broadcast at a later time. 145 | FTP-PLAN Debugging resumed. 146 | Pruning possibilities from (#{CX.6: (CX)}) 147 | :----------------------CX.6-------------------- 148 | Running rules for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} 149 | setting last sprout concept = NIL in #{CX.5: (CX)} 150 | Broadcasting delayed debugs. 151 | ****************** 152 | FTP-PLAN fired as plan 153 | for #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} 154 | in CX.5 sprouting CX.6 155 | ------------------------------------------------------- 156 | IF ACTIVE-GOAL to FTP 157 | THEN ACTIVE-GOAL for RTRUE 158 | ------------------------------------------------------- 159 | 160 | ?FILE = #{FILE1: (FILE name "the Daydreamer source code"......)} 161 | ?SELF = #{ME: (FEMALE-PERSON first-name "Sarah"......)} 162 | Retract OB.1609 in CX.6 163 | Assert #{OB.1616: (ORDERING)} in CX.6 164 | Instantiate and activate subgoals 165 | Activate subgoal for #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} obj #{OB.1617: (RTRUE)} in #{CX.6: (CX)} 166 | Assert #{OB.1619: (INTENDS linked-from (ACTIVE-GOAL...)......)} in CX.6 167 | Assert #{OB.1618: (ACTIVE-GOAL obj (RTRUE) top-level-goal ......)} in CX.6 168 | End of delayed broadcast. 169 | ****************** 170 | Goal #{OB.1618: (ACTIVE-GOAL obj (RTRUE) top-level-goal ......)} succeeds in #{CX.6: (CX)} 171 | Retract OB.1618 in CX.6 172 | Assert #{OB.1620: (ACTIVE-GOAL obj (RTRUE))} in CX.6 173 | Retract OB.1619 in CX.6 174 | Assert #{OB.1622: (INTENDS linked-from (ACTIVE-GOAL...)......)} in CX.6 175 | Retract OB.1620 in CX.6 176 | Assert #{OB.1620: (SUCCEEDED-GOAL obj (RTRUE...)......)} in CX.6 177 | Subgoals of #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} completed 178 | About to perform real action but not in performance mode 179 | Change status of OB.1599: HACK to WAITINGRun inferences in #{CX.6: (CX)}, bp = (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 180 | :Taking optional object or concept input 181 | Enter concepts in #{CX.4: (CX)} 182 | Parser> 183 | end 184 | End of parser input 185 | No more goals to run; switching to performance mode 186 | Change status of OB.1599: HACK to RUNABLEState changes from DAYDREAMING to PERFORMANCE 187 | :----------------------CX.6-------------------- 188 | Running rules for #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} 189 | setting last sprout concept = NIL in #{CX.5: (CX)} 190 | Subgoals of #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} completed 191 | Perform external action 192 | Perform action goal #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} in #{CX.6: (CX)} 193 | ****************** 194 | Goal #{OB.1611: (ACTIVE-GOAL obj (FTP actor ......)......)} succeeds in #{CX.6: (CX)} 195 | Retract OB.1611 in CX.6 196 | Assert #{OB.1625: (ACTIVE-GOAL obj (FTP actor ......)......)} in CX.6 197 | Retract OB.1622 in CX.6 198 | Assert #{OB.1627: (INTENDS linked-from (ACTIVE-GOAL...)......)} in CX.6 199 | Retract OB.1612 in CX.6 200 | Assert #{OB.1628: (INTENDS linked-from (ACTIVE-GOAL...)......)} in CX.6 201 | Retract OB.1625 in CX.6 202 | Assert #{OB.1625: (SUCCEEDED-GOAL obj (FTP actor ......)......)} in CX.6 203 | Assert #{OB.1626: (FTP actor ME obj FILE1)} in CX.6 204 | ================================================== 205 | I download the Daydreamer source code. 206 | ================================================== 207 | Run inferences in #{CX.6: (CX)}, bp = (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 208 | Taking optional concept input 209 | Enter concepts in #{CX.6: (CX)} 210 | Parser> 211 | end 212 | End of parser input 213 | Subgoals of #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} completed 214 | ****************** 215 | Goal #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} succeeds in #{CX.6: (CX)} 216 | Replace obj of #{OB.1599: (ACTIVE-GOAL obj (HACK strength ......)......)} with (T) 217 | Retract OB.1599 in CX.6 218 | Assert #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} in CX.6 219 | ================================================== 220 | I succeed at hacking some code. 221 | ================================================== 222 | Assert #{OB.1631: (HACK strength 1.0)} in CX.6 223 | ================================================== 224 | I hack some code. 225 | ================================================== 226 | Run inferences in #{CX.6: (CX)}, bp = (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 227 | Running p-goals in #{CX.6: (CX)} 228 | Running plans in #{CX.6: (CX)} for #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} bp (#{ME: (FEMALE-PERSON first-name "Sarah"......)}) 229 | Terminating planning for top-level goal #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} 230 | Leaf context #{CX.6: (CX)} 231 | [OB.1599: (SG. (HACK strength 1.0))] 232 | [OB.1625: (SG. (FTP actor ME obj FILE1))] 233 | [OB.1620: (SG. (RTRUE))] 234 | Removing motivating emotions of #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} in #{CX.6: (CX)} 235 | Retract OB.1602 in CX.6 236 | Retract OB.1601 in CX.6 237 | Emotional responses for #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} in #{CX.6: (CX)} 238 | Add dependency from #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} to #{OB.1634: (POS-EMOTION)} in #{CX.6: (CX)} 239 | Assert #{OB.1635: (DEPENDENCY linked-from (SUCCEEDED-GOAL...)......)} in CX.6 240 | Assert #{OB.1634: (POS-EMOTION strength 0.6)} in CX.6 241 | ================================================== 242 | I feel pleased about hacking some code. 243 | ================================================== 244 | Store episode #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} in #{CX.6: (CX)} 245 | Assess scenario desirability in #{CX.6: (CX)} 246 | #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} (0.6) 247 | Scenario desirability = 0.6 248 | Store goal of episode #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)}, realism 1.0 249 | Store goal of episode #{OB.1625: (SUCCEEDED-GOAL obj (FTP actor ......)......)}, realism 1.0 250 | Store goal of episode #{OB.1620: (SUCCEEDED-GOAL obj (RTRUE...)......)}, realism 1.0 251 | Make episode for goal #{OB.1625: (SUCCEEDED-GOAL obj (FTP actor ......)......)} 252 | Storing #{EPISODE.1: (EPISODE rule FTP-PLAN goal ......)} under #{FTP-PLAN: (RULE subgoal (RTRUE) goal ......)} 253 | Make episode for goal #{OB.1599: (SUCCEEDED-GOAL obj (HACK strength ......)......)} 254 | Storing #{EPISODE.2: (EPISODE rule HACK-PLAN goal ......)} under #{HACK-PLAN: (RULE subgoal (FTP actor ?Self......)......)} 255 | Storing #{EPISODE.2: (EPISODE rule HACK-PLAN goal ......)} under #{OB.1634: (POS-EMOTION strength 0.6)} 256 | Assert #{OB.1634: (POS-EMOTION strength 0.6)} in EPISODIC-MEMORY 257 | Storing #{EPISODE.2: (EPISODE rule HACK-PLAN goal ......)} under #{FILE1: (FILE name "the Daydreamer source code"......)} 258 | Assert #{FILE1: (FILE name "the Daydreamer source code"......)} in EPISODIC-MEMORY 259 | Activate index #{HACK-PLAN: (RULE subgoal (FTP actor ?Self......)......)} 260 | Activate index #{FILE1: (FILE name "the Daydreamer source code"......)} 261 | #{CX.6: (CX)} --> #{CX.7: (CX)} 262 | Retract OB.1620 in CX.7 263 | Retract OB.1627 in CX.7 264 | Retract OB.1625 in CX.7 265 | Retract OB.1628 in CX.7 266 | :No more goals to run; switching to daydreaming mode 267 | State changes from PERFORMANCE to DAYDREAMING 268 | :Taking optional object or concept input 269 | Enter concepts in #{CX.7: (CX)} 270 | Parser> 271 | end 272 | End of parser input 273 | No more goals to run; switching to performance mode 274 | State changes from DAYDREAMING to PERFORMANCE 275 | :No more goals to run; switching to daydreaming mode 276 | State changes from PERFORMANCE to DAYDREAMING 277 | DAYDREAMER terminates 278 | T 279 | CL-USER> -------------------------------------------------------------------------------- /outputtest.txt: -------------------------------------------------------------------------------- 1 | ; International Allegro CL Trial Edition Port: 3033 Pid: 10792 2 | CL-USER> (load "gate_test") 3 | ; Loading /home/erik/daydreamer3.5/gate_test.cl 4 | ; Loading /home/erik/daydreamer3.5/gate_get.cl 5 | ======================= 6 | Loading GATE 2.3, Common Lisp version of 2004-12-20... 7 | ======================= 8 | ; Fast loading /home/erik/daydreamer3.5/compat.fasl 9 | ; Fast loading /home/erik/daydreamer3.5/loop.fasl 10 | ; Fast loading /home/erik/daydreamer3.5/gate_macros.fasl 11 | ; Fast loading /home/erik/daydreamer3.5/gate_main.fasl 12 | ; Fast loading /home/erik/daydreamer3.5/gate_ty.fasl 13 | ; Fast loading /home/erik/daydreamer3.5/gate_cx.fasl 14 | ; Fast loading /home/erik/daydreamer3.5/gate_instan.fasl 15 | ; Fast loading /home/erik/daydreamer3.5/gate_prove.fasl 16 | ; Fast loading /home/erik/daydreamer3.5/gate_read_pr.fasl 17 | ; Fast loading /home/erik/daydreamer3.5/gate_unify.fasl 18 | ; Fast loading /home/erik/daydreamer3.5/gate_utils.fasl 19 | ; Loading /home/erik/daydreamer3.5/gate_obs.cl 20 | ======================= 21 | Welcome to GATE 2.3, Common Lisp version of 2004-12-20 22 | ======================= 23 | SUCCEEDED (TY$FCREATE 'PERSON NIL '(NAME AGE OCCUPATION)) 24 | SUCCEEDED (OB$FCREATE '(PERSON NAME Karen AGE 27 OCCUPATION 'DOCTOR 25 | OBNAME KAREN1)) 26 | SUCCEEDED (OB$FCREATE '(PERSON NAME Jim AGE 31 OCCUPATION 'COMPOSER 27 | OBNAME JIM1)) 28 | SUCCEEDED '#{KAREN1: (PERSON name "Karen" age 27......)} 29 | SUCCEEDED '#{JIM1: (PERSON name "Jim" age 31 occupation ......)} 30 | SUCCEEDED (OB$GET '#{KAREN1: (PERSON name "Karen" age 27......)} 'NAME) 31 | SUCCEEDED (OB$GET '#{JIM1: (PERSON name "Jim" age 31 occupation ......)} 32 | 'AGE) 33 | SUCCEEDED (OB$GET '#{JIM1: (PERSON name "Jim" age 31 occupation ......)} 34 | 'OCCUPATION) 35 | SUCCEEDED (OB$SET '#{JIM1: (PERSON name "Jim" age 32 occupation ......)} 36 | 'AGE 32) 37 | SUCCEEDED (OB$GET '#{JIM1: (PERSON name "Jim" age 32 occupation ......)} 38 | 'AGE) 39 | SUCCEEDED (TY$FCREATE 'ACTION NIL '(ACTOR FROM TO OBJ)) 40 | SUCCEEDED (TY$FCREATE 'STATE NIL NIL) 41 | SUCCEEDED (TY$FCREATE 'ATRANS '(ACTION) '(ACTOR FROM TO OBJ)) 42 | SUCCEEDED (TY$FCREATE 'MTRANS '(ACTION) '(ACTOR FROM TO OBJ)) 43 | SUCCEEDED (TY$FCREATE 'PTRANS '(ACTION) '(ACTOR FROM TO OBJ)) 44 | SUCCEEDED (TY$FCREATE 'LIVES-IN '(STATE) '(ACTOR LOC)) 45 | SUCCEEDED (TY$FCREATE 'MAGAZINE NIL '(NAME)) 46 | SUCCEEDED (OB$FCREATE '(ATRANS ACTOR JIM1 FROM JIM1 TO KAREN1 OBJ 47 | (MAGAZINE NAME Ear Magazine) OBNAME ATRANS1)) 48 | SUCCEEDED (OB$FCREATE '(PERSON NAME Peter AGE 26 OCCUPATION 'MUSICIAN 49 | OBNAME PETER1)) 50 | SUCCEEDED (OB$FCREATE '(MTRANS ACTOR JIM1 FROM JIM1 TO PETER1 OBJ 51 | ATRANS1 OBNAME MTRANS1)) 52 | SUCCEEDED (TY$INSTANCE? '#{ATRANS1: (ATRANS actor JIM1 from JIM1......)} 53 | 'ACTION) 54 | SUCCEEDED (TY$INSTANCE? '#{ATRANS1: (ATRANS actor JIM1 from JIM1......)} 55 | 'ATRANS) 56 | SUCCEEDED (TY$INSTANCE? '#{ATRANS1: (ATRANS actor JIM1 from JIM1......)} 57 | 'MTRANS) 58 | SUCCEEDED (TY$INSTANCE? '#{ATRANS1: (ATRANS actor JIM1 from JIM1......)} 59 | 'PERSON) 60 | SUCCEEDED (TY$INSTANCE? '#{MTRANS1: (MTRANS actor JIM1 from JIM1......)} 61 | 'MTRANS) 62 | SUCCEEDED (SETQ BD 63 | (OB$UNIFY PATTERN 64 | '#{MTRANS1: (MTRANS actor JIM1 from JIM1......)} 65 | *EMPTY-BD*)) 66 | SUCCEEDED (OB->LIST (OB$INSTANTIATE PATTERN BD)) 67 | SUCCEEDED (TY$FCREATE 'POSS '(STATE) '(ACTOR OBJ)) 68 | SUCCEEDED (TY$FCREATE 'INFERENCE NIL '(IF THEN)) 69 | SUCCEEDED (OB->LIST (CAR (FORWARD-INFERENCES '#{ATRANS1: (ATRANS actor JIM1 from JIM1......)}))) 70 | SUCCEEDED (TY$FCREATE 'LOCATION NIL 'NIL) 71 | SUCCEEDED (TY$FCREATE 'STORE '(LOCATION) 'NIL) 72 | SUCCEEDED (OB$FCREATE '(STORE OBNAME STORE1)) 73 | SUCCEEDED (TY$FCREATE 'PROX '(STATE) '(ACTOR LOC)) 74 | SUCCEEDED (OB->LIST (OB$PROVE (OB$FCREATE '(PROX 75 | ACTOR 76 | #{OB.77: ?PERSON:PERSON} 77 | LOC 78 | STORE1)) 79 | *EMPTY-BD* 999)) 80 | SUCCEEDED (OB->LIST (OB$PROVE1 (OB$FCREATE 81 | '(GRANDFATHER-OF 82 | ACTOR 83 | SCHANK 84 | OBJ 85 | DYER)) 86 | *EMPTY-BD* 10 *PRULES* *PFACTS* NIL)) 87 | SUCCEEDED (OB->LIST (OB$PROVE1 (OB$FCREATE 88 | '(GRANDFATHER-OF 89 | ACTOR 90 | SCHANK 91 | OBJ 92 | #{OB.134: ?PERSON:PERSON})) 93 | *EMPTY-BD* 10 *PRULES* *PFACTS* NIL)) 94 | 37 of 37 tests succeeded. 95 | T 96 | CL-USER> --------------------------------------------------------------------------------