From d13fc60bf3d8d1b99ee37ba91f2da4b31df7f99f Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Sat, 26 Nov 2022 16:36:47 +0100
Subject: [PATCH] it prlgs.

---
 app/Builtins.hs | 49 ++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 42 insertions(+), 7 deletions(-)

diff --git a/app/Builtins.hs b/app/Builtins.hs
index b81d298..64838bb 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -16,7 +16,7 @@ import Control.Monad.Trans.State.Lazy (get, gets, modify)
 import Data.Functor.Identity (runIdentity)
 import Data.List (intercalate)
 import qualified Data.Map as M
-import Env (PrlgEnv(..), findStruct)
+import Env (PrlgEnv(..), findAtom, findStruct)
 import qualified IR
 import Interpreter (backtrack)
 import qualified Operators as O
@@ -49,6 +49,13 @@ printLocals = do
 
 promptRetry :: BuiltinFn
 promptRetry = do
+  last <- gets (null . cho)
+  if last
+    then return Nothing
+    else promptRetry'
+
+promptRetry' :: BuiltinFn
+promptRetry' = do
   x <- lift $ getInputChar "? "
   case x of
     Just ';' -> backtrack
@@ -74,11 +81,26 @@ assertFact :: BuiltinFn
 assertFact = do
   scope <- gets (hvar . cur)
   heap <- gets (heap . cur)
-  case Co.compileGoal . Co.struct2goal . Co.squashVars <$>
+  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
+    _ -> backtrack --TODO actually throw
+
+assertClause :: BuiltinFn
+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
     _ -> backtrack
 
 retractall :: BuiltinFn
@@ -88,9 +110,10 @@ retractall = do
 {- adding the builtins -}
 addOp op = modify $ \s -> s {ops = op : ops s}
 
-addClause struct head =
+addClause struct code = do
+  lift . outputStrLn $ "Adding " ++ show struct ++ " with code " ++ show code
   modify $ \s ->
-    s {defs = M.alter (Just . maybe [head] (\hs -> head : hs)) struct $ defs s}
+    s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s}
 
 addProcedure struct heads =
   modify $ \s -> s {defs = M.insert struct heads $ defs s}
@@ -112,12 +135,24 @@ addPrelude = do
   {- clauses -}
   addOp $ O.xfy "," 1000
   addOp $ O.xfx ":-" 1200
-  addOp $ O.fx ":-" 1200
-  addProc "assert" 1 [[U (LocalRef 0 0), Invoke (bi assertFact)]]
+  horn2 <- findStruct ":-" 2
+  --addOp $ O.fx ":-" 1200
+  addProc
+    "assert"
+    1
+    [ [ U (Struct horn2)
+      , U (LocalRef 0 0)
+      , U (LocalRef 1 0)
+      , Cut
+      , Invoke (bi assertClause)
+      ]
+    , [U (LocalRef 0 0), Invoke (bi assertFact)]
+    ]
   addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]]
   {- query tools -}
   addBi0 "print_locals" printLocals
-  addBi0 "prompt_retry" promptRetry
+  addBi0 "prompt_retry" promptRetry'
+  addBi0 "query" (printLocals >> promptRetry)
   {- IO -}
   addProc "write" 1 [[U (LocalRef 0 0), Invoke (bi write)]]
   addProc "writeln" 1 [[U (LocalRef 0 0), Invoke (bi writeln)]]