Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 111 lines (98 sloc) 3.436 kb
4d8f4f13 »
2009-02-18 Documented the connection with the paper.
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
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
5 import qualified Data.Map as Map
6 import Control.Monad.Reader
7 import Control.Monad.State
53ab4d0b »
2009-02-18 Converted typeOf to use MaybeT for clarity.
8 import Control.Monad.Error
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
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
1029fbea »
2009-02-18 Documentation and readability tweaks.
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
53ab4d0b »
2009-02-18 Converted typeOf to use MaybeT for clarity.
32 type Proof = ErrorT String (ReaderT (Map.Map Int Term) (State Int))
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
33
53ab4d0b »
2009-02-18 Converted typeOf to use MaybeT for clarity.
34 runProof :: Proof a -> Either String a
35 runProof p = evalState (runReaderT (runErrorT p) Map.empty) 0
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
36
37 newNeutral :: Proof Int
38 newNeutral = do
39 n <- get
40 put $! n+1
41 return n
42
1029fbea »
2009-02-18 Documentation and readability tweaks.
43 -- Reduce a term to weak head normal form.
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
44 rwhnf :: Term -> Term
45 rwhnf (t :% u) =
46 case rwhnf t of
dffd7307 »
2009-02-18 Small bugfix.
47 Lam z -> rwhnf (subst 0 u z)
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
48 t' -> t' :% u
49 rwhnf x = x
50
bd7a8662 »
2009-02-18 Another bugfix.
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
1029fbea »
2009-02-18 Documentation and readability tweaks.
56 subst n with (Lam t) = Lam (subst (n+1) (quote 0 with) t)
57 subst n with (Var n') =
bd7a8662 »
2009-02-18 Another bugfix.
58 case n' `compare` n of
59 LT -> Var n'
1029fbea »
2009-02-18 Documentation and readability tweaks.
60 EQ -> with
bd7a8662 »
2009-02-18 Another bugfix.
61 GT -> Var (n'-1)
1029fbea »
2009-02-18 Documentation and readability tweaks.
62 subst n with (t :% u) = subst n with t :% subst n with u
63 subst n with x = x
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
64
53ab4d0b »
2009-02-18 Converted typeOf to use MaybeT for clarity.
65 onFailure e m = catchError m (const (fail e))
66
4d8f4f13 »
2009-02-18 Documented the connection with the paper.
67 -- returns Just if the term given is a neutral normal form
68 -- (and thus has a type in the envt), Nothing otherwise
2c664a46 »
2009-02-18 Significant cleanup.
69 typeOf :: Term -> Maybe (Proof Term)
ddd77a49 »
2009-02-18 Fixed stupidity in last edit.
70 typeOf = go . rwhnf
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
71 where
2c664a46 »
2009-02-18 Significant cleanup.
72 go (Neutral n) = return . lift $ asks (Map.! n)
98eb4793 »
2009-02-18 Incorporate G_e rule, which had far reaching consequences.
73 go (f :% x) = do
2c664a46 »
2009-02-18 Significant cleanup.
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
98eb4793 »
2009-02-18 Incorporate G_e rule, which had far reaching consequences.
79
80 unify :: Term -> Term -> Proof ()
1029fbea »
2009-02-18 Documentation and readability tweaks.
81 unify t u = unless (t == u) . fail $ "Could not unify: " ++ show t ++ " = " ++ show u
98eb4793 »
2009-02-18 Incorporate G_e rule, which had far reaching consequences.
82
83 prove :: Term -> Proof ()
84 prove = go . rwhnf
85 where
1029fbea »
2009-02-18 Documentation and readability tweaks.
86 go (G :% x :% y :% z) = do -- rule Gi
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
87 prove (L :% x)
88 var <- newNeutral
89 let n = Neutral var
90 local (Map.insert var x) . prove . rwhnf $ y :% n :% (z :% n)
98eb4793 »
2009-02-18 Incorporate G_e rule, which had far reaching consequences.
91 go (f :% x) = do
92 case (f, rwhnf x) of
1029fbea »
2009-02-18 Documentation and readability tweaks.
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
2c664a46 »
2009-02-18 Significant cleanup.
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
1029fbea »
2009-02-18 Documentation and readability tweaks.
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
2c664a46 »
2009-02-18 Significant cleanup.
107 prove (L :% t)
108 var <- newNeutral
109 local (Map.insert var t) $ prove (L :% (u :% Neutral var))
98eb4793 »
2009-02-18 Incorporate G_e rule, which had far reaching consequences.
110 t -> fail $ "Don't know how to prove: " ++ show (f :% x)
8a731b1d »
2009-02-18 Added an Illative Combinatory Logic (system TG) experiment.
111 go t = fail $ "Couldn't prove " ++ show t ++ ": no applicable rule"
112
Something went wrong with that request. Please try again.