├── .gitignore ├── Appl.agda ├── Ask.hs ├── BellosEscape.agda ├── Bi71 ├── Basics.agda ├── Bwd.agda ├── SmolCat.agda └── Thin.agda ├── BigArray.hs ├── Bino2.agda ├── C2W.agda ├── Cats.agda ├── Circ.hs ├── CompLam.hs ├── ConCom.agda ├── CoqInterpreter.v ├── Dag.hs ├── Dagstuhl18-start.agda ├── Dagstuhl18.agda ├── DeFunct.agda ├── Diff.agda ├── EGTBS.agda ├── EWAM-Crib.agda ├── EffW.hs ├── ExampleSemantics.agda ├── FamPowSet.agda ├── Full.hs ├── Full ├── Basics.agda ├── Cat.agda ├── Pub.agda ├── Quad.agda ├── Term.agda └── TermQuad.agda ├── Hooligan.agda ├── IC.agda ├── IIIR.agda ├── Induction.agda ├── Jaco.agda ├── JacoDay.agda ├── KanGo.hs ├── Kipling.agda ├── Lenin.hs ├── MM.agda ├── Monhomie.agda ├── NBE-Monoid.agda ├── Nellist.agda ├── NormTree.hs ├── Norms.hs ├── OpTT ├── Term.hs └── Thin.hs ├── Pigeons.agda ├── ReleNorm.hs ├── Relevant.agda ├── Relevant.hs ├── STLCThin.agda ├── StackM.agda ├── T-NorB.agda ├── TakeOdd.agda ├── Time.hs ├── Tubes ├── Th.hs └── Tm.hs ├── VecApart.agda ├── VecReflect.agda ├── WTS2.agda └── Wang.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | -------------------------------------------------------------------------------- /Appl.agda: -------------------------------------------------------------------------------- 1 | module Appl where 2 | 3 | id : forall {l} {X : Set l} -> X -> X 4 | id x = x 5 | 6 | comp : forall {R S T : Set} -> (S -> T) -> (R -> S) -> R -> T 7 | comp f g r = f (g r) 8 | 9 | data _==_ {l}{X : Set l}(x : X) : X -> Set where 10 | refl : x == x 11 | {-# BUILTIN EQUALITY _==_ #-} 12 | 13 | trans : forall {l}{X : Set l}{x y z : X} -> x == y -> y == z -> x == z 14 | trans refl q = q 15 | 16 | cong : forall {l k}{X : Set l}{Y : Set k}(f : X -> Y) {x x' : X} -> x == x' -> f x == f x' 17 | cong f refl = refl 18 | 19 | record Appl (F : Set -> Set) : Set1 where 20 | field 21 | pure : {X : Set} -> X -> F X 22 | _<*>_ : {S T : Set} -> F (S -> T) -> F S -> F T 23 | homomorphism : forall {S T}(f : S -> T)(s : S) -> (pure f <*> pure s) == pure (f s) 24 | interchange : forall {S T}(fF : F (S -> T))(s : S) -> (fF <*> pure s) == (pure (\ f -> f s) <*> fF) 25 | composition : forall {R S T}(fF : F (S -> T))(gF : F (R -> S))(rF : F R) -> 26 | (fF <*> (gF <*> rF)) == (((pure comp <*> fF) <*> gF) <*> rF) 27 | identity : forall {X}(xF : F X) -> (pure id <*> xF) == xF 28 | 29 | data Bwd {l}(X : Set l) : Set l where 30 | [] : Bwd X 31 | _-,_ : Bwd X -> X -> Bwd X 32 | 33 | record One {l} : Set l where constructor <> 34 | 35 | record Sg {l}(S : Set l)(T : S -> Set l) : Set l where 36 | constructor _,_ 37 | field 38 | fst : S 39 | snd : T fst 40 | open Sg 41 | _*_ : forall {l} -> Set l -> Set l -> Set l 42 | S * T = Sg S \ _ -> T 43 | 44 | All : forall {k l}{X : Set l}(P : X -> Set k) -> Bwd X -> Set k 45 | All P [] = One 46 | All P (xz -, x) = All P xz * P x 47 | 48 | _++_ : forall {l}{X : Set l} -> Bwd X -> Bwd X -> Bwd X 49 | xz ++ [] = xz 50 | xz ++ (yz -, x) = (xz ++ yz) -, x 51 | 52 | pair : forall (Xz Yz : Bwd Set)(F : Set -> Set) -> All F Xz -> All F Yz -> All F (Xz ++ Yz) 53 | pair Xz [] F xz <> = xz 54 | pair Xz (Yz -, Y) F xz (yz , y) = pair Xz Yz F xz yz , y 55 | 56 | split : forall (Xz Yz : Bwd Set)(F : Set -> Set)(xyz : All F (Xz ++ Yz)) -> All F Xz * All F Yz 57 | split Xz [] F xyz = xyz , <> 58 | split Xz (Yz -, Y) F (xyz , y) = let xz , yz = split Xz Yz F xyz in xz , ((yz , y)) 59 | 60 | module APPL (F : Set -> Set)(AF : Appl F) where 61 | open Appl AF 62 | 63 | run : (Xz : Bwd Set) -> All F Xz -> F (All id Xz) 64 | run [] <> = pure <> 65 | run (Xz -, X) (xz , x) = (pure _,_ <*> run Xz xz) <*> x 66 | 67 | data Appl' (T : Set) : Set1 where 68 | [_] : F T -> Appl' T 69 | pure' : T -> Appl' T 70 | _<*>'_ : forall {S} -> Appl' (S -> T) -> Appl' S -> Appl' T 71 | 72 | [!_!]0 : forall {T} -> Appl' T -> F T 73 | [! [ t ] !]0 = t 74 | [! pure' t !]0 = pure t 75 | [! f <*>' s !]0 = [! f !]0 <*> [! s !]0 76 | 77 | record NormA (T : Set) : Set1 where 78 | field 79 | Types : Bwd Set 80 | report : All id Types -> T 81 | tasks : All F Types 82 | open NormA 83 | 84 | nPure : forall {X} -> X -> NormA X 85 | nPure x = record { Types = [] ; report = \ _ -> x ; tasks = <> } 86 | 87 | splap : forall Az Bz {S T : Set} -> (All id Az -> S -> T) -> (All id Bz -> S) -> All id (Az ++ Bz) -> T 88 | splap Az Bz f s abz = let az , bz = split Az Bz id abz in f az (s bz) 89 | 90 | nApply : forall {S T} -> NormA (S -> T) -> NormA S -> NormA T 91 | nApply (record { Types = fAz ; report = f ; tasks = az }) record { Types = sBz ; report = s ; tasks = bz } = 92 | record { Types = fAz ++ sBz ; report = splap fAz sBz f s ; tasks = pair fAz sBz _ az bz } 93 | 94 | nOne : forall {T} -> F T -> NormA T 95 | nOne t = record { Types = [] -, _ ; report = snd ; tasks = <> , t } 96 | 97 | [!_!]N : forall {T} -> NormA T -> F T 98 | [! record { Types = Xz ; report = t ; tasks = xz } !]N = pure t <*> run Xz xz 99 | 100 | [!_!]1 : forall {T} -> Appl' T -> NormA T 101 | [! [ t' ] !]1 = nOne t' 102 | [! pure' t !]1 = nPure t 103 | [! f' <*>' s' !]1 = nApply [! f' !]1 [! s' !]1 104 | 105 | pc : forall {R S T} -> (f : S -> T)(gF : F (R -> S))(rF : F R) -> 106 | (pure f <*> (gF <*> rF)) == ((pure (comp f) <*> gF) <*> rF) 107 | pc {R}{S}{T} f gF rF rewrite composition (pure f) gF rF 108 | | homomorphism {S -> T}{(R -> S) -> R -> T} comp f = refl 109 | 110 | ppc : forall {R S T} -> (f : S -> T)(g : R -> S)(rF : F R) -> 111 | (pure f <*> (pure g <*> rF)) == (pure (comp f g) <*> rF) 112 | ppc {R}{S}{T} f g rF rewrite pc f (pure g) rF | homomorphism (comp f) g = refl 113 | 114 | lemma : forall {S T} Az Bz (f : All id Az -> S -> T)(aFz : All F Az)(s : All id Bz -> S)(bFz : All F Bz) -> 115 | ((pure f <*> run Az aFz) <*> (pure s <*> run Bz bFz)) == 116 | (pure (splap Az Bz f s) <*> run (Az ++ Bz) (pair Az Bz F aFz bFz)) 117 | lemma Az [] f aFz s <> 118 | rewrite homomorphism s <> 119 | | interchange (pure f <*> run Az aFz) (s <>) 120 | | pc (\ f -> f (s <>)) (pure f) (run Az aFz) 121 | | homomorphism (\ g r -> g r (s <>)) f 122 | = refl 123 | lemma {S}{T} Az (Bz -, B) f aFz s (bFz , b) 124 | rewrite pc (splap Az (Bz -, B) f s) (pure _,_ <*> run (Az ++ Bz) (pair Az Bz F aFz bFz)) b 125 | | ppc (comp (splap Az (Bz -, B) f s)) _,_ (run (Az ++ Bz) (pair Az Bz F aFz bFz)) 126 | | pc s (pure _,_ <*> run Bz bFz) b 127 | | composition (pure f <*> run Az aFz) (pure (comp s) <*> (pure _,_ <*> run Bz bFz)) b 128 | | ppc (comp s) _,_ (run Bz bFz) 129 | | ppc {All id Az}{S -> T}{(B -> S) -> B -> T} comp f (run Az aFz) 130 | | lemma Az Bz (comp comp f) aFz (comp (comp s) _,_) bFz 131 | = refl 132 | 133 | claim : forall {T}(a : Appl' T) -> [! a !]0 == [! [! a !]1 !]N 134 | claim {T} [ t ] rewrite homomorphism {One}{T -> _} _,_ <> 135 | | composition {T}{One * T}{T} (pure snd) (pure (_,_ <>)) t 136 | | homomorphism {One * T -> T}{(T -> One * T) -> _} comp snd 137 | | homomorphism {T -> One * T}{T -> T} (comp snd) (_,_ <>) 138 | | identity t = refl 139 | claim (pure' t) rewrite homomorphism {One}{_} (\ _ -> t) <> = refl 140 | claim (f' <*>' s') rewrite claim f' | claim s' = lemma (Types [! f' !]1) (Types [! s' !]1) (report [! f' !]1) (tasks [! f' !]1) (report [! s' !]1) (tasks [! s' !]1) 141 | 142 | solver : forall {T}(a b : Appl' T) -> [! a !]1 == [! b !]1 -> [! a !]0 == [! b !]0 143 | solver a b q rewrite claim a | claim b | q = refl 144 | 145 | -------------------------------------------------------------------------------- /BellosEscape.agda: -------------------------------------------------------------------------------- 1 | mutual 2 | 3 | record InfOft (A B : Set) : Set where 4 | coinductive 5 | constructor [_] 6 | field 7 | gimme : InfOftEra A B 8 | 9 | data InfOftEra (A B : Set) : Set where 10 | _!-_ : A -> InfOft A B -> InfOftEra A B 11 | _,-_ : B -> InfOftEra A B -> InfOftEra A B 12 | 13 | open InfOft 14 | 15 | data Nat : Set where 16 | ze : Nat 17 | su : Nat -> Nat 18 | {-# BUILTIN NATURAL Nat #-} 19 | 20 | data LeftOf (X : Nat -> Set) : Nat -> Set where 21 | [] : LeftOf X ze 22 | _<_ : forall {n} -> LeftOf X n -> X n -> LeftOf X (su n) 23 | infixl 5 _<_ 24 | 25 | record RightFrom (X : Nat -> Set)(i : Nat) : Set where 26 | coinductive 27 | constructor _>_ 28 | field 29 | here : X i 30 | right : RightFrom X (su i) 31 | open RightFrom 32 | infixr 5 _>_ 33 | 34 | data Zero : Set where 35 | record One : Set where constructor <> 36 | 37 | IsSu : Nat -> Set 38 | IsSu ze = Zero 39 | IsSu (su n) = One 40 | 41 | record Sg (S : Set)(T : S -> Set) : Set where 42 | constructor _,_ 43 | field 44 | fst : S 45 | snd : T fst 46 | open Sg 47 | _*_ : Set -> Set -> Set 48 | S * T = Sg S \ _ -> T 49 | infixr 4 _,_ _*_ 50 | 51 | Signal : Nat -> Set 52 | Signal i = InfOft One (IsSu i) 53 | 54 | Position : Set 55 | Position = Sg Nat \ i -> LeftOf Signal i * RightFrom Signal i 56 | 57 | step : Position -> Position 58 | step' : forall i -> LeftOf Signal i -> InfOftEra One (IsSu i) -> RightFrom Signal (su i) -> Position 59 | step (i , ls , hrs) with here hrs | right hrs 60 | ... | h | rs with gimme h 61 | step (i , ls , hrs) | h | rs | hi = step' i ls hi rs 62 | step' i ls (x !- h') rs = su i , ls < h' , rs 63 | step' .0 [] (() ,- hi) rs 64 | step' .(su _) (ls < l) (<> ,- hi') rs = _ , ls , l > [ hi' ] > rs 65 | 66 | data _~~>_ (p : Position) : Position -> Set where 67 | stop : p ~~> p 68 | go_ : forall {p'} -> step p ~~> p' -> p ~~> p' 69 | infixr 5 go_ 70 | 71 | _++_ : forall {p0 p1 p2 : Position} -> p0 ~~> p1 -> p1 ~~> p2 -> p0 ~~> p2 72 | stop ++ qs = qs 73 | (go ps) ++ qs = go (ps ++ qs) 74 | infixr 5 _++_ 75 | 76 | the : (X : Set) -> X -> X 77 | the X x = x 78 | 79 | lemma : forall n ls hrs -> Sg _ \ ls' -> step (n , ls , hrs) ~~> (su n , ls' , right hrs) 80 | lemma n ls hrs with here hrs | right hrs 81 | ... | h | r with gimme h 82 | lemma n ls hrs | h | rs | hi = help n ls hi rs where 83 | help : forall n (ls : LeftOf (λ i → InfOft One (IsSu i)) n) 84 | (hi : InfOftEra One (IsSu n)) 85 | (rs : RightFrom Signal (su n)) -> 86 | Sg _ \ ls' -> step' n ls hi rs ~~> (su n , ls' , rs) 87 | help n ls (<> !- h') rs = _ , stop 88 | help .0 [] (() ,- hi) rs 89 | help .(su _) (ls < l) (<> ,- hi) rs with help _ ls (gimme l) ([ hi ] > rs) 90 | ... | ls' , ps with help _ ls' hi rs 91 | ... | ls'' , qs = _ , go ps ++ go qs 92 | -------------------------------------------------------------------------------- /Bi71/Basics.agda: -------------------------------------------------------------------------------- 1 | module Basics where 2 | 3 | id : forall {l}{X : Set l} -> X -> X 4 | id x = x 5 | 6 | _-_ : forall {i j k}{A : Set i}{B : A -> Set j}{C : (a : A) -> B a -> Set k} 7 | (f : (a : A) -> B a) 8 | (g : {a : A}(b : B a) -> C a b) 9 | (a : A) -> 10 | C a (f a) 11 | (f - g) a = g (f a) 12 | 13 | data Zero : Set where 14 | record One : Set where constructor <> 15 | data Two : Set where ff tt : Two 16 | 17 | record _><_ (S : Set)(T : S -> Set) : Set where 18 | constructor _,_ 19 | field 20 | fst : S 21 | snd : T fst 22 | open _><_ public 23 | _+_ _*_ : Set -> Set -> Set 24 | S + T = Two >< \ { ff -> S ; tt -> T } 25 | S * T = S >< \ _ -> T 26 | pattern !_ t = _ , t 27 | pattern _^_ s t = ! s , t 28 | infixr 20 _+_ 29 | infixr 30 _,_ _><_ _*_ !_ 30 | infixr 31 _^_ 31 | 32 | module _ {X : Set} where 33 | _+:_ _*:_ _-:>_ : (X -> Set) -> (X -> Set) -> (X -> Set) 34 | (S +: T) x = S x + T x 35 | (S *: T) x = S x * T x 36 | (S -:> T) x = S x -> T x 37 | 38 | [_] <_> : (X -> Set) -> Set 39 | [ P ] = forall {x} -> P x 40 | < P > = X >< P 41 | infix 5 [_] <_> 42 | infixr 10 _-:>_ 43 | infixr 20 _+:_ 44 | infixr 30 _*:_ 45 | 46 | data _~_ {X : Set}(x : X) : X -> Set where 47 | r~ : x ~ x 48 | {-# BUILTIN EQUALITY _~_ #-} 49 | 50 | 51 | _>!<_ : (S : Set)(T : S -> Set) -> Set 52 | S >!< T = S >< \ s -> T s * ((x : S) -> T x -> x ~ s) 53 | 54 | -------------------------------------------------------------------------------- /Bi71/Bwd.agda: -------------------------------------------------------------------------------- 1 | module Bwd where 2 | 3 | open import Basics 4 | 5 | data Bwd (X : Set) : Set where 6 | [] : Bwd X 7 | _-,_ : Bwd X -> X -> Bwd X 8 | 9 | infixl 50 _-,_ 10 | 11 | Nat = Bwd One 12 | -------------------------------------------------------------------------------- /Bi71/SmolCat.agda: -------------------------------------------------------------------------------- 1 | module SmolCat where 2 | 3 | open import Basics 4 | 5 | record Cat {O : Set}(A : O -> O -> Set) : Set1 where 6 | field 7 | iden : forall {o} -> A o o 8 | [_&_]~_ : forall {R S T} -> A R S -> A S T -> A R T -> Set 9 | tri : forall {R S T}(f : A R S)(g : A S T) -> < [ f & g ]~_ > 10 | triq : forall {R S T}{f : A R S}{g : A S T}(v w : < [ f & g ]~_ >) -> v ~ w 11 | idTri : forall {S T}(f : A S T) -> [ iden & f ]~ f 12 | triId : forall {S T}(f : A S T) -> [ f & iden ]~ f 13 | ass03 : forall {X0 X1 X2 X3} 14 | {f01 : A X0 X1}{f02 : A X0 X2}{f23 : A X2 X3}{f13 : A X1 X3} 15 | -> < [ f01 &_]~ f02 *: [_& f23 ]~ f13 > 16 | -> < [ f01 & f13 ]~_ *: [ f02 & f23 ]~_ > 17 | infix 45 [_&_]~_ 18 | ass02 : forall {X0 X1 X2 X3} 19 | {f01 : A X0 X1}{f03 : A X0 X3}{f12 : A X1 X2}{f23 : A X2 X3} 20 | -> < [ f01 &_]~ f03 *: [ f12 & f23 ]~_ > 21 | -> < [ f01 & f12 ]~_ *: [_& f23 ]~ f03 > 22 | ass02 {f01 = f01}{f03}{f12}{f23} (v013 ^ v123) 23 | with f02 , v012 <- tri f01 f12 24 | | w013 ^ v023 <- ass03 (v012 ^ v123) 25 | | r~ <- triq (! v013) (! w013) 26 | = v012 ^ v023 27 | ass13 : forall {X0 X1 X2 X3} 28 | {f01 : A X0 X1}{f03 : A X0 X3}{f12 : A X1 X2}{f23 : A X2 X3} 29 | -> < [ f01 & f12 ]~_ *: [_& f23 ]~ f03 > 30 | -> < [ f01 &_]~ f03 *: [ f12 & f23 ]~_ > 31 | ass13 {f01 = f01}{f03}{f12}{f23} (v012 ^ v023) 32 | with f13 , v123 <- tri f12 f23 33 | | v013 ^ w023 <- ass03 (v012 ^ v123) 34 | | r~ <- triq (! v023) (! w023) 35 | = v013 ^ v123 36 | 37 | module _ {X : Set}{A : X -> X -> Set}(C : Cat A) 38 | {Y : Set}{B : Y -> Y -> Set}(D : Cat B) 39 | where 40 | open Cat 41 | record Fun : Set where 42 | field 43 | fobj : X -> Y 44 | farr : forall {S T : X} -> A S T -> B (fobj S) (fobj T) 45 | fidq : (S : X) -> farr (iden C {S}) ~ iden D {fobj S} 46 | fcot : forall {R S T : X}{f : A R S}{g : A S T}{h : A R T} 47 | -> [_&_]~_ C f g h -> [_&_]~_ D (farr f) (farr g) (farr h) 48 | 49 | module _ {O : Set}{A : O -> O -> Set} where 50 | open Cat 51 | _^op : Cat A -> Cat \ S T -> A T S 52 | iden (C ^op) = iden C 53 | [_&_]~_ (C ^op) f g h = [_&_]~_ C g f h 54 | tri (C ^op) f g = tri C g f 55 | triq (C ^op) v w = triq C v w 56 | idTri (C ^op) = triId C 57 | triId (C ^op) = idTri C 58 | ass03 (C ^op) (v ^ w) = let w' ^ v' = ass03 C (w ^ v) in v' ^ w' 59 | 60 | module _ (X : Set) where 61 | open Cat 62 | Disc : Cat {X} _~_ 63 | iden Disc = r~ 64 | [_&_]~_ Disc _ _ _ = One 65 | tri Disc r~ q = q , <> 66 | triq Disc (r~ , <>) (r~ , <>) = r~ 67 | idTri Disc = _ 68 | triId Disc = _ 69 | ass03 Disc {f01 = r~}{f02 = r~}{f23 = r~} _ = r~ , _ 70 | 71 | module _ {O : Set}{A : O -> O -> Set}(C : Cat A) where 72 | 73 | module _ where 74 | open Cat C 75 | data ConeObj : Set where 76 | limit : ConeObj 77 | copy : O -> ConeObj 78 | data ConeArr : ConeObj -> ConeObj -> Set where 79 | limit : (o : ConeObj) -> ConeArr limit o 80 | copy : forall {S T} -> A S T -> ConeArr (copy S) (copy T) 81 | data ConeTri : forall {R S T} -> ConeArr R S -> ConeArr S T -> ConeArr R T -> Set where 82 | copy : forall {R S T}{f : A R S}{g : A S T}{h : A R T} -> [ f & g ]~ h 83 | -> ConeTri (copy f) (copy g) (copy h) 84 | limit : forall {S T}(f : ConeArr S T) 85 | -> ConeTri (limit S) f (limit T) 86 | open Cat 87 | Cone : Cat ConeArr 88 | iden Cone {limit} = limit limit 89 | iden Cone {copy x} = copy (iden C {x}) 90 | [_&_]~_ Cone = ConeTri 91 | tri Cone (limit o) g = ! limit g 92 | tri Cone (copy f) (copy g) = let ! v = tri C f g in ! copy v 93 | triq Cone (! copy v) (! copy w) with r~ <- triq C (! v) (! w) = r~ 94 | triq Cone (! limit f) (! limit .f) = r~ 95 | idTri Cone (limit o) = limit (limit o) 96 | idTri Cone (copy f) = copy (idTri C f) 97 | triId Cone (limit o) = limit (iden Cone) 98 | triId Cone (copy f) = copy (triId C f) 99 | ass03 Cone (copy v ^ copy w) = let v' ^ w' = ass03 C (v ^ w) in copy v' ^ copy w' 100 | ass03 Cone (limit _ ^ _) = limit _ ^ limit _ 101 | 102 | module _ {X : Set}{A : X -> X -> Set}{C : Cat A} 103 | {Y : Set}{B : Y -> Y -> Set}{D : Cat B} 104 | (F : Fun C D) 105 | where 106 | open Cat 107 | open Fun 108 | module _ where 109 | record ConeExt : Set where 110 | field 111 | limObj : Y 112 | limArr : (x : X) -> B limObj (fobj F x) 113 | limTri : forall {s t : X}(f : A s t) 114 | -> [_&_]~_ D (limArr s) (farr F f) (limArr t) 115 | ExtF : Fun (Cone C) D 116 | fobj ExtF limit = limObj 117 | fobj ExtF (copy x) = fobj F x 118 | farr ExtF (limit limit) = iden D 119 | farr ExtF (limit (copy x)) = limArr x 120 | farr ExtF (copy f) = farr F f 121 | fidq ExtF limit = r~ 122 | fidq ExtF (copy x) = fidq F x 123 | fcot ExtF (copy v) = fcot F v 124 | fcot ExtF (limit (limit o)) = idTri D _ 125 | fcot ExtF (limit (copy f)) = limTri f 126 | open ConeExt public 127 | record Limit : Set where 128 | field 129 | best : ConeExt 130 | factor : (c : ConeExt) -> 131 | B (limObj c) (limObj best) >!< \ f -> 132 | (x : X) -> [_&_]~_ D f (limArr best x) (limArr c x) 133 | open Limit public 134 | 135 | module _ {X : Set}{A : X -> X -> Set}(C : Cat A) where 136 | open Cat C 137 | open Fun 138 | Pair : X -> X -> Fun (Disc Two) C 139 | fobj (Pair S T) ff = S 140 | fobj (Pair S T) tt = T 141 | farr (Pair S T) {ff} r~ = iden 142 | farr (Pair S T) {tt} r~ = iden 143 | fidq (Pair S T) ff = r~ 144 | fidq (Pair S T) tt = r~ 145 | fcot (Pair S T) {ff} {f = r~} {g = r~} {h = r~} = \ _ -> idTri iden 146 | fcot (Pair S T) {tt} {f = r~} {g = r~} {h = r~} = \ _ -> idTri iden 147 | 148 | Products : Set 149 | Products = (S T : X) -> Limit (Pair S T) 150 | 151 | module _ {X : Set}{_=>_ : X -> X -> Set}(C : Cat _=>_)(x : X) where 152 | open Cat C 153 | _//_ : Cat {< _=> x >}(\ (! f) (! g) -> < [_& g ]~ f > ) 154 | Cat.iden _//_ = ! idTri _ 155 | Cat.[_&_]~_ _//_ (f , _) (g , _) (h , _) = [ f & g ]~ h 156 | Cat.tri _//_ (f , v) (g , w) = let h , x , y = ass02 (v ^ w) in (h , y) , x 157 | Cat.triq _//_ ((f , v) , x) ((g , w) , y) 158 | with r~ <- triq (! x) (! y) 159 | | r~ <- triq (! v) (! w) 160 | = r~ 161 | Cat.idTri _//_ (f , _) = idTri f 162 | Cat.triId _//_ (f , _) = triId f 163 | Cat.ass03 _//_ {X0 , f0}{X1 , f1}{X2 , f2}{X3 , f3} 164 | {g01 , v01}{g02 , v02}{g23 , v23}{g13 , v13} 165 | ((g12 , v12) , v012 , v123) 166 | with g03 , v012 , v023 <- ass03 (v012 ^ v123) 167 | | w01 ^ w <- ass03 (v012 ^ v13) 168 | | r~ <- triq (! v01) (! w01) 169 | = (g03 , w) , v012 , v023 170 | 171 | module _ {X : Set}{_=>_ : X -> X -> Set} where 172 | _\\_ : (C : Cat _=>_)(x : X) 173 | -> Cat {< x =>_ >} (\ (! f) (! g) -> _ >< \ h -> Cat.[_&_]~_ C f h g) 174 | C \\ x = ((C ^op) // x) ^op 175 | 176 | -------------------------------------------------------------------------------- /Bi71/Thin.agda: -------------------------------------------------------------------------------- 1 | module Thin where 2 | 3 | open import Basics 4 | open import Bwd 5 | open import SmolCat 6 | 7 | module _ {X : Set} where 8 | 9 | infix 40 _<=_ 10 | infixl 50 _-^_ _-^,_ 11 | data _<=_ : Bwd X -> Bwd X -> Set where 12 | _-^_ : forall {ga de : Bwd X} -> ga <= de -> forall y -> ga <= de -, y 13 | _-,_ : forall {ga de : Bwd X} -> ga <= de -> forall x -> ga -, x <= de -, x 14 | [] : [] <= [] 15 | 16 | infix 40 [_<&_]~_ 17 | data [_<&_]~_ : forall {ga de xi} -> ga <= de -> de <= xi -> ga <= xi -> Set where 18 | _-^_ : forall {ga de xi}{th : ga <= de}{ph : de <= xi}{ps : ga <= xi} 19 | -> [ th <& ph ]~ ps -> forall x 20 | -> [ th <& ph -^ x ]~ ps -^ x 21 | _-^,_ : forall {ga de xi}{th : ga <= de}{ph : de <= xi}{ps : ga <= xi} 22 | -> [ th <& ph ]~ ps -> forall x 23 | -> [ th -^ x <& ph -, x ]~ ps -^ x 24 | _-,_ : forall {ga de xi}{th : ga <= de}{ph : de <= xi}{ps : ga <= xi} 25 | -> [ th <& ph ]~ ps -> forall x 26 | -> [ th -, x <& ph -, x ]~ ps -, x 27 | [] : [ [] <& [] ]~ [] 28 | 29 | inj : forall {ga de xi}{ph : de <= xi}{ps : ga <= xi} 30 | (p q : < [_<& ph ]~ ps >) -> p ~ q 31 | inj (! v -^ x) (! w -^ .x) with r~ <- inj (! v) (! w) = r~ 32 | inj (! v -^, x) (! w -^, .x) with r~ <- inj (! v) (! w) = r~ 33 | inj (! (v -, x)) (! (w -, .x)) with r~ <- inj (! v) (! w) = r~ 34 | inj (! []) (! []) = r~ 35 | 36 | open Cat 37 | THIN : Cat _<=_ 38 | iden THIN {[]} = [] 39 | iden THIN {ga -, x} = iden THIN {ga} -, x 40 | [_&_]~_ THIN = [_<&_]~_ 41 | tri THIN th (ph -^ y) = let ! v = tri THIN th ph in ! v -^ y 42 | tri THIN (th -^ .x) (ph -, x) = let ! v = tri THIN th ph in ! v -^, x 43 | tri THIN (th -, .x) (ph -, x) = let ! v = tri THIN th ph in ! v -, x 44 | tri THIN [] [] = ! [] 45 | triq THIN (! v -^ x) (! w -^ .x) with r~ <- triq THIN (! v) (! w) = r~ 46 | triq THIN (! v -^, x) (! w -^, .x) with r~ <- triq THIN (! v) (! w) = r~ 47 | triq THIN (! v -, x) (! w -, .x) with r~ <- triq THIN (! v) (! w) = r~ 48 | triq THIN (! [] ) (! [] ) = r~ 49 | idTri THIN (th -^ y) = idTri THIN th -^ y 50 | idTri THIN (th -, x) = idTri THIN th -, x 51 | idTri THIN [] = [] 52 | triId THIN (th -^ y) = triId THIN th -^, y 53 | triId THIN (th -, x) = triId THIN th -, x 54 | triId THIN [] = [] 55 | ass03 THIN (v ^ w -^ x ) with v' ^ w' <- ass03 THIN (v ^ w) = v' -^ x ^ w' -^ x 56 | ass03 THIN (v -^ .x ^ w -^, x) with v' ^ w' <- ass03 THIN (v ^ w) = v' -^ x ^ w' -^, x 57 | ass03 THIN (v -^, .x ^ w -, x ) with v' ^ w' <- ass03 THIN (v ^ w) = v' -^, x ^ w' -^, x 58 | ass03 THIN (v -, .x ^ w -, x ) with v' ^ w' <- ass03 THIN (v ^ w) = v' -, x ^ w' -, x 59 | ass03 THIN ( [] ^ [] ) = [] ^ [] 60 | 61 | infix 45 _/u\_ 62 | infixl 50 _-,^_ 63 | data _/u\_ : forall {ga} 64 | {ga0}(th0 : ga0 <= ga) 65 | {ga1}(th1 : ga1 <= ga) 66 | -> Set where 67 | _-^,_ : forall {ga} 68 | {ga0}{th0 : ga0 <= ga} 69 | {ga1}{th1 : ga1 <= ga} 70 | -> th0 /u\ th1 -> forall x 71 | -> th0 -^ x /u\ th1 -, x 72 | _-,^_ : forall {ga} 73 | {ga0}{th0 : ga0 <= ga} 74 | {ga1}{th1 : ga1 <= ga} 75 | -> th0 /u\ th1 -> forall x 76 | -> th0 -, x /u\ th1 -^ x 77 | _-,_ : forall {ga} 78 | {ga0}{th0 : ga0 <= ga} 79 | {ga1}{th1 : ga1 <= ga} 80 | -> th0 /u\ th1 -> forall x 81 | -> th0 -, x /u\ th1 -, x 82 | [] : [] /u\ [] 83 | 84 | cop : forall {ga} 85 | {ga0}(ph0 : ga0 <= ga) 86 | {ga1}(ph1 : ga1 <= ga) -> 87 | (< ga0 <=_ *: ga1 <=_ >) >< \ (th0 ^ th1) -> 88 | th0 /u\ th1 * (< [ th0 <&_]~ ph0 *: [ th1 <&_]~ ph1 >) 89 | cop (ph0 -^ y) (ph1 -^ .y) = 90 | let ! u , v ^ w = cop ph0 ph1 in ! u , v -^ y ^ w -^ y 91 | cop (ph0 -^ y) (ph1 -, .y) = 92 | let ! u , v ^ w = cop ph0 ph1 in ! u -^, y , v -^, y ^ w -, y 93 | cop (ph0 -, x) (ph1 -^ .x) = 94 | let ! u , v ^ w = cop ph0 ph1 in ! u -,^ x , v -, x ^ w -^, x 95 | cop (ph0 -, x) (ph1 -, .x) = 96 | let ! u , v ^ w = cop ph0 ph1 in ! u -, x , v -, x ^ w -, x 97 | cop [] [] = ! [] , [] ^ [] 98 | 99 | copU : forall {ga} 100 | {ga0}{ph0 : ga0 <= ga} 101 | {ga1}{ph1 : ga1 <= ga} -> 102 | {(th0 ^ th1) : < ga0 <=_ *: ga1 <=_ >} -> 103 | th0 /u\ th1 -> 104 | ((th , _) : < [ th0 <&_]~ ph0 *: [ th1 <&_]~ ph1 >) -> 105 | {(ps0 ^ ps1) : < ga0 <=_ *: ga1 <=_ >} -> 106 | ((ps , _) : < [ ps0 <&_]~ ph0 *: [ ps1 <&_]~ ph1 >) -> 107 | < [ th0 <&_]~ ps0 *: [_<& ps ]~ th *: [ th1 <&_]~ ps1 > 108 | copU u (v -^ _ ^ w -^ _) (x -^ _ ^ y -^ _) 109 | = let ! a , b , c = copU u (v ^ w) (x ^ y) in ! a , b -^ _ , c 110 | copU u (v -^ _ ^ w -^ _) (x -^, _ ^ y -^, _) 111 | = let ! a , b , c = copU u (v ^ w) (x ^ y) in ! a -^ _ , b -^, _ , c -^ _ 112 | copU (u -^, _) (v -^, _ ^ w -, _) (x -^, _ ^ y -, _) 113 | = let ! a , b , c = copU u (v ^ w) (x ^ y) in ! a -^, _ , b -, _ , c -, _ 114 | copU (u -,^ _) (v -, _ ^ w -^, _) (x -, _ ^ y -^, _) 115 | = let ! a , b , c = copU u (v ^ w) (x ^ y) in ! a -, _ , b -, _ , c -^, _ 116 | copU (u -, _) (v -, _ ^ w -, _) (x -, _ ^ y -, _) 117 | = let ! a , b , c = copU u (v ^ w) (x ^ y) in ! a -, _ , b -, _ , c -, _ 118 | copU u ([] ^ []) ([] ^ []) = ! [] , [] , [] 119 | 120 | data Pub : forall {de ga}{(th0 ^ ph0) (th1 ^ ph1) : < de <=_ *: _<= ga >} 121 | -> < [ th0 <& ph0 ]~_ *: [ th1 <& ph1 ]~_ > -> Set where 122 | _-^_ : forall {de ga}{(th0 ^ ph0) (th1 ^ ph1) : < de <=_ *: _<= ga >} 123 | {(v ^ w) : < [ th0 <& ph0 ]~_ *: [ th1 <& ph1 ]~_ >} -> 124 | Pub (v ^ w) -> forall x -> Pub (v -^ x ^ w -^ x) 125 | _-^,_ : forall {de ga}{(th0 ^ ph0) (th1 ^ ph1) : < de <=_ *: _<= ga >} 126 | {(v ^ w) : < [ th0 <& ph0 ]~_ *: [ th1 <& ph1 ]~_ >} -> 127 | Pub (v ^ w) -> forall x -> Pub (v -^ x ^ w -^, x) 128 | _-,^_ : forall {de ga}{(th0 ^ ph0) (th1 ^ ph1) : < de <=_ *: _<= ga >} 129 | {(v ^ w) : < [ th0 <& ph0 ]~_ *: [ th1 <& ph1 ]~_ >} -> 130 | Pub (v ^ w) -> forall x -> Pub (v -^, x ^ w -^ x) 131 | _-,_ : forall {de ga}{(th0 ^ ph0) (th1 ^ ph1) : < de <=_ *: _<= ga >} 132 | {(v ^ w) : < [ th0 <& ph0 ]~_ *: [ th1 <& ph1 ]~_ >} -> 133 | Pub (v ^ w) -> forall x -> Pub (v -, x ^ w -, x) 134 | [] : Pub ([] ^ []) 135 | 136 | pub : forall {ga0 ga1 ga}(ph0 : ga0 <= ga)(ph1 : ga1 <= ga) -> 137 | < _<= ga0 *: _<= ga1 > >< \ (th0 ^ th1) -> 138 | < [ th0 <& ph0 ]~_ *: [ th1 <& ph1 ]~_ > >< Pub 139 | pub (ph0 -^ y) (ph1 -^ .y) = let ! ! p = pub ph0 ph1 in ! ! p -^ y 140 | pub (ph0 -^ y) (ph1 -, .y) = let ! ! p = pub ph0 ph1 in ! ! p -^, y 141 | pub (ph0 -, x) (ph1 -^ .x) = let ! ! p = pub ph0 ph1 in ! ! p -,^ x 142 | pub (ph0 -, x) (ph1 -, .x) = let ! ! p = pub ph0 ph1 in ! ! p -, x 143 | pub [] [] = ! ! [] 144 | 145 | pubU : forall {de ga}{(th0 ^ ph0) (th1 ^ ph1) : < de <=_ *: _<= ga >} 146 | -> {p@(th , _) : < [ th0 <& ph0 ]~_ *: [ th1 <& ph1 ]~_ >} 147 | -> Pub p 148 | -> forall {(ps0 ^ ps1) : < _<= _ *: _<= _ >} 149 | -> ((ps , _) : < [ ps0 <& ph0 ]~_ *: [ ps1 <& ph1 ]~_ >) 150 | -> < [_<& th0 ]~ ps0 *: [_<& th ]~ ps *: [_<& th1 ]~ ps1 > 151 | pubU (p -^ _) (x -^ _ ^ y -^ _) = 152 | let ! a , b , c = pubU p (x ^ y) in ! a , b -^ _ , c 153 | pubU (p -^, _) (x -^ _ ^ y -^, _) = 154 | let ! a , b , c = pubU p (x ^ y) in ! a , b -^ _ , c -^ _ 155 | pubU (p -,^ _) (x -^, _ ^ y -^ _) = 156 | let ! a , b , c = pubU p (x ^ y) in ! a -^ _ , b -^ _ , c 157 | pubU (p -, _) (x -^, _ ^ y -^, _) = 158 | let ! a , b , c = pubU p (x ^ y) in ! a -^, _ , b -^, _ , c -^, _ 159 | pubU (p -, _) (x -, _ ^ y -, _) = 160 | let ! a , b , c = pubU p (x ^ y) in ! a -, _ , b -, _ , c -, _ 161 | pubU [] ([] ^ []) = ! [] , [] , [] 162 | 163 | module _ (ga : Bwd X) where 164 | 165 | UNION : Products ((THIN ^op) \\ ga) 166 | UNION (! ph0) (! ph1) = let ! u , v ^ w = cop ph0 ph1 in record 167 | { best = record 168 | { limArr = \ { ff -> ! v ; tt -> ! w } 169 | ; limTri = \ { {ff} r~ -> idTri THIN _ ; {tt} r~ -> idTri THIN _ } 170 | } 171 | ; factor = \ c -> 172 | let ps , a , b , c = 173 | copU u (v ^ w) (snd (limArr c ff) ^ snd (limArr c tt)) 174 | in (ps , b) , (\ { ff -> a ; tt -> c }) 175 | , \ z _ -> inj z (! b) 176 | } 177 | 178 | INTERSECTION : Products (THIN // ga) 179 | INTERSECTION (! ph0) (! ph1) = let ! (v ^ w) , p = pub ph0 ph1 in record 180 | { best = record 181 | { limArr = \ { ff -> ! v ; tt -> ! w } 182 | ; limTri = \ { {ff} r~ -> triId THIN _ ; {tt} r~ -> triId THIN _ } 183 | } 184 | ; factor = \ c -> 185 | let ps , a , b , c = pubU p (snd (limArr c ff) ^ snd (limArr c tt)) 186 | in (ps , b) , (\ { ff -> a ; tt -> c }) , \ z _ -> inj z (! b) 187 | } 188 | -------------------------------------------------------------------------------- /BigArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, StandaloneDeriving, RankNTypes, 2 | TypeSynonymInstances #-} 3 | 4 | module BigArray where 5 | 6 | import Data.Monoid 7 | import Control.Applicative 8 | import Data.Functor.Identity 9 | 10 | data Nat = Ze | Su Nat 11 | 12 | data Bnd k = Bot | Key k | Top deriving (Ord, Eq, Show) 13 | 14 | data T23 (n :: Nat) (k :: *) (v :: *) where 15 | Leaf :: T23 Ze k v 16 | Node2 :: T23 n k v -> (k, v) -> T23 n k v -> T23 (Su n) k v 17 | Node3 :: T23 n k v -> (k, v) -> T23 n k v -> (k, v) -> T23 n k v -> T23 (Su n) k v 18 | deriving instance (Show k, Show v) => Show (T23 n k v) 19 | 20 | instance Functor (T23 n k) where 21 | fmap f Leaf = Leaf 22 | fmap f (Node2 l (k, v) r) = Node2 (fmap f l) (k, f v) (fmap f r) 23 | fmap f (Node3 l (j, u) m (k, v) r) = 24 | Node3 (fmap f l) (j, f u) (fmap f m) (k, f v) (fmap f r) 25 | 26 | data I23 n k v where 27 | Level :: T23 n k v -> I23 n k v 28 | Grow2 :: T23 n k v -> (k, v) -> T23 n k v -> I23 n k v 29 | 30 | find23 :: Ord k => k -> T23 n k v -> Maybe v 31 | find23 k Leaf = Nothing 32 | find23 k (Node2 lj (j, jv) ju) = case compare k j of 33 | LT -> find23 k lj 34 | EQ -> Just jv 35 | GT -> find23 k ju 36 | find23 k (Node3 li (i, iv) ij (j, jv) ju) = case (compare k i, compare k j) of 37 | (LT, _) -> find23 k li 38 | (EQ, _) -> Just iv 39 | (_, LT) -> find23 k ij 40 | (_, EQ) -> Just jv 41 | (_, GT) -> find23 k ju 42 | 43 | insert23 :: Ord k => (k, v) -> T23 n k v -> I23 n k v 44 | insert23 iv Leaf = Grow2 Leaf iv Leaf 45 | insert23 iv@(i, _) (Node2 lj jv@(j, _) ju) = 46 | case compare i j of 47 | LT -> case insert23 iv lj of 48 | Grow2 lh hv hj -> Level (Node3 lh hv hj jv ju) 49 | Level lj -> Level (Node2 lj jv ju) 50 | EQ -> Level (Node2 lj iv ju) 51 | GT -> case insert23 iv ju of 52 | Grow2 jk kv ku -> Level (Node3 lj jv jk kv ku) 53 | Level ju -> Level (Node2 lj jv ju) 54 | insert23 iv@(i, _) (Node3 lj jv@(j, _) jk kv@(k, _) ku) = 55 | case (compare i j, compare i k) of 56 | (LT, _) -> case insert23 iv lj of 57 | Grow2 lh hv hj -> Grow2 (Node2 lh hv hj) jv (Node2 jk kv ku) 58 | Level lj -> Level (Node3 lj jv jk kv ku) 59 | (EQ, _) -> Level (Node3 lj iv jk kv ku) 60 | (_, LT) -> case insert23 iv jk of 61 | Grow2 jh hv hk -> Grow2 (Node2 lj jv jh) hv (Node2 hk kv ku) 62 | Level jk -> Level (Node3 lj jv jk kv ku) 63 | (_, EQ) -> Level (Node3 lj jv jk iv ku) 64 | (_, GT) -> case insert23 iv ku of 65 | Grow2 kh hv hu -> Grow2 (Node2 lj jv jk) kv (Node2 kh hv hu) 66 | Level ku -> Level (Node3 lj jv jk kv ku) 67 | 68 | anoin23 :: Ord k => T23 n k v -> T23 n k v -> I23 n k v 69 | anoin23 Leaf Leaf = Level Leaf 70 | anoin23 (Node2 ai i' im) (Node2 mr r' rz) = case anoin23 im mr of 71 | Level ir -> Level (Node3 ai i' ir r' rz) 72 | Grow2 im m' mr -> Grow2 (Node2 ai i' im) m' (Node2 mr r' rz) 73 | anoin23 (Node2 ai i' im) (Node3 mp p' pu u' uz) = case anoin23 im mp of 74 | Level ip -> Grow2 (Node2 ai i' ip) p' (Node2 pu u' uz) 75 | Grow2 im m' mp -> Grow2 (Node2 ai i' im) m' (Node3 mp p' pu u' uz) 76 | anoin23 (Node3 ag g' gj j' jm) (Node2 mr r' rz) = case anoin23 jm mr of 77 | Level jr -> Grow2 (Node2 ag g' gj) j' (Node2 jr r' rz) 78 | Grow2 jm m' mr -> Grow2 (Node3 ag g' gj j' jm) m' (Node2 mr r' rz) 79 | anoin23 (Node3 ag g' gj j' jm) (Node3 mp p' pu u' uz) = case anoin23 jm mp of 80 | Level jp -> Grow2 (Node2 ag g' gj) j' (Node3 jp p' pu u' uz) 81 | Grow2 jm m' mp -> Grow2 (Node3 ag g' gj j' jm) m' (Node3 mp p' pu u' uz) 82 | 83 | data D23 n k v where 84 | DSame :: T23 n k v -> D23 n k v 85 | DDrop :: T23 n k v -> D23 (Su n) k v 86 | 87 | i2dSu :: I23 n k v -> D23 (Su n) k v 88 | i2dSu (Level t) = DDrop t 89 | i2dSu (Grow2 li i' iu) = DSame (Node2 li i' iu) 90 | 91 | dtNode :: D23 n k v -> (k, v) -> T23 n k v -> D23 (Su n) k v 92 | dtNode (DSame am) m' mz = DSame (Node2 am m' mz) 93 | dtNode (DDrop am) m' (Node2 mr r' rz) = DDrop (Node3 am m' mr r' rz) 94 | dtNode (DDrop am) m' (Node3 mp p' ps s' sz) = 95 | DSame (Node2 (Node2 am m' mp) p' (Node2 ps s' sz)) 96 | 97 | tdNode :: T23 n k v -> (k, v) -> D23 n k v -> D23 (Su n) k v 98 | tdNode am m' (DSame mz) = DSame (Node2 am m' mz) 99 | tdNode (Node2 af f' fm) m' (DDrop mz) = DDrop (Node3 af f' fm m' mz) 100 | tdNode (Node3 ad d' dh h' hm) m' (DDrop mz) = 101 | DSame (Node2 (Node2 ad d' dh) h' (Node2 hm m' mz)) 102 | 103 | delete23 :: Ord k => k -> T23 n k v -> D23 n k v 104 | delete23 k Leaf = DSame Leaf 105 | delete23 k (Node2 ai i' iz) = case compare k (fst i') of 106 | LT -> dtNode (delete23 k ai) i' iz 107 | EQ -> i2dSu (anoin23 ai iz) 108 | GT -> tdNode ai i' (delete23 k iz) 109 | delete23 k (Node3 ai i' ip p' pz) = case (compare k (fst i'), compare k (fst p')) of 110 | (LT, _) -> case delete23 k ai of 111 | DSame ai -> DSame (Node3 ai i' ip p' pz) 112 | DDrop ai -> case ip of 113 | Node2 im m' mp -> 114 | DSame (Node2 (Node3 ai i' im m' mp) p' pz) 115 | Node3 il l' ln n' np -> 116 | DSame (Node3 (Node2 ai i' il) l' (Node2 ln n' np) p' pz) 117 | (EQ, _) -> case anoin23 ai ip of 118 | Level ap -> DSame (Node2 ap p' pz) 119 | Grow2 ai i' ip -> DSame (Node3 ai i' ip p' pz) 120 | (_, LT) -> case delete23 k ip of 121 | DSame ip -> DSame (Node3 ai i' ip p' pz) 122 | DDrop ip -> case pz of 123 | Node2 pt t' tz -> DSame (Node2 ai i' (Node3 ip p' pt t' tz)) 124 | Node3 pr r' ru u' uz -> 125 | DSame (Node3 ai i' (Node2 ip p' pr) r' (Node2 ru u' uz)) 126 | (_, EQ) -> case anoin23 ip pz of 127 | Level iz -> DSame (Node2 ai i' iz) 128 | Grow2 ip p' pz -> DSame (Node3 ai i' ip p' pz) 129 | (_, GT) -> case delete23 k pz of 130 | DSame pz -> DSame (Node3 ai i' ip p' pz) 131 | DDrop pz -> case ip of 132 | Node2 im m' mp -> 133 | DSame (Node2 ai i' (Node3 im m' mp p' pz)) 134 | Node3 il l' ln n' np -> 135 | DSame (Node3 ai i' (Node2 il l' ln) n' (Node2 np p' pz)) 136 | 137 | data Arr (k :: *)(v :: *) where 138 | Arr :: T23 n k v -> Arr k v 139 | deriving instance (Show k, Show v) => Show (Arr k v) 140 | 141 | instance Functor (Arr k) where 142 | fmap f (Arr t) = Arr (fmap f t) 143 | 144 | emptyArr :: Arr k v 145 | emptyArr = Arr Leaf 146 | 147 | insertArr :: Ord k => (k, v) -> Arr k v -> Arr k v 148 | insertArr iv (Arr lu) = case insert23 iv lu of 149 | Level lu -> Arr lu 150 | Grow2 lj jv ju -> Arr (Node2 lj jv ju) 151 | 152 | findArr :: Ord k => k -> Arr k v -> Maybe v 153 | findArr k (Arr lu) = find23 k lu 154 | 155 | deleteArr :: Ord k => k -> Arr k v -> Arr k v 156 | deleteArr k (Arr lu) = case delete23 k lu of 157 | DSame lu -> Arr lu 158 | DDrop lu -> Arr lu 159 | 160 | single :: Ord k => (k, v) -> Arr k v 161 | single x = insertArr x emptyArr 162 | 163 | isEmptyArr :: Arr k v -> Bool 164 | isEmptyArr (Arr Leaf) = True 165 | isEmptyArr _ = False 166 | 167 | travT23 :: Applicative f => ((k, v) -> f w) -> T23 n k v -> f (T23 n k w) 168 | travT23 f Leaf = pure Leaf 169 | travT23 f (Node2 l x@(k, _) r) = Node2 <$> travT23 f l <*> ((,) k <$> f x) <*> travT23 f r 170 | travT23 f (Node3 l x@(j, _) m y@(k, _) r) = 171 | Node3 <$> travT23 f l <*> ((,) j <$> f x) <*> travT23 f m <*> ((,) k <$> f y) <*> travT23 f r 172 | 173 | travArr :: Applicative f => ((k, v) -> f w) -> Arr k v -> f (Arr k w) 174 | travArr f (Arr t) = Arr <$> travT23 f t 175 | 176 | foldMapArr :: Monoid x => ((k, v) -> x) -> Arr k v -> x 177 | foldMapArr f = getConst . travArr (Const . f) 178 | 179 | foldMapSet :: Monoid y => (x -> y) -> Set x -> y 180 | foldMapSet f = foldMapArr (f . fst) 181 | 182 | instance (Ord k, Semigroup v) => Semigroup (Arr k v) where (<>) = mappend 183 | instance (Ord k, Semigroup v) => Monoid (Arr k v) where 184 | mempty = emptyArr 185 | mappend l r = appEndo (foldMapArr up l) r where 186 | up (k, v) = Endo $ \ r -> case findArr k r of 187 | Just w -> insertArr (k, v <> w) r 188 | Nothing -> insertArr (k, v) r 189 | 190 | type Set x = Arr x () 191 | 192 | domain :: Ord k => Arr k v -> Set k 193 | domain = runIdentity . travArr (\ (k, _) -> Identity ()) 194 | 195 | inSet :: Ord x => x -> Set x -> Bool 196 | inSet x s = case findArr x s of 197 | Just _ -> True 198 | _ -> False 199 | 200 | singleton :: Ord x => x -> Set x 201 | singleton = single . flip (,) () 202 | 203 | leftmostArr :: Arr k v -> Maybe k 204 | leftmostArr (Arr t) = go t where 205 | go :: T23 n k v -> Maybe k 206 | go Leaf = Nothing 207 | go (Node2 l (k, _) _) = go l <|> Just k 208 | go (Node3 l (k, _) _ _ _) = go l <|> Just k 209 | 210 | rightmostArr :: Arr k v -> Maybe k 211 | rightmostArr (Arr t) = go t where 212 | go :: T23 n k v -> Maybe k 213 | go Leaf = Nothing 214 | go (Node2 _ (k, _) r) = go r <|> Just k 215 | go (Node3 _ _ _ (k, _) r) = go r <|> Just k 216 | 217 | intersectSet :: Ord x => Set x -> Set x -> Set x 218 | intersectSet xs = 219 | foldMapArr (\ (y, ()) -> if inSet y xs then singleton y else mempty) 220 | 221 | subSet :: Ord x => Set x -> Set x -> Bool 222 | subSet xs ys = getAll (foldMapSet (All . (`inSet` ys)) xs) 223 | -------------------------------------------------------------------------------- /C2W.agda: -------------------------------------------------------------------------------- 1 | module C2W where 2 | 3 | data Nat : Set where 4 | ze : Nat 5 | su : Nat -> Nat 6 | 7 | data _<=_ : Nat -> Nat -> Set where 8 | `0_ : forall {n m} -> n <= m -> n <= su m 9 | `1_ : forall {n m} -> n <= m -> su n <= su m 10 | [] : ze <= ze 11 | 12 | infixr 20 `0_ `1_ 13 | 14 | infix 10 _/x\_ 15 | data _/x\_ : forall {l n m} -> 16 | l <= m -> n <= m -> Set where 17 | [] : [] /x\ [] 18 | rr_ : forall {l n m}{th : l <= m}{ph : n <= m} 19 | -> th /x\ ph -> `0 th /x\ `1 ph 20 | ll_ : forall {l n m}{th : l <= m}{ph : n <= m} 21 | -> th /x\ ph -> `1 th /x\ `0 ph 22 | 23 | data Vec (X : Set) : Nat -> Set where 24 | [] : Vec X ze 25 | _,-_ : forall {n} -> X -> Vec X n -> Vec X (su n) 26 | infixr 20 _,-_ 27 | 28 | vec : forall {S T n} -> (S -> T) 29 | -> Vec S n -> Vec T n 30 | vec f [] = [] 31 | vec f (s ,- ss) = f s ,- vec f ss 32 | 33 | riffle : forall {X l n m}{th : l <= m}{ph : n <= m} 34 | -> Vec X l -> th /x\ ph -> Vec X n 35 | -> Vec X m 36 | riffle ls [] rs = [] 37 | riffle ls (rr p) (x ,- rs) = x ,- riffle ls p rs 38 | riffle (x ,- ls) (ll p) rs = x ,- riffle ls p rs 39 | 40 | data Two : Set where 41 | ff tt : Two 42 | 43 | record _><_ (S : Set)(T : S -> Set) : Set where 44 | constructor _,_ 45 | field 46 | fst : S 47 | snd : T fst 48 | 49 | data Riffled {T : Two -> Set}{m : Nat} 50 | : Vec (Two >< T) m -> Set where 51 | riffling : 52 | forall {l}{n}{th : l <= m}{ph : n <= m} 53 | (ffs : Vec (T ff) l) 54 | (p : th /x\ ph) 55 | (tts : Vec (T tt) n) 56 | -> Riffled (riffle (vec (ff ,_) ffs) 57 | p 58 | (vec (tt ,_) tts)) 59 | 60 | riffled : forall (T : Two -> Set){m : Nat} 61 | (bts : Vec (Two >< T) m) 62 | -> Riffled bts 63 | riffled T [] = riffling [] [] [] 64 | riffled T ((b , t) ,- bts) with riffled T bts 65 | riffled T ((ff , f) ,- .(riffle (vec (ff ,_) ffs) p (vec (tt ,_) tts))) | riffling ffs p tts = 66 | riffling (f ,- ffs ) (ll p) tts 67 | riffled T ((tt , t) ,- .(riffle (vec (ff ,_) ffs) p (vec (tt ,_) tts))) | riffling ffs p tts = 68 | riffling ffs (rr p) (t ,- tts) 69 | 70 | data _~_ {X : Set}(x : X) : X -> Set where 71 | r~ : x ~ x 72 | 73 | {-# BUILTIN EQUALITY _~_ #-} 74 | 75 | riffle1 : forall (T : Two -> Set){m : Nat} 76 | {l}{n}{th : l <= m}{ph : n <= m} 77 | (ffs : Vec (T ff) l) 78 | (p : th /x\ ph) 79 | (tts : Vec (T tt) n) 80 | -> riffled T (riffle (vec (ff ,_) ffs) p (vec (tt ,_) tts)) ~ riffling ffs p tts 81 | riffle1 T ffs (rr p) (t ,- tts) 82 | with riffled T (riffle (vec (ff ,_) ffs) p (vec (tt ,_) tts)) 83 | | riffle1 T ffs p tts 84 | ... | z | w rewrite w = r~ 85 | riffle1 T (f ,- ffs) (ll p) tts 86 | with riffled T (riffle (vec (ff ,_) ffs) p (vec (tt ,_) tts)) 87 | | riffle1 T ffs p tts 88 | ... | z | w rewrite w = r~ 89 | riffle1 T [] [] [] = r~ 90 | -------------------------------------------------------------------------------- /Cats.agda: -------------------------------------------------------------------------------- 1 | module Cats where 2 | 3 | data _~_ {X : Set}(x : X) : X -> Set where 4 | r~ : x ~ x 5 | 6 | record _><_ (S : Set)(T : S -> Set) : Set where 7 | constructor _,_ 8 | field 9 | fst : S 10 | snd : T fst 11 | open _><_ public 12 | infixr 4 _,_ 13 | 14 | _*_ : Set -> Set -> Set 15 | S * T = S >< \ _ -> T 16 | 17 | _:*_ : {X : Set} -> 18 | (X -> Set) -> (X -> Set) -> (X -> Set) 19 | (P :* Q) x = P x * Q x 20 | 21 | record <_> {X : Set}(P : X -> Set) : Set where 22 | constructor !_ 23 | field 24 | {wit} : X 25 | prf : P wit 26 | open <_> public 27 | infixr 4 !_ 28 | 29 | data Nat : Set where 30 | ze : Nat 31 | su : Nat -> Nat 32 | 33 | data [_+N_]~_ : Nat -> Nat -> Nat -> Set where 34 | ze : forall {y} 35 | -> [ ze +N y ]~ y 36 | su : forall {x y z} 37 | -> [ x +N y ]~ z 38 | -> [ su x +N y ]~ su z 39 | 40 | mk+N : forall x y -> < [ x +N y ]~_ > 41 | mk+N ze y = ! ze 42 | mk+N (su x) y with ! p <- mk+N x y = ! su p 43 | 44 | unique+N : forall {x y}(a b : < [ x +N y ]~_ >) -> a ~ b 45 | unique+N (! ze) (! ze) = r~ 46 | unique+N (! su a) (! su b) 47 | with r~ <- unique+N (! a) (! b) = r~ 48 | 49 | _+N_ : Nat -> Nat -> Nat 50 | x +N y = wit (mk+N x y) 51 | 52 | asso+N : forall {i j k l} 53 | -> < ([ i +N j ]~_) :* ([_+N k ]~ l) > 54 | -> < ([ j +N k ]~_) :* ([ i +N_]~ l) > 55 | 56 | asso+N (! ze , b) = ! b , ze 57 | asso+N (! su a , su b) 58 | with ! c , d <- asso+N (! a , b) 59 | = ! c , su d 60 | 61 | data Vec (X : Set) : Nat -> Set where 62 | [] : Vec X ze 63 | _,-_ : forall {n} -> X -> Vec X n -> Vec X (su n) 64 | 65 | data [_+V_]~_ {X : Set} : forall {i j k} -> 66 | Vec X i -> Vec X j -> Vec X k -> Set 67 | where 68 | ze : forall {j}{ys : Vec X j} -> [ [] +V ys ]~ ys 69 | su : forall {i j k x} 70 | {xs : Vec X i}{ys : Vec X j}{zs : Vec X k} 71 | -> [ xs +V ys ]~ zs 72 | -> [ (x ,- xs) +V ys ]~ (x ,- zs) 73 | 74 | mk+V : forall {X i j}(xs : Vec X i)(ys : Vec X j) -> 75 | <(\ k -> <_> {Vec X k} ([ xs +V ys ]~_))> 76 | mk+V [] ys = ! ! ze 77 | mk+V (x ,- xs) ys with ! ! p <- mk+V xs ys = ! ! su p 78 | 79 | lem+VN : forall {X i j k} 80 | {xs : Vec X i}{ys : Vec X j}{zs : Vec X k} 81 | -> [ xs +V ys ]~ zs 82 | -> [ i +N j ]~ k 83 | lem+VN ze = ze 84 | lem+VN (su p) = su (lem+VN p) 85 | 86 | asso+V : forall {X}{i j k l} 87 | {ws : Vec X i}{xs : Vec X j}{ys : Vec X k}{zs : Vec X l} 88 | -> <(\ m -> <_> {Vec X m} 89 | (([ ws +V xs ]~_) :* ([_+V ys ]~ zs)))> 90 | -> <(\ m -> <_> {Vec X m} 91 | (([ xs +V ys ]~_) :* ([ ws +V_]~ zs)))> 92 | asso+V (! ! (ze , q)) = ! ! q , ze 93 | asso+V (! ! (su p , su q)) 94 | with ! ! r , s <- asso+V (! ! p , q) 95 | = ! ! r , su s 96 | 97 | _+V_ : forall {X i j} 98 | -> Vec X i -> Vec X j -> Vec X (i +N j) 99 | _+V_ {X}{i}{j} xs ys 100 | with p <- mk+N i j | ! q <- mk+V xs ys 101 | | p' <- lem+VN (prf q) 102 | | r~ <- unique+N p (! p') 103 | = wit q 104 | -------------------------------------------------------------------------------- /CompLam.hs: -------------------------------------------------------------------------------- 1 | module CompLam where 2 | 3 | import Control.Monad.State 4 | 5 | import BigArray 6 | 7 | data Inst 8 | = Push Int | PushReg | Restack | Swap | Pop 9 | | Cons | Decons 10 | | Load Int | Add 11 | deriving Show 12 | 13 | data Exit = Jump Int | Return 14 | deriving Show 15 | 16 | type Block = ([Inst], Exit) 17 | 18 | type Heap v = (Int, Arr Int v) 19 | 20 | type Prog = Heap Block 21 | type Store = Heap (Int, Int) 22 | 23 | alloc :: v -> State (Heap v) Int 24 | alloc v = do 25 | (n, vs) <- get 26 | put (n + 1, insertArr (n, v) vs) 27 | return n 28 | 29 | hunt :: Int -> State (Heap v) v 30 | hunt i = do 31 | (n, vs) <- get 32 | let Just v = findArr i vs 33 | return v 34 | 35 | type Config = 36 | ( Int -- register 37 | , [Int] -- stack 38 | , Store 39 | ) 40 | 41 | inst :: Config -> Inst -> Config 42 | inst (r, s, m) (Push i) = (r, i : s, m) 43 | inst (r, s, m) PushReg = (r, r : s, m) 44 | inst (r, h : s, m) Restack = (h, r : s, m) 45 | inst (r, x : y : s, m) Swap = (r, y : x : s, m) 46 | inst (r, _ : s, m) Pop = (r, s, m) 47 | inst (r, x : s, m) Cons = (r', s, m') where 48 | (r', m') = runState (alloc (x, r)) m 49 | inst (r, s, m) Decons = (r', x : s, m) where 50 | (x, r') = evalState (hunt r) m 51 | inst (_, s, m) (Load n) = (n, s, m) 52 | inst (x, y : s, m) Add = (x + y, s, m) 53 | 54 | run :: Prog -> Exit -> Config -> (Int, Store) 55 | run p Return (r, [], m) = (r, m) 56 | run p Return (r, i : s, m) = run p (Jump i) (r, s, m) 57 | run p (Jump i) c = run p e (foldl inst c is) where 58 | (is, e) = evalState (hunt i) p 59 | 60 | data Tm 61 | = V Int 62 | | L Tm 63 | | Tm :$ Tm 64 | | N Int 65 | | Tm :+ Tm 66 | deriving Show 67 | 68 | compile :: [Inst] -- prefix 69 | -> Tm -- code 70 | -> Int -- exit point 71 | -> State Prog Int 72 | compile is (L t) k = do 73 | ret <- alloc ([], Return) 74 | bod <- compile [] t ret 75 | alloc (is ++ [Push bod, Cons], Jump k) 76 | compile is (V i) k = 77 | alloc (is ++ concat (replicate i [Decons, Pop]) ++ [Decons, Restack, Pop], Jump k) 78 | compile is (f :$ s) k = do 79 | fin <- alloc ([Decons, Swap, Cons, Push k, Swap], Return) 80 | fun <- compile [Restack] f fin 81 | compile (is ++ [PushReg]) s fun 82 | compile is (N n) k = alloc (is ++ [Load n], Jump k) 83 | compile is (s :+ t) k = do 84 | add <- alloc ([Add], Jump k) 85 | s' <- compile [Restack] s add 86 | compile (is ++ [PushReg]) t s' 87 | 88 | topLevel :: Tm -> (Int, Prog) 89 | topLevel t = runState p (0, emptyArr) 90 | where 91 | p = do 92 | ret <- alloc ([], Return) 93 | compile [] t ret 94 | 95 | try :: Tm -> (Int, Store) 96 | try t = run p (Jump e) (negate 1, [], (0, emptyArr)) where 97 | (e, p) = topLevel t 98 | 99 | --- 100 | 101 | cze :: Tm 102 | cze = L (L (V 0)) 103 | 104 | csu :: Tm 105 | csu = L (L (L (V 1 :$ ((V 2 :$ V 1) :$ V 0)))) 106 | 107 | c2 :: Tm 108 | c2 = csu :$ (csu :$ cze) 109 | 110 | nsu :: Tm 111 | nsu = L (N 1 :+ V 0) 112 | 113 | -------------------------------------------------------------------------------- /ConCom.agda: -------------------------------------------------------------------------------- 1 | module ConCom where 2 | 3 | data _~_ {l}{X : Set l}(x : X) : X -> Set l where 4 | r~ : x ~ x 5 | 6 | -- see you B, raise you S 7 | _-_ : forall {i j k} 8 | {A : Set i}{B : A -> Set j}{C : (a : A) -> B a -> Set k} 9 | (f : (a : A) -> B a) 10 | (g : {a : A}(b : B a) -> C a b) 11 | (a : A) -> C a (f a) 12 | (f - g) a = g (f a) 13 | 14 | infixl 10 _-_ 15 | 16 | record One : Set where constructor <> 17 | 18 | record _><_ (S : Set)(T : S -> Set) : Set where 19 | constructor _,_ 20 | field 21 | fst : S 22 | snd : T fst 23 | open _><_ 24 | infixr 5 _,_ 25 | 26 | record Con : Set1 where 27 | constructor _ Set -- datoid? 31 | open Con 32 | 33 | [_]o : Con -> Set -> Set 34 | [ S < \ s -> P s -> X 35 | 36 | [_]m : (F : Con){S T : Set} -> (S -> T) -> ([ F ]o S -> [ F ]o T) 37 | [ F ]m f (s , k) = s , (k - f) 38 | 39 | Div : Con -> Con 40 | Div (S < P) _ : Con -> Con -> Set 43 | (S F = (s : S) -> [ F ]o (P s) 44 | 45 | [_]t : forall {F G} -> F => G -> forall {X} -> [ F ]o X -> [ G ]o X 46 | [_]t {F} {G} t (s , k) = [ G ]m k (t s) 47 | 48 | [_]r : forall {F G} -> (forall {X} -> [ F ]o X -> [ G ]o X) -> F => G 49 | [ f ]r s = f (s , \ p -> p) 50 | 51 | I : Con 52 | I = One One 53 | 54 | _!>>_ : Con -> Con -> Con 55 | (S > (S' P' s' >< (k - P) 56 | 57 | id : {F : Con} -> F => F 58 | id {F} = [_]r {F}{F} \ x -> x 59 | 60 | comp : {F G : Con}{X : Set} -> [ G ]o ([ F ]o X) -> [ F !>> G ]o X 61 | comp (s , k) = (s , k - fst) , \ (p , p') -> snd (k p) p' 62 | 63 | pmoc : {F G : Con}{X : Set} -> [ F !>> G ]o X -> [ G ]o ([ F ]o X) 64 | pmoc ((s , f) , k) = s , \ p -> f p , ((p ,_) - k) 65 | 66 | map : (F : Con){G H : Con} -> G => H -> (G !>> F) => (H !>> F) 67 | map F {G}{H} gh = [ pmoc {G}{F} - [ F ]m [ gh ]t - comp {H}{F} ]r 68 | 69 | pam : {F G : Con}(H : Con) -> F => G -> (H !>> F) => (H !>> G) 70 | pam {F}{G}H fg = [ pmoc {H}{F} - [ fg ]t - comp {H}{G} ]r 71 | 72 | rid : {F : Con} -> F => (F !>> I) 73 | rid {F} s = (<> , \ _ -> s) , snd 74 | 75 | dir : {F : Con} -> (F !>> I) => F 76 | dir (<> , s) = s <> , \ p -> <> , p 77 | 78 | dil : {F : Con} -> (I !>> F) => F 79 | dil (s , _) = s , (_, <>) 80 | 81 | asso : {F G H : Con} -> ((F !>> G) !>> H) => (F !>> (G !>> H)) 82 | asso {F}{G}{H} = [ pmoc{F !>> G}{H} - [ H ]m (pmoc{F}{G}) 83 | - comp{G}{H} - comp{F}{G !>> H} ]r 84 | 85 | _=>=_ : {F G H : Con} -> F => G -> G => H -> F => H 86 | (fg =>= gh) = [ [ fg ]t - [ gh ]t ]r 87 | 88 | here : {F : Con} -> Div F => I 89 | here (s , h) = <> , \ _ -> h 90 | 91 | deco : {F : Con} -> Div F => (Div F !>> Div F) 92 | deco (s , h) = ((s , h) , (s ,_)) , snd 93 | 94 | law1 : {F : Con} -> (deco {F} =>= (pam (Div F) (here {F}) =>= dir {Div F})) ~ id {Div F} 95 | law1 = r~ 96 | 97 | law2 : {F : Con} -> (deco {F} =>= (map (Div F) (here {F}) =>= dil {Div F})) ~ id {Div F} 98 | law2 = r~ 99 | 100 | law3 : {F : Con} -> (deco {F} =>= pam (Div F) (deco {F})) 101 | ~ (deco {F} =>= (map (Div F) (deco {F}) =>= asso {Div F}{Div F}{Div F})) 102 | law3 = r~ 103 | -------------------------------------------------------------------------------- /CoqInterpreter.v: -------------------------------------------------------------------------------- 1 | (*Inductive nat : Set := | O : nat.*) 2 | 3 | Inductive ope : nat -> nat -> Set := 4 | | oz : ope O O 5 | | os : forall n m : nat, ope n m -> ope (S n) (S m) 6 | | o' : forall n m : nat, ope n m -> ope n (S m). 7 | 8 | Lemma oi : forall n : nat, ope n n. 9 | induction n. 10 | exact oz. 11 | eapply os. 12 | eapply IHn. 13 | Defined. 14 | 15 | Lemma oe : forall n : nat, ope O n. 16 | induction n. 17 | exact oz. 18 | eapply o'. 19 | eapply IHn. 20 | Defined. 21 | 22 | Lemma oc' : forall n m : nat, ope n m -> 23 | forall p : nat, ope p n -> ope p m. 24 | induction 1. 25 | intros. 26 | inversion H. 27 | eapply oz. 28 | intros. 29 | inversion H0. 30 | eapply os. 31 | eapply IHope. 32 | eapply H3. 33 | eapply o'. 34 | eapply IHope. 35 | eapply H3. 36 | intros. 37 | eapply o'. 38 | eapply IHope. 39 | eapply H0. 40 | Defined. 41 | 42 | Definition oc (p n m : nat)(th : ope p n)(ph : ope n m) 43 | : ope p m 44 | := oc' n m ph p th. 45 | 46 | Inductive tm (n : nat) : Set := 47 | | var : ope 1 n -> tm n 48 | | prop : tm n 49 | | type : nat -> tm n 50 | | pi : tm n -> tm (S n) -> tm n 51 | | lam : tm n -> tm (S n) -> tm n 52 | | app : tm n -> tm n -> tm n. 53 | 54 | Inductive dir : Set := | chk | syn . 55 | 56 | Inductive va (n : nat) : dir -> Set := 57 | | vvar : ope 1 n -> va n syn 58 | | vapp : va n syn -> va n chk -> va n syn 59 | | vprop : va n chk 60 | | vtype : nat -> va n chk 61 | | vpi : va n chk -> 62 | forall m, (ope 1 m -> va n chk) -> 63 | tm (S m) -> va n chk 64 | | vlam : va n chk -> 65 | forall m, (ope 1 m -> va n chk) -> 66 | tm (S m) -> va n chk 67 | | vem : va n syn -> va n chk. 68 | 69 | Inductive EVAL (X : Set) : Set := 70 | | ret : X -> EVAL X 71 | | eva : forall n : nat, tm n -> 72 | forall m : nat, (ope 1 n -> va m chk) -> 73 | (va m chk -> EVAL X) -> EVAL X 74 | | nor : forall n : nat, va n chk -> 75 | (tm n -> EVAL X) -> EVAL X 76 | | err : EVAL X. 77 | 78 | Lemma snoc : forall X : Set, forall n : nat, 79 | (ope 1 n -> X) -> X -> 80 | (ope 1 (S n) -> X). 81 | intros X n xs x i. 82 | inversion i. 83 | exact x. 84 | exact (xs H1). 85 | Defined. 86 | 87 | Lemma appv : forall m : nat, va m chk -> va m chk -> 88 | EVAL (va m chk). 89 | intros m f s. 90 | inversion f. 91 | eapply err. (* prop *) 92 | eapply err. (* type *) 93 | eapply err. (* pi *) 94 | eapply (eva _ (S m0) H1 m). (* lam *) 95 | eapply snoc. 96 | exact H0. 97 | exact s. 98 | intros t. 99 | eapply ret. 100 | exact t. 101 | eapply ret. (* stuck *) 102 | eapply vem. 103 | eapply vapp. 104 | exact H. 105 | exact s. 106 | Defined. 107 | 108 | Lemma bind : forall X Y : Set, 109 | EVAL X -> (X -> EVAL Y) -> EVAL Y. 110 | intros X Y ex k. 111 | induction ex. 112 | exact (k x). 113 | eapply (eva _ n t m v). 114 | intros u. 115 | exact (H u). 116 | eapply (nor _ _ v). intros u. exact (H u). 117 | eapply err. 118 | Defined. 119 | 120 | Lemma eval : forall n : nat, tm n -> 121 | forall m : nat, (ope 1 n -> va m chk) -> 122 | EVAL (va m chk). 123 | induction 1. 124 | intros m g. (* var *) 125 | eapply ret. 126 | exact (g o). 127 | intros m g. (* prop *) 128 | eapply ret. 129 | eapply vprop. 130 | intros m g. (* type *) 131 | eapply ret. 132 | eapply vtype. 133 | exact n0. 134 | intros m g. (* pi *) 135 | eapply bind. 136 | eapply (IHtm1 _ g). 137 | intros S'. 138 | eapply ret. 139 | eapply vpi. 140 | exact S'. 141 | exact g. 142 | exact H0. 143 | intros m g. (* lam *) 144 | eapply bind. 145 | eapply (IHtm1 _ g). 146 | intros S'. 147 | eapply ret. 148 | eapply vlam. 149 | exact S'. 150 | exact g. 151 | exact H0. 152 | intros m g. (* app *) 153 | eapply bind. eapply (IHtm1 _ g). intros f. 154 | eapply bind. eapply (IHtm2 _ g). intros s. 155 | eapply appv. 156 | exact f. 157 | exact s. 158 | Defined. 159 | 160 | Lemma thinv : forall n : nat, forall d : dir, va n d -> 161 | forall m : nat, ope n m -> va m d. 162 | induction 1. 163 | intros m th. (* vvar *) 164 | eapply vvar. 165 | eapply oc. exact o. exact th. 166 | intros m th. (* vapp *) 167 | eapply vapp. eapply (IHva1 _ th). eapply (IHva2 _ th). 168 | intros m th. (* vprop *) 169 | eapply vprop. 170 | intros m th. (* vtype *) 171 | eapply vtype. exact n0. 172 | intros m' th. (* vpi *) 173 | eapply vpi. 174 | eapply (IHva _ th). 175 | intros i. eapply (H0 i). exact th. exact t. 176 | intros m' th. (* vlam *) 177 | eapply vlam. 178 | eapply (IHva _ th). 179 | intros i. eapply (H0 i). exact th. exact t. 180 | intros m th. (* vem *) 181 | eapply vem. 182 | eapply (IHva _ th). 183 | Defined. 184 | 185 | Lemma norm : forall n : nat, forall d : dir, 186 | va n d -> EVAL (tm n). 187 | induction 1. 188 | eapply ret. eapply var. exact o. 189 | eapply bind. exact IHva1. intros f. 190 | eapply bind. exact IHva2. intros s. 191 | eapply ret. eapply app. exact f. exact s. 192 | eapply ret. eapply prop. 193 | eapply ret. eapply type. exact n0. 194 | eapply bind. exact IHva. intros S'. 195 | eapply eva. 196 | exact t. 197 | eapply snoc. 198 | intros i. eapply thinv. 199 | eapply (v i). 200 | eapply o'. eapply oi. 201 | eapply vem. eapply vvar. eapply os. eapply oe. 202 | intros T. eapply nor. eapply T. 203 | intros T'. eapply ret. eapply pi. 204 | exact S'. exact T'. 205 | eapply bind. exact IHva. intros S'. 206 | eapply eva. 207 | exact t. 208 | eapply snoc. 209 | intros i. eapply thinv. 210 | eapply (v i). 211 | eapply o'. eapply oi. 212 | eapply vem. eapply vvar. eapply os. eapply oe. 213 | intros T. eapply nor. eapply T. 214 | intros T'. eapply ret. eapply lam. 215 | exact S'. exact T'. 216 | exact IHva. 217 | Defined. 218 | 219 | CoInductive Delay (T : Set) : Set := 220 | | now : T -> Delay T 221 | | wait : Delay T -> Delay T 222 | | fail : Delay T. 223 | 224 | Lemma run : forall X : Set, EVAL X -> Delay X. 225 | cofix ru. 226 | destruct 1. 227 | eapply now. exact x. 228 | eapply wait. eapply ru. 229 | eapply bind. 230 | eapply eval. exact t. exact v. 231 | exact e. 232 | eapply wait. eapply ru. 233 | eapply bind. 234 | eapply norm. exact v. 235 | exact e. 236 | eapply fail. 237 | Defined. 238 | 239 | Lemma normalize : forall n : nat, tm n -> Delay (tm n). 240 | intros n t. 241 | eapply run. 242 | eapply bind. 243 | eapply eval. 244 | eapply t. 245 | intros i. eapply vem. eapply vvar. exact i. 246 | intros v. eapply nor. 247 | exact v. 248 | eapply ret. 249 | Defined. 250 | 251 | Lemma PN : forall n : nat, tm n. 252 | intros n. 253 | eapply pi. 254 | eapply prop. 255 | eapply pi. 256 | eapply pi. 257 | eapply var. eapply os. eapply oe. 258 | eapply var. eapply o'. eapply os. eapply oe. 259 | eapply pi. 260 | eapply var. eapply o'. eapply os. eapply oe. 261 | eapply var. eapply o'. eapply o'. eapply os. eapply oe. 262 | Defined. 263 | 264 | Lemma PZ : forall n : nat, tm n. 265 | intros n. 266 | eapply lam. 267 | eapply prop. 268 | eapply lam. 269 | eapply pi. 270 | eapply var. eapply os. eapply oe. 271 | eapply var. eapply o'. eapply os. eapply oe. 272 | eapply lam. 273 | eapply var. eapply o'. eapply os. eapply oe. 274 | eapply var. eapply os. eapply oe. 275 | Defined. 276 | 277 | Lemma PS : forall n : nat, tm n. 278 | intros n. 279 | eapply lam. 280 | eapply (PN n). 281 | eapply lam. 282 | eapply prop. 283 | eapply lam. 284 | eapply pi. 285 | eapply var. eapply os. eapply oe. 286 | eapply var. eapply o'. eapply os. eapply oe. 287 | eapply lam. 288 | eapply var. eapply o'. eapply os. eapply oe. 289 | eapply app. 290 | eapply var. eapply o'. eapply os. eapply oe. 291 | eapply app. eapply app. eapply app. 292 | eapply var. eapply o'. eapply o'. eapply o'. eapply os. eapply oe. 293 | eapply var. eapply o'. eapply o'. eapply os. eapply oe. 294 | eapply var. eapply o'. eapply os. eapply oe. 295 | eapply var. eapply os. eapply oe. 296 | Defined. 297 | 298 | Lemma P1 : forall n : nat, tm n. 299 | intros n. 300 | eapply app. 301 | exact (PS n). 302 | exact (PZ n). 303 | Defined. 304 | 305 | Lemma gas : forall X : Set, forall n : nat, Delay X -> option X. 306 | intros X n. 307 | induction n. 308 | intros d. eapply None. 309 | intros d. destruct d. 310 | eapply Some. exact x. 311 | eapply IHn. exact d. 312 | eapply None. 313 | Defined. 314 | 315 | Compute (gas _ 42 (normalize 0 (P1 0))). 316 | 317 | Lemma P2 : forall n : nat, tm n. 318 | intros n. 319 | eapply app. 320 | exact (PS n). 321 | exact (P1 n). 322 | Defined. 323 | 324 | Compute (gas _ 42 (normalize 0 (P2 0))). 325 | 326 | Lemma P4 : forall n : nat, tm n. 327 | intros n. 328 | eapply lam. eapply prop. 329 | eapply app. eapply app. eapply P2. 330 | eapply pi. 331 | eapply var. eapply os. eapply oe. 332 | eapply var. eapply o'. eapply os. eapply oe. 333 | eapply app. 334 | eapply P2. 335 | eapply var. eapply os. eapply oe. 336 | Defined. 337 | 338 | Compute (gas _ 420 (normalize 0 (P4 0))). 339 | -------------------------------------------------------------------------------- /Dag.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | ----- ----- 3 | ----- Dag: directed acyclic graphs ----- 4 | ----- ----- 5 | ------------------------------------------------------------------------------ 6 | 7 | module Dag where 8 | 9 | import Data.Maybe 10 | import Data.Monoid 11 | 12 | import BigArray 13 | 14 | newtype Dag n = Dag 15 | { upSets :: Arr n (Set n) -- map each node to its upward closure 16 | } deriving Show 17 | 18 | upSet :: Ord n => Dag n -> n -> Set n 19 | upSet (Dag dag) n = fromMaybe (singleton n) (findArr n dag) 20 | 21 | downSet :: Ord n => Dag n -> n -> Set n 22 | downSet (Dag dag) n = singleton n <> 23 | foldMapArr (\ (x, xup) -> if inSet n xup then singleton x else mempty) dag 24 | 25 | invertDag :: Ord n => Dag n -> Dag n 26 | invertDag (Dag dag) = 27 | Dag (foldMapArr (\ (x, _) -> single (x, downSet (Dag dag) x)) dag) 28 | 29 | rawDelete :: Ord n => Set n -> Dag n -> Dag n 30 | rawDelete ns (Dag dag) = Dag $ 31 | foldMapArr (\ (x, xup) -> if inSet x ns then mempty else 32 | single (x, 33 | foldMapArr (\ (y, ()) -> if inSet y ns then mempty else singleton y) 34 | xup)) 35 | dag 36 | 37 | edge :: Ord n => (n {-x-}, n {-y-}) -> Dag n -> 38 | ( Set n -- the set of nodes thus identified with y and deleted 39 | , Dag n -- the updated dag 40 | ) 41 | edge (x, y) (Dag dag) = case findArr y dag of 42 | Nothing -> -- y does not exist, so 43 | let dag' = dag <> single (x, singleton x) <> single (y, singleton y) 44 | -- ensure that x and y both exist, then... 45 | in (mempty, 46 | Dag $ dag' <> 47 | foldMapArr 48 | (\ (z, zup) -> if inSet x zup then single (z, singleton y) else mempty) 49 | dag' -- ...add y to every upSet containing x 50 | ) 51 | Just yup -- y exists, with upSet yup 52 | | inSet x yup -> -- x is above y, so some collapse is needed 53 | let yis = deleteArr y (intersectSet yup (downSet (Dag dag) x)) 54 | -- everything above y and below x, apart from y 55 | in (yis, rawDelete yis (Dag dag)) 56 | | otherwise -> 57 | let dag' = dag <> single (x, singleton x) -- ensure that x exists 58 | in ( mempty 59 | , Dag (dag' <> 60 | foldMapArr (\ (z, zup) -> if inSet x zup then (single (z, yup)) else mempty) 61 | dag') -- everything with x in its upSet gets yup in its upSet, too 62 | ) 63 | 64 | upDelete :: Ord n => n -> Dag n -> (Set n, Dag n) 65 | upDelete n (Dag dag) = case findArr n dag of 66 | Nothing -> (singleton n, Dag dag) 67 | Just nup -> (nup, rawDelete nup (Dag dag)) 68 | 69 | downDelete :: Ord n => n -> Dag n -> (Set n, Dag n) 70 | downDelete n dag = 71 | let ndn = downSet dag n 72 | in (ndn, rawDelete ndn dag) 73 | 74 | data DagComponents n = DagComponents 75 | { nextComponent :: Integer -- larger than any mentioned 76 | , knownComponents :: Arr Integer (Set n) -- which things are in a component 77 | , whichComponent :: Arr n Integer -- which component a thing is in 78 | } deriving Show 79 | 80 | growComponents :: Ord n => Set n -> DagComponents n -> DagComponents n 81 | growComponents xs (DagComponents n k w) = 82 | case foldMapSet (\ x -> maybe [] (:[]) (findArr x w)) xs of 83 | [] -> DagComponents 84 | { nextComponent = n + 1 85 | , knownComponents = insertArr (n, xs) k 86 | , whichComponent = appEndo 87 | (foldMapSet (\ x -> Endo $ insertArr (x, n)) xs) w 88 | } 89 | [i] -> DagComponents 90 | { nextComponent = n 91 | , knownComponents = k <> single (i, xs) 92 | , whichComponent = appEndo 93 | (foldMapSet (\ x -> Endo $ insertArr (x, i)) xs) w 94 | } 95 | i : js -> 96 | let blob = xs <> foldMap (\ j -> fromMaybe mempty (findArr j k)) js 97 | k' = foldr deleteArr k js 98 | in DagComponents 99 | { nextComponent = n 100 | , knownComponents = insertArr (i, blob) k' 101 | , whichComponent = appEndo 102 | (foldMapSet (\ x -> Endo $ insertArr (x, i)) blob) w 103 | } 104 | 105 | dagComponents :: Ord n => Dag n -> DagComponents n 106 | dagComponents (Dag dag) = 107 | appEndo (foldMapArr (Endo . growComponents . snd) dag) 108 | (DagComponents 0 emptyArr emptyArr) 109 | 110 | dagClosure :: Ord n => n -> Dag n -> Set n 111 | dagClosure n dag = case findArr n w of 112 | Just c -> case findArr c k of 113 | Just s -> s 114 | where 115 | DagComponents {knownComponents = k, whichComponent = w} = 116 | dagComponents dag 117 | 118 | -------------------------------------------------------------------------------- /Diff.agda: -------------------------------------------------------------------------------- 1 | module Diff where 2 | 3 | data Nat : Set where ze : Nat ; su : Nat -> Nat 4 | 5 | data Fin : Nat -> Set where 6 | ze : forall {n} -> Fin (su n) 7 | su : forall {n} -> Fin n -> Fin (su n) 8 | 9 | data Flg : Set where nml dgn : Flg 10 | 11 | data Reg : Flg -> Nat -> Set where 12 | -- the normal regulars 13 | # : forall {f n} -> Fin n -> Reg f n 14 | `0 `1 : forall {f n} -> Reg f n 15 | _`+_ _`*_ : forall {f n} -> Reg f n -> Reg f n -> Reg f n 16 | `Mu : forall {f n} -> Reg f (su n) -> Reg f n 17 | -- the degenerate regulars 18 | `wk : forall {n} -> Reg dgn n -> Reg dgn (su n) 19 | _`/_ : forall {n} -> Reg dgn (su n) -> Reg dgn n -> Reg dgn n 20 | 21 | -- everything can degenerate 22 | degenerate : forall {f n} -> Reg f n -> Reg dgn n 23 | degenerate (# x) = # x 24 | degenerate `0 = `0 25 | degenerate `1 = `1 26 | degenerate (s `+ t) = degenerate s `+ degenerate t 27 | degenerate (s `* t) = degenerate s `* degenerate t 28 | degenerate (`Mu t) = `Mu (degenerate t) 29 | degenerate (`wk t) = `wk t 30 | degenerate (f `/ s) = f `/ s 31 | 32 | module _ 33 | (I : Nat -> Set) 34 | (bv : forall {n} -> I (su n)) 35 | (wk : forall {n} -> I n -> I (su n)) 36 | (tm : forall {n} -> I n -> Reg nml n) 37 | where 38 | lift : forall {n m} -> (Fin n -> I m) -> (Fin (su n) -> I (su m)) 39 | lift f ze = bv 40 | lift f (su i) = wk (f i) 41 | 42 | act : forall {n m} -> (Fin n -> I m) -> Reg nml n -> Reg nml m 43 | act al (# x) = tm (al x) 44 | act al `0 = `0 45 | act al `1 = `1 46 | act al (s `+ t) = act al s `+ act al t 47 | act al (s `* t) = act al s `* act al t 48 | act al (`Mu f) = `Mu (act (lift al) f) 49 | 50 | ren = act Fin ze su # 51 | sub = act (Reg nml) (# ze) (ren su) (\ t -> t) 52 | 53 | _/_ : forall {n} -> Reg nml (su n) -> Reg nml n -> Reg nml n 54 | f / s = sub (\ { ze -> s ; (su i) -> # i }) f 55 | 56 | -- everything can be normalized 57 | normalize : forall {f n} -> Reg f n -> Reg nml n 58 | normalize (# x) = # x 59 | normalize `0 = `0 60 | normalize `1 = `1 61 | normalize (s `+ t) = normalize s `+ normalize t 62 | normalize (s `* t) = normalize s `* normalize t 63 | normalize (`Mu f) = `Mu (normalize f) 64 | normalize (`wk t) = ren su (normalize t) 65 | normalize (f `/ s) = normalize f / normalize s 66 | 67 | delta : forall {n f m} -> Fin n -> Fin n -> Reg f m 68 | delta ze ze = `1 69 | delta ze (su j) = `0 70 | delta (su i) ze = `0 71 | delta (su i) (su j) = delta i j 72 | 73 | dbyd : forall {n} -> Fin n -> Reg dgn n -> Reg dgn n 74 | dbyd x (# y) = delta x y 75 | dbyd x `0 = `0 76 | dbyd x `1 = `0 77 | dbyd x (s `+ t) = dbyd x s `+ dbyd x t 78 | dbyd x (s `* t) = (dbyd x s `* t) `+ (s `* dbyd x t) 79 | dbyd x (`Mu f) = 80 | `Mu (`wk (dbyd (su x) f `/ `Mu f) `+ 81 | (`wk (dbyd ze f `/ `Mu f) `* # ze)) 82 | dbyd ze (`wk t) = `0 83 | dbyd (su x) (`wk t) = `wk (dbyd x t) 84 | dbyd x (f `/ s) = 85 | (dbyd (su x) f `/ s) `+ 86 | ((dbyd ze f `/ s) `* dbyd x s) 87 | 88 | dbydn : forall {n} -> Fin n -> Reg nml n -> Reg nml n 89 | dbydn x (# y) = delta x y 90 | dbydn x `0 = `0 91 | dbydn x `1 = `0 92 | dbydn x (s `+ t) = dbydn x s `+ dbydn x t 93 | dbydn x (s `* t) = (dbydn x s `* t) `+ (s `* dbydn x t) 94 | dbydn x (`Mu f) = 95 | `Mu (ren su (dbydn (su x) f / `Mu f) `+ 96 | (ren su (dbydn ze f / `Mu f) `* # ze)) 97 | 98 | data Zero : Set where 99 | record One : Set where constructor <> 100 | data Two : Set where ff tt : Two 101 | record _><_ (S : Set)(T : S -> Set) : Set where 102 | constructor _,_ 103 | field 104 | fst : S 105 | snd : T fst 106 | open _><_ public 107 | _*_ _+_ : Set -> Set -> Set 108 | S * T = S >< \ _ -> T 109 | S + T = Two >< \ { ff -> S ; tt -> T } 110 | 111 | data Mu (f : Reg nml (su ze)) : Set 112 | [[_]] : Reg nml ze -> Set 113 | data Mu f where 114 | <_> : [[ f / `Mu f ]] -> Mu f 115 | [[ `0 ]] = Zero 116 | [[ `1 ]] = One 117 | [[ s `+ t ]] = [[ s ]] + [[ t ]] 118 | [[ s `* t ]] = [[ s ]] * [[ t ]] 119 | [[ `Mu f ]] = Mu f 120 | 121 | -------------------------------------------------------------------------------- /EWAM-Crib.agda: -------------------------------------------------------------------------------- 1 | module EWAM-Crib where 2 | 3 | 4 | data Nat : Set where 5 | ze : Nat 6 | su : Nat -> Nat 7 | {-# BUILTIN NATURAL Nat #-} 8 | 9 | natElim : forall {l} 10 | (n : Nat) -- target 11 | (P : Nat -> Set l) -- motive 12 | (z : P ze) -- methods 13 | (s : (k : Nat) -> P k -> P (su k)) 14 | -> 15 | P n -- the return type is an instance of the motive 16 | 17 | natElim ze P z s = z 18 | natElim (su k) P z s = s k (natElim k P z s) 19 | 20 | natCase : forall {l} 21 | (n : Nat) -- target 22 | (P : Nat -> Set l) -- motive 23 | (z : P ze) -- methods 24 | (s : (k : Nat) -> P (su k)) 25 | -> 26 | P n -- the return type is an instance of the motive 27 | natCase n P z s = natElim n P z \ k kh -> s k 28 | 29 | {- 30 | plus : Nat -> Nat -> Nat 31 | plus = \ x -> natElim x (\ x -> Nat -> Nat) (\ y -> y) (\ x plusx y -> su (plusx y)) 32 | -} 33 | 34 | mutual 35 | 36 | data _=? {X : Set} : X -> Set where 37 | [_]=_ : (x y : X) -> x =? 38 | 39 | [_]? : forall {X}(x : X){p : x =?} -> X 40 | [ x ]?{[ .x ]= y} = y 41 | 42 | postulate `plus : Nat -> Nat -> Nat 43 | 44 | mkPlus : (x y : Nat) -> `plus x y =? 45 | mkPlus x y = natElim x (\ x -> (y : Nat) -> `plus x y =?) 46 | (\ y -> [ `plus ze y ]= y) 47 | (\ x xh y -> [ `plus (su x) y ]= su ([ `plus x y ]?{xh y})) 48 | y 49 | 50 | plus : Nat -> Nat -> Nat 51 | plus x y = [ `plus x y ]?{mkPlus x y} 52 | 53 | data _~_ {X : Set}(x : X) : X -> Set where 54 | r~ : x ~ x 55 | 56 | R~ : {X : Set}(x : X) -> x ~ x 57 | R~ x = r~ 58 | 59 | J : forall {l}{X : Set}{x y : X}(q : x ~ y) 60 | (P : (y : X)(q : x ~ y) -> Set l) 61 | (px : P x r~) 62 | -> 63 | P y q 64 | J r~ P px = px 65 | 66 | _~$~_ : {S T : Set} 67 | {f g : S -> T} -> f ~ g -> 68 | {x y : S} -> x ~ y -> 69 | f x ~ g y 70 | _~$~_ {S}{T}{f}{g} fg {x}{y} xy = J fg (\ g q -> {x y : _} -> x ~ y -> f x ~ g y) 71 | (\ {x}{y} xy -> J xy (\ y q -> f x ~ f y) r~) 72 | xy 73 | 74 | asso : (x y z : Nat) -> plus (plus x y) z ~ plus x (plus y z) 75 | asso x y z = natElim x (\ x -> (y z : Nat) -> plus (plus x y) z ~ plus x (plus y z)) 76 | (\ y z -> r~) 77 | (\ x xh y z -> R~ su ~$~ xh y z) 78 | y z 79 | 80 | record One {l} : Set l where constructor <> 81 | record _><_ {l}(S : Set l)(T : S -> Set l) : Set l where 82 | constructor _,_ 83 | field 84 | fst : S 85 | snd : T fst 86 | open _><_ 87 | infixr 10 _,_ 88 | 89 | TEL : Nat -> Set1 90 | TEL n = natElim n (\ _ -> Set1) 91 | One 92 | \ n H -> Set >< \ X -> X -> H 93 | 94 | EL : forall n -> TEL n -> Set 95 | EL n = natElim n (\ n -> TEL n -> Set) 96 | (\ <> -> One) 97 | \ n nH (X , T) -> X >< \ x -> nH (T x) 98 | 99 | TELQ : forall n -> (T : TEL n)(as bs : EL n T) -> Set 100 | TELQ n = natElim n (\ n -> (T : TEL n)(as bs : EL n T) -> Set) 101 | (\ <> <> <> -> One) 102 | \ n nH (X , T) (a , as) (b , bs) -> 103 | (a ~ b) >< \ q -> nH (T a) as 104 | (J q (\ b q -> EL n (T b) -> EL n (T a)) (\ bs -> bs) bs) 105 | 106 | data Tel : Nat -> Set1 where 107 | [] : Tel ze 108 | _,-_ : forall {n}(X : Set)(T : X -> Tel n) -> Tel (su n) 109 | El : forall {n} -> Tel n -> Set 110 | El [] = One 111 | El (X ,- T) = X >< \ x -> El (T x) 112 | 113 | TelQ : forall {n}(T : Tel n) -> El T -> El T -> Set 114 | TelQ [] <> <> = One 115 | TelQ (X ,- T) (a , as) (b , bs) = (a ~ b) >< \ q -> TelQ (T b) (J q (\ a q -> El (T a)) as) bs 116 | 117 | NoConfNat : (n m : Nat)(G : (n ~ m) -> Set) -> Set 118 | NoConfNat ze ze G = G r~ 119 | NoConfNat ze (su m) G = One 120 | NoConfNat (su n) ze G = One 121 | NoConfNat (su n) (su m) G = (q : n ~ m) -> G (R~ su ~$~ q) 122 | noConfNat : {n m : Nat}(q : n ~ m)(G : (n ~ m) -> Set) -> NoConfNat n m G -> G q 123 | noConfNat {n} q G h = J q (\ m q -> (G : (n ~ m) -> Set) -> NoConfNat n m G -> G q) 124 | (natElim n (\ n -> (G : n ~ n -> Set) -> NoConfNat n n G -> G r~) 125 | (\ G h -> h) 126 | (\ k kh G h -> h r~) ) 127 | G h 128 | 129 | data Vec (X : Set) : Nat -> Set where 130 | [] : Vec X ze 131 | _,-_ : forall {n} -> X -> Vec X n -> Vec X (su n) 132 | infixr 20 _,-_ 133 | 134 | vecElim : forall {l}{X : Set}{n : Nat}(xs : Vec X n) 135 | (P : (n : Nat) -> Vec X n -> Set l) 136 | (z : P ze []) 137 | (s : {n : Nat}(x : X)(xs : Vec X n) -> P n xs -> P (su n) (x ,- xs)) 138 | -> 139 | P n xs 140 | vecElim [] P z s = z 141 | vecElim (x ,- xs) P z s = s x xs (vecElim xs P z s) 142 | 143 | vtail : {Y : Set}{m : Nat}(ys : Vec Y (su m)) -> Vec Y m 144 | vtail {Y}{m} ys = vecElim ys 145 | (\ n xs -> {m : Nat}(ys : Vec Y (su m)) 146 | -> TELQ 2 (Nat , \ n -> Vec Y n , \ _ -> <>) (su m , ys , <>) (n , xs , <>) 147 | -> Vec Y m) 148 | (\ {m} ys (q0 , q1 , <>) -> 149 | noConfNat q0 (\ _ -> Vec Y m) <>) 150 | (\ {n} x xs h {m} ys (q0 , q1 , <>) -> 151 | noConfNat q0 (\ q0 -> ys ~ 152 | fst 153 | (J q0 154 | (λ b q → 155 | EL 1 (Vec Y b , (λ _ → <>)) → EL 1 (Vec Y (su m) , (λ _ → <>))) 156 | (λ bs → bs) (x ,- xs , <>)) 157 | -> Vec Y m) 158 | (\ q2 -> J q2 (\ n q2 -> (xs : Vec Y n) -> 159 | ys ~ 160 | fst 161 | (J (R~ su ~$~ q2) 162 | (λ b q → 163 | EL 1 (Vec Y b , (λ _ → <>)) → EL 1 (Vec Y (su m) , (λ _ → <>))) 164 | (λ bs → bs) (x ,- xs , <>)) → 165 | Vec Y m) 166 | (\ xs _ -> xs) 167 | xs) 168 | q1 ) 169 | ys (r~ , r~ , <>) 170 | 171 | trichotomy : (n m : Nat) 172 | (P : Nat -> Nat -> Set) 173 | (lt : (n m : Nat) -> P n (plus n (su m))) 174 | (eq : (n : Nat) -> P n n) 175 | (gt : (n m : Nat) -> P (plus n (su m)) n) 176 | -> 177 | P n m 178 | trichotomy = \ n -> natElim n (\ n -> (m : Nat) 179 | (P : Nat -> Nat -> Set) 180 | (lt : (n m : Nat) -> P n (plus n (su m))) 181 | (eq : (n : Nat) -> P n n) 182 | (gt : (n m : Nat) -> P (plus n (su m)) n) 183 | -> 184 | P n m) 185 | (\ m -> natElim m (\ m -> (P : Nat → Nat → Set) → 186 | ((n₂ m₁ : Nat) → P n₂ (plus n₂ (su m₁))) → 187 | ((n₂ : Nat) → P n₂ n₂) → 188 | ((n₂ m₁ : Nat) → P (plus n₂ (su m₁)) n₂) → P ze m) 189 | (\ P lt eq gt -> eq ze) 190 | \ m h P lt eq gt -> lt ze m) 191 | \ n nh m -> natElim m (\ m -> (P : Nat → Nat → Set) → 192 | ((n₁ m₁ : Nat) → P n₁ (plus n₁ (su m₁))) → 193 | ((n₁ : Nat) → P n₁ n₁) → 194 | ((n₁ m₁ : Nat) → P (plus n₁ (su m₁)) n₁) → P (su n) m 195 | ) 196 | (\ P lt eq gt -> gt ze n) 197 | \ m mh P lt eq gt -> nh m (\ n m -> P (su n) (su m)) 198 | (\ n m -> lt (su n) m) 199 | (\ n -> eq (su n)) 200 | (\ n m -> gt (su n) m) 201 | 202 | natPlusRec : (n : Nat) 203 | (P : Nat -> Set) 204 | (h : (n : Nat)(p : (x y : Nat) -> n ~ su (plus x y) -> P y) -> P n) 205 | -> 206 | P n 207 | natPlusRec n P h = h n (natElim n (\ n -> (x y : Nat) → n ~ su (plus x y) → P y) 208 | (\ x y q -> noConfNat q (\ _ -> P y) <>) 209 | \ n nh x -> natCase x (\ x -> (y : Nat) → su n ~ su (plus x y) → P y) 210 | (\ y q -> noConfNat q (\ _ -> P y) \ q' -> J q' (\ y _ -> P y) (h n nh)) 211 | \ x y q -> noConfNat q (\ _ -> P y) \ q' -> nh x y q') 212 | 213 | postulate gcd' : Nat -> Nat -> Nat 214 | mkGcd : (x y : Nat) -> gcd' x y =? 215 | mkGcd x y = natPlusRec x (\ x -> (y : Nat) -> gcd' x y =?) 216 | (\ x xh y -> natPlusRec y (\ y -> gcd' x y =?) 217 | \ y yh -> natCase x (\ x -> 218 | ((x₂ y₃ : Nat) → 219 | x ~ su (plus x₂ y₃) → (y₄ : Nat) → gcd' y₃ y₄ =?) -> 220 | ((x₂ y₃ : Nat) → y ~ su (plus x₂ y₃) → gcd' x y₃ =?) -> 221 | gcd' x y =?) 222 | (\ xh yh -> [ gcd' ze y ]= y) 223 | (\ x xh yh -> natCase y (\ y -> ((x₂ y₃ : Nat) → y ~ su (plus x₂ y₃) → gcd' (su x) y₃ =?) 224 | -> gcd' (su x) y =?) 225 | (\ yh -> [ gcd' (su x) ze ]= su x) 226 | (\ y yh -> trichotomy x y (\ x y -> 227 | ((x₂ y₃ : Nat) → 228 | su x ~ su (plus x₂ y₃) → (y₄ : Nat) → gcd' y₃ y₄ =?) -> 229 | ((x₂ y₃ : Nat) → 230 | su y ~ su (plus x₂ y₃) → gcd' (su x) y₃ =?) -> 231 | gcd' (su x) (su y) =?) 232 | (\ n m xh yh -> [ gcd' (su n) (su (plus n (su m))) ]= 233 | [ gcd' (su n) (su m) ]?{yh n (su m) r~}) 234 | (\ n xh yh -> [ gcd' (su n) (su n) ]= su n) 235 | (\ n m xh yh -> [ gcd' (su (plus n (su m))) (su n) ]= 236 | [ gcd' (su m) (su n) ]?{xh n (su m) r~ (su n)}) 237 | xh yh) 238 | yh) 239 | xh yh) 240 | y 241 | 242 | gcd : Nat -> Nat -> Nat 243 | gcd x y = [ gcd' x y ]?{mkGcd x y} 244 | -------------------------------------------------------------------------------- /FamPowSet.agda: -------------------------------------------------------------------------------- 1 | module FamPowSet where 2 | 3 | ------------------------------------------------------ 4 | -- diagrammatic composition; would prefer semicolon -- 5 | ------------------------------------------------------ 6 | _%_ : forall {i j k}{R : Set i}{S : Set j}{T : Set k} 7 | -> (R -> S) -> (S -> T) -> R -> T 8 | (f % g) x = g (f x) 9 | 10 | ------------------------------------------ 11 | -- overly intensional equality, but hey -- 12 | ------------------------------------------ 13 | data _~_ {X : Set}(x : X) : X -> Set where 14 | r~ : x ~ x 15 | {-# BUILTIN EQUALITY _~_ #-} 16 | 17 | sym : forall {X : Set}{x y : X} -> x ~ y -> y ~ x 18 | sym r~ = r~ 19 | 20 | refl : forall {X}(x : X) -> x ~ x 21 | refl _ = r~ 22 | 23 | _~$~_ : forall {X Y}{f g : X -> Y}{a b : X} -> f ~ g -> a ~ b -> f a ~ g b 24 | r~ ~$~ r~ = r~ 25 | 26 | -------------------------------- 27 | -- dependent pairs made infix -- 28 | -------------------------------- 29 | record _><_ (S : Set)(T : S -> Set) : Set where 30 | constructor _,_ 31 | field 32 | fst : S 33 | snd : T fst 34 | open _><_ public 35 | 36 | --------------------------------- 37 | -- What is (small) Fam? --------- 38 | --------------------------------- 39 | {- 40 | Fam is the covariant proof-relevant power set functor. 41 | Fam X picks a subset of X as the image of a function. 42 | -} 43 | record Fam (X : Set) : Set1 where 44 | constructor _$_ 45 | field 46 | Pre : Set 47 | img : Pre -> X 48 | open Fam public 49 | 50 | {- Yes, it's covariant. -} 51 | FAM : forall {X Y} -> (X -> Y) -> Fam X -> Fam Y 52 | FAM f (P $ i) = P $ (i % f) 53 | 54 | {- 55 | Now, an arrow between Fams is a mediating map on 56 | pre-images which respects the image maps. 57 | -} 58 | _=Fam>_ : forall {X} -> Fam X -> Fam X -> Set 59 | (P $ i) =Fam> (Q $ j) = 60 | -- (P -> Q) >< \ f -> i ~ (f % j) {- not today! choice away! -} 61 | (p : P) -> Q >< \ q -> i p ~ j q 62 | 63 | --------------------------------- 64 | -- What is (small) Pow? --------- 65 | --------------------------------- 66 | {- 67 | Pow is the contravariant proof-relevant power set functor. 68 | Pow X picks a subset of X by "predicate" comprehension. 69 | -} 70 | Pow : Set -> Set1 71 | Pow X = X -> Set 72 | 73 | {- Yes, it's covariant. -} 74 | POW : forall {X Y} -> (Y -> X) -> Pow X -> Pow Y 75 | POW f P = f % P 76 | 77 | {- Arrows between pows are "predicate" implications. -} 78 | _=Pow>_ : forall {X} -> Pow X -> Pow X -> Set 79 | P =Pow> Q = forall x -> P x -> Q x 80 | 81 | -------------------------------------- 82 | -- Forgetful Interaction Structures -- 83 | -------------------------------------- 84 | record Interface : Set1 where 85 | constructor _!_/_ 86 | field 87 | Memo : Set -- what we remember 88 | Play : Fam Memo -- how we can play 89 | Oppo : Pow Memo -- how opponent can respond 90 | open Interface public 91 | {- 92 | If Memo is 1, Play and Oppo amount to Set. 93 | If Play is (Memo $ id), you have dependent interactions. 94 | -} 95 | 96 | {- 97 | strategies achieving a goal by one step of interaction 98 | -} 99 | Step : (X : Interface) -> Set -> Set 100 | Step (M ! P / O) G 101 | = Pre P >< \ p -- choose a play 102 | -> (o : O (img P p)) -- wait for a response 103 | -> G -- deliver the goal 104 | 105 | ------------------------------------------------------ 106 | -- morphisms between interfaces ---------------------- 107 | ------------------------------------------------------ 108 | record _=>_ (S : Interface)(T : Interface) : Set where 109 | field 110 | translate : Memo S -> Memo T 111 | forwards : FAM translate (Play S) =Fam> Play T 112 | backwards : POW translate (Oppo T) =Pow> Oppo S 113 | open _=>_ public 114 | 115 | {- 116 | morphisms between interfaces transform strategies 117 | -} 118 | xform : forall {S T} -> S => T -> forall {G} -> Step S G -> Step T G 119 | fst (xform F (p , r)) with p' , _ <- forwards F p = p' 120 | snd (xform {S}{T} F (p , r)) o 121 | with p' , q <- forwards F p 122 | | back <- backwards F (img (Play S) p) 123 | rewrite q 124 | = r (back o) 125 | 126 | -------------------------------------------------------------------------------- /Full.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable, FlexibleInstances #-} 2 | 3 | module Full where 4 | 5 | import Debug.Trace 6 | 7 | data Fm' x -- yer maw 8 | = V x -- the variable 9 | | Z -- zero 10 | | D (Fm' x) -- double 11 | | S (Fm' x) -- successor 12 | | F (Fm' x) -- full 13 | deriving (Eq, Ord, Functor, Foldable, Traversable) 14 | 15 | type Var = Int 16 | type Fm = Fm' Var 17 | 18 | db :: Fm -> Fm 19 | db Z = Z 20 | db (S f) = S (S (db f)) 21 | db f = D f 22 | 23 | fu :: Fm -> Fm 24 | fu Z = Z 25 | fu (S f) = S (db (fu f)) 26 | fu f = F f 27 | 28 | type Store = 29 | ( Int -- name supply 30 | , [(Var, Fm)] -- defs var = nm 31 | ) 32 | 33 | nm :: Fm -> Store -> Fm 34 | nm (V x) ga = va x ga 35 | nm Z ga = Z 36 | nm (S f) ga = S (nm f ga) 37 | nm (D f) ga = db (nm f ga) 38 | nm (F f) ga = fu (nm f ga) 39 | 40 | va :: Var -> Store -> Fm 41 | va x (_ , xns) = case lookup x xns of 42 | Just n -> n 43 | Nothing -> V x 44 | 45 | -- you *have* done the occur check, haven't you? 46 | gro :: Var -> Fm -> Store -> Store 47 | gro x f (k, xns) = (k, (x, f) : map (sb x f <$>) xns) 48 | 49 | sb :: Var -> Fm -> Fm -> Fm 50 | sb x f (V y) = if x == y then f else V y 51 | sb x f Z = Z 52 | sb x f (S g) = S (sb x f g) 53 | sb x f (D g) = db (sb x f g) 54 | sb x f (F g) = fu (sb x f g) 55 | 56 | unify :: Fm -> Fm -> Store -> Maybe Store 57 | unify f g ga = go (nm f ga) (nm g ga) where 58 | go f g | trace (show f ++ " =? " ++ show g) False = undefined 59 | go f g | f == g = pure ga 60 | go f g | f > g = go g f 61 | go (V x) g = case occ x g of 62 | False -> pure (gro x g ga) 63 | True -> zee g ga 64 | go Z g = zee g ga 65 | go (D f) g = do 66 | (h, ga) <- evn g ga 67 | unify f h ga 68 | go (S f) g = do 69 | (h, ga) <- suu g ga 70 | unify f h ga 71 | go (F f) (F g) = go f g 72 | go _ _ = Nothing 73 | 74 | occ :: Int -> Fm -> Bool 75 | occ x = any (x ==) 76 | 77 | -- Fm is normal 78 | zee :: Fm -> Store -> Maybe Store 79 | zee (V x) ga = pure (gro x Z ga) 80 | zee Z ga = Just ga 81 | zee (S _) ga = Nothing 82 | zee (D f) ga = zee f ga 83 | zee (F f) ga = zee f ga 84 | 85 | -- Fm is normal 86 | suu :: Fm -> Store -> Maybe (Fm, Store) 87 | suu (V x) (k, xns) = pure (V k, gro x (S (V k)) (k+1, xns)) 88 | suu Z ga = Nothing 89 | suu (S f) ga = pure (f, ga) 90 | suu (D f) ga = do 91 | (g, ga) <- suu f ga 92 | pure (S (db g), ga) 93 | suu (F f) ga = do 94 | (g, ga) <- suu f ga 95 | pure (db (fu g), ga) 96 | 97 | -- Fm is normal 98 | evn :: Fm -> Store -> Maybe (Fm, Store) 99 | evn (V x) (k, xns) = pure (V k, gro x (D (V k)) (k+1, xns)) 100 | evn Z ga = pure (Z, ga) 101 | evn (S f) ga = do 102 | (g, ga) <- ood f ga 103 | pure (S g, ga) 104 | evn (D f) ga = pure (f, ga) 105 | evn (F f) ga = do 106 | ga <- zee f ga 107 | pure (Z, ga) 108 | 109 | -- Fm is normal 110 | ood :: Fm -> Store -> Maybe (Fm, Store) 111 | ood (V x) (k, xns) = pure (V k, gro x (S (D (V k))) (k+1, xns)) 112 | ood Z _ = Nothing 113 | ood (S f) ga = do 114 | (g, ga) <- evn f ga 115 | pure (g, ga) 116 | ood (D _) _ = Nothing 117 | ood (F f) ga = do 118 | (g, ga) <- suu f ga 119 | pure (fu g, ga) 120 | 121 | 122 | instance Show Fm where 123 | show f = go (nm f (0, [])) where 124 | go (V x) = "V" ++ show x 125 | go Z = "0" 126 | go (S f) = mo 1 f where 127 | mo :: Integer -> Fm -> String 128 | mo k Z = show k 129 | mo k (S f) = mo (k+1) f 130 | mo k f = show k ++ "+" ++ go f 131 | go (D f) = mo 1 f where 132 | mo :: Integer -> Fm -> String 133 | mo k (D f) = mo (k+1) f 134 | mo k f = po k ++ "*" ++ go f 135 | po i = if length a <= length b then a else b where 136 | a = show (2 ^ i) 137 | b = "2^" ++ show i 138 | go (F f) = "[" ++ go f ++ "]" 139 | 140 | instance Num Fm where 141 | fromInteger 0 = Z 142 | fromInteger n = S (fromInteger (n - 1)) 143 | Z + f = f 144 | f + Z = f 145 | S f + g = S (f + g) 146 | f + S g = S (f + g) 147 | D f + D g = db (f + g) 148 | x + y | x == y = db x 149 | Z * f = Z 150 | f * Z = Z 151 | S f * g = g + (f * g) 152 | f * S g = f + (f * g) 153 | D f * g = db (f * g) 154 | f * D g = db (f * g) 155 | negate Z = Z 156 | signum Z = Z 157 | signum _ = S Z 158 | abs x = x 159 | 160 | {- DIVERGING in VZSDF order, but not VZDSF 161 | unify (S (F (D (V 0)))) (D (F (V 0))) (1, []) 162 | unify (S (F (D (V 0)))) (D (F (V 1))) (2, []) 163 | unify (S (S (S (S (S (D (V 0))))))) (D (D (D (V 1)))) (2, []) 164 | -} -------------------------------------------------------------------------------- /Full/Basics.agda: -------------------------------------------------------------------------------- 1 | module Basics where 2 | 3 | id : forall {l}{X : Set l} -> X -> X 4 | id x = x 5 | 6 | K-_ : forall {k l}{X : Set k}{Y : Set l} -> (x : X)(y : Y) -> X 7 | (K- x) y = x 8 | 9 | _-_ : forall {i j k}{A : Set i}{B : A -> Set j}{C : (a : A) -> B a -> Set k} 10 | (f : (a : A) -> B a) 11 | (g : {a : A}(b : B a) -> C a b) 12 | (a : A) -> C a (f a) 13 | (f - g) a = g (f a) 14 | infixl 10 _-_ 15 | 16 | data _~_ {X : Set}(x : X) : X -> Set where 17 | r~ : x ~ x 18 | infix 2 _~_ 19 | {-# BUILTIN EQUALITY _~_ #-} 20 | 21 | sym : forall {X}{x y : X} -> x ~ y -> y ~ x 22 | sym r~ = r~ 23 | 24 | 25 | module _ {X : Set}(x : X) where 26 | 27 | _~[_>_ : forall {y z : X} -> x ~ y -> y ~ z -> x ~ z 28 | _~[_>_ r~ q = q 29 | _<_]~_ : forall {y z : X} -> y ~ x -> y ~ z -> x ~ z 30 | _<_]~_ r~ q = q 31 | _[QED] : x ~ x 32 | _[QED] = r~ 33 | infixr 1 _~[_>_ _<_]~_ 34 | infixr 2 _[QED] 35 | 36 | _~$~_ : forall {S T}{f g : S -> T} -> f ~ g -> {x y : S} -> x ~ y -> f x ~ f y 37 | r~ ~$~ r~ = r~ 38 | 39 | _$~_ : forall {S T}(f : S -> T){x y : S} -> x ~ y -> f x ~ f y 40 | f $~ q = (f [QED]) ~$~ q 41 | 42 | data Zero : Set where 43 | 44 | magic : forall {l}{X : Set l} -> Zero -> X 45 | magic () 46 | 47 | record One : Set where constructor <> 48 | 49 | data Two : Set where ff tt : Two 50 | 51 | record _><_ (S : Set)(T : S -> Set) : Set where 52 | constructor _,_ 53 | field 54 | fst : S 55 | snd : T fst 56 | open _><_ public 57 | _*_ : Set -> Set -> Set 58 | S * T = S >< \ _ -> T 59 | infixr 10 _,_ _*_ 60 | 61 | data Nat : Set where 62 | ze : Nat 63 | su-_ : Nat -> Nat 64 | 65 | {-# BUILTIN NATURAL Nat #-} 66 | 67 | NatNoConf : Nat -> Nat -> Set 68 | NatNoConf ze ze = One 69 | NatNoConf ze (su- y) = Zero 70 | NatNoConf (su- x) ze = Zero 71 | NatNoConf (su- x) (su- y) = x ~ y 72 | 73 | natNoConf : {x y : Nat} -> x ~ y -> NatNoConf x y 74 | natNoConf {ze} r~ = _ 75 | natNoConf {su- x} r~ = r~ 76 | 77 | _+N_ : Nat -> Nat -> Nat 78 | ze +N y = y 79 | (su- x) +N y = su- (x +N y) 80 | 81 | du-_ : Nat -> Nat 82 | du- ze = ze 83 | du- su- n = su- su- du- n 84 | 85 | bu-_ : Nat -> Nat 86 | bu- n = su- du- n 87 | 88 | fu-_ : Nat -> Nat 89 | fu- ze = ze 90 | fu- su- n = bu- fu- n 91 | -------------------------------------------------------------------------------- /Full/Cat.agda: -------------------------------------------------------------------------------- 1 | module Cat where 2 | 3 | open import Basics 4 | 5 | data Obj : Set where 6 | `0 `1 `N : Obj 7 | 8 | FObj : Obj -> Set 9 | FObj `0 = Zero 10 | FObj `1 = One 11 | FObj `N = Nat 12 | 13 | record _>>_ (S T : Obj) : Set where 14 | constructor go 15 | field 16 | fo : FObj S -> FObj T 17 | open _>>_ public 18 | 19 | FARR : (A : Obj -> Obj -> Set) -> Set 20 | FARR A = forall {S T} -> A S T -> S >> T 21 | -- Mia Farra borra marra furra farra! 22 | 23 | iA : forall {X} -> X >> X 24 | iA = go id 25 | 26 | eA : forall {X} -> FObj X -> `1 >> X 27 | eA x = go (K- x) 28 | 29 | nA : forall {X} -> `0 >> X 30 | nA = go magic 31 | 32 | _->-_ : forall {R S T} -> R >> S -> S >> T -> R >> T 33 | go f ->- go g = go (f - g) 34 | 35 | Inj : forall {X Y} -> X >> Y -> Set 36 | Inj f = forall {a b} -> fo f a ~ fo f b -> a ~ b 37 | 38 | _~><~_ : forall {S T} -> S >> T -> S >> T -> Set 39 | go f ~><~ go g = forall x -> f x ~ g x 40 | 41 | injCo : forall {R S T}{f0 f1 : R >> S}{g : S >> T} 42 | -> Inj g 43 | -> (f0 ->- g) ~><~ (f1 ->- g) 44 | -> f0 ~><~ f1 45 | injCo gi q x = gi (q x) 46 | 47 | module _ {S T : Obj} where 48 | _~!_>_ : forall (f : S >> T){g h} -> f ~><~ g -> g ~><~ h -> f ~><~ h 49 | _~!_>_ (go f) {go g} {go h} p q x = f x ~[ p x > g x ~[ q x > h x [QED] 50 | _<_!~_ : forall (f : S >> T){g h} -> g ~><~ f -> g ~><~ h -> f ~><~ h 51 | _<_!~_ (go f) {go g} {go h} p q x = f x < p x ]~ g x ~[ q x > h x [QED] 52 | _[==] : (f : S >> T) -> f ~><~ f 53 | _[==] (go f) x = f x [QED] 54 | infixr 1 _~!_>_ _<_!~_ 55 | infixr 2 _[==] 56 | 57 | module _ {R S T : Obj} where 58 | _~>~_ : {f0 f1 : R >> S}(fq : f0 ~><~ f1) 59 | -> {g0 g1 : S >> T}(gq : g0 ~><~ g1) 60 | -> (f0 ->- g0) ~><~ (f1 ->- g1) 61 | (fq ~>~ gq) x rewrite fq x = gq _ 62 | 63 | data _-[_/_]-_ (R : Obj)(A : Obj -> Obj -> Set) 64 | : Nat -> Obj -> Set where 65 | [] : R -[ A / ze ]- R 66 | _-,_ : forall {S T n} -> R -[ A / n ]- S -> A S T 67 | -> R -[ A / su- n ]- T 68 | 69 | infixl 10 _-,_ 70 | 71 | ncomp : forall {n A} -> FARR A -> FARR (_-[ A / n ]-_) 72 | ncomp fa [] = iA 73 | ncomp fa (as -, a) = ncomp fa as ->- fa a 74 | 75 | map : forall {A B n S T} 76 | -> (forall {S T} -> A S T -> B S T) 77 | -> S -[ A / n ]- T -> S -[ B / n ]- T 78 | map ab [] = [] 79 | map ab (as -, a) = map ab as -, ab a 80 | 81 | map-ncomp : forall {A B} 82 | (fa : FARR A)(fb : FARR B) 83 | (ab : forall {S T} -> A S T -> B S T) 84 | -> (forall {S T}(a : A S T) -> fa a ~><~ fb (ab a)) 85 | -> forall {n S T}(as : S -[ A / n ]- T) -> ncomp fa as ~><~ ncomp fb (map ab as) 86 | map-ncomp fa fb ab q [] = _ [==] 87 | map-ncomp fa fb ab q (as -, a) = map-ncomp fa fb ab q as ~>~ q a 88 | 89 | _++_ : forall {n m A R S T} 90 | -> R -[ A / n ]- S 91 | -> S -[ A / m ]- T 92 | -> R -[ A / (m +N n) ]- T 93 | fs ++ [] = fs 94 | fs ++ (gs -, g) = (fs ++ gs) -, g 95 | 96 | catComp : forall {n m A R S T}(fa : FARR A) 97 | (fs : R -[ A / n ]- S) 98 | (gs : S -[ A / m ]- T) 99 | -> (ncomp fa fs ->- ncomp fa gs) ~><~ 100 | ncomp fa (fs ++ gs) 101 | catComp fa fs [] = ncomp fa fs [==] 102 | catComp fa fs (gs -, g) = catComp fa fs gs ~>~ (fa g [==]) 103 | 104 | _-[_]-_ : Obj -> (Obj -> Obj -> Set) -> Obj -> Set 105 | S -[ A ]- T = Nat >< \ n -> S -[ A / n ]- T 106 | 107 | nil : forall {A T} -> T -[ A ]- T 108 | nil = ze , [] 109 | 110 | one : forall {A S T} -> A S T -> S -[ A ]- T 111 | one f = su- ze , ([] -, f) 112 | 113 | lcomp : forall {A} -> FARR A -> FARR (_-[ A ]-_) 114 | lcomp fa (n , fs) = ncomp {n} fa fs 115 | 116 | record _&_ (A B : Obj -> Obj -> Set)(R T : Obj) : Set where 117 | constructor _-&-_ 118 | field 119 | {middle} : Obj 120 | pre : A R middle 121 | post : B middle T 122 | open _&_ public 123 | 124 | _&&_ : forall {A B} -> FARR A -> FARR B -> FARR (A & B) 125 | (fa && fb) (a -&- b) = fa a ->- fb b 126 | 127 | -------------------------------------------------------------------------------- /Full/Pub.agda: -------------------------------------------------------------------------------- 1 | module Pub where 2 | 3 | open import Basics 4 | open import Cat 5 | 6 | record Pub[_>_]~[_>_] {S P Q R} 7 | (g* : S >> P)(f : P >> R)(f* : S >> Q)(g : Q >> R) : Set where 8 | field 9 | commutes : (g* ->- f) ~><~ (f* ->- g) 10 | universally : forall {S'}(g' : S' >> P)(f' : S' >> Q) 11 | -> (g' ->- f) ~><~ (f' ->- g) 12 | -> (S' >> S) >< \ h 13 | -> (g' ~><~ (h ->- g*)) 14 | * (f' ~><~ (h ->- f*)) 15 | open Pub[_>_]~[_>_] 16 | 17 | module _ {S P Q R} 18 | {g* g*' : S >> P}{f f' : P >> R}{f* f*' : S >> Q}{g g' : Q >> R} 19 | where 20 | 21 | pubResp[_>_]~[_>_] : 22 | g* ~><~ g*' -> f ~><~ f' -> f* ~><~ f*' -> g ~><~ g' 23 | -> Pub[ g* > f ]~[ f* > g ] 24 | -> Pub[ g*' > f' ]~[ f*' > g' ] 25 | commutes (pubResp[ g*q > fq ]~[ f*q > gq ] p) = 26 | (g*' ->- f') < g*q ~>~ fq !~ 27 | (g* ->- f) ~! commutes p > 28 | (f* ->- g) ~! f*q ~>~ gq > 29 | (f*' ->- g') [==] 30 | universally (pubResp[ g*q > fq ]~[ f*q > gq ] p) g0 f0 q0 31 | with h , l0 , r0 <- universally p g0 f0 ( 32 | (g0 ->- f) ~! (g0 [==]) ~>~ fq > 33 | (g0 ->- f') ~! q0 > 34 | (f0 ->- g') < (f0 [==]) ~>~ gq !~ 35 | (f0 ->- g) [==]) 36 | = h 37 | , (g0 ~! l0 > 38 | h ->- g* ~! (h [==]) ~>~ g*q > 39 | h ->- g*' [==]) 40 | , (f0 ~! r0 > 41 | h ->- f* ~! (h [==]) ~>~ f*q > 42 | h ->- f*' [==]) 43 | 44 | pubId : forall {Q R}(g : Q >> R) -> Pub[ g > iA ]~[ iA > g ] 45 | commutes (pubId g) = g [==] 46 | universally (pubId g) g' f' q = f' , q , (f' [==]) 47 | 48 | pubCo : forall {Q R S T U V} 49 | {g2 : Q >> R} 50 | {h* : Q >> S}{h : R >> T} 51 | {g1 : S >> T} 52 | {f* : S >> U}{f : T >> V} 53 | {g0 : U >> V} 54 | -> Pub[ g2 > h ]~[ h* > g1 ] 55 | -> Pub[ g1 > f ]~[ f* > g0 ] 56 | -> Pub[ g2 > (h ->- f) ]~[ (h* ->- f*) > g0 ] 57 | commutes (pubCo {g2 = g2} {h*} {h} {g1} {f*} {f} {g0} r s) = 58 | ((g2 ->- h) ->- f) ~! commutes r ~>~ (f [==]) > 59 | (h* ->- (g1 ->- f)) ~! (h* [==]) ~>~ commutes s > 60 | ((h* ->- f*) ->- g0) [==] 61 | universally (pubCo {g2 = g2} {h*} {h} {g1} {f*} {f} {g0} r s) a b q = 62 | let c , u , v = universally s (a ->- h) b 63 | (((a ->- h) ->- f) ~! q > 64 | (b ->- g0) [==]) in 65 | let d , x , y = universally r a c u in 66 | d , x , ( 67 | b ~! v > 68 | (c ->- f*) ~! y ~>~ (f* [==]) > 69 | (d ->- (h* ->- f*)) [==]) 70 | 71 | pubInj : forall {P R}{f : P >> R} -> Inj f -> Pub[ iA > f ]~[ iA > f ] 72 | commutes (pubInj fi) = _ [==] 73 | universally (pubInj fi) g' f' q 74 | = f' 75 | , injCo fi q 76 | , (_ [==]) 77 | 78 | pubFlip : forall {S P Q R} 79 | {g* : S >> P}{f : P >> R}{f* : S >> Q}{g : Q >> R} 80 | -> Pub[ g* > f ]~[ f* > g ] 81 | -> Pub[ f* > g ]~[ g* > f ] 82 | commutes (pubFlip s) = _ < commutes s !~ _ [==] 83 | universally (pubFlip s) f' g' q = 84 | let h , p , r = universally s g' f' (_ < q !~ _ [==]) in 85 | h , r , p 86 | 87 | pubNo : forall {P Q R} 88 | {g* : `0 >> P}{f : P >> R} 89 | {f* : `0 >> Q}{g : Q >> R} 90 | -> (forall {x y} -> fo f x ~ fo g y -> Zero) 91 | -> Pub[ g* > f ]~[ f* > g ] 92 | commutes (pubNo n) () 93 | universally (pubNo n) {`0} g' f' q = iA , (\ ()) , (\ ()) 94 | universally (pubNo n) {`1} g' f' q with () <- n (q <>) 95 | universally (pubNo n) {`N} g' f' q with () <- n (q ze) 96 | 97 | pubUn : forall {P Q R}{f : P >> R}{g : Q >> R} p q 98 | -> fo f p ~ fo g q 99 | -> (forall x y -> fo f x ~ fo g y -> (x ~ p) * (y ~ q)) 100 | -> Pub[ eA p > f ]~[ eA q > g ] 101 | commutes (pubUn p q y u) = \ _ -> y 102 | universally (pubUn p q y u) {`0} g' f' z = _ , (\ ()) , (\ ()) 103 | universally (pubUn p q y u) {`1} g' f' z = 104 | let s , t = u (fo g' <>) (fo f' <>) (z <>) in 105 | _ , K- s , K- t 106 | universally (pubUn p q y u) {`N} g' f' z = _ 107 | , (\ n -> let s , t = u (fo g' n) (fo f' n) (z n) in s) 108 | , (\ n -> let s , t = u (fo g' n) (fo f' n) (z n) in t) 109 | 110 | pubNa : {g* f f* g : Nat -> Nat} 111 | -> (forall n -> f (g* n) ~ g (f* n)) 112 | -> (forall x y -> f x ~ g y -> Nat >< \ z -> (x ~ g* z) * (y ~ f* z)) 113 | -> Pub[ go g* > go f ]~[ go f* > go g ] 114 | commutes (pubNa y u) = y 115 | universally (pubNa y u) {`0} g' f' q = nA , (\ ()) , (\ ()) 116 | universally (pubNa y u) {`1} g' f' q = 117 | let n , s , t = u (fo g' <>) (fo f' <>) (q <>) in 118 | go (K- n) , (K- s) , (K- t) 119 | universally (pubNa y u) {`N} g' f' q 120 | = (go \ n -> fst (u (fo g' n) (fo f' n) (q n))) 121 | , (\ n -> fst (snd (u (fo g' n) (fo f' n) (q n)))) 122 | , (\ n -> snd (snd (u (fo g' n) (fo f' n) (q n)))) 123 | -------------------------------------------------------------------------------- /Full/Quad.agda: -------------------------------------------------------------------------------- 1 | module Quad where 2 | 3 | open import Basics 4 | open import Cat 5 | open import Pub 6 | 7 | module _ {B* A A* B} 8 | (fb* : FARR B*)(fa : FARR A)(fa* : FARR A*)(fb : FARR B) where 9 | 10 | Quadrifier : Set 11 | Quadrifier = forall {P Q R}(f : A P R)(g : B Q R) 12 | -> Obj >< \ S -> B* S P >< \ g* -> A* S Q >< \ f* 13 | -> Pub[ fb* g* > fa f ]~[ fa* f* > fb g ] 14 | 15 | module _ {B* A A* B} 16 | {fb* : FARR B*}{fa : FARR A}{fa* : FARR A*}{fb : FARR B} 17 | (r : Quadrifier fb* fa fa* fb) where 18 | 19 | qflip : Quadrifier fa* fb fb* fa 20 | qflip g f with _ , g* , f* , p <- r f g = _ , f* , g* , pubFlip p 21 | 22 | module _ {A B}(fa : FARR A)(fb : FARR B) where 23 | 24 | Rectifier : Set 25 | Rectifier = Quadrifier fb fa fa fb 26 | 27 | module _ {B* A B} 28 | {fb* : FARR B*}{fa : FARR A}{fb : FARR B} 29 | (r : Quadrifier fa fb* fb fa) where 30 | 31 | qstrip : forall {n} -> 32 | Quadrifier fa (ncomp {n} fb*) (ncomp {n} fb) fa 33 | qstrip [] g = _ , g , [] , pubId _ 34 | qstrip (fs -, f) g0 35 | with _ , g1 , f* , p1 <- r f g0 36 | with _ , g2 , fs* , p2 <- qstrip fs g1 37 | = _ , g2 , (fs* -, f*) , pubCo p2 p1 38 | 39 | module _ {A B}{fa : FARR A}{fb : FARR B} 40 | (r : Rectifier fa fb) where 41 | 42 | rect : forall {n m} -> Rectifier (ncomp {n} fa) (ncomp {m} fb) 43 | rect = qstrip (qflip (qstrip (qflip r))) 44 | -------------------------------------------------------------------------------- /Full/Term.agda: -------------------------------------------------------------------------------- 1 | module Term where 2 | 3 | open import Basics 4 | open import Cat 5 | 6 | record Variant : Set where 7 | constructor va 8 | field 9 | hasSu : Two 10 | hasBuDu : Two 11 | hasFu : Two 12 | open Variant public 13 | 14 | data Fun : Variant -> Obj -> Obj -> Set where 15 | `id : forall {V X} -> Fun V X X 16 | `no : forall {V X} -> Fun V `0 X 17 | `ze : forall {V} -> Fun V `1 `N 18 | `su : forall {b f} -> Fun (va tt b f) `N `N 19 | `du : forall {s f} -> Fun (va s tt f) `N `N 20 | `bu : forall {s f} -> Fun (va s tt f) `N `N 21 | `fu : forall {s b} -> Fun (va s b tt) `N `N 22 | 23 | [_]F : {V : Variant} -> FARR (Fun V) 24 | [ `id ]F = go id 25 | [ `no ]F = go magic 26 | [ `ze ]F = go (K- ze) 27 | [ `su ]F = go su-_ 28 | [ `du ]F = go du-_ 29 | [ `bu ]F = go bu-_ 30 | [ `fu ]F = go fu-_ 31 | 32 | INJ : forall {A} -> FARR A -> Set 33 | INJ {A} farra = forall {S T}(f : A S T) -> Inj (farra f) 34 | 35 | dudu : Inj (go du-_) 36 | dudu {ze} {ze} q = r~ 37 | dudu {su- x} {su- y} q with r~ <- dudu (natNoConf (natNoConf q)) = r~ 38 | 39 | bubu : Inj (go bu-_) 40 | bubu q = dudu (natNoConf q) 41 | 42 | fufu : Inj (go fu-_) 43 | fufu {ze} {ze} q = r~ 44 | fufu {su- x} {su- y} q with r~ <- fufu (bubu q) = r~ 45 | 46 | funInj : {V : Variant} -> INJ ([_]F {V}) 47 | funInj `id q = q 48 | funInj `ze q = r~ 49 | funInj `su q = natNoConf q 50 | funInj `du q = dudu q 51 | funInj `bu q = bubu q 52 | funInj `fu q = fufu q 53 | 54 | budu : {x y : Nat} -> bu- x ~ du- y -> Zero 55 | budu {su- x} {su- y} q = budu (natNoConf (natNoConf q)) 56 | 57 | zedu : (x : Nat) -> ze ~ du- x -> x ~ ze 58 | zedu ze q = r~ 59 | 60 | data Trouble : Obj -> Obj -> Set where 61 | `id : Trouble `1 `1 62 | `no : forall {X} -> Trouble `0 X 63 | `ze : Trouble `1 `N 64 | `fu : Trouble `N `N 65 | 66 | [_]T : forall {s b S T} -> 67 | Trouble S T -> Fun (va s b tt) S T 68 | [ `id ]T = `id 69 | [ `no ]T = `no 70 | [ `ze ]T = `ze 71 | [ `fu ]T = `fu 72 | 73 | f0g : forall {s b f S T} -> Fun (va ff ff ff) S T -> Fun (va s b f) S T 74 | f0g `id = `id 75 | f0g `no = `no 76 | f0g `ze = `ze 77 | 78 | f0gq : forall {s b f S T}(g : Fun (va ff ff ff) S T) 79 | -> [ g ]F ~><~ [ f0g {s}{b}{f} g ]F 80 | f0gq `id = _ [==] 81 | f0gq `no = _ [==] 82 | f0gq `ze = _ [==] 83 | 84 | f1g : forall {s b S T} -> Fun (va ff ff tt) S T -> Fun (va s b tt) S T 85 | f1g `id = `id 86 | f1g `no = `no 87 | f1g `ze = `ze 88 | f1g `fu = `fu 89 | 90 | f1gq : forall {s b S T}(g : Fun (va ff ff tt) S T) 91 | -> [ g ]F ~><~ [ f1g {s}{b} g ]F 92 | f1gq `id = _ [==] 93 | f1gq `no = _ [==] 94 | f1gq `ze = _ [==] 95 | f1gq `fu = _ [==] 96 | 97 | f2g : forall {s f S T} -> Fun (va ff tt ff) S T -> Fun (va s tt f) S T 98 | f2g `id = `id 99 | f2g `no = `no 100 | f2g `ze = `ze 101 | f2g `du = `du 102 | f2g `bu = `bu 103 | 104 | f2gq : forall {s f S T}(g : Fun (va ff tt ff) S T) 105 | -> [ g ]F ~><~ [ f2g {s}{f} g ]F 106 | f2gq `id = _ [==] 107 | f2gq `no = _ [==] 108 | f2gq `ze = _ [==] 109 | f2gq `du = _ [==] 110 | f2gq `bu = _ [==] 111 | 112 | f6g : forall {S T} -> Fun (va tt tt ff) S T -> Fun (va tt tt tt) S T 113 | f6g `id = `id 114 | f6g `no = `no 115 | f6g `ze = `ze 116 | f6g `du = `du 117 | f6g `bu = `bu 118 | f6g `su = `su 119 | 120 | f6gq : forall {S T}(g : Fun (va tt tt ff) S T) 121 | -> [ g ]F ~><~ [ f6g g ]F 122 | f6gq `id = _ [==] 123 | f6gq `no = _ [==] 124 | f6gq `ze = _ [==] 125 | f6gq `du = _ [==] 126 | f6gq `bu = _ [==] 127 | f6gq `su = _ [==] 128 | 129 | 130 | data FullEh : forall {S T} -> Fun (va ff ff tt) S T -> Set where 131 | isFull : FullEh `fu 132 | isDull : forall {S T}(f : Fun (va ff ff ff) S T) -> FullEh (f0g f) 133 | 134 | fullEh : forall {S T} -> (f : Fun (va ff ff tt) S T) -> FullEh f 135 | fullEh `id = isDull `id 136 | fullEh `no = isDull `no 137 | fullEh `ze = isDull `ze 138 | fullEh `fu = isFull 139 | -------------------------------------------------------------------------------- /IIIR.agda: -------------------------------------------------------------------------------- 1 | module IIIR where 2 | 3 | open import Agda.Primitive 4 | 5 | id : forall {l}{X : Set l} -> X -> X 6 | id x = x 7 | 8 | _-_ : forall {j k l} 9 | {A : Set j}{B : A -> Set k}{C : (a : A) -> B a -> Set l} 10 | (f : {a : A}(b : B a) -> C a b) -> 11 | (g : (a : A) -> B a) 12 | (a : A) -> C a (g a) 13 | (f - g) a = f (g a) 14 | infixl 3 _-_ 15 | 16 | module UPOLY {l} where 17 | 18 | data Zero : Set l where 19 | 20 | record One : Set l where constructor <> 21 | 22 | record Sg (S : Set l)(T : S -> Set l) : Set l where 23 | constructor _,_ 24 | field 25 | fst : S 26 | snd : T fst 27 | open Sg public 28 | infixr 4 _,_ 29 | 30 | record Up (X : Set l) : Set (lsuc l) where 31 | constructor up 32 | field 33 | down : X 34 | open Up public 35 | 36 | record Fam (X : Set (lsuc l)): Set (lsuc l) where 37 | constructor _/_ 38 | field 39 | Rep : Set l 40 | meaning : Rep -> X 41 | open Fam public 42 | 43 | data _==_ {X : Set l}(x : X) : X -> Set l where 44 | refl : x == x -- boo, hiss 45 | 46 | open UPOLY 47 | 48 | {-# BUILTIN EQUALITY _==_ #-} 49 | 50 | cong : forall {k l}{S : Set k}{T : Set l}(f : S -> T){s s' : S} -> s == s' -> f s == f s' 51 | cong f refl = refl 52 | 53 | postulate 54 | ext : forall {k l}{S : Set k}{T : S -> Set l}{f g : (s : S) -> T s} -> 55 | ((s : S) -> f s == g s) -> f == g 56 | 57 | 58 | module FAMKIT {l} where 59 | 60 | KON : (A : Set l) -> Fam (Up A) 61 | KON A = A / up 62 | 63 | SG : {X : Set (lsuc l)}{Y : X -> Set (lsuc l)} -> 64 | (B : Fam X)(C : (x : X) -> Fam (Y x)) -> 65 | Fam (Sg X Y) 66 | Rep (SG (S / f) C) = Sg S (Rep - C - f) 67 | meaning (SG (S / f) C) (s , t) = let x = f s in x , meaning (C x) t 68 | 69 | PI : (A : Set l) 70 | {Y : A -> Set (lsuc l)}(C : (a : A) -> Fam (Y a)) -> 71 | Fam ((a : A) -> Y a) 72 | Rep (PI A C) = (a : A) -> Rep (C a) 73 | meaning (PI A C) f a = meaning (C a) (f a) 74 | 75 | 76 | open FAMKIT 77 | 78 | module IIR {l}(I : Set l)(J : I -> Set (lsuc l)) where 79 | 80 | data Code : Set (lsuc l) 81 | AtLeast : Code -> Set (lsuc l) 82 | 83 | data Code where 84 | var : (i : I) -> Code 85 | kon : (A : Set l) -> Code 86 | sg : (B : Code)(C : AtLeast B -> Code) -> Code 87 | pi : (A : Set l)(C : A -> Code) -> Code 88 | 89 | AtLeast (var i) = J i 90 | AtLeast (kon A) = Up A 91 | AtLeast (sg B C) = Sg (AtLeast B) \ b -> AtLeast (C b) 92 | AtLeast (pi A C) = (a : A) -> AtLeast (C a) 93 | 94 | module KNOT (F : I -> Code) 95 | (f : (i : I) -> AtLeast (F i) -> J i) 96 | where 97 | 98 | data Mu (i : I) : Set l 99 | Node : (C : Code) -> Set l 100 | atLeast : (C : Code) -> Node C -> AtLeast C 101 | decode : forall {i} -> Mu i -> J i 102 | data Mu i where 103 | [_] : Node (F i) -> Mu i 104 | decode {i} [ n ] = f i (atLeast (F i) n) 105 | Node (var i) = Mu i 106 | Node (kon A) = A 107 | Node (sg B C) = Sg (Node B) \ b -> Node (C (atLeast B b)) 108 | Node (pi A C) = (a : A) -> Node (C a) 109 | atLeast (var i) n = decode n 110 | atLeast (kon A) a = up a 111 | atLeast (sg B C) (b , c) = atLeast B b , atLeast (C (atLeast B b)) c 112 | atLeast (pi A C) g a = atLeast (C a) (g a) 113 | 114 | MU : (i : I) -> Fam (J i) 115 | MU i = Mu i / decode 116 | 117 | open KNOT public 118 | 119 | open IIR public 120 | 121 | data TyTag : Set where baseT arrT : TyTag 122 | 123 | Ty : Set 124 | Ty = Mu One (\ _ -> One) (\ _ -> sg (kon TyTag) \ { 125 | (up baseT) -> kon One ; 126 | (up arrT) -> sg (var <>) \ _ -> var <>}) 127 | _ <> 128 | 129 | pattern base = [ baseT , <> ] 130 | pattern _>>_ S T = [ arrT , S , T ] 131 | 132 | data BwdTag : Set where nilT snocT : BwdTag 133 | 134 | Bwd : Set -> Set 135 | Bwd X = Mu One (\ _ -> One) (\ _ -> sg (kon BwdTag) \ { 136 | (up nilT) -> kon One ; 137 | (up snocT) -> sg (var <>) \ _ -> kon X }) 138 | _ <> 139 | 140 | pattern [] = [ nilT , <> ] 141 | pattern _-,_ xz x = [ snocT , xz , x ] 142 | 143 | data IxTag : Set where zeT suT : IxTag 144 | 145 | IX : {X : Set} -> Bwd X -> Fam (Up X) 146 | IX {X} = MU (Bwd X) (\ _ -> Up X) 147 | (\ { 148 | [] -> kon Zero ; 149 | (xz -, x) -> sg (kon IxTag) \ { (up zeT) -> kon One ; (up suT) -> var xz } }) 150 | \ { [] (up ()) 151 | ; (xz -, x) (up zeT , _) -> up x 152 | ; (xz -, S) (up suT , i) -> i 153 | } 154 | 155 | Ix : {X : Set} -> Bwd X -> Set 156 | Ix G = Rep (IX G) 157 | proj : {X : Set}(G : Bwd X) -> Ix G -> X 158 | proj G = down - meaning (IX G) 159 | 160 | data Dir : Set where syn chk : Dir 161 | 162 | TmIn : Set 163 | TmIn = Sg (Bwd Ty) \ G -> 164 | Sg Dir \ { 165 | syn -> One ; 166 | chk -> Ty } 167 | 168 | TmOut : TmIn -> Set1 169 | TmOut (G , syn , <>) = Up Ty 170 | TmOut (G , chk , T) = One 171 | 172 | data SynTag : Set where va ap ty : SynTag 173 | 174 | IsArr : Ty -> Set 175 | IsArr base = Zero 176 | IsArr (S >> T) = One 177 | 178 | isArr : forall {l}(R : Ty)(Rarr : IsArr R) -> {P : Ty -> Set l} -> 179 | ((S T : Ty) -> P (S >> T)) -> P R 180 | isArr base () p 181 | isArr (S >> T) Rarr p = p S T 182 | 183 | data ChkTag (T : Ty) : Set where 184 | emb : ChkTag T 185 | lam : IsArr T -> ChkTag T 186 | 187 | TERM : (i : TmIn) -> Fam (TmOut i) 188 | TERM = MU TmIn TmOut 189 | (\ { (G , syn , <>) -> sg (kon SynTag) \ { 190 | (up va) -> kon (Ix G) ; 191 | (up ap) -> sg (var (G , syn , <>)) \ { 192 | (up base) -> kon Zero ; 193 | (up (S >> T)) -> var (G , chk , S) } ; 194 | (up ty) -> sg (kon Ty) \ { (up T) -> var (G , chk , T)} } ; 195 | (G , chk , T) -> sg (kon (ChkTag T)) \ { 196 | (up emb) -> sg (var (G , syn , <>)) \ { (up S) -> kon (S == T) } ; 197 | (up (lam Tarr)) -> isArr T Tarr \ S T -> var ((G -, S) , chk , T)} }) 198 | \ { (G , syn , <>) (up va , up i) -> up (proj G i) 199 | ; (G , syn , <>) (up ap , up base , up ()) 200 | ; (G , syn , <>) (up ap , up (S >> T) , <>) -> up T 201 | ; (G , syn , <>) (up ty , up T , _) -> up T 202 | ; (G , chk , T) n -> _ 203 | } 204 | 205 | Graph : forall {l}(I : Set l)(J : I -> Set (lsuc l)) -> 206 | Code I J -> Code (Sg (Up I) (J - down)) \ _ -> One 207 | phaph : forall {l}(I : Set l)(J : I -> Set (lsuc l)) -> 208 | (C : Code I J) -> AtLeast _ _ (Graph I J C) -> AtLeast I J C 209 | Graph I J (var i) = sg (kon (J i)) \ { (up j) -> var (up i , j) } 210 | Graph I J (kon A) = kon (Up A) 211 | Graph I J (sg B C) = sg (Graph I J B) \ { b -> Graph I J (C (phaph I J B b)) } 212 | Graph I J (pi A C) = pi (Up A) \ {(up a) -> Graph I J (C a) } 213 | phaph I J (var i) (up j , _) = j 214 | phaph I J (kon A) (up (up a)) = up a 215 | phaph I J (sg B C) (b , c) = let x = phaph I J B b in x , phaph I J (C x) c 216 | phaph I J (pi A C) f a = phaph I J (C a) (f (up a)) 217 | 218 | MuG : forall {l}{I : Set l}{J : I -> Set (lsuc l)} 219 | (F : I -> Code I J)(f : (i : I) -> AtLeast I J (F i) -> J i) -> 220 | (Sg (Up I) (J - down)) -> Code (Sg (Up I) (J - down)) \ _ -> One 221 | MuG {l}{I}{J} F f (up i , j) = sg (Graph I J (F i)) \ n -> kon (f i (phaph I J (F i) n) == j) 222 | 223 | mkMuG : forall {l}{I : Set l}{J : I -> Set (lsuc l)} 224 | {F : I -> Code I J}{f : (i : I) -> AtLeast I J (F i) -> J i} -> 225 | {i : I} -> (x : Mu I J F f i) -> Mu _ _ (MuG F f) _ (up i , decode _ _ _ _ x) 226 | mkMuGn : forall {l}{I : Set l}{J : I -> Set (lsuc l)} 227 | {F : I -> Code I J}{f : (i : I) -> AtLeast I J (F i) -> J i} -> 228 | (C : Code I J) -> (x : Node I J F f C) -> Sg (Node _ _ (MuG F f) _ (Graph I J C)) \ x' -> 229 | phaph I J C (atLeast (Sg (Up I) (\ a -> J (down a))) (λ _ → One) (MuG F f) _ (Graph I J C) x') == atLeast I J F f C x 230 | 231 | mkMuG {F = F}{f = f}{i = i} [ x ] with mkMuGn (F i) x 232 | ... | y , q = [ y , cong (f i) q ] 233 | 234 | mkMuGn (var i) x = (_ , mkMuG x) , refl 235 | mkMuGn (kon A) a = (up a , refl) 236 | mkMuGn (sg B C) (b , c) with mkMuGn B b 237 | ... | b' , q with mkMuGn (C _) c 238 | ... | c' , q' with atLeast _ _ _ _ B b | atLeast _ _ _ _ (C _) c 239 | mkMuGn (sg B C) (b , c) | b' , refl | c' , refl | ._ | ._ = (b' , c') , refl 240 | fst (mkMuGn (pi A C) g) (up a) = fst (mkMuGn (C a) (g a)) 241 | snd (mkMuGn (pi A C) g) = ext \ a -> snd (mkMuGn (C a) (g a)) 242 | 243 | -------------------------------------------------------------------------------- /Induction.agda: -------------------------------------------------------------------------------- 1 | module Induction where 2 | 3 | data Zero : Set where 4 | record One : Set where constructor <> 5 | data Two : Set where ff tt : Two 6 | record _><_ (S : Set)(T : S -> Set) : Set where 7 | constructor _,_ 8 | field 9 | fst : S 10 | snd : T fst 11 | open _><_ 12 | 13 | record IxCon (I : Set) : Set1 where 14 | constructor _ Set 17 | Position : (i : I) -> Shape i -> Set 18 | offspring : (i : I)(s : Shape i)(p : Position i s) -> I 19 | _$_ : (I -> Set) -> (I -> Set) 20 | _$_ X i = Shape i >< \ s -> ((p : Position i s) -> X (offspring i s p)) 21 | _$$_ : forall {X Y : I -> Set} 22 | -> (forall {i} -> X i -> Y i) 23 | -> forall {i} -> _$_ X i -> _$_ Y i 24 | _$$_ f (s , k) = s , \ p -> f (k p) 25 | open IxCon 26 | 27 | module _ {I : Set}(F : IxCon I) where 28 | 29 | data Mu (i : I) : Set where 30 | con : (F $ Mu) i -> Mu i 31 | 32 | iterate : forall {X : I -> Set} 33 | -> (forall {i} -> (F $ X) i -> X i) 34 | -> forall {i} -> Mu i -> X i 35 | iterate alg (con (s , k)) = alg (s , \ p -> iterate alg (k p)) 36 | -- iterate alg (con fr) = alg ((F $$ iterate alg) fr) 37 | 38 | _^ : IxCon (I >< Mu) 39 | Shape _^ _ = One 40 | Position _^ (i , con (s , k)) <> = Position F i s 41 | offspring _^ (i , con (s , k)) <> p = offspring F i s p , k p 42 | 43 | inductivity : forall {I}{F : IxCon I} 44 | -> forall {i}(x : Mu F i) -> Mu (F ^) (i , x) 45 | inductivity (con (s , k)) = con (<> , \ p -> inductivity (k p)) 46 | 47 | induction : forall {I}{F : IxCon I} 48 | -> (P : forall i -> Mu F i -> Set) 49 | -> (forall {i}(s : Shape F i) 50 | (k : (p : Position F i s) -> Mu F (offspring F i s p)) 51 | (h : (p : Position F i s) -> P (offspring F i s p) (k p)) 52 | -> P i (con (s , k))) 53 | -> forall {i}(x : Mu F i) -> P i x 54 | induction {F = F} P m x = 55 | iterate (F ^) {X = \ (i , x) -> P i x} 56 | (\ { {(i , con (s , k))} (<> , h) -> m s k h}) 57 | (inductivity x) 58 | 59 | NAT : IxCon One 60 | Shape NAT <> = Two 61 | Position NAT <> ff = Zero 62 | Position NAT <> tt = One 63 | offspring NAT <> tt <> = <> 64 | 65 | Nat = Mu NAT <> 66 | ze : Nat 67 | ze = con (ff , \ ()) 68 | su : Nat -> Nat 69 | su n = con (tt , \ (<>) -> n) 70 | 71 | _+_ : Nat -> Nat -> Nat 72 | _+_ x y = iterate NAT (\ { (ff , _) -> y ; (tt , k) -> su (k <>) }) x 73 | 74 | data _~_ {X : Set}(x : X) : X -> Set where 75 | r~ : x ~ x 76 | postulate 77 | ext : forall {S : Set}{T : S -> Set}{f g : (s : S) -> T s} 78 | -> ((s : S) -> f s ~ g s) 79 | -> f ~ g 80 | !~ : forall {X}(x : X) -> x ~ x 81 | !~ x = r~ 82 | _~$~_ : forall {S T : Set} 83 | {f g : S -> T} -> f ~ g -> 84 | {x y : S} -> x ~ y -> 85 | f x ~ g y 86 | r~ ~$~ r~ = r~ 87 | 88 | _+ze : (x : Nat) -> (x + ze) ~ x 89 | x +ze = induction (\ _ x -> (x + ze) ~ x) 90 | (\ { ff k h -> !~ con ~$~ (!~ (ff ,_) ~$~ ext \ () ) 91 | ; tt k h -> !~ con ~$~ (!~ (tt ,_) ~$~ ext \ _ -> h <>) }) 92 | x 93 | -------------------------------------------------------------------------------- /Jaco.agda: -------------------------------------------------------------------------------- 1 | module Jaco where 2 | 3 | -- Polynomials in some set I variables 4 | 5 | data Poly (I : Set) : Set1 where 6 | va : I -> Poly I -- variable 7 | _>P<_ : (A : Set) -> (A -> Poly I) -> Poly I -- dependent pair with a tag 8 | _*P_ : Poly I -> Poly I -> Poly I -- pair of polynomials 9 | ko : Set -> Poly I -- constant 10 | 11 | -- To interpret polynomials, we need some basic kit. 12 | 13 | record _><_ (S : Set)(T : S -> Set) : Set where 14 | constructor _,_ 15 | field 16 | fst : S 17 | snd : T fst 18 | open _><_ public 19 | infixr 4 _,_ 20 | _*_ : Set -> Set -> Set 21 | S * T = S >< \ _ -> T 22 | 23 | data Zero : Set where 24 | record One : Set where constructor <> 25 | data Two : Set where ff tt : Two 26 | 27 | _+_ : Set -> Set -> Set 28 | S + T = Two >< \ { ff -> S ; tt -> T } 29 | 30 | _+P_ : forall {I} -> Poly I -> Poly I -> Poly I 31 | P +P Q = Two >P< \ { ff -> P ; tt -> Q } 32 | 33 | 34 | -- semantics of Polynomials 35 | 36 | [_]P : forall {I} -> Poly I -> (I -> Set) -> Set 37 | [ va i ]P X = X i 38 | [ A >P< B ]P X = A >< \ a -> [ B a ]P X 39 | [ P *P Q ]P X = [ P ]P X * [ Q ]P X 40 | [ ko A ]P X = A 41 | 42 | 43 | -- Equality 44 | 45 | data _~_ {X : Set}(x : X) : X -> Set where 46 | r~ : x ~ x 47 | 48 | 49 | -- Liftings to indexed sets 50 | 51 | [_] : {I : Set} -> (I -> Set) -> Set -- necessity 52 | [ P ] = forall {i} -> P i 53 | 54 | <_> : {I : Set} -> (I -> Set) -> Set -- possibility 55 | < P > = _ >< P 56 | 57 | _+:_ _*:_ _-:>_ : {I : Set} -> (I -> Set) -> (I -> Set) -> I -> Set 58 | (P +: Q) i = P i + Q i 59 | (P *: Q) i = P i * Q i 60 | (P -:> Q) i = P i -> Q i 61 | 62 | True : forall {I : Set} -> I -> Set 63 | True _ = One 64 | 65 | 66 | -- partial derivatives of polynomials 67 | 68 | parD : forall {I} -> I -> Poly I -> Poly I 69 | parD i (va j) = ko (j ~ i) 70 | parD i (A >P< B) = A >P< \ a -> parD i (B a) 71 | parD i (P *P Q) = (parD i P *P Q) +P (P *P parD i Q) 72 | parD i (ko A) = ko Zero 73 | 74 | 75 | -- "gradient vector" collects all the partial derivatives 76 | 77 | Grad : forall {I} -> (I -> Set) -> Poly I -> I -> Set 78 | Grad X P i = [ parD i P ]P X 79 | 80 | -- "divergence" collects all the ways to be visited 81 | 82 | Div : forall {I} -> (I -> Set) -> Poly I -> Set 83 | Div {I} X P = < Grad X P *: X > 84 | 85 | -- we can always stop visiting 86 | 87 | up : forall {I}{X : I -> Set}(P : Poly I) -> Div X P -> [ P ]P X 88 | up (va i) (_ , r~ , x) = x 89 | up (A >P< B) (_ , (a , b') , x) = a , up (B a) (_ , b' , x) 90 | up (P *P Q) (_ , (ff , p' , q) , x) = up P (_ , p' , x) , q 91 | up (P *P Q) (_ , (tt , p , q') , x) = p , up Q (_ , q' , x) 92 | 93 | -- we can find the leftmost child or discover we are childless 94 | 95 | leftest : forall {I}{X : I -> Set}(P : Poly I) -> 96 | [ P ]P X -> Div X P + [ P ]P \ _ -> Zero 97 | leftest (va i) x = ff , i , r~ , x 98 | leftest (A >P< B) (a , b) with leftest (B a) b 99 | ... | ff , i , b' , x = ff , i , (a , b') , x 100 | ... | tt , b0 = tt , a , b0 101 | leftest (P *P Q) (p , q) with leftest P p 102 | ... | ff , i , p' , x = ff , i , (ff , p' , q) , x 103 | ... | tt , p0 with leftest Q q 104 | ... | ff , i , q' , x = ff , i , (tt , p , q') , x 105 | ... | tt , q0 = tt , p0 , q0 106 | leftest (ko A) a = tt , a 107 | 108 | -- we can try to move right and move up if there's nowhere to move to 109 | 110 | righter : forall {I}{X : I -> Set}(P : Poly I) -> 111 | Div X P -> 112 | Div X P + [ P ]P X 113 | righter (va i) (_ , r~ , x) = tt , x 114 | righter (A >P< B) (_ , (a , b') , x) with righter (B a) (_ , b' , x) 115 | ... | ff , j , c' , y = ff , j , (a , c') , y 116 | ... | tt , r = tt , a , r 117 | righter (P *P Q) (_ , (ff , p' , q) , x) with righter P (_ , p' , x) 118 | ... | ff , j , r' , y = ff , j , (ff , r' , q) , y 119 | ... | tt , p with leftest Q q 120 | ... | ff , j , q' , y = ff , j , (tt , p , q') , y 121 | ... | tt , _ = tt , p , q 122 | righter (P *P Q) (_ , (tt , p , q') , x) with righter Q (_ , q' , x) 123 | ... | ff , j , r' , y = ff , j , (tt , p , r') , y 124 | ... | tt , q = tt , p , q 125 | 126 | 127 | -- now, the general situation is that we have a *family* of polynomials 128 | -- which has a Jacobian matrix, indexed the sort of the hole and the sort 129 | -- of the node it sits inside 130 | 131 | Jaco : forall {O I} -> 132 | (O -> Poly I) -> (I * O -> Poly I) 133 | Jaco F (i , o) = parD i (F o) 134 | 135 | -- tie the knot and obtain the generic polynomial datatype 136 | 137 | data Mu {I : Set}(F : I -> Poly I)(i : I) : Set 138 | where con : [ F i ]P (Mu F) -> Mu F i 139 | 140 | -- sequences of steps 141 | 142 | data Star {X : Set}(R : X -> X -> Set)(x : X) : X -> Set where 143 | [] : Star R x x 144 | _,-_ : forall {y z} -> R x y -> Star R y z -> Star R x z 145 | 146 | -- a one-hole context is a sequence of steps from hole to root where 147 | -- each step is given by the Jacobian of the family of polynomials which 148 | -- generates the datatype 149 | 150 | _>[_]>_ : {I : Set}(hole : I)(F : I -> Poly I)(root : I) -> Set 151 | hole >[ F ]> root = Star (\ i o -> [ Jaco F (i , o) ]P (Mu F)) hole root 152 | 153 | -- a zipper is, for some sort, a term of that sort and a context from that 154 | -- sort back to the root 155 | 156 | Zipper : forall {I}(F : I -> Poly I)(root : I) -> Set 157 | Zipper F root = < Mu F *: (_>[ F ]> root) > 158 | 159 | -- we can zoom all the way out 160 | 161 | top : forall {I}{F : I -> Poly I} -> [ Zipper F -:> Mu F ] 162 | top {I}{F}{root} (_ , t , z) = go t z where 163 | go : forall {hole} -> Mu F hole -> hole >[ F ]> root -> Mu F root 164 | go t [] = t 165 | go t (_,-_ {y = o} f' f's) = go (con (up (F o) (_ , f' , t))) f's 166 | 167 | -- we can try to visit our left child 168 | 169 | leftChild : forall {I}{F : I -> Poly I} -> [ Zipper F -:> (True +: Zipper F) ] 170 | leftChild {I}{F} (o , con ts , z) with leftest (F o) ts 171 | ... | ff , _ , c , t = tt , _ , t , (c ,- z) 172 | ... | tt , _ = ff , <> 173 | 174 | -- we can try to move right 175 | 176 | rightSib : forall {I}{F : I -> Poly I} -> [ Zipper F -:> (True +: Zipper F) ] 177 | rightSib {I} {F} (o , t , []) = ff , <> 178 | rightSib {I} {F} (_ , t , (_,-_ {y = o} c z)) with righter (F o) (_ , c , t) 179 | ... | ff , _ , d , u = tt , _ , u , (d ,- z) 180 | ... | tt , _ = ff , <> 181 | -------------------------------------------------------------------------------- /JacoDay.agda: -------------------------------------------------------------------------------- 1 | module JacoDay where 2 | 3 | record _><_ (S : Set)(T : S -> Set) : Set where 4 | constructor _,_ 5 | field 6 | fst : S 7 | snd : T fst 8 | open _><_ public 9 | infixr 4 _,_ 10 | _*_ : Set -> Set -> Set 11 | S * T = S >< \ _ -> T 12 | 13 | data Zero : Set where 14 | record One : Set where constructor <> 15 | data Two : Set where ff tt : Two 16 | 17 | _+_ : Set -> Set -> Set 18 | S + T = Two >< \ { ff -> S ; tt -> T } 19 | 20 | data Size : Set where 21 | ze un : Size 22 | _+S_ _*S_ : Size -> Size -> Size 23 | 24 | [_]0 : Size -> Set -> Set 25 | [ ze ]0 X = One 26 | [ un ]0 X = X 27 | [ N +S M ]0 X = [ N ]0 X * [ M ]0 X 28 | [ N *S M ]0 X = [ N ]0 ([ M ]0 X) 29 | 30 | pure : (N : Size) -> {X : Set} -> X -> [ N ]0 X 31 | pure ze x = <> 32 | pure un x = x 33 | pure (N +S M) x = pure N x , pure M x 34 | pure (N *S M) x = pure N (pure M x) 35 | 36 | apply : (N : Size) -> {S T : Set} -> [ N ]0 (S -> T) -> [ N ]0 S -> [ N ]0 T 37 | apply ze <> <> = <> 38 | apply un f s = f s 39 | apply (N +S M) (fs , gs) (ss , ts) = apply N fs ss , apply M gs ts 40 | apply (N *S M) fs ss = apply N (apply N (pure N (apply M)) fs) ss 41 | 42 | map : (N : Size) -> {S T : Set} -> (S -> T) -> [ N ]0 S -> [ N ]0 T 43 | map N f = apply N (pure N f) 44 | 45 | [_]P : Size -> Set 46 | [ ze ]P = Zero 47 | [ un ]P = One 48 | [ N +S M ]P = [ N ]P + [ M ]P 49 | [ N *S M ]P = [ N ]P * [ M ]P 50 | 51 | D : (N : Size) -> [ N ]P -> Size 52 | D un p = ze 53 | D (N +S M) (ff , p) = D N p +S M 54 | D (N +S M) (tt , p) = N +S D M p 55 | D (N *S M) (p , q) = (D N p *S D M q) +S (D N p +S D M q) 56 | 57 | plug : {X : Set}(N : Size)(p : [ N ]P) -> [ D N p ]0 X -> X -> [ N ]0 X 58 | plug un <> <> x = x 59 | plug (N +S M) (ff , p) (p' , q) x = plug N p p' x , q 60 | plug (N +S M) (tt , q) (p , q') x = p , plug M q q' x 61 | plug (N *S M) (p , q) (m' , p' , q') x = 62 | apply N (apply N (pure N (plug M q)) 63 | (plug N p m' q')) 64 | (plug N p p' x) 65 | 66 | gulp : {X : Set}(N : Size)(p : [ N ]P) -> [ N ]0 X -> [ D N p +S un ]0 X 67 | gulp un <> x = <> , x 68 | gulp (N +S M) (ff , p) (xn , yn) with xn' , x <- gulp N p xn = (xn' , yn) , x 69 | gulp (N +S M) (tt , q) (xn , yn) with yn' , y <- gulp M q yn = (xn , yn') , y 70 | gulp (N *S M) (p , q) xmn 71 | with xmn' , xm <- gulp N p xmn 72 | | xm' , x <- gulp M q xm 73 | | xgn' <- map (D N p) (gulp M q) xmn' 74 | = (map (D N p) fst xgn' , map (D N p) snd xgn' , xm') , x 75 | 76 | cart : {X Y : Set}(N M : Size) -> [ N ]0 X -> [ M ]0 Y -> [ N *S M ]0 (X * Y) 77 | cart N M xn ym = map N (\ x -> map M (x ,_) ym) xn 78 | 79 | [_]1 : (N : Size){X : Set}(P : X -> Set) -> [ N ]0 X -> Set 80 | [ ze ]1 P <> = One 81 | [ un ]1 P x = P x 82 | [ N +S M ]1 P (xs , ys) = [ N ]1 P xs * [ M ]1 P ys 83 | [ N *S M ]1 P xss = [ N ]1 ([ M ]1 P) xss 84 | 85 | data _<=_ : Size -> Size -> Set where 86 | ze : forall {M} -> ze <= M 87 | un : un <= un 88 | _+S_ : forall {N N' M M'} -> N <= N' -> M <= M' -> (N +S M) <= (N' +S M') 89 | _*S_ : forall {N N' M M'} -> N <= N' -> M <= M' -> (N *S M) <= (N' *S M') 90 | 91 | select : forall {N N' X} -> N <= N' -> [ N' ]0 X -> [ N ]0 X 92 | select ze _ = <> 93 | select un x = x 94 | select (th +S ph) (xn , yn) = select th xn , select ph yn 95 | select (_*S_ {N}{N'}{M}{M'} th ph) xn = select th (map N' (select ph) xn) 96 | 97 | record _|>_ (I O : Set) : Set1 where 98 | constructor Cn 99 | field 100 | Sh : O -> Set 101 | Si : (o : O) -> Sh o -> Size 102 | Ch : (o : O)(s : Sh o) -> [ Si o s ]0 I 103 | open _|>_ 104 | 105 | [_]C : forall {O I} -> I |> O -> (I -> Set) -> (O -> Set) 106 | [ Cn S Z iz ]C X o = S o >< \ s -> [ Z o s ]1 X (iz o s) 107 | 108 | data _~_ {X : Set}(x : X) : X -> Set where 109 | r~ : x ~ x 110 | 111 | J : forall {I O : Set} -> I |> O -> I |> (I * O) 112 | Sh (J (Cn S Z iz)) (i , o) = S o >< \ s -> [ Z o s ]P >< \ p -> snd (gulp (Z o s) p (iz o s)) ~ i 113 | Si (J (Cn S Z iz)) (_ , o) (s , p , r~) = D (Z o s) p 114 | Ch (J (Cn S Z iz)) (_ , o) (s , p , r~) = fst (gulp (Z o s) p (iz o s)) 115 | -------------------------------------------------------------------------------- /Nellist.agda: -------------------------------------------------------------------------------- 1 | module Nellist where 2 | 3 | -- see you B, raise you S 4 | _-_ : forall {i j k} 5 | {A : Set i}{B : A -> Set j}{C : (a : A) -> B a -> Set k} 6 | (f : (a : A) -> B a) 7 | (g : {a : A}(b : B a) -> C a b) 8 | (a : A) -> C a (f a) 9 | (f - g) a = g (f a) 10 | 11 | infixl 10 _-_ 12 | 13 | data _~_ {X : Set}(x : X) : X -> Set where 14 | r~ : x ~ x 15 | {-# BUILTIN EQUALITY _~_ #-} 16 | 17 | _[_>_ : forall {X} x {y z : X} -> x ~ y -> y ~ z -> x ~ z 18 | x [ r~ > q = q 19 | _<_]_ : forall {X} x {y z : X} -> y ~ x -> y ~ z -> x ~ z 20 | x < r~ ] q = q 21 | infixr 4 _[_>_ _<_]_ 22 | _[QED] : forall {X}(x : X) -> x ~ x 23 | x [QED] = r~ 24 | infixr 5 _[QED] 25 | 26 | _$~_ : forall {X Y}(f : X -> Y){x x' : X} -> x ~ x' -> f x ~ f x' 27 | f $~ r~ = r~ 28 | resp2 : forall {X Y Z}(f : X -> Y -> Z){x x' : X} -> x ~ x' -> {y y' : Y} -> y ~ y' -> f x y ~ f x' y' 29 | resp2 f r~ r~ = r~ 30 | 31 | record Nellist (X : Set) : Set 32 | data Neltail (X : Set) : Set 33 | 34 | record Nellist X where 35 | inductive 36 | constructor _,_ 37 | field 38 | head : X 39 | tail : Neltail X 40 | infixr 10 _,_ 41 | open Nellist 42 | 43 | data Neltail X where 44 | [] : Neltail X 45 | !_ : Nellist X -> Neltail X 46 | infixr 10 !_ 47 | 48 | _++_ : forall {X} -> Nellist X -> Neltail X -> Nellist X 49 | _++'_ : forall {X} -> Neltail X -> Neltail X -> Neltail X 50 | (x , xs) ++ ys = x , (xs ++' ys) 51 | [] ++' ys = ys 52 | (! xs) ++' ys = ! (xs ++ ys) 53 | 54 | map : forall {X Y} -> (X -> Y) -> Nellist X -> Nellist Y 55 | mapt : forall {X Y} -> (X -> Y) -> Neltail X -> Neltail Y 56 | map f (x , xs) = f x , mapt f xs 57 | mapt f [] = [] 58 | mapt f (! xs) = ! map f xs 59 | 60 | mapnelcat : forall {X Y}(f : X -> Y) xs ys -> 61 | map f (xs ++ ys) ~ (map f xs ++ mapt f ys) 62 | mapnelcat' : forall {X Y}(f : X -> Y) xs ys -> 63 | mapt f (xs ++' ys) ~ (mapt f xs ++' mapt f ys) 64 | mapnelcat f (x , xs) ys rewrite mapnelcat' f xs ys = r~ 65 | mapnelcat' f [] ys = r~ 66 | mapnelcat' f (! xs) ys rewrite mapnelcat f xs ys = r~ 67 | 68 | mapmap : forall {X Y Z}(f : X -> Y)(g : Y -> Z)(h : X -> Z) 69 | (q : (x : X) -> g (f x) ~ h x) 70 | (xs : Nellist X) -> 71 | map g (map f xs) ~ map h xs 72 | maptmapt : forall {X Y Z}(f : X -> Y)(g : Y -> Z)(h : X -> Z) 73 | (q : (x : X) -> g (f x) ~ h x) 74 | (xs : Neltail X) -> 75 | mapt g (mapt f xs) ~ mapt h xs 76 | mapmap f g h q (x , xs) rewrite q x | maptmapt f g h q xs = r~ 77 | maptmapt f g h q [] = r~ 78 | maptmapt f g h q (! xs) rewrite mapmap f g h q xs = r~ 79 | 80 | decorot : forall {X} -> Neltail X -> Neltail X -> Neltail (Nellist X) 81 | decorot' : forall {X} -> Nellist X -> Neltail X -> Neltail (Nellist X) 82 | decorot [] ys = [] 83 | decorot (! xs) ys = ! (xs ++ ys) , decorot' xs ys 84 | decorot' (x , xs) ys = decorot xs (ys ++' (! x , [])) 85 | 86 | catnil : forall {X}(xs : Neltail X) -> (xs ++' []) ~ xs 87 | catnil [] = r~ 88 | catnil (! x , xs) = !_ $~ ((x ,_) $~ catnil xs) 89 | 90 | catasso : forall {X}(xs ys zs : Neltail X) -> ((xs ++' ys) ++' zs) ~ (xs ++' (ys ++' zs)) 91 | catasso [] ys zs = r~ 92 | catasso (! x , xs) ys zs = !_ $~ ((x ,_) $~ catasso xs ys zs) 93 | 94 | lemma : forall {X}(xs ys zs : Neltail X) -> 95 | decorot (xs ++' ys) zs ~ 96 | (decorot xs (ys ++' zs) ++' decorot ys (zs ++' xs)) 97 | lemma [] ys zs = decorot ys $~ (zs < catnil zs ] zs ++' [] [QED]) 98 | lemma (! x , xs) ys zs = !_ $~ resp2 _,_ 99 | ((x ,_) $~ catasso xs ys zs) 100 | (decorot (xs ++' ys) (zs ++' (! x , [])) [ lemma xs ys (zs ++' (! x , [])) > 101 | (decorot xs (ys ++' (zs ++' (! x , []))) ++' 102 | decorot ys ((zs ++' (! x , [])) ++' xs)) 103 | [ resp2 _++'_ 104 | (decorot xs $~ ((ys ++' (zs ++' (! x , []))) 105 | < catasso ys zs (! x , []) ] 106 | ((ys ++' zs) ++' (! x , [])) [QED])) 107 | (decorot ys $~ (((zs ++' (! x , [])) ++' xs) 108 | [ catasso zs (! x , []) xs > 109 | (zs ++' (! x , xs)) [QED])) > 110 | (decorot xs ((ys ++' zs) ++' (! x , [])) ++' 111 | decorot ys (zs ++' (! x , xs))) [QED]) 112 | 113 | deco : forall {X} -> Nellist X -> Nellist (Nellist X) 114 | deco xs = xs , decorot (tail xs) (! head xs , []) 115 | 116 | here : forall {X} -> Nellist X -> X 117 | here = head 118 | 119 | data Nat : Set where 120 | ze : Nat 121 | su : Nat -> Nat 122 | {-# BUILTIN NATURAL Nat #-} 123 | 124 | test = deco (1 , ! 2 , ! 3 , ! 4 , []) 125 | 126 | check : deco test ~ map deco test 127 | check = r~ 128 | 129 | law1 : forall {X}(xs : Nellist X) -> here (deco xs) ~ xs 130 | law1 (x , xs) = r~ 131 | 132 | law2 : forall {X}(xs : Nellist X) -> map here (deco xs) ~ xs 133 | law2' : forall {X} xs ys -> mapt (head{X}) (decorot xs ys) ~ xs 134 | law2 (x , xs) = (x ,_) $~ law2' xs (! x , []) 135 | law2' [] ys = r~ 136 | law2' (! x , xs) ys = !_ $~ ((x ,_) $~ law2' xs _) 137 | 138 | law3 : forall {X}(xs : Nellist X) -> 139 | deco (deco xs) ~ map deco (deco xs) 140 | law3' : forall {X}(xs ys : Neltail X) -> 141 | decorot (decorot xs ys) (decorot ys xs) ~ 142 | mapt deco (decorot xs ys) 143 | law3 (x , xs) = (((x , xs) , decorot xs (! x , [])) ,_) $~ law3' xs (! x , []) 144 | law3' [] ys = r~ 145 | law3' (! x , xs) ys = !_ $~ resp2 _,_ 146 | (((x , (xs ++' ys)) ,_) $~ ( 147 | (decorot xs (ys ++' (! x , [])) ++' decorot ys (! x , xs)) < lemma xs ys (! x , []) ] 148 | decorot (xs ++' ys) (! x , []) [QED])) 149 | (decorot (decorot xs (ys ++' (! x , []))) 150 | (decorot ys (! x , xs) ++' (! (x , (xs ++' ys)) , [])) 151 | [ decorot (decorot xs (ys ++' (! x , []))) $~ 152 | ((decorot ys (! x , xs) ++' (! (x , (xs ++' ys)) , [])) 153 | < lemma ys (! x , []) xs ] 154 | decorot (ys ++' (! x , [])) xs [QED]) 155 | > 156 | decorot (decorot xs (ys ++' (! x , []))) (decorot (ys ++' (! x , [])) xs) 157 | [ law3' xs (ys ++' (! x , []))> 158 | mapt deco (decorot xs (ys ++' (! x , []))) [QED]) 159 | -------------------------------------------------------------------------------- /NormTree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, EmptyDataDecls, TypeFamilies, 2 | PolyKinds, TypeOperators, PatternSynonyms #-} 3 | 4 | module NormTree where 5 | 6 | import Data.Traversable 7 | import Data.Foldable 8 | import Data.List 9 | 10 | -- Natural numbers 11 | data Nat = Z | S Nat 12 | 13 | -- Singletons for natural numbers 14 | data Natty :: Nat -> * where 15 | Zy :: Natty Z 16 | Sy :: Natty n -> Natty (S n) 17 | 18 | -- Vectors 19 | data Vec :: Nat -> * -> * where 20 | Nil :: Vec Z x 21 | (:.) :: x -> Vec n x -> Vec (S n) x 22 | infixr 5 :. 23 | 24 | -- The following definition is a Haskellization of the 25 | -- "fixpoint of normal functors" 26 | -- from https://github.com/pigworker/MetaprogAgda/raw/master/notes.pdf 27 | -- section 1.9 28 | 29 | -- General Single Sorted Trees Containing x things 30 | data NormTree (sh :: Nat -> * -> *)(x :: *) :: * where 31 | (:-) :: sh n x -> Vec n (NormTree sh x) -> NormTree sh x 32 | -- the sh parameter determines the possible shapes of nodes 33 | -- for each arity; we expect it to be a GADT or a data family 34 | infix 4 :- 35 | 36 | -- Here's how to say "the usual shapes, or some extra shapes, 37 | -- but nobody else handles variables" 38 | data ExpPlush (sh :: Nat -> *) :: Nat -> * -> * where 39 | Var :: x -> ExpPlush sh Z x 40 | Abs :: x -> ExpPlush sh (S Z) x 41 | App :: ExpPlush sh (S (S Z)) x 42 | Tup :: Natty n -> ExpPlush sh n x 43 | Plus :: sh n -> ExpPlush sh n x -- see? no x in the shapes 44 | 45 | -- You can say "no extra shapes" 46 | data NoExt :: Nat -> * where 47 | 48 | -- So, just the usual shapes, with strings for variables. 49 | type Basic = NormTree (ExpPlush NoExt) String 50 | 51 | -- The Church numeral for 2 looks like this. 52 | church2 :: Basic 53 | church2 = Abs "f" :- (Abs "x" :- 54 | (App :- 55 | (Var "f" :- Nil) :. 56 | (App :- (Var "f" :- Nil) :. (Var "x" :- Nil) :. Nil) :. 57 | Nil) :. 58 | Nil) :. Nil 59 | -- That's easy to clean with pattern synonyms. 60 | 61 | -- Generic calculation, e.g. of free variables, is cheap. 62 | freeVars :: Eq x => NormTree (ExpPlush sh) x -> [x] 63 | freeVars (Var x :- Nil) = [x] 64 | freeVars (Abs x :- t :. Nil) = delete x (freeVars t) 65 | freeVars (_ :- ts) = foldr (union . freeVars) [] ts 66 | 67 | 68 | -- But what if we're multisorted? 69 | 70 | -- The above notes generalize normal functors to containers (chapter 3) 71 | -- (by the way, you can sort of do containers in Haskell 72 | -- https://pigworker.wordpress.com/2015/06/06/hasochistic-containers-a-first-attempt/ 73 | -- but I digress) 74 | -- then to indexed (i.e., multisorted) containers (chapter 4) 75 | -- which are closed under fixpoints (section 4.5) 76 | 77 | -- The theory of containers (and indexed containers) is a depth well plumbed 78 | -- by Neil Ghani and his friends (e.g. Michael Abbott, Thorsten Altenkirch, 79 | -- me, Peter Morris, Peter Hancock). The papers tend to be quite categorical, 80 | -- which is tricky if you don't have the relevant Babelfish in your ear. 81 | -- DBLP Neil Ghani and search for "container" for the back issues of the 82 | -- series. 83 | -- This paper http://www.cs.nott.ac.uk/~psztxa/publ/jpartial.pdf 84 | -- is about differentiability of containers, but has some *pictures* 85 | -- which might help make sense of the categorical mumbo jumbo. 86 | 87 | -- It's a big brain upload, but it has that "threshold concept" aspect 88 | -- of changing the way you perceive what is common to inductive data 89 | -- structures, and to systems of interactive programming (which is 90 | -- Hancock's key insight). Almost like you *can* see the wood for the trees. 91 | -- The "Cambridge notes" I linked to, above, give a more 92 | -- (Agda-)programming-oriented presentation. 93 | -- Brain-mangling homework exercises are available on request. 94 | 95 | -- My plan here is to drag the indexed container fixpoint construction back 96 | -- to the finitary case. We get multisorted normal functors. 97 | -- A *number* of recursive position becomes 98 | -- a *list of sorts* of recursive (and nonrecursive) positions, 99 | 100 | -- So... 101 | 102 | -- Sorts are either terminal (Left) or nonterminal (Right). 103 | type family Case (f :: x -> *) (g :: y -> *) (z :: Either x y) :: * where 104 | Case f g (Left x) = f x 105 | Case f g (Right y) = g y 106 | 107 | -- If we know how to build both, we can interpret a list of sorts. 108 | data Kids (f :: x -> *)(g :: y -> *)(zs :: [Either x y]) :: * where 109 | KNil :: Kids f g '[] 110 | (:&) :: Case f g z -> Kids f g zs -> Kids f g (z ': zs) 111 | infixr 5 :& 112 | 113 | -- Now a shape is indexed by its own nonterminal sort and its kids' sorts. 114 | data MutTree (sh :: y -> [Either x y] -> *)(v :: x -> *)(i :: y) where 115 | (:=) :: sh i zs -> Kids v (MutTree sh v) zs -> MutTree sh v i 116 | infixr 4 := 117 | 118 | -- Let's go wild! 119 | data Side = Pat | Exp 120 | data Sort = Tm Side | Def | List Sort 121 | -- Sorts are closed under list formation, term sorts and definition sorts. 122 | -- Term sorts are either pattern or expression. 123 | 124 | -- Now we say what the syntax trees are by describing the shapes for 125 | -- each sort. We have only one nonterminal sort -- identifiers. 126 | -- 127 | -- But, by way of going wild, I've added 128 | -- "mode" whose job is to specify labelling disciplines 129 | -- (and I'm not fussy what kind mode is) 130 | -- "more" whose job is to specify syntax extensions 131 | -- I'm choosing only to label variable references, but ymmv. 132 | -- Crucially, this labelling and extensibility discipline has 133 | -- nothing to do with the idea of how to make trees. 134 | -- Helpfully, "more" also takes "Mode", so extensions are free 135 | -- to negotiate their own relationships with labelling disciplines. 136 | data Syntax :: (mode -> Sort -> [Either () Sort] -> *) -> 137 | mode -> Sort -> [Either () Sort] -> * where 138 | SNil :: Syntax more mode (List s) '[] 139 | SCons :: Syntax more mode (List s) '[Right s, Right (List s)] 140 | SVar :: LabelVar mode -> Syntax more mode (Tm e) '[Left '()] 141 | SCon :: Syntax more mode (Tm e) '[Left '(), Right (List (Tm e))] 142 | SAbs :: Syntax more mode (Tm Exp) '[Left '(), Right (Tm Exp)] 143 | SApp :: Syntax more mode (Tm Exp) '[Right (Tm Exp), Right (Tm Exp)] 144 | SLet :: Syntax more mode (Tm Exp) '[Right (List Def), Right (Tm Exp)] 145 | SEqn :: Syntax more mode Def 146 | '[Left '(), Right (List (Tm Pat)), Right (Tm Exp)] 147 | SMore :: more mode y zs -> Syntax more mode y zs 148 | 149 | -- The empty extension. 150 | data NoMore :: mode -> Sort -> [Either () Sort] -> * where 151 | 152 | -- Two labelling disciplines. 153 | data Mode = Plain | Fancy -- actually, Mode should be extensible 154 | type family LabelVar (m :: mode) :: * where 155 | LabelVar Plain = () 156 | LabelVar Fancy = Int 157 | 158 | -- We need to interpret the nonterminal sort somehow. 159 | data N (i :: ()) = N String 160 | 161 | -- Here's an example with expressions, patterns and definitions 162 | church4 :: MutTree (Syntax NoMore Fancy) N (Tm Exp) 163 | church4 = 164 | SLet := (SCons := (SEqn := N "church2" 165 | :& (SCons := (SVar 1 := N "f" :& KNil) 166 | :& (SCons := (SVar 2 := N "x" :& KNil) 167 | :& (SNil := KNil) 168 | :& KNil) 169 | :& KNil) 170 | :& (SApp := (SVar 1 := N "f" :& KNil) 171 | :& (SApp := (SVar 1 := N "f" :& KNil) 172 | :& (SVar 2 := N "x" :& KNil) 173 | :& KNil) 174 | :& KNil) 175 | :& KNil) 176 | :& (SNil := KNil) 177 | :& KNil) 178 | :& (SApp := (SVar 0 := N "church2" :& KNil) 179 | :& (SVar 0 := N "church2" :& KNil) 180 | :& KNil) 181 | :& KNil 182 | 183 | -- Now let me hide some cruft. 184 | 185 | pattern PNil = SNil := KNil 186 | pattern x :+ xs = SCons := x :& xs :& KNil 187 | infixr 6 :+ 188 | pattern f :$ a = SApp := f :& a :& KNil 189 | infixl 7 :$ 190 | pattern PV :: LabelVar mode -> String -> MutTree (Syntax NoMore mode) N (Tm e) 191 | pattern PV i x = SVar i := N x :& KNil 192 | 193 | church4' :: MutTree (Syntax NoMore Fancy) N (Tm Exp) 194 | church4' = 195 | SLet := ((SEqn := N "church2" 196 | :& PV 1 "f" :+ PV 2 "x" :+ PNil 197 | :& PV 1 "f" :$ (PV 1 "f" :$ PV 2 "x") 198 | :& KNil) 199 | :+ PNil) 200 | :& PV 0 "church2" :$ PV 0 "church2" 201 | :& KNil 202 | 203 | 204 | -- Dull stuff 205 | 206 | instance Traversable (Vec n) where 207 | traverse f Nil = pure Nil 208 | traverse f (x :. xs) = pure (:.) <*> f x <*> traverse f xs 209 | 210 | instance Functor (Vec n) where 211 | fmap = fmapDefault 212 | 213 | instance Foldable (Vec n) where 214 | foldMap = foldMapDefault 215 | -------------------------------------------------------------------------------- /OpTT/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, TypeFamilies, TypeOperators, StandaloneDeriving, QuantifiedConstraints, UndecidableInstances #-} 2 | 3 | module Term where 4 | 5 | import Thin 6 | 7 | data TmSort = Syn | Chk deriving Show 8 | 9 | data TmSorty (t :: TmSort) :: * where 10 | Syny :: TmSorty Syn 11 | Chky :: TmSorty Chk 12 | 13 | data Sort 14 | = Term TmSort 15 | | Bind Sort 16 | | Pair Sort Sort 17 | | Unit 18 | | Vect Nat Sort 19 | deriving Show 20 | 21 | data Sorty (s :: Sort) :: * where 22 | Termy :: TmSorty t -> Sorty (Term t) 23 | Bindy :: Sorty s -> Sorty (Bind s) 24 | Pairy :: Sorty l -> Sorty r -> Sorty (Pair l r) 25 | Unity :: Sorty Unit 26 | Vecty :: Natty n -> Sorty s -> Sorty (Vect n s) 27 | 28 | type family TmOf (s :: Sort) :: Nat -> * where 29 | TmOf (Term t) = Tm t 30 | TmOf (Bind s) = Su (TmOf s) 31 | TmOf (Pair l r) = TmOf l ^*^ TmOf r 32 | TmOf Unit = Un 33 | TmOf (Vect Z s) = Un 34 | TmOf (Vect (S n) s) = TmOf (Vect n s) ^*^ TmOf s 35 | 36 | data Tm (t :: TmSort) (n :: Nat) :: * where 37 | (:$) :: Con s t -> TmOf s n -> Tm t n 38 | V :: Tm Syn (S Z) 39 | A :: String -> Tm Chk Z 40 | infixr 5 :$ 41 | 42 | instance Show (Tm t n) where 43 | show (c :$ t) = concat [ "(", show c, " ", showSort (conSort c) t, ")"] where 44 | show V = "#" 45 | show (A x) = x 46 | 47 | showSort :: forall s n. Sorty s -> TmOf s n -> String 48 | showSort (Bindy s) (La t) = concat ["(x. ", showSort s t, ")"] 49 | showSort (Bindy s) (Ka t) = concat ["(_. ", showSort s t, ")"] 50 | showSort Unity _ = "()" 51 | showSort (Pairy l r) (Pr p u q) = concat 52 | ["(", showSort l p , " ", show u, " ", showSort r q, ")"] 53 | showSort (Termy _) t = show t 54 | showSort (Vecty Zy s) t = showSort Unity t 55 | showSort (Vecty (Sy n) s) t = showSort (Pairy (Vecty n s) s) t 56 | 57 | data Con (s :: Sort) (t :: TmSort) :: * where 58 | Meta :: Name -> Natty n -> Con (Vect n (Term Syn)) Chk 59 | Abst :: Con (Bind (Term Chk)) Chk 60 | Cons :: Con (Pair (Term Chk) (Term Chk)) Chk 61 | Null :: Con Unit Chk 62 | Turn :: Con (Term Syn) Chk 63 | Radi :: Con (Pair (Term Chk) (Term Chk)) Syn 64 | Elim :: Con (Pair (Term Syn) (Term Chk)) Syn 65 | deriving instance Show (Con s t) 66 | 67 | conSort :: Con s t -> Sorty s 68 | conSort (Meta _ n) = Vecty n (Termy Syny) 69 | conSort Abst = Bindy (Termy Chky) 70 | conSort Cons = Pairy (Termy Chky) (Termy Chky) 71 | conSort Null = Unity 72 | conSort Turn = Termy Syny 73 | conSort Radi = Pairy (Termy Chky) (Termy Chky) 74 | conSort Elim = Pairy (Termy Syny) (Termy Chky) 75 | 76 | sortily :: Sorty s -> (Subst (TmOf s) => r) -> r 77 | sortily (Termy _) k = k 78 | sortily (Bindy s) k = sortily s k 79 | sortily (Pairy l r) k = sortily l (sortily r k) 80 | sortily Unity k = k 81 | sortily (Vecty Zy s) k = k 82 | sortily (Vecty (Sy n) s) k = sortily (Vecty n s) (sortily s k) 83 | 84 | type Name = [(String, Int)] 85 | 86 | type (/>) (m :: Nat) = TmOf (Vect m (Term Syn)) 87 | 88 | idSubstEh :: Natty m -> m /> n -> Maybe (m :=: n) 89 | idSubstEh Zy Un = pure Refl 90 | idSubstEh (Sy m) (Pr sg (ISS u) V) = case allLeft u of 91 | Refl -> do 92 | Refl <- idSubstEh m sg 93 | pure Refl 94 | idSubstEh _ _ = Nothing 95 | 96 | class Subst (p :: Nat -> *) where 97 | (//), (///) :: p m -> (Natty m, m /> n, Natty n) -> p n 98 | p // msg@(m, sg, n) = case idSubstEh m sg of 99 | Just Refl -> p 100 | Nothing -> p /// msg 101 | 102 | instance Subst (Tm t) where 103 | (c :$ s) /// msgn = sortily (conSort c) (c :$ (s /// msgn)) 104 | V /// (Sy Zy, Pr Un u e, _) = case allRight u of Refl -> e 105 | A a /// (Zy, Un, Zy) = A a 106 | 107 | data Roof (l :: Nat) (r :: Nat) (m :: Nat) (n :: Nat) :: * where 108 | Roof :: (l /> k) -> Cov k s n -> (r /> s) -> Roof l r m n 109 | 110 | roof :: Cov l r m -> m /> n -> Roof l r m n 111 | roof (SSS u) (Pr sg w e) = case roof u sg of 112 | Roof rh u' ta -> case mid4Cov u' w (covLR (rSup w)) of 113 | Mid4Cov ul lr ur -> Roof (Pr rh ul e) lr (Pr ta ur e) 114 | roof (ISS u) (Pr sg w e) = case roof u sg of 115 | Roof rh u' ta -> case rotRCov u' w of 116 | RotRCov u0 u1 -> Roof rh u0 (Pr ta u1 e) 117 | roof (SIS u) (Pr sg w e) = case roof u sg of 118 | Roof rh u' ta -> case rotRCov (swapCov u') w of 119 | RotRCov u0 u1 -> Roof (Pr rh u1 e) (swapCov u0) ta 120 | roof ZZZ Un = Roof Un ZZZ Un 121 | 122 | instance (Subst p, Subst q) => Subst (p ^*^ q) where 123 | Pr p u q /// (m, sg, n) = case roof u sg of 124 | Roof rh w ta -> Pr (p // (lSup u, rh, lSup w)) w (q // (rSup u, ta, rSup w)) 125 | 126 | instance Subst Un where 127 | Un /// (Zy, Un, Zy) = Un 128 | 129 | instance Subst p => Subst (Su p) where 130 | La p /// (m, sg, n) = La (p /// (Sy m, Pr sg (ISS (covL n)) V, Sy n)) 131 | Ka p /// msgn = Ka (p /// msgn) 132 | -------------------------------------------------------------------------------- /OpTT/Thin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, TypeOperators, KindSignatures, RankNTypes, QuantifiedConstraints, ConstraintKinds #-} 2 | 3 | module Thin where 4 | 5 | data (x :: a) :=: (y :: a) where 6 | Refl :: x :=: x 7 | 8 | class IxEq (p :: a -> *) where 9 | (=?=) :: p x -> p y -> Maybe (x :=: y) 10 | 11 | data Nat = Z | S Nat 12 | 13 | instance Show Nat where 14 | show = show . count where 15 | count :: Nat -> Int 16 | count Z = 0 17 | count (S n) = 1 + count n 18 | 19 | type Shown (p :: Nat -> *) = forall n. Show (p n) 20 | 21 | data Natty (n :: Nat) where 22 | Zy :: Natty Z 23 | Sy :: Natty n -> Natty (S n) 24 | 25 | instance Show (Natty n) where 26 | show = show . count where 27 | count :: forall n. Natty n -> Int 28 | count Zy = 0 29 | count (Sy n) = 1 + count n 30 | 31 | instance IxEq Natty where 32 | Zy =?= Zy = pure Refl 33 | Sy n =?= Sy m = do 34 | Refl <- n =?= m 35 | pure Refl 36 | _ =?= _ = Nothing 37 | 38 | data (n :: Nat) <= (m :: Nat) :: * where 39 | IS :: n <= m -> n <= S m 40 | SS :: n <= m -> S n <= S m 41 | ZZ :: Z <= Z 42 | 43 | instance Show (n <= m) where 44 | show th = concat ["|", go th, "|"] where 45 | go :: forall n m. n <= m -> String 46 | go (IS th) = go th ++ "0" 47 | go (SS th) = go th ++ "1" 48 | go ZZ = "" 49 | 50 | bigEnd :: n <= m -> Natty m 51 | bigEnd (IS th) = Sy (bigEnd th) 52 | bigEnd (SS th) = Sy (bigEnd th) 53 | bigEnd ZZ = Zy 54 | 55 | weeEnd :: n <= m -> Natty n 56 | weeEnd (IS th) = weeEnd th 57 | weeEnd (SS th) = Sy (weeEnd th) 58 | weeEnd ZZ = Zy 59 | 60 | thinEqEh :: a <= b -> c <= d -> Maybe (a :=: c, b :=: d) 61 | thinEqEh (IS th) (IS ph) = do (Refl, Refl) <- thinEqEh th ph; pure (Refl, Refl) 62 | thinEqEh (SS th) (SS ph) = do (Refl, Refl) <- thinEqEh th ph; pure (Refl, Refl) 63 | thinEqEh ZZ ZZ = pure (Refl, Refl) 64 | thinEqEh _ _ = Nothing 65 | 66 | class Thinny (p :: Nat -> *) where 67 | (-<) :: p n -> n <= m -> p m 68 | infixl 5 -< 69 | 70 | instance Thinny ((<=) n) where 71 | th -< IS ph = IS (th -< ph) 72 | IS th -< SS ph = IS (th -< ph) 73 | SS th -< SS ph = SS (th -< ph) 74 | ZZ -< ZZ = ZZ 75 | 76 | instance Thinny Natty where 77 | n -< IS th = Sy (n -< th) 78 | Sy n -< SS th = Sy (n -< th) 79 | Zy -< ZZ = Zy 80 | 81 | io :: Natty n -> n <= n 82 | io Zy = ZZ 83 | io (Sy n) = SS (io n) 84 | 85 | data CdB (p :: Nat -> *) (m :: Nat) :: * where 86 | (:^) :: p n -> n <= m -> CdB p m 87 | infixl 4 :^ 88 | 89 | instance Shown p => Show (CdB p n) where 90 | show (p :^ th) = concat ["(", show p, " :^", show th, ")"] 91 | 92 | instance Thinny (CdB p) where 93 | (p :^ th) -< ph = p :^ th -< ph 94 | 95 | no :: Natty n -> Z <= n 96 | no Zy = ZZ 97 | no (Sy n) = IS (no n) 98 | 99 | data Cov (l :: Nat)(r :: Nat)(m :: Nat) :: * where 100 | SIS :: Cov l r n -> Cov (S l) r (S n) 101 | ISS :: Cov l r n -> Cov l (S r) (S n) 102 | SSS :: Cov l r n -> Cov (S l) (S r) (S n) 103 | ZZZ :: Cov Z Z Z 104 | 105 | lCov :: Cov l r n -> l <= n 106 | lCov (SIS th) = SS (lCov th) 107 | lCov (ISS th) = IS (lCov th) 108 | lCov (SSS th) = SS (lCov th) 109 | lCov ZZZ = ZZ 110 | 111 | rCov :: Cov l r n -> r <= n 112 | rCov (SIS th) = IS (rCov th) 113 | rCov (ISS th) = SS (rCov th) 114 | rCov (SSS th) = SS (rCov th) 115 | rCov ZZZ = ZZ 116 | 117 | lSup :: Cov l r n -> Natty l 118 | lSup u = weeEnd (lCov u) 119 | 120 | rSup :: Cov l r n -> Natty r 121 | rSup u = weeEnd (rCov u) 122 | 123 | instance Show (Cov l r n) where 124 | show u = concat ["<", show (lCov u), show (rCov u), ">"] 125 | 126 | cop :: l <= m -> r <= m -> CdB (Cov l r) m 127 | cop (IS th) (IS ph) = case cop th ph of u :^ ps -> u :^ IS ps 128 | cop (SS th) (IS ph) = case cop th ph of u :^ ps -> SIS u :^ SS ps 129 | cop (IS th) (SS ph) = case cop th ph of u :^ ps -> ISS u :^ SS ps 130 | cop (SS th) (SS ph) = case cop th ph of u :^ ps -> SSS u :^ SS ps 131 | cop ZZ ZZ = ZZZ :^ ZZ 132 | 133 | covL :: Natty n -> Cov n Z n 134 | covL Zy = ZZZ 135 | covL (Sy n) = SIS (covL n) 136 | 137 | allLeft :: Cov l Z n -> l :=: n 138 | allLeft (SIS u) = case allLeft u of 139 | Refl -> Refl 140 | allLeft ZZZ = Refl 141 | 142 | covR :: Natty n -> Cov Z n n 143 | covR Zy = ZZZ 144 | covR (Sy n) = ISS (covR n) 145 | 146 | allRight :: Cov Z r n -> r :=: n 147 | allRight (ISS u) = case allRight u of 148 | Refl -> Refl 149 | allRight ZZZ = Refl 150 | 151 | covLR :: Natty n -> Cov n n n 152 | covLR Zy = ZZZ 153 | covLR (Sy n) = SSS (covLR n) 154 | 155 | swapCov :: Cov l r n -> Cov r l n 156 | swapCov (ISS u) = SIS (swapCov u) 157 | swapCov (SIS u) = ISS (swapCov u) 158 | swapCov (SSS u) = SSS (swapCov u) 159 | swapCov ZZZ = ZZZ 160 | 161 | data RotRCov a b c abc where 162 | RotRCov :: Cov a bc abc -> Cov b c bc -> RotRCov a b c abc 163 | 164 | rotRCov :: Cov a b ab -> Cov ab c abc -> RotRCov a b c abc 165 | rotRCov u (ISS w) = case rotRCov u w of RotRCov w' u' -> RotRCov (ISS w') (ISS u') 166 | rotRCov (ISS u) (SIS w) = case rotRCov u w of RotRCov w' u' -> RotRCov (ISS w') (SIS u') 167 | rotRCov (SIS u) (SIS w) = case rotRCov u w of RotRCov w' u' -> RotRCov (SIS w') u' 168 | rotRCov (SSS u) (SIS w) = case rotRCov u w of RotRCov w' u' -> RotRCov (SSS w') (SIS u') 169 | rotRCov (ISS u) (SSS w) = case rotRCov u w of RotRCov w' u' -> RotRCov (ISS w') (SSS u') 170 | rotRCov (SIS u) (SSS w) = case rotRCov u w of RotRCov w' u' -> RotRCov (SSS w') (ISS u') 171 | rotRCov (SSS u) (SSS w) = case rotRCov u w of RotRCov w' u' -> RotRCov (SSS w') (SSS u') 172 | rotRCov ZZZ ZZZ = RotRCov ZZZ ZZZ 173 | 174 | data RotLCov a b c abc where 175 | RotLCov :: Cov a b ab -> Cov ab c abc -> RotLCov a b c abc 176 | 177 | rotLCov :: Cov a bc abc -> Cov b c bc -> RotLCov a b c abc 178 | rotLCov u w = case rotRCov (swapCov w) (swapCov u) of 179 | RotRCov u' w' -> RotLCov (swapCov w') (swapCov u') 180 | 181 | data Mid4Cov a b c d n where 182 | Mid4Cov :: Cov a c ac -> Cov ac bd n -> Cov b d bd -> Mid4Cov a b c d n 183 | 184 | mid4Cov :: Cov a b ab -> Cov ab cd n -> Cov c d cd -> Mid4Cov a b c d n 185 | mid4Cov a_b ab_cd c_d = case rotRCov a_b ab_cd of 186 | RotRCov a_bcd b_cd -> case rotLCov b_cd c_d of 187 | RotLCov b_c bc_d -> case rotRCov (swapCov b_c) bc_d of 188 | RotRCov c_bd b_d -> case rotLCov a_bcd c_bd of 189 | RotLCov a_c ac_bd -> Mid4Cov a_c ac_bd b_d 190 | 191 | data (p :: Nat -> *) ^*^ (q :: Nat -> *) :: Nat -> * where 192 | Pr :: p l -> Cov l r n -> q r -> (p ^*^ q) n 193 | 194 | instance (Shown p, Shown q) => Show ((p ^*^ q) n) where 195 | show (Pr p u q) = concat ["(", show p , " ", show u, " ", show q, ")"] 196 | 197 | infixr 3 ^&^ 198 | (^&^) :: CdB p m -> CdB q m -> CdB (p ^*^ q) m 199 | p :^ th ^&^ q :^ ph = case cop th ph of 200 | u :^ ps -> Pr p u q :^ ps 201 | 202 | splip :: CdB (p ^*^ q) m -> (CdB p m, CdB q m) 203 | splip (Pr p u q :^ ps) = (p :^ lCov u -< ps, q :^ rCov u -< ps) 204 | 205 | data Un (n :: Nat) :: * where 206 | Un :: Un Z 207 | instance Show (Un n) where 208 | show Un = "()" 209 | 210 | data Su (p :: Nat -> *) (n :: Nat) where 211 | La :: p (S n) -> Su p n 212 | Ka :: p n -> Su p n 213 | 214 | su :: CdB p (S n) -> CdB (Su p) n 215 | su (p :^ SS th) = La p :^ th 216 | su (p :^ IS th) = Ka p :^ th 217 | 218 | us :: CdB (Su p) n -> CdB p (S n) 219 | us (La p :^ th) = p :^ SS th 220 | us (Ka p :^ th) = p :^ IS th 221 | 222 | data Span (l :: Nat)(r :: Nat) :: * where 223 | Span :: n <= l -> n <= r -> Span l r 224 | deriving instance Show (Span l r) 225 | 226 | pub :: l <= m -> r <= m -> Span l r 227 | pub (IS th) (IS ph) = pub th ph 228 | pub (IS th) (SS ph) = case pub th ph of Span th' ph' -> Span th' (IS ph') 229 | pub (SS th) (IS ph) = case pub th ph of Span th' ph' -> Span (IS th') ph' 230 | pub (SS th) (SS ph) = case pub th ph of Span th' ph' -> Span (SS th') (SS ph') 231 | pub ZZ ZZ = Span ZZ ZZ 232 | 233 | ioEh :: n <= m -> Maybe (n :=: m) 234 | ioEh th = weeEnd th =?= bigEnd th 235 | 236 | subThinEh :: l <= m -> n <= m -> Maybe (l <= n) 237 | subThinEh th ph = case pub th ph of Span th' ph' -> do Refl <- ioEh th'; pure ph' -------------------------------------------------------------------------------- /Pigeons.agda: -------------------------------------------------------------------------------- 1 | module Pigeons where 2 | 3 | 4 | ------------------------------------------------------------------------------ 5 | -- TOTALLY STANDARD PRELIMINARIES 6 | ------------------------------------------------------------------------------ 7 | 8 | data _~_ {X : Set}(x : X) : X -> Set where 9 | r~ : x ~ x 10 | 11 | data Zero : Set where 12 | 13 | data Nat : Set where 14 | su : Nat -> Nat 15 | ze : Nat 16 | 17 | record _><_ (S : Set)(T : S -> Set) : Set where 18 | constructor _,_ 19 | field 20 | fst : S 21 | snd : T fst 22 | open _><_ public 23 | _*_ : Set -> Set -> Set 24 | S * T = S >< \ _ -> T 25 | infixr 20 _*_ _,_ 26 | 27 | 28 | ------------------------------------------------------------------------------ 29 | -- IDIOSYNCRATIC PRELIMINARIES re THINNINGS 30 | ------------------------------------------------------------------------------ 31 | 32 | data _c=_ : Nat -> Nat -> Set where 33 | no : forall {n m} -> n c= m -> n c= su m 34 | su : forall {n m} -> n c= m -> su n c= su m 35 | ze : ze c= ze 36 | 37 | none : forall {n} -> ze c= n 38 | none {su n} = no none 39 | none {ze} = ze 40 | 41 | -- relational diagrammatic composition 42 | data [_-<_]~_ : forall {l n m} 43 | -> l c= n -> n c= m -> l c= m -> Set where 44 | no : forall {l n m}{th : l c= n}{ph : n c= m}{ps : l c= m} 45 | -> [ th -< ph ]~ ps 46 | -> [ th -< no ph ]~ no ps 47 | nosu : forall {l n m}{th : l c= n}{ph : n c= m}{ps : l c= m} 48 | -> [ th -< ph ]~ ps 49 | -> [ no th -< su ph ]~ no ps 50 | su : forall {l n m}{th : l c= n}{ph : n c= m}{ps : l c= m} 51 | -> [ th -< ph ]~ ps 52 | -> [ su th -< su ph ]~ su ps 53 | ze : [ ze -< ze ]~ ze 54 | 55 | nonethnone : forall {i j}{th : i c= j} -> [ none -< th ]~ none 56 | nonethnone {th = no th} = no nonethnone 57 | nonethnone {th = su th} = nosu nonethnone 58 | nonethnone {th = ze} = ze 59 | 60 | -- candidate pullback 61 | record Common {i j n} h (th : i c= n)(ph : j c= n) : Set where 62 | constructor common 63 | field 64 | {leftInc} : h c= i 65 | {midInc} : h c= n 66 | {rightInc} : h c= j 67 | leftTri : [ leftInc -< th ]~ midInc 68 | rightTri : [ rightInc -< ph ]~ midInc 69 | 70 | 71 | ------------------------------------------------------------------------------ 72 | -- IDIOSYNCRATIC PRELIMINARIES re ADDITION 73 | ------------------------------------------------------------------------------ 74 | 75 | -- relational addition 76 | data [_+_]~_ : Nat -> Nat -> Nat -> Set where 77 | su : forall {l n m} 78 | -> [ l + n ]~ m 79 | -> [ su l + n ]~ su m 80 | ze : (m : Nat) 81 | -> [ ze + m ]~ m 82 | 83 | su' : forall {l n m} -> [ l + n ]~ m -> [ l + su n ]~ su m 84 | su' (su c) = su (su' c) 85 | su' (ze n) = ze (su n) 86 | 87 | rightSu : forall {l n m} 88 | -> [ l + su n ]~ m 89 | -> _ >< \ p -> (m ~ su p) * [ l + n ]~ p 90 | rightSu (su c) with _ , r~ , u <- rightSu c = _ , r~ , su u 91 | rightSu (ze .(su _)) = _ , r~ , ze _ 92 | 93 | 94 | ------------------------------------------------------------------------------ 95 | -- THE PIGEONHOLE PRINCIPLE 96 | ------------------------------------------------------------------------------ 97 | 98 | pigeons : forall {i j n k m} 99 | -> (th : i c= n) 100 | -> (ph : j c= n) 101 | -> [ i + j ]~ m 102 | -> [ su n + k ]~ m 103 | -> Common (su ze) th ph 104 | pigeons (no th) (no ph) ij (su (su nk)) 105 | with common u v <- pigeons th ph ij (su (su' nk)) 106 | = common (no u) (no v) 107 | pigeons (no th) (su ph) ij (su nk) 108 | with _ , r~ , d <- rightSu ij 109 | with common u v <- pigeons th ph d nk 110 | = common (no u) (nosu v) 111 | pigeons (su th) (no ph) (su ij) (su nk) 112 | with common u v <- pigeons th ph ij nk 113 | = common (nosu u) (no v) 114 | pigeons (su th) (su ph) ij nk 115 | = common (su nonethnone) (su nonethnone) 116 | pigeons ze ze (ze .ze) () 117 | -------------------------------------------------------------------------------- /Relevant.agda: -------------------------------------------------------------------------------- 1 | module Relevant where 2 | 3 | data Nat : Set where 4 | ze : Nat 5 | su : Nat -> Nat 6 | 7 | data Fin : Nat -> Set where 8 | ze : {n : Nat} -> Fin (su n) 9 | su : {n : Nat} -> Fin n -> Fin (su n) 10 | 11 | data OPE : Nat -> Nat -> Set where 12 | ze : OPE ze ze 13 | su : {n m : Nat} -> OPE n m -> OPE (su n) (su m) 14 | no : {n m : Nat} -> OPE n m -> OPE n (su m) 15 | 16 | thin : forall {n m} -> OPE n m -> Fin n -> Fin m 17 | thin ze () 18 | thin (su r) ze = ze 19 | thin (su r) (su i) = su (thin r i) 20 | thin (no r) i = su (thin r i) 21 | 22 | idOPE : forall {n} -> OPE n n 23 | idOPE {ze} = ze 24 | idOPE {su n} = su idOPE 25 | 26 | data Tm (n : Nat) : Set where 27 | va : Fin n -> Tm n 28 | _$_ : Tm n -> Tm n -> Tm n 29 | la : Tm (su n) -> Tm n 30 | 31 | infixl 4 _$_ 32 | 33 | thinTm : forall {n m} -> OPE n m -> Tm n -> Tm m 34 | thinTm r (va i) = va (thin r i) 35 | thinTm r (f $ s) = thinTm r f $ thinTm r s 36 | thinTm r (la t) = la (thinTm (su r) t) 37 | 38 | data Zero : Set where 39 | record One : Set where constructor <> 40 | 41 | _&_ : forall {n n' m} -> OPE n m -> OPE n' m -> Set 42 | ze & ze = One 43 | su r & su r' = r & r' 44 | su r & no r' = r & r' 45 | no r & su r' = r & r' 46 | no r & no r' = Zero 47 | 48 | one : Nat -> Set 49 | one (su ze) = One 50 | one _ = Zero 51 | 52 | data Re (m : Nat) : Set where 53 | it : one m -> Re m 54 | ap : forall {n n'}(r : OPE n m)(r' : OPE n' m) -> 55 | r & r' -> Re n -> Re n' -> Re m 56 | la : Re (su m) -> Re m 57 | ka : Re m -> Re m 58 | 59 | reTm : forall {n} -> Re n -> Tm n 60 | reTm {ze} (it ()) 61 | reTm {su n} (it i) = va ze 62 | reTm (ap r r' p f s) = thinTm r (reTm f) $ thinTm r' (reTm s) 63 | reTm (la t) = la (reTm t) 64 | reTm (ka t) = la (thinTm (no idOPE) (reTm t)) 65 | 66 | data RE {m : Nat} : Tm m -> Set where 67 | mkRE : {n : Nat}(t : Re n)(r : OPE n m) -> RE (thinTm r (reTm t)) 68 | 69 | re : {n : Nat}(t : Tm n) -> RE t 70 | re t = {!!} 71 | -------------------------------------------------------------------------------- /Relevant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, DataKinds, KindSignatures, StandaloneDeriving, TypeFamilies, 2 | UndecidableInstances, RankNTypes #-} 3 | 4 | module Relevant where 5 | 6 | -------------------------------------------------------------------------- 7 | -- NATURAL NUMBERS 8 | -------------------------------------------------------------------------- 9 | 10 | -- usual type level numbers and singletons 11 | data Nat = Z | S Nat deriving Show 12 | data Natty :: Nat -> * where 13 | Zy :: Natty Z 14 | Sy :: Natty n -> Natty (S n) 15 | deriving instance Show (Natty n) 16 | class NATTY (n :: Nat) where 17 | natty :: Natty n 18 | instance NATTY Z where 19 | natty = Zy 20 | instance NATTY n => NATTY (S n) where 21 | natty = Sy natty 22 | 23 | 24 | -------------------------------------------------------------------------- 25 | -- ORDER PRESERVING EMBEDDINGS 26 | -------------------------------------------------------------------------- 27 | 28 | -- order preserving embeddings 29 | data OPE :: Nat -> Nat -> * where 30 | OPEI :: Natty n -> OPE n n 31 | OPES :: OPE n m -> OPE (S n) (S m) 32 | OPE' :: OPE n m -> OPE n (S m) 33 | deriving instance Show (OPE n m) 34 | 35 | -- smart constructor maximizing use of OPEI 36 | opeS :: OPE n m -> OPE (S n) (S m) 37 | opeS (OPEI n) = OPEI (Sy n) 38 | opeS p = OPES p 39 | 40 | -- finding both ends of an OPE 41 | opeEnds :: OPE n m -> (Natty n, Natty m) 42 | opeEnds (OPEI n) = (n, n) 43 | opeEnds (OPES p) = case opeEnds p of 44 | (n, m) -> (Sy n, Sy m) 45 | opeEnds (OPE' p) = case opeEnds p of 46 | (n, m) -> (n, Sy m) 47 | 48 | -- composition of OPEs 49 | (<^>) :: OPE m p -> OPE n m -> OPE n p 50 | OPEI _ <^> q = q 51 | p <^> OPEI _ = p 52 | OPES p <^> OPES q = opeS (p <^> q) 53 | OPES p <^> OPE' q = OPE' (p <^> q) 54 | OPE' p <^> q = OPE' (p <^> q) 55 | 56 | -- OPEs from empty 57 | nOPE :: Natty n -> OPE Z n 58 | nOPE Zy = OPEI Zy 59 | nOPE (Sy n) = OPE' (nOPE n) 60 | 61 | 62 | -------------------------------------------------------------------------- 63 | -- LAMBDA CALCULUS 64 | -------------------------------------------------------------------------- 65 | 66 | -- Finite sets are OPEs from one 67 | type Fin = OPE (S Z) 68 | fZ :: NATTY n => Fin (S n) 69 | fZ = opeS (nOPE natty) 70 | fS :: Fin n -> Fin (S n) 71 | fS = OPE' 72 | 73 | -- Yer traditional well scoped lambda terms 74 | data Tm :: Nat -> * where 75 | V :: Fin n -> Tm n 76 | (:$) :: Tm n -> Tm n -> Tm n 77 | L :: Tm (S n) -> Tm n 78 | deriving instance Show (Tm n) 79 | 80 | 81 | -------------------------------------------------------------------------- 82 | -- OPE COPRODUCTS 83 | -------------------------------------------------------------------------- 84 | 85 | -- Encoding pairs of OPEs with the same target, 86 | -- ensuring that the target is *covered*. 87 | data OPE2 :: Nat -> Nat -> Nat -> * where 88 | OPEII :: Natty m -> OPE2 m m m 89 | OPESS :: OPE2 n n' m -> OPE2 (S n) (S n') (S m) 90 | OPES' :: OPE2 n n' m -> OPE2 (S n) n' (S m) 91 | OPE'S :: OPE2 n n' m -> OPE2 n (S n') (S m) 92 | deriving instance Show (OPE2 n n' m) 93 | 94 | -- smart constructor, ya da ya da 95 | opeSS :: OPE2 n n' m -> OPE2 (S n) (S n') (S m) 96 | opeSS (OPEII n) = OPEII (Sy n) 97 | opeSS p = OPESS p 98 | 99 | -- extract left OPE 100 | lope :: OPE2 n n' m -> OPE n m 101 | lope (OPEII n) = OPEI n 102 | lope (OPESS p) = opeS (lope p) 103 | lope (OPES' p) = opeS (lope p) 104 | lope (OPE'S p) = OPE' (lope p) 105 | 106 | -- extract right OPE 107 | rope :: OPE2 n n' m -> OPE n' m 108 | rope (OPEII n) = OPEI n 109 | rope (OPESS p) = opeS (rope p) 110 | rope (OPES' p) = OPE' (rope p) 111 | rope (OPE'S p) = opeS (rope p) 112 | 113 | -- construct OPE2 full on left, empty on right 114 | alll :: Natty n -> OPE2 n Z n 115 | alll Zy = OPEII Zy 116 | alll (Sy n) = OPES' (alll n) 117 | 118 | -- construct OPE2 empty on left, full on right 119 | allr :: Natty n -> OPE2 Z n n 120 | allr Zy = OPEII Zy 121 | allr (Sy n) = OPE'S (allr n) 122 | 123 | -- if you have two OPEs targeting m', then we can compute the 124 | -- OPE2 which targets the union of their images, and the OPE which 125 | -- embeds *that* in m' (representing the points hit by neither); 126 | -- it's a kind of coproduct calculation, being the smallest thing 127 | -- supporting both injections 128 | 129 | data COPOPE :: Nat -> Nat -> Nat -> * where 130 | COPOPE :: OPE2 n n' m -> OPE m m' -> COPOPE n n' m' 131 | copOPE :: OPE n m' -> OPE n' m' -> COPOPE n n' m' 132 | copOPE (OPEI n) (OPEI _) = COPOPE (OPEII n) (OPEI n) 133 | copOPE (OPEI (Sy n)) q = copOPE (OPES (OPEI n)) q 134 | copOPE p (OPEI (Sy n)) = copOPE p (OPES (OPEI n)) 135 | copOPE (OPES p) (OPES q) = case copOPE p q of 136 | COPOPE pq r -> COPOPE (opeSS pq) (opeS r) 137 | copOPE (OPES p) (OPE' q) = case copOPE p q of 138 | COPOPE pq r -> COPOPE (OPES' pq) (opeS r) 139 | copOPE (OPE' p) (OPES q) = case copOPE p q of 140 | COPOPE pq r -> COPOPE (OPE'S pq) (opeS r) 141 | copOPE (OPE' p) (OPE' q) = case copOPE p q of 142 | COPOPE pq r -> COPOPE pq (OPE' r) 143 | 144 | -- annoying lemma: if the sources of an OPE2 are nonzero, 145 | -- the target certainly is 146 | data OPE2SSS :: Nat -> Nat -> Nat -> * where 147 | OPE2SSS :: OPE2 (S n) (S n') (S m) -> OPE2SSS (S n) (S n') (S m) 148 | ope2SSS :: OPE2 (S n) (S n') m -> OPE2SSS (S n) (S n') m 149 | ope2SSS (OPEII n) = OPE2SSS (OPEII n) 150 | ope2SSS (OPESS p) = OPE2SSS (opeSS p) 151 | ope2SSS (OPES' p) = OPE2SSS (OPES' p) 152 | ope2SSS (OPE'S p) = OPE2SSS (OPE'S p) 153 | 154 | 155 | -------------------------------------------------------------------------- 156 | -- UNDERGROUND RELEVANT TERMS 157 | -------------------------------------------------------------------------- 158 | 159 | -- closed terms 160 | data Cl :: * where 161 | (:$$) :: Cl -> Cl -> Cl 162 | CL :: Un (S Z) -> Cl 163 | CK :: Cl -> Cl 164 | deriving instance Show Cl 165 | 166 | -- stations are either variables or junctions with action in both branches 167 | data St :: Nat -> * where 168 | It :: St (S Z) 169 | Ap :: OPE2 (S n) (S n') (S m) -> Un (S n) -> Un (S n') -> St (S m) 170 | deriving instance Show (St n) 171 | 172 | -- tubes binding n variables have only closed terms either side 173 | data Tu :: Nat -> * where 174 | TH :: Tu Z 175 | TL :: Tu m -> Tu (S m) 176 | TK :: Tu m -> Tu m 177 | TF :: Tu m -> Cl -> Tu m 178 | TA :: Cl -> Tu m -> Tu m 179 | deriving instance Show (Tu m) 180 | 181 | -- abacus addition adds number bound to number free 182 | type family Abacus (m :: Nat) (n :: Nat) :: Nat where 183 | Abacus Z n = n 184 | Abacus (S m) n = Abacus m (S n) 185 | 186 | -- underground relevant terms are either closed, 187 | -- or they're tubes which bring us to a station 188 | data Un :: Nat -> * where 189 | UC :: Cl -> Un Z 190 | UTJ :: Natty m -> Tu m -> St (Abacus m (S n)) -> Un (S n) 191 | deriving instance Show (Un n) 192 | 193 | -- for every term, we can find the variables it actually uses and 194 | -- build the underground relevant representation over just those, 195 | -- with the OPE that embeds back where we came from 196 | data TM :: Nat -> * where 197 | MkTM :: OPE n m -> Un n -> TM m 198 | deriving instance Show (TM n) 199 | 200 | tm :: Tm m -> TM m 201 | tm (V i) = MkTM i (UTJ Zy TH It) 202 | tm (L t) = case tm t of 203 | MkTM (OPE' r) (UC c) -> MkTM r (UC (CK c)) 204 | MkTM (OPE' r) (UTJ k t j) -> MkTM r (UTJ k (TK t) j) 205 | MkTM (OPES r) (UTJ k t j) -> case opeEnds r of 206 | (Zy, _) -> MkTM r (UC (CL (UTJ k t j))) 207 | (Sy _, _) -> MkTM r (UTJ (Sy k) (TL t) j) 208 | MkTM (OPEI (Sy Zy)) (UTJ k t j) -> MkTM (OPEI Zy) (UC (CL (UTJ k t j))) 209 | MkTM (OPEI (Sy (Sy n))) (UTJ k t j) -> MkTM (OPEI (Sy n)) (UTJ (Sy k) (TL t) j) 210 | tm (f :$ s) = case (tm f, tm s) of 211 | (MkTM r (UC cf), MkTM _ (UC cs)) -> MkTM r (UC (cf :$$ cs)) 212 | (MkTM _ (UC cf), MkTM r (UTJ k t j)) -> MkTM r (UTJ k (TA cf t) j) 213 | (MkTM r (UTJ k t j), MkTM _ (UC cs)) -> MkTM r (UTJ k (TF t cs) j) 214 | (MkTM r uf@(UTJ _ _ _), MkTM r' us@(UTJ _ _ _)) -> case copOPE r r' of 215 | COPOPE p pr -> case ope2SSS p of 216 | OPE2SSS p -> MkTM pr (UTJ Zy TH (Ap p uf us)) 217 | 218 | -- we can still do a case analysis like it's a regular term, but 219 | -- we get a reliable distinction between vacuous and relevant abstraction 220 | caseUn :: Natty m -> 221 | p (S Z) -> 222 | (forall n n'. OPE2 n n' m -> Un n -> Un n' -> p m) -> 223 | (Un m -> p m) -> 224 | (Un (S m) -> p m) -> 225 | Un m -> p m 226 | caseUn m v a k l (UC (f :$$ s)) = a (OPEII Zy) (UC f) (UC s) 227 | caseUn m v a k l (UC (CK t)) = k (UC t) 228 | caseUn m v a k l (UC (CL u)) = l u 229 | caseUn m v a k l (UTJ Zy TH It) = v 230 | caseUn m v a k l (UTJ Zy TH (Ap p f s)) = a p f s 231 | caseUn m v a k l (UTJ n (TK t) j) = k (UTJ n t j) 232 | caseUn m v a k l (UTJ (Sy n) (TL t) j) = l (UTJ n t j) 233 | caseUn m v a k l (UTJ n (TF t s) j) = a (alll m) (UTJ n t j) (UC s) 234 | caseUn m v a k l (UTJ n (TA f t) j) = a (allr m) (UC f) (UTJ n t j) 235 | 236 | -------------------------------------------------------------------------------- /STLCThin.agda: -------------------------------------------------------------------------------- 1 | module STLCThin where 2 | 3 | {- I'm going to show that well scoped well typed 4 | syntax is a presheaf over the semisimplicial 5 | category of contexts, despite the fact that 6 | it's painfully obvious. -} 7 | 8 | {- I'll need simple types... -} 9 | 10 | data Ty : Set where 11 | base : Ty -- any old base type 12 | _>>_ : Ty -> Ty -> Ty -- functions 13 | 14 | {- ...and right-growing (i.e., backward) lists 15 | to put them in, to make contexts. -} 16 | 17 | data Bwd (X : Set) : Set where 18 | [] : Bwd X 19 | _-,_ : Bwd X -> X -> Bwd X 20 | 21 | {- Now the semisimplicial category. -} 22 | 23 | data _<=_ {X : Set} : Bwd X -> Bwd X -> Set where 24 | _-^_ : forall {xz yz} 25 | -> xz <= yz 26 | -> forall y 27 | -> xz <= (yz -, y) 28 | _-,_ : forall {xz yz} 29 | -> xz <= yz 30 | -> forall y 31 | -> (xz -, y) <= (yz -, y) 32 | [] : [] <= [] 33 | 34 | {- Read right to left, this is exactly how to 35 | choose none, some or all of the entries in 36 | a context. (It's secretly a bit vector.) 37 | Read left to right, this is an embedding of 38 | a context into a larger one, preserving 39 | order. -} 40 | 41 | {- Identity -} 42 | 43 | iota : forall {X}(xz : Bwd X) -> xz <= xz 44 | iota [] = [] 45 | iota (xz -, x) = iota xz -, x -- CLUE! 46 | 47 | {- Composition (diagrammatic) -} 48 | 49 | _-<=-_ : forall {X}{xz yz zz : Bwd X} -> 50 | xz <= yz -> yz <= zz -> xz <= zz 51 | th -<=- (ph -^ y) = (th -<=- ph) -^ y 52 | (th -^ y) -<=- (ph -, y) = (th -<=- ph) -^ y 53 | (th -, y) -<=- (ph -, y) = (th -<=- ph) -, y -- CLUE! 54 | [] -<=- [] = [] 55 | 56 | {- I omit the proofs because I'm in a hurry. -} 57 | 58 | {- The two CLUEs show that context extension is 59 | on-the-nose covariantly functorial. -} 60 | 61 | {- Now, here are well scoped well typed terms. -} 62 | 63 | data _|-_ (Ga : Bwd Ty) : Ty -> Set where 64 | 65 | var : forall {T} 66 | -> ([] -, T) <= Ga -- Ga on the *right* of <= 67 | ------------------ 68 | -> Ga |- T 69 | 70 | app : forall {S T} 71 | -> Ga |- (S >> T) 72 | -> Ga |- S 73 | ----------------- 74 | -> Ga |- T 75 | 76 | lam : forall {S T} 77 | -> (Ga -, S) |- T -- context extension! 78 | ----------------- 79 | -> Ga |- (S >> T) 80 | 81 | {- The above is the fixpoint of a polynomial with 82 | 83 | O = Bwd Ty * Ty -- contexts and types of terms 84 | ^ 85 | | inl (Ga, T, x) |-> Ga, T 86 | | inr (lam, Ga, S, T) |-> Ga, S >> T 87 | | inr (app, Ga, S, T) |-> Ga, T 88 | | 89 | S = ((Ga, t) : Bwd Ty * Ty) * ([] -, T) <= Ga 90 | + {lam, app} * Bwd Ty * Ty * Ty 91 | ^ 92 | | lam, Ga, S, T |-> inr (lam, Ga, S, T) 93 | | fun, Ga, S, T |-> inr (app, Ga, S, T) 94 | | arg, Ga, S, T |-> inr (app, Ga, S, T) 95 | | 96 | P = {lam, fun, arg} * Bwd Ty * Ty * Ty 97 | | 98 | | lam, Ga, S, T |-> (Ga -, S), T 99 | | fun, Ga, S, T |-> Ga, (S >> T) 100 | | arg, Ga, S, T |-> Ga, S 101 | v 102 | I = Bwd Ty * Ty -- contexts and types of subterms 103 | 104 | -} 105 | 106 | {- It is absolutely no surprise that I can now "thin" 107 | terms, embedding their context into a larger context. -} 108 | 109 | _^_ : forall {Ga De T} -> Ga |- T -> Ga <= De -> De |- T 110 | var x ^ th = var (x -<=- th) 111 | app f s ^ th = app (f ^ th) (s ^ th) 112 | lam t ^ th = lam (t ^ (th -, _)) -- Agda figures "_" out 113 | 114 | {- And then I should prove that 115 | t ^ iota Ga = t 116 | t ^ (th -<=- ph) = (t ^ th) ^ ph 117 | -} 118 | 119 | {- Or rather, I SHOULDN'T, because it's OBVIOUS! -} 120 | 121 | {- The point is that the definition of _|-_ is manifestly 122 | STRICTLY POSITIVE in Ga, seen as an object of _<=_. 123 | because it is used in morphisms only on the right 124 | (hence admitting postcomposition) and acted on only 125 | covariantly (hence allowing context extension under 126 | lam). I've already paid for my functor! -} 127 | 128 | {- But Agda doesn't let me construct *functors* 129 | (Bwd Ty, <=) -> (Set, ->)/Ty 130 | so I'm forced to play stupid, work in 131 | |Bwd Ty| -> (Set, ->)/Ty 132 | and then work hard to "discover" the functoriality 133 | I already knew I wanted, in advance. -} 134 | 135 | {- And that's why I'm thinking about how to expose 136 | the functoriality I'm looking for when giving the 137 | polynomial whose fixpoint I'm taking (which is 138 | what data declarations do, in effect). -} 139 | -------------------------------------------------------------------------------- /StackM.agda: -------------------------------------------------------------------------------- 1 | module StackM where 2 | 3 | {- 4 | Types of Truth 5 | 6 | Conor McBride 7 | 8 | Mathematically Structured Programming 9 | Computer and Information Sciences 10 | University of Strathclyde 11 | -} 12 | 13 | {- This file is Agda code. If you load it in an Agda-enabled editor (e.g., emacs), 14 | Agda will colour it in for you, but not in the colours I like to use. Deep in 15 | the configuration menus, there's an option to use my colours. -} 16 | 17 | {- We have data types, quite like those in Haskell, but there are no funny 18 | rules about capital letters. My habit is to use Big Letters for Big Things 19 | (like types) and small letters for small things (like values). Agda helpfully 20 | colours them in for us: blue for type constructors and red for value 21 | constructors. And we just say directly what types the things have. 22 | Set is the type of types (or, more particularly, the type of types which 23 | never talk about types, themselves). -} 24 | 25 | {- Haskell calls this "Bool", but I like to count the things. -} 26 | data Two : Set where ff tt : Two 27 | 28 | {- Numbers, we must make from potatoes, but we can ask Agda to use Arabic 29 | notation. -} 30 | data Nat : Set where 31 | ze : Nat 32 | su : Nat -> Nat 33 | {-# BUILTIN NATURAL Nat #-} 34 | 35 | {- We can define functions (they're green) in pattern matching style, with purple 36 | pattern variables. Agda helps us make sure we cover all the cases. The truth we 37 | must tell is that whenever a function gets some input, it produces some output. 38 | No looping. No leaving out any possible cases. -} 39 | _+_ : Nat -> Nat -> Nat 40 | ze + y = y 41 | su x + y = su (x + y) 42 | 43 | {- But we can also make types which tell tighter truths. Here, I generalise lists 44 | to paths from one point to another. The points live in some type X, and the 45 | paths are made of segments given by a family of types, R, indexed over where 46 | the segment starts and ends. Note that Agda allows me fancy mixfix notation. 47 | When I declare something with underscores in the name, those underscores say 48 | where the things go. The empty path, [], ends wherever it starts. If we have 49 | a segment from x to y and a path from y to z, we can use "cons" (which I write 50 | asymmetrically as ,-) We're enforcing that the segments of a path all join up 51 | properly. And note that I'm beginning to talk about types of things using 52 | language that sounds like stating truths. -} 53 | data _-[_>_ {X : Set}(x : X)(R : X -> X -> Set) : X -> Set where 54 | [] : x -[ R > x 55 | _,-_ : forall {y z} -> R x y -> y -[ R > z -> x -[ R > z 56 | infixr 10 _,-_ 57 | infix 5 _-[_>_ 58 | 59 | {- Concatenation of paths: the code looks just like concatenation of lists, but 60 | look at the truth the type tells! -} 61 | _++_ : {X : Set}{R : X -> X -> Set}{x y z : X} 62 | -> x -[ R > y -> y -[ R > z -> x -[ R > z 63 | [] ++ ss = ss 64 | (r ,- rs) ++ ss = r ,- rs ++ ss 65 | infixr 10 _++_ 66 | 67 | {- Now, I'm going to use paths to represent programs in the machine code of a 68 | stack machine. The individual instructions don't make sense in all circumstances. 69 | We must rather care about what types of things are on the stack to ensure that a 70 | given instruction is appropriate. How to way say what's on the stack? With a 71 | stack of types! I write stacks as lists which grow on the *right*. One boring 72 | but vital lesson I have learned in my life is to mind the spatial properties of 73 | my program texts. I would rather have more types of list than flip my head. -} 74 | 75 | {- Note that I reuse []. Agda will disambiguate. I write -, for "snoc", growing lists 76 | on the right. -} 77 | data Bwd (X : Set) : Set where 78 | [] : Bwd X 79 | _-,_ : Bwd X -> X -> Bwd X 80 | infixl 10 _-,_ 81 | 82 | {- I will have two types of stack entry: bits and numbers. -} 83 | data Ty : Set where 84 | `Two : Ty 85 | `Nat : Ty 86 | 87 | {- I can write a program saying which Agda types represent values in which stack 88 | entry types. -} 89 | Val : Ty -> Set 90 | Val `Two = Two 91 | Val `Nat = Nat 92 | 93 | {- And now I can say what the instructions are, and what stack transitions they make. -} 94 | data Inst : Bwd Ty -> Bwd Ty -> Set where 95 | -- we can push a value onto the stack 96 | PSH : forall {Tz T} -> Val T -> Inst Tz (Tz -, T) 97 | -- we can add the top two numbers on the stack and put their sum back 98 | ADD : forall {Tz} -> Inst (Tz -, `Nat -, `Nat) (Tz -, `Nat) 99 | -- if there's a bit on top of the stack, we can choose between code paths 100 | PAF : forall {Tz Uz}(fc tc : Tz -[ Inst > Uz) -> Inst (Tz -, `Two) Uz 101 | 102 | {- What is a stack? It's a kind of truth, that we know a value of the right type for 103 | every entry in the stack of types. So let's have a type for that. -} 104 | data [Bwd] {X : Set}(P : X -> Set) : Bwd X -> Set where 105 | [] : [Bwd] P [] 106 | _-,_ : forall {xz x} -> [Bwd] P xz -> P x -> [Bwd] P (xz -, x) 107 | 108 | {- Now let's say how to run a program that gets us from one stack state to another. -} 109 | infixl 5 _!>_ 110 | _!>_ : forall {Tz Uz} -> [Bwd] Val Tz -> Tz -[ Inst > Uz -> [Bwd] Val Uz 111 | vz !> [] = vz 112 | vz !> PSH x ,- is = vz -, x !> is 113 | vz -, m -, n !> ADD ,- is = vz -, (m + n) !> is 114 | vz -, ff !> PAF fc tc ,- is = vz !> fc !> is 115 | vz -, tt !> PAF fc tc ,- is = vz !> tc !> is 116 | 117 | {- Now, let's put a simple functional programming language on top. -} 118 | data Expr : Ty -> Set where 119 | val : {T : Ty} -> Val T -> Expr T 120 | _+E_ : Expr `Nat -> Expr `Nat -> Expr `Nat 121 | if_then_else_ : forall {T} -> Expr `Two -> Expr T -> Expr T -> Expr T 122 | 123 | {- We can have a reference interpreter which promises a value for every expression. -} 124 | eval : forall {T} -> Expr T -> Val T 125 | eval (val x) = x 126 | eval (e +E e') = eval e + eval e' 127 | eval (if eb then et else ef) with eval eb -- "with" brings the value of something to the left 128 | eval (if eb then et else ef) | ff = eval ef 129 | eval (if eb then et else ef) | tt = eval et 130 | 131 | {- Now, let's compile expressions. We should be able to start with any stack, and end with 132 | one more value on the stack than we had at the start. -} 133 | compile : forall {Tz T} -> Expr T -> Tz -[ Inst > Tz -, T 134 | compile (val x) = PSH x ,- [] 135 | compile (e +E e') = compile e ++ compile e' ++ ADD ,- [] 136 | compile (if e then et else ef) = compile e ++ PAF (compile ef) (compile et) ,- [] 137 | 138 | 139 | {- But we don't know our compiler gives *correct* code. Let's prove it. We will need to 140 | state an equation. -} 141 | 142 | data _~_ {X : Set}(x : X) : X -> Set where 143 | r~ : x ~ x 144 | infix 1 _~_ 145 | 146 | {- This is fancy notation for writing equational explanations that you can read! -} 147 | _~[_>_ : forall {X}(x : X){y z : X} -> x ~ y -> y ~ z -> x ~ z 148 | x ~[ r~ > q = q 149 | _[QED] : forall {X}(x : X) -> x ~ x 150 | x [QED] = r~ 151 | infixr 2 _~[_>_ 152 | infixr 3 _[QED] 153 | 154 | {- Doing the same function to equal inputs gives you equal outputs. -} 155 | _$~_ : {S T : Set}(f : S -> T){x y : S} -> x ~ y -> f x ~ f y 156 | f $~ r~ = r~ 157 | 158 | {- We'll need to run our program a bit at a time. That means we need the fact that running 159 | a whole program gives the same answer as running the beginning then the end. The way you 160 | do a proof like this is to trick the programs involved into taking a step. -} 161 | runs : forall {Sz Tz Uz}(vz : [Bwd] Val Sz)(is : Sz -[ Inst > Tz)(js : Tz -[ Inst > Uz) 162 | -> vz !> is ++ js ~ vz !> is !> js 163 | runs vz [] js = r~ 164 | runs vz (PSH x ,- is) js = runs _ is js 165 | runs (vz -, m -, n) (ADD ,- is) js = runs _ is js 166 | runs (vz -, ff) (PAF fc tc ,- is) js = runs _ is js 167 | runs (vz -, tt) (PAF fc tc ,- is) js = runs _ is js 168 | 169 | {- Now we can prove that running compiled code for an expression effectively pushes the 170 | value of the expression. -} 171 | agree : forall {Tz T}(vz : [Bwd] Val Tz)(e : Expr T) 172 | -> vz !> compile e ~ (vz -, eval e) 173 | agree vz (val x) = r~ 174 | agree vz (e +E e') = 175 | vz !> compile (e +E e') 176 | ~[ r~ > 177 | vz !> compile e ++ compile e' ++ ADD ,- [] 178 | ~[ runs vz (compile e) _ > 179 | vz !> compile e !> compile e' ++ ADD ,- [] 180 | ~[ (_!> compile e' ++ ADD ,- []) $~ agree vz e > 181 | vz -, eval e !> compile e' ++ ADD ,- [] 182 | ~[ runs (vz -, _) (compile e') _ > 183 | vz -, eval e !> compile e' !> ADD ,- [] 184 | ~[ (_!> ADD ,- []) $~ agree (vz -, _) e' > 185 | vz -, eval e -, eval e' !> ADD ,- [] 186 | ~[ r~ > 187 | (vz -, eval (e +E e')) 188 | [QED] 189 | agree vz (if e then et else ef) with eval e | agree vz e -- double with! 190 | agree vz (if e then et else ef) | ff | bq = 191 | vz !> compile e ++ PAF (compile ef) (compile et) ,- [] 192 | ~[ runs vz (compile e) _ > 193 | vz !> compile e !> PAF (compile ef) (compile et) ,- [] 194 | ~[ (_!> PAF (compile ef) (compile et) ,- []) $~ bq > 195 | vz -, ff !> PAF (compile ef) (compile et) ,- [] 196 | ~[ agree vz ef > 197 | vz -, eval ef 198 | [QED] 199 | agree vz (if e then et else ef) | tt | bq = 200 | vz !> compile e ++ PAF (compile ef) (compile et) ,- [] 201 | ~[ runs vz (compile e) _ > 202 | vz !> compile e !> PAF (compile ef) (compile et) ,- [] 203 | ~[ (_!> PAF (compile ef) (compile et) ,- []) $~ bq > 204 | vz -, tt !> PAF (compile ef) (compile et) ,- [] 205 | ~[ agree vz et > 206 | vz -, eval et 207 | [QED] 208 | 209 | -------------------------------------------------------------------------------- /T-NorB.agda: -------------------------------------------------------------------------------- 1 | module T-NorB where 2 | 3 | data Nat : Set where 4 | ze : Nat 5 | su : Nat -> Nat 6 | 7 | {-# BUILTIN NATURAL Nat #-} 8 | 9 | data Dir : Set where chk syn : Dir 10 | 11 | data Bwd (X : Set) : Set where 12 | [] : Bwd X 13 | _-,_ : Bwd X -> X -> Bwd X 14 | 15 | data BVec (X : Set) : Nat -> Set where 16 | [] : BVec X ze 17 | _-,_ : {n : Nat} -> BVec X n -> X -> BVec X (su n) 18 | 19 | infixl 3 _-,_ 20 | 21 | data Ty : Set where 22 | nat bool : Ty 23 | _=>_ : Ty -> Ty -> Ty 24 | 25 | infixr 4 _=>_ 26 | 27 | data _<=_ : Nat -> Nat -> Set where 28 | oz : ze <= ze 29 | os : {n m : Nat} -> n <= m -> su n <= su m 30 | o' : {n m : Nat} -> n <= m -> n <= su m 31 | 32 | _-<-_ : forall {p n m} -> p <= n -> n <= m -> p <= m 33 | f -<- o' g = o' (f -<- g) 34 | oz -<- oz = oz 35 | os f -<- os g = os (f -<- g) 36 | o' f -<- os g = o' (f -<- g) 37 | 38 | oi : forall {n} -> n <= n 39 | oi {ze} = oz 40 | oi {su x} = os oi 41 | 42 | on : forall {n} -> ze <= n 43 | on {ze} = oz 44 | on {su x} = o' on 45 | 46 | _/_ : forall {X n} -> BVec X n -> 1 <= n -> X 47 | [] / () 48 | (xz -, x) / os _ = x 49 | (xz -, x) / o' i = xz / i 50 | 51 | data Tm (n : Nat) : Dir -> Set where 52 | [_] : Tm n syn -> Tm n chk 53 | lam : Tm (su n) chk -> Tm n chk 54 | _%_ : Nat -> Bwd (Tm n chk) -> Tm n chk 55 | # : 1 <= n -> Tm n syn 56 | _$_ : Tm n syn -> Tm n chk -> Tm n syn 57 | rec : Tm n syn -> Ty -> Tm n chk -> Tm n chk -> Tm n syn 58 | _::_ : Tm n chk -> Ty -> Tm n syn 59 | infixl 4 _$_ 60 | infixr 2 _%_ 61 | 62 | _^_ : forall {n m d} -> Tm n d -> n <= m -> Tm m d 63 | _^z_ : forall {n m d} -> Bwd (Tm n d) -> n <= m -> Bwd (Tm m d) 64 | [ t ] ^ r = [ t ^ r ] 65 | lam t ^ r = lam (t ^ os r) 66 | (c % tz) ^ r = c % (tz ^z r) 67 | # i ^ r = # (i -<- r) 68 | (f $ s) ^ r = (f ^ r) $ (s ^ r) 69 | rec e T t t' ^ r = rec (e ^ r) T (t ^ r) (t' ^ r) 70 | (t :: T) ^ r = (t ^ r) :: T 71 | 72 | [] ^z r = [] 73 | (tz -, t) ^z r = (tz ^z r) -, (t ^ r) 74 | 75 | data _+_ (S T : Set) : Set where 76 | inl : S -> S + T 77 | inr : T -> S + T 78 | 79 | data Maybe (X : Set) : Set where 80 | yes : X -> Maybe X 81 | no : Maybe X 82 | 83 | data Two : Set where 84 | tt ff : Two 85 | record One : Set where constructor <> 86 | record Sg (S : Set)(T : S -> Set) : Set where 87 | constructor _,_ 88 | field 89 | fst : S 90 | snd : T fst 91 | open Sg 92 | _*_ : Set -> Set -> Set 93 | S * T = Sg S \ _ -> T 94 | 95 | Va Go : Ty -> Nat -> Set 96 | Va T n = Tm n syn + Go T n 97 | Go nat n = Nat * (One + Tm n syn) 98 | Go bool n = Two 99 | Go (S => T) n = {m : Nat} -> n <= m -> Va S m -> Maybe (Va T m) 100 | 101 | _!_^^_ : forall T {n m} -> Va T n -> n <= m -> Va T m 102 | T ! inl e ^^ r = inl (e ^ r) 103 | nat ! inr (n , inl <>) ^^ r = inr (n , inl <>) 104 | nat ! inr (n , inr e) ^^ r = inr (n , inr (e ^ r)) 105 | bool ! inr tt ^^ r = inr tt 106 | bool ! inr ff ^^ r = inr ff 107 | (S => T) ! inr g ^^ r = inr \ r' s -> g (r -<- r') s 108 | 109 | Cell : Nat -> Set 110 | Cell n = Sg Ty \ T -> Va T n 111 | 112 | _^C_ : forall {n m} -> Cell n -> n <= m -> Cell m 113 | (T , v) ^C r = T , (T ! v ^^ r) 114 | 115 | Env : Nat -> Nat -> Set 116 | Env n l = BVec (Cell l) n 117 | 118 | _^E_ : forall {n m l} -> Env l n -> n <= m -> Env l m 119 | [] ^E r = [] 120 | (g -, c) ^E r = (g ^E r) -, (c ^C r) 121 | 122 | _>>=_ : {S T : Set} -> Maybe S -> (S -> Maybe T) -> Maybe T 123 | no >>= k = no 124 | yes s >>= k = k s 125 | 126 | data _==_ {X : Set}(x : X) : X -> Set where 127 | refl : x == x 128 | 129 | tyQ? : (S T : Ty) -> Maybe (S == T) 130 | tyQ? nat nat = yes refl 131 | tyQ? nat bool = no 132 | tyQ? nat (_ => _) = no 133 | tyQ? bool nat = no 134 | tyQ? bool bool = yes refl 135 | tyQ? bool (_ => _) = no 136 | tyQ? (_ => _) nat = no 137 | tyQ? (_ => _) bool = no 138 | tyQ? (S => T) (S' => T') with tyQ? S S' | tyQ? T T' 139 | tyQ? (S => T) (.S => .T) | yes refl | yes refl = yes refl 140 | tyQ? (S => T) (S' => T') | _ | _ = no 141 | 142 | sucs : Nat -> forall {m} -> Tm m chk -> Tm m chk 143 | sucs ze t = t 144 | sucs (su n) t = 1 % ([] -, sucs n t) 145 | 146 | stop : forall T {l} -> Va T l -> Maybe (Tm l chk) 147 | stop T (inl e) = yes [ e ] 148 | stop nat (inr (n , inl <>)) = yes (sucs n (0 % [])) 149 | stop nat (inr (n , inr e)) = yes (sucs n [ e ]) 150 | stop bool (inr tt) = yes (1 % []) 151 | stop bool (inr ff) = yes (0 % []) 152 | stop (S => T) (inr g) = 153 | g (o' oi) (inl (# (os on))) >>= \ v -> 154 | stop T v >>= \ t -> 155 | yes (lam t) 156 | 157 | apply : forall S T {l} -> Va (S => T) l -> Va S l -> Maybe (Va T l) 158 | apply S T (inl f) u = stop S u >>= \ s -> yes (inl (f $ s)) 159 | apply S T (inr g) u = g oi u 160 | 161 | primRec : {l : Nat}(T : Ty) -> Va nat l -> 162 | Maybe (Va T l) -> Maybe (Va (nat => T => T) l) -> 163 | Maybe (Cell l) 164 | primRec T (inl e) (yes vz) ms = 165 | stop T vz >>= \ tz -> 166 | ms >>= \ vs -> stop (nat => T => T) vs >>= \ ts -> 167 | yes (T , inl (rec e T tz ts)) 168 | primRec {l} T (inr (n , t)) (yes vz) ms = 169 | go n t >>= \ v -> yes (T , v) 170 | where 171 | go : Nat -> (One + Tm l syn) -> Maybe (Va T l) 172 | go ze (inl <>) = yes vz 173 | go ze (inr e) = 174 | stop T vz >>= \ tz -> 175 | ms >>= \ vs -> stop (nat => T => T) vs >>= \ ts -> 176 | yes (inl (rec e T tz ts)) 177 | go (su n) t = go n t >>= \ v -> ms >>= \ vs -> 178 | apply nat (T => T) vs (inr (n , t)) >>= \ vf -> 179 | apply T T vf v 180 | primRec _ _ _ _ = no 181 | 182 | chkEval : {n l : Nat} -> Env n l -> 183 | (T : Ty) -> Tm n chk -> Maybe (Va T l) 184 | evalSyn : {n l : Nat} -> Env n l -> 185 | Tm n syn -> Maybe (Cell l) 186 | chkEval g T [ e ] with evalSyn g e 187 | chkEval g T [ e ] | no = no 188 | chkEval g T [ e ] | yes (S , v) with tyQ? S T 189 | chkEval g .S [ e ] | yes (S , v) | (yes refl) = yes v 190 | chkEval g T [ e ] | yes (S , v) | no = no 191 | chkEval g nat (lam t) = no 192 | chkEval g bool (lam t) = no 193 | chkEval g (S => T) (lam t) = 194 | yes (inr (\ r s -> chkEval ((g ^E r) -, (S , s)) T t)) 195 | chkEval g nat (0 % []) = yes (inr (ze , inl <>)) 196 | chkEval g nat (1 % [] -, n) = chkEval g nat n >>= 197 | \ { (inl e) -> yes (inr (1 , inr e)) 198 | ; (inr (n , t)) -> yes (inr (su n , t))} 199 | chkEval g bool (0 % []) = yes (inr ff) 200 | chkEval g bool (1 % []) = yes (inr tt) 201 | chkEval g _ (c % tz) = no 202 | evalSyn g (# i) = yes (g / i) 203 | evalSyn g (f $ s) = evalSyn g f >>= 204 | \ { ((S => T) , v) -> chkEval g S s 205 | >>= \ u -> apply S T v u >>= \ w -> yes (T , w) 206 | ; _ -> no } 207 | evalSyn g (rec e T t0 t1) with evalSyn g e 208 | evalSyn g (rec e T t0 t1) | yes (nat , v) = 209 | primRec T v (chkEval g T t0) (chkEval g (nat => T => T) t1) 210 | evalSyn g (rec e T t0 t1) | yes (bool , inl e') = 211 | chkEval g T t0 >>= \ v0 -> stop T v0 >>= \ n0 -> 212 | chkEval g T t1 >>= \ v1 -> stop T v1 >>= \ n1 -> 213 | yes (T , inl (rec e' T n0 n1)) 214 | evalSyn g (rec e T t0 t1) | yes (bool , inr tt) = 215 | chkEval g T t1 >>= \ v -> yes (T , v) 216 | evalSyn g (rec e T t0 t1) | yes (bool , inr ff) = 217 | chkEval g T t0 >>= \ v -> yes (T , v) 218 | ... | _ = no 219 | evalSyn g (t :: T) = chkEval g T t >>= \ v -> yes (T , v) 220 | 221 | add : forall {n} -> Tm n syn 222 | add = lam (lam [ rec (# (o' (os on))) nat 223 | [ # (os on) ] 224 | (lam (lam (1 % [] -, [ # (os on) ]))) ]) 225 | :: (nat => nat => nat) 226 | vNat : Nat -> forall {n} -> Tm n chk 227 | vNat ze = 0 % [] 228 | vNat (su n) = 1 % [] -, vNat n 229 | 230 | natQ : forall {n} -> Tm n syn 231 | natQ = lam [ rec (# (os on)) (nat => bool) 232 | (lam [ rec (# (os on)) bool 233 | (1 % []) 234 | (lam (lam (0 % []))) ]) 235 | (lam (lam (lam [ rec (# (os on)) bool 236 | (0 % []) 237 | (lam (lam [ # (o' (o' (o' (os on)))) 238 | $ [ # (o' (os on)) ] ])) ]))) 239 | ] :: (nat => nat => bool) 240 | 241 | test : Maybe (Cell ze) 242 | test = evalSyn [] (natQ $ [ add $ vNat 2 $ vNat 2 ] $ vNat 4) 243 | -------------------------------------------------------------------------------- /TakeOdd.agda: -------------------------------------------------------------------------------- 1 | module TakeOdd where 2 | 3 | -- here be lists 4 | data List (X : Set) : Set where 5 | [] : List X 6 | _,-_ : X -> List X -> List X 7 | infixr 10 _,-_ 8 | 9 | -- and here be their large eliminator 10 | elimList : forall {l X}(xs : List X)(P : List X -> Set l) 11 | -> P [] 12 | -> (forall x xs -> P xs -> P (x ,- xs)) 13 | -> P xs 14 | elimList [] P n c = n 15 | elimList (x ,- xs) P n c = c x xs (elimList xs P n c) 16 | 17 | -- no more pattern matching on lists! 18 | 19 | -- derive case analysis 20 | caseList : forall {l X}(xs : List X)(P : List X -> Set l) 21 | -> P [] 22 | -> (forall x xs -> P (x ,- xs)) 23 | -> P xs 24 | caseList xs P n c = elimList xs P n (\ x xs pxs -> c x xs) 25 | 26 | -- to define the recursor, let's have tuple kit 27 | record One {l} : Set l where 28 | constructor <> 29 | 30 | record _><_ {l}(S : Set l)(T : S -> Set l) : Set l where 31 | constructor _,_ 32 | no-eta-equality 33 | field 34 | fst : S 35 | snd : T fst 36 | open _><_ public 37 | _*_ : forall {l} -> Set l -> Set l -> Set l 38 | S * T = S >< \ _ -> T 39 | 40 | -- now define the memo structure for lists 41 | BelowList : forall {l X} -> (List X -> Set l) -> (List X -> Set l) 42 | BelowList P xs = elimList xs (\ _ -> Set _) One (\ x xs H -> P xs * H) 43 | 44 | -- show that it's constructoable 45 | belowList : forall {l X}(xs : List X)(P : List X -> Set l) 46 | -> ((xs : List X) -> BelowList P xs -> P xs) 47 | -> BelowList P xs 48 | belowList xs P m = elimList xs (BelowList P) <> (\ x xs bPxs -> m xs bPxs , bPxs) 49 | 50 | -- and now we get the recursor 51 | recList : forall {l X}(xs : List X)(P : List X -> Set l) 52 | -> ((xs : List X) -> BelowList P xs -> P xs) 53 | -> P xs 54 | recList xs P m = m xs (belowList xs P m) 55 | 56 | -- the relational story 57 | data [TakeOdd_]~_ {X : Set} : List X -> List X -> Set where 58 | takeOddNil : [TakeOdd [] ]~ [] 59 | takeOddOne : forall x -> [TakeOdd x ,- [] ]~ [] 60 | takeOddTwo : forall x y {zs os} -> [TakeOdd zs ]~ os -> [TakeOdd x ,- y ,- zs ]~ (y ,- os) 61 | 62 | mkTakeOdd : {X : Set}(xs : List X) -> _ >< [TakeOdd xs ]~_ 63 | mkTakeOdd xs = recList xs (\ xs -> _ >< [TakeOdd xs ]~_) 64 | \ xs -> caseList xs 65 | (\ xs -> BelowList (\ xs -> _ >< [TakeOdd xs ]~_) xs -> _ >< [TakeOdd xs ]~_) 66 | (\ _ -> _ , takeOddNil) 67 | \ x ys -> caseList ys 68 | (\ ys -> BelowList (\ xs -> _ >< [TakeOdd xs ]~_) (x ,- ys) 69 | -> _ >< [TakeOdd x ,- ys ]~_) 70 | (\ _ -> _ , takeOddOne x) 71 | \ y zs m -> _ , takeOddTwo x y (snd (fst (snd m))) 72 | 73 | takeOdd : {X : Set} -> List X -> List X 74 | takeOdd xs = fst (mkTakeOdd xs) 75 | 76 | -- let's check 77 | data _~_ {X : Set}(x : X) : X -> Set where 78 | r~ : x ~ x 79 | infix 2 _~_ 80 | 81 | eqnNil : forall {X} -> takeOdd {X} [] ~ [] 82 | eqnNil = r~ 83 | 84 | eqnOne : forall {X}{x : X} -> takeOdd (x ,- []) ~ [] 85 | eqnOne = r~ 86 | 87 | eqnTwo : forall {X}{x y : X}{zs : List X} -> takeOdd (x ,- y ,- zs) ~ y ,- takeOdd zs 88 | eqnTwo = r~ 89 | -------------------------------------------------------------------------------- /Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, RankNTypes, StandaloneDeriving, 2 | QuantifiedConstraints, LambdaCase, ScopedTypeVariables, 3 | TypeFamilies, UndecidableInstances, ConstraintKinds, 4 | IncoherentInstances, OverlappingInstances, TypeOperators #-} 5 | 6 | module Main where 7 | 8 | import Data.Constraint 9 | import Unsafe.Coerce 10 | 11 | data Time = Z | S Time deriving Show 12 | data Timey (t :: Time) :: * where 13 | Zy :: Timey Z 14 | Sy :: Timey n -> Timey (S n) 15 | 16 | data Le :: Time -> Time -> * where 17 | Now :: Le t t 18 | Later :: Le s t -> Le s (S t) 19 | deriving instance Show (Le s t) 20 | 21 | class Timed (v :: Time -> *) where 22 | (&>) :: v s -> Le s t -> v t 23 | 24 | instance Timed (Le s) where 25 | v &> Now = v 26 | v &> Later u = Later (v &> u) 27 | 28 | class LE (s :: Time)(t :: Time) where 29 | lesson :: Le s t 30 | 31 | instance LE s s where 32 | lesson = Now 33 | 34 | class StepTo (t :: Time) where 35 | type StepFrom t :: Time 36 | step :: Le (StepFrom t) t 37 | 38 | instance (LE s (StepFrom t), StepTo t) => LE s t where 39 | lesson = lesson &> step 40 | 41 | data FakeLe s t = FakeLe (Le s t) 42 | 43 | mkStep :: forall s t. Le s t -> Dict (StepTo t, (StepFrom t ~ s)) 44 | mkStep u = case (foo, baz) of 45 | (Dict, Dict) -> Dict 46 | where 47 | foo :: Dict (StepTo t) 48 | foo = unsafeCoerce (FakeLe u) 49 | bar :: Dict (s ~ s) 50 | bar = Dict 51 | baz :: Dict (StepFrom t ~ s) 52 | baz = unsafeCoerce bar 53 | 54 | leap :: forall s t x 55 | . Le s t 56 | -> ((StepTo t, StepFrom t ~ s) => x) 57 | -> x 58 | leap u k = case mkStep u of 59 | Dict -> k 60 | 61 | type Kripke v t = forall u. LE t u => v u 62 | 63 | kripke :: Timed v => v s -> Kripke v s 64 | kripke v = v &> lesson 65 | 66 | class MoTime (m :: (Time -> *) -> (Time -> *)) where 67 | retNow :: Timed v => v s -> m v s 68 | (>>>=) :: (Timed f, Timed g) 69 | => m f s 70 | -> (forall t. (StepTo t, StepFrom t ~ s) => 71 | Kripke f t -> m g t) 72 | -> m g s 73 | 74 | data TiMo 75 | (c :: (Time -> *) -> Time -> *) 76 | (v :: Time -> *) 77 | (s :: Time) 78 | :: * where 79 | RetNow :: v s -> TiMo c v s 80 | Call :: forall c r v s 81 | . c r s 82 | -> (forall t. Le s t -> r t -> TiMo c v t) 83 | -> TiMo c v s 84 | 85 | instance (forall r. Timed (c r), Timed v) => Timed (TiMo c v) where 86 | RetNow v &> u = RetNow (v &> u) 87 | Call c k &> u = Call (c &> u) $ \ w -> k (u &> w) 88 | 89 | now :: v s -> Le s s 90 | now _ = Now 91 | 92 | instance MoTime (TiMo c) where 93 | retNow = RetNow 94 | (>>>=) :: forall c f g s. (Timed f, Timed g) 95 | => TiMo c f s 96 | -> (forall t. (StepTo t, StepFrom t ~ s) => 97 | Kripke f t -> TiMo c g t) 98 | -> TiMo c g s 99 | RetNow v >>>= k = leap (now v) (k (kripke v)) 100 | Call c j >>>= k = Call c $ \ u r -> 101 | j u r >>>= jump u step 102 | where 103 | jump :: forall t t'. Le s t -> Le t t' 104 | -> Kripke f t' -> TiMo c g t' 105 | jump u w f = leap (u &> w) (k f) 106 | 107 | op :: Timed r => c r s -> TiMo c r s 108 | op c = Call c $ \ u r -> RetNow r 109 | 110 | newtype Ticky (t :: Time) = Clock Int deriving Show 111 | 112 | instance Timed Ticky where 113 | x &> Now = x 114 | x &> Later u = case x &> u of 115 | Clock i -> Clock (i + 1) 116 | 117 | data Cmd (r :: Time -> *)(s :: Time) :: * where 118 | Grab :: Cmd Ticky s 119 | Emit :: Ticky s -> Cmd (K ()) s 120 | Wait :: Cmd (K ()) s 121 | 122 | instance Timed (Cmd b) where 123 | Grab &> u = Grab 124 | Emit x &> u = Emit (x &> u) 125 | Wait &> u = Wait 126 | 127 | data K (a :: *)(s :: Time) :: * where 128 | K :: a -> K a s 129 | instance Show a => Show (K a s) where show (K a) = show a 130 | instance Timed (K a) where 131 | K a &> _ = K a 132 | 133 | run :: forall s v. (forall i. Show (v i)) => Timey s -> TiMo Cmd v s -> IO () 134 | run _ (RetNow v) = print v 135 | run s (Call Wait k) = wait Now s where 136 | wait :: forall t. Le s t -> Timey t -> IO () 137 | wait u t = do 138 | putStrLn "waiting" 139 | getLine >>= \case 140 | "" -> wait (Later u) (Sy t) 141 | _ -> run t (k u (K ())) 142 | run s (Call Grab k) = run s (k Now (Clock 0)) 143 | run s (Call (Emit (Clock x)) k) = do 144 | print x 145 | run s (k Now (K ())) 146 | 147 | myProg :: TiMo Cmd (K ()) Z 148 | myProg = 149 | op Grab >>>= \ x -> 150 | op Wait >>>= \ _ -> 151 | op (Emit x) >>>= \ _ -> 152 | retNow (K ()) 153 | 154 | myProg' :: TiMo Cmd (K ()) Z 155 | myProg' = 156 | op Grab >>>= \ x -> 157 | op Wait >>>= \ _ -> 158 | op Grab >>>= \ y -> 159 | op (Emit x) >>>= \ _ -> 160 | -- retNow x >>>= \ x -> 161 | op (Emit y) >>>= \ _ -> 162 | op Wait >>>= \ _ -> 163 | op (Emit x) >>>= \ _ -> 164 | op (Emit y) >>>= \ _ -> 165 | retNow (K ()) 166 | 167 | main :: IO () 168 | main = run Zy myProg -------------------------------------------------------------------------------- /Tubes/Th.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, KindSignatures, RankNTypes, TypeOperators 2 | , TypeFamilies 3 | #-} 4 | 5 | module Th where 6 | import Data.Kind 7 | 8 | 9 | ------------------------------------------------------------------------------ 10 | -- Equality 11 | ------------------------------------------------------------------------------ 12 | 13 | data (==) :: a -> a -> Type where 14 | Ry :: x == x 15 | 16 | 17 | ------------------------------------------------------------------------------ 18 | -- Natural Numbers 19 | ------------------------------------------------------------------------------ 20 | 21 | data Nat = Z | S Nat deriving Show 22 | data Natty :: Nat -> Type where 23 | Zy :: Natty Z 24 | Sy :: Natty n -> Natty (S n) 25 | 26 | data Positive :: Nat -> Type where 27 | Positive :: Natty n -> Positive (S n) 28 | 29 | 30 | ------------------------------------------------------------------------------ 31 | -- Thinnings 32 | ------------------------------------------------------------------------------ 33 | 34 | data (<=) :: Nat -> Nat -> Type where 35 | NN :: n <= m -> n <= S m 36 | SS :: n <= m -> S n <= S m 37 | ZZ :: Z <= Z 38 | 39 | weeEnd :: n <= m -> Natty n 40 | weeEnd (NN th) = weeEnd th 41 | weeEnd (SS th) = Sy (weeEnd th) 42 | weeEnd ZZ = Zy 43 | 44 | bigEnd :: n <= m -> Natty m 45 | bigEnd (NN th) = Sy (bigEnd th) 46 | bigEnd (SS th) = Sy (bigEnd th) 47 | bigEnd ZZ = Zy 48 | 49 | 50 | -- full and empty 51 | 52 | io :: Natty n -> n <= n 53 | io Zy = ZZ 54 | io (Sy n) = SS (io n) 55 | 56 | no :: Natty n -> Z <= n 57 | no Zy = ZZ 58 | no (Sy n) = NN (no n) 59 | 60 | 61 | ------------------------------------------------------------------------------ 62 | -- Thinnable and Thinning Composition 63 | ------------------------------------------------------------------------------ 64 | 65 | class Thinnable (p :: Nat -> Type) where 66 | (-<) :: p n -> n <= m -> p m 67 | 68 | instance Thinnable ((<=) n) where 69 | th -< NN ph = NN (th -< ph) 70 | NN th -< SS ph = NN (th -< ph) 71 | SS th -< SS ph = SS (th -< ph) 72 | ZZ -< ZZ = ZZ 73 | 74 | -- free thinnability 75 | 76 | data (^) :: (Nat -> Type) -> Nat -> Type where 77 | (:^) :: p n -> n <= m -> p ^ m 78 | 79 | instance Thinnable ((^) p) where 80 | (p :^ th) -< ph = p :^ (th -< ph) 81 | 82 | 83 | ------------------------------------------------------------------------------ 84 | -- Antisymmetry 85 | ------------------------------------------------------------------------------ 86 | 87 | dropLast :: S n <= m -> n <= m 88 | dropLast (SS th) = NN th 89 | dropLast (NN th) = NN (dropLast th) 90 | 91 | noBig :: S n <= n -> x 92 | noBig (NN th) = noBig (dropLast th) 93 | noBig (SS th) = noBig th 94 | 95 | antisym :: n <= m -> m <= n -> n == m 96 | antisym (NN th) ph = noBig (ph -< th) 97 | antisym th (NN ph) = noBig (th -< ph) 98 | antisym (SS th) (SS ph) = case antisym th ph of Ry -> Ry 99 | antisym ZZ ZZ = Ry 100 | 101 | 102 | ------------------------------------------------------------------------------ 103 | -- Unions 104 | ------------------------------------------------------------------------------ 105 | 106 | data Union :: Nat -> Nat -> Nat -> Type where 107 | NSS :: Union l r n -> Union l (S r) (S n) 108 | SNS :: Union l r n -> Union (S l) r (S n) 109 | SSS :: Union l r n -> Union (S l) (S r) (S n) 110 | ZZZ :: Union Z Z Z 111 | 112 | luth :: Union l r n -> l <= n 113 | luth (NSS u) = NN (luth u) 114 | luth (SNS u) = SS (luth u) 115 | luth (SSS u) = SS (luth u) 116 | luth ZZZ = ZZ 117 | 118 | ruth :: Union l r n -> r <= n 119 | ruth (NSS u) = SS (ruth u) 120 | ruth (SNS u) = NN (ruth u) 121 | ruth (SSS u) = SS (ruth u) 122 | ruth ZZZ = ZZ 123 | 124 | cop :: l <= m -> r <= m -> Union l r ^ m 125 | cop (NN th) (NN ph) = case cop th ph of u :^ ps -> u :^ NN ps 126 | cop (NN th) (SS ph) = case cop th ph of u :^ ps -> NSS u :^ SS ps 127 | cop (SS th) (NN ph) = case cop th ph of u :^ ps -> SNS u :^ SS ps 128 | cop (SS th) (SS ph) = case cop th ph of u :^ ps -> SSS u :^ SS ps 129 | cop ZZ ZZ = ZZZ :^ ZZ 130 | 131 | allLeft :: Natty n -> Union n Z n 132 | allLeft Zy = ZZZ 133 | allLeft (Sy n) = SNS (allLeft n) 134 | 135 | noneRight :: Union l Z n -> l == n 136 | noneRight (SNS u) = case noneRight u of Ry -> Ry 137 | noneRight ZZZ = Ry 138 | 139 | flipU :: Union l r n -> Union r l n 140 | flipU (NSS u) = SNS (flipU u) 141 | flipU (SNS u) = NSS (flipU u) 142 | flipU (SSS u) = SSS (flipU u) 143 | flipU ZZZ = ZZZ 144 | 145 | allRight :: Natty n -> Union Z n n 146 | allRight = flipU . allLeft 147 | 148 | noneLeft :: Union Z r n -> r == n 149 | noneLeft = noneRight . flipU 150 | -------------------------------------------------------------------------------- /VecApart.agda: -------------------------------------------------------------------------------- 1 | {-# OPTIONS --prop #-} 2 | 3 | module VecApart where 4 | 5 | data Ff : Prop where 6 | record Zero : Set where 7 | constructor bad 8 | field 9 | dab : Ff 10 | record One : Set where constructor <> 11 | data Two : Set where ff tt : Two 12 | record _><_ (S : Set)(T : S -> Set) : Set where 13 | constructor _,_ 14 | field 15 | fst : S 16 | snd : T fst 17 | infixr 30 _,_ 18 | open _><_ public 19 | _*_ : Set -> Set -> Set 20 | S * T = S >< \ _ -> T 21 | _+_ : Set -> Set -> Set 22 | S + T = Two >< \ { ff -> S ; tt -> T } 23 | infixr 20 _><_ _*_ 24 | infixr 10 _+_ 25 | la_ : forall {l S T}{P : S >< T -> Set l} 26 | -> ((s : S) -> (t : T s) -> P (s , t)) 27 | -> (x : S >< T) -> P x 28 | la_ f (s , t) = f s t 29 | infixr 0 la_ 30 | 31 | __ : forall {l}{P : Two -> Set l} 32 | -> P ff -> P tt -> (b : Two) -> P b 33 | (pf pt) ff = pf 34 | (pf pt) tt = pt 35 | 36 | ko_ : forall {k l}{X : Set k}{Y : X -> Set l} -> (x : X)(y : Y x) -> X 37 | (ko x) y = x 38 | 39 | module _ {X : Set} where 40 | _*:_ _+:_ _-:>_ : (X -> Set) -> (X -> Set) -> (X -> Set) 41 | infixr 20 _*:_ 42 | (P *: Q) x = P x * Q x 43 | infixr 10 _+:_ 44 | (P +: Q) x = P x + Q x 45 | infixr 0 _-:>_ 46 | (P -:> Q) x = P x -> Q x 47 | 48 | <_> [_] : (X -> Set) -> Set 49 | < P > = X >< P 50 | [ P ] = forall {x} -> P x 51 | 52 | _$>_ : forall {i j k} 53 | {A : Set i}{B : A -> Set j}{C : (a : A) -> B a -> Set k} 54 | (f : (a : A) -> B a) 55 | (g : {a : A}(b : B a) -> C a b) 56 | (a : A) -> C a (f a) 57 | (f $> g) a = g (f a) 58 | 59 | data Nat : Set where 60 | ze : Nat 61 | su : Nat -> Nat 62 | {-# BUILTIN NATURAL Nat #-} 63 | 64 | data Vec {l}(X : Set l) : Nat -> Set l where 65 | [] : Vec X 0 66 | _,-_ : {n : Nat}(x : X)(xs : Vec X n) -> Vec X (su n) 67 | 68 | infixr 50 _,-_ 69 | 70 | pure : forall {l}{X : Set l}{n} -> X -> Vec X n 71 | pure {n = ze} x = [] 72 | pure {n = su n} x = x ,- pure x 73 | 74 | infixl 60 _<*>_ 75 | _<*>_ : forall {k l}{S : Set k}{T : Set l}{n} 76 | -> Vec (S -> T) n -> Vec S n -> Vec T n 77 | [] <*> [] = [] 78 | (f ,- fs) <*> (s ,- ss) = f s ,- fs <*> ss 79 | 80 | module _ {X : Set} where 81 | 82 | infix 40 _<=_ 83 | data _<=_ : {n m : Nat}(xs : Vec X n)(ys : Vec X m) -> Set where 84 | _^-_ : forall {n m : Nat}{xs : Vec X n} y {ys : Vec X m} 85 | -> xs <= ys 86 | -> xs <= y ,- ys 87 | _,-_ : forall {n m : Nat} x {xs : Vec X n}{ys : Vec X m} 88 | -> xs <= ys 89 | -> x ,- xs <= x ,- ys 90 | [] : [] <= [] 91 | infixr 50 _^-_ 92 | 93 | io : forall {n}{xs : Vec X n} -> xs <= xs 94 | io {xs = []} = [] 95 | io {xs = x ,- xs} = x ,- io 96 | 97 | infixr 50 _&-_ 98 | _&-_ : forall {n m l}{xs : Vec X n}{ys : Vec X m}{zs : Vec X l} 99 | -> xs <= ys -> ys <= zs -> xs <= zs 100 | th &- (y ^- ph) = y ^- th &- ph 101 | (.x ^- th) &- (x ,- ph) = x ^- th &- ph 102 | (.x ,- th) &- (x ,- ph) = x ,- th &- ph 103 | [] &- [] = [] 104 | 105 | no : forall {n}{xs : Vec X n} -> [] <= xs 106 | no {xs = []} = [] 107 | no {xs = x ,- xs} = x ^- no 108 | 109 | infix 30 _<-_ 110 | _<-_ : forall (x : X){n}(xs : Vec X n) -> Set 111 | x <- xs = x ,- [] <= xs 112 | 113 | infix 30 #_ 114 | #_ : {n : Nat}(xs : Vec X n) -> Set 115 | # xs = forall x -> x ,- x ,- [] <= xs -> Zero 116 | 117 | #0 : # [] 118 | #0 _ () 119 | 120 | #1 : {x : X} -> # x ,- [] 121 | #1 _ (y ^- ()) 122 | #1 _ (x ,- ()) 123 | 124 | infixr 30 _?#_ 125 | _?#_ : forall {n m}{xs : Vec X n}{ys : Vec X m} 126 | -> xs <= ys -> # ys -> # xs 127 | (th ?# d) x ph = d x (ph &- th) 128 | 129 | _-_ : (X : Set){n : Nat} -> Vec X n -> Set 130 | X - xs = X >< \ x -> # x ,- xs 131 | 132 | module _ {l}{X : Set l} where 133 | 134 | data _~_ (x : X) : X -> Set l where 135 | r~ : x ~ x 136 | 137 | subst : forall {k x y} -> x ~ y -> (P : X -> Set k) -> P x -> P y 138 | subst r~ P p = p 139 | 140 | _~[_>_ : forall x {y z} -> x ~ y -> y ~ z -> x ~ z 141 | x ~[ r~ > q = q 142 | _<_]~_ : forall x {y z} -> y ~ x -> y ~ z -> x ~ z 143 | x < r~ ]~ q = q 144 | infixr 3 _~[_>_ _<_]~_ 145 | _[QED] : forall x -> x ~ x 146 | x [QED] = r~ 147 | infix 4 _[QED] 148 | 149 | !~_ : forall x -> x ~ x 150 | !~ x = r~ 151 | infixl 6 !~_ 152 | 153 | _~/~_ : X -> X -> Set l 154 | x ~/~ y = x ~ y -> Zero 155 | 156 | {-# BUILTIN EQUALITY _~_ #-} 157 | 158 | _~$~_ : forall {k l}{S : Set k}{T : Set l}{f g : S -> T}{x y : S} 159 | -> f ~ g -> x ~ y -> f x ~ g y 160 | r~ ~$~ r~ = r~ 161 | infixl 5 _~$~_ 162 | 163 | infix 0 _<=>_ 164 | record _<=>_ (S T : Set) : Set where 165 | field 166 | l2r : S -> T 167 | r2l : T -> S 168 | l2r2l : (s : S) -> r2l (l2r s) ~ s 169 | r2l2r : (t : T) -> l2r (r2l t) ~ t 170 | open _<=>_ public 171 | 172 | module _ {X : Set} where 173 | 174 | diffDist : {x y : X} -> x ~/~ y -> # x ,- y ,- [] 175 | diffDist nq x (_ ^- _ ^- ()) 176 | diffDist nq x (_ ^- (.x ,- ())) 177 | diffDist nq x (.x ,- (.x ,- th)) = nq r~ 178 | 179 | distDiff : {x y : X} -> # x ,- y ,- [] -> x ~/~ y 180 | distDiff di r~ = di _ io 181 | 182 | no~ : forall {n}{xs : Vec X n}(th ph : [] <= xs) -> th ~ ph 183 | no~ (y ^- th) (.y ^- ph) = !~ y ^-_ ~$~ no~ th ph 184 | no~ [] [] = r~ 185 | 186 | atMost1 : forall {n}{xs : Vec X n}(p : # xs){x}(i j : x <- xs) -> i ~ j 187 | atMost1 p (y ^- i) (.y ^- j) = !~ y ^-_ ~$~ atMost1 (y ^- io ?# p) i j 188 | atMost1 p (y ^- i) (.y ,- j) with () <- p y (y ,- i) 189 | atMost1 p (x ,- i) (.x ^- j) with () <- p x (x ,- j) 190 | atMost1 p (x ,- i) (.x ,- j) = !~ x ,-_ ~$~ no~ i j 191 | 192 | twoDiff : forall {n}{xs : Vec X n}{y z : X} 193 | -> # y ,- xs -> # z ,- xs -> y ~/~ z -> # y ,- z ,- xs 194 | twoDiff yd zd ynz x (y ^- z ^- th) = yd x (y ^- th) 195 | twoDiff yd zd ynz x (y ^- (.x ,- th)) = zd x (x ,- th) 196 | twoDiff yd zd ynz x (.x ,- (y ^- th)) = yd x (x ,- th) 197 | twoDiff yd zd ynz x (.x ,- (.x ,- th)) = ynz r~ 198 | 199 | Dec : Set -> Set 200 | Dec X = (X -> Zero) + X 201 | 202 | DecEq : Set -> Set 203 | DecEq X = (x y : X) -> Dec (x ~ y) 204 | 205 | record Datoid : Set1 where 206 | constructor _/~?_ 207 | field 208 | Data : Set 209 | _~?_ : (x y : Data) -> Dec (x ~ y) 210 | 211 | module _ (D : Datoid) where 212 | module Private where 213 | X = Datoid.Data D 214 | _~?_ = Datoid._~?_ D 215 | open Private 216 | 217 | dec- : forall {n}{xs : Vec X n} -> DecEq (X - xs) 218 | dec- (x , p) (y , q) with x ~? y 219 | dec- (x , p) (y , q) | ff , nq = ff , \ { r~ -> nq r~ } 220 | dec- (x , p) (.x , q) | tt , r~ = tt , r~ 221 | 222 | seek : forall {n}(xs : Vec X n) -> # xs -> 223 | (x : X) -> # x ,- xs + x <- xs 224 | seek [] xd x = ff , #1 225 | seek (y ,- xs) xd x with x ~? y 226 | seek (y ,- xs) xd x | ff , p with seek xs (y ^- io ?# xd) x 227 | seek (y ,- xs) yd x | ff , p | ff , xd = ff , twoDiff xd yd p 228 | seek (y ,- xs) xd x | ff , p | tt , i = tt , y ^- i 229 | seek (y ,- xs) xd .y | tt , r~ = tt , y ,- no 230 | 231 | module _ {n : Nat}(xs : Vec X n)(xd : # xs) where 232 | 233 | dIso : X <=> (X - xs) + < _<- xs > 234 | l2r dIso x with seek xs xd x 235 | l2r dIso x | ff , w = ff , x , w 236 | l2r dIso x | tt , w = tt , x , w 237 | r2l dIso (ff , x , w) = x 238 | r2l dIso (tt , x , w) = x 239 | l2r2l dIso x with seek xs xd x 240 | l2r2l dIso x | ff , w = r~ 241 | l2r2l dIso x | tt , w = r~ 242 | r2l2r dIso (ff , x , w) with seek xs xd x 243 | r2l2r dIso (ff , x , w) | ff , v = r~ 244 | r2l2r dIso (ff , x , w) | tt , v with () <- w x (x ,- v) 245 | r2l2r dIso (tt , x , w) with seek xs xd x 246 | r2l2r dIso (tt , x , w) | ff , v with () <- v x (x ,- w) 247 | r2l2r dIso (tt , x , w) | tt , v = !~ tt ,_ ~$~ (!~ x ,_ ~$~ atMost1 xd v w) 248 | 249 | module _ {n : Nat}(x : X)(xs : Vec X n)(xxd : # x ,- xs) where 250 | 251 | hIso : X - xs <=> X - x ,- xs + One 252 | l2r hIso (y , p) with y ~? x 253 | l2r hIso (y , p) | ff , n = ff , y , twoDiff p xxd n 254 | l2r hIso (y , p) | tt , q = tt , <> 255 | r2l hIso (ff , y , p) = y , y ,- x ^- io ?# p 256 | r2l hIso (tt , <>) = x , xxd 257 | l2r2l hIso (y , p) with y ~? x 258 | l2r2l hIso (y , p) | ff , q = r~ 259 | l2r2l hIso (y , p) | tt , r~ = r~ 260 | r2l2r hIso (ff , y , p) with y ~? x 261 | r2l2r hIso (ff , y , p) | ff , q = r~ 262 | r2l2r hIso (ff , y , p) | tt , r~ with () <- p x (x ,- x ,- no) 263 | r2l2r hIso (tt , <>) with x ~? x 264 | r2l2r hIso (tt , <>) | ff , q with () <- q r~ 265 | r2l2r hIso (tt , <>) | tt , r~ = r~ 266 | 267 | open Datoid 268 | 269 | record Con : Set1 where 270 | constructor _<|_ 271 | field 272 | Sh : Set 273 | Po : Sh -> Datoid 274 | open Con public 275 | 276 | record Der (n : Nat)(C : Con)(X : Set) : Set where 277 | constructor _<_^_!_ 278 | field 279 | shape : Sh C 280 | holes : Vec (Data (Po C shape)) n 281 | apart : # holes 282 | stuff : Data (Po C shape) - holes -> X 283 | 284 | plug : forall {n C X} -> Der (su n) C X -> X -> Der n C X 285 | plug {C = S <| P} (s < h ,- hs ^ hd ! f) x = 286 | let Ps /~? eq? = P s in 287 | s < hs ^ h ^- io ?# hd ! (l2r (hIso (P s) h hs hd) $> (la f (ko x))) 288 | -------------------------------------------------------------------------------- /VecReflect.agda: -------------------------------------------------------------------------------- 1 | module VecReflect where 2 | 3 | data Nat : Set where 4 | ze : Nat 5 | su : Nat -> Nat 6 | 7 | data Vec (X : Set) : Nat -> Set where 8 | [] : Vec X ze 9 | _,_ : {n : Nat} -> X -> Vec X n -> Vec X (su n) 10 | 11 | -- we have some operations that we like... 12 | -- ...and which obey some laws 13 | 14 | -- green pure 15 | pure : forall {n}{X} -> X -> Vec X n 16 | pure {ze} x = [] 17 | pure {su n} x = x , pure x 18 | 19 | -- green <*> 20 | _<*>_ : forall {n S T} -> Vec (S -> T) n -> Vec S n -> Vec T n 21 | [] <*> [] = [] 22 | (g , gs) <*> (s , ss) = g s , (gs <*> ss) 23 | 24 | -- we write down a syntax of formulae built from those expressions 25 | -- and embedded values (effectively, a type of quotations) 26 | 27 | data VecFmla (X : Set)(n : Nat) : Set1 where 28 | 29 | -- embed values 30 | [_] : Vec X n -> VecFmla X n 31 | 32 | -- quote green pure as red pure' 33 | pure' : X -> VecFmla X n 34 | 35 | -- quote green <*> as red <*>' 36 | _<*>'_ : forall {S} -> VecFmla (S -> X) n -> VecFmla S n -> 37 | VecFmla X n 38 | 39 | -- we can easily evaluate quoted things (because we made them 40 | -- so; unembed values; replace red by green 41 | 42 | eval : forall {X n} -> VecFmla X n -> Vec X n 43 | eval [ xs ] = xs 44 | eval (pure' x) = pure x 45 | eval (g <*>' s) = eval g <*> eval s 46 | 47 | -- now, here's projection, about which we shall prove a fact 48 | 49 | data Fin : Nat -> Set where 50 | fz : {n : Nat} -> Fin (su n) 51 | fs : {n : Nat} -> Fin n -> Fin (su n) 52 | 53 | _!!_ : forall {X n} -> Vec X n -> Fin n -> X 54 | (x , xs) !! fz = x 55 | (x , xs) !! fs i = xs !! i 56 | 57 | -- define *symbolic* projection 58 | 59 | _!!'_ : forall {X n} -> VecFmla X n -> Fin n -> X 60 | [ xs ] !!' i = xs !! i 61 | pure' x !!' _ = x 62 | (g <*>' s) !!' i = (g !!' i) (s !!' i) 63 | 64 | -- here's equality 65 | 66 | data _==_ {X : Set}(x : X) : X -> Set where 67 | refl : x == x 68 | 69 | -- one lemma for each operation 70 | 71 | pureLem : forall {X n}(x : X)(i : Fin n) -> (pure x !! i) == x 72 | pureLem x fz = refl 73 | pureLem x (fs i) = pureLem x i 74 | 75 | appLem : forall {S T n}(gs : Vec (S -> T) n)(ss : Vec S n)(i : Fin n) -> 76 | ((gs <*> ss) !! i) == (gs !! i) (ss !! i) 77 | appLem (g , gs) (s , ss) fz = refl 78 | appLem (g , gs) (s , ss) (fs i) = appLem gs ss i 79 | 80 | -- and now a "big stick" lemma, proven by induction over 81 | -- formulae, deploying the lemmas for each quoted operation 82 | 83 | evalLem : forall {X n}(f : VecFmla X n)(i : Fin n) -> 84 | (eval f !! i) == (f !!' i) 85 | evalLem [ xs ] i = refl 86 | evalLem (pure' x) i = pureLem x i 87 | -- manually desugaring "rewrite", because rewrite needs a 88 | -- universe-polymorphic equality and I can't be arsed 89 | evalLem (g <*>' s) i with (eval g <*> eval s) !! i | appLem (eval g) (eval s) i 90 | evalLem (g <*>' s) i | .((eval g !! i) (eval s !! i)) | refl 91 | with (eval g !! i) | (eval s !! i) | evalLem g i | evalLem s i 92 | evalLem (g <*>' s) i 93 | | .((eval g !! i) (eval s !! i)) | refl | .(g !!' i) | .(s !!' i) | refl | refl 94 | = refl 95 | 96 | -- So, if some random wee goal about projection from pure-<*> 97 | -- combination shows up... 98 | 99 | zipFact : forall {X Y Z n}(f : X -> Y -> Z) 100 | (xs : Vec X n)(ys : Vec Y n)(i : Fin n) -> 101 | (((pure f <*> xs) <*> ys) !! i) == f (xs !! i) (ys !! i) 102 | 103 | ...just hit it with a big stick! 104 | 105 | zipFact f xs ys i = evalLem ((pure' f <*>' [ xs ]) <*>' [ ys ]) i 106 | -------------------------------------------------------------------------------- /WTS2.agda: -------------------------------------------------------------------------------- 1 | module WTS2 where 2 | 3 | open import LibAgda.Zero 4 | open import LibAgda.One 5 | open import LibAgda.Two 6 | open import LibAgda.Nat 7 | open import LibAgda.Fin 8 | open import LibAgda.Comb 9 | open import LibAgda.Ix 10 | open import LibAgda.Sg 11 | open import LibAgda.Cat 12 | open import LibAgda.Eq 13 | open import LibAgda.Bwd 14 | 15 | data _+top (X : Set) : Set where 16 | # : X -> X +top 17 | top : X +top 18 | 19 | _ Nat +top -> Set 20 | top Nat +top -> Set 25 | _ Act 35 | dom : Q -> Act 36 | 37 | 38 | Az : Set 39 | Az = Bwd Act 40 | 41 | postulate 42 | W : Set 43 | _-W>_ : W -> W -> Set 44 | _/_ : W -> Act -> W 45 | wrefl : forall {w} -> w -W> w 46 | wtrans : forall {u v w} -> u -W> v -> v -W> w -> u -W> w 47 | mono : forall u w a -> u -W> w -> (u / a) -W> (w / a) 48 | argDom1 : forall w q -> (w / arg q) -W> (w / type / dom q) 49 | argDom2 : forall w q -> (w / type / dom q / type) -W> (w / arg q / type) 50 | 51 | infixl 8 _/_ _//_ 52 | 53 | _//_ : W -> Az -> W 54 | w // [] = w 55 | w // (az -, q) = w // az / q 56 | 57 | monoz : forall u w az -> u -W> w -> (u // az) -W> (w // az) 58 | monoz u w [] uw = uw 59 | monoz u w (az -, a) uw = mono (u // az) (w // az) a (monoz u w az uw) 60 | 61 | postulate 62 | func : forall v w bz az -> v -W> w -> 63 | (v // bz) -W> (v // az) -> (w // bz) -W> (w // az) 64 | 65 | 66 | record Up-Set : Set1 where 67 | field 68 | UpPred : W -> Set 69 | UpClose : (u w : W) -> u -W> w -> UpPred u -> UpPred w 70 | ! : Set 71 | ! = Sg W UpPred 72 | open Up-Set 73 | 74 | data Dir : Set where chk syn : Dir 75 | 76 | data Tm (n : Nat) : Dir -> Set where 77 | [_] : Tm n syn -> Tm n chk 78 | U : Nat +top -> Tm n chk 79 | Pi : Q -> Tm n chk -> Tm (su n) chk -> Tm n chk 80 | la : Tm (su n) chk -> Tm n chk 81 | _::_ : Tm n chk -> Tm n chk -> Tm n syn 82 | # : Fin n -> Tm n syn 83 | _$_ : Tm n syn -> Tm n chk -> Tm n syn 84 | 85 | Chk : Nat -> Set 86 | Chk n = Tm n chk 87 | Syn : Nat -> Set 88 | Syn n = Tm n syn 89 | 90 | module ACT 91 | (I : Nat -> Set) 92 | (vi : ^ Fin -:> I) 93 | (is : ^ I -:> Syn) 94 | (wk : ^ I -:> (I o su)) 95 | where 96 | shf : forall {m n} -> (Env m (I n)) -> Env m (I (su n)) 97 | shf = env wk 98 | wkn : forall {m n} -> (Env m (I n)) -> Env (su m) (I (su n)) 99 | wkn g = shf g , vi ze 100 | ida : forall {n} -> Env n (I n) 101 | ida {ze} = <> 102 | ida {su n} = wkn ida 103 | act : forall {m n d} -> (Env m (I n)) -> Tm m d -> Tm n d 104 | act g [ t ] = [ act g t ] 105 | act g (U h) = U h 106 | act g (Pi q S T) = Pi q (act g S) (act (wkn g) T) 107 | act g (la t) = la (act (wkn g) t) 108 | act g (t :: T) = act g t :: act g T 109 | act g (# i) = is (proj i g) 110 | act g (f $ s) = act g f $ act g s 111 | 112 | module REN = ACT Fin id # su 113 | ren : forall {m n d} -> (Env m (Fin n)) -> Tm m d -> Tm n d 114 | ren = REN.act 115 | 116 | wkr : forall {m n} -> m <= n -> Env m (Fin n) 117 | wkr {ze} mn = <> 118 | wkr {su m} {ze} () 119 | wkr {su m} {su n} mn = REN.shf (wkr mn) , fin m mn 120 | 121 | open MODAL Nat<= 122 | open Cat _ Nat<= 123 | 124 | sucr : forall {n} -> Env n (Fin (su n)) 125 | sucr = let open REN in shf ida 126 | 127 | module SUB = ACT Syn # id (ren sucr) 128 | sub : forall {m n d} -> (Env m (Syn n)) -> Tm m d -> Tm n d 129 | sub = SUB.act 130 | 131 | Cx : Nat -> Set 132 | Cx ze = One 133 | Cx (su n) = Cx n * W * Chk n 134 | 135 | projW : forall {n} -> Cx n -> Fin n -> W 136 | projW (_ , (u , _)) ze = u 137 | projW (G , _) (su i) = projW G i 138 | 139 | projT : forall {n} -> Cx n -> Fin n -> Chk n 140 | projT (_ , (_ , S)) ze = ren sucr S 141 | projT (G , _) (su i) = ren sucr (projT G i) 142 | 143 | _%_ : forall {n d} -> Tm (su n) d -> Tm n syn -> Tm n d 144 | t % e = sub (SUB.ida , e) t 145 | 146 | data Reds {n} : forall {d} -> Tm n d -> Tm n d -> Set where 147 | 148 | beta : forall {q t t' S S' T T' s s'} -> 149 | Reds t t' -> Reds S S' -> Reds T T' -> Reds s s' -> 150 | Reds ((la t :: Pi q S T) $ s) ((t' :: T') % (s' :: S')) 151 | 152 | upsi : forall {t t' T} -> 153 | Reds t t' -> 154 | Reds [ t :: T ] t' 155 | 156 | [_] : forall {e e'} -> 157 | Reds e e' -> 158 | Reds [ e ] [ e' ] 159 | 160 | U : forall i -> Reds (U i) (U i) 161 | 162 | Pi : forall {q S S' T T'} -> 163 | Reds S S' -> Reds T T' -> 164 | Reds (Pi q S T) (Pi q S' T') 165 | 166 | _::_ : forall {t t' T T'} -> 167 | Reds t t' -> Reds T T' -> 168 | Reds (t :: T) (t' :: T') 169 | 170 | # : forall i -> Reds (# i) (# i) 171 | 172 | _$_ : forall {f f' s s'} -> 173 | Reds f f' -> Reds s s' -> 174 | Reds (f $ s) (f' $ s') 175 | 176 | 177 | 178 | data SUBTY {n}(G : Cx n)(w : W) : Chk n -> Chk n -> Set where 179 | -- comparing two types which should both be valid in w [type] 180 | 181 | uniCum : forall {i j} -> i SUBTY G w (U i) (U j) 182 | 183 | piSub : forall {q S S' T T'} -> 184 | SUBTY G (w / dom q / type) S' S -> 185 | SUBTY (G , (w / dom q , S')) w T T' -> 186 | ------------------------------------------ 187 | SUBTY G w (Pi q S T) (Pi q S' T') 188 | 189 | neRefl : forall {E} -> SUBTY G w [ E ] [ E ] 190 | 191 | data CHK {n}(G : Cx n)(w : W) : Chk n -> Chk n -> Set 192 | data SYN {n}(G : Cx n)(w : W) : Syn n -> Chk n -> Set 193 | 194 | data CHK {n} G w where 195 | 196 | 197 | pre : forall {T T' t} -> 198 | 199 | Reds T T' -> CHK G w T' t -> 200 | -------------------------------- 201 | CHK G w T t 202 | 203 | 204 | subty : forall {e S T} -> 205 | 206 | SYN G w e S -> SUBTY G (w / type) S T -> 207 | -------------------------------------------- 208 | CHK G w T [ e ] 209 | 210 | 211 | U : forall {i j} -> 212 | 213 | i 214 | ----------------------- 215 | CHK G w (U j) (U i) 216 | 217 | 218 | Pi : forall {i} q {S T} -> 219 | 220 | CHK G (w / dom q / type) (U i) S -> 221 | CHK (G , (w / dom q , S)) w (U i) T -> 222 | ------------------------------------------ 223 | CHK G w (U i) (Pi q S T) 224 | 225 | 226 | la : forall {q S T t} -> 227 | 228 | CHK (G , (w / arg q , S)) w T t -> 229 | -------------------------------------- 230 | CHK G w (Pi q S T) (la t) 231 | 232 | 233 | data SYN {n} G w where 234 | 235 | 236 | post : forall {e S S'} -> 237 | 238 | SYN G w e S -> Reds S S' -> 239 | ------------------------------- 240 | SYN G w e S' 241 | 242 | 243 | annot : forall {t T} -> 244 | 245 | CHK G (w / type) (U top) T -> CHK G w T t -> 246 | ------------------------------------------------ 247 | SYN G w (t :: T) T 248 | 249 | 250 | var : forall i -> 251 | 252 | projW G i -W> w -> 253 | ----------------------------- 254 | SYN G w (# i) (projT G i) 255 | 256 | 257 | _$_ : forall {q S T f s} -> 258 | 259 | SYN G w f (Pi q S T) -> CHK G (w / arg q) S s -> 260 | ---------------------------------------------------- 261 | SYN G w (f $ s) (T % (s :: S)) 262 | 263 | CxAz : Nat -> Set 264 | CxAz ze = One 265 | CxAz (su n) = CxAz n * ((W + Az) * Chk n) 266 | 267 | cxAz : forall n -> W -> CxAz n -> Cx n 268 | cxAz ze w <> = <> 269 | cxAz (su n) w (GAz , x , S) = cxAz n w GAz , (hit x , S) where 270 | hit : W + Az -> W 271 | hit (tt , u) = u 272 | hit (ff , az) = w // az 273 | 274 | wSUBTY : forall {n} (G : CxAz n) {v S T w} az -> v -W> w -> 275 | SUBTY (cxAz n v G) (v // az) S T -> SUBTY (cxAz n w G) (w // az) S T 276 | wSUBTY G az vw (uniCum ij) = uniCum ij 277 | wSUBTY G az vw (piSub S'S TT') = 278 | piSub (wSUBTY G ((az -, dom _) -, type) vw S'S) 279 | (wSUBTY (G , ((ff , (az -, dom _)) , _)) az vw TT') 280 | wSUBTY G az vw neRefl = neRefl 281 | 282 | wCHK : forall {n} (G : CxAz n) {v T t w} az -> v -W> w -> 283 | CHK (cxAz n v G) (v // az) T t -> CHK (cxAz n w G) (w // az) T t 284 | wSYN : forall {n} (G : CxAz n) {v e S w} az -> v -W> w -> 285 | SYN (cxAz n v G) (v // az) e S -> SYN (cxAz n w G) (w // az) e S 286 | 287 | wCHK G az vw (pre TT' T't) = pre TT' (wCHK G az vw T't) 288 | wCHK G az vw (subty eS ST) = 289 | subty (wSYN G az vw eS) (wSUBTY G (az -, type) vw ST) 290 | wCHK G az vw (U x) = U x 291 | wCHK G az vw (Pi q US UT) = 292 | Pi q (wCHK G ((az -, dom q) -, type) vw US) 293 | (wCHK (G , (ff , (az -, dom q)) , _) az vw UT) 294 | wCHK G az vw (la Tt) = 295 | la (wCHK (G , (ff , (az -, arg _)) , _) az vw Tt) 296 | 297 | wVAR : forall {n} (G : CxAz n) {v w} i az -> v -W> w -> 298 | projW (cxAz n v G) i -W> (v // az) -> 299 | projW (cxAz n w G) i -W> (w // az) * 300 | projT (cxAz n w G) i == projT (cxAz n v G) i 301 | wVAR (G , (tt , u) , S) ze az vw u-vaz = wtrans u-vaz (monoz _ _ az vw) , refl 302 | wVAR (G , (ff , bz) , S) ze az vw u-vaz = func _ _ bz az vw u-vaz , refl 303 | wVAR (G , _ ) (su i) az vw u-vaz with wVAR G i az vw u-vaz 304 | wVAR (G , (_ , _) , _) (su i) az vw u-vaz | u-waz , pq 305 | rewrite pq = u-waz , refl 306 | 307 | wSYN G az vw (post eS SS') = post (wSYN G az vw eS) SS' 308 | wSYN G az vw (annot US Ss) = 309 | annot (wCHK G (az -, type) vw US) (wCHK G az vw Ss) 310 | wSYN {n} G {v}{_}{.(projT (cxAz n v G) i)}{w} az vw (var i u-vaz) 311 | with wVAR G i az vw u-vaz 312 | ... | u-waz , pq = subst pq (SYN _ _ _) (var i u-waz) 313 | wSYN G az vw (eST $ Ss) = wSYN G az vw eST $ wCHK G (az -, arg _) vw Ss 314 | -------------------------------------------------------------------------------- /Wang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, LambdaCase #-} 2 | module Wang where 3 | 4 | import Data.Monoid 5 | import Control.Newtype 6 | import Data.List 7 | 8 | humpty :: (Newtype n o, Monoid o) => n 9 | humpty = pack mempty 10 | 11 | (<^^>) :: (Newtype n o, Monoid o) => n -> n -> n 12 | x <^^> y = pack (unpack x <> unpack y) 13 | 14 | data Fmla 15 | = V Int 16 | | F 17 | | Fmla :\/: Fmla 18 | | T 19 | | Fmla :/\: Fmla 20 | | N Fmla 21 | deriving Show 22 | 23 | data Anxiety 24 | = Chill -- there is no need to worry in this subcase 25 | | Yikes -- we're indiscriminately stuffed in this subcase 26 | | Split Anxiety Int Anxiety -- this case matters 27 | -- left go the countermodels in which the var is a hypo 28 | -- right go the countermodels in which the var is a goal 29 | -- all splits, left and right, are on strictly higher vars 30 | 31 | instance Show Anxiety where 32 | show Chill = "Always" 33 | show Yikes = "Never" 34 | show a = "Except for " ++ intercalate ", or " (map mo (go a)) where 35 | go Chill = [] 36 | go Yikes = [([], [])] 37 | go (Split h i g) = 38 | [(i : hs, gs) | (hs, gs) <- go h] ++ 39 | [(hs, i : gs) | (hs, gs) <- go g] 40 | mo (hs, []) = "all of " ++ show hs 41 | mo ([], gs) = "none of " ++ show gs 42 | mo (hs, gs) = show hs ++ " but not " ++ show gs 43 | 44 | instance Eq Anxiety where 45 | Chill == Chill = True 46 | Yikes == Yikes = True 47 | Split hi i gi == Split hj j gj -- test the vars first! 48 | = i == j && hi == hj && gi == gj 49 | _ == _ = False 50 | 51 | split :: Anxiety -> Int -> Anxiety -> Anxiety 52 | split h i g 53 | | obvEq h g = h -- if the countermodels match, no need to split 54 | | otherwise = Split h i g 55 | where 56 | obvEq Chill Chill = True 57 | obvEq Yikes Yikes = True 58 | {- 59 | -- is it worth it? 60 | obvEq (Split hi i gi) (Split hj j gj) = 61 | i == j && obvEq hi hj && obvEq gi gj 62 | -} 63 | obvEq _ _ = False 64 | 65 | instance Semigroup Anxiety where (<>) = mappend 66 | instance Monoid Anxiety where 67 | -- we're collating countermodels 68 | mempty = Chill 69 | -- Chill is absorbed 70 | mappend Chill b = b 71 | mappend a Chill = a 72 | -- Yikes dominates 73 | mappend Yikes b = Yikes 74 | mappend a Yikes = Yikes 75 | -- otherwise, do the merge-like thing 76 | mappend a@(Split hi i gi) b@(Split hj j gj) = case compare i j of 77 | LT -> split (hi <> b) i (gi <> b) 78 | EQ -> split (hi <> hj) i (gi <> gj) 79 | GT -> split (a <> hj) j (a <> gj) 80 | 81 | hypo :: Int -> Anxiety -> Anxiety 82 | hypo i Chill = Chill 83 | hypo i Yikes = Split Yikes i Chill 84 | hypo i a@(Split h j g) = case compare i j of 85 | LT -> split a i Chill 86 | EQ -> split h i Chill 87 | GT -> split (hypo i h) j (hypo i g) 88 | 89 | goal :: Int -> Anxiety -> Anxiety 90 | goal i Chill = Chill 91 | goal i Yikes = Split Chill i Yikes 92 | goal i a@(Split h j g) = case compare i j of 93 | LT -> split Chill i a 94 | EQ -> split Chill i g 95 | GT -> split (goal i h) j (goal i g) 96 | 97 | chillOut :: Endo Anxiety -> Endo Anxiety 98 | chillOut (Endo f) = Endo $ \case 99 | Chill -> Chill 100 | a -> f a 101 | 102 | wang, wang', gnaw, gnaw' :: Fmla -> Endo Anxiety 103 | wang = chillOut . wang' 104 | wang' (V x) = Endo (goal x) 105 | wang' F = mempty 106 | wang' (p :\/: q) = wang p <> wang q 107 | wang' T = humpty 108 | wang' (p :/\: q) = wang p <^^> wang q 109 | wang' (N p) = gnaw p 110 | gnaw = chillOut . gnaw' 111 | gnaw' (V x) = Endo (hypo x) 112 | gnaw' F = humpty 113 | gnaw' (p :\/: q) = gnaw p <^^> gnaw q 114 | gnaw' T = mempty 115 | gnaw' (p :/\: q) = gnaw p <> gnaw q 116 | gnaw' (N p) = wang p 117 | 118 | (==>) :: Fmla -> Fmla -> Anxiety 119 | h ==> g = appEndo (wang g <> gnaw h) Yikes 120 | 121 | 122 | --------------------------- 123 | 124 | allOf :: [Fmla] -> Fmla 125 | allOf [] = T 126 | allOf [x] = x 127 | allOf (x : xs) = x :/\: allOf xs 128 | 129 | someOf :: [Fmla] -> Fmla 130 | someOf [] = F 131 | someOf [x] = x 132 | someOf (x : xs) = x :\/: someOf xs 133 | 134 | oneOf :: [Fmla] -> Fmla 135 | oneOf [] = F 136 | oneOf [x] = x 137 | oneOf (x : xs) = 138 | (x :/\: allOf [N y | y <- xs]) :\/: (N x :/\: oneOf xs) 139 | 140 | ham :: [(Int, Int)] -- edges 141 | -> Fmla 142 | ham es = 143 | -- every node is in exactly one position 144 | allOf [oneOf [nodePos i p | p <- [1 .. l]] | i <- ns] 145 | :/\: 146 | -- every position has exactly one node 147 | allOf [oneOf [nodePos i p | i <- ns] | p <- [1 .. l]] 148 | :/\: 149 | -- every edge present is somewhere in the path 150 | allOf [N (edgeIn x) :\/: 151 | someOf [(nodePos i p :/\: nodePos j (p + 1)) :\/: 152 | (nodePos j p :/\: nodePos i (p + 1)) 153 | | p <- [1 .. l-1]] 154 | | (x, (i, j)) <- xes] 155 | :/\: 156 | -- every step in the path is an edge 157 | allOf [ someOf [ edgeIn x :/\: 158 | ((nodePos i p :/\: nodePos j (p + 1)) :\/: 159 | (nodePos j p :/\: nodePos i (p + 1))) 160 | | (x, (i, j)) <- xes] 161 | | p <- [1 .. l-1]] 162 | where 163 | xes = zip [0..] es 164 | e = length es 165 | ns = nub (es >>= ((pure . fst) <> (pure . snd))) 166 | n = 10 * (1 + maximum ns) 167 | l = length ns 168 | nodePos i p = V (p * n + i) 169 | edgeIn x = V (n * n + x) 170 | 171 | eul :: [(Int, Int)] -- edges 172 | -> Fmla 173 | eul es = 174 | -- every edge occurs exactly once 175 | allOf [oneOf [edgePos e p | p <- [1..l]] 176 | | (e, (i, j)) <- xes] 177 | :/\: 178 | -- every position has exactly one edge 179 | allOf [oneOf [edgePos e p | (e, _) <- xes] 180 | | p <- [1..l]] 181 | :/\: 182 | allOf [ N (edgePos e 1) :\/: path i 2 :\/: path j 2 183 | | (e, (i, j)) <- xes] 184 | where 185 | xes = zip [0..] es 186 | l = length xes 187 | edgePos e p = V (l * p + e) 188 | path _ p | p >= l = T 189 | path i p = someOf 190 | ( 191 | [edgePos e p :/\: path j (p+1) | (e, (q, j)) <- xes, i == q] ++ 192 | [edgePos e p :/\: path j (p+1) | (e, (j, q)) <- xes, i == q] 193 | ) 194 | 195 | dual :: [(Int,Int)] -> [(Int,Int)] 196 | dual es = go xes where 197 | go [] = [] 198 | go ((x, (i, j)) : xes) = 199 | [(x, y) | (y, (k, l)) <- xes, any (`elem` [k, l]) [i, j]] 200 | ++ go xes 201 | xes = zip [0..] es 202 | 203 | koenigsberg :: [(Int, Int)] 204 | koenigsberg = [(0,1),(0,1),(0,2),(0,2),(0,3),(1,3),(2,3)] 205 | 206 | clique :: Int -> [(Int, Int)] 207 | clique n = go 0 where 208 | go i | i >= n = [] 209 | go i = [(i, j) | j <- [i+1 .. n-1]] ++ go (i+1) 210 | 211 | main :: IO () 212 | main = print $ eul koenigsberg ==> F 213 | --------------------------------------------------------------------------------