ints int
This commit is contained in:
parent
b417117130
commit
336feaeba0
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Reference in a new issue