Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 113 lines (98 sloc) 3.436 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
4
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
5 import qualified Data.Map as Map
6 import Control.Monad.Reader
7 import Control.Monad.State
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
8 import Control.Monad.Error
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
9
10 infixl 9 :%
11 data Term
12 = Lam Term
13 | Var Int
14 | Neutral Int
15 | Term :% Term
16 | L
17 | G
18 deriving Show
19
1029fbe @luqui Documentation and readability tweaks.
authored
20 -- Beta equality
21 instance Eq Term where
22 t == u = go (rwhnf t) (rwhnf u)
23 where
24 go (Lam t) (Lam u) = t == u
25 go (Var i) (Var j) = i == j
26 go (Neutral i) (Neutral j) = i == j
27 go (t :% u) (t' :% u') = go t t' && u == u'
28 go L L = True
29 go G G = True
30 go _ _ = False
31
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
32 type Proof = ErrorT String (ReaderT (Map.Map Int Term) (State Int))
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
33
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
34 runProof :: Proof a -> Either String a
35 runProof p = evalState (runReaderT (runErrorT p) Map.empty) 0
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
36
37 newNeutral :: Proof Int
38 newNeutral = do
39 n <- get
40 put $! n+1
41 return n
42
1029fbe @luqui Documentation and readability tweaks.
authored
43 -- Reduce a term to weak head normal form.
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
44 rwhnf :: Term -> Term
45 rwhnf (t :% u) =
46 case rwhnf t of
dffd730 @luqui Small bugfix.
authored
47 Lam z -> rwhnf (subst 0 u z)
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
48 t' -> t' :% u
49 rwhnf x = x
50
bd7a866 @luqui Another bugfix.
authored
51 quote n (Lam t) = Lam (quote (n+1) t)
52 quote n (Var z) | n <= z = Var (z+1)
53 quote n (t :% u) = quote n t :% quote n u
54 quote n x = x
55
1029fbe @luqui Documentation and readability tweaks.
authored
56 subst n with (Lam t) = Lam (subst (n+1) (quote 0 with) t)
57 subst n with (Var n') =
bd7a866 @luqui Another bugfix.
authored
58 case n' `compare` n of
59 LT -> Var n'
1029fbe @luqui Documentation and readability tweaks.
authored
60 EQ -> with
bd7a866 @luqui Another bugfix.
authored
61 GT -> Var (n'-1)
1029fbe @luqui Documentation and readability tweaks.
authored
62 subst n with (t :% u) = subst n with t :% subst n with u
63 subst n with x = x
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
64
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
65 onFailure e m = catchError m (const (fail e))
66
4d8f4f1 @luqui Documented the connection with the paper.
authored
67 -- returns Just if the term given is a neutral normal form
68 -- (and thus has a type in the envt), Nothing otherwise
2c664a4 @luqui Significant cleanup.
authored
69 typeOf :: Term -> Maybe (Proof Term)
ddd77a4 @luqui Fixed stupidity in last edit.
authored
70 typeOf = go . rwhnf
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
71 where
2c664a4 @luqui Significant cleanup.
authored
72 go (Neutral n) = return . lift $ asks (Map.! n)
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
73 go (f :% x) = do
2c664a4 @luqui Significant cleanup.
authored
74 fty <- (fmap.fmap) rwhnf (typeOf f)
75 return $ onFailure "Cannot apply nonfunction type" $ do
76 G :% dom :% cod <- fty
77 prove (dom :% x) >> return (cod :% x)
78 go _ = Nothing
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
79
80 unify :: Term -> Term -> Proof ()
1029fbe @luqui Documentation and readability tweaks.
authored
81 unify t u = unless (t == u) . fail $ "Could not unify: " ++ show t ++ " = " ++ show u
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
82
83 prove :: Term -> Proof ()
84 prove = go . rwhnf
85 where
1029fbe @luqui Documentation and readability tweaks.
authored
86 go (G :% x :% y :% z) = do -- rule Gi
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
87 prove (L :% x)
88 var <- newNeutral
89 let n = Neutral var
90 local (Map.insert var x) . prove . rwhnf $ y :% n :% (z :% n)
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
91 go (f :% x) = do
92 case (f, rwhnf x) of
1029fbe @luqui Documentation and readability tweaks.
authored
93 -- first rule (X in ? => ? |- X)
94 (f, Neutral n) -> unify f =<< asks (Map.! n)
95 -- rule Ge
96 (f, z :% v) | Just typeof <- typeOf z -> do
2c664a4 @luqui Significant cleanup.
authored
97 zty <- typeof
98 case zty of
99 G :% x' :% y' -> unify f (y' :% v)
100 t -> fail $ "Couldn't apply non-function type: " ++ show t
1029fbe @luqui Documentation and readability tweaks.
authored
101 -- Type:Type, my own contribution. Causes inconsistency by Girard.
102 -- Remove to make consistent, but you need explicit external "L a"
103 -- assumptions to do anything useful.
104 (L, L) -> return ()
105 -- rule GL
106 (L, G :% t :% u) -> do
2c664a4 @luqui Significant cleanup.
authored
107 prove (L :% t)
108 var <- newNeutral
109 local (Map.insert var t) $ prove (L :% (u :% Neutral var))
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
110 t -> fail $ "Don't know how to prove: " ++ show (f :% x)
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
111 go t = fail $ "Couldn't prove " ++ show t ++ ": no applicable rule"
112
Something went wrong with that request. Please try again.