Substitute with the version from the video

app/Binding.hs

@@ -1,42 +1,43 @@
 module Binding
 ( newVar, unify, instantiate
 ) where
+import Primitives
 import Terms
 import Nondeterminism
-import Primitives
 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 :: Slot -> PrologStream (Maybe Term)
-getVar var = liftPrologIO (getVarPrim var)
+getVar slot = liftPrologIO (getVarPrim slot)
 
-setVar :: Var -> Term -> PrologStream ()
+setVar :: Slot -> Term -> PrologStream ()
-setVar var value = reversibly set unset
+setVar slot value = reversibly set unset
   where
   set = do
-    oldValue <- getVarPrim var
+    oldValue <- getVarPrim slot
-    when (oldValue /= Nothing) (errorPrim "cannot set var that is currently set")
+    when (oldValue /= Nothing) (errorPrim "cannot set var that is already set")
-    setVarPrim var (Just value)
+    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 (length args0 /= length args1) empty
-  forM_ (zip args0 args1) $ \(arg0, arg1) -> unify arg0 arg1
+  forM_ (zip args0 args1) $ \(arg0, arg1) ->
-unify (Var v0) (Var v1) | v0 == v1 = return ()
+    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
     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

app/Classes.hs

@@ -1,6 +1,5 @@
-module Classes
+module Classes (LiftIO(..)) where
-( LiftIO (..)
-) where
 
 class Monad m => LiftIO m where
   liftIO :: IO a -> m a
+

app/Database.hs

@@ -1,13 +1,9 @@
-module Database
+module Database where
-( Clause(..)
-, Database(..)
-, seekAndInstantiate, seek
-) where
-import Binding
 import Nondeterminism 
 import Terms
-import Control.Monad
 import Control.Applicative
+import Binding
+import Control.Monad
 
 data Clause = Clause Term [Term]
 
@@ -22,7 +18,7 @@ seekAndInstantiate goal db = do
 
 seek :: Term -> Database -> PrologStream ()
 seek goal db = do
-  foldr (<|>) mzero (map doClause (clauses db))
+  foldr (<|>) empty (map doClause (clauses db))
   where
     doClause clause = do
       Clause chead body <- clause

app/Main.hs

@@ -1,37 +1,36 @@
-{-# LANGUAGE InstanceSigs #-}
 module Main where
-
-import Binding
-import Classes
 import Database 
 import Nondeterminism
+import Classes
 import Terms
+import Binding
 
 demoProgram :: Database
 demoProgram = Database
   { clauses =
-    [ do
+    -- act(sam, 'goes to law school')
-      who <- newVar "who"
+    [ return $ Clause (Compound "act" [Compound "Sam" [], Compound "goes to law school" []]) []
-      action <- newVar "action"
+    , 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"
+      -- is_vampire(Progeny) :- has_progenitor(Progenitor, Progeny), is_vampire(Progenitor)>
-      progeny <- newVar "progeny"
+      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" []]) []
     ]
   }
 
@@ -41,10 +40,10 @@ main = do
   _ <- takeAllRemainingSolutions thread
   return ()
   where
+  runDemoProgram :: PrologStream ()
   runDemoProgram = do
     who <- newVar "who"
     what <- newVar "what"
     let goal = Compound "act" [Var who, Var what]
-      seek goal demoProgram
+    goal' <- seekAndInstantiate goal demoProgram
-      instantiatedGoal <- instantiate goal
+    liftIO $ putStrLn ("Got " ++ show goal')
-      liftIO $ putStrLn ("Got " ++ show instantiatedGoal)

app/Nondeterminism.hs

@@ -1,54 +1,68 @@
-{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE InstanceSigs, PartialTypeSignatures #-}
 module Nondeterminism
 ( PrologStream
 , newThread
 , takeNextSolution, takeAllRemainingSolutions
-, reversibly
+, reversibly, liftPrologIO
-, liftPrologIO
 ) where
-import Primitives (Globals, PrologIO(..), newGlobals)
+import Primitives
+import Classes
 import Control.Applicative 
 import Control.Monad
-import Classes (LiftIO (..))
+import Data.IORef
-import GHC.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)
+  (>>=) (PMaybe (Yield x) xs) f = f x <|> PMaybe Suspend (fmap (>>= f) xs)
-  PYes Suspend xs >>= f = PYes Suspend (fmap (>>= f) xs)
+  (>>=) (PMaybe Suspend xs) f = PMaybe Suspend (fmap (>>= f) xs)
+
+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)
@@ -73,10 +93,10 @@ newThread stream = do
     }
 
 takeNextSolution :: Thread a -> IO (Maybe a)
-takeNextSolution (Thread { threadGlobals = globals, threadStream = streamRef }) = do
+takeNextSolution thread = do
-  stream <- readIORef streamRef
+  stream <- readIORef (threadStream thread)
-  (value, newStream) <- runPrologIO (squeeze stream) globals
+  (value, newStream) <- runPrologIO (squeeze stream) (threadGlobals thread)
-  writeIORef streamRef newStream
+  writeIORef (threadStream thread) newStream
   return value
 
 takeAllRemainingSolutions :: Thread a -> IO [a]
@@ -85,20 +105,3 @@ takeAllRemainingSolutions thread = do
   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)

