pyrex/prolog_in_haskell
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Substitute with the version from the video

Browse Source
This commit is contained in:
Pyrex 2025-04-12 19:40:32 -07:00
parent 288c999c0e
commit 2e819b454f
7 changed files with 162 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
app/Binding.hs
View File

@ -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 var = liftPrologIO (getVarPrim var)
getVar :: Slot -> PrologStream (Maybe Term)
getVar slot = liftPrologIO (getVarPrim slot)
setVar :: Var -> Term -> PrologStream ()
setVar var value = reversibly set unset
setVar :: Slot -> Term -> PrologStream ()
setVar slot 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)
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 (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
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

5
app/Classes.hs
View File

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

12
app/Database.hs
View File

@ -1,13 +1,9 @@
module Database
( Clause(..)
, Database(..)
, seekAndInstantiate, seek
) where
import Binding
module Database where
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

35
app/Main.hs
View File

@ -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
who <- newVar "who"
action <- newVar "action"
-- 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"
-- 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" []]) []
]
}
@ -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
instantiatedGoal <- instantiate goal
liftIO $ putStrLn ("Got " ++ show instantiatedGoal)
goal' <- seekAndInstantiate goal demoProgram
liftIO $ putStrLn ("Got " ++ show goal')

87
app/Nondeterminism.hs
View File

@ -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 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 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
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]
@ -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)

76
app/Primitives.hs
View File

@ -1,20 +1,25 @@
{-# LANGUAGE InstanceSigs #-}
module Primitives
( PrologIO(..)
, Globals
( Globals(..)
, PrologIO(..)
, newGlobals
, newVarPrim, unnewVarPrim
, getVarPrim, setVarPrim
, errorPrim
)
where
import Data.IORef
, 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)

18
app/Terms.hs
View File

@ -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
= Compound Atom [Term]
| Var Slot
deriving (Eq, Show)
newtype Var = VInt Int
deriving (Ord, Eq, Show)
newtype Slot = Slot Int
deriving (Eq, Show)