diff --git a/app/Builtins.hs b/app/Builtins.hs index eb2dac1..8df703c 100644 --- a/app/Builtins.hs +++ b/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 diff --git a/inst/prelude.pl b/inst/prelude.pl index fefed5f..cc0c940 100644 --- a/inst/prelude.pl +++ b/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.