ints int

app/Builtins.hs

@@ -9,12 +9,13 @@ import Control.Exception (IOException, catch)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
+import Data.Bits
 import Data.Functor.Identity (runIdentity)
 import Data.List (intercalate)
 import qualified Data.Map as M
 import Data.Maybe (fromJust)
 import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
-import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars)
+import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap)
 import qualified IR
 import Interpreter (backtrack)
 import Lens.Micro.Mtl
@@ -149,6 +150,13 @@ call = exec' id
 exec :: InterpFn
 exec = exec' (const [Done])
 
+stop :: InterpFn
+stop =
+  withArgs [0] $ \[arg] -> do
+    IR.StrTable _ _ itos <- use strtable
+    heap <- use (cur . heap)
+    prlgError $ "stop: " ++ showTerm itos heap arg
+
 {- struct assembly/disassembly -}
 struct :: InterpFn
 struct = do
@@ -218,6 +226,14 @@ var = do
     Just (FreeRef _) -> continue
     _ -> backtrack
 
+number :: InterpFn
+number = do
+  heap <- use (cur . heap)
+  scope <- use (cur . hvar)
+  case derefHeap heap <$> scope M.!? 0 of
+    Just (BoundRef _ (Number _)) -> continue
+    _ -> backtrack
+
 sameTerm :: InterpFn
 sameTerm = do
   heap <- use (cur . heap)
@@ -304,6 +320,57 @@ popExpansions = do
       macrostash .= stash'
       continue
 
