├── .gitattributes ├── .gitignore ├── CHANGELOG.md ├── Haskell-LICENSE.txt ├── LICENSE.txt ├── Makefile ├── README-forbus-dekleer.txt ├── README.md ├── Setup.hs ├── build.sbt ├── misc └── reddit-2022apr21.txt ├── package.yaml ├── project ├── build.properties └── plugins.sbt ├── rootdoc.txt ├── src ├── main │ ├── haskell │ │ ├── app │ │ │ ├── ATMSTrun.hs │ │ │ ├── JTMSrun.hs │ │ │ └── Main.hs │ │ ├── lib │ │ │ └── Data │ │ │ │ └── TMS │ │ │ │ ├── ATMS │ │ │ │ └── ATMST.hs │ │ │ │ ├── ChooseDebugging.hs │ │ │ │ ├── Dbg.hs │ │ │ │ ├── Formatters.hs │ │ │ │ ├── Helpers.hs │ │ │ │ ├── JTMS.hs │ │ │ │ └── MList.hs │ │ └── prof │ │ │ ├── ATMSTrun.hs │ │ │ ├── JTMSrun.hs │ │ │ └── Main.hs │ ├── lisp │ │ ├── atms │ │ │ ├── adata.lisp │ │ │ ├── ainter.lisp │ │ │ ├── aplanr.lisp │ │ │ ├── aqueens.lisp │ │ │ ├── arules.lisp │ │ │ ├── atest.lisp │ │ │ ├── atms.asd │ │ │ ├── atms.lisp │ │ │ ├── atre.lisp │ │ │ ├── atret.lisp │ │ │ ├── bcode.lisp │ │ │ ├── blocks.lisp │ │ │ ├── causality-ex.lisp │ │ │ ├── causality.lisp │ │ │ ├── csp.lisp │ │ │ ├── funify.lisp │ │ │ ├── id.lisp │ │ │ ├── interactive-ex.lisp │ │ │ ├── my.lisp │ │ │ ├── plan-a.lisp │ │ │ ├── plan-e.lisp │ │ │ ├── prob.lisp │ │ │ ├── sudoku.lisp │ │ │ └── unify.lisp │ │ ├── cps │ │ │ ├── algebra.lisp │ │ │ ├── boston.lisp │ │ │ ├── cps.lisp │ │ │ ├── match.lisp │ │ │ ├── search.lisp │ │ │ ├── simplify.lisp │ │ │ ├── subways.lisp │ │ │ └── variants.lisp │ │ ├── ftre │ │ │ ├── fdata.lisp │ │ │ ├── finter.lisp │ │ │ ├── fnd-ex.lisp │ │ │ ├── fnd.lisp │ │ │ ├── fqrule.lisp │ │ │ ├── fqueens.lsp │ │ │ ├── frules.lisp │ │ │ ├── ftre.lisp │ │ │ ├── funify.lisp │ │ │ └── unify.lisp │ │ ├── gde │ │ │ ├── 2bit.txt │ │ │ ├── atcon.lisp │ │ │ ├── condef.lisp │ │ │ ├── diagrams.lisp │ │ │ ├── gde.lisp │ │ │ └── polyex.txt │ │ ├── jtms │ │ │ ├── bms-ex.rkt │ │ │ ├── bms.rkt │ │ │ ├── carnival-load.lisp │ │ │ ├── carnival.lisp │ │ │ ├── dds.lisp │ │ │ ├── funify.lisp │ │ │ ├── funify.rkt │ │ │ ├── jbms-ex.rkt │ │ │ ├── jdata.lisp │ │ │ ├── jinter.lisp │ │ │ ├── jqrule.lisp │ │ │ ├── jqueens.lisp │ │ │ ├── jqueens.rkt │ │ │ ├── jrules.lisp │ │ │ ├── jsaint-rules.rkt │ │ │ ├── jsaint.lisp │ │ │ ├── jsaint.rkt │ │ │ ├── jsops.lisp │ │ │ ├── jsrules.lisp │ │ │ ├── jtest.lisp │ │ │ ├── jtest.rkt │ │ │ ├── jtms-ex.lisp │ │ │ ├── jtms-ex.rkt │ │ │ ├── jtms.lisp │ │ │ ├── jtms.rkt │ │ │ ├── jtre.lisp │ │ │ ├── jtre.rkt │ │ │ ├── logic.rkt │ │ │ ├── match.lisp │ │ │ ├── match.rkt │ │ │ ├── my.lisp │ │ │ ├── simplify.lisp │ │ │ ├── simplify.rkt │ │ │ ├── sudoku-rule.lisp │ │ │ ├── sudoku.lisp │ │ │ ├── tinytms-ex.rkt │ │ │ ├── tinytms.rkt │ │ │ ├── unify.lisp │ │ │ ├── unify.rkt │ │ │ └── utils.rkt │ │ ├── ltms │ │ │ ├── abduction-ex.lisp │ │ │ ├── abduction-simple.lisp │ │ │ ├── abduction.lisp │ │ │ ├── carnival-ex.dot │ │ │ ├── carnival-ex.lisp │ │ │ ├── carnival-ex.png │ │ │ ├── carnival-from-dot.py │ │ │ ├── carnival-load.lisp │ │ │ ├── carnival-ltre.lisp │ │ │ ├── carnival-play.lisp │ │ │ ├── carnival-test.dot │ │ │ ├── carnival-test.lisp │ │ │ ├── carnival-test.png │ │ │ ├── carnival.lisp │ │ │ ├── cltms.lisp │ │ │ ├── counterfactual.lisp │ │ │ ├── cwa.lisp │ │ │ ├── dds.lisp │ │ │ ├── explain.lisp │ │ │ ├── forward-abduction.lisp │ │ │ ├── funify.lisp │ │ │ ├── indirect.lisp │ │ │ ├── interactive-ex.lisp │ │ │ ├── laccept.lisp │ │ │ ├── ldata.lisp │ │ │ ├── linter.lisp │ │ │ ├── lrules.lisp │ │ │ ├── ltms-ex.lisp │ │ │ ├── ltms.lisp │ │ │ ├── ltre.lisp │ │ │ ├── marx.lisp │ │ │ ├── marxdata.lisp │ │ │ ├── my.lisp │ │ │ ├── setrule.lisp │ │ │ ├── sudoku.lisp │ │ │ └── unify.lisp │ │ ├── relax │ │ │ ├── allen.lisp │ │ │ ├── cube.lisp │ │ │ ├── jcatalog.lisp │ │ │ ├── scene.lisp │ │ │ ├── stack.lisp │ │ │ ├── timedb.lisp │ │ │ ├── waltzer.lisp │ │ │ └── wedge.lisp │ │ ├── tcon │ │ │ ├── condef.lisp │ │ │ ├── debug.lisp │ │ │ ├── intex.txt │ │ │ ├── motion.lisp │ │ │ ├── polybox.lisp │ │ │ ├── suspend.lisp │ │ │ └── tcon.lisp │ │ ├── tgizmo │ │ │ ├── debug.lisp │ │ │ ├── defs.lisp │ │ │ ├── ex1.lisp │ │ │ ├── ex2.lisp │ │ │ ├── ex3.lisp │ │ │ ├── ex4.lisp │ │ │ ├── ex5.lisp │ │ │ ├── ex6.lisp │ │ │ ├── ex7.lisp │ │ │ ├── ineqs.lisp │ │ │ ├── laws.lisp │ │ │ ├── mi.lisp │ │ │ ├── mlang.lisp │ │ │ ├── psvs.lisp │ │ │ ├── resolve.lisp │ │ │ ├── states.lisp │ │ │ ├── tgizmo.lisp │ │ │ └── tnst.lisp │ │ ├── tre │ │ │ ├── data.lisp │ │ │ ├── rules.lisp │ │ │ ├── tinter.lisp │ │ │ ├── tre.lisp │ │ │ ├── treex1.lisp │ │ │ └── unify.lisp │ │ └── utils │ │ │ ├── loader.lisp │ │ │ └── lst.lisp │ └── scala │ │ ├── assumptionbased │ │ ├── ATMS.scala │ │ ├── Blurbs.scala │ │ ├── Env.scala │ │ ├── Just.scala │ │ ├── Node.scala │ │ ├── Runners.scala │ │ └── ruleengine │ │ │ ├── Datum.scala-x │ │ │ ├── DbClass.scala-x │ │ │ ├── Rule.scala-x │ │ │ ├── adata.lisp │ │ │ ├── aplanr.lisp │ │ │ ├── aqueens.lisp │ │ │ ├── arules.lisp │ │ │ ├── atest.lisp │ │ │ ├── atre.lisp │ │ │ ├── atret.lisp │ │ │ ├── bcode.lisp │ │ │ ├── blocks.lisp │ │ │ ├── causality-ex.lisp │ │ │ ├── causality.lisp │ │ │ ├── csp.lisp │ │ │ ├── funify.lisp │ │ │ ├── id.lisp │ │ │ ├── interactive-ex.lisp │ │ │ ├── my.lisp │ │ │ ├── plan-a.lisp │ │ │ ├── plan-e.lisp │ │ │ ├── prob.lisp │ │ │ ├── sudoku.lisp │ │ │ └── unify.lisp │ │ ├── justificationbased │ │ ├── JTMS.scala │ │ ├── Just.scala │ │ ├── Node.scala │ │ └── ruleengine │ │ │ ├── Datum.scala │ │ │ ├── DbClass.scala │ │ │ ├── JTMS.scala-x │ │ │ ├── JTRE.scala │ │ │ ├── Just.scala-x │ │ │ ├── Node.scala-x │ │ │ └── Rule.scala │ │ ├── random │ │ ├── AtmsMaker.scala │ │ ├── Maker.scala │ │ └── NOTES.txt │ │ └── utils │ │ └── Printing.scala └── test │ ├── haskell │ ├── ATMSTests.hs │ ├── JTMSTests.hs │ ├── Spec.hs │ └── Testers.hs │ └── scala │ ├── atmstests │ └── TestATMS.scala │ └── jtmstests │ ├── JtmsCoreEx1.scala │ ├── JtmsCoreEx2.scala │ ├── JtmsCoreEx3.scala │ ├── Utils.scala │ └── ruleengine │ ├── JtmsCoreEx1.scala │ ├── JtmsCoreEx2.scala │ ├── JtmsCoreEx3.scala │ └── Utils.scala ├── stack-profile ├── stack-running ├── stack-testing └── stack.yaml /.gitattributes: -------------------------------------------------------------------------------- 1 | *.lisp linguist-detectable=false 2 | *.rkt linguist-detectable=false 3 | *.py linguist-detectable=false 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.class 2 | *.log 3 | .bsp 4 | project/target 5 | target 6 | .stack-work 7 | BPS.cabal 8 | stack.yaml.lock 9 | .bloop/ 10 | .metals/ 11 | project/.bloop/ 12 | project/metals.sbt 13 | project/project/ 14 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | Note that the *repository* version numbers do not directly correspond 3 | to the release numbers of either the Haskell or Scala releases. 4 | Haskell releases adhere to Haskell's [Package Versioning 5 | Policy](https://pvp.haskell.org/); Scala releases use the [Semantic 6 | Versioning spec](https://semver.org/). 7 | 8 | # Version 0.6.0 (Haskell 0.1.1.0, Scala 0.1.0) 9 | 10 | - Added `interpretations` in Haskell implementation. Only lighted 11 | tested at this point. 12 | 13 | # Version 0.5.0 (Haskell 0.1.0.0, Scala 0.1.0) 14 | 15 | - First version with Haskell: working implementation of a monad 16 | transformer for the JTMS and ATMS. The `interpretations` and 17 | `explain-node` functions of the ATMS are not yet translated, and 18 | are omitted from the module API. 19 | 20 | - Promoting Scala release to 0.1.0. No significant additions, but it 21 | will be nice to distinguish new feature additions at 0.x.0 from 22 | patches and documentation additions at 0.x.y. 23 | 24 | # Version 0.4.0 (Scala only, 0.0.4) 25 | 26 | - Documentation for both JTMS and ATMS. 27 | 28 | - Generator for large randomized ATMS examples. 29 | 30 | - Some tweaks to data structure selection based on rough profiling. 31 | 32 | # Version 0.3.0 (Scala only, 0.0.3) 33 | 34 | - Contains a mostly-working version of a standalone ATMS. 35 | 36 | # Version 0.2.0 (Scala only, 0.0.2) 37 | 38 | - Separation of the standalone JTMS from (untranslated) JTMS+JTRE 39 | wrapper. 40 | 41 | - Further testing and debugging of the standalone JTMS. 42 | 43 | - Scaladoc documentation of the standalone JTMS. 44 | 45 | - There may be additional type parameters in later versions of 46 | the standalone JTMS. 47 | 48 | - First version containing this file. 49 | 50 | # Version 0.1.0 (Scala only, 0.0.1) 51 | 52 | Initial release 53 | 54 | - Contains a mostly-working version of the standalone JTMS. 55 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: JTMS-hs.ps 3 | # 4 | 5 | JTMS-hs.ps: src/main/haskell/lib/Data/TMS/JTMS.hs 6 | a2ps -2r -o $@ $< 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Truth maintenance system libraries for Scala and Haskell 2 | 3 | This repository is a translation from Common Lisp of the truth 4 | maintenance systems and other tools from Forbus and de Kleer's 5 | *Building Problem Solvers* into both Scala and Haskell. 6 | 7 | The current version includes working versions of the justification- 8 | and assumption-based truth maintenance systems (JTMS and ATMS) in both 9 | languages. The Haskell translation omits the two top-level function 10 | of the original system, but otherwise both translations include all of 11 | the original functionality of these two TMSes. There is a partial 12 | translation of the rule engine wrapper for these TMSes in Scala. 13 | 14 | To contribute, submit pull requests to one of the three branches 15 | `atms` (Scala), `jtms` (Scala) or `haskell` (both JTMS and ATMS), or 16 | start a new branch for one of the other BPS tools, at 17 | [its repository](https://github.com/jphmrst/bps-scala). 18 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /build.sbt: -------------------------------------------------------------------------------- 1 | 2 | val scala3Version = "3.1.0" 3 | 4 | // library name 5 | name := "bps-scala" 6 | 7 | // library version 8 | version := "0.1.0" 9 | 10 | ///////////////////////////////////////////////////////////////// 11 | // This section activates scala-native 12 | 13 | // // Set to false or remove if you want to show stubs as linking errors 14 | // nativeLinkStubs := false 15 | // // 16 | // enablePlugins(ScalaNativePlugin) 17 | 18 | ///////////////////////////////////////////////////////////////// 19 | // begin maven etc. publishing information 20 | 21 | // groupId, SCM, license information 22 | organization := "org.maraist" 23 | homepage := Some(url("https://github.com/jphmrst/bps-scala")) 24 | scmInfo := Some(ScmInfo( 25 | url("https://github.com/jphmrst/bps-scala"), 26 | "git@github.com:jphmrst/bps-scala.git")) 27 | developers := List(Developer( 28 | "jphmrst", "jphmrst", "via-github@maraist.org", 29 | url("https://maraist.org/work/"))) 30 | licenses += ( 31 | "Educational", 32 | url("https://github.com/jphmrst/bps-scala/blob/master/LICENSE.txt")) 33 | 34 | // add sonatype repository settings 35 | // snapshot versions publish to sonatype snapshot repository 36 | // other versions publish to sonatype staging repository 37 | pomIncludeRepository := { _ => false } 38 | val nexus = "https://s01.oss.sonatype.org/" 39 | publishTo := { 40 | if (isSnapshot.value) 41 | Some("snapshots" at nexus + "content/repositories/snapshots") 42 | else 43 | Some("releases" at nexus + "service/local/staging/deploy/maven2") 44 | } 45 | publishMavenStyle := true 46 | 47 | ThisBuild / versionScheme := Some("semver-spec") 48 | 49 | // end of maven etc. publishing section 50 | ///////////////////////////////////////////////////////////////// 51 | 52 | Global / excludeLintKeys ++= Set(scalacOptions) 53 | Compile / doc / scalacOptions ++= Seq( 54 | "-groups", 55 | "-doc-root-content", "rootdoc.txt" 56 | ) 57 | 58 | lazy val main = project 59 | .in(file(".")) 60 | .settings( 61 | scalaVersion := scala3Version, 62 | libraryDependencies ++= Seq( 63 | "org.scalactic" %% "scalactic" % "3.2.9", 64 | "org.scalatest" %% "scalatest" % "3.2.9" % "test" 65 | ), 66 | compile / watchTriggers += baseDirectory.value.toGlob / "build.sbt", 67 | unmanagedSources / excludeFilter := ".#*", 68 | scalacOptions ++= Seq( "-source:future-migration" ), 69 | ) 70 | 71 | -------------------------------------------------------------------------------- /misc/reddit-2022apr21.txt: -------------------------------------------------------------------------------- 1 | 2 | [ANN] Haskell translations of Truth Maintenance System algorithms 3 | 4 | I've made a small library with implementations of two Truth Maintenance System available on Hackage and Github. They are translations of Forbus and de Kleer's justification-based and assumption-based (JTMS and ATMS) algorithms. 5 | 6 | TMS algorithms are classic AI approaches to reasoning about logical implication relationships. Code using a TMS defines /nodes/ representing sentences or logical ideas, and how some nodes can be used to conclude other nodes. We can also identify "nogood" or contradictory sets of nodes. Some nodes are distinguished as /assumptions/, and the TMS lets us reason about how the belief or disbelief in each assumption impacts whether we should also believe or disbelieve other nodes. 7 | 8 | - In the JTMS, the believe/disbelieve setting for each assumption is set directly, and the JTMS maintains the believe/disbelieve status of each node based on the current assumption beliefs. 9 | 10 | - In the ATMS, there is no setting of "current" beliefs. Instead, the ATMS tracks the minimal consistent sets of assumptions which justify belief in each node. 11 | 12 | Please do not look for beautiful and pure functional algorithms here! At this point the implementations are direct translations of the original imperative Common Lisp implementations, implemented as a monad transformer, and using `STT`. A non-stateful re-implementation remains an interesting idea for the (non-short-term) future! I wrote this library to give myself a bit more insight into how this algorithm work on the inside, and some deeper practice with the state thread libraries than I'd had before, but I hope you find them interesting or useful! 13 | 14 | Hackage, https://hackage.haskell.org/package/BPS 15 | 16 | Github, https://hackage.haskell.org/package/BPS 17 | 18 | Wikipedia entry on reason maintenance, https://en.wikipedia.org/wiki/Reason_maintenance 19 | 20 | A standard reference on the subject, probably available at a library near you, https://mitpress.mit.edu/books/building-problem-solvers 21 | -------------------------------------------------------------------------------- /project/build.properties: -------------------------------------------------------------------------------- 1 | sbt.version=1.6.0 2 | # sbt.version=1.5.5 3 | -------------------------------------------------------------------------------- /project/plugins.sbt: -------------------------------------------------------------------------------- 1 | addSbtPlugin("org.scala-native" % "sbt-scala-native" % "0.4.3-RC1") 2 | -------------------------------------------------------------------------------- /rootdoc.txt: -------------------------------------------------------------------------------- 1 | 2 | Scala translations of Forbus and de Kleer's implementations of 3 | truth-maintenance systems and other code from their *Building Problem 4 | Solvers* book. 5 | 6 | Curently there are two working translations: 7 | 8 | - Standalone justification-based truth maintenence systems. 9 | 10 | - Standalone assumption-based truth maintenence systems. 11 | 12 | There are partial/in-progress translations of combined justification- 13 | and assumption-based truth maintenence systems and rule engines (in 14 | the `jtms` and `atms` branches of the repository). 15 | -------------------------------------------------------------------------------- /src/main/haskell/app/JTMSrun.hs: -------------------------------------------------------------------------------- 1 | module JTMSrun where 2 | 3 | import Data.Symbol 4 | import Data.TMS.JTMS 5 | import Control.Monad.IO.Class 6 | 7 | runJTMS1 :: IO (Either JtmsErr ()) 8 | runJTMS1 = runJTMST $ do 9 | j <- createJTMS "Ex1" 10 | na <- createNode j (intern "a") True False 11 | naName <- nodeString na 12 | naIn <- isInNode na 13 | liftIO $ putStrLn $ 14 | "Node " ++ naName ++ " is " ++ if naIn then "in" else "out" 15 | -------------------------------------------------------------------------------- /src/main/haskell/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ATMSTrun 4 | import JTMSrun 5 | 6 | main :: IO () 7 | main = do 8 | runATMS1 9 | -- runJTMS1 10 | return () 11 | -------------------------------------------------------------------------------- /src/main/haskell/lib/Data/TMS/ChooseDebugging.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, KindSignatures, RankNTypes #-} 2 | 3 | {-| 4 | Module : ChooseDebugging 5 | Description : The main switch for activating tracing messages for debugging in output. 6 | Copyright : (c) John Maraist, 2022 7 | License : AllRightsReserved 8 | Maintainer : haskell-tms@maraist.org 9 | Stability : experimental 10 | Portability : POSIX 11 | 12 | The module contains the flag which indicates whether debugging output 13 | should be compiled into modules using this system for runtime trace 14 | output. 15 | -} 16 | 17 | module Data.TMS.ChooseDebugging (debuggingOn, debugging) where 18 | import Language.Haskell.TH 19 | import Control.Monad 20 | import Control.Monad.IO.Class 21 | import Control.Monad.ST.Trans 22 | import Control.Monad.Trans.Class 23 | import Control.Monad.Trans.Free 24 | import Control.Monad.Trans.Identity 25 | import Control.Monad.Trans.Maybe 26 | import Control.Monad.Trans.Reader 27 | import Control.Monad.Trans.Resource 28 | import Control.Monad.Trans.State.Strict 29 | import qualified Control.Monad.Trans.State.Lazy as SL 30 | import qualified Control.Monad.Trans.Writer.Lazy as WL 31 | import qualified Control.Monad.Trans.Writer.Strict as WS 32 | 33 | -- | Flag which indicates whether debugging output should be compiled 34 | -- into modules using this system for runtime trace output. 35 | debuggingOn = False 36 | 37 | unitQ :: Q Exp 38 | {-# INLINE unitQ #-} 39 | unitQ = [| return () |] 40 | 41 | monadIOQ = ''MonadIO 42 | monadQ = ''Monad 43 | 44 | -- | Macro which expands to definitions which either print debugging 45 | -- statements, or do nothing. 46 | debugging :: Q [Dec] 47 | debugging = if debuggingOn 48 | then [d| class MonadIO m => Debuggable m 49 | instance MonadIO m => Debuggable m 50 | dbg :: Q Exp -> Q Exp 51 | {-# INLINE dbg #-} 52 | dbg exp = exp 53 | |] 54 | else [d| class Monad m => Debuggable m 55 | instance Monad m => Debuggable m 56 | dbg :: a -> Q Exp 57 | {-# INLINE dbg #-} 58 | dbg _ = unitQ 59 | |] 60 | -------------------------------------------------------------------------------- /src/main/haskell/lib/Data/TMS/Dbg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, KindSignatures, RankNTypes, FlexibleInstances, UndecidableInstances #-} 2 | 3 | module Data.TMS.Dbg ( 4 | -- |Constraint for monads which will require `MonadIO` when 5 | -- debugging is activated. 6 | Debuggable, 7 | -- |The quoted code will be run when debugging is activated. 8 | dbg 9 | ) where 10 | import Language.Haskell.TH 11 | import Data.TMS.ChooseDebugging (debugging) 12 | import Control.Monad.IO.Class 13 | 14 | $(debugging) 15 | -------------------------------------------------------------------------------- /src/main/haskell/prof/ATMSTrun.hs: -------------------------------------------------------------------------------- 1 | module ATMSTrun where 2 | 3 | import Control.Monad.State 4 | import Data.Symbol 5 | import Data.TMS.Formatters 6 | import Data.TMS.ATMS.ATMST 7 | 8 | runATMS1 :: IO (Either AtmsErr ()) 9 | runATMS1 = do 10 | runATMST $ do 11 | atms <- createATMS "Ex1" 12 | setInformantStringViaString atms 13 | setDatumStringViaString atms 14 | -- debugAtms "Created" atms 15 | na <- createNode atms "A" True False 16 | -- debugAtms "Added assumption node A" atms 17 | nc <- createNode atms "C" True False 18 | -- debugAtms "Added assumption node C" atms 19 | ne <- createNode atms "E" True False 20 | -- debugAtms "Added assumption node E" atms 21 | nh <- createNode atms "H" False False 22 | -- debugAtms "Added non-assumption node H" atms 23 | justifyNode "R1" nh [nc, ne] 24 | -- debugAtms "After rule R1" atms 25 | ng <- createNode atms "G" False False 26 | -- debugAtms "After non-assumption node G" atms 27 | justifyNode "R2" ng [na, nc] 28 | -- debugAtms "After rule R2" atms 29 | nx <- createNode atms "X" False True 30 | -- debugAtms "After contradiction node X" atms 31 | justifyNode "R3" nx [ng] 32 | -- debugAtms "After rule R3" atms 33 | nb <- createNode atms "B" True False 34 | liftIO $ putStrLn "Added assumption node B" 35 | debug atms 36 | justifyNode "R4" nh [nb, nc] 37 | liftIO $ putStrLn "After rule R4" 38 | debug atms 39 | -------------------------------------------------------------------------------- /src/main/haskell/prof/JTMSrun.hs: -------------------------------------------------------------------------------- 1 | module JTMSrun where 2 | 3 | import Data.Symbol 4 | import Data.TMS.JTMS 5 | import Control.Monad.IO.Class 6 | 7 | runJTMS1 :: IO (Either JtmsErr ()) 8 | runJTMS1 = runJTMST $ do 9 | j <- createJTMS "Ex1" 10 | na <- createNode j (intern "a") True False 11 | naName <- nodeString na 12 | naIn <- isInNode na 13 | liftIO $ putStrLn $ 14 | "Node " ++ naName ++ " is " ++ if naIn then "in" else "out" 15 | -------------------------------------------------------------------------------- /src/main/haskell/prof/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Main where 4 | 5 | import ATMSTrun 6 | import JTMSrun 7 | import Control.Monad.Random 8 | import Control.Monad.Random.Class 9 | import Data.TMS.ATMS.ATMST 10 | 11 | main :: IO () 12 | main = do 13 | -- gen <- getStdGen 14 | let gen = mkStdGen 8675309 --- Fix for comparing like to like 15 | evalRandT (runATMST $ 16 | makeForceATMS 17 | (IntRange 800 810) (IntRange 4000 4010) 18 | 0.1 19 | (IntRange 50 60) (IntRange 25 30) 20 | False) gen 21 | return () 22 | 23 | intSet :: (RandomGen g, Monad m) => Int -> Int -> RandT g m [Int] 24 | intSet 0 _ = return [] 25 | intSet n m = do 26 | x <- getRandomR (0, m) 27 | xs <- intSet (n - 1) m 28 | return $ x : xs 29 | 30 | intSetExcept :: (RandomGen g, Monad m) => Int -> Int -> Int -> RandT g m [Int] 31 | intSetExcept 0 _ _ = return [] 32 | intSetExcept n m d = do 33 | x <- getRandomR (0, m) 34 | if (x == d) then intSetExcept n m d else do 35 | xs <- intSetExcept (n - 1) m d 36 | return $ x : xs 37 | 38 | data IntRange = IntRange { lo :: Int, hi :: Int } 39 | 40 | sample :: (RandomGen g, Monad m) => IntRange -> RandT g m Int 41 | sample (IntRange lo hi) = getRandomR (lo, hi) 42 | 43 | coinFlip :: (RandomGen g, Monad m) => Double -> RandT g m Bool 44 | coinFlip p = do 45 | q <- getRandomR (0.0, 1.0) 46 | return $ q <= p 47 | 48 | makeForceATMS :: 49 | (RandomGen g, MonadIO m) => 50 | IntRange -> IntRange -> Double -> IntRange -> IntRange -> Bool -> 51 | ATMST s (RandT g m) () 52 | makeForceATMS assumptionsRange nonassumptionsRange contradictionChance 53 | justificationsPerConclusion antecedentsPerJustifications 54 | cyclic = do 55 | 56 | atms <- createATMS "Random ATMS" 57 | setDatumStringViaString atms 58 | setInformantStringViaString atms 59 | assumptions <- lift $ sample assumptionsRange 60 | nonassumptions <- lift $ sample nonassumptionsRange 61 | let totalNodes = assumptions + nonassumptions 62 | 63 | assumptionNodes <- forM [0 .. assumptions - 1] $ \i -> 64 | createNode atms ("Node-" ++ show i) True False 65 | 66 | nonassumptionNodes <- forM [0 .. nonassumptions - 1] $ \i -> do 67 | isContradiction <- lift $ coinFlip contradictionChance 68 | let idx = assumptions + i 69 | createNode atms ("Node-" ++ show idx) False isContradiction 70 | 71 | let nodes = assumptionNodes ++ nonassumptionNodes 72 | 73 | {-# SCC "mainLoop" #-} forM_ [0 .. nonassumptions - 1] $ \i -> do 74 | let idx = assumptions + i 75 | let node = nodes !! idx 76 | justifications <- lift $ sample justificationsPerConclusion 77 | -- lift $ lift $ liftIO $ putStrLn $ 78 | -- show justifications ++ " justifications for node " ++ show idx 79 | forM_ [0 .. justifications - 1] $ \j -> do 80 | thisSize <- lift $ sample antecedentsPerJustifications 81 | antsIdx <- lift $ if cyclic 82 | then intSet thisSize $ idx - 1 83 | else intSetExcept thisSize (totalNodes - 1) j 84 | let ants = map (nodes !!) antsIdx 85 | {-# SCC "justCalls" #-} justifyNode (show i ++ "." ++ show j) node ants 86 | {-# SCC "forceLabel" #-} debugNodeLabel node 87 | 88 | -------------------------------------------------------------------------------- /src/main/lisp/atms/aqueens.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Lisp -*- 2 | 3 | ;;;; ATMS version of the N-queens problem 4 | 5 | ;; Copyright (c) 1986, 1987, 1988, 1989, 1990 Kenneth D. Forbus, 6 | ;; Northwestern University, and Johan de Kleer, Xerox Corporation. 7 | ;; All rights reserved. 8 | 9 | (in-package 'user) 10 | 11 | ;; This version uses special-purpose lisp code for simplicity. 12 | ;; Clearly one queen per column is required, hence choice sets 13 | ;; are placement of queen within the rows for each column. 14 | 15 | (defvar *queen-nodes* nil) 16 | (defvar *solutions* nil) 17 | (defvar *atms*) 18 | 19 | (defun n-queens (n) 20 | (setq *atms* (create-atms "N-queens")) 21 | (setq *solutions* nil) 22 | (setq *queen-nodes* nil) 23 | (setup-queen-nodes n) 24 | (setq *solutions* (interpretations *atms* *queen-nodes*)) 25 | (length *solutions*)) 26 | 27 | (defun setup-queen-nodes (n) 28 | (do ((i 1 (1+ i)) 29 | (column nil nil) 30 | (nodes nil)) 31 | ((> i n) 32 | (setq nodes (apply #'append *queen-nodes*)) 33 | (dolist (n1 nodes) 34 | (dolist (n2 nodes) 35 | (unless (or (eq n1 n2) 36 | (= (caddr (tms-node-datum n1)) 37 | (caddr (tms-node-datum n2)))) 38 | (when (queens-capture? (tms-node-datum n1) 39 | (tms-node-datum n2)) 40 | (nogood-nodes 'QUEENS-CAPTURE (list n1 n2))))))) 41 | (do ((j 1 (1+ j))) 42 | ((> j n) (push column *queen-nodes*)) 43 | (push (tms-create-node *atms* `(Queen ,j ,i) :assumptionp T) column)))) 44 | 45 | (defun queens-capture? (qa1 qa2) 46 | (or (= (cadr qa1) (cadr qa2)) 47 | (= (abs (- (cadr qa1) (cadr qa2))) 48 | (abs (- (caddr qa1) (caddr qa2)))))) 49 | 50 | (defun test-queens (from to) 51 | (do ((n from (1+ n))) 52 | ((> n to)) 53 | (time (n-queens n)) 54 | (format t "~%For ~D queens, ~D solutions." 55 | n (length *solutions*)))) 56 | -------------------------------------------------------------------------------- /src/main/lisp/atms/atms.asd: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: common-lisp; package: yr-asd; -*- 2 | 3 | 4 | ;;; ASDF file hacked in by J Maraist 5 | 6 | (defpackage :atms-asd (:use :common-lisp :asdf)) 7 | (in-package :atms-asd) 8 | 9 | ;;; :atms 10 | ;;; (asdf:oos 'asdf:load-op :atms) 11 | ;;; :als :atms 12 | ;;; (atms-test1) 13 | 14 | (defsystem :atms 15 | :depends-on (:trdbg) 16 | :components (;; (:file "package") 17 | (:file "adata" :depends-on ()) 18 | (:file "ainter" :depends-on ()) 19 | ;; (:file "aplanr" :depends-on ()) 20 | ;; (:file "aqueens" :depends-on ()) 21 | (:file "arules" :depends-on ()) 22 | (:file "atms" :depends-on ()) 23 | (:file "atre" :depends-on ()) 24 | (:file "atest" :depends-on ()) 25 | ; 26 | ;; (:file "atret" :depends-on ()) 27 | ;; (:file "bcode" :depends-on ()) 28 | ;; (:file "blocks" :depends-on ()) 29 | ;; (:file "causality-ex" :depends-on ()) 30 | ;; (:file "causality" :depends-on ()) 31 | ;; (:file "csp" :depends-on ()) 32 | ;; (:file "funify" :depends-on ()) 33 | ;; (:file "id" :depends-on ()) 34 | ;; (:file "interactive-ex" :depends-on ()) 35 | ;; (:file "my" :depends-on ()) 36 | ;; (:file "plan-a" :depends-on ()) 37 | ;; (:file "plan-e" :depends-on ()) 38 | ;; (:file "prob" :depends-on ()) 39 | ;; (:file "sudoku" :depends-on ()) 40 | ;; (:file "unify" :depends-on ()) 41 | )) 42 | -------------------------------------------------------------------------------- /src/main/lisp/atms/atre.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- MODE: Lisp; -*- 2 | 3 | ;;; ATRE: Tiny Rule Engine, with ATMS interface 4 | ;; Last edited: 1/29/93, KDF 5 | 6 | ;; Copyright (c) 1992, Kenneth D. Forbus, Northwestern 7 | ;; University, and Johan de Kleer, the Xerox Corporation 8 | ;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *atre-path* 17 | #+ILS "/u/bps/code/atms/" 18 | #+PARC "virgo:/virgo/dekleer/bps/code/atms/" 19 | #+MCL "Macintosh HD:BPS:atms:") 20 | 21 | (setq *atre-files* 22 | '("atms" ;; ATMS 23 | "ainter" ;; Interface 24 | "adata" ;; Database 25 | "arules" ;; Rule system 26 | "unify" ;; Variables and pattern matching 27 | "funify" ;; Open-coding of unification 28 | "atret")) ;; Test procedures 29 | 30 | (setq *planner-files* 31 | '("aplanr" ;; Utilities 32 | "plan-a" ;; Antecedent planner 33 | "plan-e" ;; Envisioner 34 | "bcode" ;; Blocks World support 35 | "blocks")) ;; Rules for Blocks World 36 | 37 | (defun compile-planner () ;; Assumes ATRE is compiled and loaded. 38 | (compile-load-files '("aplanr" "plan-a" "plan-e" "bcode") 39 | *atre-path*) 40 | (unless (and (boundp '*plnpr*) 41 | (not (null *plnpr*))) 42 | (create-planning-problem "DUMMY" nil)) 43 | (compile-load-files '("blocks") *atre-path*)) 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /src/main/lisp/atms/bcode.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Test code for ATRE Blocksworld system 4 | ;; Last edited: 1/29/93, by KDF 5 | 6 | ;; Copyright (c) 1990-1992 Kenneth D. Forbus, Northwestern 7 | ;; University, and Johan de Kleer, Xerox Corporation. 8 | ;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *blocks-file* 17 | #+ILS "/u/bps/code/atms/blocks" 18 | #+PARC "virgo:/virgo/dekleer/bps/code/atms/blocks" 19 | #+MCL "Macintosh HD:BPS:atms:blocks") 20 | 21 | (defun build-blocks-problem (title blocks-list 22 | &optional (debugging nil) 23 | &aux plnpr) 24 | (setq plnpr 25 | (create-planning-problem 26 | title (make-blocks-basis-set blocks-list))) 27 | (in-plnpr plnpr) 28 | (set-debug-plnpr debugging) 29 | (with-atre (plnpr-atre plnpr) 30 | (load *blocks-file*) ;; Load basic definitions 31 | (dolist (block blocks-list) 32 | (assert! `(block ,block) 'Definition)) 33 | (run-rules) 34 | (setup-choice-sets plnpr)) 35 | plnpr) 36 | 37 | (defun make-blocks-basis-set (blocks &aux basis) 38 | (dolist (block blocks) 39 | ;; what the block can be on. 40 | (push `((Holding ,block) (On ,block Table) 41 | ,@ (mapcar #'(lambda (other) 42 | `(On ,block ,other)) 43 | (remove block blocks))) 44 | basis) 45 | ;;; What can be on the block 46 | (push `((Holding ,block) (Clear ,block) 47 | ,@ (mapcar #'(lambda (other) 48 | `(ON ,other ,block)) 49 | (remove block blocks))) 50 | basis)) 51 | (cons `((HAND-EMPTY) 52 | ,@ (mapcar #'(lambda (block) 53 | `(HOLDING ,block)) blocks)) 54 | basis)) 55 | -------------------------------------------------------------------------------- /src/main/lisp/atms/csp.lisp: -------------------------------------------------------------------------------- 1 | (defvar *atms* nil) 2 | 3 | (defun add-var (x vs) 4 | (let ((ns (mapcar #'(lambda (v) 5 | (tms-create-node *atms* (list x v) :assumptionp t)) 6 | vs))) 7 | (loop for a in ns 8 | do (loop for b in ns 9 | when (not (equal (tms-node-datum a) (tms-node-datum b))) 10 | do (nogood-nodes 'unique-value (list a b)))) 11 | ns)) 12 | 13 | (defun add-con (xs ys allowed) 14 | (loop for a in xs 15 | do (loop for b in ys 16 | when (not (member (list (cadr (tms-node-datum a)) (cadr (tms-node-datum b))) allowed :test #'equal)) 17 | do (nogood-nodes 'not-allowed (list a b))))) 18 | 19 | (defun find-var (x vars) 20 | (find-if #'(lambda (line) (equal x (car (tms-node-datum (car line))))) vars)) 21 | 22 | (defun csp (var-defs con-defs) 23 | (setq *atms* (create-atms "csp" :debugging t)) 24 | (let ((vars (mapcar #'(lambda (line) (add-var (car line) (cdr line))) var-defs))) 25 | (mapcar #'(lambda (line) (add-con (find-var (caar line) vars) 26 | (find-var (cadar line) vars) 27 | (cdr line))) 28 | con-defs) 29 | (let ((i (interpretations *atms* vars))) 30 | (mapcar #'print-env i) 31 | i))) 32 | 33 | (csp '((x a b) 34 | (y e f) 35 | (z c d g)) 36 | '(((x y) (b e) (b f)) 37 | ((x z) (b c) (b d) (b g)) 38 | ((y z) (e d) (f g)))) 39 | 40 | (csp '((n1 r g b) 41 | (n2 r g b) 42 | (n3 r g b)) 43 | '(((n1 n2) (r g) (r b) (g r) (g b) (b r) (b g)) 44 | ((n2 n3) (r g) (r b) (g r) (g b) (b r) (b g)) 45 | ((n1 n3) (r g) (r b) (g r) (g b) (b r) (b g)))) 46 | 47 | (csp '((n1 r g b) 48 | (n2 r g b) 49 | (n3 r g b) 50 | (n4 r g b)) 51 | '(((n1 n2) (r g) (r b) (g r) (g b) (b r) (b g)) 52 | ((n2 n3) (r g) (r b) (g r) (g b) (b r) (b g)) 53 | ((n1 n3) (r g) (r b) (g r) (g b) (b r) (b g)) 54 | ((n1 n4) (r g) (r b) (g r) (g b) (b r) (b g)) 55 | ((n2 n4) (r g) (r b) (g r) (g b) (b r) (b g)) 56 | ((n3 n4) (r g) (r b) (g r) (g b) (b r) (b g)))) 57 | -------------------------------------------------------------------------------- /src/main/lisp/atms/interactive-ex.lisp: -------------------------------------------------------------------------------- 1 | (setq *atms* (create-atms "Simple Example")) 2 | (setq assumption-a (tms-create-node *atms* "A" :assumptionp t) 3 | assumption-c (tms-create-node *atms* "C" :assumptionp t) 4 | assumption-e (tms-create-node *atms* "E" :assumptionp t)) 5 | 6 | (setq node-h (tms-create-node *atms* "h")) 7 | (justify-node "R1" node-h (list assumption-c assumption-e)) 8 | (why-node node-h) 9 | 10 | (setq node-g (tms-create-node *atms* "g")) 11 | (justify-node "R2" node-g (list assumption-a assumption-c)) 12 | (setq contradiction (tms-create-node *atms* 'contradiction :contradictoryp t)) 13 | (justify-node "R3" contradiction (list node-g)) 14 | (why-node node-g) 15 | 16 | (mapc 'print-env (interpretations *atms* nil (atms-assumptions *atms*))) 17 | 18 | (mapcar #'(lambda (le) 19 | (in-node? node-h le)) 20 | (interpretations *atms* nil (atms-assumptions *atms*))) 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/main/lisp/atms/my.lisp: -------------------------------------------------------------------------------- 1 | (setq *pack-ltms* t) 2 | (bps-load-file (make-bps-path "ltms") "ltms" :action :compile) 3 | (bps-load-file (make-bps-path "ltms") "cltms" :action :compile) 4 | (in-package :COMMON-LISP-USER) 5 | (bps-load-file (make-bps-path "atms") "atre" :action :compile) 6 | (bps-load-file (make-bps-path "atms") "atms" :action :compile) 7 | (compile-atre) 8 | ;;(compile-planner) 9 | 10 | (bps-load-file (make-bps-path "atms") "prob" :action :compile) 11 | (bps-load-file (make-bps-path "atms") "causality" :action :compile) 12 | (bps-load-file (make-bps-path "atms") "causality-ex" :action :compile) 13 | 14 | (bps-load-file (make-bps-path "atms") "sudoku" :action :compile) 15 | (solve-sudoku *easy-puzzle*) 16 | 17 | (bps-load-file (make-bps-path "atms") "atest" :action :compile) 18 | (atms-test1) 19 | (atms-test2) 20 | (step-1) 21 | -------------------------------------------------------------------------------- /src/main/lisp/atms/plan-a.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Antecedent Planner (a.k.a. Plan-A) 4 | ;; Last edited: 1/29/93, KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;; This algorithm assumes that every choice in each choice set 17 | ;; has become an assumption, but that states have not yet been 18 | ;; generated. 19 | 20 | ;; Notice how the ability to use environments as explicit 21 | ;; objects lets us revert back to CPS-like code! 22 | 23 | (defun Plan-a (start goal &optional (*plnpr* *plnpr*)) 24 | ;; Here start is a specific environment. 25 | ;; The goal is a list of conjunctions 26 | (do ((queue (list (list start)) 27 | (nconc (cdr queue) new-sprouts)) 28 | (new-sprouts nil nil) 29 | (found? nil) (result nil) 30 | (number-examined 1 (1+ number-examined))) 31 | ((or found? (null queue)) 32 | (values (setf (getf (plnpr-plist *plnpr*) 33 | :PLAN) found?) 34 | number-examined)) 35 | (cond ((satisfies-goal? (caar queue) goal) 36 | (setq found? (car queue))) 37 | (t (dolist (op-inst (find-applicable-operators 38 | (caar queue))) 39 | (setq result 40 | (apply-operator (caar queue) 41 | op-inst)) 42 | (unless (member result (car queue)) 43 | (debug-plnpr t 44 | "~% Reaching ~A via ~A on ~A.." 45 | result op-inst (caar queue)) 46 | (push (cons result 47 | (cons op-inst (car queue))) 48 | new-sprouts))))))) 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /src/main/lisp/atms/plan-e.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; ATMS-based Envisioner for planning problems 4 | ;; Last edited: 1/29/93, KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun envision (&optional (*plnpr* *plnpr*) 17 | &aux states) 18 | (setq states (solutions (plnpr-atre *plnpr*) 19 | (plnpr-basis-set *plnpr*))) 20 | (setf (getf (plnpr-plist *plnpr*) :STATES) states) 21 | (setf (getf (plnpr-plist *plnpr*) :TRANSITIONS) 22 | (apply-all-operators states))) 23 | 24 | (defun apply-all-operators (states) 25 | (mapcar 26 | #'(lambda (state &aux entry) 27 | (dolist (op-inst (find-applicable-operators state) 28 | entry) 29 | (push (cons op-inst (apply-operator state op-inst)) 30 | entry)) 31 | (push state entry)) states)) 32 | 33 | (defun show-envisionment (&optional (*plnpr* *plnpr*) 34 | (stream *standard-input*) 35 | &aux states trans-table) 36 | (setq states (getf (plnpr-plist *plnpr*) :STATES)) 37 | (cond ((null states) 38 | (format stream "~%The state space is empty.")) 39 | (t (format stream 40 | "~% ~D states have been generated:" 41 | (length states)) 42 | (dolist (state states) 43 | (print-env state stream)) 44 | (format stream "~%Transition Table:") 45 | (setq trans-table 46 | (getf (plnpr-plist *plnpr*) :TRANSITIONS)) 47 | (if (null trans-table) (format stream " empty.") 48 | (dolist (state-entry trans-table) 49 | (format stream "~% ~A: " (car state-entry)) 50 | (dolist (pair (cdr state-entry)) 51 | (format stream "~% ~A -> ~A" 52 | (car pair) (cdr pair)))))))) 53 | 54 | ;;;; Finding plans by searching the envisionment 55 | 56 | (defun find-plan (start goals &optional (*plnpr* *plnpr*)) 57 | (let ((goal-states (fetch-states goals)) 58 | (start-states (fetch-states start))) 59 | (debug-plnpr t "~%Initial states are ~A." start-states) 60 | (debug-plnpr t "~%Goal states are ~A." goal-states) 61 | (do ((queue (mapcar #'(lambda (state) 62 | (list state)) start-states) 63 | (nconc (cdr queue) new-sprouts)) 64 | (new-sprouts nil nil) 65 | (transitions (getf (plnpr-plist *plnpr*) 66 | :TRANSITIONS)) 67 | (found? nil)) 68 | ((or found? (null queue)) 69 | (setf (getf (plnpr-plist *plnpr*) :PLAN) found?)) 70 | (cond ((member (caar queue) goal-states) ;got it 71 | (setq found? (car queue))) 72 | (t (dolist (transition 73 | (cdr (assoc (caar queue) 74 | transitions))) 75 | (unless (member (cdr transition) 76 | (cdar queue)) ;avoid loops 77 | (debug-plnpr t 78 | "~% Can reach ~A via ~A from ~A." 79 | (cdr transition) (car transition) 80 | (caar queue)) 81 | (push (cons (cdr transition) 82 | (cons (car transition) 83 | (car queue))) 84 | new-sprouts)))))))) -------------------------------------------------------------------------------- /src/main/lisp/atms/prob.lisp: -------------------------------------------------------------------------------- 1 | (defstruct (numeric (:PRINT-FUNCTION print-numeric)) 2 | (title nil) 3 | (+ nil) 4 | (* nil) 5 | (- nil) 6 | (/ nil)) 7 | 8 | (defun print-numeric (causal stream ignore) 9 | (declare (ignore ignore)) 10 | (format stream "#" (numeric-title causal))) 11 | 12 | (setq 13 | *numeric* 14 | (make-numeric 15 | :title "numeric" 16 | :+ #'+ 17 | :* #'* 18 | :- #'- 19 | :/ #'/)) 20 | 21 | (defun symbolic-* (&rest xs) 22 | (let ((xs (remove-if #'(lambda (x) (eql 1 x)) xs))) 23 | (if (null xs) 24 | 1 25 | (if (null (cdr xs)) 26 | (car xs) 27 | (cons '* xs))))) 28 | 29 | (defun symbolic-+ (&rest xs) 30 | (let ((xs (remove-if #'(lambda (x) (eql 0 x)) xs))) 31 | (if (null xs) 32 | 0 33 | (if (null (cdr xs)) 34 | (car xs) 35 | (cons '+ xs))))) 36 | 37 | (defun symbolic-- (&rest xs) 38 | (if (and (not (null (cdr xs))) (null (cddr xs)) (eql 0 (cadr xs))) 39 | (car xs) 40 | (cons '- xs))) 41 | 42 | (defun symbolic-/ (&rest xs) 43 | (if (and (= 2 (length xs)) (equal (car xs) (cadr xs))) 44 | 1 ;; ignoring div by 0 45 | (cons '/ xs))) 46 | 47 | (setq 48 | *symbolic* 49 | (make-numeric 50 | :title "symbolic" 51 | :+ #'symbolic-+ 52 | :* #'symbolic-* 53 | :- #'symbolic-- 54 | :/ #'symbolic-/)) 55 | -------------------------------------------------------------------------------- /src/main/lisp/atms/unify.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Variables and unification 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1988-1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun variable? (x) 17 | (and (symbolp x) ;A symbol whose first character is "?" 18 | (char= #\? (elt (symbol-name x) 0)))) 19 | 20 | (defun unify (a b &optional (bindings nil)) 21 | (cond ((equal a b) bindings) 22 | ((variable? a) (unify-variable a b bindings)) 23 | ((variable? b) (unify-variable b a bindings)) 24 | ((or (not (listp a)) (not (listp b))) :FAIL) 25 | ((not (eq :FAIL (setq bindings 26 | (unify (car a) (car b) bindings)))) 27 | (unify (cdr a) (cdr b) bindings)) 28 | (t :FAIL))) 29 | 30 | (defun unify-variable (var exp bindings &aux val) 31 | ;; Must distinguish no value from value of nil 32 | (setq val (assoc var bindings)) 33 | (cond (val (unify (cdr val) exp bindings)) 34 | ;; If safe, bind to 35 | ((free-in? var exp bindings) (cons (cons var exp) bindings)) 36 | (t :FAIL))) 37 | 38 | (defun free-in? (var exp bindings) 39 | ;; Returns nil if occurs in , assuming . 40 | (cond ((null exp) t) 41 | ((equal var exp) nil) 42 | ((variable? exp) 43 | (let ((val (assoc exp bindings))) 44 | (if val 45 | (free-in? var (cdr val) bindings) 46 | t))) 47 | ((not (listp exp)) t) 48 | ((free-in? var (car exp) bindings) 49 | (free-in? var (cdr exp) bindings)))) 50 | -------------------------------------------------------------------------------- /src/main/lisp/cps/boston.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Description of the Boston Subway system 4 | ;;; Last Edited: 1/11/91, KDF 5 | 6 | ;;; Copyright (c) 1983-1991, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;;; (Note: this map is quite sketchy) 17 | (defline Red-Line) 18 | (defline Green-Line) 19 | (defline Orange-Line) 20 | (defline Blue-Line) 21 | 22 | (defstation Airport (Blue-Line) 4.0 1.0) 23 | (defstation Aquarium (Blue-Line) 3.75 0.1) 24 | (defstation Wood-Island (Blue-Line) 5.0 2.0) 25 | (defstation State (Blue-Line Orange-Line) 3.1 -0.75) 26 | 27 | (defstation Park-Street (Green-Line Red-Line) 2.5 -0.5) 28 | (defstation Government-Center (green-line blue-line) 2.9 -0.25) 29 | (defstation Copley-Square (Green-Line) 1.0 -1.0) 30 | (defstation Boston-U (Green-Line) -1.0 -1.0) 31 | (defstation North-Station (Green-Line Orange-Line) 2.5 0.75) 32 | (defstation Haymarket (Orange-Line Green-Line) 2.75 0.5) 33 | 34 | (defstation South-Station (Red-Line) 3.0 -1.0) 35 | (defstation Washington (Red-Line Orange-Line) 2.75 -0.75) 36 | (defstation Kendall-Square (Red-Line) 1.0 0.0) 37 | (defstation Central-Square (Red-Line) -1.0 0.0) 38 | (defstation Harvard-Square (Red-Line) -2.0 1.0) 39 | -------------------------------------------------------------------------------- /src/main/lisp/cps/cps.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; File specifications for CPS, the "Classical Problem Solver" 4 | ;;; Last edited: 2/6/93, KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (setq *cps-path* 17 | #+ILS "/u/bps/code/cps/" 18 | #+PARC "virgo:/virgo/dekleer/bps/code/cps/" 19 | #+MCL "Macintosh HD:BPS:cps:") 20 | 21 | (defvar *cps-files* '("search" "variants")) 22 | (defvar *algebra-files* '("match" "algebra" "simplify")) 23 | (defvar *subway-files* '("subways" "boston")) 24 | 25 | (defun compile-cps () 26 | (compile-load-files *cps-files* *cps-path*) 27 | (compile-load-files *algebra-files* *cps-path*) 28 | (compile-load-files *subway-files* *cps-path*)) 29 | 30 | -------------------------------------------------------------------------------- /src/main/lisp/ftre/fqrule.lisp: -------------------------------------------------------------------------------- 1 | ; -*- Mode: Lisp; -*- 2 | 3 | ;;;; N-Queens rules, FTRE version 4 | ;;;; Modified: forbus on Tue Apr 2 10:24:59 1996 5 | 6 | ;;; Copyright (c) 1992-1996 Kenneth D. Forbus, Northwestern University, 7 | ;;; Johan de Kleer and Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (rule ((queen ?column1 ?row1) 17 | (queen ?column2 ?row2) 18 | :TEST (not (or (= ?column1 ?column2) 19 | (queens-okay? ?column1 ?row1 20 | ?column2 ?row2)))) 21 | (rassert! Contradiction)) 22 | 23 | -------------------------------------------------------------------------------- /src/main/lisp/ftre/fqueens.lsp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; N-Queens puzzle, using FTRE. 4 | ;;;; Modified: forbus on Tue Apr 2 10:22:45 1996 5 | 6 | ;;; Copyright (c) 1988-1992, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;;; Statistics 17 | (defvar *n-assumptions* 0) ;number of assumptions made (statistics) 18 | (defvar *placements* nil) ;successful solutions 19 | 20 | (defun test-queens (from to) 21 | (do ((n from (1+ n))) 22 | ((> n to)) 23 | (gc) 24 | (time (n-queens n)) 25 | (format t "~% For n=~D, ~D solutions, ~D assumptions." 26 | n (length *placements*) *n-assumptions*))) 27 | 28 | (defun n-queens (n &optional (debugging? nil)) 29 | (setup-queens-puzzle n debugging?) 30 | (solve-queens-puzzle (make-queens-choice-sets n)) 31 | (length *placements*)) 32 | 33 | ;;;; Setup and search 34 | 35 | (defun setup-queens-puzzle (n debugging?) 36 | (in-ftre 37 | (create-ftre (format nil "~D queens" n) 38 | :DEBUGGING debugging? 39 | :MAX-DEPTH (+ n 1))) 40 | (setq *placements* nil 41 | *n-assumptions* 0) 42 | (bps-load-file *ftre-path* *fqueen-rule-file*)) 43 | 44 | (defun make-queens-choice-sets (n) 45 | (do ((column 1 (1+ column)) 46 | (column-queens nil nil) 47 | (choice-sets nil)) 48 | ((> column n) (nreverse choice-sets)) 49 | (dotimes (row n) 50 | (push `(Queen ,column ,(1+ row)) column-queens)) 51 | (push (nreverse column-queens) choice-sets))) 52 | 53 | ;;; The chronological search itself 54 | 55 | (defun solve-queens-puzzle (choice-sets) 56 | (cond ((fetch 'contradiction) 57 | (return-from solve-queens-puzzle nil)) 58 | (choice-sets ;; Make next choice 59 | (dolist (choice (car choice-sets)) 60 | (incf *n-assumptions*) 61 | (try-in-context choice 62 | `(solve-queens-puzzle ',(cdr choice-sets))))) 63 | (t ;; Got a consistent set of placements 64 | (gather-queens-solution)))) 65 | 66 | ;;;; Utilities 67 | 68 | (defun queens-okay? (x1 y1 x2 y2) 69 | (not (or (= y1 y2) (= (abs (- x1 x2)) (abs (- y1 y2)))))) 70 | 71 | (defun gather-queens-solution () 72 | (push (fetch '(Queen ?x ?y) *ftre*) *placements*)) 73 | 74 | (defun show-queens-solution (solution &aux n) 75 | (setq n (length solution)) 76 | (dotimes (i n) 77 | (terpri) 78 | (dotimes (j n) 79 | (format t "~A" 80 | (if (member `(queen ,i ,j) solution 81 | :TEST #'equal) "Q" "-"))))) 82 | 83 | 84 | -------------------------------------------------------------------------------- /src/main/lisp/ftre/ftre.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Fast Tiny Rule Engine. 4 | ;;;; Modified: forbus on Tue Apr 2 10:14:11 1996 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *ftre-path* nil "FTRE's path") 17 | (defvar *ftre-files* nil "FTRE's files") 18 | (defvar *fqueen-rule-file* nil "FTRE's version of the n-queens rule") 19 | 20 | (setq *ftre-path* (make-bps-path "ftre")) 21 | 22 | (setq *ftre-files* 23 | '("finter" ;; Interface 24 | "fdata" ;; Database 25 | "frules" ;; Rule system 26 | "unify" ;; Unifier 27 | "funify" ;; Open-coding for unification 28 | "fnd-ex" ;; Natural deduction examples for ftre 29 | "fqueens" ;; n-queens setup for FTRE 30 | )) 31 | 32 | (setf *fqueen-rule-file* "fqrule") 33 | 34 | (defun load-ftre (&key (action :compile-if-newer)) 35 | (bps-load-files *ftre-path* *ftre-files* :action action)) -------------------------------------------------------------------------------- /src/main/lisp/ftre/unify.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Variables and unification 4 | ;;;; Modified: forbus on Tue Apr 2 10:20:10 1996 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun variable? (x) 17 | (and (symbolp x) 18 | (char= #\? (elt (symbol-name x) 0)))) 19 | 20 | (defun unify (a b &optional (bindings nil)) 21 | (cond ((equal a b) bindings) 22 | ((variable? a) (unify-variable a b bindings)) 23 | ((variable? b) (unify-variable b a bindings)) 24 | ((or (not (listp a)) (not (listp b))) :FAIL) 25 | ((not (eq :FAIL 26 | (setq bindings 27 | (unify (car a) (car b) bindings)))) 28 | (unify (cdr a) (cdr b) bindings)) 29 | (t :FAIL))) 30 | 31 | (defun unify-variable (var exp bindings &aux val) 32 | ;; Must distinguish no value from value of nil 33 | (setq val (assoc var bindings)) 34 | (cond (val (unify (cdr val) exp bindings)) 35 | ;; If safe, bind to 36 | ((free-in? var exp bindings) 37 | (cons (cons var exp) bindings)) 38 | (t :FAIL))) 39 | 40 | (defun free-in? (var exp bindings) 41 | ;; Returns nil if occurs in , 42 | ;; assuming . 43 | (cond ((null exp) t) 44 | ((equal var exp) nil) 45 | ((variable? exp) 46 | (let ((val (assoc exp bindings))) 47 | (if val 48 | (free-in? var (cdr val) bindings) 49 | t))) 50 | ((not (listp exp)) t) 51 | ((free-in? var (car exp) bindings) 52 | (free-in? var (cdr exp) bindings)))) 53 | -------------------------------------------------------------------------------- /src/main/lisp/gde/2bit.txt: -------------------------------------------------------------------------------- 1 | > (standard-2bit) 2 | There are 5 minimum cardinality diagnoses: 3 | {(X2 BIT1 ADD)} 4 | {(X1 BIT1 ADD)} 5 | {(O1 BIT0 ADD)} 6 | {(A2 BIT0 ADD)} 7 | {(A1 BIT0 ADD)} 8 | Measuring > RIPPLE ADD)> has cost 6.7548876 9 | Measuring > X BIT0 ADD)> has cost 8.0 10 | Measuring > Y BIT0 ADD)> has cost 8.0 11 | Measuring > Z BIT1 ADD)> has cost 8.0 12 | Measuring > CI BIT0 ADD)> has cost 11.60964 13 | Measuring > A BIT0 ADD)> has cost 11.60964 14 | Measuring > B BIT0 ADD)> has cost 11.60964 15 | Measuring > Q BIT0 ADD)> has cost 11.60964 16 | Measuring > Z BIT0 ADD)> has cost 11.60964 17 | Measuring > CO BIT1 ADD)> has cost 11.60964 18 | Measuring > A BIT1 ADD)> has cost 11.60964 19 | Measuring > B BIT1 ADD)> has cost 11.60964 20 | Measuring > Q BIT1 ADD)> has cost 11.60964 21 | Measuring > X BIT1 ADD)> has cost 11.60964 22 | Measuring > Y BIT1 ADD)> has cost 11.60964 23 | Please enter result of measuring > RIPPLE ADD)> 24 | 25 | -------------------------------------------------------------------------------- /src/main/lisp/gde/condef.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER -*- 2 | 3 | ;;; Copyright (c) 1986-1992 Kenneth D. Forbus, Johan de Kleer and 4 | ;;; Xerox Corporation. All Rights Reserved. 5 | 6 | ;;; See the file legal.txt for a paragraph stating scope of permission 7 | ;;; and disclaimer of warranty. The above copyright notice and that 8 | ;;; paragraph must be included in any separate copy of this file. 9 | 10 | (constraint adder-component ((a1 cell) (a2 cell) (sum cell) 11 | (ok assumption)) 12 | (formulae (sum (a1 a2 ok) (+ a1 a2)) 13 | (a1 (sum a2 ok) (- sum a2)) 14 | (a2 (sum a1 ok) (- sum a1)))) 15 | 16 | (constraint multiplier-component ((m1 cell) (m2 cell) 17 | (product cell) (ok assumption)) 18 | (formulae (product (m1) (if (nearly-equal? 0 m1) 0.0 :dismiss)) 19 | (product (m2) (if (nearly-equal? 0 m2) 0.0 :dismiss)) 20 | (product (m1 m2 ok) (cond ((or (nearly-equal? 0 m1) 21 | (nearly-equal? 0 m2)) 22 | :dismiss) 23 | (t (* m1 m2)))) 24 | (m1 (product m2 ok) (if (nearly-equal? 0 m2) :dismiss 25 | (/ product m2))) 26 | (m2 (product m1 ok) (if (nearly-equal? 0 m1) :dismiss 27 | (/ product m1))))) 28 | 29 | (constraint poly ((a cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 30 | (b cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 31 | (c cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 32 | (d cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 33 | (e cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 34 | (x cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 35 | (y cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 36 | (z cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 37 | (f cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 38 | (g cell 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 39 | (m1 multiplier-component a c x) 40 | (m2 multiplier-component b d y) 41 | (m3 multiplier-component c e z) 42 | (a1 adder-component x y f) 43 | (a2 adder-component y z g))) 44 | 45 | (assume-constraint xor-component ((in1 cell 0 1) (in2 cell 0 1) 46 | (out cell 0 1)) 47 | (formulae (out (in1 in2) (if (= in1 in2) 0 1)) 48 | (in1 (out in2) (if (= in2 out) 0 1)) 49 | (in2 (out in1) (if (= in1 out) 0 1)))) 50 | 51 | (assume-constraint or-component ((in1 cell 0 1) (in2 cell 0 1) 52 | (out cell 0 1)) 53 | (formulae (out (in1 in2) 54 | (if (and (= in1 0) (= in2 0)) 0 :dismiss)) 55 | (out (in1) (if (= in1 1) 1 :dismiss)) 56 | (out (in2) (if (= in2 1) 1 :dismiss)) 57 | (in1 (out in2) 58 | (if (and (= out 1) (= in2 0)) 1 :dismiss)) 59 | (in2 (out in1) 60 | (if (and (= out 1) (= in1 0)) 1 :dismiss)) 61 | (in1 (out) (if (= out 0) 0 :dismiss)) 62 | (in2 (out) (if (= out 0) 0 :dismiss)))) 63 | 64 | (assume-constraint and-component ((in1 cell 0 1) (in2 cell 0 1) 65 | (out cell 0 1)) 66 | (formulae (out (in1 in2) 67 | (if (and (= in1 1) (= in2 1)) 1 :dismiss)) 68 | (out (in1) (if (= in1 0) 0 :dismiss)) 69 | (out (in2) (if (= in2 0) 0 :dismiss)) 70 | (in1 (out) (if (= out 1) 1 :dismiss)) 71 | (in2 (out) (if (= out 1) 1 :dismiss)) 72 | (in1 (out in2) (if (and (= out 0) (= in2 1)) 0 :dismiss)) 73 | (in2 (out in1) (if (and (= out 0) (= in1 1)) 0 :dismiss)))) 74 | 75 | (constraint full-adder ((co cell) (ci cell) (a cell) (b cell) (q cell) 76 | (x cell) (y cell) (z cell) 77 | (x1 xor-component a b z) 78 | (a1 and-component a b y) 79 | (x2 xor-component ci z q) 80 | (a2 and-component ci z x) 81 | (o1 or-component x y co))) 82 | 83 | (constraint 2-bit-adder ((ripple cell) 84 | (bit0 full-adder ripple) 85 | (bit1 full-adder () ripple))) -------------------------------------------------------------------------------- /src/main/lisp/gde/diagrams.lisp: -------------------------------------------------------------------------------- 1 | ;-*- Mode: LISP; Syntax: Common-lisp; Package: USER-*- 2 | 3 | ;;; Copyright (c) 1986-1993 Kenneth D. Forbus, Johan de Kleer and 4 | ;;; Xerox Corporation. All Rights Reserved. 5 | 6 | ;;; See the file legal.txt for a paragraph stating scope of permission 7 | ;;; and disclaimer of warranty. The above copyright notice and that 8 | ;;; paragraph must be included in any separate copy of this file. 9 | 10 | ;;; Load the file atms 11 | ;;; Load the file atcon 12 | ;;; Load the file gde 13 | ;;; Load the file condef 14 | 15 | (defun standard-poly () 16 | (setq *atcon* (create-atcon "Poly")) 17 | (create 'p 'poly) 18 | (set-parameter (>> a p) 3) 19 | (set-parameter (>> b p) 2) 20 | (set-parameter (>> c p) 2) 21 | (set-parameter (>> d p) 3) 22 | (set-parameter (>> e p) 3) 23 | (format T "~% Measured f to be 10") 24 | (set-parameter (>> f p) 10) 25 | (print-minimal-conflicts) 26 | (print-minimal-diagnoses) 27 | (print-smallest-diagnoses) 28 | (score-measurements (smallest-diagnoses)) 29 | (format T "~% Measured g to be 12") 30 | (set-parameter (>> g p) 12) 31 | (print-minimal-conflicts) 32 | (print-minimal-diagnoses) 33 | (print-smallest-diagnoses) 34 | (score-measurements (smallest-diagnoses)) 35 | 'DONE) 36 | 37 | (defun ole-string (node &aux value) 38 | (setq value (TMSnode.datum node)) 39 | (cond ((stringp value) value) 40 | ((value-string value)) 41 | ((eq (cell-name (value-cell value)) 'OK) 42 | (format nil "~A" (constraint-pretty-name 43 | (cell-owner (value-cell value))))) 44 | (t (format nil "~A = ~A" (cell-pretty-name (value-cell value)) 45 | (value-datum value))))) 46 | 47 | 48 | (defun standard-2bit () 49 | (setq *atcon* (create-atcon "ole")) 50 | (create 'add '2-bit-adder) 51 | (change-atms (atcon-atms *atcon*) :node-string 'ole-string) 52 | (set-parameter (>> a bit0 add) 0) 53 | (set-parameter (>> b bit0 add) 0) 54 | (set-parameter (>> a bit1 add) 0) 55 | (set-parameter (>> b bit1 add) 0) 56 | (set-parameter (>> ci bit0 add) 0) 57 | (set-parameter (>> q bit1 add) 1) 58 | ; (assume-parameter (>> co bit1 add) 1) 59 | (diagnose)) 60 | -------------------------------------------------------------------------------- /src/main/lisp/gde/polyex.txt: -------------------------------------------------------------------------------- 1 | > (standard-poly) 2 | Measured f to be 10 3 | Minimal conflict: {A1,M1,M2} 4 | There are 3 minimal diagnoses: 5 | {A1} 6 | {M2} 7 | {M1} 8 | There are 3 minimum cardinality diagnoses: 9 | {A1} 10 | {M2} 11 | {M1} 12 | Measuring > X P)> has cost 2.0 13 | Measuring > Y P)> has cost 2.0 14 | Measuring > G P)> has cost 2.0 15 | Measuring > A P)> has cost 4.7548876 16 | Measuring > B P)> has cost 4.7548876 17 | Measuring > C P)> has cost 4.7548876 18 | Measuring > D P)> has cost 4.7548876 19 | Measuring > E P)> has cost 4.7548876 20 | Measuring > Z P)> has cost 4.7548876 21 | Measuring > F P)> has cost 4.7548876 22 | Measured g to be 12 23 | Minimal conflict: {A1,M1,M2} 24 | Minimal conflict: {A1,A2,M1,M3} 25 | There are 4 minimal diagnoses: 26 | {A2,M2} 27 | {A1} 28 | {M2,M3} 29 | {M1} 30 | There are 2 minimum cardinality diagnoses: 31 | {A1} 32 | {M1} 33 | Measuring > X P)> has cost 0.0 34 | Measuring > A P)> has cost 2.0 35 | Measuring > B P)> has cost 2.0 36 | Measuring > C P)> has cost 2.0 37 | Measuring > D P)> has cost 2.0 38 | Measuring > E P)> has cost 2.0 39 | Measuring > Y P)> has cost 2.0 40 | Measuring > Z P)> has cost 2.0 41 | Measuring > F P)> has cost 2.0 42 | Measuring > G P)> has cost 2.0 43 | DONE -------------------------------------------------------------------------------- /src/main/lisp/jtms/carnival-load.lisp: -------------------------------------------------------------------------------- 1 | (bps-load-file (make-bps-path "jtms") "jtre" :action :compile) 2 | (compile-jtre) 3 | (bps-load-file (make-bps-path "jtms") "jtms" :action :compile) 4 | (bps-load-file (make-bps-path "jtms") "carnival" :action :compile) 5 | (bps-load-file (make-bps-path "ltms") "carnival-ex" :action :compile) 6 | (bps-load-file (make-bps-path "ltms") "carnival-play" :action :compile) 7 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/carnival.lisp: -------------------------------------------------------------------------------- 1 | ;; inspired by 2 | ;; https://github.com/saezlab/CARNIVAL 3 | 4 | (defvar *node-labels*) 5 | (defvar *nodes*) 6 | 7 | (defun new-carnival (title) 8 | (setq *jtms* (create-jtms (format nil "CARNIVAL ~A" title))) 9 | (setq *node-labels* '()) 10 | (setq *nodes* '())) 11 | 12 | (defun get-node (n) 13 | (cdr (assoc n *nodes*))) 14 | 15 | (defun find-node (tms datum) 16 | (car (member datum (jtms-nodes tms) :key #'tms-node-datum))) 17 | 18 | (defun opposite-valence (val) 19 | (ecase val (+ '-) (- '+))) 20 | 21 | (defun node-name (val n) 22 | (read-from-string (concatenate 'string (string val) (string n)))) 23 | 24 | (defmacro node (val n &key (measured? nil) (top? nil)) 25 | `(progn 26 | (push (cons ',n ',val) *node-labels*) 27 | (let ((na (tms-create-node *jtms* ',(node-name val n))) 28 | (nb (tms-create-node *jtms* ',(node-name (opposite-valence val) n))) 29 | (n! (tms-create-node *jtms* ',(node-name '! n) :CONTRADICTORYP t))) 30 | (justify-node 'CONTRA n! (list na nb)) 31 | (push (cons ',(node-name val n) na) *nodes*) 32 | (push (cons ',(node-name (opposite-valence val) n) nb) *nodes*) 33 | ,(if top? `(assume-node na) t)))) 34 | 35 | (defun edge-name (val src dst) 36 | (read-from-string (concatenate 'string (string src) (string val) (string dst)))) 37 | 38 | (defun maybe-flip-valence (edge-val node-val) 39 | (ecase edge-val (+ node-val) (- (opposite-valence node-val)))) 40 | 41 | (defmacro edge (val src dst) 42 | (let ((edge-name (edge-name val src dst))) 43 | `(progn 44 | ,@(mapcar 45 | #'(lambda (node-val) 46 | `(justify-node 47 | ',edge-name 48 | (get-node ',(node-name (maybe-flip-valence val node-val) dst)) 49 | (list (get-node ',(node-name node-val src))))) 50 | '(+ -))))) 51 | 52 | (defmacro edge (val src dst) 53 | (let ((edge-name (edge-name val src dst))) 54 | `(let ((edge (tms-create-node *jtms* ',edge-name :ASSUMPTIONP t))) 55 | (enable-assumption edge) 56 | ,@(mapcar 57 | #'(lambda (node-val) 58 | `(justify-node 59 | ',val 60 | (get-node ',(node-name (maybe-flip-valence val node-val) dst)) 61 | (list edge (get-node ',(node-name node-val src))))) 62 | '(+ -))))) 63 | 64 | (defun solve () 65 | 'ok) 66 | 67 | (defun check-consistency (&aux c) 68 | (setq c t) 69 | (mapc #'(lambda (x) 70 | (let ((n (car x)) 71 | (v (cdr x))) 72 | (let ((node (get-node (node-name v n)))) 73 | (unless (equal ':IN (tms-node-label node)) 74 | (setq c nil) 75 | (format t "~%Node ~A inconsistent." n) 76 | (what-node n))))) 77 | *node-labels*) 78 | c) 79 | 80 | (defun what-node (n) 81 | (let ((n+ (get-node (node-name '+ n))) 82 | (n- (get-node (node-name '- n)))) 83 | (if (equal ':IN (tms-node-label n+)) (why-node n+)) 84 | (if (equal ':IN (tms-node-label n-)) (why-node n-)))) 85 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jbms-ex.rkt: -------------------------------------------------------------------------------- 1 | #lang 2 | 3 | (require "jbms.rkt") 4 | 5 | (oplus (interval 0.5 0.5) (interval 0.3 0.5)) 6 | 7 | (oplus (interval 0 1) (interval 0 1)) 8 | 9 | (oplus (interval 0 1) (interval 0.3 0.5)) ;; [0 1] is like the neutral element: 0 means no support, 1 means not true 10 | 11 | (oplus (interval 0.01 0.99) (interval 0.3 0.5)) ;; consistent 12 | 13 | (oplus (interval 0.5 1) (interval 0.5 1)) ;; div by zero but not following invariant 14 | 15 | (oplus (interval 0 0) (interval 0.3 0.6)) ;; [0 0] is like 1 16 | 17 | 18 | (define ex1 19 | (define j (create-jbms "hello" #:debugging #t)) 20 | (define na (tms-create-node j 'a #:belief (interval 0.1 0.6))) 21 | (define nb (tms-create-node j 'b #:belief (interval 0.2 0.5))) 22 | (define nf (tms-create-node j 'f #:belief (interval 0.3 0.4))) 23 | (justify-node 'j1 nf (list na nb)) 24 | (why-node nf) 25 | (enable-assumption na) ;; still have to attacth the belief for now 26 | (enable-assumption nb) 27 | (why-node nf) 28 | (tms-node-belief nf) 29 | (tms-node-belief na) 30 | (tms-node-belief nb) 31 | (combine-beliefs nf na nb) 32 | ) 33 | 34 | (define ex2 35 | (define j (create-jbms "hello" #:debugging #t)) 36 | (define na (tms-create-node j 'a #:belief (interval 0.1 0.6))) 37 | (define nb (tms-create-node j 'b #:belief (interval 0.2 0.5))) 38 | (define nc (tms-create-node j 'c #:belief (interval 0.1 0.6))) 39 | (define nd (tms-create-node j 'd #:belief (interval 0.2 0.5))) 40 | (define ne (tms-create-node j 'e #:belief (interval 0.2 0.5))) 41 | (justify-node 'j1 nb (list na)) 42 | (justify-node 'j2 nb (list nd)) 43 | (justify-node 'j2 nc (list nb)) 44 | (justify-node 'j2 nd (list nc)) 45 | (justify-node 'j2 nd (list ne)) 46 | (enable-assumption na) ;; still have to attacth the belief for now 47 | 48 | (tms-node-belief na) 49 | (tms-node-belief nb) 50 | (tms-node-belief nc) 51 | (tms-node-belief nd) 52 | 53 | (enable-assumption ne) 54 | 55 | (tms-node-belief nb) ;; B is not more supported than it should. See discussion on cycles. 56 | ) 57 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jinter.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; JTRE definitions 4 | ;;;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1989 -- 1992 Kenneth D. Forbus, Northwestern University, 7 | ;;; Johan de Kleer and Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defstruct (jtre (:PRINT-FUNCTION jtre-printer)) 17 | title ; Pretty name 18 | jtms ; Pointer to its JTMS 19 | (dbclass-table nil) ; Table of dbclasses 20 | (datum-counter 0) ; Unique ID for asserts 21 | (rule-counter 0) ; Unique ID for rules 22 | (debugging nil) ; If non-NIL, show basic operations 23 | (queue nil) ; Rule queue 24 | (rules-run 0)) ; Statistic 25 | 26 | (defun jtre-printer (j st ignore) 27 | (format st "" (jtre-title j))) 28 | 29 | (defvar *JTRE* nil) 30 | 31 | (defmacro With-Jtre (jtre &rest forms) 32 | `(let ((*JTRE* ,jtre)) ,@ forms)) 33 | 34 | (defun In-Jtre (jtre) (setq *JTRE* jtre)) 35 | 36 | (defmacro debugging-jtre (msg &rest args) 37 | `(when (jtre-debugging *JTRE*) (format t ,msg ,@args))) 38 | 39 | (defun create-jtre (title &key debugging) 40 | (let ((j (make-jtre 41 | :TITLE title 42 | :JTMS (create-jtms (list :JTMS-OF title) 43 | :NODE-STRING 'view-node) 44 | :DBCLASS-TABLE (make-hash-table :TEST #'eq) 45 | :DEBUGGING debugging))) 46 | (change-jtms (jtre-jtms j) 47 | :ENQUEUE-PROCEDURE 48 | #'(lambda (rule) (enqueue rule j))) 49 | j)) 50 | 51 | (defun change-jtre (jtre &key (debugging :NADA)) 52 | (unless (eq debugging :NADA) 53 | (setf (jtre-debugging jtre) debugging))) 54 | 55 | ;;;; Running JTRE 56 | 57 | (defun uassert! (fact &optional (just 'user)) 58 | (assert! fact just) ;; Do internal operation 59 | (run-rules *JTRE*)) ;; Run the rules 60 | 61 | (defun uassume! (fact reason) ;; Similar to UASSERT! 62 | (assume! fact reason *JTRE*) 63 | (run-rules *JTRE*)) 64 | 65 | (defun run-forms (forms &optional (*JTRE* *JTRE*)) 66 | (dolist (form forms) (eval form) (run-rules *JTRE*))) 67 | 68 | (defun run (&optional (*JTRE* *JTRE*)) ;; Toplevel driver function 69 | (format T "~%>>") 70 | (do ((form (read) (read))) 71 | ((member form '(quit stop exit abort)) nil) 72 | (format t "~%~A" (eval form)) 73 | (run-rules) 74 | (format t "~%>>"))) 75 | 76 | (defun show (&optional (*JTRE* *JTRE*) (stream *standard-output*)) 77 | (show-data *JTRE* stream) (show-rules *JTRE* stream)) 78 | 79 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jqrule.lisp: -------------------------------------------------------------------------------- 1 | ;-*- Mode: Lisp; Syntax: Common-lisp -*- 2 | 3 | ;;;; N-Queens rules, JTRE version 4 | ;;; Last edited 1/29/93, by KDF. 5 | 6 | ;;; Copyright (c) 1986 --- 1992 Kenneth D. Forbus, Northwestern University, 7 | ;;; Johan de Kleer and Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (contradiction 'Queens-capture *jtre*) 17 | 18 | (rule ((:IN (Queen ?column1 ?row1) :VAR ?Q1) 19 | (:IN (Queen ?column2 ?row2) :VAR ?Q2 20 | :TEST (not (or (= ?column1 ?column2) 21 | (queens-okay? ?column1 ?row1 22 | ?column2 ?row2))))) 23 | (rassert! Queens-capture (Death ?Q1 ?Q2))) 24 | 25 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jsaint-rules.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "utils.rkt") 4 | (require "jtms.rkt") 5 | (require "jtre.rkt") 6 | (provide (all-defined-out)) 7 | 8 | (define (jsaint-rules) 9 | 10 | ;;; expand pointers 11 | (rule ((:in (and-subgoals ?parent ?children) :var ?def)) 12 | (for/list ((child ?children)) 13 | (rlet ((?child (:eval child))) 14 | (rassert! (parent-of ?child ?parent :and) 15 | (:def-of-and ?def)) 16 | (rule ((:in (failed ?child) :var ?delinquent)) 17 | (rassert! (failed ?parent) 18 | (:and-failure ?def ?delinquent))))) 19 | (assert! `(solved ,?parent) 20 | `(:and-success ,?def 21 | ,@(map (lambda (child) 22 | `(solved ,child)) 23 | ?children)))) 24 | 25 | (rule ((:in (or-subgoals ?parent ?children) :var ?def 26 | :test (not (null? ?children)))) 27 | (for/list ((child ?children)) 28 | (rlet ((?child (:eval child))) 29 | (rassert! (parent-of ?child ?parent :or) 30 | (:def-of-or ?def)) 31 | (rule ((:in (solved ?child) :var ?winner)) 32 | (rassert! (solved ?parent) 33 | (:or-success ?winner ?def))))) 34 | (assert! `(failed ,?parent) 35 | `(:or-failure ,?def 36 | ,@(map (lambda (child) 37 | `(failed ,child)) 38 | ?children)))) 39 | 40 | (rule ((:in (parent-of ?child ?parent ?type) :var ?lineage)) 41 | (rassert! (relevant ?child) 42 | (:still-working-on (open ?parent) ?lineage))) 43 | 44 | (rule ((:in (solution-of ?problem ?answer) :var ?found)) 45 | (rassert! (solved ?problem) (:found-answer ?found))) 46 | 47 | (rule ((:in (or-subgoals (integrate ?expr) nil) :var ?no-ideas)) 48 | (rassert! (failed (integrate ?expr)) (:no-methods ?no-ideas))) 49 | 50 | (rule ((:in (solved ?problem))) ;; can only happen once 51 | (retract! `(open ,?problem) ':expand-agenda-item #t)) 52 | 53 | (rule ((:in (failed ?problem))) 54 | (retract! `(open ,?problem) ':expand-agenda-item #t)) 55 | 56 | ) 57 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jsrules.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; -*- 2 | 3 | ;;;; Basic rules for JSAINT. 4 | ;;;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1991-1993, Kenneth D. Forbus, Northwestern 7 | ;;; University, and Johan de Kleer, Xerox Corporation. 8 | ;;; All Rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;;; Expand pointers 17 | (rule ((:IN (AND-SUBGOALS ?parent ?children) :VAR ?def)) 18 | (dolist (child ?children) 19 | (rlet ((?child (:EVAL child))) 20 | (rassert! (PARENT-OF ?child ?parent :AND) 21 | (:DEF-OF-AND ?def)) 22 | (rule ((:IN (failed ?child) :VAR ?delinquent)) 23 | (rassert! (failed ?parent) 24 | (:AND-FAILURE ?def ?delinquent))))) 25 | (assert! `(solved ,?parent) 26 | `(:AND-SUCCESS ,?def 27 | ,@ (mapcar #'(lambda (child) 28 | `(SOLVED ,child)) 29 | ?children)))) 30 | 31 | (rule ((:IN (OR-SUBGOALS ?parent ?children) :VAR ?def 32 | :TEST ?children)) 33 | (dolist (child ?children) 34 | (rlet ((?child (:EVAL child))) 35 | (rassert! (PARENT-OF ?child ?parent :OR) 36 | (:DEF-OF-OR ?def)) 37 | (rule ((:IN (SOLVED ?child) :VAR ?winner)) 38 | (rassert! (SOLVED ?parent) 39 | (:OR-SUCCESS ?winner ?def))))) 40 | (assert! `(FAILED ,?parent) 41 | `(:OR-FAILURE ,?def 42 | ,@ (mapcar #'(lambda (child) 43 | `(FAILED ,child)) 44 | ?children)))) 45 | 46 | (rule ((:IN (PARENT-OF ?child ?parent ?type) :VAR ?lineage)) 47 | (rassert! (RELEVANT ?child) 48 | (:STILL-WORKING-ON (OPEN ?parent) ?lineage))) 49 | 50 | (rule ((:IN (SOLUTION-OF ?problem ?answer) :VAR ?found)) 51 | (rassert! (SOLVED ?problem) (:FOUND-ANSWER ?found))) 52 | 53 | (rule ((:IN (OR-SUBGOALS (Integrate ?expr) NIL) :VAR ?no-ideas)) 54 | (rassert! (FAILED (Integrate ?expr)) (:NO-METHODS ?no-ideas))) 55 | 56 | (rule ((:IN (SOLVED ?problem))) ;; Can only happen once 57 | (retract! `(OPEN ,?problem) :EXPAND-AGENDA-ITEM t)) 58 | 59 | (rule ((:IN (FAILED ?problem))) 60 | (retract! `(OPEN ,?problem) :EXPAND-AGENDA-ITEM t)) 61 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jtest.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Simple shakedown procedure for JTRE 4 | ;;;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1988-1992, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun shakedown-jtre () 17 | (in-jtre (create-jtre "Test One" :debugging t)) 18 | (dolist (form '((rule ((:INTERN (foo ?x) :VAR ?f :TEST (numberp ?x)) 19 | (:INTERN (bar ?y) :VAR ?g :TEST (numberp ?y))) 20 | (rassert! (mumble ?x ?y) (Test-intern ?f ?g))) 21 | (format t "~% :INTERN rule defined okay.") 22 | (rule ((:IN (foo ?x) :VAR ?f 23 | :TEST (not (numberp ?x))) 24 | (:IN (bar ?y) :VAR ?g 25 | :TEST (not (numberp ?y)))) 26 | (rassert! (grumble ?x ?y) 27 | (:TEST-in ?f ?g))) 28 | (format t "~% :IN rule defined okay.") 29 | (referent '(foo 1) t) 30 | (cond ((fetch '(foo 1)) 31 | (format t "~% Referent worked okay.")) 32 | (t (error "Referent failed."))) 33 | (referent '(bar 1) t) 34 | (run-rules) 35 | (format t "~% No errors during attempted rule execution.") 36 | (cond ((fetch '(mumble 1 1)) 37 | (format t "~%:INTERN rule fired okay.")) 38 | (t (error "~% :INTERN rule failed to fire."))) 39 | (referent '(foo a) t) 40 | (referent '(bar a) t) 41 | (run-rules) 42 | (when (some #'(lambda (fact) (in? fact)) 43 | (fetch '(grumble ?p ?q))) 44 | (format t "~%Premature triggering of :IN rule.")) 45 | (uassume! '(foo a) :USER) 46 | (uassume! '(bar a) :USER) 47 | (cond ((in? '(grumble a a)) 48 | (format t "~% :IN rule worked okay.")) 49 | (t (format t "~%:IN rule failed to fire."))) 50 | (uassume! '(foo 1) :USER) 51 | (uassume! '(bar 1) :USER) 52 | (unless (in? '(mumble 1 1)) 53 | (format t "~% Reference or JTMS failure."))) 54 | :OKAY) 55 | (print (eval form)))) 56 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jtest.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "utils.rkt") 4 | (require "jtms.rkt") 5 | (require "jtre.rkt") 6 | 7 | (define (shakedown-jtre) 8 | (in-jtre (create-jtre "Test One" #:debugging #t)) 9 | (rule ((:intern (foo ?x) :var ?f :test (number? ?x)) 10 | (:intern (bar ?y) :var ?g :test (number? ?y))) 11 | (rassert! (mumble ?x ?y) (Test-intern ?f ?g))) 12 | (printf "\n :intern rule defined okay.") 13 | (rule ((:in (foo ?x) :var ?f 14 | :test (not (number? ?x))) 15 | (:in (bar ?y) :var ?g 16 | :test (not (number? ?y)))) 17 | (rassert! (grumble ?x ?y) 18 | (:test-in ?f ?g))) 19 | (printf "\n :in rule defined okay.") 20 | (referent '(foo 1) #t) 21 | (cond ((not (null? (fetch '(foo 1)))) 22 | (printf "\n Referent worked okay.")) 23 | (else (error "Referent failed."))) 24 | (referent '(bar 1) #t) 25 | (run-rules) 26 | (printf "\n No errors during attempted rule execution.") 27 | (cond ((not (null? (fetch '(mumble 1 1)))) 28 | (printf "\n:intern rule fired okay.")) 29 | (else (printf "\n :intern rule failed to fire."))) 30 | (referent '(foo a) #t) 31 | (referent '(bar a) #t) 32 | (run-rules) 33 | (when (ormap (lambda (fact) (in? fact)) 34 | (fetch '(grumble ?p ?q))) 35 | (printf "\n%Premature triggering of :in rule.")) 36 | (uassume! '(foo a) ':user) 37 | (uassume! '(bar a) ':user) 38 | (cond ((in? '(grumble a a)) 39 | (printf "\n :in rule worked okay.")) 40 | (else (printf "\n:in rule failed to fire."))) 41 | (uassume! '(foo 1) ':user) 42 | (uassume! '(bar 1) ':user) 43 | (unless (in? '(mumble 1 1)) 44 | (printf "\n Reference or JMS failure.")) 45 | ':okay) 46 | 47 | (shakedown-jtre) 48 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jtms-ex.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; -*- 2 | 3 | ;;;; Examples for Justification-based TMS 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun get-node (datum jtms) 17 | (dolist (node (jtms-nodes jtms)) 18 | (if (equal datum (tms-node-datum node)) (return node)))) 19 | 20 | (defun get-justification (num jtms) 21 | (dolist (just (jtms-justs jtms)) 22 | (if (= num (just-index just)) (return just)))) 23 | 24 | (proclaim '(special na nb nc nd ne nf ng contra *jtms*)) 25 | 26 | (defun ex1 () 27 | (setq *jtms* (create-jtms "Simple Example" :debugging T) 28 | na (tms-create-node *jtms* 'a :assumptionp T) 29 | nb (tms-create-node *jtms* 'b :assumptionp T) 30 | nc (tms-create-node *jtms* 'c :assumptionp T) 31 | nd (tms-create-node *jtms* 'd :assumptionp T) 32 | ne (tms-create-node *jtms* 'e :assumptionp T) 33 | nf (tms-create-node *jtms* 'f :assumptionp T) 34 | ng (tms-create-node *jtms* 'g :assumptionp T)) 35 | (justify-node 'j1 nf (list na nb)) 36 | (justify-node 'j2 ne (list nb nc)) 37 | (justify-node 'j3 ng (list na ne)) 38 | (justify-node 'j4 ng (list nd ne)) 39 | (enable-assumption na) 40 | (enable-assumption nb) 41 | (enable-assumption nc) 42 | (enable-assumption nd)) 43 | 44 | (defun ex2 () ;; uses Ex1 to test the contradiction stuff. 45 | (setq contra (tms-create-node *jtms* 'Loser :contradictoryp T)) 46 | (justify-node 'j5 contra (list ne nf))) 47 | 48 | (defun ex3 () 49 | (setq *jtms* (create-jtms "Multiple support example") 50 | assumption-a (tms-create-node *jtms* 'A :assumptionp T) 51 | assumption-c (tms-create-node *jtms* 'C :assumptionp T) 52 | assumption-e (tms-create-node *jtms* 'E :assumptionp T) 53 | node-h (tms-create-node *jtms* 'h)) 54 | (enable-assumption assumption-a) 55 | (enable-assumption assumption-c) 56 | (enable-assumption assumption-e) 57 | (justify-node 'R1 node-h (list assumption-c assumption-e)) 58 | (setq node-g (tms-create-node *jtms* 'g)) 59 | (justify-node 'R2 node-g (list assumption-a assumption-c)) 60 | (setq contradiction (tms-create-node *jtms* 61 | 'CONTRADICTION :contradictoryp T)) 62 | (justify-node 'R3 contradiction (list node-g))) 63 | 64 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jtms-ex.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "jtms.rkt") 4 | 5 | (define j (create-jtms "hello")) 6 | (tms-create-node j 'a) 7 | 8 | (define hello-jtms (create-jtms "hello again" #:debugging #t)) 9 | (debugging-jtms hello-jtms "hello from jtms") 10 | 11 | (define (ex1) 12 | (define *jtms* (create-jtms "Simple Example" #:debugging #t)) 13 | (define na (tms-create-node *jtms* 'a #:assumptionp #t)) 14 | (define nb (tms-create-node *jtms* 'b #:assumptionp #t)) 15 | (define nc (tms-create-node *jtms* 'c #:assumptionp #t)) 16 | (define nd (tms-create-node *jtms* 'd #:assumptionp #t)) 17 | (define ne (tms-create-node *jtms* 'e #:assumptionp #t)) 18 | (define nf (tms-create-node *jtms* 'f #:assumptionp #t)) 19 | (define ng (tms-create-node *jtms* 'g #:assumptionp #t)) 20 | 21 | (justify-node 'j1 nf (list na nb)) 22 | (justify-node 'j2 ne (list nb nc)) 23 | (justify-node 'j3 ng (list na ne)) 24 | (justify-node 'j4 ng (list nd ne)) 25 | 26 | (enable-assumption na) 27 | (enable-assumption nb) 28 | (enable-assumption nc) 29 | (enable-assumption nd) 30 | 31 | (explore-network ng) 32 | (explore-network nf) 33 | 34 | (define contra (tms-create-node *jtms* 'Loser #:contradictoryp #t)) 35 | (justify-node 'j5 contra (list ne nf)) 36 | 37 | ) 38 | 39 | (define (ex3) 40 | (define *jtms* (create-jtms "Multiple support example")) 41 | (define assumption-a (tms-create-node *jtms* 'A #:assumptionp #t)) 42 | (define assumption-c (tms-create-node *jtms* 'C #:assumptionp #t)) 43 | (define assumption-e (tms-create-node *jtms* 'E #:assumptionp #t)) 44 | (define node-h (tms-create-node *jtms* 'h)) 45 | (enable-assumption assumption-a) 46 | (enable-assumption assumption-c) 47 | (enable-assumption assumption-e) 48 | (justify-node 'R1 node-h (list assumption-c assumption-e)) 49 | (define node-g (tms-create-node *jtms* 'g)) 50 | (justify-node 'R2 node-g (list assumption-a assumption-c)) 51 | (define contradiction (tms-create-node *jtms* 52 | 'CONTRADICTION #:contradictoryp #t)) 53 | (justify-node 'R3 contradiction (list node-g))) 54 | 55 | (ex1) 56 | (ex3) 57 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/jtre.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; -*- 2 | 3 | ;;;; JTRE -- a version of TRE which uses the JTMS 4 | ;;; Last Edited, 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1992, Kenneth D. Forbus, Northwestern University, 7 | ;;; Johan de Kleer and Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *jtre-path* 17 | (make-bps-path "jtms")) 18 | 19 | (defvar *jtre-files* 20 | '("jtms" ;; JTMS 21 | "jinter" ;; Interface 22 | "jdata" ;; Database 23 | "jrules" ;; Rule system 24 | "unify" ;; Unifier 25 | "funify")) ;; Open-coding unification 26 | 27 | (setq *jqueens-files* 28 | '("jqueens" ;; JTRE version of N-queens puzzle 29 | "jqrule")) ;; Contradiction detection rule 30 | 31 | (setq *jsaint-files* 32 | '("jsaint" ;; JSAINT main program 33 | "match" ;; math-oriented pattern matcher 34 | "simplify" ;; Algebraic simplifier 35 | ;; These two files can only be compiled after a JSAINT 36 | ;; has been created: 37 | "jsrules" ;; Bookkeeping rules 38 | "jsops" ;; Sample integration library 39 | )) 40 | 41 | (defun compile-jtre () 42 | (compile-load-files *jtre-files* *jtre-path*)) 43 | 44 | (defun compile-jqueens () 45 | (unless (and (boundp '*jtre*) 46 | (not (null *jtre*))) 47 | (in-jtre (create-jtre "Dummy"))) 48 | (compile-load-files *jqueens-files* *jtre-path*)) 49 | 50 | (defun compile-jsaint () 51 | (compile-load-files '("jsaint" "match" "simplify") *jtre-path*) 52 | (unless (and (boundp '*jsaint*) 53 | (not (null *jsaint*))) 54 | (create-jsaint "Dummy" nil)) 55 | (compile-load-files '("jsrules" "jsops") *jtre-path*)) 56 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/logic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | (struct interval 4 | (s p) 5 | #:transparent) 6 | 7 | ;;;Belief Manipulations;;;;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (define (noti i1) 11 | (interval (interval-p i1) 12 | (interval-s i1))) 13 | 14 | (define (sumlst lst) 15 | (let ((x 0)) 16 | (map (lambda (y) 17 | (set! x 18 | (+ y x))) 19 | lst) 20 | x)) 21 | 22 | (define (maxlst lst) 23 | (cond 24 | ((empty? lst) -1) ;;assuming lst has non-negative numbers only 25 | (else (let ((temp_max (maxlst (rest lst)))) 26 | (max (car lst) 27 | temp_max))))) 28 | 29 | (define (andi intervals) 30 | (interval (max 0 31 | (+ (sumlst (for/list ((i1 intervals)) 32 | (interval-s i1))) 33 | (- 1 34 | (length intervals)))) 35 | (maxlst (for/list ((i1 intervals)) 36 | (interval-p i1))))) 37 | 38 | 39 | (define (ori . intervals) 40 | (interval (maxlst (for/list ((i1 intervals)) 41 | (interval-s i1))) 42 | (max 0 43 | (+ (sumlst (for/list ((i1 intervals)) 44 | (interval-p i1))) 45 | (- 1 46 | (length intervals)))))) 47 | 48 | (define (impli i1 s) ;; antecedent i1, support for implication s 49 | (interval (* (interval-s i1) (interval-s s)) (* (interval-s i1) (interval-p s)))) 50 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/my.lisp: -------------------------------------------------------------------------------- 1 | (bps-load-file (make-bps-path "jtms") "jtre" :action :compile) 2 | (compile-jtre) 3 | (bps-load-file (make-bps-path "jtms") "jtms" :action :compile) 4 | 5 | (bps-load-file (make-bps-path "jtms") "jtms-ex" :action :compile) 6 | (ex1) 7 | (ex2) 8 | (ex3) 9 | 10 | (bps-load-file (make-bps-path "jtms") "jqueens" :action :compile) 11 | (test-queens 1 8) 12 | 13 | (setup-queens-puzzle 2 t) 14 | (change-jtms (jtre-jtms *jtre*) :debugging t) 15 | (assume! '(queen 1 1) '(try queen 1 1)) 16 | (assume! '(queen 2 1) '(try queen 2 1)) 17 | (run-rules) 18 | (assume! '(queen 2 2) '(try queen 2 2)) 19 | (run-rules) 20 | 21 | (bps-load-file (make-bps-path "jtms") "jtest" :action :compile) 22 | (shakedown-jtre) 23 | 24 | (bps-load-file (make-bps-path "jtms") "dds" :action :compile) 25 | (test-dd-search) 26 | 27 | (bps-load-file (make-bps-path "jtms") "sudoku" :action :compile) 28 | (solve-sudoku *easy-puzzle* :debugging t) 29 | 30 | (bps-load-file (make-bps-path "jtms") "match" :action :compile) 31 | (bps-load-file (make-bps-path "jtms") "simplify" :action :compile) 32 | (bps-load-file (make-bps-path "jtms") "jsaint" :action :compile) 33 | (try-jsaint '(integrate (integral x x))) 34 | (try-jsaint problem2) 35 | (explain-result) 36 | (try-jsaint '(integrate (integral (+ (* 3 x) (cos (* 1.1 x))) x))) 37 | (explain-result) 38 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/sudoku-rule.lisp: -------------------------------------------------------------------------------- 1 | (in-package :COMMON-LISP-USER) 2 | 3 | (contradiction 'Conflict *jtre*) 4 | 5 | (rule ((:IN (C ?v1 ?r1 ?c1 ?u1) :VAR ?a) 6 | (:IN (C ?v2 ?r2 ?c2 ?u2) :VAR ?b 7 | :TEST (and (= ?v1 ?v2) 8 | (or (= ?r1 ?r2) (= ?c1 ?c2) (= ?u1 ?u2)) 9 | (not (and (= ?r1 ?r2) (= ?c1 ?c2) (= ?u1 ?u2)))))) 10 | (rassert! Conflict (Death ?a ?b))) 11 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/sudoku.lisp: -------------------------------------------------------------------------------- 1 | (in-package :COMMON-LISP-USER) 2 | 3 | ;;; Statistics 4 | (defvar *n-assumptions* 0) 5 | (defvar *placements* nil) 6 | 7 | (proclaim '(special *JTRE*)) 8 | 9 | (defvar *sudoku-rules-file* 10 | (make-bps-source-file-name *jtre-path* "sudoku-rule")) 11 | 12 | (defvar *puzzle* 13 | '#( 14 | #(4 0 0 0 0 0 8 0 5) 15 | #(0 3 0 0 0 0 0 0 0) 16 | #(0 0 0 7 0 0 0 0 0) 17 | #(0 2 0 0 0 0 0 6 0) 18 | #(0 0 0 0 8 0 4 0 0) 19 | #(0 0 0 0 1 0 0 0 0) 20 | #(0 0 0 6 0 3 0 7 0) 21 | #(5 0 0 2 0 0 0 0 0) 22 | #(1 0 4 0 0 0 0 0 0) 23 | )) 24 | 25 | (defvar *easy-puzzle* 26 | '#( 27 | #(0 0 3 0 2 0 6 0 0) 28 | #(9 0 0 3 0 5 0 0 1) 29 | #(0 0 1 8 0 6 4 0 0) 30 | #(0 0 8 1 0 2 9 0 0) 31 | #(7 0 0 0 0 0 0 0 8) 32 | #(0 0 6 7 0 8 2 0 0) 33 | #(0 0 2 6 0 9 5 0 0) 34 | #(8 0 0 2 0 3 0 0 9) 35 | #(0 0 5 0 1 0 3 0 0) 36 | )) 37 | 38 | (defun calc-unit (i j) 39 | (let* ((x (- i 1)) 40 | (y (- j 1)) 41 | (m (floor x 3)) 42 | (n (floor y 3))) 43 | (+ 1 n (* m 3)))) 44 | 45 | (defun calc-unit-check () 46 | (loop for i from 1 to 9 do 47 | (loop for j from 1 to 9 do 48 | (format t "~D " (calc-unit i j))) 49 | (format t "~%"))) 50 | 51 | (defun name (v i j) 52 | (list 'C v i j (calc-unit i j))) 53 | 54 | (defun create-puzzle (puzzle) 55 | (apply #'concatenate 'list 56 | (loop for i from 1 to 9 collect 57 | (loop for j from 1 to 9 collect 58 | (let ((x (elt (elt puzzle (- i 1)) (- j 1)))) 59 | (if (= x 0) 60 | (loop for v from 1 to 9 collect (name v i j)) 61 | (list (name x i j)))))))) 62 | 63 | (defun rows () 64 | (loop for i from 1 to 9 collect 65 | (loop for j from 1 to 9 collect 66 | (cons i j)))) 67 | 68 | (defun cols () 69 | (loop for i from 1 to 9 collect 70 | (loop for j from 1 to 9 collect 71 | (cons j i)))) 72 | 73 | (defun units () 74 | (apply #'concatenate 'list 75 | (loop for m from 0 to 2 collect 76 | (loop for n from 0 to 2 collect 77 | (apply #'concatenate 'list 78 | (loop for i from 0 to 2 collect 79 | (loop for j from 0 to 2 collect 80 | (cons (+ i (* m 3) 1) (+ j (* n 3) 1))))))))) 81 | 82 | (defun namec (v ij) 83 | (name v (car ij) (cdr ij))) 84 | 85 | (defun show-solution () 86 | (let ((r (remove-if-not #'in? (fetch '(C ?v ?i ?j ?u))))) 87 | (format t "~%~A~%" r) 88 | 89 | (loop for i from 1 to 9 do 90 | (loop for j from 1 to 9 do 91 | (loop for v from 1 to 9 92 | when (member (name v i j) r :TEST #'equal) do 93 | (format t "~D " v))) 94 | (format t "~%")) 95 | 96 | (break) 97 | )) 98 | 99 | (defun solve-sudoku (puzzle &key (debugging t)) 100 | (in-JTRE (create-jtre "Sudoku" 101 | :DEBUGGING debugging)) 102 | (load *sudoku-rules-file*) 103 | (dd-init) 104 | (DD-Search (create-puzzle puzzle) '(show-solution))) 105 | 106 | 107 | ;;(solve-sudoku *easy-puzzle* :debugging t) 108 | ;;(solve-sudoku *puzzle* :debugging t) 109 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/tinytms-ex.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "tinytms.rkt") 4 | 5 | (define tms (make-tms "hello")) 6 | (tms-create-node tms 'a) 7 | 8 | (define hello-tms (make-tms "hello again" #:debugging #t)) 9 | (debugging-tms hello-tms "hello from tms") 10 | 11 | (define (ex1) 12 | (define *tms* (make-tms "Simple Example" #:debugging #t)) 13 | (define na (tms-create-node *tms* 'a #:assumption? #t)) 14 | (define nb (tms-create-node *tms* 'b #:assumption? #t)) 15 | (define nc (tms-create-node *tms* 'c #:assumption? #t)) 16 | (define nd (tms-create-node *tms* 'd #:assumption? #t)) 17 | (define ne (tms-create-node *tms* 'e #:assumption? #t)) 18 | (define nf (tms-create-node *tms* 'f #:assumption? #t)) 19 | (define ng (tms-create-node *tms* 'g #:assumption? #t)) 20 | 21 | (justify-node 'j1 nf (list na nb)) 22 | (justify-node 'j2 ne (list nb nc)) 23 | (justify-node 'j3 ng (list na ne)) 24 | (justify-node 'j4 ng (list nd ne)) 25 | 26 | (enable-assumption na) 27 | (enable-assumption nb) 28 | (enable-assumption nc) 29 | (enable-assumption nd) 30 | 31 | (why-node ng) 32 | (why-node nf) 33 | 34 | (define contra (tms-create-node *tms* 'Loser #:contradictory? #t)) 35 | (justify-node 'j5 contra (list ne nf)) 36 | 37 | ) 38 | 39 | (define (ex3) 40 | (define *tms* (make-tms "Multiple support example")) 41 | (define assumption-a (tms-create-node *tms* 'A #:assumption? #t)) 42 | (define assumption-c (tms-create-node *tms* 'C #:assumption? #t)) 43 | (define assumption-e (tms-create-node *tms* 'E #:assumption? #t)) 44 | (define node-h (tms-create-node *tms* 'h)) 45 | (enable-assumption assumption-a) 46 | (enable-assumption assumption-c) 47 | (enable-assumption assumption-e) 48 | (justify-node 'R1 node-h (list assumption-c assumption-e)) 49 | (define node-g (tms-create-node *tms* 'g)) 50 | (justify-node 'R2 node-g (list assumption-a assumption-c)) 51 | (define contradiction (tms-create-node *tms* 52 | 'CONTRADICTION #:contradictory? #t)) 53 | (justify-node 'R3 contradiction (list node-g))) 54 | 55 | (ex1) 56 | (ex3) 57 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/unify.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Variables and unification 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1988-1992, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun variable? (x) 17 | (and (symbolp x) ;A symbol whose first character is "?" 18 | (char= #\? (elt (symbol-name x) 0)))) 19 | 20 | (defun unify (a b &optional (bindings nil)) 21 | (cond ((equal a b) bindings) 22 | ((variable? a) (unify-variable a b bindings)) 23 | ((variable? b) (unify-variable b a bindings)) 24 | ((or (not (listp a)) (not (listp b))) :FAIL) 25 | ((not (eq :FAIL (setq bindings 26 | (unify (car a) (car b) bindings)))) 27 | (unify (cdr a) (cdr b) bindings)) 28 | (t :FAIL))) 29 | 30 | (defun unify-variable (var exp bindings &aux val) 31 | ;; Must distinguish no value from value of nil 32 | (setq val (assoc var bindings)) 33 | (cond (val (unify (cdr val) exp bindings)) 34 | ;; If safe, bind to 35 | ((free-in? var exp bindings) (cons (cons var exp) bindings)) 36 | (t :FAIL))) 37 | 38 | (defun free-in? (var exp bindings) 39 | ;; Returns nil if occurs in , assuming . 40 | (cond ((null exp) t) 41 | ((equal var exp) nil) 42 | ((variable? exp) 43 | (let ((val (assoc exp bindings))) 44 | (if val 45 | (free-in? var (cdr val) bindings) 46 | t))) 47 | ((not (listp exp)) t) 48 | ((free-in? var (car exp) bindings) 49 | (free-in? var (cdr exp) bindings)))) 50 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/unify.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define (variable? x) 6 | (and (symbol? x) 7 | (char=? #\? (string-ref (symbol->string x) 0)))) 8 | 9 | (define (unify a b [bindings '()]) 10 | (cond 11 | ((equal? a b) bindings) 12 | ((variable? a) (unify-variable a b bindings)) 13 | ((variable? b) (unify-variable b a bindings)) 14 | ((or (not (pair? a)) (not (pair? b))) ':fail) 15 | (else 16 | (let ((bindings (unify (car a) (car b) bindings))) 17 | (if (eq? ':fail bindings) 18 | ':fail 19 | (unify (cdr a) (cdr b) bindings)))))) 20 | 21 | (define (unify-variable var exp bindings) 22 | (let ((val (assoc var bindings))) 23 | (cond 24 | (val (unify (cdr val) exp bindings)) 25 | ((free-in? var exp bindings) (cons (cons var exp) bindings)) 26 | (else ':fail)))) 27 | 28 | (define (free-in? var exp bindings) 29 | ;; Returns #f if var occurs in exp, assuming bindings. 30 | (cond 31 | ((null? exp) #t) 32 | ((equal? var exp) #f) 33 | ((variable? exp) 34 | (let ((val (assoc exp bindings))) 35 | (if val 36 | (free-in? var (cdr val) bindings) 37 | #t))) 38 | ((not (pair? exp)) #t) 39 | ((free-in? var (car exp) bindings) 40 | (free-in? var (cdr exp) bindings)) 41 | (else #f))) 42 | -------------------------------------------------------------------------------- /src/main/lisp/jtms/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (all-defined-out)) 4 | 5 | (define-syntax-rule (push! val lst) ;; pushes val to list lst at first pos 6 | (set! lst (cons val lst))) 7 | (define-syntax-rule (pop! lst) ;; pops the first position 8 | (cond 9 | ((null? lst) '()) 10 | (else (let ((popped (car lst))) (set! lst (rest lst)) popped)))) 11 | 12 | (define-syntax-rule (inc! x) 13 | (begin 14 | (set! x (+ x 1)) 15 | x)) 16 | 17 | (define (sublis d x) 18 | (cond ((null? x) '()) 19 | ((pair? x) 20 | (cons (sublis d (car x)) 21 | (sublis d (cdr x)))) 22 | (else 23 | (let ((av (assoc x d))) 24 | (if av 25 | (cdr av) 26 | x))))) 27 | 28 | (define (atom? x) 29 | (not (pair? x))) 30 | 31 | (define (subst new old x) 32 | (cond ((null? x) '()) 33 | ((pair? x) 34 | (cons (subst new old (car x)) 35 | (subst new old (cdr x)))) 36 | ((eq? old x) new) 37 | (else x))) 38 | 39 | (define (cadr-if x) 40 | (and x (cadr x))) 41 | 42 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/abduction-ex.lisp: -------------------------------------------------------------------------------- 1 | (in-ltre (create-ltre "Abduction Test")) 2 | 3 | 4 | (rule ((:INTERN (son ?son of ?father) :var ?def)) 5 | (rassert! (:IMPLIES ?def (father ?father of ?son)) 6 | :EQUIVALENCE) 7 | (rassert! (:IMPLIES ?def (related ?son ?father)) :FAMILY) 8 | (rassert! (:IMPLIES ?def (related ?father ?son))) :FAMILY) 9 | 10 | (rule ((:INTERN (father ?father of ?son) :var ?def)) 11 | (rassert! (:IMPLIES ?def (son ?son of ?father)) 12 | :EQUIVALENCE) 13 | (rassert! (:IMPLIES ?def (related ?son ?father)) :FAMILY) 14 | (rassert! (:IMPLIES ?def (related ?father ?son))) :FAMILY) 15 | 16 | (rule ((:INTERN (brothers ?a ?b) :var ?def)) 17 | (rassert! (:IMPLIES ?def (brothers ?b ?a)) :EQUIVALENCE) 18 | (rassert! (:IMPLIES ?def (related ?a ?b)) :FAMILY) 19 | (rassert! (:IMPLIES ?def (related ?b ?a)) :FAMILY)) 20 | 21 | (rule ((:INTERN (uncle ?uncle of ?nephew) :var ?def)) 22 | (rassert! (:IMPLIES ?def (nephew ?nephew of ?uncle)) 23 | :EQUIVALENCE) 24 | (rassert! (:IMPLIES ?def (related ?nephew ?uncle)) :FAMILY) 25 | (rassert! (:IMPLIES ?def (related ?uncle ?nephew))) :FAMILY) 26 | 27 | (rule ((:INTERN (nephew ?nephew of ?uncle) :var ?def)) 28 | (rassert! (:IMPLIES ?def (uncle ?uncle of ?nephew)) 29 | :EQUIVALENCE) 30 | (rassert! (:IMPLIES ?def (related ?nephew ?uncle)) :FAMILY) 31 | (rassert! (:IMPLIES ?def (related ?uncle ?nephew))) :FAMILY) 32 | 33 | (rule ((:INTERN (brothers ?a ?b) :var ?brothers-def) 34 | (:INTERN (son ?c of ?a) :var ?son-def)) 35 | (rassert! (:IMPLIES (:AND ?brothers-def ?son-def) 36 | (uncle ?b of ?c)) 37 | :FAMILY)) 38 | 39 | (rule ((:INTERN (related ?a ?b) :var ?def)) 40 | (rassert! (:IMPLIES ?def 41 | (:OR (brothers ?a ?b) 42 | (father ?a of ?b) 43 | (son ?a of ?b) 44 | (uncle ?a of ?b) 45 | (nephew ?a of ?b))) 46 | :RELATED-SIMPLE-MINDED-GUESS)) 47 | 48 | (setq patterns '((son ?son of ?father) (father ?father of ?son) (brothers ?a ?b) (uncle ?a of ?b) (nephew ?a of ?b))) 49 | 50 | (needs '(father mohamed of aadel) :TRUE patterns) 51 | ; (((FATHER MOHAMED OF AADEL)) ((SON AADEL OF MOHAMED))) 52 | 53 | (sort-fact-sets (needs '(related mohamed aadel) :TRUE patterns)) 54 | ;(((BROTHERS AADEL MOHAMED)) 55 | ; ((BROTHERS MOHAMED AADEL)) 56 | ; ((FATHER AADEL OF MOHAMED)) 57 | ; ((FATHER MOHAMED OF AADEL)) 58 | ; ((NEPHEW AADEL OF MOHAMED)) 59 | ; ((NEPHEW MOHAMED OF AADEL)) 60 | ; ((SON AADEL OF MOHAMED)) 61 | ; ((SON MOHAMED OF AADEL)) 62 | ; ((UNCLE AADEL OF MOHAMED)) 63 | ; ((UNCLE MOHAMED OF AADEL))) 64 | 65 | (setq pattern-cost-list 66 | '(((son ?son of ?father) . 20) 67 | ((father ?father of ?son) . 10) 68 | ((brothers ?a ?b) . 30) 69 | ((uncle ?a of ?b) . 40) 70 | ((nephew ?a of ?b) . 50))) 71 | 72 | (labduce '(related mohamed aadel) :TRUE pattern-cost-list) 73 | ; (((FATHER MOHAMED OF AADEL)) . 10) -------------------------------------------------------------------------------- /src/main/lisp/ltms/abduction-simple.lisp: -------------------------------------------------------------------------------- 1 | (in-ltre (create-ltre "Abduction Simple Example")) 2 | 3 | (rassert! (:IMPLIES (:AND a b) c) :USER) 4 | (rassert! (:IMPLIES (:AND x y) a) :USER) 5 | (rassert! (:IMPLIES (:OR x y) b) :USER) 6 | (rassert! (:IMPLIES c d) :USER) 7 | 8 | #| 9 | (setq node (get-tms-node 'c)) 10 | (setq label :TRUE) 11 | (setq sets-1 (node-needs-1 node label)) 12 | (setq matching-patterns nil) 13 | (setq new-nodes (list node)) 14 | |# 15 | 16 | (needs 'c :TRUE) 17 | ; ((A B) (A Y) (A X) (X Y)) 18 | 19 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-ex.dot: -------------------------------------------------------------------------------- 1 | digraph { 2 | A->B [penwidth=1, color=black, arrowhead="vee"] 3 | A->C [penwidth=1, color=black, arrowhead="tee"] 4 | B->C [penwidth=1, color=black, arrowhead="tee"] 5 | E->D [penwidth=1, color=black, arrowhead="tee"] 6 | D->F [penwidth=1, color=black, arrowhead="vee"] 7 | C->G [penwidth=1, color=black, arrowhead="vee"] 8 | E->G [penwidth=1, color=black, arrowhead="vee"] 9 | A [style=filled, color=blue, fillcolor=lavender, shape=doublecircle]; 10 | B [style=filled, color=blue, fillcolor=lavender]; 11 | C [style=filled, color=red, fillcolor=mistyrose]; 12 | D [style=filled, color=blue, fillcolor=lavender]; 13 | E [style=filled, color=red, fillcolor=mistyrose, shape=doublecircle]; 14 | F [style=filled, color=blue, fillcolor=lavender, shape=doublecircle]; 15 | G [style=filled, color=red, fillcolor=mistyrose, shape=doublecircle]; 16 | } -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-ex.lisp: -------------------------------------------------------------------------------- 1 | (progn 2 | (new-carnival "toy example") 3 | (node + A :measured? t :top? t) 4 | (node + B) 5 | (node - C) 6 | (node + D) 7 | (node - E :measured? t :top? t) 8 | (node + F :measured? t) 9 | (node - G :measured? t) 10 | (edge + A B) 11 | (edge - A C) 12 | (edge - B C) 13 | (edge - E D) 14 | (edge + D F) 15 | (edge + C G) 16 | (edge + E G) 17 | ) 18 | (solve) 19 | (check-consistency) 20 | 21 | (what-node 'A) 22 | #| 23 | 1 A () Assumption 24 | |# 25 | 26 | (what-node 'B) 27 | #| 28 | 1 A+B () Assumption 29 | 2 A () Assumption 30 | 3 B (1 2) (:OR (:NOT A) B (:NOT A+B)) 31 | |# 32 | 33 | (what-node 'G) 34 | #| 35 | 1 C+G () Assumption 36 | 2 A-C () Assumption 37 | 3 A () Assumption 38 | 4 (:NOT C) (2 3) (:OR (:NOT A) (:NOT C) (:NOT A-C)) 39 | 5 (:NOT G) (1 4) (:OR C (:NOT G) (:NOT C+G)) 40 | |# 41 | 42 | #| 43 | ;; Contradiction 44 | (edge + A G) 45 | Contradiction found: 46 | 1 A-C 47 | 2 C+G 48 | 3 A+G 49 | 4 A 50 | ;; In slime, type :, then (tms-answer 3) 51 | 52 | (explain-node (find-node *ltms* 'A+G)) 53 | 1 C+G () Assumption 54 | 2 A-C () Assumption 55 | 3 A () Assumption 56 | 4 (:NOT C) (2 3) (:OR (:NOT A) (:NOT C) (:NOT A-C)) 57 | 5 (:NOT G) (1 4) (:OR C (:NOT G) (:NOT C+G)) 58 | 6 (:NOT A+G) (5 3) (:OR (:NOT A) G (:NOT A+G)) 59 | |# 60 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-ex.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jphmrst/bps/9beee6cb49a630a8f1e2ee665c0919b4d1b092ba/src/main/lisp/ltms/carnival-ex.png -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-from-dot.py: -------------------------------------------------------------------------------- 1 | import pydot 2 | 3 | val_colors = {'lavender':'+', 'mistyrose':'-', None: '?'} 4 | val_arrowheads = {'"vee"':'+', '"tee"':'-'} 5 | 6 | def read_graph(filename): 7 | graphs = pydot.graph_from_dot_file(filename) 8 | return graphs[0] 9 | 10 | def not_destination(n, g): 11 | for e in g.get_edges(): 12 | if e.get_destination()==n.get_name(): 13 | return False 14 | return True 15 | 16 | def print_node(n, g): 17 | val = val_colors[n.get_fillcolor()] 18 | name = n.get_name() 19 | measured = n.get_shape()=='doublecircle' 20 | top = not_destination(n, g) 21 | measured_opt = ":measured? t" if measured else "" 22 | top_opt = ":top? t" if top else "" 23 | print("(node %s %s %s %s)" % (val, name, measured_opt, top_opt)) 24 | 25 | def print_edge(e, g): 26 | val = val_arrowheads[e.get_arrowhead()] 27 | src = e.get_source() 28 | dst = e.get_destination() 29 | print("(edge %s %s %s)" % (val, src, dst)) 30 | 31 | def print_graph(g): 32 | for n in g.get_nodes(): print_node(n, g) 33 | for e in g.get_edges(): print_edge(e, g) 34 | 35 | def main(): 36 | import sys 37 | filename = sys.argv[1] 38 | g = read_graph(filename) 39 | print_graph(g) 40 | 41 | main() 42 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-load.lisp: -------------------------------------------------------------------------------- 1 | (bps-load-file (make-bps-path "ltms") "ltre" :action :compile) 2 | (compile-ltre) 3 | (bps-load-file (make-bps-path "ltms") "ltms" :action :compile) 4 | ;;do NOT load -- causes trouble with JTRE! 5 | ;;(bps-load-file (make-bps-path "ltms") "cltms" :action :compile) 6 | (bps-load-file (make-bps-path "ltms") "dds" :action :compile) 7 | (bps-load-file (make-bps-path "ltms") "carnival" :action :compile) 8 | (bps-load-file (make-bps-path "ltms") "carnival-ltre" :action :compile) 9 | (bps-load-file (make-bps-path "ltms") "carnival-ex" :action :compile) 10 | (bps-load-file (make-bps-path "ltms") "carnival-play" :action :compile) 11 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-ltre.lisp: -------------------------------------------------------------------------------- 1 | ;; inspired by 2 | ;; https://github.com/saezlab/CARNIVAL 3 | 4 | (defvar *node-labels*) 5 | (defvar *edge-labels*) 6 | 7 | (defun new-carnival (title &key (debugging t)) 8 | (setq *debug-dds* debugging) 9 | (in-LTRE (create-ltre (format nil "CARNIVAL ~A" title) :DEBUGGING debugging)) 10 | (carnival-rules) 11 | (setq *node-labels* '()) 12 | (setq *edge-labels* '())) 13 | 14 | (defun choices () 15 | (mapcar #'(lambda (e) 16 | (let ((src (caddr e)) 17 | (dst (cadddr e))) 18 | `((E + ,src ,dst) (E - ,src ,dst)))) 19 | *edge-labels*)) 20 | 21 | (defmacro node (val n &key (measured? nil) (top? nil)) 22 | `(progn 23 | (push (cons ',n ',val) *node-labels*) 24 | ,(if (or measured? top?) 25 | `(assert! 26 | ',(ecase val 27 | (+ `(V ,n)) 28 | (- `(:NOT (V ,n)))) 29 | :MEASURED) 30 | t))) 31 | 32 | (defmacro edge (val src dst) 33 | `(progn 34 | (push '(edge ,val ,src ,dst) *edge-labels*) 35 | ;;(assert! '(E ,val ,src ,dst) :GIVEN) 36 | )) 37 | 38 | (defun carnival-rules () 39 | (eval `(rule ((:TRUE (E + ?src ?dst))) 40 | (rassert! (:IMPLIES (E + ?src ?dst) 41 | (:AND (:IMPLIES (V ?src) (V ?dst)) 42 | (:IMPLIES (:NOT (V ?src)) (:NOT (V ?dst)))))))) 43 | 44 | (eval `(rule ((:TRUE (E - ?src ?dst))) 45 | (rassert! (:IMPLIES (E - ?src ?dst) 46 | (:AND (:IMPLIES (V ?src) (:NOT (V ?dst))) 47 | (:IMPLIES (:NOT (V ?src)) (V ?dst)))))))) 48 | 49 | (defun check-consistency (&aux c) 50 | (setq c t) 51 | (mapc #'(lambda (x) 52 | (let ((n (car x)) 53 | (val (cdr x))) 54 | (unless (ecase val 55 | (+ (true? `(V ,n))) 56 | (- (false? `(V ,n)))) 57 | (setq c nil) 58 | (format t "~%Node ~A inconsistent." n) 59 | (what-node n)))) 60 | *node-labels*) 61 | c) 62 | 63 | (defvar *solutions*) 64 | (defvar *n-consistent-solutions*) 65 | (defvar *n-inconsistent-solutions*) 66 | 67 | (defun show-solution () 68 | (let ((r (remove-if-not #'true? (fetch-global '(E ?val ?src ?dst))))) 69 | (format t "~%~A~%" r) 70 | (let ((c (check-consistency))) 71 | (if c 72 | (incf *n-consistent-solutions*) 73 | (incf *n-inconsistent-solutions*)) 74 | (when c 75 | (push r *solutions*) 76 | ;;(break) 77 | )))) 78 | 79 | (defun solve () 80 | (setq *solutions* '()) 81 | (setq *n-consistent-solutions* 0) 82 | (setq *n-inconsistent-solutions* 0) 83 | (dd-search (assert-choices! (choices)) '(show-solution)) 84 | (assert-solution! (car *solutions*)) 85 | ) 86 | 87 | (defun assert-solution! (solution) 88 | (mapc #'(lambda (fact) (assert! fact :SOLUTION)) solution)) 89 | 90 | (defun node-of (n) 91 | (let ((r (referent `(V ,n) nil))) 92 | (and r (datum-tms-node r)))) 93 | 94 | (defun what-node (n) 95 | (let ((node (node-of n))) 96 | (and node (why-node node)))) 97 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-play.lisp: -------------------------------------------------------------------------------- 1 | (new-carnival "test") 2 | (load "../ltms/carnival-test.lisp") 3 | (solve) 4 | (check-consistency) 5 | (what-node 'NS1) 6 | (what-node 'PIK3CA) 7 | (what-node 'MYC) 8 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival-test.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jphmrst/bps/9beee6cb49a630a8f1e2ee665c0919b4d1b092ba/src/main/lisp/ltms/carnival-test.png -------------------------------------------------------------------------------- /src/main/lisp/ltms/carnival.lisp: -------------------------------------------------------------------------------- 1 | ;; inspired by 2 | ;; https://github.com/saezlab/CARNIVAL 3 | 4 | (defvar *node-labels*) 5 | 6 | (defun new-carnival (title) 7 | (setq *ltms* (create-ltms (format nil "CARNIVAL ~A" title))) 8 | (setq *node-labels* '())) 9 | 10 | (defmacro node (val n &key (measured? nil) (top? nil)) 11 | (let ((label (ecase val (+ :TRUE) (- :FALSE)))) 12 | `(let ((node (tms-create-node *ltms* ',n :ASSUMPTIONP t))) 13 | (push (cons ',n ',label) *node-labels*) 14 | ,(if top? 15 | `(enable-assumption node ',label) 16 | t)))) 17 | 18 | #| 19 | (defmacro node (val n &key (measured? nil) (top? nil)) 20 | (let ((label (ecase val (+ :TRUE) (- :FALSE)))) 21 | `(progn 22 | (push (cons ',n ',label) *node-labels*) 23 | ,(if top? 24 | `(let ((node (tms-create-node *ltms* ',n :ASSUMPTIONP t))) 25 | (enable-assumption node ',label) 26 | node) 27 | `(tms-create-node *ltms* ',n))))) 28 | |# 29 | 30 | (defun edge-name (val src dst) 31 | (read-from-string (concatenate 'string (string src) (string val) (string dst)))) 32 | 33 | (defmacro edge (val src dst) 34 | (let ((edge-name (edge-name val src dst))) 35 | `(let ((edge (tms-create-node *ltms* ',edge-name :ASSUMPTIONP t))) 36 | (enable-assumption edge :TRUE) 37 | ,(if (ecase val (+ t) (- nil)) 38 | `(compile-formula 39 | *ltms* 40 | '(:IMPLIES ,edge-name 41 | (:AND 42 | (:IMPLIES ,src ,dst) 43 | (:IMPLIES (:NOT ,src) (:NOT ,dst))))) 44 | `(compile-formula 45 | *ltms* 46 | '(:IMPLIES ,edge-name 47 | (:AND 48 | (:IMPLIES ,src (:NOT ,dst)) 49 | (:IMPLIES (:NOT ,src) ,dst)))))))) 50 | 51 | #| 52 | (defmacro edge (val src dst) 53 | (let ((edge-name (edge-name val src dst))) 54 | (if (ecase val (+ t) (- nil)) 55 | `(compile-formula 56 | *ltms* 57 | '(:AND 58 | (:IMPLIES ,src ,dst) 59 | (:IMPLIES (:NOT ,src) (:NOT ,dst)))) 60 | `(compile-formula 61 | *ltms* 62 | '(:AND 63 | (:IMPLIES ,src (:NOT ,dst)) 64 | (:IMPLIES (:NOT ,src) ,dst)))))) 65 | |# 66 | 67 | (defun solve () 68 | 'ok) 69 | 70 | (defun check-consistency (&aux c) 71 | (setq c t) 72 | (mapc #'(lambda (x) 73 | (let ((n (car x)) 74 | (v (cdr x))) 75 | (let ((node (find-node *ltms* n))) 76 | (unless (equal v (tms-node-label node)) 77 | (setq c nil) 78 | (format t "~%Node ~A inconsistent." n) 79 | (explain-node node))))) 80 | *node-labels*) 81 | c) 82 | 83 | (defun what-node (n) 84 | (explain-node (find-node *ltms* n))) 85 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/dds.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Syntax: Common-lisp; -*- 2 | ;;;; Modified: forbus on Thurs Apr 18 8:58:35 1996 3 | 4 | ;;;; Dependency-directed search facility 5 | ;;;; Last Edited 4/27/94, by KDF 6 | 7 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 8 | ;;; and Johan de Kleer, the Xerox Corporation. 9 | ;;; All rights reserved. 10 | 11 | ;;; See the file legal.txt for a paragraph stating scope of permission 12 | ;;; and disclaimer of warranty. The above copyright notice and that 13 | ;;; paragraph must be included in any separate copy of this file. 14 | 15 | (in-package :COMMON-LISP-USER) 16 | 17 | (defvar *debug-dds* nil) 18 | 19 | (defmacro debug-dds (str &rest args) 20 | `(if *debug-dds* (format t ,str ,@ args))) 21 | 22 | (defun DD-Search (choice-sets end &aux answer marker choices) 23 | (when (null choice-sets) 24 | (debug-dds "~% DDS: Found solution.") 25 | (eval end) 26 | (return-from DD-Search nil)) 27 | (setq marker (list 'DDS (car choice-sets))) 28 | (setq choices (car choice-sets)) 29 | (dolist (choice choices) 30 | (debug-dds "~% DDS: Considering ~A..." choice) 31 | (cond ((false? choice) ;skip if known loser 32 | (debug-dds "~% DDS: ~A already known nogood." choice)) 33 | ((true? choice) ;continue if known 34 | (debug-dds "~% DDS: ~A true by implication." choice) 35 | (DD-Search (cdr choice-sets) end) 36 | (return nil)) 37 | (t (debug-dds "~% DDS: Assuming ~A." choice) 38 | (with-Contradiction-Handler (ltre-ltms *ltre*) 39 | #'(lambda (clauses ltms &aux asns) 40 | (debug-dds "~% DDS: Entering handler for ~A with ~A~A." 41 | choice clauses 42 | (mapcar #'(lambda (c) (violated-clause? c)) 43 | clauses)) 44 | (dolist (cl clauses) 45 | (setq asns (assumptions-of-clause cl)) 46 | (debug-dds "~% DDS: Assumptions are: ~A" 47 | (mapcar #'view-node asns)) 48 | (dolist (asn asns) 49 | (when (or (equal choice (view-node asn)) 50 | (and (listp choice) (eq (car choice) :NOT) 51 | (equal (cadr choice) (view-node asn)))) 52 | (throw marker 53 | (cons :LOSERS ;; Assign labels before any retraction 54 | ;; Failure to do so can result in incorrect nogoods. 55 | (mapcar #'signed-view-node 56 | (delete asn asns)))))))) 57 | (setq answer (catch marker 58 | (Assuming (list choice) *ltre* 59 | (run-rules *ltre*) 60 | (DD-Search (cdr choice-sets) end)))) 61 | (when (and (listp answer) 62 | (eq (car answer) :LOSERS)) 63 | (debug-dds "~% DDS: ~A inconsistent with ~A." 64 | choice (mapcar #'view-node (cdr answer))) 65 | (assert! `(:NOT (:AND ,choice 66 | ,@ (cdr answer))) 67 | :DD-SEARCH-NOGOOD))))))) 68 | 69 | ;;;; A familiar example 70 | 71 | (defun Test-DD-search (&optional (debugging? t)) 72 | (in-LTRE (create-ltre "DDS Test" :DEBUGGING debugging?)) 73 | (eval '(rule ((:TRUE A) (:TRUE C)) 74 | (rassert! (:NOT (:AND A C)) :DOMAIN-NOGOOD))) 75 | (eval '(rule ((:TRUE B) (:TRUE E)) 76 | (rassert! (:NOT (:AND B E)) :DOMAIN-NOGOOD))) 77 | (DD-Search '((A B) (C D) (E F)) 78 | '(show-DD-test-solution))) 79 | 80 | (defun show-DD-test-solution (&aux result) 81 | (dolist (var '(F E D C B A)) 82 | (when (true? var *ltre*) (push var result))) 83 | (format t "~% Consistent solution: (~A)." result)) 84 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/explain.lisp: -------------------------------------------------------------------------------- 1 | ;; biohacker/trunk/BPS/ltms/explain.lisp 2 | 3 | (defun node->fact (node &aux literal) 4 | (setq literal 5 | (cond ((true-node? node) (tms-node-true-literal node)) 6 | ((false-node? node) (tms-node-false-literal node)) 7 | (t (error (format nil "Node ~A is not known." node))))) 8 | (literal->fact literal)) 9 | 10 | (defun node-all-antecedents (node) 11 | (clear-node-marks) 12 | (do ((todo (list node)) 13 | (result nil) 14 | (current) 15 | (support)) 16 | ((null todo) result) 17 | (setq current (car todo)) 18 | (setq todo (cdr todo)) 19 | (unless (tms-node-mark current) 20 | (setf (tms-node-mark current) t) 21 | (setq support (tms-node-support current)) 22 | (unless (eq :ENABLED-ASSUMPTION support) 23 | (setq todo (append (clause-antecedents support) todo))) 24 | (push current result)))) 25 | 26 | (defun all-antecedents (fact &optional (patterns nil) &aux node antecedents) 27 | (setq node (get-tms-node fact)) 28 | (when (known-node? node) 29 | (setq antecedents (mapcar #'node->fact (node-all-antecedents node))) 30 | (when patterns 31 | (setq antecedents (remove-if-not (function-matching-patterns patterns) antecedents))) 32 | antecedents)) 33 | 34 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/forward-abduction.lisp: -------------------------------------------------------------------------------- 1 | ;; biohacker/trunk/BPS/ltms/forward-abduction.lisp 2 | (defun keep-assuming (fact label patterns &key (debugging t) &aux all-assumed) 3 | (dolist (pattern patterns) 4 | (dolist (new-fact (fetch pattern)) 5 | (unless (known? new-fact) 6 | (when debugging 7 | (format t "~%Assuming ~A for forward abduction" new-fact)) 8 | (assume! new-fact :FORWARD-ABDUCTION) 9 | (push new-fact all-assumed) 10 | (when (known? fact) ;; should check label as sanity check 11 | (return-from keep-assuming all-assumed)))))) 12 | 13 | (defun needs-forward (fact label patterns &key (debugging t) &aux all-assumed antecedents) 14 | (setq all-assumed (keep-assuming fact label patterns :debugging debugging)) 15 | (setq antecedents 16 | (remove-if-not #'already-assumed? (all-antecedents (signed-view-node (get-tms-node fact)) patterns))) 17 | (dolist (assumed-fact all-assumed) 18 | (when debugging 19 | (format t "~%Retracting ~A after forward abduction" assumed-fact)) 20 | (retract! assumed-fact :FORWARD-ABDUCTION)) 21 | antecedents) -------------------------------------------------------------------------------- /src/main/lisp/ltms/indirect.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp; -*- 2 | 3 | ;;;; Indirect proof mechanism for LTRE 4 | ;;; Last Edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (proclaim '(special *LTRE*)) 17 | 18 | (defun try-indirect-proof (fact &optional (*LTRE* *LTRE*)) 19 | (unless (known? fact) 20 | (with-contradiction-handler (ltre-ltms *ltre*) 21 | #'(lambda (contradictions ltms &aux assumptions) 22 | (setq assumptions 23 | (assumptions-of-clause 24 | (car contradictions))) 25 | (let ((the-node 26 | (find (datum-tms-node (referent fact T)) 27 | assumptions))) 28 | (when the-node 29 | (let ((status (tms-node-label the-node))) 30 | (retract-assumption the-node) 31 | (add-nogood the-node status 32 | assumptions))))) 33 | ;; Assume the negation 34 | (assuming `((:NOT ,fact)) *LTRE* 35 | (run-rules))) 36 | (known? fact))) 37 | 38 | ;;;; Example of indirect proof 39 | 40 | (defun indirect-proof-example () 41 | (in-ltre (create-ltre "Indirect Proof Example")) 42 | (assert! '(:OR p q) 'user) 43 | (assert! '(:IMPLIES p r) 'user) 44 | (assert! '(:IMPLIES q r) 'user) 45 | (known? 'r) 46 | (try-indirect-proof 'r) 47 | (known? 'r)) 48 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/interactive-ex.lisp: -------------------------------------------------------------------------------- 1 | (setq *ltms* (create-ltms "Explain Example")) 2 | (setq x (tms-create-node *ltms* "x" :ASSUMPTIONP t) 3 | y (tms-create-node *ltms* "y") 4 | z (tms-create-node *ltms* "z") 5 | r (tms-create-node *ltms* "r")) 6 | (add-formula *ltms* `(:OR ,x ,y)) 7 | (add-formula *ltms* `(:OR (:NOT ,y) ,z)) 8 | (add-formula *ltms* `(:OR (:NOT ,z) ,r)) 9 | (enable-assumption x :FALSE) 10 | (explain-node r) 11 | (support-for-node r) 12 | (assumptions-of-node r) 13 | (signed-node-string r) 14 | (node-consequences x) 15 | (setq clause (tms-node-support r)) 16 | (clause-antecedents clause) 17 | (show-node-consequences x) 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/laccept.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; Package: common-lisp-user; -*- 2 | 3 | ;;;; Acceptance tests for LTRE 4 | ;; Last edited 4/27/95, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun test-ltre () 17 | (in-ltre (create-ltre "Debugging LTRE")) 18 | (format t "~%Testing database/LTMS link...") 19 | (test-datums) 20 | (format t "~%Testing LTMS...") 21 | (test-clauses) 22 | (format t "~%Testing Rule system...") 23 | (test-rules)) 24 | 25 | (defun test-datums () 26 | (assert! 'foo 'testing) 27 | (unless (true? 'foo) (error "Fact installation glitch")) 28 | (assert! '(:NOT bar) 'testing) 29 | (unless (false? 'bar) (error "Negation glitch")) 30 | :OKAY) 31 | 32 | (defun test-clauses () 33 | (assert! '(:OR a b) 'case-split) 34 | (assert! '(:IMPLIES a c) 'why-not?) 35 | (assume! '(:IMPLIES c d) 'what-the-heck) 36 | (assume! '(:NOT b) 'for-fun) 37 | (unless (true? 'd) (error "Propagation glitch")) 38 | (retract! '(:NOT b) 'for-fun) 39 | (unless (unknown? 'd) (error "Retraction glitch")) 40 | (assume! '(:NOT b) 'for-fun) 41 | (unless (true? 'd) (error "Unouting glitch")) 42 | (retract! '(:IMPLIES c d) 'what-the-heck) 43 | (unless (unknown? 'd) (error "Retraction glitch 2")) 44 | (assume!'(:IMPLIES c d) 'what-the-heck) 45 | (unless (true? 'd) (error "Unouting glitch 2")) 46 | :OKAY) 47 | 48 | (defun test-rules () 49 | (eval `(rule ((:TRUE (foo ?x) :VAR ?f1) 50 | (:TRUE (bar ?y) :VAR ?f2)) 51 | (rassert! (:IMPLIES (:AND ?f1 ?f2) (mumble ?x ?y)) 'hack))) 52 | (eval `(rule ((:INTERN (foo ?x) :VAR ?f1) 53 | (:INTERN (bar ?y) :VAR ?f2)) 54 | (rassert! (:IMPLIES (:AND ?f1 ?f2) (grumble ?x ?y)) 'hack))) 55 | (referent '(foo 1) t) 56 | (referent '(bar 1) t) 57 | (run-rules) 58 | (unless (referent '(grumble 1 1) nil) (error "Intern triggering failure")) 59 | (when (referent '(mumble 1 1) nil) (error "Premature triggering")) 60 | (assume! '(foo 1) 'why-not?) 61 | (assume! '(:not (bar 1)) 'monkeywrench) 62 | (run-rules) 63 | (when (true? '(mumble 1 1)) (error "Badly conditioned triggering")) 64 | (retract! '(:not (bar 1)) 'tweak) 65 | (unless (false? '(bar 1)) (error "Retraction with wrong informant")) 66 | (retract! '(:not (bar 1)) 'monkeywrench) 67 | (run-rules) 68 | (when (true? '(mumble 1 1)) (error "Badly conditioned triggering - 2")) 69 | (assume! '(bar 1) 'why) 70 | (run-rules) 71 | (unless (true? '(mumble 1 1)) (error "Badly conditioned triggering - 2")) 72 | (assume! '(foo 2) 'go-for-it) 73 | (run-rules) 74 | (unless (true? '(mumble 2 1)) (error "Rule chaining failure")) 75 | (assume! '(bar 2) 'alternate) 76 | (run-rules) 77 | (unless (true? '(mumble 1 2)) (error "Subrule spawning failure")) 78 | (unless (true? '(mumble 2 2)) (error "Subrule spawning failure - 2")) 79 | :OKAY) 80 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/ltre.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Modified: everett on Mon Mar 6 13:09:00 1995 2 | 3 | ;;;; LTRE -- a version of TRE which uses the LTMS 4 | ;;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1989, 1990, 1991 Kenneth D. Forbus, Northwestern University, 7 | ;;; Johan de Kleer and Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *ltre-path* (make-bps-path "ltms")) 17 | 18 | 19 | ;; Unless the ltre is placed in its own package, unexporting won't 20 | ;; do the trick, we have to unequivocally destroy rlet 21 | #+MCL (unintern 'rlet (find-package :ccl)) 22 | 23 | 24 | (defparameter *ltre-files* 25 | '("ltms" ;; LTMS 26 | "linter" ;; Interface 27 | "ldata" ;; Database 28 | "lrules" ;; Rule system 29 | "unify" ;; Unifier 30 | "funify" ;; Open-coding of unification 31 | "laccept" ;; shakedown tests for ltre 32 | "cwa" ;; Closed-world assumption mechanism 33 | "dds")) ;; Dependency-directed search facility 34 | 35 | (defparameter *set-rule-file* "setrule") 36 | 37 | ;;; The file setrule.lisp should also be compiled for efficiency. 38 | ;;; It can only be compiled after an LTRE has been created. 39 | 40 | (defun load-ltre (&key (action :compile-if-newer)) 41 | (if (eq action :compile) 42 | (compile-ltre) 43 | (bps-load-files *ltre-path* *ltre-files* :action action))) 44 | 45 | (defun compile-ltre () 46 | (bps-load-files *ltre-path* *ltre-files* :action :compile) 47 | (unless (and (boundp '*ltre*) 48 | (not (null *ltre*))) 49 | (create-ltre "DUMMY")) 50 | (bps-load-file (make-bps-path "ltms") *set-rule-file* :action :compile)) 51 | 52 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/marx.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; -*- 2 | ;;;; ------------------------------------------------------------------------------ 3 | ;;;; File name: marx.lsp 4 | ;;;; System: LTRE 5 | ;;;; Version: 1.0 6 | ;;;; Author: Kenneth D. Forbus 7 | ;;;; Created: Apr 18, 1996 8 | ;;;; Modified: forbus on Thurs Apr 18 10:04:00 1996 9 | ;;;; Purpose: Figuring out which Marx brother was which 10 | ;;;; ------------------------------------------------------------------------------ 11 | 12 | (in-package :COMMON-LISP-USER) 13 | 14 | ;; This puzzle is a simple example of a constraint satisfaction problem, 15 | ;; which can easily be solved via dependency directed search. Here the 16 | ;; problem is figuring out which brothers have which attributes, which 17 | ;; mathematically is equivalent to finding bindings for variables over a discrete 18 | ;; domain. The LTRE allows us to express these relationships very naturally, 19 | ;; using higher-order relations to concisely describe the facts at hand. 20 | 21 | (defparameter *attributes* 22 | '(PLAYS-PIANO PLAYS-HARP ;; musical talents 23 | SMOOTH-TALKER LIKES-GAMBLING LIKES-ANIMALS)) ;; interests 24 | 25 | (defparameter *objects* '(GROUCHO HARPO CHICO)) ;; Sorry, Zeppo. 26 | 27 | (defparameter *constraint-file* "marxdata") 28 | 29 | (defun marx-brothers () 30 | (solve-attribution-problem *attributes* *objects* *constraint-file*)) 31 | 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | ;;; General purpose attribute solver 34 | 35 | (defun make-attribute-choice-sets (attributes objects) 36 | ;; Each attribute is assumed to apply to exactly one of the objects. 37 | (mapcar #'(lambda (attribute) 38 | (mapcar #'(lambda (object) 39 | (list attribute object)) objects)) 40 | attributes)) 41 | 42 | (defun solve-attribution-problem (attributes objects constraint-file) 43 | (in-ltre (create-ltre "Attribution Problem Scratchpad")) 44 | (bps-load-file (make-bps-path "ltms") constraint-file) 45 | (DD-Search (make-attribute-choice-sets attributes objects) 46 | `(show-attribute-solution ',attributes))) 47 | 48 | (defun show-attribute-solution (attributes) 49 | (format t "~%Solution:") 50 | (dolist (attribute attributes) 51 | (dolist (match (fetch `(,attribute ?object))) 52 | (when (true? match) 53 | (format t "~% ~A" match))))) 54 | 55 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/marxdata.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; -*- 2 | ;;;; ------------------------------------------------------------------------------ 3 | ;;;; File name: marxdata.lsp 4 | ;;;; System: Rules for the Marx Brothers Problem 5 | ;;;; Version: 1.0 6 | ;;;; Author: Kenneth D. Forbus 7 | ;;;; Created: Apr 18, 1996 8 | ;;;; Modified: forbus on Thurs Apr 18 10:10:44 1996 9 | ;;;; Purpose: Data for figuring out which Marx Brother was which 10 | ;;;; ------------------------------------------------------------------------------ 11 | 12 | (in-package :COMMON-LISP-USER) 13 | 14 | ;; Here are the constraints, from page 648-649 of Building Problem Solvers: 15 | ;; 1. The pianist, harpist, and talker are distinct brothers. 16 | ;; 2. The brother who is fond of money is distinct from the one 17 | ;; who is fond of gambling, who is also distinct from the one 18 | ;; who is fond of animals. 19 | ;; 3. The one who likes to talk doesn't like gambling. 20 | ;; 4. The one who likes animals plays the harp. 21 | ;; 5. Groucho hates animals. 22 | ;; 6. Harpo is always silent. 23 | ;; 7. Chico plays the piano. 24 | 25 | ;; We could simply write a large set of rules that trigger on pairs of 26 | ;; assertions to implement these constraints, but that isn't very elegant 27 | ;; and provides many opportunities for error. Instead, we use explicit 28 | ;; higher-order relations to state the constraints in a concise manner, 29 | ;; and use rules that implement the semantics of these constraints to do 30 | ;; the work. This makes it easier to write and debug, as well as putting more 31 | ;; of the knowledge we extract from the constraints in the system explicitly, 32 | ;; so that they can be reasoned about. 33 | 34 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 35 | ;;; Description of the constraints, formally 36 | 37 | ;; 1. The pianist, harpist, and talker are distinct brothers. 38 | 39 | (rassert! (pairwise-nogood plays-piano plays-harp)) 40 | (rassert! (pairwise-nogood plays-piano smooth-talker)) 41 | (rassert! (pairwise-nogood plays-harp smooth-talker)) 42 | 43 | ;; 2. The brother who is fond of money is distinct from the one 44 | ;; who is fond of gambling, who is also distinct from the one 45 | ;; who is fond of animals. 46 | 47 | (rassert! (pairwise-nogood likes-money likes-gambling)) 48 | (rassert! (pairwise-nogood likes-gambling likes-animals)) 49 | 50 | ;; 3. The one who likes to talk doesn't like gambling. 51 | 52 | (rassert! (pairwise-nogood smooth-talker likes-gambling)) 53 | 54 | ;; 4. The one who likes animals plays the harp. 55 | 56 | (rassert! (same-entity likes-animals plays-harp)) 57 | 58 | ;; 5. Groucho hates animals. 59 | 60 | (rassert! (:not (likes-animals groucho))) 61 | 62 | ;; 6. Harpo is always silent. 63 | 64 | (rassert! (:not (smooth-talker harpo))) 65 | 66 | ;; 7. Chico plays the piano. 67 | 68 | (rassert! (plays-piano chico)) 69 | 70 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 71 | ;;; Implementing the higher-order relations 72 | 73 | (rule ((:true (pairwise-nogood ?attribute1 ?attribute2) :var ?hor) 74 | (:true (?attribute1 ?obj) :var ?f1) 75 | (:true (?attribute2 ?obj) :var ?f2)) 76 | (rassert! (:not (:and ?hor ?f1 ?f2)))) 77 | 78 | (rule ((:true (same-entity ?attribute1 ?attribute2) :var ?hor) 79 | (:true (?attribute1 ?obj) :var ?f1)) 80 | (rassert! (:implies (:and ?hor ?f1) (?attribute2 ?obj)))) 81 | 82 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/my.lisp: -------------------------------------------------------------------------------- 1 | (bps-load-file (make-bps-path "ltms") "ltre" :action :compile) 2 | (compile-ltre) 3 | (bps-load-file (make-bps-path "ltms") "ltms" :action :compile) 4 | 5 | (bps-load-file (make-bps-path "ltms") "cltms" :action :compile) 6 | 7 | (bps-load-file (make-bps-path "ltms") "ltms-ex" :action :compile) 8 | (test-explain) 9 | (run-tests) 10 | 11 | (bps-load-file (make-bps-path "ltms") "counterfactual" :action :compile) 12 | 13 | ;; pages 292-293 of BPS 14 | (setq *ltms* (create-ltms "Simple")) 15 | (setq x (tms-create-node *ltms* "x" :ASSUMPTIONP t) y (tms-create-node *ltms* "y") z (tms-create-node *ltms* "z") r (tms-create-node *ltms* "r")) 16 | (add-formula *ltms* `(:OR ,x ,y)) 17 | (add-formula *ltms* `(:OR (:NOT ,y) ,z)) 18 | (add-formula *ltms* `(:OR (:NOT ,z) ,r)) 19 | (enable-assumption x :FALSE) 20 | (explain-node r) 21 | 22 | (bps-load-file (make-bps-path "ltms") "dds" :action :compile) 23 | (Test-DD-search) 24 | 25 | (bps-load-file (make-bps-path "ltms") "sudoku" :action :compile) 26 | (solve-sudoku *easy-puzzle* :debugging t) 27 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/setrule.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Rule for enforcing constraints on sets 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (rule ((:TRUE (set ?name) :VAR ?f1)) 17 | (rule ((:INTERN (?name members ?construal1) :VAR ?f2)) 18 | (rule ((:INTERN (?name has-member ?new) :VAR ?f3 19 | :TEST (not (member ?new ?construal1 20 | :TEST #'equal)))) 21 | (rassert! (:IMPLIES (:AND ?f1 ?f2) (:NOT ?f3)) 22 | :NOT-IN-SET)) 23 | (rule ((:INTERN (?name MEMBERS ?construal2) :VAR ?f3 24 | :TEST (and (form< ?f2 ?f3) ;; Avoid redundant nogoods 25 | (set-exclusive-or ?construal1 26 | ?construal2 27 | :TEST 'equal)))) 28 | (rassert! (:NOT (:AND ?f1 ?f2 ?f3)) 29 | :CONSTRUAL-UNIQUENESS)))) 30 | 31 | ;;; It's important to avoid duplicate justifications, especially in 32 | ;;; large problems. Do this by reifying justifications made by the 33 | ;;; CWA code in the LTRE database, using this rule to translate the 34 | ;;; statement into the appropriate clauses. (These statements can 35 | ;;; safely be premises, because they are inviolate: only the 36 | ;;; statements which participate in them can be wrong. 37 | 38 | (rule ((:INTERN (CWA-JUSTIFICATION ?ante ?conse) :VAR ?cwaj)) 39 | (rassert! (:IMPLIES ?cwaj 40 | (:IMPLIES ?ante ?conse)) 41 | :CWA-JUSTIFICATION)) 42 | -------------------------------------------------------------------------------- /src/main/lisp/ltms/unify.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Variables and unification 4 | ;;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun variable? (x) 17 | (and (symbolp x) ;A symbol whose first character is "?" 18 | (char= #\? (elt (symbol-name x) 0)))) 19 | 20 | (defun unify (a b &optional (bindings nil)) 21 | (cond ((equal a b) bindings) 22 | ((variable? a) (unify-variable a b bindings)) 23 | ((variable? b) (unify-variable b a bindings)) 24 | ((or (not (listp a)) (not (listp b))) :FAIL) 25 | ((not (eq :FAIL (setq bindings 26 | (unify (car a) (car b) bindings)))) 27 | (unify (cdr a) (cdr b) bindings)) 28 | (t :FAIL))) 29 | 30 | (defun unify-variable (var exp bindings &aux val) 31 | ;; Must distinguish no value from value of nil 32 | (setq val (assoc var bindings)) 33 | (cond (val (unify (cdr val) exp bindings)) 34 | ;; If safe, bind to 35 | ((free-in? var exp bindings) (cons (cons var exp) bindings)) 36 | (t :FAIL))) 37 | 38 | (defun free-in? (var exp bindings) 39 | ;; Returns nil if occurs in , assuming . 40 | (cond ((null exp) t) 41 | ((equal var exp) nil) 42 | ((variable? exp) 43 | (let ((val (assoc exp bindings))) 44 | (if val 45 | (free-in? var (cdr val) bindings) 46 | t))) 47 | ((not (listp exp)) t) 48 | ((free-in? var (car exp) bindings) 49 | (free-in? var (cdr exp) bindings)))) 50 | -------------------------------------------------------------------------------- /src/main/lisp/relax/cube.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Cube example 4 | 5 | ;; Copyright (c) 1988, 1989, 1991 Kenneth D. Forbus, Northwestern University, 6 | ;; Johan de Kleer, Xerox Corporation. 7 | ;; All rights reserved. 8 | 9 | ;;; See the file legal.txt for a paragraph stating scope of permission 10 | ;;; and disclaimer of warranty. The above copyright notice and that 11 | ;;; paragraph must be included in any separate copy of this file. 12 | 13 | (in-package :COMMON-LISP-USER) 14 | 15 | (Scene "Cube") 16 | 17 | (Line L1) 18 | (Line L2) 19 | (Line L3) 20 | (Line L4) 21 | (Line L5) 22 | (Line L6) 23 | (Line L7) 24 | (Line L8) 25 | (Line L9) 26 | 27 | (Junction J1 Arrow :LEFT L6 :RIGHT L1 :BOTTOM L7) 28 | (Junction J2 Ell :LEFT L1 :RIGHT L2) 29 | (Junction J3 Arrow :LEFT L2 :RIGHT L3 :BOTTOM L8) 30 | (Junction J4 Ell :LEFT L3 :RIGHT L4) 31 | (Junction J5 Arrow :LEFT L4 :RIGHT L5 :BOTTOM L9) 32 | (Junction J6 Ell :LEFT L6 :RIGHT L5) 33 | (Junction J7 Fork :LEFT L7 :RIGHT L8 :BOTTOM L9) 34 | -------------------------------------------------------------------------------- /src/main/lisp/relax/jcatalog.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Junction catalog 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;; Copyright (c) 1988, 1989, 1991 Kenneth D. Forbus, Northwestern University, 7 | ;; Johan de Kleer, Xerox Corporation. 8 | ;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;; Based on Figure 3-14, Page 56, Winston. 17 | 18 | (Junction-Labelling Ell 1 :LEFT < :RIGHT <) 19 | (Junction-Labelling Ell 2 :LEFT > :RIGHT >) 20 | (Junction-Labelling Ell 3 :LEFT + :RIGHT >) 21 | (Junction-Labelling Ell 4 :LEFT > :RIGHT +) 22 | (Junction-Labelling Ell 5 :LEFT - :RIGHT <) 23 | (Junction-Labelling Ell 6 :LEFT < :RIGHT -) 24 | 25 | (Junction-Labelling Fork 1 :LEFT + :RIGHT + :BOTTOM +) 26 | (Junction-Labelling Fork 2 :LEFT - :RIGHT - :BOTTOM -) 27 | (Junction-Labelling Fork 3 :LEFT > :RIGHT > :BOTTOM -) 28 | (Junction-Labelling Fork 4 :LEFT - :RIGHT < :BOTTOM <) 29 | (Junction-Labelling Fork 5 :LEFT < :RIGHT - :BOTTOM >) 30 | 31 | (Junction-Labelling Tee 1 :LEFT > :RIGHT > :BOTTOM +) 32 | (Junction-Labelling Tee 2 :LEFT > :RIGHT > :BOTTOM -) 33 | (Junction-Labelling Tee 3 :LEFT > :RIGHT > :BOTTOM <) 34 | (Junction-Labelling Tee 4 :LEFT > :RIGHT > :BOTTOM >) 35 | 36 | (Junction-Labelling Arrow 1 :LEFT > :RIGHT > :BOTTOM +) 37 | (Junction-Labelling Arrow 2 :LEFT - :RIGHT - :BOTTOM +) 38 | (Junction-Labelling Arrow 3 :LEFT + :RIGHT + :BOTTOM -) 39 | -------------------------------------------------------------------------------- /src/main/lisp/relax/stack.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Stack -- another example 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;; Copyright (c) 1988, 1989, 1991 Kenneth D. Forbus, Northwestern University, 7 | ;; Johan de Kleer, Xerox Corporation. 8 | ;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (Scene "Stack") 17 | 18 | (line L1) 19 | (line L2) 20 | (line L3) 21 | (line L4) 22 | (line L5) 23 | (line L6) 24 | (line L7) 25 | (line L8) 26 | (line L9) 27 | (line L10) 28 | (line L11) 29 | (line L12) 30 | (line L13) 31 | (line L14) 32 | (line L15) 33 | (line L16) 34 | (line L17) 35 | 36 | (Junction J1 Arrow :LEFT L9 :RIGHT L1 :BOTTOM L10) 37 | (Junction J2 Fork :LEFT L1 :RIGHT L2 :BOTTOM L5) 38 | (Junction J3 Arrow :LEFT L2 :RIGHT L3 :BOTTOM L16) 39 | (Junction J4 Ell :LEFT L3 :RIGHT L4) 40 | (Junction J5 Arrow :LEFT L4 :RIGHT L5 :BOTTOM L17) 41 | (Junction J6 Ell :LEFT L5 :RIGHT L6) 42 | (Junction J7 Tee :LEFT L6 :RIGHT L7 :BOTTOM L13) 43 | (Junction J8 Arrow :LEFT L7 :RIGHT L8 :BOTTOM L12) 44 | (Junction J9 Ell :LEFT L8 :RIGHT L9) 45 | (Junction J10 Fork :LEFT L10 :RIGHT L11 :BOTTOM L12) 46 | (Junction J11 Arrow :LEFT L14 :RIGHT L11 :BOTTOM L15) 47 | (Junction J12 Fork :LEFT L16 :RIGHT L17 :BOTTOM L14) 48 | -------------------------------------------------------------------------------- /src/main/lisp/relax/wedge.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;; Wedge scene, from Winston Figure 3.6 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1988-1990, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (scene "Wedge") 17 | 18 | (line L1) 19 | (line L2) 20 | (line L3) 21 | (line L4) 22 | (line L5) 23 | (line L6) 24 | (line L7) 25 | (line L8) 26 | (line L9) 27 | (line L10) 28 | (line L11) 29 | (line L12) 30 | (line L13) 31 | (line L14) 32 | (line L15) 33 | 34 | (junction J1 Ell :LEFT L1 :RIGHT L2) 35 | (junction J2 Arrow :LEFT L2 :RIGHT L3 :BOTTOM L9) 36 | (junction J3 Ell :LEFT L3 :RIGHT L4) 37 | (junction J4 Arrow :LEFT L4 :RIGHT L5 :BOTTOM L10) 38 | (junction J5 Fork :LEFT L5 :RIGHT L6 :BOTTOM L12) 39 | (junction J6 Arrow :LEFT L6 :RIGHT L7 :BOTTOM L14) 40 | (junction J7 Ell :LEFT L7 :RIGHT L8) 41 | (junction J8 Arrow :LEFT L8 :RIGHT L1 :BOTTOM L15) 42 | (junction J9 Fork :LEFT L9 :RIGHT L11 :BOTTOM L10) 43 | (junction J10 Arrow :LEFT L13 :RIGHT L11 :BOTTOM L12) 44 | (junction J11 Fork :LEFT L15 :RIGHT L13 :BOTTOM L14) 45 | 46 | -------------------------------------------------------------------------------- /src/main/lisp/tcon/debug.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | (defun intercept (&optional (debugging? nil)) 4 | (create-tcon "test" :PROTOTYPE-FILE "/u/bps/code/tcon/motion.lisp" 5 | :DEBUGGING debugging?) 6 | (create 'sat '2d-motion) 7 | (create 'int '2d-motion) 8 | (== (>> deltat sat) (>> deltat int)) 9 | (== (>> x end sat) (>> x end int)) 10 | (== (>> y end sat) (>> y end int)) 11 | (set-parameter (>> yaccel sat) -9.98) 12 | (set-parameter (>> yaccel int) -9.98) 13 | (set-parameter (>> xaccel sat) 0.0) 14 | (set-parameter (>> xaccel int) 0.0) 15 | (set-parameter (>> x start sat) -1000.0) 16 | (set-parameter (>> y start sat) 1000.0) 17 | (set-parameter (>> x vstart sat) 100.0) 18 | (set-parameter (>> y vstart sat) -100.0) 19 | (set-parameter (>> x start int) 100.0) 20 | (set-parameter (>> y start int) 0.0)) 21 | 22 | (defun show () 23 | (what-is (>> theta vstart int)) 24 | (what-is (>> deltat xmotion int)) 25 | (what-is (>> y end sat))) 26 | 27 | (defun diff () 28 | (what-is (>> x end sat)) 29 | (what-is (>> y end sat)) 30 | (what-is (>> x end int)) 31 | (what-is (>> y end int))) 32 | -------------------------------------------------------------------------------- /src/main/lisp/tcon/intex.txt: -------------------------------------------------------------------------------- 1 | ;;; Interception example -- 2/17/92 2 | 3 | > (intercept) 4 | ;;; Loading source file "/u/bps/code/tcon/motion.lisp" 5 | 32 6 | 0 7 | > (set-parameter (>> y end sat) 100.0) 8 | 447 9 | 0 10 | > (constraint-values (>> vstart int)) 11 | 12 | (>> X VSTART INT) = -63.30380008156704. 13 | (>> Y VSTART INT) = 48.45800007415186. 14 | (>> SIGNX VSTART INT) = -1.0. 15 | (>> SIGNY VSTART INT) = 1.0. 16 | (>> R VSTART INT) = 79.72169639410284. 17 | (>> THETA VSTART INT) = 2.48825566963078. 18 | (>> QUADRENT VSTART INT) = 2. 19 | NIL 20 | > (constraint-values (>> int)) 21 | 22 | (>> XACCEL INT) = 0.0. 23 | (>> YACCEL INT) = -9.98. 24 | (>> DELTAT INT) = 6.735911837021377. 25 | NIL 26 | > (change-parameter (>> y end sat) 200.0) 27 | 447 28 | 147 29 | > (constraint-values (>> int)) 30 | 31 | (>> XACCEL INT) = 0.0. 32 | (>> YACCEL INT) = -9.98. 33 | (>> DELTAT INT) = 6.12684334948592. 34 | NIL 35 | > (constraint-values (>> vstart int)) 36 | 37 | (>> X VSTART INT) = -79.5378039316603. 38 | (>> Y VSTART INT) = 63.21618539241843. 39 | (>> SIGNX VSTART INT) = -1.0. 40 | (>> SIGNY VSTART INT) = 1.0. 41 | (>> R VSTART INT) = 101.59994266651854. 42 | (>> THETA VSTART INT) = 2.4700340490900947. 43 | (>> QUADRENT VSTART INT) = 2. 44 | NIL 45 | > (change-parameter (>> y end sat) 500.0) 46 | 447 47 | 147 48 | > (constraint-values (>> int)) 49 | 50 | (>> XACCEL INT) = 0.0. 51 | (>> YACCEL INT) = -9.98. 52 | (>> DELTAT INT) = 4.143349486240177. 53 | NIL 54 | > (constraint-values (>> vstart int)) 55 | 56 | (>> X VSTART INT) = -165.48569065994462. 57 | (>> Y VSTART INT) = 141.35062787267694. 58 | (>> SIGNX VSTART INT) = -1.0. 59 | (>> SIGNY VSTART INT) = 1.0. 60 | (>> R VSTART INT) = 217.6361960088415. 61 | (>> THETA VSTART INT) = 2.434690647204288. 62 | (>> QUADRENT VSTART INT) = 2. 63 | NIL 64 | > -------------------------------------------------------------------------------- /src/main/lisp/tcon/polybox.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Polybox example 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (constraint adder ((a1 cell) (a2 cell) (sum cell)) 17 | (formulae (sum (a1 a2) (+ a1 a2)) 18 | (a1 (sum a2) (- sum a2)) 19 | (a2 (sum a1) (- sum a1)))) 20 | 21 | (constraint multiplier ((m1 cell) (m2 cell) (product cell)) 22 | (formulae (product (m1) (if (nearly-zero? m1) 0.0 :DISMISS)) 23 | (product (m2) (if (nearly-zero? m2) 0.0 :DISMISS)) 24 | (product (m1 m2) (if (or (nearly-zero? m1) 25 | (nearly-zero? m2)) 26 | :DISMISS) 27 | (* m1 m2)) 28 | (m1 (product m2) (if (nearly-zero? m2) 29 | (if (nearly-zero? product) 30 | :DISMISS 31 | :LOSE) 32 | (/ product m2))) 33 | (m2 (product m1) (if (nearly-zero? m1) 34 | (if (nearly-zero? product) 35 | :DISMISS 36 | :LOSE) 37 | (/ product m1))))) 38 | 39 | (constraint Polybox-Example ((a cell)(b cell)(c cell) 40 | (d cell)(e cell)(f cell) 41 | (g cell) (x cell)(y cell)(z cell) 42 | (add-1 adder)(add-2 adder) 43 | (mult-1 multiplier) 44 | (mult-2 multiplier) 45 | (mult-3 multiplier)) 46 | (== (>> a) (>> m1 mult-1)) 47 | (== (>> b) (>> m1 mult-2)) 48 | (== (>> c) (>> m2 mult-1)) 49 | (== (>> c) (>> m1 mult-3)) 50 | (== (>> d) (>> m2 mult-2)) 51 | (== (>> e) (>> m2 mult-3)) 52 | (== (>> f) (>> sum add-1)) 53 | (== (>> g) (>> sum add-2)) 54 | (== (>> x) (>> product mult-1)) 55 | (== (>> x) (>> a1 add-1)) 56 | (== (>> y) (>> product mult-2)) 57 | (== (>> y) (>> a2 add-1)) 58 | (== (>> y) (>> a1 add-2)) 59 | (== (>> z) (>> product mult-3)) 60 | (== (>> z) (>> a2 add-2))) 61 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/ex1.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Two containers scenario 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (rassert! (phase liquid)) 17 | (rassert! (substance water)) 18 | 19 | ;; Declare indivduals and their types 20 | (rassert! (container F)) 21 | (rassert! (container G)) 22 | (rassert! (fluid-path P1)) 23 | 24 | ;; Specify their connectivity 25 | (rassert! (fluid-connection P1 F G)) 26 | (rassert! (fluid-connection P1 G F)) 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/ex2.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Syntax: Common-lisp; Mode: LISP; -*- 2 | 3 | ;;;; Water on stove example 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (rassert! (substance water)) 17 | (rassert! (phase liquid)) 18 | (rassert! (phase gas)) 19 | 20 | (rassert! (Container Can)) 21 | 22 | (rassert! (Temperature-Source Stove)) 23 | 24 | (rassert! (Heat-Path Burner)) 25 | 26 | (rassert! (Heat-Connection Burner Stove (c-s water gas can))) 27 | (rassert! (Heat-Connection Burner Stove (c-s water liquid can))) 28 | 29 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/ex3.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Syntax: Common-lisp; Mode: Lisp; -*- 2 | 3 | ;;; Three containers example 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1991-1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (rassert! (phase liquid)) 17 | (rassert! (substance water)) 18 | 19 | (rassert! (container F)) 20 | (rassert! (container G)) 21 | (rassert! (container H)) 22 | 23 | (rassert! (fluid-path P1)) 24 | (rassert! (fluid-path P2)) 25 | 26 | (rassert! (Aligned P1)) 27 | (rassert! (Aligned P2)) 28 | 29 | (rassert! (fluid-connection P1 F G)) 30 | (rassert! (fluid-connection P1 G F)) 31 | (rassert! (fluid-connection P2 G H)) 32 | (rassert! (fluid-connection P2 H G)) 33 | 34 | 35 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/ex4.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Syntax: Common-lisp; Mode: Lisp; -*- 2 | 3 | ;;;; double-heat flow example 4 | ;; Last edited 1/29/93 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (assert! (physob rock)) 17 | (assert! (Exists rock)) 18 | 19 | (assert! (Temperature-Source Stove)) 20 | 21 | (assert! (Temperature-Source ATM)) 22 | 23 | (assert! (Heat-Path Burner)) 24 | 25 | (assert! (Heat-Path (surface rock))) 26 | 27 | (assert! (Heat-Connection Burner Stove rock)) 28 | (assert! (Heat-Connection Burner rock stove)) 29 | 30 | (assert! (Heat-Connection (surface rock) ATM rock)) 31 | (assert! (Heat-Connection (surface rock) rock ATM)) 32 | 33 | (assert! (Less-Than (A (temperature ATM)) (A (temperature Stove)))) 34 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/ex5.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Syntax: Common-lisp; Mode: LISP; -*- 2 | 3 | ;;;; Three blobs example 4 | ;;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;;; Three blobs example 17 | 18 | (assertq (physob F)) 19 | (assertq (physob G)) 20 | (assertq (physob H)) 21 | 22 | (assertq (heat-path P1)) 23 | (assertq (heat-path P2)) 24 | 25 | (assertq (heat-connection P1 F G)) 26 | (assertq (heat-connection P1 G F)) 27 | (assertq (heat-connection P2 G H)) 28 | (assertq (heat-connection P2 H G)) 29 | 30 | 31 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/ex6.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Syntax: Common-lisp; Mode: LISP; -*- 2 | 3 | ;;;; Four blobs example 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (assertq (physob F)) 17 | (assertq (physob G)) 18 | (assertq (physob H)) 19 | (assertq (physob I)) 20 | 21 | (assertq (heat-path P1)) 22 | (assertq (heat-path P2)) 23 | (assertq (heat-path P3)) 24 | 25 | (assertq (heat-connection P1 F G)) 26 | (assertq (heat-connection P1 G F)) 27 | (assertq (heat-connection P2 G H)) 28 | (assertq (heat-connection P2 H G)) 29 | (assertq (heat-connection P3 G I)) 30 | (assertq (heat-connection P3 I G)) 31 | 32 | 33 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/ex7.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: LISP; Syntax: Common-lisp -*- 2 | 3 | ;;;; Four containers example 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (assertq (state liquid)) 17 | (assertq (substance water)) 18 | 19 | (assertq (container F)) 20 | (assertq (container G)) 21 | (assertq (container H)) 22 | (assertq (container I)) 23 | 24 | (assertq (fluid-path P1)) 25 | (assertq (fluid-path P2)) 26 | (assertq (fluid-path P3)) 27 | 28 | (assertq (fluid-connection P1 F G)) 29 | (assertq (fluid-connection P1 G F)) 30 | (assertq (fluid-connection P2 G H)) 31 | (assertq (fluid-connection P2 H G)) 32 | (assertq (fluid-connection P3 G I)) 33 | (assertq (fluid-connection P3 I G)) 34 | 35 | (assertq (Equal-to (A (bottom-height F)) (A (Max-Height P1)))) 36 | (assertq (Equal-to (A (bottom-height H)) (A (Max-Height P2)))) 37 | (assertq (Equal-to (A (bottom-height I)) (A (Max-Height P3)))) 38 | 39 | (assertq (Equal-to (A (bottom-height G)) (A (max-height P1)))) 40 | (assertq (Equal-to (A (bottom-height G)) (A (max-height P2)))) 41 | (assertq (Equal-to (A (bottom-height G)) (A (max-height P3)))) 42 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/mi.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Measurement Interpretation system 4 | ;;;; Last Edited: 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1991-1992, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All Rights Reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *tgizmo-laws-file* 17 | #+ILS "/u/bps/code/tgizmo/laws" 18 | #+PARC "virgo:/virgo/dekleer/bps/code/tgizmo/laws" 19 | #+MCL "Macintosh HD:BPS:tgizmo:laws.fasl") 20 | 21 | (defvar *domain-file* #+UNIX "/u/bps/code/tgizmo/tnst.lisp" 22 | #+PARC "virgo:/virgo/dekleer/bps/code/tgizmo/tnst" 23 | #+MCL "Macintosh HD:BPS:tgizmo:tnst.fasl") 24 | 25 | (defun mi (scenario measurements 26 | &key (debugging nil) 27 | (debugging-dds nil) 28 | (title nil) 29 | (domain *domain-file*)) 30 | (with-tgizmo 31 | (setq *tgizmo* 32 | (create-tgizmo 33 | (if title title (format nil "MI of ~A" scenario)) 34 | :DEBUGGING debugging :SCENARIO scenario 35 | :MEASUREMENTS measurements)) 36 | (with-LTRE (tgizmo-ltre *tgizmo*) 37 | (load *set-rule-file*) 38 | (setq *debug-dds* debugging-dds) 39 | (load *tgizmo-laws-file*) 40 | (load domain) 41 | (load-scenario scenario) 42 | (dolist (d measurements) 43 | (assume! d :MEASURED)) 44 | (find-states *tgizmo*)) 45 | (values *tgizmo* (length (tgizmo-states *tgizmo*))))) 46 | 47 | (defun find-states (&optional (*tgizmo* *tgizmo*)) 48 | (setf (tgizmo-nstates *tgizmo*) 0) 49 | (setf (tgizmo-states *tgizmo*) nil) 50 | (Search-PSVS `(Resolve-Completely 51 | '(push (snapshot (incf (tgizmo-nstates *tgizmo*))) 52 | (tgizmo-states *tgizmo*))))) 53 | 54 | (defun debug-find-states 55 | (&optional (thunk 56 | '(progn (push (snapshot (incf (tgizmo-nstates *tgizmo*))) 57 | (tgizmo-states *tgizmo*)) 58 | (print (tgizmo-nstates *tgizmo*)) 59 | (when (tg-fetch '(Active ?x) :UNKNOWN) 60 | (show-state (car (tgizmo-states *tgizmo*))) 61 | (break "~% Some status assignments unknow at state ~D" 62 | (tgizmo-nstates *tgizmo*))))) 63 | (*tgizmo* *tgizmo*)) 64 | (Search-PSVS `(Resolve-Completely ',thunk))) 65 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/psvs.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; TGizmo PS/VS operations 4 | ;;;; Last Edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1991-1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun load-scenario (sfile &optional (*tgizmo* *tgizmo*)) 17 | (with-tgizmo *tgizmo* 18 | (with-ltre (tgizmo-ltre *tgizmo*) 19 | (load sfile)) 20 | (tg-run-rules) 21 | (use-transitivity *tgizmo*))) 22 | 23 | (defun gather-vps (&optional (*tgizmo* *tgizmo*)) 24 | (tg-fetch `(Active ?x))) 25 | 26 | (defun psvs-choice-sets (&optional (*tgizmo* *tgizmo*)) 27 | (mapcar #'(lambda (a-s) `(,a-s (:NOT ,a-s))) 28 | (gather-vps))) 29 | 30 | (defun search-PSVS (thunk &optional (*tgizmo* *tgizmo*)) 31 | (DD-Search (psvs-choice-sets) 32 | `(unwind-protect 33 | (progn (when-debugging-tgizmo :PSVS-DDS 34 | (format t "~% =======================") 35 | (show-psvs)) 36 | ,thunk 37 | (when-debugging-tgizmo :PSVS-DDS 38 | (format t "~% ======================="))) 39 | (retract-IR-CWAs)))) 40 | 41 | (defun show-psvs (&optional (*tgizmo* *tgizmo*)) 42 | ;;; good for examining the current state 43 | (dolist (active-s (tg-fetch '(Active ?x))) 44 | (format t "~% ~A is ~A." 45 | (cadr active-s) 46 | (case (label-of active-s) 47 | (:TRUE "active") 48 | (:FALSE "inactive") 49 | (t "??"))))) 50 | -------------------------------------------------------------------------------- /src/main/lisp/tgizmo/tgizmo.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Tiny Gizmo, a partial implementation of QP theory 4 | ;;; Last Edited: 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | ;;;; Gizmo was the first implementation of QP theory, which 15 | ;;;; evolved from 1982 to 1984. Like the original, TGizmo 16 | ;;;; is based on an LTMS. However, we've simplified the modeling 17 | ;;;; language, and not implemented limit analysis or temporal 18 | ;;;; projection here to keep the size of the code small. 19 | ;;;; We show how to use dependency-directed search to interpret 20 | ;;;; measurements within a single qualitative behavior, as per 21 | ;;;; Forbus' IJCAI-83 paper. 22 | 23 | (in-package :COMMON-LISP-USER) 24 | 25 | (defvar *tgizmo-path* 26 | #+ILS "/u/bps/code/tgizmo/" 27 | #+PARC "virgo:/virgo/dekleer/bps/code/tgizmo/" 28 | #+MCL "Macintosh HD:BPS:tgizmo:") 29 | 30 | (defvar *tgizmo-files* 31 | '("defs" ; Definitions of internal structs. 32 | "mlang" ; Simple modeling language for QP descriptions. 33 | "psvs" ; Finding view and process structures. 34 | "resolve" ; Influence resolution. 35 | "ineqs" ; Inequality reasoning. 36 | "states" ; Caching states. 37 | "mi" ; Measurement Interpretation system. 38 | "debug")) ; Various examples and debugging procedures. 39 | 40 | ;;; The file laws.lisp contains PDIS rules that enforce logical 41 | ;;; constraints of QP theory. It must be compiled after a tgizmo 42 | ;;; has been created. 43 | 44 | (defun compile-tgizmo () 45 | (compile-load-files *tgizmo-files* *tgizmo-path*) 46 | (unless (and (boundp '*tgizmo*) 47 | (not (null *tgizmo*))) 48 | (create-tgizmo "DUMMY")) 49 | (compile-load-files '("laws" "tnst") *tgizmo-path*)) 50 | -------------------------------------------------------------------------------- /src/main/lisp/tre/data.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;; Database for Tiny Rule Engine 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1986-1992, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;; This simple version uses "car indexing" to store facts and rules 17 | ;; which might match. Unification provides the actual matching. 18 | 19 | (proclaim '(special *TRE* *ENV*)) 20 | 21 | (defstruct (dbclass (:PRINT-FUNCTION (lambda (d st ignore) 22 | (format st "" 23 | (dbclass-name d))))) 24 | name ;a symbol 25 | tre ;The TRE it belongs to 26 | facts ;facts of this dbclass 27 | rules) ;rules applicable to this dbclass 28 | 29 | (defun show-data (&optional (stream *standard-output*) &aux counter) 30 | (setq counter 0) 31 | (maphash #'(lambda (key dbclass) 32 | (dolist (datum (dbclass-facts dbclass)) 33 | (incf counter) 34 | (format stream "~%~A" datum))) 35 | (tre-dbclass-table *TRE*)) 36 | counter) 37 | 38 | ;;;; Installing new facts 39 | 40 | (defun assert! (fact &optional (*TRE* *TRE*)) 41 | (when (insert fact *tre*) ;; when it isn't already there 42 | (try-rules fact *tre*))) ;; run the rules on it. 43 | 44 | (defun insert (fact tre &aux dbclass) 45 | (setq dbclass (get-dbclass fact tre)) ;Question: Why not use PUSHNEW here? 46 | (unless (member fact (dbclass-facts dbclass) :TEST #'equal) 47 | (debugging-tre "~% ~A: Inserting ~A into database." tre fact) 48 | (push fact (dbclass-facts dbclass)))) 49 | 50 | (defun get-dbclass (fact tre &aux dbclass val) 51 | (cond ((listp fact) (get-dbclass (car fact) tre)) 52 | ((variable? fact) 53 | ;; We might be in the environment of some rule, so must 54 | ;; check the variable's bindings. 55 | (cond ((boundp fact) (get-dbclass (symbol-value fact) tre)) 56 | ((setq val (assoc fact *ENV*)) 57 | (get-dbclass (cdr val) tre)) 58 | (t (error "~%Dbclass unbound: ~A" fact)))) 59 | ((symbolp fact) 60 | (cond ((setq dbclass (gethash fact (tre-dbclass-table tre))) dbclass) 61 | ;; Nothing found, so build it. 62 | (t (setq dbclass (make-dbclass :NAME fact :TRE tre 63 | :FACTS nil :RULES nil)) 64 | (setf (gethash fact (tre-dbclass-table tre)) dbclass) 65 | dbclass))) 66 | (t (error "Bad dbclass type: ~A" fact)))) 67 | 68 | ;;;; Fetching data 69 | 70 | (defun fetch (pattern &optional (tre *TRE*) &aux bindings unifiers) 71 | ;; Returns the list of facts which unify with the pattern. 72 | (dolist (candidate (get-candidates pattern tre) unifiers) 73 | (setq bindings (unify pattern candidate)) 74 | (unless (eq bindings :FAIL) 75 | (push (sublis bindings pattern) unifiers)))) 76 | 77 | (defun get-candidates (pattern tre) (dbclass-facts (get-dbclass pattern tre))) 78 | -------------------------------------------------------------------------------- /src/main/lisp/tre/tinter.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; TRE interface 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;; Includes user hooks (for people and programs). 17 | 18 | (defstruct (tre (:PRINT-FUNCTION tre-printer)) 19 | title ; String for printing 20 | (dbclass-table nil) ; symbols --> classes 21 | (debugging nil) ; prints extra info if non-nil 22 | (queue nil) ; LIFO 23 | (rule-counter 0) ; Unique id for rules 24 | (rules-run 0)) ; Statistics 25 | 26 | (defun tre-printer (tre st ignore) 27 | (format st "" (tre-title tre))) 28 | 29 | (proclaim '(special *TRE*)) ;; Current TRE 30 | 31 | (defvar *TRE* nil "Name for default TRE") 32 | 33 | (defmacro With-TRE (tre &rest forms) 34 | `(let ((*TRE* ,tre)) ,@ forms)) 35 | 36 | (defun in-TRE (tre) (setq *TRE* tre)) 37 | 38 | (defmacro debugging-tre (msg &rest args) 39 | `(when (tre-debugging *TRE*) (format t ,msg ,@ args))) 40 | 41 | 42 | (defun create-tre (title &key debugging) 43 | (make-tre :TITLE title 44 | :DBCLASS-TABLE (make-hash-table :test #'eq) 45 | :DEBUGGING debugging)) 46 | 47 | (defun debug-tre (tre debugging) 48 | (setf (tre-debugging tre) debugging)) 49 | 50 | ;;;; Drivers for programs and people 51 | 52 | (defun run (&optional (*TRE* *TRE*)) 53 | (format T "~%>>") 54 | (do ((form (read) (read))) 55 | ((member form '(quit stop exit)) nil) 56 | (format t "~%~A" (eval form)) 57 | (run-rules *tre*) ;; Defined in RULES module 58 | (format t "~%>>"))) 59 | 60 | (defun run-forms (*TRE* forms) ;; Toplevel for programs 61 | (dolist (form forms) 62 | (eval form) (run-rules *TRE*))) 63 | 64 | (defun show (&optional (stream *standard-output*)) 65 | ;; Pass on the request to both modules of default TRE 66 | (show-data stream) 67 | (show-rules stream)) 68 | -------------------------------------------------------------------------------- /src/main/lisp/tre/tre.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;; Tiny Rule Engine, Version 5 4 | ;; Last edited 2/6/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;; A very simple pattern-directed inference system. 17 | ;; This version is the simplest. 18 | 19 | (defvar *tre-path* 20 | #+ILS "/u/bps/code/tre/" 21 | #+PARC "virgo:/virgo/dekleer/bps/code/jtms/" 22 | #+MCL "Macintosh HD:BPS:tre:tre.lisp") 23 | 24 | (defvar *tre-files* 25 | '("tinter" ;; User interface 26 | "data" ;; Assertions and database 27 | "rules" ;; Storing and retrieving rules 28 | "unify")) ;; Pattern matching & variables 29 | -------------------------------------------------------------------------------- /src/main/lisp/tre/treex1.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: LISP; -*- 2 | 3 | ;;;; Test cases for TRE 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun ex1 (&optional (debugging nil)) 17 | (in-tre (create-tre "Ex1" :DEBUGGING debugging)) 18 | (run-forms *TRE* 19 | '( 20 | ;; A simple version of Modus Ponens 21 | (rule (implies ?ante ?conse) 22 | (rule ?ante 23 | (assert! ?conse))) 24 | ;; A simple version of negation elimination 25 | (rule (not (not ?x)) (assert! ?x)) 26 | (assert! '(implies (human Turing) (mortal Turing))) 27 | (assert! '(not (not (human Turing)))))) 28 | (show-data)) 29 | 30 | (defun ex2 (&optional (debugging nil)) 31 | (in-tre (create-tre "Ex2" :DEBUGGING debugging)) 32 | ;; Rules can be used to interface with other representations 33 | (setq *parts* nil) 34 | (run-forms *TRE* 35 | '( ;; Creates parts index, say for graphics system 36 | (rule (has-part ?sys ?part) 37 | (let ((entry (assoc ?sys *parts*))) 38 | (unless entry 39 | (push (setq entry (cons ?sys nil)) 40 | *parts*)) 41 | (pushnew ?part (cdr entry)))) 42 | ;; Parts of a car 43 | (rule (car ?c) 44 | (assert! `(has-part ,?c (Engine ,?c))) 45 | (assert! `(has-part ,?c (Body ,?c))) 46 | (assert! `(has-part ,?c (Chasis ,?c)))) 47 | ;; Parts of a workstation 48 | (rule (workstation ?c) 49 | (assert! `(has-part ,?c (Disk ,?c))) 50 | (assert! `(has-part ,?c (Screen ,?c))) 51 | (assert! `(has-part ,?c (CPU-box ,?c))) 52 | (assert! `(has-part ,?c (Keyboard ,?c)))) 53 | (assert! '(car Ariel)) 54 | (assert! '(Workstation Hal-9000)))) 55 | (pprint *parts*)) 56 | 57 | (defun ex3 (&optional (debugging nil)) 58 | (in-tre (create-tre "Ex3" :DEBUGGING debugging)) 59 | ;; You may want to run this one last. 60 | (run-forms *TRE* '( 61 | (rule (integer ?x) 62 | (when (numberp ?x) 63 | (assert! `(integer ,(1+ ?x))))) 64 | (assert! `(integer 0))))) 65 | 66 | -------------------------------------------------------------------------------- /src/main/lisp/tre/unify.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Variables and unification 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1986-1992, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun variable? (x) 17 | (and (symbolp x) ;A symbol whose first character is "?" 18 | (char= #\? (elt (symbol-name x) 0)))) 19 | 20 | (defun unify (a b &optional (bindings nil)) 21 | (cond ((equal a b) bindings) 22 | ((variable? a) (unify-variable a b bindings)) 23 | ((variable? b) (unify-variable b a bindings)) 24 | ((or (not (listp a)) (not (listp b))) :FAIL) 25 | ((not (eq :FAIL (setq bindings 26 | (unify (car a) (car b) bindings)))) 27 | (unify (cdr a) (cdr b) bindings)) 28 | (t :FAIL))) 29 | 30 | (defun unify-variable (var exp bindings &aux binding) 31 | ;; Must distinguish no value from value of nil 32 | (setq binding (assoc var bindings)) 33 | (cond (binding (unify (cdr binding) exp bindings)) 34 | ;; If safe, bind to 35 | ((free-in? var exp bindings) (cons (cons var exp) bindings)) 36 | (t :FAIL))) 37 | 38 | (defun free-in? (var exp bindings) 39 | ;; Returns nil if occurs in , assuming . 40 | (cond ((null exp) t) 41 | ((equal var exp) nil) 42 | ((variable? exp) 43 | (let ((val (assoc exp bindings))) 44 | (if val 45 | (free-in? var (cdr val) bindings) 46 | t))) 47 | ((not (listp exp)) t) 48 | ((free-in? var (car exp) bindings) 49 | (free-in? var (cdr exp) bindings)))) 50 | -------------------------------------------------------------------------------- /src/main/lisp/utils/loader.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- MODE: LISP; -*- 2 | 3 | ;;;; Simple loader for Building Problem Solvers 4 | 5 | ;; Source code type 6 | 7 | (defvar *default-source-type* 8 | #+(OR Lucid Symbolics MCL) "lisp" 9 | #+ACLPC "lsp") 10 | 11 | ;; compiled file type 12 | (defvar *default-bin-type* 13 | #+RT "bbin" 14 | #+(:AND :LUCID :RIOS) "rbin" 15 | #+:IRIX "mbin" 16 | #+MCL "fasl" 17 | #+ACLPC "fsl") 18 | 19 | ;; Where to get stuff 20 | (defvar *default-pathname* 21 | #+:ILS "/u/bps/code/" 22 | #+:PARC "virgo:/virgo/dekleer/bps/" 23 | #+:MCL "Macintosh HD:BPS:" 24 | #+:ACLPC "e:\\code\\") 25 | 26 | (defun load-files (file-list &optional (path *default-pathame*) 27 | (type *default-bin-type*)) 28 | (dolist (file file-list) 29 | (load (merge-pathnames path 30 | (concatenate 'string file "." type))))) 31 | 32 | (defun compile-files (file-list 33 | &optional (path *default-pathname*)) 34 | (dolist (file file-list) 35 | (format t "~% Compiling ~A..." 36 | (merge-pathnames path 37 | (concatenate 'string file "." 38 | *default-source-type*))) 39 | (compile-file 40 | (merge-pathnames path 41 | (concatenate 'string file "." 42 | *default-source-type*)) 43 | :OUTPUT-FILE 44 | (merge-pathnames path 45 | (concatenate 'string file "." 46 | *default-bin-type*))))) 47 | 48 | (defun load-from (file path) 49 | (load (concatenate 'string path file))) 50 | 51 | ;;;; Compiling and loading files 52 | 53 | (defun compile-load-files (file-list 54 | &optional (path *default-pathname*) 55 | (pre-load? t) 56 | &aux out-path) 57 | (dolist (file file-list) 58 | (setq out-path 59 | (merge-pathnames path 60 | (concatenate 'string file "." 61 | *default-bin-type*))) 62 | (when pre-load? 63 | (load (merge-pathnames path 64 | (concatenate 'string file "." 65 | *default-source-type*)))) 66 | (compile-file 67 | (merge-pathnames path 68 | (concatenate 'string file "." 69 | *default-source-type*)) 70 | :OUTPUT-FILE out-path) 71 | (load out-path))) 72 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/Runners.scala: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.assumptionbased 19 | import scala.collection.mutable.{ListBuffer, HashSet, HashMap, Queue} 20 | 21 | @main def traceConstruction1: Unit = { 22 | val atms = new ATMS[Symbol, String, Nothing]("atms-test0", debugging = true) 23 | atms.debugging = false 24 | val a = atms.createNode("A", isAssumption = true) 25 | val c = atms.createNode("C", isAssumption = true) 26 | val e = atms.createNode("E", isAssumption = true) 27 | val h = atms.createNode("H") 28 | val j1 = atms.justifyNode("R1", h, List(c, e)) 29 | val g = atms.createNode("G") 30 | val j2 = atms.justifyNode("R2", g, List(a, c)) 31 | val x = atms.createNode("X", isContradictory = true) 32 | val j3 = atms.justifyNode("R3", x, List(g)) 33 | atms.debugging = true 34 | atms.debugAtms 35 | val b = atms.createNode("B", isAssumption = true) 36 | atms.debugAtms 37 | val j4 = atms.justifyNode("R4", h, List(b, c)) 38 | atms.debugAtms 39 | } 40 | 41 | def traceInterpretations1: Unit = { 42 | val atms = new ATMS[Symbol, String, Nothing]("atms-test0") 43 | val a = atms.createNode("A", isAssumption = true) 44 | val c = atms.createNode("C", isAssumption = true) 45 | val e = atms.createNode("E", isAssumption = true) 46 | val h = atms.createNode("H") 47 | val j1 = atms.justifyNode("R1", h, List(c, e)) 48 | val g = atms.createNode("G") 49 | val j2 = atms.justifyNode("R2", g, List(a, c)) 50 | val x = atms.createNode("X", isContradictory = true) 51 | val j3 = atms.justifyNode("R3", x, List(g)) 52 | val b = atms.createNode("B", isAssumption = true) 53 | val j4 = atms.justifyNode("R4", h, List(b, c)) 54 | 55 | atms.debugging = true 56 | atms.debugAtms 57 | 58 | val i1_hORg = atms.interpretations(List(List(h, g))) 59 | 60 | // val i1_hANDg = atms.interpretations(List(List(h), List(g))) 61 | } 62 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/Datum.scala-x: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.assumptionbased 19 | import scala.util.control.NonLocalReturns.* 20 | import scala.collection.mutable.{ListBuffer, HashSet, HashMap, Queue} 21 | 22 | // Assumption-based truth maintenance system, translated from F/dK 23 | // version 61 of 7/21/92. 24 | 25 | class Datum[I]() { 26 | 27 | // ; From ainter.lisp 28 | // (defstruct (datum (:PRINT-FUNCTION print-atre-datum)) 29 | // counter ; Unique ID for easy lookup 30 | // atre ; The ATRE it is part of 31 | // lisp-form ; Expression for pattern-matching 32 | // (tms-node nil) ; Pointer into TMS 33 | // dbclass ; Dbclass of the corresponding pattern 34 | // (assumption? nil) ; if non-nil, indicates informant 35 | // (plist nil)) ; local property list 36 | // 37 | // (defun print-atre-datum (d st ignore) (declare (ignore ignore)) 38 | // (format st "" (datum-counter d))) 39 | } 40 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/DbClass.scala-x: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.assumptionbased 19 | import scala.util.control.NonLocalReturns.* 20 | import scala.collection.mutable.{ListBuffer, HashSet, HashMap, Queue} 21 | 22 | // Assumption-based truth maintenance system, translated from F/dK 23 | // version 61 of 7/21/92. 24 | 25 | class DbClass[I]( 26 | val name: String, 27 | val ruleEngine: RuleEngine[I] 28 | ) { 29 | 30 | // ; From ainter.lisp 31 | // (defstruct (dbclass (:PRINT-FUNCTION print-atre-dbclass)) 32 | // name ; Corresponding symbol 33 | // atre ; ATRE it is part of. 34 | // facts ; Associated facts 35 | // rules) ; Associated rules 36 | 37 | override def toString: String = s"" 38 | def printRuleEngineDbClass: Unit = println(toString) 39 | // (defun print-atre-dbclass (r st ignore) 40 | // (declare (ignore ignore)) 41 | // (format st "" (dbclass-name r))) 42 | } 43 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/aqueens.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Lisp -*- 2 | 3 | ;;;; ATMS version of the N-queens problem 4 | 5 | ;; Copyright (c) 1986, 1987, 1988, 1989, 1990 Kenneth D. Forbus, 6 | ;; Northwestern University, and Johan de Kleer, Xerox Corporation. 7 | ;; All rights reserved. 8 | 9 | (in-package 'user) 10 | 11 | ;; This version uses special-purpose lisp code for simplicity. 12 | ;; Clearly one queen per column is required, hence choice sets 13 | ;; are placement of queen within the rows for each column. 14 | 15 | (defvar *queen-nodes* nil) 16 | (defvar *solutions* nil) 17 | (defvar *atms*) 18 | 19 | (defun n-queens (n) 20 | (setq *atms* (create-atms "N-queens")) 21 | (setq *solutions* nil) 22 | (setq *queen-nodes* nil) 23 | (setup-queen-nodes n) 24 | (setq *solutions* (interpretations *atms* *queen-nodes*)) 25 | (length *solutions*)) 26 | 27 | (defun setup-queen-nodes (n) 28 | (do ((i 1 (1+ i)) 29 | (column nil nil) 30 | (nodes nil)) 31 | ((> i n) 32 | (setq nodes (apply #'append *queen-nodes*)) 33 | (dolist (n1 nodes) 34 | (dolist (n2 nodes) 35 | (unless (or (eq n1 n2) 36 | (= (caddr (tms-node-datum n1)) 37 | (caddr (tms-node-datum n2)))) 38 | (when (queens-capture? (tms-node-datum n1) 39 | (tms-node-datum n2)) 40 | (nogood-nodes 'QUEENS-CAPTURE (list n1 n2))))))) 41 | (do ((j 1 (1+ j))) 42 | ((> j n) (push column *queen-nodes*)) 43 | (push (tms-create-node *atms* `(Queen ,j ,i) :assumptionp T) column)))) 44 | 45 | (defun queens-capture? (qa1 qa2) 46 | (or (= (cadr qa1) (cadr qa2)) 47 | (= (abs (- (cadr qa1) (cadr qa2))) 48 | (abs (- (caddr qa1) (caddr qa2)))))) 49 | 50 | (defun test-queens (from to) 51 | (do ((n from (1+ n))) 52 | ((> n to)) 53 | (time (n-queens n)) 54 | (format t "~%For ~D queens, ~D solutions." 55 | n (length *solutions*)))) 56 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/atre.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- MODE: Lisp; -*- 2 | 3 | ;;; ATRE: Tiny Rule Engine, with ATMS interface 4 | ;; Last edited: 1/29/93, KDF 5 | 6 | ;; Copyright (c) 1992, Kenneth D. Forbus, Northwestern 7 | ;; University, and Johan de Kleer, the Xerox Corporation 8 | ;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *atre-path* 17 | #+ILS "/u/bps/code/atms/" 18 | #+PARC "virgo:/virgo/dekleer/bps/code/atms/" 19 | #+MCL "Macintosh HD:BPS:atms:") 20 | 21 | (setq *atre-files* 22 | '("atms" ;; ATMS 23 | "ainter" ;; Interface 24 | "adata" ;; Database 25 | "arules" ;; Rule system 26 | "unify" ;; Variables and pattern matching 27 | "funify" ;; Open-coding of unification 28 | "atret")) ;; Test procedures 29 | 30 | (setq *planner-files* 31 | '("aplanr" ;; Utilities 32 | "plan-a" ;; Antecedent planner 33 | "plan-e" ;; Envisioner 34 | "bcode" ;; Blocks World support 35 | "blocks")) ;; Rules for Blocks World 36 | 37 | (defun compile-planner () ;; Assumes ATRE is compiled and loaded. 38 | (compile-load-files '("aplanr" "plan-a" "plan-e" "bcode") 39 | *atre-path*) 40 | (unless (and (boundp '*plnpr*) 41 | (not (null *plnpr*))) 42 | (create-planning-problem "DUMMY" nil)) 43 | (compile-load-files '("blocks") *atre-path*)) 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/bcode.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Test code for ATRE Blocksworld system 4 | ;; Last edited: 1/29/93, by KDF 5 | 6 | ;; Copyright (c) 1990-1992 Kenneth D. Forbus, Northwestern 7 | ;; University, and Johan de Kleer, Xerox Corporation. 8 | ;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defvar *blocks-file* 17 | #+ILS "/u/bps/code/atms/blocks" 18 | #+PARC "virgo:/virgo/dekleer/bps/code/atms/blocks" 19 | #+MCL "Macintosh HD:BPS:atms:blocks") 20 | 21 | (defun build-blocks-problem (title blocks-list 22 | &optional (debugging nil) 23 | &aux plnpr) 24 | (setq plnpr 25 | (create-planning-problem 26 | title (make-blocks-basis-set blocks-list))) 27 | (in-plnpr plnpr) 28 | (set-debug-plnpr debugging) 29 | (with-atre (plnpr-atre plnpr) 30 | (load *blocks-file*) ;; Load basic definitions 31 | (dolist (block blocks-list) 32 | (assert! `(block ,block) 'Definition)) 33 | (run-rules) 34 | (setup-choice-sets plnpr)) 35 | plnpr) 36 | 37 | (defun make-blocks-basis-set (blocks &aux basis) 38 | (dolist (block blocks) 39 | ;; what the block can be on. 40 | (push `((Holding ,block) (On ,block Table) 41 | ,@ (mapcar #'(lambda (other) 42 | `(On ,block ,other)) 43 | (remove block blocks))) 44 | basis) 45 | ;;; What can be on the block 46 | (push `((Holding ,block) (Clear ,block) 47 | ,@ (mapcar #'(lambda (other) 48 | `(ON ,other ,block)) 49 | (remove block blocks))) 50 | basis)) 51 | (cons `((HAND-EMPTY) 52 | ,@ (mapcar #'(lambda (block) 53 | `(HOLDING ,block)) blocks)) 54 | basis)) 55 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/csp.lisp: -------------------------------------------------------------------------------- 1 | (defvar *atms* nil) 2 | 3 | (defun add-var (x vs) 4 | (let ((ns (mapcar #'(lambda (v) 5 | (tms-create-node *atms* (list x v) :assumptionp t)) 6 | vs))) 7 | (loop for a in ns 8 | do (loop for b in ns 9 | when (not (equal (tms-node-datum a) (tms-node-datum b))) 10 | do (nogood-nodes 'unique-value (list a b)))) 11 | ns)) 12 | 13 | (defun add-con (xs ys allowed) 14 | (loop for a in xs 15 | do (loop for b in ys 16 | when (not (member (list (cadr (tms-node-datum a)) (cadr (tms-node-datum b))) allowed :test #'equal)) 17 | do (nogood-nodes 'not-allowed (list a b))))) 18 | 19 | (defun find-var (x vars) 20 | (find-if #'(lambda (line) (equal x (car (tms-node-datum (car line))))) vars)) 21 | 22 | (defun csp (var-defs con-defs) 23 | (setq *atms* (create-atms "csp" :debugging t)) 24 | (let ((vars (mapcar #'(lambda (line) (add-var (car line) (cdr line))) var-defs))) 25 | (mapcar #'(lambda (line) (add-con (find-var (caar line) vars) 26 | (find-var (cadar line) vars) 27 | (cdr line))) 28 | con-defs) 29 | (let ((i (interpretations *atms* vars))) 30 | (mapcar #'print-env i) 31 | i))) 32 | 33 | (csp '((x a b) 34 | (y e f) 35 | (z c d g)) 36 | '(((x y) (b e) (b f)) 37 | ((x z) (b c) (b d) (b g)) 38 | ((y z) (e d) (f g)))) 39 | 40 | (csp '((n1 r g b) 41 | (n2 r g b) 42 | (n3 r g b)) 43 | '(((n1 n2) (r g) (r b) (g r) (g b) (b r) (b g)) 44 | ((n2 n3) (r g) (r b) (g r) (g b) (b r) (b g)) 45 | ((n1 n3) (r g) (r b) (g r) (g b) (b r) (b g)))) 46 | 47 | (csp '((n1 r g b) 48 | (n2 r g b) 49 | (n3 r g b) 50 | (n4 r g b)) 51 | '(((n1 n2) (r g) (r b) (g r) (g b) (b r) (b g)) 52 | ((n2 n3) (r g) (r b) (g r) (g b) (b r) (b g)) 53 | ((n1 n3) (r g) (r b) (g r) (g b) (b r) (b g)) 54 | ((n1 n4) (r g) (r b) (g r) (g b) (b r) (b g)) 55 | ((n2 n4) (r g) (r b) (g r) (g b) (b r) (b g)) 56 | ((n3 n4) (r g) (r b) (g r) (g b) (b r) (b g)))) 57 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/interactive-ex.lisp: -------------------------------------------------------------------------------- 1 | (setq *atms* (create-atms "Simple Example")) 2 | (setq assumption-a (tms-create-node *atms* "A" :assumptionp t) 3 | assumption-c (tms-create-node *atms* "C" :assumptionp t) 4 | assumption-e (tms-create-node *atms* "E" :assumptionp t)) 5 | 6 | (setq node-h (tms-create-node *atms* "h")) 7 | (justify-node "R1" node-h (list assumption-c assumption-e)) 8 | (why-node node-h) 9 | 10 | (setq node-g (tms-create-node *atms* "g")) 11 | (justify-node "R2" node-g (list assumption-a assumption-c)) 12 | (setq contradiction (tms-create-node *atms* 'contradiction :contradictoryp t)) 13 | (justify-node "R3" contradiction (list node-g)) 14 | (why-node node-g) 15 | 16 | (mapc 'print-env (interpretations *atms* nil (atms-assumptions *atms*))) 17 | 18 | (mapcar #'(lambda (le) 19 | (in-node? node-h le)) 20 | (interpretations *atms* nil (atms-assumptions *atms*))) 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/my.lisp: -------------------------------------------------------------------------------- 1 | (setq *pack-ltms* t) 2 | (bps-load-file (make-bps-path "ltms") "ltms" :action :compile) 3 | (bps-load-file (make-bps-path "ltms") "cltms" :action :compile) 4 | (in-package :COMMON-LISP-USER) 5 | (bps-load-file (make-bps-path "atms") "atre" :action :compile) 6 | (bps-load-file (make-bps-path "atms") "atms" :action :compile) 7 | (compile-atre) 8 | ;;(compile-planner) 9 | 10 | (bps-load-file (make-bps-path "atms") "prob" :action :compile) 11 | (bps-load-file (make-bps-path "atms") "causality" :action :compile) 12 | (bps-load-file (make-bps-path "atms") "causality-ex" :action :compile) 13 | 14 | (bps-load-file (make-bps-path "atms") "sudoku" :action :compile) 15 | (solve-sudoku *easy-puzzle*) 16 | 17 | (bps-load-file (make-bps-path "atms") "atest" :action :compile) 18 | (atms-test1) 19 | (atms-test2) 20 | (step-1) 21 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/plan-a.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Antecedent Planner (a.k.a. Plan-A) 4 | ;; Last edited: 1/29/93, KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | ;; This algorithm assumes that every choice in each choice set 17 | ;; has become an assumption, but that states have not yet been 18 | ;; generated. 19 | 20 | ;; Notice how the ability to use environments as explicit 21 | ;; objects lets us revert back to CPS-like code! 22 | 23 | (defun Plan-a (start goal &optional (*plnpr* *plnpr*)) 24 | ;; Here start is a specific environment. 25 | ;; The goal is a list of conjunctions 26 | (do ((queue (list (list start)) 27 | (nconc (cdr queue) new-sprouts)) 28 | (new-sprouts nil nil) 29 | (found? nil) (result nil) 30 | (number-examined 1 (1+ number-examined))) 31 | ((or found? (null queue)) 32 | (values (setf (getf (plnpr-plist *plnpr*) 33 | :PLAN) found?) 34 | number-examined)) 35 | (cond ((satisfies-goal? (caar queue) goal) 36 | (setq found? (car queue))) 37 | (t (dolist (op-inst (find-applicable-operators 38 | (caar queue))) 39 | (setq result 40 | (apply-operator (caar queue) 41 | op-inst)) 42 | (unless (member result (car queue)) 43 | (debug-plnpr t 44 | "~% Reaching ~A via ~A on ~A.." 45 | result op-inst (caar queue)) 46 | (push (cons result 47 | (cons op-inst (car queue))) 48 | new-sprouts))))))) 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/plan-e.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; ATMS-based Envisioner for planning problems 4 | ;; Last edited: 1/29/93, KDF 5 | 6 | ;;; Copyright (c) 1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun envision (&optional (*plnpr* *plnpr*) 17 | &aux states) 18 | (setq states (solutions (plnpr-atre *plnpr*) 19 | (plnpr-basis-set *plnpr*))) 20 | (setf (getf (plnpr-plist *plnpr*) :STATES) states) 21 | (setf (getf (plnpr-plist *plnpr*) :TRANSITIONS) 22 | (apply-all-operators states))) 23 | 24 | (defun apply-all-operators (states) 25 | (mapcar 26 | #'(lambda (state &aux entry) 27 | (dolist (op-inst (find-applicable-operators state) 28 | entry) 29 | (push (cons op-inst (apply-operator state op-inst)) 30 | entry)) 31 | (push state entry)) states)) 32 | 33 | (defun show-envisionment (&optional (*plnpr* *plnpr*) 34 | (stream *standard-input*) 35 | &aux states trans-table) 36 | (setq states (getf (plnpr-plist *plnpr*) :STATES)) 37 | (cond ((null states) 38 | (format stream "~%The state space is empty.")) 39 | (t (format stream 40 | "~% ~D states have been generated:" 41 | (length states)) 42 | (dolist (state states) 43 | (print-env state stream)) 44 | (format stream "~%Transition Table:") 45 | (setq trans-table 46 | (getf (plnpr-plist *plnpr*) :TRANSITIONS)) 47 | (if (null trans-table) (format stream " empty.") 48 | (dolist (state-entry trans-table) 49 | (format stream "~% ~A: " (car state-entry)) 50 | (dolist (pair (cdr state-entry)) 51 | (format stream "~% ~A -> ~A" 52 | (car pair) (cdr pair)))))))) 53 | 54 | ;;;; Finding plans by searching the envisionment 55 | 56 | (defun find-plan (start goals &optional (*plnpr* *plnpr*)) 57 | (let ((goal-states (fetch-states goals)) 58 | (start-states (fetch-states start))) 59 | (debug-plnpr t "~%Initial states are ~A." start-states) 60 | (debug-plnpr t "~%Goal states are ~A." goal-states) 61 | (do ((queue (mapcar #'(lambda (state) 62 | (list state)) start-states) 63 | (nconc (cdr queue) new-sprouts)) 64 | (new-sprouts nil nil) 65 | (transitions (getf (plnpr-plist *plnpr*) 66 | :TRANSITIONS)) 67 | (found? nil)) 68 | ((or found? (null queue)) 69 | (setf (getf (plnpr-plist *plnpr*) :PLAN) found?)) 70 | (cond ((member (caar queue) goal-states) ;got it 71 | (setq found? (car queue))) 72 | (t (dolist (transition 73 | (cdr (assoc (caar queue) 74 | transitions))) 75 | (unless (member (cdr transition) 76 | (cdar queue)) ;avoid loops 77 | (debug-plnpr t 78 | "~% Can reach ~A via ~A from ~A." 79 | (cdr transition) (car transition) 80 | (caar queue)) 81 | (push (cons (cdr transition) 82 | (cons (car transition) 83 | (car queue))) 84 | new-sprouts)))))))) -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/prob.lisp: -------------------------------------------------------------------------------- 1 | (defstruct (numeric (:PRINT-FUNCTION print-numeric)) 2 | (title nil) 3 | (+ nil) 4 | (* nil) 5 | (- nil) 6 | (/ nil)) 7 | 8 | (defun print-numeric (causal stream ignore) 9 | (declare (ignore ignore)) 10 | (format stream "#" (numeric-title causal))) 11 | 12 | (setq 13 | *numeric* 14 | (make-numeric 15 | :title "numeric" 16 | :+ #'+ 17 | :* #'* 18 | :- #'- 19 | :/ #'/)) 20 | 21 | (defun symbolic-* (&rest xs) 22 | (let ((xs (remove-if #'(lambda (x) (eql 1 x)) xs))) 23 | (if (null xs) 24 | 1 25 | (if (null (cdr xs)) 26 | (car xs) 27 | (cons '* xs))))) 28 | 29 | (defun symbolic-+ (&rest xs) 30 | (let ((xs (remove-if #'(lambda (x) (eql 0 x)) xs))) 31 | (if (null xs) 32 | 0 33 | (if (null (cdr xs)) 34 | (car xs) 35 | (cons '+ xs))))) 36 | 37 | (defun symbolic-- (&rest xs) 38 | (if (and (not (null (cdr xs))) (null (cddr xs)) (eql 0 (cadr xs))) 39 | (car xs) 40 | (cons '- xs))) 41 | 42 | (defun symbolic-/ (&rest xs) 43 | (if (and (= 2 (length xs)) (equal (car xs) (cadr xs))) 44 | 1 ;; ignoring div by 0 45 | (cons '/ xs))) 46 | 47 | (setq 48 | *symbolic* 49 | (make-numeric 50 | :title "symbolic" 51 | :+ #'symbolic-+ 52 | :* #'symbolic-* 53 | :- #'symbolic-- 54 | :/ #'symbolic-/)) 55 | -------------------------------------------------------------------------------- /src/main/scala/assumptionbased/ruleengine/unify.lisp: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp; -*- 2 | 3 | ;;;; Variables and unification 4 | ;; Last edited 1/29/93, by KDF 5 | 6 | ;;; Copyright (c) 1988-1993, Kenneth D. Forbus, Northwestern University, 7 | ;;; and Johan de Kleer, the Xerox Corporation. 8 | ;;; All rights reserved. 9 | 10 | ;;; See the file legal.txt for a paragraph stating scope of permission 11 | ;;; and disclaimer of warranty. The above copyright notice and that 12 | ;;; paragraph must be included in any separate copy of this file. 13 | 14 | (in-package :COMMON-LISP-USER) 15 | 16 | (defun variable? (x) 17 | (and (symbolp x) ;A symbol whose first character is "?" 18 | (char= #\? (elt (symbol-name x) 0)))) 19 | 20 | (defun unify (a b &optional (bindings nil)) 21 | (cond ((equal a b) bindings) 22 | ((variable? a) (unify-variable a b bindings)) 23 | ((variable? b) (unify-variable b a bindings)) 24 | ((or (not (listp a)) (not (listp b))) :FAIL) 25 | ((not (eq :FAIL (setq bindings 26 | (unify (car a) (car b) bindings)))) 27 | (unify (cdr a) (cdr b) bindings)) 28 | (t :FAIL))) 29 | 30 | (defun unify-variable (var exp bindings &aux val) 31 | ;; Must distinguish no value from value of nil 32 | (setq val (assoc var bindings)) 33 | (cond (val (unify (cdr val) exp bindings)) 34 | ;; If safe, bind to 35 | ((free-in? var exp bindings) (cons (cons var exp) bindings)) 36 | (t :FAIL))) 37 | 38 | (defun free-in? (var exp bindings) 39 | ;; Returns nil if occurs in , assuming . 40 | (cond ((null exp) t) 41 | ((equal var exp) nil) 42 | ((variable? exp) 43 | (let ((val (assoc exp bindings))) 44 | (if val 45 | (free-in? var (cdr val) bindings) 46 | t))) 47 | ((not (listp exp)) t) 48 | ((free-in? var (car exp) bindings) 49 | (free-in? var (cdr exp) bindings)))) 50 | -------------------------------------------------------------------------------- /src/main/scala/justificationbased/ruleengine/Datum.scala: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.justificationbased.ruleengine 19 | import scala.collection.mutable.{ListBuffer, HashSet, HashMap} 20 | import org.maraist.truthmaintenancesystems.justificationbased.{ 21 | Node, Just, Justification} 22 | 23 | /** 24 | * FILL IN 25 | * 26 | * The initialization of `node`, and the storage to `dbClass.facts`, 27 | * were originally in the Lisp `defun insert`. The `plist` slot of 28 | * the `defstruct` is not written to or read from any point of the 29 | * Lisp code, and has been dropped. 30 | * 31 | * @param id 32 | * @param fact 33 | * @param dbClass 34 | * @param jtms 35 | */ 36 | class Datum private[justificationbased] (jtre: JTRE, val fact: Fact) { 37 | 38 | val id: Int = jtre.incfDatumCounter 39 | 40 | val dbClass: DbClass = jtre.getDbClass(fact) 41 | 42 | var node: Node[Datum, Fact, Rule] = jtre.jtms.createNode(this) 43 | 44 | var isAssumption: Option[Fact] = None 45 | 46 | dbClass.facts += this 47 | 48 | // (defstruct (datum (:PRINT-FUNCTION jtre-datum-printer)) 49 | // id ; Unique ID for easy lookup 50 | // lisp-form ; Expression for pattern-matching 51 | // (tms-node nil) ; Pointer into TMS 52 | // dbclass ; Dbclass of the corresponding pattern 53 | // (assumption? nil) ; if non-nil, indicates informant 54 | // (plist nil)) ; local property list 55 | 56 | override def toString: String = s"" 57 | def jtreDatumPrinter: Unit = println(this.toString) 58 | // (defun jtre-datum-printer (d st ignore) 59 | // (declare (ignore ignore)) 60 | // (format st "" (datum-id d))) 61 | 62 | def showDatum: String = fact.toString 63 | // (defun show-datum (datum) 64 | // (format nil "~A" (datum-lisp-form datum))) 65 | } 66 | 67 | -------------------------------------------------------------------------------- /src/main/scala/justificationbased/ruleengine/JTMS.scala-x: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.justificationbased.ruleengine 19 | import scala.util.control.NonLocalReturns.* 20 | import scala.collection.mutable.{ListBuffer, HashSet, HashMap, Queue} 21 | import org.maraist.truthmaintenancesystems.justificationbased 22 | import org.maraist.truthmaintenancesystems.justificationbased.{ 23 | ContraAssumptions, TmsContradictionHandler, Node} 24 | 25 | /** Implementation of justification-based truth maintenance systems. 26 | * 27 | * @param title Name of this TMS, for output. 28 | * @param nodeString Default formatter for TMS nodes. 29 | * @param debugging Debugging flag. 30 | * @param enqueueProcedure 31 | * @param contradictionHandler External handler for detecting contradictions. 32 | * @param checkingContradictions For external systems. 33 | * @tparam I Type of (external) informants in justifications. 34 | */ 35 | class JTMS[I]( 36 | theTitle: String, 37 | theNodeString: (Node[Datum[I], I, Rule[I]]) => String = 38 | (n: Node[Datum[I], I, Rule[I]]) => s"${n.datum.toString()}", 39 | theDebugging: Boolean = false, 40 | theCheckingContradictions: Boolean = true, 41 | theEnqueueProcedure: Option[(Rule[I]) => Unit] = None, 42 | theContradictionHandler: Option[ 43 | (justificationbased.JTMS[Datum[I], I, Rule[I]], 44 | ListBuffer[Node[Datum[I], I, Rule[I]]]) 45 | => Unit 46 | ] = None 47 | ) 48 | extends justificationbased.JTMS( 49 | theTitle, theNodeString, theDebugging, theCheckingContradictions, 50 | theEnqueueProcedure, theContradictionHandler) 51 | -------------------------------------------------------------------------------- /src/main/scala/justificationbased/ruleengine/Just.scala-x: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.justificationbased.ruleengine 19 | import scala.collection.mutable.{ListBuffer, HashSet, HashMap} 20 | import org.maraist.truthmaintenancesystems.justificationbased.{Node} 21 | 22 | type Justification[D, I] = Just[D, I] | Symbol 23 | 24 | class Just[D, I]( 25 | val index: Int, 26 | val informant: I, 27 | val consequence: Node[D, I], 28 | val antecedents: ListBuffer[Node[D, I]] 29 | ) { 30 | // (defstruct (just (:PRINT-FUNCTION print-just)) 31 | // (index 0) 32 | // informant 33 | // consequence 34 | // antecedents) 35 | 36 | override def toString: String = s"" 37 | def printJust: Unit = println(this.toString) 38 | // (defun print-just (just stream ignore) 39 | // (declare (ignore ignore)) 40 | // (format stream "#" (just-index just))) 41 | 42 | def checkJustification: Boolean = 43 | consequence.isOutNode && isJustificationSatisfied 44 | // (defun check-justification (just) 45 | // (and (out-node? (just-consequence just)) 46 | // (justification-satisfied? just))) 47 | 48 | def isJustificationSatisfied: Boolean = antecedents.forall(_.isInNode) 49 | // (defun justification-satisfied? (just) 50 | // (every #'in-node? (just-antecedents just))) 51 | 52 | def getBlurb: String = 53 | s"($index) $informant ${consequence.datum} <= ${antecedents.map(_.datum).mkString(", ")}" 54 | def detailJust: Unit = println(getBlurb) 55 | 56 | } // class Just 57 | -------------------------------------------------------------------------------- /src/main/scala/random/AtmsMaker.scala: -------------------------------------------------------------------------------- 1 | // Copyright (C) 2021, 2022 John Maraist. 2 | // All rights reserved. 3 | // 4 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 5 | // with this work for a paragraph stating scope of permission and 6 | // disclaimer of warranty, and for additional information regarding 7 | // copyright ownership. The above copyright notice and that paragraph 8 | // must be included in any separate copy of this file. 9 | // 10 | // Unless required by applicable law or agreed to in writing, software 11 | // distributed under the License is distributed on an "AS IS" BASIS, 12 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 13 | // implied, for NON-COMMERCIAL use. See the License for the specific 14 | // language governing permissions and limitations under the License. 15 | 16 | package org.maraist.truthmaintenancesystems.random 17 | import scala.util.Random 18 | import org.maraist.truthmaintenancesystems.assumptionbased.ATMS 19 | 20 | class AtmsMaker(random: Random) extends Maker(random) { 21 | def this(seed: Int) = this(new Random(seed)) 22 | def this(seed: Long) = this(new Random(seed)) 23 | def this() = this(new Random()) 24 | 25 | def makeATMS( 26 | assumptionsRange: IntRange = IntRange(300, 300), 27 | nonassumptionsRange: IntRange = IntRange(8000, 8000), 28 | contradictionChance: Float = 0.05, 29 | justificationsPerConclusion: IntRange = IntRange(10, 12), 30 | antecedentsPerJustifications: IntRange = IntRange(6, 12), 31 | cyclic: Boolean = false 32 | ): 33 | ATMS[Int, String, Nothing] = { 34 | val atms = new ATMS[Int, String, Nothing]("Random ATMS") 35 | 36 | val assumptions = assumptionsRange.get 37 | val nonassumptions = nonassumptionsRange.get 38 | val totalNodes = assumptions + nonassumptions 39 | 40 | for (i <- 0 until assumptions) do atms.createNode(i, isAssumption = true) 41 | 42 | for (i <- 0 until nonassumptions) do { 43 | val isContradiction = random.nextFloat < contradictionChance 44 | val idx = assumptions + i 45 | atms.createNode(idx, isContradictory = isContradiction) 46 | } 47 | 48 | for (i <- 0 until nonassumptions) do { 49 | val idx = assumptions + i 50 | val node = atms.nodes(idx) 51 | val justifications = justificationsPerConclusion.get 52 | for (j <- 0 until justifications) do { 53 | val thisSize = antecedentsPerJustifications.get 54 | val ants = ( 55 | if cyclic 56 | then intSet(thisSize, IntRange(0, idx)) 57 | else intSetExcept(thisSize, IntRange(0, totalNodes), j) 58 | ).map(atms.nodes(_)) 59 | atms.justifyNode(s"$idx.$j", node, ants.toList) 60 | } 61 | } 62 | 63 | atms 64 | } 65 | } 66 | 67 | @main def randomAtms: Unit = { 68 | import java.util.Date 69 | val maker = new AtmsMaker() 70 | var totalMS: Long = 0 71 | val runs: Int = 100 72 | 73 | for (i <- 1 to runs) do { 74 | java.lang.System.gc() 75 | print(s"($i) ") 76 | val start = new Date 77 | val atms = maker.makeATMS() 78 | val end = new Date 79 | val elapsed = end.getTime - start.getTime 80 | println(f"${atms.nodes.size}%,d nodes, ${atms.justs.size}%,d justifications, elapsed time ${elapsed}%,dms") 81 | totalMS = totalMS + elapsed 82 | } 83 | println(f"Average time ${totalMS / runs}%,d") 84 | } 85 | -------------------------------------------------------------------------------- /src/main/scala/random/Maker.scala: -------------------------------------------------------------------------------- 1 | // Copyright (C) 2021, 2022 John Maraist. 2 | // All rights reserved. 3 | // 4 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 5 | // with this work for a paragraph stating scope of permission and 6 | // disclaimer of warranty, and for additional information regarding 7 | // copyright ownership. The above copyright notice and that paragraph 8 | // must be included in any separate copy of this file. 9 | // 10 | // Unless required by applicable law or agreed to in writing, software 11 | // distributed under the License is distributed on an "AS IS" BASIS, 12 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 13 | // implied, for NON-COMMERCIAL use. See the License for the specific 14 | // language governing permissions and limitations under the License. 15 | 16 | package org.maraist.truthmaintenancesystems.random 17 | import scala.util.Random 18 | import scala.collection.mutable.ListBuffer 19 | import org.maraist.truthmaintenancesystems.utils.Printing.* 20 | import org.maraist.truthmaintenancesystems.assumptionbased.Blurb 21 | 22 | class Maker(val random: Random) { 23 | def this(seed: Int) = this(new Random(seed)) 24 | def this(seed: Long) = this(new Random(seed)) 25 | def this() = this(new Random()) 26 | given Random = random 27 | 28 | def intSet(size: Int, range: IntSampler): ListBuffer[Int] = { 29 | val buf = new ListBuffer[Int] 30 | while buf.size < size do buf += range.get 31 | buf 32 | } 33 | 34 | def intSetExcept(size: Int, range: IntSampler, disallow: Int): 35 | ListBuffer[Int] = { 36 | val buf = new ListBuffer[Int] 37 | while buf.size < size do { 38 | val add = range.get 39 | if add != disallow then buf += add 40 | } 41 | buf 42 | } 43 | } 44 | 45 | trait IntSampler { 46 | def get(using random: Random): Int 47 | } 48 | 49 | class IntRange(lower: Int, upper: Int) extends IntSampler { 50 | private val nextArg = upper - lower + 1 51 | def get(using random: Random): Int = 52 | if lower < upper then random.nextInt(nextArg) + lower else lower 53 | } 54 | -------------------------------------------------------------------------------- /src/main/scala/utils/Printing.scala: -------------------------------------------------------------------------------- 1 | // Copyright (C) 2021 John Maraist. 2 | // All rights reserved. 3 | // 4 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 5 | // with this work for a paragraph stating scope of permission and 6 | // disclaimer of warranty, and for additional information regarding 7 | // copyright ownership. The above copyright notice and that paragraph 8 | // must be included in any separate copy of this file. 9 | // 10 | // Unless required by applicable law or agreed to in writing, software 11 | // distributed under the License is distributed on an "AS IS" BASIS, 12 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 13 | // implied, for NON-COMMERCIAL use. See the License for the specific 14 | // language governing permissions and limitations under the License. 15 | 16 | package org.maraist.truthmaintenancesystems.utils 17 | 18 | object Printing { 19 | def plural(n: Int, ifPlural: String = "s", ifSingular: String = "") = 20 | n match { 21 | case 1 => ifSingular 22 | case _ => ifPlural 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /src/test/haskell/Spec.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Description : Testing truth maintenance systems (TMSes) 3 | Copyright : (c) John Maraist, 2022 4 | Kenneth D. Forbus, Johan de Kleer and Xerox Corporation, 1986-1993 5 | License : AllRightsReserved 6 | Maintainer : haskell-tms@maraist.org 7 | Stability : experimental 8 | Portability : POSIX 9 | 10 | Testing the translation of Forbus and de Kleer's various truth 11 | maintenance systems (TMSes) from Common Lisp to Haskell. 12 | 13 | See the @LICENSE.txt@ and @README-forbus-dekleer.txt@ files 14 | distributed with this work for a paragraph stating scope of permission 15 | and disclaimer of warranty, and for additional information regarding 16 | copyright ownership. The above copyright notice and that paragraph 17 | must be included in any separate copy of this file. 18 | 19 | Unless required by applicable law or agreed to in writing, software 20 | distributed under the License is distributed on an "AS IS" BASIS, 21 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 22 | implied, for NON-COMMERCIAL use. See the License for the specific 23 | language governing permissions and limitations under the License. 24 | 25 | -} 26 | 27 | {-# LANGUAGE RankNTypes #-} 28 | 29 | import Data.TMS.JTMS 30 | import Data.TMS.ATMS.ATMST 31 | import Control.Monad.ST.Trans 32 | import Test.TLT 33 | import JTMSTests 34 | import ATMSTests 35 | 36 | main :: IO () 37 | main = do 38 | runSTT $ tlt $ do 39 | inGroup "JTMS tests" $ runJTMST $ do 40 | testEx1 41 | testEx3 42 | inGroup "ATMS tests" $ runATMST $ do 43 | ex1AndTest 44 | -------------------------------------------------------------------------------- /src/test/scala/jtmstests/JtmsCoreEx2.scala: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.justificationbased.tests 19 | import scala.language.adhocExtensions 20 | import org.scalatest.flatspec.AnyFlatSpec 21 | import org.scalatest.matchers.should.* 22 | import org.maraist.truthmaintenancesystems.justificationbased.* 23 | 24 | class JTMScoreEx2 extends AnyFlatSpec with Matchers with JTMScoreEx1 25 | with JTMSexample[Symbol, String, Nothing]("Simple example") { 26 | val contra = j.createNode(Symbol("Loser"), contradictionP = true) 27 | 28 | override def beliefsString: String = 29 | s"${super.beliefsString} contra:${contra.believed}" 30 | 31 | override def contradictoryString: String = 32 | s"${super.beliefsString} contra:${contra.isContradictory}" 33 | 34 | "JTMS ex2" `should` "all pass" in { 35 | na.enableAssumption 36 | nb.enableAssumption 37 | nc.enableAssumption 38 | nd.enableAssumption 39 | 40 | // showAll(s"Before contra justify") 41 | j.justifyNode("j5", contra, List(ne, nf)) 42 | // showAll(s"After contra justify") 43 | 44 | // (Defun ex2 () ;; uses Ex1 to test the contradiction stuff. 45 | // (setq contra (tms-create-node *jtms* 'Loser :contradictoryp T)) 46 | // (justify-node 'j5 contra (list ne nf))) 47 | } 48 | } 49 | -------------------------------------------------------------------------------- /src/test/scala/jtmstests/Utils.scala: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.justificationbased.tests 19 | import scala.language.adhocExtensions 20 | import scala.collection.mutable.ListBuffer 21 | import org.scalatest.flatspec.AnyFlatSpec 22 | import org.scalatest.matchers.should.* 23 | import org.maraist.truthmaintenancesystems.justificationbased.* 24 | 25 | trait JTMSexample[DatumType, InformantType, R](name: String) { 26 | val j = new JTMS[DatumType, InformantType, R](name, debugging = false) 27 | 28 | def beliefsString: String 29 | def contradictoryString: String 30 | 31 | def showAll(tag: String): Unit = { 32 | println(tag) 33 | showBeliefs(" Believed :: ") 34 | showContradictory(" Contradictory :: ") 35 | } 36 | 37 | def showBeliefs(tag: String = ""): Unit = println(s"$tag$beliefsString") 38 | 39 | def showContradictory(tag: String = ""): Unit = 40 | println(s"$tag$contradictoryString") 41 | } 42 | 43 | // (defun get-node (datum jtms) 44 | // (dolist (node (jtms-nodes jtms)) 45 | // (if (equal datum (tms-node-datum node)) (return node)))) 46 | 47 | // (defun get-justification (num jtms) 48 | // (dolist (just (jtms-justs jtms)) 49 | // (if (= num (just-index just)) (return just)))) 50 | 51 | // (proclaim '(special na nb nc nd ne nf ng contra *jtms*)) 52 | 53 | 54 | -------------------------------------------------------------------------------- /src/test/scala/jtmstests/ruleengine/JtmsCoreEx2.scala: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.justificationbased.ruleengine.tests 19 | import scala.language.adhocExtensions 20 | import org.scalatest.flatspec.AnyFlatSpec 21 | import org.scalatest.matchers.should.* 22 | import org.maraist.truthmaintenancesystems.justificationbased.ruleengine.* 23 | 24 | class JTMScoreEx2 extends AnyFlatSpec with Matchers with JTMScoreEx1 25 | with JTMSexample[Symbol, String, Unit]("JTMS+JTRE simple example") { 26 | val contra = j.createNode(Symbol("Loser"), contradictionP = true) 27 | 28 | override def beliefsString: String = 29 | s"${super.beliefsString} contra:${contra.believed}" 30 | 31 | override def contradictoryString: String = 32 | s"${super.beliefsString} contra:${contra.isContradictory}" 33 | 34 | "JTMS+JTRE ex2" `should` "all pass" in { 35 | na.enableAssumption 36 | nb.enableAssumption 37 | nc.enableAssumption 38 | nd.enableAssumption 39 | 40 | // showAll(s"Before contra justify") 41 | j.justifyNode("j5", contra, List(ne, nf)) 42 | // showAll(s"After contra justify") 43 | 44 | // (Defun ex2 () ;; uses Ex1 to test the contradiction stuff. 45 | // (setq contra (tms-create-node *jtms* 'Loser :contradictoryp T)) 46 | // (justify-node 'j5 contra (list ne nf))) 47 | } 48 | } 49 | -------------------------------------------------------------------------------- /src/test/scala/jtmstests/ruleengine/Utils.scala: -------------------------------------------------------------------------------- 1 | // Copyright (c) 1986-1993, Kenneth D. Forbus, Northwestern University 2 | // and Johan de Kleer, the Xerox Corporation. 3 | // Copyright (C) 2021 John Maraist. 4 | // All rights reserved. 5 | // 6 | // See the LICENSE.txt and README-forbus-dekleer.txt files distributed 7 | // with this work for a paragraph stating scope of permission and 8 | // disclaimer of warranty, and for additional information regarding 9 | // copyright ownership. The above copyright notice and that paragraph 10 | // must be included in any separate copy of this file. 11 | // 12 | // Unless required by applicable law or agreed to in writing, software 13 | // distributed under the License is distributed on an "AS IS" BASIS, 14 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 15 | // implied, for NON-COMMERCIAL use. See the License for the specific 16 | // language governing permissions and limitations under the License. 17 | 18 | package org.maraist.truthmaintenancesystems.justificationbased.ruleengine.tests 19 | import scala.language.adhocExtensions 20 | import scala.collection.mutable.ListBuffer 21 | import org.scalatest.flatspec.AnyFlatSpec 22 | import org.scalatest.matchers.should.* 23 | import org.maraist.truthmaintenancesystems.justificationbased.ruleengine.* 24 | import org.maraist.truthmaintenancesystems.justificationbased.JTMS 25 | 26 | trait JTMSexample[DatumType, InformantType, R](name: String) { 27 | val j = new JTMS[DatumType, InformantType, R](name, debugging = false) 28 | 29 | def beliefsString: String 30 | def contradictoryString: String 31 | 32 | def showAll(tag: String): Unit = { 33 | println(tag) 34 | showBeliefs(" Believed :: ") 35 | showContradictory(" Contradictory :: ") 36 | } 37 | 38 | def showBeliefs(tag: String = ""): Unit = println(s"$tag$beliefsString") 39 | 40 | def showContradictory(tag: String = ""): Unit = 41 | println(s"$tag$contradictoryString") 42 | } 43 | 44 | // (defun get-node (datum jtms) 45 | // (dolist (node (jtms-nodes jtms)) 46 | // (if (equal datum (tms-node-datum node)) (return node)))) 47 | 48 | // (defun get-justification (num jtms) 49 | // (dolist (just (jtms-justs jtms)) 50 | // (if (= num (just-index just)) (return just)))) 51 | 52 | // (proclaim '(special na nb nc nd ne nf ng contra *jtms*)) 53 | 54 | 55 | -------------------------------------------------------------------------------- /stack-profile: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | stack build --profile 3 | 4 | echo Time profiling 5 | stack exec --profile -- hbps_profile +RTS -p # Time profile 6 | 7 | echo Space profiling 8 | stack exec --profile -- hbps_profile +RTS -h # Heap profile 9 | hp2ps -e8in -c hbps_profile.hp 10 | -------------------------------------------------------------------------------- /stack-running: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | stack build --file-watch \ 3 | --copy-bins \ 4 | --haddock BPS \ 5 | --exec 'echo All targets completed' \ 6 | --exec '/home/jm/.local/bin/hbps' \ 7 | -------------------------------------------------------------------------------- /stack-testing: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | stack build --file-watch --test --copy-bins --haddock BPS --exec 'echo All targets completed' --exec 'echo For doc files: stack haddock --open BPS' 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: 21 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # subdirs: 30 | # - auto-update 31 | # - wai 32 | packages: 33 | - . 34 | 35 | # Dependency packages to be pulled from upstream that are not in the resolver. 36 | # These entries can reference officially published versions as well as 37 | # forks / in-progress versions pinned to a git hash. For example: 38 | # 39 | # extra-deps: 40 | # - acme-missiles-0.3 41 | # - git: https://github.com/commercialhaskell/stack.git 42 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 43 | # 44 | # extra-deps: [] 45 | 46 | extra-deps: 47 | - TLT-0.1.0.0 48 | 49 | # Override default flag values for local packages and extra-deps 50 | # flags: {} 51 | 52 | # Extra package databases containing global packages 53 | # extra-package-dbs: [] 54 | 55 | # Control whether we use the GHC we find on the path 56 | # system-ghc: true 57 | # 58 | # Require a specific version of stack, using version ranges 59 | # require-stack-version: -any # Default 60 | # require-stack-version: ">=2.7" 61 | # 62 | # Override the architecture used by stack, especially useful on Windows 63 | # arch: i386 64 | # arch: x86_64 65 | # 66 | # Extra directories used by stack for building 67 | # extra-include-dirs: [/path/to/dir] 68 | # extra-lib-dirs: [/path/to/dir] 69 | # 70 | # Allow a newer minor version of GHC than the snapshot specifies 71 | # compiler-check: newer-minor 72 | --------------------------------------------------------------------------------