Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 104 lines (90 sloc) 3.09 kb
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
1 import qualified Data.Map as Map
2 import Control.Monad.Reader
3 import Control.Monad.State
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
4 import Control.Monad.Maybe
5 import Control.Monad.Error
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
6
7 infixl 9 :%
8 data Term
9 = Lam Term
10 | Var Int
11 | Neutral Int
12 | Term :% Term
13 | L
14 | G
15 deriving Show
16
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
17 type Proof = ErrorT String (ReaderT (Map.Map Int Term) (State Int))
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
18
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
19 runProof :: Proof a -> Either String a
20 runProof p = evalState (runReaderT (runErrorT p) Map.empty) 0
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
21
22 newNeutral :: Proof Int
23 newNeutral = do
24 n <- get
25 put $! n+1
26 return n
27
28 rwhnf :: Term -> Term
29 rwhnf (t :% u) =
30 case rwhnf t of
dffd730 @luqui Small bugfix.
authored
31 Lam z -> rwhnf (subst 0 u z)
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
32 t' -> t' :% u
33 rwhnf x = x
34
bd7a866 @luqui Another bugfix.
authored
35 quote n (Lam t) = Lam (quote (n+1) t)
36 quote n (Var z) | n <= z = Var (z+1)
37 quote n (t :% u) = quote n t :% quote n u
38 quote n x = x
39
40 subst n for (Lam t) = Lam (subst (n+1) (quote 0 for) t)
41 subst n for (Var n') =
42 case n' `compare` n of
43 LT -> Var n'
44 EQ -> for
45 GT -> Var (n'-1)
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
46 subst n for (t :% u) = subst n for t :% subst n for u
47 subst n for x = x
48
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
49 onFailure e m = catchError m (const (fail e))
50
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
51 typeOf :: Term -> Proof (Maybe Term)
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
52 typeOf = onFailure "Cannot apply nonfunction type" . runMaybeT . go
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
53 where
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
54 typeOf' = go . rwhnf
55
56 go (Neutral n) = lift $ asks (Map.! n)
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
57 go (f :% x) = do
53ab4d0 @luqui Converted typeOf to use MaybeT for clarity.
authored
58 G :% dom :% cod <- fmap rwhnf (typeOf' f)
59 lift $ prove (dom :% x)
60 return (cod :% x)
61 go _ = fail ""
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
62
63 unify :: Term -> Term -> Proof ()
64 unify t u = unless (betaEq t u) . fail $ "Could not unify: " ++ show t ++ " = " ++ show u
65
66 prove :: Term -> Proof ()
67 prove = go . rwhnf
68 where
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
69 go (G :% x :% y :% z) = do
70 prove (L :% x)
71 var <- newNeutral
72 let n = Neutral var
73 local (Map.insert var x) . prove . rwhnf $ y :% n :% (z :% n)
98eb479 @luqui Incorporate G_e rule, which had far reaching consequences.
authored
74 go (f :% x) = do
75 case (f, rwhnf x) of
76 (f, Neutral n) -> do
77 nty <- asks (Map.lookup n)
78 maybe (fail $ show n ++ " not in environment") (unify f) nty
79 (f, z :% v) -> do
80 mzty <- typeOf z
81 case mzty of
82 Just (G :% x' :% y') -> unify f (y' :% v)
83 Just t -> fail $ "Couldn't apply non-function type: " ++ show t
84 Nothing -> case (f, z :% v) of
85 (L, G :% t :% u) -> do
86 prove (L :% t)
87 var <- newNeutral
88 local (Map.insert var t) $ prove (L :% (u :% Neutral var))
89 t -> fail $ "Don't know how to prove: " ++ show (f :% (z :% v))
90 (L, L) -> return ()
91 t -> fail $ "Don't know how to prove: " ++ show (f :% x)
8a731b1 @luqui Added an Illative Combinatory Logic (system TG) experiment.
authored
92 go t = fail $ "Couldn't prove " ++ show t ++ ": no applicable rule"
93
94 betaEq :: Term -> Term -> Bool
95 betaEq t u = go (rwhnf t) (rwhnf u)
96 where
97 go (Lam t) (Lam u) = betaEq t u
98 go (Var i) (Var j) = i == j
99 go (Neutral i) (Neutral j) = i == j
100 go (t :% u) (t' :% u') = go t t' && betaEq u u'
101 go L L = True
102 go G G = True
103 go _ _ = False
Something went wrong with that request. Please try again.