Substitute with the version from the video

2025-04-12 19:40:32 -07:00
parent 288c999c0e
commit 2e819b454f
7 changed files with 162 additions and 168 deletions
--- a/app/Binding.hs
+++ b/app/Binding.hs
@@ -1,49 +1,50 @@
-module Binding 
+module Binding
 ( newVar, unify, instantiate
 ) where
+import Primitives
 import Terms
 import Nondeterminism
-import Primitives
-import Control.Monad 
+import Control.Monad
 import Control.Applicative

-newVar :: Name -> PrologStream Var
+newVar :: Name -> PrologStream Slot
 newVar name = reversibly (newVarPrim name) unnewVarPrim

-getVar :: Var -> PrologStream (Maybe Term)
-getVar var = liftPrologIO (getVarPrim var)
+getVar :: Slot -> PrologStream (Maybe Term)
+getVar slot = liftPrologIO (getVarPrim slot)

-setVar :: Var -> Term -> PrologStream ()
-setVar var value = reversibly set unset
-  where 
-  set = do 
-    oldValue <- getVarPrim var
-    when (oldValue /= Nothing) (errorPrim "cannot set var that is currently set")
-    setVarPrim var (Just value)
+setVar :: Slot -> Term -> PrologStream ()
+setVar slot value = reversibly set unset
+  where
+  set = do
+    oldValue <- getVarPrim slot
+    when (oldValue /= Nothing) (errorPrim "cannot set var that is already set")
+    setVarPrim slot (Just value)
  unset = do
-    oldValue <- getVarPrim var
+    oldValue <- getVarPrim slot
    when (oldValue == Nothing) (errorPrim "cannot unset var that is already unset")
-    setVarPrim var Nothing
-
+    setVarPrim slot Nothing
+  
 unify :: Term -> Term -> PrologStream ()
 unify (Compound h0 args0) (Compound h1 args1) = do
-  when (h0 /= h1) empty
+  when (h0 /= h1) empty 
  when (length args0 /= length args1) empty
-  forM_ (zip args0 args1) $ \(arg0, arg1) -> unify arg0 arg1
-unify (Var v0) (Var v1) | v0 == v1 = return ()
+  forM_ (zip args0 args1) $ \(arg0, arg1) ->
+    unify arg0 arg1
+unify (Var v0) (Var v1) | v0 == v1 = return ()  -- succeed with {} (no bindings)
 unify (Var v0) t1 = do
  binding <- getVar v0
  case binding of
-    Just t0 -> unify t0 t1 
+    Just t0 -> unify t0 t1
    Nothing -> setVar v0 t1
-unify t0 t1@(Var _) = unify t1 t0
+unify t0@(Compound _ _) t1@(Var _) = unify t1 t0

 instantiate :: Term -> PrologStream Term
 instantiate t@(Var v) = do
  binding <- getVar v
-  case binding of 
+  case binding of
    Just t0 -> instantiate t0
    Nothing -> return t
 instantiate (Compound h args) = do
  instantiatedArgs <- mapM instantiate args
-  return (Compound h instantiatedArgs)
+  return (Compound h instantiatedArgs)
--- a/app/Classes.hs
+++ b/app/Classes.hs
@@ -1,6 +1,5 @@
-module Classes
-( LiftIO (..)
-) where
+module Classes (LiftIO(..)) where

 class Monad m => LiftIO m where
-  liftIO :: IO a -> m a
+  liftIO :: IO a -> m a
+
--- a/app/Database.hs
+++ b/app/Database.hs
@@ -1,13 +1,9 @@
-module Database
-( Clause(..)
-, Database(..)
-, seekAndInstantiate, seek
-) where
-import Binding
-import Nondeterminism
+module Database where
+import Nondeterminism 
 import Terms
-import Control.Monad
 import Control.Applicative
+import Binding
+import Control.Monad

 data Clause = Clause Term [Term]

