10h vacuum cleaner sound
This commit is contained in:
parent
71992db7d0
commit
2f07d89043
105
app/Builtins.hs
105
app/Builtins.hs
|
|
@ -46,9 +46,9 @@ printLocals = do
|
|||
scope <- gets (gvar . cur)
|
||||
heap <- gets (heap . cur)
|
||||
IR.StrTable _ _ itos <- gets strtable
|
||||
flip traverse (M.elems scope) $ \(ref, name) ->
|
||||
flip traverse (M.assocs scope) $ \(local, ref) ->
|
||||
lift . outputStrLn $
|
||||
(maybe "_" id $ itos M.!? name) ++ " = " ++ showTerm itos heap ref
|
||||
"_Local" ++ show local ++ " = " ++ showTerm itos heap ref
|
||||
return Nothing
|
||||
|
||||
promptRetry :: InterpFn
|
||||
|
|
@ -65,15 +65,22 @@ promptRetry' = do
|
|||
Just ';' -> backtrack
|
||||
_ -> return Nothing
|
||||
|
||||
write :: InterpFn
|
||||
write
|
||||
--TODO: prlgError on write(Unbound)
|
||||
= do
|
||||
withArgs :: [Int] -> ([Int] -> InterpFn) -> InterpFn
|
||||
withArgs as f = do
|
||||
scope <- gets (hvar . cur)
|
||||
if all (`M.member` scope) as
|
||||
then f $ map (scope M.!) as
|
||||
else prlgError "arguments not bound"
|
||||
|
||||
write' :: InterpFn -> InterpFn
|
||||
write' c =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- gets (heap . cur)
|
||||
IR.StrTable _ _ itos <- gets strtable
|
||||
lift . outputStr . showTerm itos heap . fst $ scope M.! 0
|
||||
return Nothing
|
||||
lift . outputStr $ showTerm itos heap arg
|
||||
c --this now allows error fallthrough but we might like EitherT
|
||||
|
||||
write = write' $ return Nothing
|
||||
|
||||
nl :: InterpFn
|
||||
nl = do
|
||||
|
|
@ -81,40 +88,47 @@ nl = do
|
|||
return Nothing
|
||||
|
||||
writeln :: InterpFn
|
||||
writeln = write >> nl
|
||||
writeln = write' nl
|
||||
|
||||
assertFact :: InterpFn
|
||||
assertFact = do
|
||||
scope <- gets (hvar . cur)
|
||||
assertFact =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- gets (heap . cur)
|
||||
case Co.compileGoal . Co.squashVars <$>
|
||||
Co.heapStructPrlgInt Nothing heap (fst $ scope M.! 0) of
|
||||
Co.heapStructPrlgInt Nothing heap arg of
|
||||
Just (U (Struct s):head) -> do
|
||||
addClause s $ head ++ [NoGoal]
|
||||
return Nothing
|
||||
_ -> prlgError "assert fact failure"
|
||||
|
||||
assertClause :: InterpFn
|
||||
assertClause = do
|
||||
assertClause =
|
||||
withArgs [0, 1] $ \args -> do
|
||||
scope <- gets (hvar . cur)
|
||||
heap <- gets (heap . cur)
|
||||
commaId <- findStruct "," 2
|
||||
comma <- findAtom ","
|
||||
cut <- findAtom "!"
|
||||
case Co.squashVars . IR.CallI (IR.Id 0 0) <$>
|
||||
traverse (Co.heapStructPrlgInt Nothing heap . fst . (M.!) scope) [0, 1] of
|
||||
Just (IR.CallI (IR.Id 0 0) [hs, gs]) ->
|
||||
case Co.squashVars . IR.CallI 0 <$>
|
||||
traverse (Co.heapStructPrlgInt Nothing heap) args of
|
||||
Just (IR.CallI 0 [hs, gs]) ->
|
||||
let (U (Struct s):cs) =
|
||||
Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs)
|
||||
Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals comma cut gs)
|
||||
in do addClause s cs
|
||||
return Nothing
|
||||
_ -> prlgError "assert clause failure"
|
||||
|
||||
retractall :: InterpFn
|
||||
retractall = prlgError "no retractall yet"
|
||||
retractall =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- gets (heap . cur)
|
||||
case derefHeap heap arg of
|
||||
BoundRef _ (Atom a) -> dropProcedure (IR.Id {IR.arity = 0, IR.str = a})
|
||||
BoundRef _ (Struct id) -> dropProcedure id
|
||||
_ -> prlgError "retractall needs a struct"
|
||||
|
||||
call :: InterpFn
|
||||
call = do
|
||||
ref <- gets (fst . (M.! 0) . hvar . cur)
|
||||
call =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap@(Heap _ hmap) <- gets (heap . cur)
|
||||
let exec base struct arity = do
|
||||
cur <- gets cur
|
||||
|
|
@ -128,13 +142,18 @@ call = do
|
|||
}
|
||||
}
|
||||
return Nothing
|
||||
case derefHeap heap ref of
|
||||
case derefHeap heap arg of
|
||||
BoundRef addr struct@(Struct IR.Id {IR.arity = arity}) ->
|
||||
exec addr struct arity
|
||||
BoundRef addr (Atom a) ->
|
||||
exec addr (Struct IR.Id {IR.arity = 0, IR.str = a}) 0
|
||||
_ -> prlgError "not callable"
|
||||
|
||||
struct :: InterpFn
|
||||
struct = do
|
||||
scope <- gets (hvar . cur)
|
||||
prlgError "not yet"
|
||||
|
||||
{- adding the builtins -}
|
||||
addOp op = modify $ \s -> s {ops = op : ops s}
|
||||
|
||||
|
|
@ -145,20 +164,29 @@ addClause struct code =
|
|||
addProcedure struct heads =
|
||||
modify $ \s -> s {defs = M.insert struct heads $ defs s}
|
||||
|
||||
dropProcedure struct = do
|
||||
d <- gets defs
|
||||
if struct `M.member` d
|
||||
then do
|
||||
modify $ \s -> s {defs = M.delete struct d}
|
||||
return Nothing
|
||||
else prlgError "no such definition" -- this should backtrack?
|
||||
|
||||
addProc n a c = do
|
||||
sym <- findStruct n a
|
||||
addProcedure sym c
|
||||
|
||||
addBi0 n b = addProc n 0 [[Invoke $ bi b]]
|
||||
addBi n i b =
|
||||
addProc n i [[U (LocalRef $ r - 1) | r <- [1 .. i]] ++ [Invoke $ bi b]]
|
||||
|
||||
addPrelude :: PrlgEnv ()
|
||||
addPrelude = do
|
||||
pure undefined
|
||||
{- primitives -}
|
||||
addBi0 "true" (pure Nothing)
|
||||
addBi0 "fail" backtrack
|
||||
addBi "true" 0 (pure Nothing)
|
||||
addBi "fail" 0 backtrack
|
||||
addOp $ O.xfx "=" 700
|
||||
addProc "=" 2 [[U (LocalRef 0 0), U (LocalRef 0 0), NoGoal]]
|
||||
addProc "=" 2 [[U (LocalRef 0), U (LocalRef 0), NoGoal]]
|
||||
{- clauses -}
|
||||
addOp $ O.xfy "," 1000
|
||||
addOp $ O.xfx ":-" 1200
|
||||
|
|
@ -168,22 +196,23 @@ addPrelude = do
|
|||
"assert"
|
||||
1
|
||||
[ [ U (Struct horn2)
|
||||
, U (LocalRef 0 0)
|
||||
, U (LocalRef 1 0)
|
||||
, U (LocalRef 0)
|
||||
, U (LocalRef 1)
|
||||
, Cut
|
||||
, Invoke (bi assertClause)
|
||||
]
|
||||
, [U (LocalRef 0 0), Invoke (bi assertFact)]
|
||||
, [U (LocalRef 0), Invoke (bi assertFact)]
|
||||
]
|
||||
addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]]
|
||||
addProc "call" 1 [[U (LocalRef 0 0), Invoke (bi call)]]
|
||||
addBi "retractall" 1 retractall
|
||||
addBi "call" 1 call
|
||||
addBi "struct" 3 struct
|
||||
{- query tools -}
|
||||
addBi0 "print_locals" printLocals
|
||||
addBi0 "prompt_retry" promptRetry'
|
||||
addBi0 "query" (printLocals >> promptRetry)
|
||||
addBi "print_locals" 0 printLocals
|
||||
addBi "prompt_retry" 0 promptRetry'
|
||||
addBi "query" 0 (printLocals >> promptRetry)
|
||||
{- IO -}
|
||||
addProc "write" 1 [[U (LocalRef 0 0), Invoke (bi write)]]
|
||||
addProc "writeln" 1 [[U (LocalRef 0 0), Invoke (bi writeln)]]
|
||||
addBi0 "nl" nl
|
||||
addBi "write" 1 write
|
||||
addBi "writeln" 1 writeln
|
||||
addBi "nl" 0 nl
|
||||
{- debug -}
|
||||
addBi0 "interpreter_trace" (get >>= liftIO . print >> pure Nothing)
|
||||
addBi "interpreter_trace" 0 (get >>= liftIO . print >> pure Nothing)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ data Datum
|
|||
= Atom Int -- unifies a constant
|
||||
| Struct Id -- unifies a structure with arity
|
||||
| VoidRef -- unifies with anything
|
||||
| LocalRef Int Int -- code-local variable idx (should never occur on heap)
|
||||
| LocalRef Int -- code-local variable idx (should never occur on heap)
|
||||
| HeapRef Int -- something further on the heap
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ data Heap =
|
|||
|
||||
emptyHeap = Heap 1 M.empty
|
||||
|
||||
type Scope = M.Map Int (Int, Int)
|
||||
type Scope = M.Map Int Int
|
||||
|
||||
emptyScope :: Scope
|
||||
emptyScope = M.empty
|
||||
|
|
@ -103,7 +103,7 @@ codeStruct ::
|
|||
codeStruct atom struct local rec end heap = go
|
||||
where
|
||||
go [] = ([], ) <$> end
|
||||
go (U lr@(LocalRef _ _):cs) = do
|
||||
go (U lr@(LocalRef _):cs) = do
|
||||
x <- local lr
|
||||
case x of
|
||||
Left ref -> (cs, ) <$> heapStruct atom struct rec heap ref
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@ desugarPrlg :: Int -> PrlgInt -> PrlgInt
|
|||
desugarPrlg list = go
|
||||
where
|
||||
go (CallI id ps) = CallI id $ map go ps
|
||||
go (ListI (x:xs) t) =
|
||||
CallI Id {str = list, arity = 2} [go x, go (ListI xs t)]
|
||||
go (ListI (x:xs) t) = CallI list [go x, go (ListI xs t)]
|
||||
go (ListI [] Nothing) = LiteralI list
|
||||
go (ListI [] (Just x)) = go x
|
||||
go x = x
|
||||
|
|
@ -29,7 +28,7 @@ varOccurs _ = M.empty
|
|||
variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
|
||||
variablizePrlg void (StrTable _ _ itos) = go
|
||||
where
|
||||
go (CallI id ps) = CallI id $ map go ps
|
||||
go (CallI i ps) = CallI i $ map go ps
|
||||
go (LiteralI i)
|
||||
| i == void = VoidI
|
||||
| varname (itos M.! i) = VarI i i
|
||||
|
|
@ -38,7 +37,7 @@ variablizePrlg void (StrTable _ _ itos) = go
|
|||
renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
|
||||
renumVars rename = go
|
||||
where
|
||||
go (CallI id ps) = CallI id $ map go ps
|
||||
go (CallI i ps) = CallI i $ map go ps
|
||||
go (VarI idx i)
|
||||
| Just new <- rename idx = new
|
||||
go x = x
|
||||
|
|
@ -52,13 +51,13 @@ squashVars x =
|
|||
[(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
|
||||
in renumVars (m' M.!?) x
|
||||
|
||||
compileGoals :: Id -> Int -> PrlgInt -> [Code]
|
||||
compileGoals :: Int -> Int -> PrlgInt -> [Code]
|
||||
compileGoals andop cut = go'
|
||||
where
|
||||
go' = go . struct2goal
|
||||
go p@(CallI x args)
|
||||
go p@(CallI x args@[_, _])
|
||||
| x == andop = concatMap go' args
|
||||
go p@(CallI (Id x 0) [])
|
||||
go p@(CallI x [])
|
||||
| x == cut = [[Cut]]
|
||||
go x = [compileGoal x]
|
||||
|
||||
|
|
@ -66,9 +65,10 @@ compileGoal :: PrlgInt -> Code
|
|||
compileGoal = compileArg . struct2goal
|
||||
|
||||
compileArg :: PrlgInt -> Code
|
||||
compileArg (CallI s args) = U (Struct s) : concatMap compileArg args
|
||||
compileArg (CallI i args) =
|
||||
U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
|
||||
compileArg (LiteralI s) = [U (Atom s)]
|
||||
compileArg (VarI x s) = [U (LocalRef x s)]
|
||||
compileArg (VarI x _) = [U (LocalRef x)]
|
||||
compileArg (VoidI) = [U VoidRef]
|
||||
|
||||
seqGoals :: [Code] -> Code
|
||||
|
|
@ -84,16 +84,16 @@ heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
|
|||
where
|
||||
atom (Atom s) = pure $ LiteralI s
|
||||
atom VoidRef = pure $ VoidI
|
||||
struct (Struct s) args = pure $ CallI s args
|
||||
struct (Struct s) args = pure $ CallI (str s) args
|
||||
hrec (HeapRef r) ref
|
||||
| r == ref = pure $ VarI r 0
|
||||
| otherwise = heaperr
|
||||
|
||||
-- TODO check if this is used
|
||||
goal2struct :: PrlgInt -> PrlgInt
|
||||
goal2struct (CallI (Id s 0) []) = LiteralI s
|
||||
goal2struct (CallI s []) = LiteralI s
|
||||
goal2struct x = x
|
||||
|
||||
struct2goal :: PrlgInt -> PrlgInt
|
||||
struct2goal (LiteralI s) = CallI (Id s 0) []
|
||||
struct2goal (LiteralI s) = CallI s []
|
||||
struct2goal x = x
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ import Control.Monad.Trans.Class (lift)
|
|||
import Control.Monad.Trans.State.Lazy (evalStateT, gets)
|
||||
import Data.Foldable (traverse_)
|
||||
import qualified Data.Map as M
|
||||
import Env (PrlgEnv, findAtom, findStruct, withStrTable)
|
||||
import Env (PrlgEnv, findAtom, withStrTable)
|
||||
import qualified IR
|
||||
import qualified Interpreter as I
|
||||
import qualified Parser as P
|
||||
|
|
@ -55,9 +55,9 @@ interpret = (>> return True) . lex
|
|||
C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
|
||||
compile prlgv
|
||||
compile prlgv = do
|
||||
commaId <- findStruct "," 2
|
||||
comma <- findAtom ","
|
||||
cut <- findAtom "!"
|
||||
let code = C.seqGoals $ C.compileGoals commaId cut prlgv
|
||||
let code = C.seqGoals $ C.compileGoals comma cut prlgv
|
||||
execute code
|
||||
execute code = do
|
||||
res <- I.prove code
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ data Id =
|
|||
deriving (Show, Eq, Ord)
|
||||
|
||||
data PrlgInt
|
||||
= CallI Id [PrlgInt] --TODO this should be Int
|
||||
= CallI Int [PrlgInt]
|
||||
| LiteralI Int
|
||||
| ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
|
||||
| VarI Int Int -- VarI localIndex strTableString
|
||||
|
|
@ -41,7 +41,7 @@ internPrlg = go
|
|||
go t (LiteralS str) = LiteralI <$> strtablize t str
|
||||
go t (CallS str ps) =
|
||||
let (t', i) = strtablize t str
|
||||
in CallI (Id i $ length ps) <$> mapAccumL go t' ps
|
||||
in CallI i <$> mapAccumL go t' ps
|
||||
go t (ListS elems Nothing) = flip ListI Nothing <$> mapAccumL go t elems
|
||||
go t (ListS elems (Just tail)) =
|
||||
let (t', tail') = go t tail
|
||||
|
|
|
|||
|
|
@ -89,10 +89,10 @@ proveStep = St.get >>= go
|
|||
in ( Heap (nxt + n) $
|
||||
foldr (uncurry M.insert) m [(a, HeapRef a) | a <- addrs]
|
||||
, addrs)
|
||||
allocLocal (LocalRef reg ident) scope cont
|
||||
| Just (addr, _) <- scope M.!? reg = cont scope heap addr
|
||||
allocLocal (LocalRef reg) scope cont
|
||||
| Just addr <- scope M.!? reg = cont scope heap addr
|
||||
| (heap', addr) <- newHeapVar heap =
|
||||
cont (M.insert reg (addr, ident) scope) heap' addr
|
||||
cont (M.insert reg addr scope) heap' addr
|
||||
newHeapStruct addr s@(Struct Id {arity = arity}) cont =
|
||||
let (Heap nxt' m', addrs) = newHeapVars (arity + 1) heap
|
||||
m'' =
|
||||
|
|
@ -113,10 +113,10 @@ proveStep = St.get >>= go
|
|||
unify (Struct Id {arity = a}) VoidRef =
|
||||
c i {cur = cur {hed = hs, gol = replicate a (U VoidRef) ++ gs}}
|
||||
{- handle local refs; first ignore their combination with voids to save memory -}
|
||||
unify (LocalRef _ _) VoidRef = uok
|
||||
unify VoidRef (LocalRef _ _) = uok
|
||||
unify (LocalRef _) VoidRef = uok -- TRICKY: builtins need to check if locals actually exist because of this
|
||||
unify VoidRef (LocalRef _) = uok
|
||||
{- allocate heap for LocalRefs and retry with HeapRefs -}
|
||||
unify lr@(LocalRef _ _) _ =
|
||||
unify lr@(LocalRef _) _ =
|
||||
allocLocal lr (hvar cur) $ \hvar' heap' addr ->
|
||||
c
|
||||
i
|
||||
|
|
@ -124,7 +124,7 @@ proveStep = St.get >>= go
|
|||
cur
|
||||
{hed = U (HeapRef addr) : hs, hvar = hvar', heap = heap'}
|
||||
}
|
||||
unify _ lr@(LocalRef _ _) =
|
||||
unify _ lr@(LocalRef _) =
|
||||
allocLocal lr (gvar cur) $ \gvar' heap' addr ->
|
||||
c
|
||||
i
|
||||
|
|
|
|||
|
|
@ -172,29 +172,27 @@ literal = Literal . unTok <$> free (satisfy isNormalTok <* notFollowedBy lParen)
|
|||
|
||||
call = do
|
||||
fn <- unTok <$> satisfy isNormalTok -- not free
|
||||
(Call fn [] <$ try emptyParens) <|> do
|
||||
Seq inner <- free parens
|
||||
return $ Call fn $ splitOn [Literal ","] inner
|
||||
|
||||
parens = Seq <$> (free lParen *> some seqItem <* free rParen)
|
||||
|
||||
emptyParens = Literal "()" <$ (free lParen >> free rParen)
|
||||
|
||||
list = do
|
||||
free lBracket
|
||||
choice
|
||||
[ List [] Nothing <$ free rBracket
|
||||
, do items <- splitOn [Literal ","] <$> some seqItem
|
||||
choice
|
||||
[ List items Nothing <$ free rBracket
|
||||
, List items . Just <$>
|
||||
(free listTail *> some seqItem <* free rBracket)
|
||||
]
|
||||
]
|
||||
(List [] Nothing <$ free rBracket) <|> do
|
||||
items <- splitOn [Literal ","] <$> some seqItem
|
||||
(List items Nothing <$ free rBracket) <|>
|
||||
(List items . Just <$> (free listTail *> some seqItem <* free rBracket))
|
||||
|
||||
seqItem = choice [try call, literal, parens, list]
|
||||
seqItem = choice [try call, literal, try emptyParens, parens, list]
|
||||
|
||||
simpleTok :: String -> Parser ()
|
||||
simpleTok s = void $ single (Tok s)
|
||||
|
||||
comma = simpleTok "."
|
||||
period = simpleTok "."
|
||||
|
||||
lParen = simpleTok "("
|
||||
|
||||
|
|
@ -207,7 +205,7 @@ listTail = simpleTok "|"
|
|||
rBracket = simpleTok "]"
|
||||
|
||||
clause :: Parser PAST
|
||||
clause = Seq <$> some (free seqItem) <* free comma
|
||||
clause = Seq <$> some (free seqItem) <* free period
|
||||
|
||||
parsePrlg :: Parser [PAST]
|
||||
parsePrlg = ws *> many clause <* eof
|
||||
|
|
|
|||
Loading…
Reference in a new issue