10h vacuum cleaner sound

1 files changed, 100 insertions, 71 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index 0cdd7cd..2b7f08e 100644
--- a/app/Builtins.hs
+++ b/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)
-  heap <- gets (heap . cur)
-  IR.StrTable _ _ itos <- gets strtable
-  lift . outputStr . showTerm itos heap . fst $ scope M.! 0
-  return Nothing
+  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 arg
+    c --this now allows error fallthrough but we might like EitherT
+
+write = write' $ return Nothing
 
 nl :: InterpFn
 nl = do
@@ -81,59 +88,71 @@ nl = do
   return Nothing
 
 writeln :: InterpFn
-writeln = write >> nl
+writeln = write' nl
 
 assertFact :: InterpFn
-assertFact = do
-  scope <- gets (hvar . cur)
-  heap <- gets (heap . cur)
-  case Co.compileGoal . Co.squashVars <$>
-       Co.heapStructPrlgInt Nothing heap (fst $ scope M.! 0) of
-    Just (U (Struct s):head) -> do
-      addClause s $ head ++ [NoGoal]
-      return Nothing
-    _ -> prlgError "assert fact failure"
+assertFact =
+  withArgs [0] $ \[arg] -> do
+    heap <- gets (heap . cur)
+    case Co.compileGoal . Co.squashVars <$>
+         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
-  scope <- gets (hvar . cur)
-  heap <- gets (heap . cur)
-  commaId <- findStruct "," 2
-  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]) ->
-      let (U (Struct s):cs) =
-            Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs)
-       in do addClause s cs
-             return Nothing
-    _ -> prlgError "assert clause failure"
+assertClause =
+  withArgs [0, 1] $ \args -> do
+    scope <- gets (hvar . cur)
+    heap <- gets (heap . cur)
+    comma <- findAtom ","
+    cut <- findAtom "!"
+    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 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)
-  heap@(Heap _ hmap) <- gets (heap . cur)
-  let exec base struct arity = do
-        cur <- gets cur
-        modify $ \s ->
-          s
-            { cur =
-                cur
-                  { gol =
-                      [Call, Goal, U struct] ++
-                      [U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur
-                  }
-            }
-        return Nothing
-  case derefHeap heap ref 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"
+call =
+  withArgs [0] $ \[arg] -> do
+    heap@(Heap _ hmap) <- gets (heap . cur)
+    let exec base struct arity = do
+          cur <- gets cur
+          modify $ \s ->
+            s
+              { cur =
+                  cur
+                    { gol =
+                        [Call, Goal, U struct] ++
+                        [U $ hmap M.! (base + i) | i <- [1 .. arity]] ++ gol cur
+                    }
+              }
+          return Nothing
+    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)