+{- integer arithmetics -}
+intBinary :: (Int -> Int -> Int) -> InterpFn
+intBinary op =
+  withArgs [0, 1] $ \[arg1, arg2] -> do
+    heap <- use (cur . heap)
+    case derefHeap heap <$> [arg1, arg2] of
+      [BoundRef _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2
+      _ -> prlgError "int binary needs numbers"
+
+intBinPred :: (Int -> Int -> Bool) -> InterpFn
+intBinPred op =
+  withArgs [0, 1] $ \args -> do
+    heap <- use (cur . heap)
+    case derefHeap heap <$> args of
+      [BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
+        if op n1 n2
+          then continue
+          else backtrack
+      _ -> prlgError "int binary pred needs numbers"
+
+intUnary :: (Int -> Int) -> InterpFn
+intUnary op =
+  withArgs [0] $ \[arg] -> do
+    heap <- use (cur . heap)
+    case derefHeap heap arg of
+      BoundRef _ (Number n) -> putInt (op n) 1
+      _ -> prlgError "int unary needs number"
+
+intUnPred :: (Int -> Bool) -> InterpFn
+intUnPred op =
+  withArgs [0] $ \[arg] -> do
+    heap <- use (cur . heap)
+    case derefHeap heap arg of
+      BoundRef _ (Number n) ->
+        if op n
+          then continue
+          else backtrack
+      _ -> prlgError "int binary pred needs numbers"
+
+putInt val sc = do
+  heap <- use (cur . heap)
+  scope <- use (cur . hvar)
+  case scope M.!? sc of
+    Nothing -> continue
+    Just a ->
+      case derefHeap heap a of
+        BoundRef _ (Number val')
+          | val == val' -> continue
+        FreeRef a' -> writeHeap a' (Number val) >> continue
+        _ -> backtrack
+
 {- adding the builtins -}
 addOp :: (String, O.Op) -> PrlgEnv ()
 addOp op = ops %= (op :)
@@ -357,9 +424,10 @@ load queryMode =
 addPrelude :: PrlgEnv ()
 addPrelude = do
   pure undefined
-  {- primitives -}
+  {- absolute primitives -}
   addBi (pure Nothing) "true" 0
   addBi backtrack "fail" 0
+  addBi stop "stop" 1
   addOp $ O.xfx "=" 700
   addProc [[U (LocalRef 0), U (LocalRef 0), Done]] "=" 2
   {- clauses -}
@@ -387,6 +455,7 @@ addPrelude = do
   {- terms -}
   addBi struct "struct" 3
   addBi var "var" 1
+  addBi number "number" 1
   addBi sameTerm "same_term" 2
   addBi currentPredicate "current_predicate" 1
   {- code loading -}
@@ -422,6 +491,28 @@ addPrelude = do
           2
   expandCode "load"
   expandCode "query"
+  {- int primops -}
+  let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3
+      add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2
+      add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2
+      add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1
+  add2IntOp "add" (+)
+  add2IntOp "sub" (-)
+  add1IntOp "neg" negate
+  add1IntOp "abs" abs
+  add2IntOp "mul" (*)
+  add2IntOp "div" div
+  add2IntOp "mod" mod
+  add2IntOp "bitand" (.&.)
+  add2IntOp "bitor" (.|.)
+  add2IntOp "bitxor" xor
+  add2IntOp "shl" shiftL
+  add2IntOp "shr" shiftR
+  add1IntPred "zero" (== 0)
+  add2IntPred "eq" (==)
+  add2IntPred "lt" (<)
+  add2IntPred "leq" (<=)
+  add2IntPred "neq" (/=)
   {- query tools -}
   addBi printLocals "print_locals" 0
   addBi promptRetry' "prompt_retry" 0

inst/prelude.pl

@@ -3,3 +3,59 @@ member(X, [_|T]) :- member(X,T).
 
 append([], X, X).
 append([X|T], Y, [X|TY]) :- append(T,Y,TY).
+
+:- op(700, xfx, is),
+   op(700, xfx, <),
+   op(700, xfx, =<),
+   op(700, xfx, >),
+   op(700, xfx, >=),
+   op(700, xfx, =\=),
+   op(700, xfx, =:=),
+   op(500, yfx, +),
+   op(500, yfx, -),
+   op(500, yfx, /\),
+   op(500, yfx, \/),
+   op(500, yfx, xor),
+   op(400, yfx, *),
+   op(400, yfx, /),
+   op(400, yfx, div),
+   op(400, yfx, mod),
+   op(400, yfx, <<),
+   op(400, yfx, >>),
+   op(200, fy, -),
+   op(200, fy, +).
+
+X is A :- number(A), !, X=A.
+X is V :- var(V), !, stop('variable in arithmetics').
+R is Ax + Bx :- !, A is Ax, B is Bx, int2_add(A, B, R).
+R is Ax - Bx :- !, A is Ax, B is Bx, int2_sub(A, B, R).
+R is Ax * Bx :- !, A is Ax, B is Bx, int2_mul(A, B, R).
+R is Ax / Bx :- !, A is Ax, B is Bx, int2_div(A, B, R).
+R is Ax div Bx :- !, R is Ax / Bx.
+R is Ax mod Bx :- !, A is Ax, B is Bx, int2_mod(A, B, R).
+R is (+Ax) :- !, A is Ax, int1_abs(A, R).
+R is (-Ax) :- !, A is Ax, int1_neg(A, R).
+_ is _ :- stop('arithmetics needs numbers').
+
+Ax =:= Bx :- A is Ax, B is Bx, int2p_eq(A,B).
+Ax =\= Bx :- A is Ax, B is Bx, int2p_neq(A,B).
+Ax < Bx :- A is Ax, B is Bx, int2p_lt(A,B).
+Ax =< Bx :- A is Ax, B is Bx, int2p_leq(A,B).
+Ax > Bx :- A is Ax, B is Bx, int2p_lt(B,A).
+Ax >= Bx :- A is Ax, B is Bx, int2p_leq(B,A).
+zero(Ax) :- A is Ax, int1p_zero(A).
+
+gcd(X,Y,R) :- writeln(a), fail.
+gcd(X,Y,R) :- writeln(b), zero(Y), !, R=X.
+gcd(X,Y,R) :- writeln(c), X1 is X mod Y, gcd(Y,X1,R).
+gcd(X,Y,R) :- writeln(a), Y > X, writeln(wat), !, gcd(Y,X,R).
+gcd(X,Y,R) :- writeln(b), zero(Y), !, R=X.
+gcd(X,Y,R) :- writeln(c), X1 is X mod Y, gcd(Y,X1,R).
+
+test(X) :- writeln(there), zero(X), fail.
+test(X) :- writeln(here).
+
+test :- writeln(a), a=a, !, fail.
+test :- writeln(b).
+
+xxx :- test.