From 2e819b454f9aceeadb2177712f624b9ffa1b6dbb Mon Sep 17 00:00:00 2001 From: Nyeogmi Date: Sat, 12 Apr 2025 19:40:32 -0700 Subject: [PATCH] Substitute with the version from the video --- app/Binding.hs | 47 ++++++++++----------- app/Classes.hs | 7 ++-- app/Database.hs | 24 +++++------ app/Main.hs | 55 ++++++++++++------------- app/Nondeterminism.hs | 95 ++++++++++++++++++++++--------------------- app/Primitives.hs | 80 +++++++++++++++++------------------- app/Terms.hs | 22 +++++----- 7 files changed, 162 insertions(+), 168 deletions(-) diff --git a/app/Binding.hs b/app/Binding.hs index c809868..fbf074b 100644 --- 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) \ No newline at end of file diff --git a/app/Classes.hs b/app/Classes.hs index 81a980f..8d463f8 100644 --- 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 \ No newline at end of file + liftIO :: IO a -> m a + diff --git a/app/Database.hs b/app/Database.hs index 1e92b95..4dda701 100644 --- 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 \ No newline at end of file + foldr (<|>) empty (map doClause (clauses db)) + where + doClause clause = do + Clause chead body <- clause + unify goal chead + forM_ body $ \newGoal -> seek newGoal db \ No newline at end of file diff --git a/app/Main.hs b/app/Main.hs index cc80209..ee8ada9 100644 --- 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) \ No newline at end of file + 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') diff --git a/app/Nondeterminism.hs b/app/Nondeterminism.hs index 2b77366..9612110 100644 --- 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) \ No newline at end of file + Just x -> fmap (x:) (takeAllRemainingSolutions thread) \ No newline at end of file diff --git a/app/Primitives.hs b/app/Primitives.hs index e9b942b..9cb486f 100644 --- 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) \ No newline at end of file +errorPrim message = error message \ No newline at end of file diff --git a/app/Terms.hs b/app/Terms.hs index 3dfeee1..44ad78f 100644 --- 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) \ No newline at end of file +newtype Slot = Slot Int + deriving (Eq, Show)