├── .gitignore ├── README.md ├── seqcalctalk.ipkg └── src ├── CEK.idr ├── KAM.idr ├── LK.idr ├── LKConn.idr ├── LKLamApp.idr ├── LKQ.idr ├── LKT.idr ├── Lambda.idr ├── List.idr ├── SC.idr └── STLC.idr /.gitignore: -------------------------------------------------------------------------------- 1 | *.ibc 2 | target -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Logic, Machines and Sequent Calculus 2 | 3 | Code for the talk. 4 | 5 | 2019 Version: https://www.youtube.com/watch?v=O0TgP7GKkSY 6 | 7 | 2018 Version: https://www.youtube.com/watch?v=9l6FD9gRGxc 8 | 9 | Modules by their appearance: 10 | 11 | * `List` - some properties of lists 12 | * `Lambda` - untyped lambda calculus 13 | * `STLC` - simply-typed lambda calculus 14 | * `SC` - one-sided sequent calculus LJ 15 | * `LK` - two-sided core sequent calculus LK 16 | * `LKConn` - LK with additional connectives 17 | * `LKLamApp` - LK and deconstruction of lambdas 18 | * `KAM` - Krivine abstract machine for untyped lambda 19 | * `CEK` - Control+Environment+Kontinuation abstract machine for untyped lambda 20 | * `LKT` - focused call-by-name version of LK 21 | * `LKQ` - focused call-by-value version of LK 22 | 23 | ## References 24 | 25 | * [Kokke, "One lambda-calculus, many times"](https://wenkokke.github.io/2016/one-lambda-calculus-many-times/) 26 | * [Downen, Ariola, "A Tutorial on Computational Classical Logic and the Sequent Calculus"](http://ix.cs.uoregon.edu/~pdownen/publications/sequent-intro.pdf) 27 | * [Spiwack, "A dissection of L"](http://assert-false.net/arnaud/papers/A%20dissection%20of%20L.pdf) 28 | * [Maillard et al, "A preview of a tutorial on polarised L calculi"](http://gallium.inria.fr/~scherer/research/L/tutorial-talk.pdf) 29 | * [Munch-Maccagnoni, "Syntax and Models of a non-Associative Composition of Programs and Proofs"](http://guillaume.munch.name/papers/#SMAC) 30 | -------------------------------------------------------------------------------- /seqcalctalk.ipkg: -------------------------------------------------------------------------------- 1 | package seqcalctalk 2 | 3 | sourcedir = src 4 | 5 | modules = List 6 | , Lambda 7 | , STLC 8 | , SC 9 | , LK 10 | , LKConn 11 | , LKLamApp 12 | , KAM 13 | , CEK 14 | , LKQ 15 | , LKT 16 | 17 | opts = "--total" 18 | -------------------------------------------------------------------------------- /src/CEK.idr: -------------------------------------------------------------------------------- 1 | module KAM 2 | 3 | import Data.List 4 | import Lambda 5 | 6 | %access public export 7 | %default total 8 | 9 | mutual 10 | Env : Type 11 | Env = List Clos 12 | 13 | data Clos = Cl Term Env 14 | 15 | data Frame = Fun Term Env | Arg Clos 16 | 17 | Stack : Type 18 | Stack = List Frame 19 | 20 | data State = L Term Env Stack | R Clos Stack 21 | 22 | step : State -> Maybe State 23 | step (L (Var Z) (v::_) s ) = Just $ R v s 24 | step (L (Var (S n)) (_::e) s ) = Just $ L (Var n) e s 25 | step (L (Lam t) e s ) = Just $ R (Cl (Lam t) e) s 26 | step (L (App t u) e s ) = Just $ L u e (Fun t e::s) 27 | step (R (Cl (Lam t) e) (Fun t1 e1::s)) = Just $ L t1 e1 (Arg (Cl (Lam t) e)::s) 28 | step (R (Cl (Lam t) e) ( Arg v::s)) = Just $ L t (v::e) s 29 | step _ = Nothing 30 | 31 | stepIter : State -> (Nat, Maybe State) 32 | stepIter s = loop Z s 33 | where 34 | loop : Nat -> State -> (Nat, Maybe State) 35 | loop n s1 = case step s1 of 36 | Nothing => (n, Just s1) 37 | Just s2 => assert_total $ loop (S n) s2 38 | 39 | run : Term -> (Nat, Maybe State) 40 | run t = stepIter $ L t [] [] 41 | 42 | test00 : run Term0 = (11, Just $ R (Cl Result []) []) 43 | test00 = Refl 44 | 45 | test01 : run Term1 = (11, Just $ R (Cl Result []) []) 46 | test01 = Refl 47 | 48 | test02 : run Term2 = (11, Just $ R (Cl Result []) []) 49 | test02 = Refl -------------------------------------------------------------------------------- /src/KAM.idr: -------------------------------------------------------------------------------- 1 | module KAM 2 | 3 | import Data.List 4 | import Lambda 5 | 6 | %access public export 7 | %default total 8 | 9 | mutual 10 | Env : Type 11 | Env = List Clos 12 | 13 | data Clos = Cl Term Env 14 | 15 | Stack : Type 16 | Stack = List Clos 17 | 18 | State : Type 19 | State = (Term, Env, Stack) 20 | 21 | step : State -> Maybe State 22 | step (Var Z , Cl t e::_, s) = Just ( t, e, s) 23 | step (Var (S n), _::e, s) = Just (Var n, e, s) 24 | step (Lam t , e, c::s) = Just ( t, c::e, s) 25 | step (App t u , e, s) = Just ( t, e, Cl u e::s) 26 | step _ = Nothing 27 | 28 | stepIter : State -> (Nat, Maybe State) 29 | stepIter s = loop Z s 30 | where 31 | loop : Nat -> State -> (Nat, Maybe State) 32 | loop n s1 = case step s1 of 33 | Nothing => (n, Just s1) 34 | Just s2 => assert_total $ loop (S n) s2 35 | 36 | run : Term -> (Nat, Maybe State) 37 | run t = stepIter (t, [], []) 38 | 39 | test00 : run Term0 = (7, Just (Result, [], [])) 40 | test00 = Refl 41 | 42 | test01 : run Term1 = (6, Just (Result, [], [])) 43 | test01 = Refl 44 | 45 | test02 : run Term2 = (6, Just (Result, [], [])) 46 | test02 = Refl 47 | -------------------------------------------------------------------------------- /src/LK.idr: -------------------------------------------------------------------------------- 1 | module LK 2 | 3 | import Data.List 4 | import List 5 | import STLC 6 | 7 | %access public export 8 | %default total 9 | 10 | mutual 11 | data Cmd : List Ty -> List Ty -> Type where 12 | C : Term g a d -> CoTerm g a d -> Cmd g d 13 | 14 | data Term : List Ty -> Ty -> List Ty -> Type where 15 | Var : Elem a g -> Term g a d 16 | Mu : Cmd g (a::d) -> Term g a d 17 | 18 | data CoTerm : List Ty -> Ty -> List Ty -> Type where 19 | CoVar : Elem a d -> CoTerm g a d 20 | Mut : Cmd (a::g) d -> CoTerm g a d 21 | 22 | {- 23 | mutual 24 | shiftCmd : IsSubset g g1 -> IsSubset d d1 -> Cmd g d -> Cmd g1 d1 25 | shiftCmd is1 is2 (C t e) = C (shiftTerm is1 is2 t) (shiftCoTerm is1 is2 e) 26 | 27 | shiftTerm : IsSubset g g1 -> IsSubset d d1 -> Term g a d -> Term g1 a d1 28 | shiftTerm is1 is2 (Var el) = Var $ ?wat 29 | shiftTerm is1 is2 (Mu c) = Mu $ ?wat2 30 | 31 | shiftCoTerm : IsSubset g g1 -> IsSubset d d1 -> CoTerm g a d -> CoTerm g1 a d1 32 | shiftCoTerm is1 is2 (CoVar el) = CoVar $ ?wat3 33 | shiftCoTerm is1 is2 (Mut c) = Mut $ ?wat4 34 | -} 35 | 36 | mutual 37 | shiftCmd : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Cmd g d -> Cmd g1 d1 38 | shiftCmd (C t e) = C (shiftTerm t) (shiftCoTerm e) 39 | 40 | shiftTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Term g a d -> Term g1 a d1 41 | shiftTerm {is1} (Var el) = Var $ shift is1 el 42 | shiftTerm {is2} (Mu c) = Mu $ shiftCmd {is2=Cons2 is2} c 43 | 44 | shiftCoTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> CoTerm g a d -> CoTerm g1 a d1 45 | shiftCoTerm {is2} (CoVar el) = CoVar $ shift is2 el 46 | shiftCoTerm {is1} (Mut c) = Mut $ shiftCmd {is1=Cons2 is1} c 47 | -------------------------------------------------------------------------------- /src/LKConn.idr: -------------------------------------------------------------------------------- 1 | module LKConn 2 | 3 | import Data.List 4 | import List 5 | 6 | %access public export 7 | %default total 8 | 9 | data Ty = A | Imp Ty Ty | Prod Ty Ty | Sum Ty Ty 10 | 11 | infix 5 ~> 12 | (~>) : Ty -> Ty -> Ty 13 | (~>) = Imp 14 | 15 | infix 5 :*: 16 | (:*:) : Ty -> Ty -> Ty 17 | (:*:) = Prod 18 | 19 | infix 5 :+: 20 | (:+:) : Ty -> Ty -> Ty 21 | (:+:) = Sum 22 | 23 | mutual 24 | data Cmd : List Ty -> List Ty -> Type where 25 | C : Term g a d -> CoTerm g a d -> Cmd g d 26 | 27 | data Term : List Ty -> Ty -> List Ty -> Type where 28 | Var : Elem a g -> Term g a d 29 | Mu : Cmd g (a::d) -> Term g a d 30 | Lam : Term (a::g) b d -> Term g (a~>b) d 31 | Pair : Term g a d -> Term g b d -> Term g (a:*:b) d 32 | Inl : Term g a d -> Term g (a:+:b) d 33 | Inr : Term g b d -> Term g (a:+:b) d 34 | 35 | data CoTerm : List Ty -> Ty -> List Ty -> Type where 36 | CoVar : Elem a d -> CoTerm g a d 37 | Mut : Cmd (a::g) d -> CoTerm g a d 38 | AppCon : Term g a d -> CoTerm g b d -> CoTerm g (a~>b) d 39 | MatProd : Cmd (a::b::g) d -> CoTerm g (a:*:b) d 40 | MatSum : Cmd (a::g) d -> Cmd (b::g) d -> CoTerm g (a:+:b) d 41 | -------------------------------------------------------------------------------- /src/LKLamApp.idr: -------------------------------------------------------------------------------- 1 | module LKLamApp 2 | 3 | import Data.List 4 | import List 5 | import STLC 6 | 7 | %access public export 8 | %default total 9 | 10 | mutual 11 | data Cmd : List Ty -> List Ty -> Type where 12 | C : Term g a d -> CoTerm g a d -> Cmd g d 13 | 14 | data Term : List Ty -> Ty -> List Ty -> Type where 15 | Var : Elem a g -> Term g a d 16 | Mu : Cmd g (a::d) -> Term g a d 17 | MatC : Cmd (a::g) (b::d) -> Term g (a~>b) d 18 | 19 | data CoTerm : List Ty -> Ty -> List Ty -> Type where 20 | CoVar : Elem a d -> CoTerm g a d 21 | Mut : Cmd (a::g) d -> CoTerm g a d 22 | AppC : Term g a d -> CoTerm g b d -> CoTerm g (a~>b) d 23 | 24 | mutual 25 | shiftCmd : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Cmd g d -> Cmd g1 d1 26 | shiftCmd (C t e) = C (shiftTerm t) (shiftCoTerm e) 27 | 28 | shiftTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Term g a d -> Term g1 a d1 29 | shiftTerm {is1} (Var el) = Var $ shift is1 el 30 | shiftTerm {is2} (Mu c) = Mu $ shiftCmd {is2=Cons2 is2} c 31 | shiftTerm {is1} {is2} (MatC c) = MatC $ shiftCmd {is1=Cons2 is1} {is2=Cons2 is2} c 32 | 33 | shiftCoTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> CoTerm g a d -> CoTerm g1 a d1 34 | shiftCoTerm {is2} (CoVar el) = CoVar $ shift is2 el 35 | shiftCoTerm {is1} (Mut c) = Mut $ shiftCmd {is1=Cons2 is1} c 36 | shiftCoTerm (AppC t e) = AppC (shiftTerm t) (shiftCoTerm e) 37 | 38 | lam : Term (a::g) b d -> Term g (a~>b) d 39 | lam t = 40 | MatC $ C (shiftTerm t) (CoVar Here) 41 | 42 | app : Term g (a~>b) d -> Term g a d -> Term g b d 43 | app t u = 44 | Mu $ C (shiftTerm t) 45 | (AppC (shiftTerm u) (CoVar Here)) 46 | 47 | let_ : Term g a d -> Term (a::g) b d -> Term g b d 48 | let_ t u = Mu $ C (shiftTerm t) 49 | (Mut $ C (shiftTerm u) (CoVar Here)) 50 | 51 | callcc : Term g ((a~>b)~>a) (a::d) -> Term g a d 52 | callcc f = 53 | Mu $ C f 54 | (AppC 55 | (MatC $ C (Var Here) (CoVar $ There Here)) 56 | (CoVar Here)) 57 | -------------------------------------------------------------------------------- /src/LKQ.idr: -------------------------------------------------------------------------------- 1 | module LKQ 2 | 3 | import Data.List 4 | import List 5 | import STLC 6 | 7 | %access public export 8 | %default total 9 | %hide Language.Reflection.Var 10 | 11 | mutual 12 | data Cmd : List Ty -> List Ty -> Type where 13 | C : Term g a d -> CoTerm g a d -> Cmd g d 14 | 15 | data Term : List Ty -> Ty -> List Ty -> Type where 16 | Val : Value g a d -> Term g a d 17 | Mu : Cmd g (a::d) -> Term g a d 18 | 19 | data Value : List Ty -> Ty -> List Ty -> Type where 20 | Var : Elem a g -> Value g a d 21 | MatC : Cmd (a::g) (b::d) -> Value g (a~>b) d 22 | 23 | data CoTerm : List Ty -> Ty -> List Ty -> Type where 24 | CoVar : Elem a d -> CoTerm g a d 25 | Empty : CoTerm g a d 26 | Mut : Cmd (a::g) d -> CoTerm g a d 27 | AppC : Value g a d -> CoTerm g b d -> CoTerm g (a~>b) d 28 | 29 | mutual 30 | shiftCmd : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Cmd g d -> Cmd g1 d1 31 | shiftCmd (C t e) = C (shiftTerm t) (shiftCoTerm e) 32 | 33 | shiftTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Term g a d -> Term g1 a d1 34 | shiftTerm (Val v) = Val $ shiftValue v 35 | shiftTerm {is2} (Mu c) = Mu $ shiftCmd {is2=Cons2 is2} c 36 | 37 | shiftValue : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Value g a d -> Value g1 a d1 38 | shiftValue {is1} (Var el) = Var $ shift is1 el 39 | shiftValue {is1} {is2} (MatC c) = MatC $ shiftCmd {is1=Cons2 is1} {is2=Cons2 is2} c 40 | 41 | shiftCoTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> CoTerm g a d -> CoTerm g1 a d1 42 | shiftCoTerm {is2} (CoVar el) = CoVar $ shift is2 el 43 | shiftCoTerm Empty = Empty 44 | shiftCoTerm {is1} (Mut c) = Mut $ shiftCmd {is1=Cons2 is1} c 45 | shiftCoTerm (AppC t e) = AppC (shiftValue t) (shiftCoTerm e) 46 | 47 | mutual 48 | subst : Cmd (a::g) d -> Value g a d -> Cmd g d 49 | subst (C t e) va = C (assert_total $ substTerm t va) (assert_total $ substCoTerm e va) 50 | 51 | substTerm : Term (a::g) c d -> Value g a d -> Term g c d 52 | substTerm (Val v) va = Val $ substValue v va 53 | substTerm (Mu cmd) va = Mu $ subst (shiftCmd cmd) (shiftValue va) 54 | 55 | substValue : Value (a::g) c d -> Value g a d -> Value g c d 56 | substValue (Var Here) va = va 57 | substValue (Var (There el)) _ = Var el 58 | substValue (MatC cmd) va = MatC $ subst (shiftCmd cmd) (shiftValue va) 59 | 60 | substCoTerm : CoTerm (a::g) c d -> Value g a d -> CoTerm g c d 61 | substCoTerm (CoVar el) va = CoVar el 62 | substCoTerm Empty va = Empty 63 | substCoTerm (Mut cmd) va = Mut $ subst (shiftCmd cmd) (shiftValue va) 64 | substCoTerm (AppC t e) va = AppC (substValue t va) (substCoTerm e va) 65 | 66 | mutual 67 | cosubst : Cmd g (a::d) -> CoTerm g a d -> Cmd g d 68 | cosubst (C t e) ct = C (assert_total $ cosubstTerm t ct) (assert_total $ cosubstCoTerm e ct) 69 | 70 | cosubstTerm : Term g c (a::d) -> CoTerm g a d -> Term g c d 71 | cosubstTerm (Val v) ct = Val $ cosubstValue v ct 72 | cosubstTerm (Mu cmd) ct = Mu $ cosubst (shiftCmd cmd) (shiftCoTerm ct) 73 | 74 | cosubstValue : Value g c (a::d) -> CoTerm g a d -> Value g c d 75 | cosubstValue (Var el) _ = Var el 76 | cosubstValue (MatC cmd) ct = MatC $ cosubst (shiftCmd cmd) (shiftCoTerm ct) 77 | 78 | cosubstCoTerm : CoTerm g c (a::d) -> CoTerm g a d -> CoTerm g c d 79 | cosubstCoTerm (CoVar Here) ct = ct 80 | cosubstCoTerm (CoVar (There el)) _ = CoVar el 81 | cosubstCoTerm Empty _ = Empty 82 | cosubstCoTerm (Mut cmd) ct = Mut $ cosubst cmd (shiftCoTerm ct) 83 | cosubstCoTerm (AppC t e) ct = AppC (cosubstValue t ct) (cosubstCoTerm e ct) 84 | 85 | reduce : Cmd g d -> Maybe (Cmd g d) 86 | reduce (C (Mu c) e ) = Just $ cosubst c e 87 | reduce (C (Val v) (Mut c) ) = Just $ subst c v 88 | reduce (C (Val (MatC c)) (AppC t e)) = Just $ cosubst (subst c (shiftValue t)) (shiftCoTerm e) 89 | reduce _ = Nothing 90 | 91 | reduceIter : Cmd g d -> (Nat, Maybe (Cmd g d)) 92 | reduceIter c = loop Z c 93 | where 94 | loop : Nat -> Cmd g d -> (Nat, Maybe (Cmd g d)) 95 | loop n c1 = case reduce c1 of 96 | Nothing => (n, Just c1) 97 | Just c2 => assert_total $ loop (S n) c2 98 | 99 | embedTm : STLC.Term g a -> Term g a [] 100 | embedTm (Var el) = Val $ Var el 101 | embedTm (Lam t) = Val $ MatC $ C (shiftTerm $ embedTm t) (CoVar Here) 102 | embedTm (App t u) = 103 | Mu $ C (shiftTerm $ embedTm t) $ case embedTm u of 104 | Val v => AppC (shiftValue v) (CoVar Here) 105 | Mu c => Mut $ C (shiftTerm $ Mu c) (Mut $ C (Val $ Var $ There Here) (AppC (Var Here) (CoVar Here))) 106 | 107 | extractTerm : Cmd g d -> (a ** Term g a d) 108 | extractTerm (C {a} t _) = (a ** t) 109 | 110 | runLKQ : STLC.Term g a -> (Nat, Maybe (b ** Term g b [])) 111 | runLKQ t = 112 | let (n,r) = reduceIter $ C (embedTm t) Empty in 113 | (n, extractTerm <$> r) 114 | 115 | test : runLKQ Term2 = (4, Just (TestTy ** embedTm Result)) 116 | test = Refl 117 | 118 | test2 : runLKQ Term3 = (6, Just (TestTy ** embedTm Result)) 119 | test2 = Refl 120 | -------------------------------------------------------------------------------- /src/LKT.idr: -------------------------------------------------------------------------------- 1 | module LKT 2 | 3 | import Data.List 4 | import List 5 | import STLC 6 | 7 | %access public export 8 | %default total 9 | %hide Language.Reflection.Var 10 | 11 | mutual 12 | data Cmd : List Ty -> List Ty -> Type where 13 | C : Term g a d -> CoTerm g a d -> Cmd g d 14 | 15 | data Term : List Ty -> Ty -> List Ty -> Type where 16 | Var : Elem a g -> Term g a d 17 | Mu : Cmd g (a::d) -> Term g a d 18 | MatC : Cmd (a::g) (b::d) -> Term g (a~>b) d 19 | 20 | data CoTerm : List Ty -> Ty -> List Ty -> Type where 21 | CoVal : CoValue g a d -> CoTerm g a d 22 | Mut : Cmd (a::g) d -> CoTerm g a d 23 | 24 | data CoValue : List Ty -> Ty -> List Ty -> Type where 25 | Empty : CoValue g a d 26 | CoVar : Elem a d -> CoValue g a d 27 | AppC : Term g a d -> CoValue g b d -> CoValue g (a~>b) d 28 | 29 | mutual 30 | shiftCmd : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Cmd g d -> Cmd g1 d1 31 | shiftCmd (C t e) = C (shiftTerm t) (shiftCoTerm e) 32 | 33 | shiftTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> Term g a d -> Term g1 a d1 34 | shiftTerm {is1} (Var el) = Var $ shift is1 el 35 | shiftTerm {is2} (Mu c) = Mu $ shiftCmd {is2=Cons2 is2} c 36 | shiftTerm {is1} {is2} (MatC c) = MatC $ shiftCmd {is1=Cons2 is1} {is2=Cons2 is2} c 37 | 38 | shiftCoTerm : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> CoTerm g a d -> CoTerm g1 a d1 39 | shiftCoTerm (CoVal cv) = CoVal $ shiftCoValue cv 40 | shiftCoTerm {is1} (Mut c) = Mut $ shiftCmd {is1=Cons2 is1} c 41 | 42 | shiftCoValue : {auto is1 : IsSubset g g1} -> {auto is2 : IsSubset d d1} -> CoValue g a d -> CoValue g1 a d1 43 | shiftCoValue {is2} (CoVar el) = CoVar $ shift is2 el 44 | shiftCoValue (AppC t e) = AppC (shiftTerm t) (shiftCoValue e) 45 | shiftCoValue Empty = Empty 46 | 47 | mutual 48 | subst : Cmd (a::g) d -> Term g a d -> Cmd g d 49 | subst (C t e) va = C (assert_total $ substTerm t va) (assert_total $ substCoTerm e va) 50 | 51 | substTerm : Term (a::g) c d -> Term g a d -> Term g c d 52 | substTerm (Var Here) va = va 53 | substTerm (Var (There el)) _ = Var el 54 | substTerm (Mu cmd) va = Mu $ subst (shiftCmd cmd) (shiftTerm va) 55 | substTerm (MatC cmd) va = MatC $ subst (shiftCmd cmd) (shiftTerm va) 56 | 57 | substCoTerm : CoTerm (a::g) c d -> Term g a d -> CoTerm g c d 58 | substCoTerm (CoVal v) va = CoVal $ substCoValue v va 59 | substCoTerm (Mut cmd) va = Mut $ subst (shiftCmd cmd) (shiftTerm va) 60 | 61 | substCoValue : CoValue (a::g) c d -> Term g a d -> CoValue g c d 62 | substCoValue (CoVar el) va = CoVar el 63 | substCoValue (AppC t e) va = AppC (substTerm t va) (substCoValue e va) 64 | substCoValue Empty va = Empty 65 | 66 | mutual 67 | cosubst : Cmd g (a::d) -> CoValue g a d -> Cmd g d 68 | cosubst (C t e) ct = C (assert_total $ cosubstTerm t ct) (assert_total $ cosubstCoTerm e ct) 69 | 70 | cosubstTerm : Term g c (a::d) -> CoValue g a d -> Term g c d 71 | cosubstTerm (Var el) _ = Var el 72 | cosubstTerm (Mu cmd) ct = Mu $ cosubst (shiftCmd cmd) (shiftCoValue ct) 73 | cosubstTerm (MatC cmd) ct = MatC $ cosubst (shiftCmd cmd) (shiftCoValue ct) 74 | 75 | cosubstCoTerm : CoTerm g c (a::d) -> CoValue g a d -> CoTerm g c d 76 | cosubstCoTerm (CoVal cv) ct = CoVal $ cosubstCoValue cv ct 77 | cosubstCoTerm (Mut cmd) ct = Mut $ cosubst cmd (shiftCoValue ct) 78 | 79 | cosubstCoValue : CoValue g c (a::d) -> CoValue g a d -> CoValue g c d 80 | cosubstCoValue (CoVar Here) ct = ct 81 | cosubstCoValue (CoVar (There el)) _ = CoVar el 82 | cosubstCoValue (AppC t e) ct = AppC (cosubstTerm t ct) (cosubstCoValue e ct) 83 | cosubstCoValue Empty ct = Empty 84 | 85 | reduce : Cmd g d -> Maybe (Cmd g d) 86 | reduce (C t (Mut c) ) = Just $ subst c t 87 | reduce (C (Mu c) (CoVal cv) ) = Just $ cosubst c cv 88 | reduce (C (MatC c) (CoVal (AppC t cv))) = Just $ cosubst (subst c (shiftTerm t)) (shiftCoValue cv) 89 | reduce _ = Nothing 90 | 91 | reduceIter : Cmd g d -> (Nat, Maybe (Cmd g d)) 92 | reduceIter c = loop Z c 93 | where 94 | loop : Nat -> Cmd g d -> (Nat, Maybe (Cmd g d)) 95 | loop n c1 = case reduce c1 of 96 | Nothing => (n, Just c1) 97 | Just c2 => assert_total $ loop (S n) c2 98 | 99 | --- 100 | 101 | embedTm : STLC.Term g a -> Term g a [] 102 | embedTm (Var el) = Var el 103 | embedTm (Lam t) = MatC $ C (shiftTerm $ embedTm t) (CoVal $ CoVar Here) 104 | embedTm (App t u) = Mu $ C (shiftTerm $ embedTm t) (CoVal $ AppC (shiftTerm $ embedTm u) (CoVar Here)) 105 | 106 | extractTerm : Cmd g d -> (a ** Term g a d) 107 | extractTerm (C {a} t _) = (a ** t) 108 | 109 | runLKT : STLC.Term g a -> (Nat, Maybe (b ** Term g b [])) 110 | runLKT t = 111 | let (n,r) = reduceIter $ C (embedTm t) (CoVal Empty) in 112 | (n, extractTerm <$> r) 113 | 114 | test : runLKT Term2 = (4, Just (TestTy ** embedTm Result)) 115 | test = Refl 116 | 117 | test2 : runLKT Term3 = (4, Just (TestTy ** embedTm Result)) 118 | test2 = Refl 119 | -------------------------------------------------------------------------------- /src/Lambda.idr: -------------------------------------------------------------------------------- 1 | module Lambda 2 | 3 | %access public export 4 | %default total 5 | 6 | data Term = Var Nat 7 | | Lam Term 8 | | App Term Term 9 | 10 | Term0 : Term 11 | Term0 = App (Lam $ App (Var Z) (Var Z)) (Lam $ Var Z) 12 | 13 | Term1 : Term 14 | Term1 = App (App (Lam $ Var Z) (Lam $ Var Z)) (Lam $ Var Z) 15 | 16 | Term2 : Term 17 | Term2 = App (Lam $ Var Z) (App (Lam $ Var Z) (Lam $ Var Z)) 18 | 19 | Result : Term 20 | Result = Lam $ Var Z -------------------------------------------------------------------------------- /src/List.idr: -------------------------------------------------------------------------------- 1 | module List 2 | 3 | import Data.List 4 | 5 | %access public export 6 | %default total 7 | 8 | {- 9 | data List : Type -> Type where 10 | Nil : List a -- aka [] 11 | (::) : a -> List a -> List a 12 | 13 | data Elem : a -> List a -> Type where 14 | Here : Elem x (x :: xs) 15 | There : Elem x xs -> Elem x (y :: xs) 16 | 17 | data Nat : Type where 18 | Z : Nat 19 | S : Nat -> Nat 20 | -} 21 | 22 | Subset : List a -> List a -> Type 23 | Subset {a} xs ys = {x : a} -> Elem x xs -> Elem x ys 24 | 25 | s12 : Subset [1] [2,1] 26 | s12 Here = There Here 27 | s12 (There el) = absurd el 28 | 29 | data IsSubset : List a -> List a -> Type where 30 | Id : IsSubset l l 31 | Cons2 : IsSubset l m -> IsSubset ( a::l) ( a::m) 32 | 33 | ConsR : IsSubset l m -> IsSubset l ( a::m) 34 | Swap : IsSubset l m -> IsSubset ( a::b::l) ( b::a::m) 35 | Rot : IsSubset l m -> IsSubset (a::b::c::l) (c::a::b::m) 36 | 37 | shift : IsSubset l m -> Subset l m 38 | shift Id el = el 39 | shift (Cons2 s) Here = Here 40 | shift (Cons2 s) (There el) = There $ shift s el 41 | 42 | shift (ConsR s) el = There $ shift s el 43 | shift (Swap s) Here = There Here 44 | shift (Swap s) (There Here) = Here 45 | shift (Swap s) (There (There el)) = There $ There $ shift s el 46 | shift (Rot s) Here = There Here 47 | shift (Rot s) (There Here) = There $ There Here 48 | shift (Rot s) (There (There Here)) = Here 49 | shift (Rot s) (There (There (There el))) = There $ There $ There $ shift s el 50 | -------------------------------------------------------------------------------- /src/SC.idr: -------------------------------------------------------------------------------- 1 | module SC 2 | 3 | import Data.List 4 | import List 5 | import STLC 6 | 7 | %access public export 8 | %default total 9 | 10 | data SC : List Ty -> Ty -> Type where 11 | VarS : Elem a g -> SC g a 12 | Cut : SC g a -> SC (a::g) b -> SC g b 13 | ImpL : SC g a -> SC (b::g) c -> SC ((a~>b)::g) c 14 | ImpR : SC (a::g) b -> SC g (a~>b) 15 | 16 | data LJ : List Ty -> Ty -> Type where 17 | AxJ : LJ [a] a 18 | CutJ : LJ g a -> LJ (a::g) b -> LJ g b 19 | ImpLJ : LJ g a -> LJ (b::g) c -> LJ ((a~>b)::g) c 20 | ImpRJ : LJ (a::g) b -> LJ g (a~>b) 21 | WSJ : LJ g b -> LJ (a::g) b 22 | CSJ : LJ (a::a::g) b -> LJ (a::g) b 23 | PSJ : LJ (g ++ a::b::d) c -> LJ (g ++ b::a::d) c -------------------------------------------------------------------------------- /src/STLC.idr: -------------------------------------------------------------------------------- 1 | module STLC 2 | 3 | import Data.List 4 | 5 | %access public export 6 | %default total 7 | 8 | data Ty = A | Imp Ty Ty 9 | infix 5 ~> 10 | (~>) : Ty -> Ty -> Ty 11 | (~>) = Imp 12 | 13 | data Term : List Ty -> Ty -> Type where 14 | Var : Elem a g -> Term g a 15 | Lam : Term (a::g) b -> Term g (a~>b) 16 | App : Term g (a~>b) -> Term g a -> Term g b 17 | 18 | TestTy : Ty 19 | TestTy = A ~> A 20 | 21 | -- Term1 not typeable! 22 | 23 | Term2 : Term [] TestTy 24 | Term2 = App (App (Lam $ Var Here) (Lam $ Var Here)) (Lam $ Var Here) 25 | 26 | Term3 : Term [] TestTy 27 | Term3 = App (Lam $ Var Here) (App (Lam $ Var Here) (Lam $ Var Here)) 28 | 29 | Result : Term [] TestTy 30 | Result = Lam $ Var Here --------------------------------------------------------------------------------