Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 108 lines (94 sloc) 3.387 kb
4d8f4f1 Luke Palmer 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 Luke Palmer 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 Luke Palmer Converted typeOf to use MaybeT for clarity.
authored
8 import Control.Monad.Error
8a731b1 Luke Palmer 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 Luke Palmer 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 Luke Palmer Converted typeOf to use MaybeT for clarity.
authored
32 type Proof = ErrorT String (ReaderT (Map.Map Int Term) (State Int))
8a731b1 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
33
53ab4d0 Luke Palmer 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 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
36
1029fbe Luke Palmer Documentation and readability tweaks.
authored
37 -- Reduce a term to weak head normal form.
8a731b1 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
38 rwhnf :: Term -> Term
39 rwhnf (t :% u) =
40 case rwhnf t of
dffd730 Luke Palmer Small bugfix.
authored
41 Lam z -> rwhnf (subst 0 u z)
8a731b1 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
42 t' -> t' :% u
43 rwhnf x = x
44
bd7a866 Luke Palmer Another bugfix.
authored
45 quote n (Lam t) = Lam (quote (n+1) t)
46 quote n (Var z) | n <= z = Var (z+1)
47 quote n (t :% u) = quote n t :% quote n u
48 quote n x = x
49
1029fbe Luke Palmer Documentation and readability tweaks.
authored
50 subst n with (Lam t) = Lam (subst (n+1) (quote 0 with) t)
51 subst n with (Var n') =
bd7a866 Luke Palmer Another bugfix.
authored
52 case n' `compare` n of
53 LT -> Var n'
1029fbe Luke Palmer Documentation and readability tweaks.
authored
54 EQ -> with
bd7a866 Luke Palmer Another bugfix.
authored
55 GT -> Var (n'-1)
1029fbe Luke Palmer Documentation and readability tweaks.
authored
56 subst n with (t :% u) = subst n with t :% subst n with u
57 subst n with x = x
8a731b1 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
58
53ab4d0 Luke Palmer Converted typeOf to use MaybeT for clarity.
authored
59 onFailure e m = catchError m (const (fail e))
60
4d8f4f1 Luke Palmer Documented the connection with the paper.
authored
61 -- returns Just if the term given is a neutral normal form
62 -- (and thus has a type in the envt), Nothing otherwise
2c664a4 Luke Palmer Significant cleanup.
authored
63 typeOf :: Term -> Maybe (Proof Term)
ddd77a4 Luke Palmer Fixed stupidity in last edit.
authored
64 typeOf = go . rwhnf
8a731b1 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
65 where
2c664a4 Luke Palmer Significant cleanup.
authored
66 go (Neutral n) = return . lift $ asks (Map.! n)
98eb479 Luke Palmer Incorporate G_e rule, which had far reaching consequences.
authored
67 go (f :% x) = do
f8d4184 Luke Palmer Clarity tweaks.
authored
68 fty <- typeOf f
69 return $ onFailure ("Cannot apply nonfunction type in " ++ show (f :% x)) $ do
70 G :% dom :% cod <- rwhnf `fmap` fty
2c664a4 Luke Palmer Significant cleanup.
authored
71 prove (dom :% x) >> return (cod :% x)
72 go _ = Nothing
98eb479 Luke Palmer Incorporate G_e rule, which had far reaching consequences.
authored
73
74 unify :: Term -> Term -> Proof ()
1029fbe Luke Palmer Documentation and readability tweaks.
authored
75 unify t u = unless (t == u) . fail $ "Could not unify: " ++ show t ++ " = " ++ show u
98eb479 Luke Palmer Incorporate G_e rule, which had far reaching consequences.
authored
76
f8d4184 Luke Palmer Clarity tweaks.
authored
77 withNeutral :: Term -> (Term -> Proof a) -> Proof a
78 withNeutral rng f = do
79 n <- get
80 put $! n+1
81 local (Map.insert n rng) $ f (Neutral n)
82
98eb479 Luke Palmer Incorporate G_e rule, which had far reaching consequences.
authored
83 prove :: Term -> Proof ()
84 prove = go . rwhnf
85 where
1029fbe Luke Palmer Documentation and readability tweaks.
authored
86 go (G :% x :% y :% z) = do -- rule Gi
8a731b1 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
87 prove (L :% x)
f8d4184 Luke Palmer Clarity tweaks.
authored
88 withNeutral x $ \n -> prove . rwhnf $ y :% n :% (z :% n)
89 go (fin :% xin) = do
90 case (fin, rwhnf xin) of
1029fbe Luke Palmer Documentation and readability tweaks.
authored
91 -- first rule (X in ? => ? |- X)
92 (f, Neutral n) -> unify f =<< asks (Map.! n)
93 -- rule Ge
f8d4184 Luke Palmer Clarity tweaks.
authored
94 (f, z :% v) | Just typeof <- typeOf z ->
95 onFailure ("Couldn't apply non-function type: " ++ show z) $ do
96 G :% x :% y <- typeof
97 unify f (y :% v)
1029fbe Luke Palmer Documentation and readability tweaks.
authored
98 -- Type:Type, my own contribution. Causes inconsistency by Girard.
99 -- Remove to make consistent, but you need explicit external "L a"
100 -- assumptions to do anything useful.
101 (L, L) -> return ()
102 -- rule GL
f8d4184 Luke Palmer Clarity tweaks.
authored
103 (L, G :% x :% y) -> do
104 prove (L :% x)
105 withNeutral x $ \z -> prove (L :% (y :% z))
106 t -> fail $ "Don't know how to prove: " ++ show (fin :% xin)
8a731b1 Luke Palmer Added an Illative Combinatory Logic (system TG) experiment.
authored
107 go t = fail $ "Couldn't prove " ++ show t ++ ": no applicable rule"
Something went wrong with that request. Please try again.