@@ -22,9 +18,9 @@ seekAndInstantiate goal db = do

 seek :: Term -> Database -> PrologStream ()
 seek goal db = do
-  foldr (<|>) mzero (map doClause (clauses db))
-  where 
-  doClause clause = do
-    Clause chead body <- clause
-    unify goal chead
-    forM_ body $ \newGoal -> seek newGoal db
+  foldr (<|>) empty (map doClause (clauses db))
+  where
+    doClause clause = do
+      Clause chead body <- clause
+      unify goal chead
+      forM_ body $ \newGoal -> seek newGoal db
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,37 +1,36 @@
-{-# LANGUAGE InstanceSigs #-}
 module Main where
-
-import Binding
+import Database 
+import Nondeterminism
 import Classes
-import Database
-import Nondeterminism 
 import Terms
+import Binding

 demoProgram :: Database
-demoProgram = Database 
-  { clauses = 
-    [ do
-      who <- newVar "who"
-      action <- newVar "action"
-      return $ Clause (Compound "act" [Var who, Var action]) 
+demoProgram = Database
+  { clauses =
+    -- act(sam, 'goes to law school')
+    [ return $ Clause (Compound "act" [Compound "Sam" [], Compound "goes to law school" []]) []
+    , return $ Clause (Compound "vampire_behavior" [Compound "drinks blood" []]) []
+    , return $ Clause (Compound "vampire_behavior" [Compound "spits venom" []]) []
+    , do
+      -- act(Who, Action) :- is_vampire(Who), vampire_behavior(Action).
+      who <- newVar "Who"
+      action <- newVar "Action"
+      return $ Clause (Compound "act" [Var who, Var action])
        [ Compound "is_vampire" [Var who]
        , Compound "vampire_behavior" [Var action]
        ]
-    , do 
-      progenitor <- newVar "progenitor"
-      progeny <- newVar "progeny"
+    , do
+      -- is_vampire(Progeny) :- has_progenitor(Progenitor, Progeny), is_vampire(Progenitor)>
+      progenitor <- newVar "Progenitor"
+      progeny <- newVar "Progeny"
      return $ Clause (Compound "is_vampire" [Var progeny])
        [ Compound "has_progenitor" [Var progenitor, Var progeny]
        , Compound "is_vampire" [Var progenitor]
        ]
-    , return $ Clause (Compound "act" [Compound "Sam" [], Compound "goes to law school" []]) []
-
-    , return $ Clause (Compound "vampire_behavior" [Compound "drinks blood" []]) []
-    , return $ Clause (Compound "vampire_behavior" [Compound "spits venom" []]) []
    , return $ Clause (Compound "is_vampire" [Compound "Nyeogmi" []]) []
-    , return $ Clause (Compound "has_progenitor" [Compound "Nyeogmi" [], Compound "Pyrex" []]) []
    , return $ Clause (Compound "has_progenitor" [Compound "Sam" [], Compound "Alex" []]) []
-    -- , return $ Clause (Compound "is_vampire" [Compound "Sam" []]) []
+    , return $ Clause (Compound "is_vampire" [Compound "Sam" []]) []
    ]
  }

@@ -40,11 +39,11 @@ main = do
  thread <- newThread runDemoProgram
  _ <- takeAllRemainingSolutions thread
  return ()
-  where 
-    runDemoProgram = do
-      who <- newVar "who"
-      what <- newVar "what"
-      let goal = Compound "act" [Var who, Var what]
-      seek goal demoProgram
-      instantiatedGoal <- instantiate goal
-      liftIO $ putStrLn ("Got " ++ show instantiatedGoal)
+  where
+  runDemoProgram :: PrologStream ()
+  runDemoProgram = do
+    who <- newVar "who"
+    what <- newVar "what"
+    let goal = Compound "act" [Var who, Var what]
+    goal' <- seekAndInstantiate goal demoProgram
+    liftIO $ putStrLn ("Got " ++ show goal')
--- a/app/Nondeterminism.hs
+++ b/app/Nondeterminism.hs
@@ -1,54 +1,68 @@
-{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE InstanceSigs, PartialTypeSignatures #-}
 module Nondeterminism
 ( PrologStream
 , newThread
 , takeNextSolution, takeAllRemainingSolutions
-, reversibly
-, liftPrologIO
+, reversibly, liftPrologIO
 ) where
-import Primitives (Globals, PrologIO(..), newGlobals)
-import Control.Applicative
+import Primitives
+import Classes
+import Control.Applicative 
 import Control.Monad
-import Classes (LiftIO (..))
-import GHC.IORef
+import Data.IORef

 data Suspend a = Yield a | Suspend
+data PrologStream a
+  = PMaybe (Suspend a) (PrologIO (PrologStream a))
+  | PNo
+
+reversibly :: PrologIO a -> PrologIO () -> PrologStream a
+reversibly forward backward = 
+  PMaybe Suspend $ forward >>= \fwdValue -> return $
+    PMaybe (Yield fwdValue) $ backward >>= \_ -> return $
+      PNo
+
+liftPrologIO :: PrologIO a -> PrologStream a
+liftPrologIO forward = reversibly forward (return ())
+
+instance LiftIO PrologStream where
+  liftIO :: IO a -> PrologStream a
+  liftIO x = liftPrologIO (liftIO x)

 instance Functor Suspend where
  fmap f (Yield a) = Yield (f a)
  fmap _ Suspend = Suspend

-data PrologStream a 
-  = PYes (Suspend a) (PrologIO (PrologStream a))
-  | PNo
-
 instance Functor PrologStream where
  fmap :: (a -> b) -> PrologStream a -> PrologStream b
-  fmap f (PYes a next) = PYes (fmap f a) (fmap (fmap f) next)
+  fmap f (PMaybe a as) 
+    = PMaybe (fmap f a) (fmap (fmap f) as)
  fmap _ PNo = PNo

-instance Applicative PrologStream where
-  pure :: a -> PrologStream a
-  pure x = PYes (Yield x) (pure PNo)
-
-  (<*>) :: PrologStream (a -> b) -> PrologStream a -> PrologStream b
-  f <*> x = f >>= (\f' -> x >>= (\x' -> return (f' x')))
-
 instance Monad PrologStream where
  return :: a -> PrologStream a
  return = pure

  (>>=) :: PrologStream a -> (a -> PrologStream b) -> PrologStream b
  PNo >>= _ = PNo
-  PYes (Yield x) xs >>= f = f x <|> PYes Suspend (fmap (>>= f) xs)
-  PYes Suspend xs >>= f = PYes Suspend (fmap (>>= f) xs)
+  (>>=) (PMaybe (Yield x) xs) f = f x <|> PMaybe Suspend (fmap (>>= f) xs)
+  (>>=) (PMaybe Suspend xs) f = PMaybe Suspend (fmap (>>= f) xs)

-instance Alternative PrologStream where 
+instance Applicative PrologStream where
+  pure :: a -> PrologStream a
+  pure x = PMaybe (Yield x) (pure PNo)
+
+  (<*>) :: PrologStream (a -> b) -> PrologStream a -> PrologStream b
+  fs <*> xs = do { f <- fs; x <- xs; return (f x) }
+
+instance Alternative PrologStream where
  empty :: PrologStream a
  empty = PNo

  (<|>) :: PrologStream a -> PrologStream a -> PrologStream a
-  (PYes x xs) <|> next = PYes x (liftM2 (<|>) xs (return next))
+  (PMaybe x xsFuture) <|> next = PMaybe x merged
+    where
+    merged = do { xs <- xsFuture; return (xs <|> next) }
  PNo <|> next = next

 instance MonadPlus PrologStream where
@@ -58,6 +72,12 @@ instance MonadPlus PrologStream where
  mplus :: PrologStream a -> PrologStream a -> PrologStream a
  mplus = (<|>)

+squeeze :: PrologStream a -> PrologIO (Maybe a, PrologStream a)
+squeeze PNo = return (Nothing, PNo)
+squeeze (PMaybe Suspend rest) = do { v <- rest; squeeze v }
+squeeze (PMaybe (Yield x) rest) 
+  = return (Just x, PMaybe Suspend rest)
+
 data Thread a = Thread
  { threadGlobals :: Globals
  , threadStream :: IORef (PrologStream a)
@@ -67,16 +87,16 @@ newThread :: PrologStream a -> IO (Thread a)
 newThread stream = do
  globals <- newGlobals
  streamRef <- newIORef stream
-  return $ Thread 
+  return $ Thread
    { threadGlobals = globals
    , threadStream = streamRef
    }

 takeNextSolution :: Thread a -> IO (Maybe a)
-takeNextSolution (Thread { threadGlobals = globals, threadStream = streamRef }) = do
-  stream <- readIORef streamRef
-  (value, newStream) <- runPrologIO (squeeze stream) globals
-  writeIORef streamRef newStream
+takeNextSolution thread = do
+  stream <- readIORef (threadStream thread)
+  (value, newStream) <- runPrologIO (squeeze stream) (threadGlobals thread)
+  writeIORef (threadStream thread) newStream
  return value

 takeAllRemainingSolutions :: Thread a -> IO [a]
@@ -84,21 +104,4 @@ takeAllRemainingSolutions thread = do
  value <- takeNextSolution thread
  case value of
    Nothing -> return []
-    Just x -> fmap (x:) (takeAllRemainingSolutions thread)
-
-squeeze :: PrologStream a -> PrologIO (Maybe a, PrologStream a)
-squeeze PNo = return (Nothing, PNo)
-squeeze (PYes Suspend rest) = rest >>= squeeze
-squeeze (PYes (Yield x) rest) = fmap ((,) (Just x)) rest
-
-reversibly :: PrologIO a -> PrologIO () -> PrologStream a
-reversibly forward backward =
-  PYes Suspend $ forward >>= \v -> return $
-    PYes (Yield v) $ backward >>= \_ -> return $
-      PNo
-
-liftPrologIO :: PrologIO a -> PrologStream a
-liftPrologIO forward = reversibly forward (return ())
-
-instance LiftIO PrologStream where
-  liftIO x = liftPrologIO (liftIO x)
+    Just x -> fmap (x:) (takeAllRemainingSolutions thread)
--- a/app/Primitives.hs
+++ b/app/Primitives.hs
@@ -1,20 +1,25 @@
 {-# LANGUAGE InstanceSigs #-}
 module Primitives
-  ( PrologIO(..)
-  , Globals
-  , newGlobals
-  , newVarPrim, unnewVarPrim
-  , getVarPrim, setVarPrim
-  , errorPrim
-  )
-where
-
-import Data.IORef
+( Globals(..)
+, PrologIO(..)
+, newGlobals
+, newVarPrim, unnewVarPrim, getVarPrim, setVarPrim, errorPrim
+) where
+import Classes
 import qualified Data.IntMap.Strict as M
+import Data.IORef 
 import Terms
-import Classes (LiftIO(..))

 newtype PrologIO a = PrologIO { runPrologIO :: Globals -> IO a }
+data Globals = Globals 
+  { values :: IORef (M.IntMap Term)
+  , names :: IORef (M.IntMap Name)
+  , nextSlot :: IORef Int
+  }
+
+instance LiftIO PrologIO where
+  liftIO :: IO a -> PrologIO a
+  liftIO io = PrologIO (\_ -> io)

 instance Functor PrologIO where
  fmap :: (a -> b) -> PrologIO a -> PrologIO b
@@ -24,17 +29,19 @@ instance Applicative PrologIO where
  pure :: a -> PrologIO a
  pure x = PrologIO (\_ -> pure x)

+  (<*>) :: PrologIO (a -> b) -> PrologIO a -> PrologIO b
  (PrologIO f) <*> (PrologIO x) = PrologIO (
    \globals -> do
      f' <- f globals
      x' <- x globals
-      pure (f' x')
+      return (f' x')
    )

 instance Monad PrologIO where
  return :: a -> PrologIO a
  return = pure

+  (>>=) :: PrologIO a -> (a -> PrologIO b) -> PrologIO b
  (PrologIO a) >>= f = PrologIO (
    \globals -> do
      a' <- a globals
@@ -42,44 +49,33 @@ instance Monad PrologIO where
      b' globals
    )

-data Globals = Globals
-  { values :: IORef (M.IntMap Term)
-  , names :: IORef (M.IntMap Name)
-  , nextVar :: IORef Int
-  }
-
-newGlobals :: IO (Globals)
+newGlobals :: IO Globals
 newGlobals = do
-  vs <- newIORef (M.empty)
-  ns <- newIORef (M.empty)
+  vs <- newIORef M.empty
+  ns <- newIORef M.empty
  next <- newIORef 0
-  return $ Globals { values = vs, names = ns, nextVar = next }
+  return Globals { values=vs, names=ns, nextSlot=next }

-newVarPrim :: Name -> PrologIO Var
+newVarPrim :: Name -> PrologIO Slot
 newVarPrim name = PrologIO $ \globals -> do
-  var <- readIORef (nextVar globals) 
-  modifyIORef (names globals) (M.insert var name)
-  modifyIORef (nextVar globals) succ
-  return (VInt var)
+  slot <- readIORef (nextSlot globals)
+  modifyIORef (names globals) (M.insert slot name)
+  modifyIORef (nextSlot globals) (\s -> s + 1)
+  return (Slot slot)

 unnewVarPrim :: PrologIO ()
 unnewVarPrim = PrologIO $ \globals -> do
-  modifyIORef (nextVar globals) pred
-  var <- readIORef (nextVar globals) 
-  modifyIORef (names globals) (M.delete var)
-  return ()
+  modifyIORef (nextSlot globals) (\s -> s - 1)
+  slot <- readIORef (nextSlot globals)
+  modifyIORef (names globals) (M.delete slot)

-getVarPrim :: Var -> PrologIO (Maybe Term) 
-getVarPrim (VInt var) = PrologIO $ \globals ->
-  fmap (M.lookup var) (readIORef (values globals))
+getVarPrim :: Slot -> PrologIO (Maybe Term)
+getVarPrim (Slot slot) = PrologIO $ \globals ->
+  fmap (M.lookup slot) (readIORef (values globals))

-setVarPrim :: Var -> Maybe Term -> PrologIO ()
-setVarPrim (VInt var) term = PrologIO $ \globals -> do
-  modifyIORef (values globals) (M.alter (\_ -> term) var)
-  return ()
+setVarPrim :: Slot -> Maybe Term -> PrologIO ()
+setVarPrim (Slot slot) term = PrologIO $ \globals ->
+  modifyIORef (values globals) (M.alter (\_ -> term) slot)

 errorPrim :: String -> PrologIO a
-errorPrim message = error message
-
-instance LiftIO PrologIO where 
-  liftIO x = PrologIO (\_ -> x)
+errorPrim message = error message
--- a/app/Terms.hs
+++ b/app/Terms.hs
@@ -1,17 +1,17 @@
-module Terms(
-    Atom,
-    Name,
-    Term(..),
-    Var(..),
+module Terms
+( Atom
+, Name
+, Term(..)
+, Slot(..)
 ) where

 type Atom = String
 type Name = String

-data Term 
-  = Compound Atom [Term] -- functor, args
-  | Var Var  
-  deriving (Eq, Show)
+data Term
+  = Compound Atom [Term]
+  | Var Slot
+  deriving (Eq, Show) 

-newtype Var = VInt Int
-  deriving (Ord, Eq, Show)
+newtype Slot = Slot Int
+  deriving (Eq, Show)