Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 105 lines (90 sloc) 3.244 kb
4d8f4f1 @luqui Documented the connection with the paper.
authored
1 -- System IG, from the paper _Systems of Illative Combinatory Logic
2 -- complete for first-order propositional and predicate calculus_,
3 -- Barendregt, Bunder, Dekkers 1993
234332d @luqui More doc and cleanup.
authored
4 --
5 -- The rules follow:
6 -- (Ai) X in Δ => Δ |- X
7 -- (Aβη) Δ |- X; X =βη Y => Δ |- Y
8 -- (Ge) Δ |- GXYZ; Δ |- XV => Δ |- YV(ZV)
9 -- (Gi) Δ |- Lx; Δ,Xx |- Yx(Zx); x not in FV(Δ,X,Y,Z) => Δ |- GXYZ
10 -- (GL) Δ |- Lx; Δ,Xx |- L(Yx); x not in FV(Δ,X,Y) => Δ |- L(GXY)
4d8f4f1 @luqui Documented the connection with the paper.
authored
11
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
12 import qualified Data.Map as Map
13 import Control.Monad.Reader
14 import Control.Monad.State
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
15 import Control.Monad.Error
7a32205 @luqui Fixed the nontermination problems, I think.
authored
16 import Debug.Trace
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
17
18 infixl 9 :%
19 data Term
20 = Lam Term
21 | Var Int
22 | Neutral Int
23 | Term :% Term
24 | L
25 | G
54511dd @luqui Whoops, should check compile.
authored
26 deriving (Show)
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
27
234332d @luqui More doc and cleanup.
authored
28 -- This first section implements Aβη. (==) is β-equality.
1029fbe @luqui Documentation and readability tweaks.
authored
29 instance Eq Term where
30 t == u = go (rwhnf t) (rwhnf u)
31 where
32 go (Lam t) (Lam u) = t == u
33 go (Var i) (Var j) = i == j
34 go (Neutral i) (Neutral j) = i == j
35 go (t :% u) (t' :% u') = go t t' && u == u'
36 go L L = True
37 go G G = True
38 go _ _ = False
39
40 -- Reduce a term to weak head normal form.
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
41 rwhnf :: Term -> Term
42 rwhnf (t :% u) =
43 case rwhnf t of
dffd730 @luqui Small bugfix.
authored
44 Lam z -> rwhnf (subst 0 u z)
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
45 t' -> t' :% u
46 rwhnf x = x
47
bd7a866 @luqui Another bugfix.
authored
48 quote n (Lam t) = Lam (quote (n+1) t)
49 quote n (Var z) | n <= z = Var (z+1)
50 quote n (t :% u) = quote n t :% quote n u
51 quote n x = x
52
1029fbe @luqui Documentation and readability tweaks.
authored
53 subst n with (Lam t) = Lam (subst (n+1) (quote 0 with) t)
54 subst n with (Var n') =
bd7a866 @luqui Another bugfix.
authored
55 case n' `compare` n of
56 LT -> Var n'
1029fbe @luqui Documentation and readability tweaks.
authored
57 EQ -> with
bd7a866 @luqui Another bugfix.
authored
58 GT -> Var (n'-1)
1029fbe @luqui Documentation and readability tweaks.
authored
59 subst n with (t :% u) = subst n with t :% subst n with u
60 subst n with x = x
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
61
234332d @luqui More doc and cleanup.
authored
62 -- This second section implements the proof search algorithm.
63 type Proof = ErrorT String (ReaderT (Map.Map Int Term) (State Int))
64
65 runProof :: Proof a -> Either String a
66 runProof p = evalState (runReaderT (runErrorT p) Map.empty) 0
67
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
68 onFailure e m = catchError m (const (fail e))
69
7a32205 @luqui Fixed the nontermination problems, I think.
authored
70 neutral :: Term -> Maybe (Proof Term)
71 neutral = go
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
72 where
2c664a4 @luqui Significant cleanup.
authored
73 go (Neutral n) = return . lift $ asks (Map.! n)
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
74 go (f :% x) = do
7a32205 @luqui Fixed the nontermination problems, I think.
authored
75 fty <- neutral f
76 return $ onFailure ("Cannot apply non-function type in " ++ show (f :% x)) $ do
77 G :% dom :% cod <- fty
2c664a4 @luqui Significant cleanup.
authored
78 prove (dom :% x) >> return (cod :% x)
79 go _ = Nothing
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
80
81 unify :: Term -> Term -> Proof ()
234332d @luqui More doc and cleanup.
authored
82 unify t u = unless (t == u) . fail $
83 "Could not unify: " ++ show t ++ " = " ++ show u
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
84
f8d4184 @luqui Clarity tweaks.
authored
85 withNeutral :: Term -> (Term -> Proof a) -> Proof a
86 withNeutral rng f = do
87 n <- get
88 put $! n+1
89 local (Map.insert n rng) $ f (Neutral n)
90
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
91 prove :: Term -> Proof ()
b15f41e @luqui Small refactor.
authored
92 prove (f :% x) = proveWF L f >> proveWF f x
93 prove x = fail $ "Cannot prove atom: " ++ show x
ae2a178 @luqui Substantial cleanup in the prove function.
authored
94
95 -- proveWF f x proves the application f x, under the
96 -- assumption that L f has already been proven.
b15f41e @luqui Small refactor.
authored
97 proveWF L L = return ()
98 proveWF f n | Just typeof <- neutral n = unify f =<< typeof
ae2a178 @luqui Substantial cleanup in the prove function.
authored
99 proveWF (G :% x :% y) (Lam z) = withNeutral x $ \n ->
b15f41e @luqui Small refactor.
authored
100 let f :% x' = rwhnf (y :% n :% subst 0 n z) in proveWF f x'
ae2a178 @luqui Substantial cleanup in the prove function.
authored
101 proveWF L (G :% x :% y) = do
7a32205 @luqui Fixed the nontermination problems, I think.
authored
102 prove (L :% x)
ae2a178 @luqui Substantial cleanup in the prove function.
authored
103 proveWF (G :% x :% Lam L) y
104 proveWF t u = fail $ "Couldn't prove " ++ show (t :% u)
Something went wrong with that request. Please try again.