app/Primitives.hs

@@ -1,20 +1,25 @@
 {-# LANGUAGE InstanceSigs #-}
 module Primitives
-  ( PrologIO(..)
+( Globals(..)
-  , Globals
+, PrologIO(..)
-  , newGlobals
+, newGlobals
-  , newVarPrim, unnewVarPrim
+, newVarPrim, unnewVarPrim, getVarPrim, setVarPrim, errorPrim
-  , getVarPrim, setVarPrim
+) where
-  , errorPrim
+import Classes
-  )
-where
-
-import Data.IORef
 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
+newGlobals :: IO Globals
-  { values :: IORef (M.IntMap Term)
-  , names :: IORef (M.IntMap Name)
-  , nextVar :: IORef Int
-  }
-
-newGlobals :: IO (Globals)
 newGlobals = do
-  vs <- newIORef (M.empty)
+  vs <- newIORef M.empty
-  ns <- 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) 
+  slot <- readIORef (nextSlot globals)
-  modifyIORef (names globals) (M.insert var name)
+  modifyIORef (names globals) (M.insert slot name)
-  modifyIORef (nextVar globals) succ
+  modifyIORef (nextSlot globals) (\s -> s + 1)
-  return (VInt var)
+  return (Slot slot)
 
 unnewVarPrim :: PrologIO ()
 unnewVarPrim = PrologIO $ \globals -> do
-  modifyIORef (nextVar globals) pred
+  modifyIORef (nextSlot globals) (\s -> s - 1)
-  var <- readIORef (nextVar globals) 
+  slot <- readIORef (nextSlot globals)
-  modifyIORef (names globals) (M.delete var)
+  modifyIORef (names globals) (M.delete slot)
-  return ()
 
-getVarPrim :: Var -> PrologIO (Maybe Term) 
+getVarPrim :: Slot -> PrologIO (Maybe Term)
-getVarPrim (VInt var) = PrologIO $ \globals ->
+getVarPrim (Slot slot) = PrologIO $ \globals ->
-  fmap (M.lookup var) (readIORef (values globals))
+  fmap (M.lookup slot) (readIORef (values globals))
 
-setVarPrim :: Var -> Maybe Term -> PrologIO ()
+setVarPrim :: Slot -> Maybe Term -> PrologIO ()
-setVarPrim (VInt var) term = PrologIO $ \globals -> do
+setVarPrim (Slot slot) term = PrologIO $ \globals ->
-  modifyIORef (values globals) (M.alter (\_ -> term) var)
+  modifyIORef (values globals) (M.alter (\_ -> term) slot)
-  return ()
 
 errorPrim :: String -> PrologIO a
 errorPrim message = error message
-
-instance LiftIO PrologIO where 
-  liftIO x = PrologIO (\_ -> x)

app/Terms.hs

@@ -1,17 +1,17 @@
-module Terms(
+module Terms
-    Atom,
+( Atom
-    Name,
+, Name
-    Term(..),
+, Term(..)
-    Var(..),
+, Slot(..)
 ) where
 
 type Atom = String
 type Name = String
 
 data Term
-  = Compound Atom [Term] -- functor, args
+  = Compound Atom [Term]
-  | Var Var  
+  | Var Slot
   deriving (Eq, Show) 
 
-newtype Var = VInt Int
+newtype Slot = Slot Int
-  deriving (Ord, Eq, Show)
+  deriving (Eq, Show)