1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
{-# LANGUAGE TupleSections #-}
module Interpreter where
import Data.Function
import qualified Data.Map as M
{- VAM 2P, done the lazy way -}
data StrTable =
StrTable Int (M.Map Int String)
data Datum
= Atom Int -- unifies a constant
| Struct (Int, Int) -- unifies a structure with arity
deriving (Show)
data Instr
= U Datum -- something unifiable
| NoGoal -- trivial goal
| Goal -- we start a new goal, set up backtracking etc
| Call -- all seems okay, call the goal
| LastCall -- tail call the goal
deriving (Show)
type Code = [Instr]
type Alts = [(Code, Code)] -- clauses to try and the corresponding goals to restore
data Stk =
Stk Alts [(Code, Alts)]
deriving (Show) -- local backtracks (skipped on cut) + return&backtracks
type Defs = M.Map (Int, Int) [Code]
data Interp =
Interp
{ defs :: Defs -- global definitions for lookup
, hed :: Code -- current head
, gol :: Code -- current goal
, stk :: Stk -- possible heads with stored original goal
}
deriving (Show)
prove :: Code -> Defs -> Either (Interp, String) Bool
prove g ds =
let i0 = Interp ds g [LastCall] (Stk [] [])
run (Left x) = x
run (Right x) = run $ proveStep Right Left x
in run (Right i0)
{- this gonna need Either String Bool for errors later -}
proveStep :: (Interp -> a) -> (Either (Interp, String) Bool -> a) -> Interp -> a
proveStep c f i = go i
where
ifail msg = f $ Left (i, msg)
withDef f
| Just d <- defs i M.!? f = ($ d)
| otherwise = const $ ifail $ "no definition: " ++ show f
{- Backtracking: try a fallback clause, restoring goal -}
backtrack i@Interp {stk = Stk ((s, gs):ss) sss} =
c i {hed = s, gol = gs, stk = Stk ss sss}
{- B: no next clause, pop stack and continue backtracking at the caller -}
backtrack i@Interp {stk = Stk [] ((g, ss):sss)} =
backtrack i {hed = error "failed hed", gol = g, stk = Stk ss sss}
{- B: we ran out of possibilities and there's nothing else to backtrack. No solution found. -}
backtrack i@Interp {stk = Stk [] []} = f (Right False)
{- Unification -}
go i@Interp {hed = (U a:hs), gol = (U b:gs)} -- unify constants
= unify a b
where
uok = c i {hed = hs, gol = gs}
unify (Atom a) (Atom b)
| a == b = uok
unify (Struct a) (Struct b)
| a == b = uok
unify _ _ = backtrack i
{- Resolution: Final success -}
go i@Interp {hed = [NoGoal], gol = [LastCall], stk = Stk _ []} =
f (Right True)
{- R: Goal succeeded; continue at parent frame -}
go i@Interp { hed = [NoGoal]
, gol = [LastCall]
, stk = Stk _ ((Goal:U (Struct f):gs, ss):sss)
} =
withDef f $ \(hs:ohs) ->
c i {hed = hs, gol = gs, stk = Stk (map (, gs) ohs ++ ss) sss}
{- R: Start matching next goal -}
go i@Interp { hed = [NoGoal]
, gol = (Call:Goal:U (Struct f):gs)
, stk = Stk ss sss
} =
withDef f $ \(hs:ohs) ->
c i {hed = hs, gol = gs, stk = Stk (map (, gs) ohs ++ ss) sss}
{- R: Goal head matching succeeded, make a normal call -}
go i@Interp { hed = (Goal:U (Struct f):ngs)
, gol = (Call:gs)
, stk = Stk ss sss
} =
withDef f $ \(hs:ohs) ->
c i {hed = hs, gol = ngs, stk = Stk (map (, ngs) ohs) ((gs, ss) : sss)}
{- R: Successful match continued by tail call -}
go i@Interp { hed = (Goal:U (Struct f):ngs)
, gol = [LastCall]
, stk = Stk _ sss
} =
withDef f $ \(hs:ohs) ->
c i {hed = hs, gol = ngs, stk = Stk (map (, ngs) ohs) sss}
{- The End -}
go _ = ifail "impossible instruction combo"
|
