├── .gitignore ├── CatCat.lidr ├── Category.lidr ├── DecProp.lidr ├── DependentCurrying.lidr ├── EqCat.lidr ├── FinSCat.lidr ├── FreeCatOnGraph.lidr ├── FunExtAxiom.lidr ├── FuncCat.lidr ├── Graph.lidr ├── NSig.lidr ├── Preorder.lidr ├── Prop.lidr ├── README.md ├── Signatures.lidr └── TypeCat.lidr /.gitignore: -------------------------------------------------------------------------------- 1 | *.ibc 2 | *.o 3 | -------------------------------------------------------------------------------- /CatCat.lidr: -------------------------------------------------------------------------------- 1 | > module CatCat 2 | > import Category 3 | > import Prop 4 | > import FunExtAxiom 5 | > import Syntax.PreorderReasoning 6 | 7 | 8 | > %default total 9 | > %auto_implicits off 10 | > %access public export 11 | 12 | Category of (small) categories and functors as morphisms 13 | -------------------------------------------------------- 14 | 15 | All our categories are small in the sense that they have 16 | types as objects and as homs. 17 | 18 | 1) Functor composition yields a functor 19 | 20 | it preserves identities: 21 | 22 | > fid : {cc, dd, ee : Cat} -> 23 | > (ff : Func dd ee) -> (gg : Func cc dd) -> 24 | > (c : Obj cc) -> 25 | > ((FH {a = (FO gg c)} {b = (FO gg c)} ff) . (FH gg)) (Id c) = 26 | > Id (((FO ff).(FO gg)) c) 27 | > 28 | > fid {cc} {dd} {ee} ff gg c = 29 | > (((FH {a = (FO gg c)} {b = (FO gg c)} ff) . (FH gg)) (Id c)) 30 | > ={ cong {f = \m => (FH {a = (FO gg c)} {b = (FO gg c)} ff) m} 31 | > (FId gg c) }= 32 | > ((FH {a = (FO gg c)} {b = (FO gg c)} ff) (Id (FO gg c))) 33 | > ={ FId {cc = dd} ff (FO gg c) }= 34 | > (Id (((FO ff) . (FO gg)) c)) 35 | > QED 36 | 37 | and composition: 38 | 39 | > comp : {cc, dd, ee : Cat} -> (ff : Func dd ee) -> (gg : Func cc dd) -> 40 | > {a, b, c: Obj cc} -> (f : Hom cc b c) -> (g : Hom cc a b) -> 41 | > (FH ff (FH gg (Comp f g))) 42 | > = Comp (FH ff (FH gg f)) (FH ff (FH gg g)) 43 | > comp ff gg {a} {b} {c} f g = 44 | > (FH ff (FH gg (Comp f g))) 45 | > ={ cong {f = \x => FH ff x} (FC {a} {b} {c} gg f g) }= 46 | > (FH ff (Comp (FH gg f) (FH gg g))) 47 | > ={ FC {a = FO gg a} {b = FO gg b} {c = FO gg c} 48 | > ff (FH gg f) (FH gg g) }= 49 | > (Comp (FH ff (FH gg f)) (FH ff (FH gg g))) 50 | > QED 51 | 52 | so we can define 53 | 54 | > funComp : {cc, dd, ee : Cat} -> 55 | > (ff : Func dd ee) -> (gg : Func cc dd) -> Func cc ee 56 | > funComp ff gg = MkFunc ((FO ff) . (FO gg)) 57 | > ((FH ff) . (FH gg)) 58 | > (fid ff gg) 59 | > (comp ff gg) 60 | 61 | 2) functor composition is associative 62 | 63 | to show equality of two functors, it is enough to show equality of the 64 | object and morphism maps: 65 | 66 | First we have to show that given equal object and morphism maps, 67 | the types that FId's and FC's are equalities in are equal 68 | 69 | > funEqI : {cc, dd: Cat} -> 70 | > (fO, gO : Obj cc -> Obj dd) -> 71 | > (eqO : fO = gO) -> 72 | > -- FId ff is equality in Hom dd (FO ff a) (FO ff a) 73 | > -- FId gg is equality in Hom dd (FO gg a) (FO gg a) for some a : Obj cc 74 | > ({a: Obj cc} -> Hom dd (fO a) (fO a)) = 75 | > ({a: Obj cc} -> Hom dd (gO a) (gO a)) 76 | > funEqI {cc} {dd} fO gO eqO = 77 | > ({a: Obj cc} -> Hom dd (fO a) (fO a)) 78 | > ={ cong {f = \oMap => ({a: Obj cc} -> Hom dd (oMap a) (oMap a) )} eqO }= 79 | > ({a: Obj cc} -> Hom dd (gO a) (gO a)) 80 | > QED 81 | 82 | > funEqC : {cc, dd: Cat} -> 83 | > (fO, gO: Obj cc -> Obj dd) -> 84 | > (eqO : fO = gO) -> 85 | > -- FC ff is equality in Hom dd (FO ff a) (FO ff c) 86 | > -- FC gg is equality in Hom dd (FO gg a) (FO gg c) for some a, c : Obj cc 87 | > ({a, c: Obj cc} -> Hom dd (fO a) (fO c)) = 88 | > ({a, c: Obj cc} -> Hom dd (gO a) (gO c)) 89 | > funEqC {cc} {dd} fO gO eqO = 90 | > ({a, c : Obj cc} -> Hom dd (fO a) (fO c)) 91 | > ={ cong {f = \oMap => ({a, c: Obj cc} -> Hom dd (oMap a) (oMap c) )} eqO }= 92 | > ({a, c : Obj cc} -> Hom dd (gO a) (gO c)) 93 | > QED 94 | 95 | funEqI and funEqC are very similar, do we really need both? 96 | 97 | Here is yet another variant. Only difference: explicit object argument in the types 98 | that are proved equal 99 | 100 | > funEqI2 : {cc, dd: Cat} -> 101 | > (fO, gO : Obj cc -> Obj dd) -> 102 | > (eqO : fO = gO) -> 103 | > -- FId ff is equality in Hom dd (FO ff a) (FO ff a) 104 | > -- FId gg is equality in Hom dd (FO gg a) (FO gg a) for some a : Obj cc 105 | > ((a: Obj cc) -> (Hom dd (fO a) (fO a))) = 106 | > ((a: Obj cc) -> (Hom dd (gO a) (gO a))) 107 | > funEqI2 {cc} {dd} fO gO eqO = 108 | > ((a: Obj cc) -> Hom dd (fO a) (fO a)) 109 | > ={ cong {f = \oMap => ((a: Obj cc) -> Hom dd (oMap a) (oMap a) )} eqO }= 110 | > ((a: Obj cc) -> Hom dd (gO a) (gO a)) 111 | > QED 112 | 113 | < funEqP0 : {cc, dd: Cat} -> (ff, gg: Func cc dd) -> 114 | < (eqO : (FO ff) = (FO gg)) -> 115 | < (eqH : (FH ff) = (FH gg)) -> 116 | < (a : Obj cc) -> FId ff a = FId gg a 117 | < funEqP0 {cc} {dd} (MkFunc fO fH fI fC) (MkFunc gO gH gI gC) eqO eqH a = 118 | < (FId (MkFunc fO fH fI fC) a) ={ Refl }= 119 | < (fI a) 120 | 121 | 122 | ?lala where 123 | 124 | > -- types: goal: fI a = gI a 125 | > -- (fI a) : fH (Id a) = Id (fO a) 126 | > -- (gI a) : gH (Id a) = Id (gO a) 127 | > -- i.e. suffices 128 | > -- IsPropH (fH (Id a) = Id (fO a)) (gH (Id a) = Id (gO a)) 129 | > -- fH (Id a) : Hom dd (fO a) (fO a) 130 | > -- gH (Id a) : Hom dd (gO a) (gO a) 131 | 132 | UipWTH2 teq1 teq1 eq1 eq2 (fI a) (gI a) where 133 | 134 | eqOa : (fO a) = (gO a) 135 | eqOa = ?lulu 136 | 137 | 138 | cong {f = \fObj => fObj a} eqO 139 | 140 | 141 | -- teq1 : (Hom dd (fO a) (fO a)) = (Hom dd (gO a) (gO a)) 142 | teq1 = cong {f = \obj => Hom dd obj obj} eqOa 143 | -- eq1 : (fH (Id a)) = (gH (Id a)) 144 | eq1 = cong {f = \fHom => fHom (Id a)} eqH 145 | -- eq2 : (Id (fO a)) = (Id (gO a)) 146 | eq2 = cong {f = Id} eqOa 147 | 148 | < funEqP1 : {cc, dd: Cat} -> (ff, gg: Func cc dd) -> 149 | < (eqO : (FO ff) = (FO gg)) -> 150 | < (eqH : (FH ff) = (FH gg)) -> 151 | < FId ff = FId gg -- FId ff : (a : Obj cc) -> (fH (Id a)) = Id (fO a) 152 | < funEqP1 {cc} {dd} ff gg eqO eqH = 153 | < funextD {A = Obj cc} 154 | < {B1 = (\a => ((=) 155 | < {A = Hom dd (FO ff a) (FO ff a)} 156 | < {B = Hom dd (FO ff a) (FO ff a)} 157 | < (FH ff (Id a)) (Id (FO a))))} 158 | < {B2 = (\a => ((=) 159 | < {A = Hom dd (FO gg a) (FO gg a)} 160 | < {B = Hom dd (FO gg a) (FO gg a)} 161 | < (FH ff (Id a)) (Id (FO gg a))))} 162 | < (FId ff) (FId gg) (prf {cc = cc} {dd = dd} ff gg eqO eqH) 163 | < where 164 | < prf : {cc, dd: Cat} -> (ff, gg : Func cc dd) -> 165 | < (eqO : (FO ff) = (FO gg)) -> 166 | < (eqH : (FH ff) = (FH gg)) -> 167 | < (w : Obj cc) -> (FId ff w) = (FId gg w) 168 | < prf = ?lala 169 | 170 | where 171 | prf = ?lala 172 | 173 | < prf : (a: Obj cc) -> fI a = gI a 174 | < prf a = ?lala 175 | 176 | 177 | UipWTH {teq = ?three} ?one ?two (fI a) (gI a) 178 | 179 | funEqI2 {cc} {dd} {a} fO gO eqO 180 | (cong {f = \hh => hh a a (Id a)} eqH) 181 | (cong {f = \oo => Id (oo a)} eqO) fI gI 182 | 183 | 184 | < funEq : {cc, dd: Cat} -> (ff, gg: Func cc dd) -> 185 | < (eqO : (FO ff) = (FO gg)) -> 186 | < (eqH : (FH ff) = (FH gg)) -> 187 | < ff = gg 188 | 189 | < funEq {cc} {dd} (MkFunc fO fH fI fC) (MkFunc gO gH gI gC) eqO eqH = 190 | < (MkFunc fO fH fI fC) ={ cong {f = \o => MkFunc o fH fI fC} eqO }= 191 | < (MkFunc gO fH fI fC) ={ cong {f = \h => MkFunc gO h fI fC} eqH }= 192 | < (MkFunc gO gH fI fC) ={ cong {f = \i => MkFunc gO gH i fC} (UipWT {teq = funEqI fO gO eqO } fI gI) }= 193 | < (MkFunc gO gH gI fC) ={ cong {f = \c => MkFunc gO gH gI c} (UipWT {teq = funEqC fO gO eqO } fC gC) }= 194 | < (MkFunc gO gH gI gC) QED 195 | 196 | < funCompAssociative : {aa, bb, cc, dd : Cat} -> 197 | < (ff : Func cc dd) -> (gg : Func bb cc) -> (hh : Func aa bb) -> 198 | < funComp (funComp ff gg) hh = funComp ff (funComp gg hh) 199 | < funCompAssociative {aa} {bb} {cc} {dd} ff gg hh = 200 | < (MkFunc lO lH lI lC) ={ ?lele {-cong Refl-} }= 201 | < (MkFunc rO lH lI lC) ={ ?lulu {-cong Refl-} }= 202 | < (MkFunc rO rH lI lC) ={ ?lala {-cong (Uip lI rI)-} }= 203 | < (MkFunc rO rH rI lC) ={ ?lulu {-cong (Uip lC rC)-} }= 204 | < (MkFunc rO rH rI rC) ={ Refl }= 205 | < (rhs) QED 206 | < where 207 | < lhs = funComp (funComp ff gg) hh 208 | < rhs = funComp ff (funComp gg hh) 209 | < lO = FO lhs 210 | < lH = FH lhs 211 | < lI = FId lhs 212 | < lC = FC lhs 213 | < rO = FO rhs 214 | < rH = FH rhs 215 | < rI = FId rhs 216 | < rC = FC rhs 217 | 218 | 219 | 220 | -------------------------------------------------------------------------------- /Category.lidr: -------------------------------------------------------------------------------- 1 | > module Category 2 | 3 | > %default total 4 | > %auto_implicits off 5 | > %access public export 6 | 7 | Basic definitions of category theory 8 | ==================================== 9 | 10 | Define category, functor, natural transformation 11 | 12 | Category 13 | -------- 14 | 15 | > data Cat : Type where 16 | > MkCat : {- Objects -} 17 | > (O : Type) -> 18 | > {- Hom -} 19 | > (H : O -> O -> Type) -> 20 | > {- Identities -} 21 | > (Id : (a : O) -> H a a) -> 22 | > {- Composition -} 23 | > (Comp : {a, b, c : O} -> 24 | > (f : H b c) -> (g : H a b) -> H a c) -> 25 | > {- Comp is associative -} 26 | > (Ass : {a, b, c, d : O} -> 27 | > (f: H c d) -> (g : H b c) -> (h : H a b) -> 28 | > (Comp (Comp f g) h) = (Comp f (Comp g h))) -> 29 | > {- Precomposing Id is the identity on Arrows -} 30 | > (IdPre : {a, b : O} -> (f : H a b) -> 31 | > (Comp f (Id a)) = f) -> 32 | > {- Postcomposing Id is the identity on Arrows -} 33 | > (IdPost : {a, b : O} -> (f : H a b) -> 34 | > (Comp (Id b) f) = f) -> 35 | > Cat 36 | 37 | Getters for the components: 38 | Obj and Hom take the category as an explicit argument 39 | 40 | > Obj : Cat -> Type 41 | > Obj (MkCat O _ _ _ _ _ _) = O 42 | 43 | > Hom : (cc : Cat) -> (a, b : Obj cc) -> Type 44 | > Hom (MkCat _ H _ _ _ _ _ ) a b = H a b 45 | 46 | the rest of the getters can have cc as an implicit argument... 47 | 48 | > Id : {cc : Cat} -> (a : Obj cc) -> Hom cc a a 49 | > Id {cc=(MkCat _ _ id _ _ _ _)} a = id a 50 | 51 | > Comp : {cc : Cat} -> {a, b, c : Obj cc} -> 52 | > (f : Hom cc b c) -> (g : Hom cc a b) -> Hom cc a c 53 | > 54 | > Comp {cc=(MkCat _ _ _ comp _ _ _)} f g = comp f g 55 | 56 | > Ass : {cc : Cat} -> {a, b, c, d : Obj cc} -> 57 | > (f : Hom cc c d) -> (g : Hom cc b c) -> (h : Hom cc a b) -> 58 | > (Comp (Comp f g) h) = (Comp f (Comp g h)) 59 | > 60 | > Ass {cc=(MkCat _ _ _ _ ass _ _)} f g h = ass f g h 61 | 62 | > IdPre : {cc : Cat} -> {a, b : Obj cc} -> 63 | > (f: Hom cc a b) -> (Comp f (Id a)) = f 64 | > 65 | > IdPre {cc=(MkCat _ _ _ _ _ idl _)} f = idl f 66 | 67 | > IdPost : {cc: Cat} -> {a, b : Obj cc} -> 68 | > (f: Hom cc a b) -> (Comp (Id b) f) = f 69 | > 70 | > IdPost {cc=(MkCat _ _ _ _ _ _ idr)} f = idr f 71 | 72 | > syntax [f] "°" [g] = Comp f g 73 | 74 | Functor 75 | ------- 76 | 77 | > data Func : (cc : Cat) -> (dd : Cat) -> Type where 78 | > MkFunc : 79 | > {cc , dd : Cat} -> 80 | > {- Object map -} 81 | > (FO : Obj cc -> Obj dd) -> 82 | > {- Homomorphism map -} 83 | > (FH : {a, b : Obj cc} -> 84 | > Hom cc a b -> Hom dd (FO a) (FO b)) -> 85 | > {- FH maps identities to identities -} 86 | > (FI : (a : Obj cc) -> (FH (Id a) = Id (FO a))) -> 87 | > {- FH commutes with composition -} 88 | > (FC : {a, b, c: Obj cc} -> 89 | > (f : Hom cc b c) -> (g : Hom cc a b) -> 90 | > (FH (f ° g) = (FH f) ° (FH g))) -> 91 | > Func cc dd 92 | 93 | getters 94 | 95 | > FO : {cc, dd : Cat} -> (Func cc dd) -> 96 | > Obj cc -> Obj dd 97 | > FO (MkFunc fo _ _ _) = fo 98 | 99 | > FH : {cc, dd : Cat} -> {a, b : Obj cc} -> 100 | > (ff : Func cc dd) -> Hom cc a b -> 101 | > Hom dd (FO ff a) (FO ff b) 102 | > FH (MkFunc _ fh _ _) = fh 103 | 104 | > FId : {cc, dd : Cat} -> (ff : Func cc dd) -> 105 | > (a : Obj cc) -> (FH ff (Id a) = Id (FO ff a)) 106 | > FId (MkFunc _ _ fi _) = fi 107 | 108 | > FC : {cc, dd : Cat} -> 109 | > {a, b, c : Obj cc} -> 110 | > (ff : Func cc dd) -> 111 | > (f : Hom cc b c) -> (g : Hom cc a b) -> 112 | > FH ff (f ° g) = (FH ff f) ° (FH ff g) 113 | > FC (MkFunc _ _ _ fc) = fc 114 | 115 | 116 | Natural transformation 117 | ---------------------- 118 | 119 | > data NT : {cc, dd : Cat} -> 120 | > (ff, gg : Func cc dd) -> Type where 121 | > MkNT : 122 | > {cc, dd : Cat} -> {ff, gg : Func cc dd} -> 123 | > {- Component maps -} 124 | > (Cmp : (a: Obj cc) -> Hom dd (FO ff a) (FO gg a)) -> 125 | > {- Commutative squares -} 126 | > (CommSq : {a, b : Obj cc} -> 127 | > (f : Hom cc a b) -> 128 | > {- type checker needs the implicits... -} 129 | > (Comp {b = FO {cc} ff b} {c = FO {cc} gg b} 130 | > (Cmp b) (FH {dd} ff f)) = 131 | > ((FH gg f) ° (Cmp a))) -> 132 | > NT ff gg 133 | 134 | getters 135 | 136 | > NTC : {cc, dd : Cat} -> {ff, gg : Func cc dd} -> 137 | > NT ff gg -> (a: Obj cc) -> Hom dd (FO ff a) (FO gg a) 138 | > NTC (MkNT cmp _) = cmp 139 | 140 | > NTSq : {cc, dd : Cat} -> {ff, gg : Func cc dd} -> 141 | > {a, b : Obj cc} -> 142 | > (eta : NT ff gg) -> (f : Hom cc a b) -> 143 | > ((NTC eta b) ° (FH {dd} ff f)) = 144 | > ((FH gg f) ° (NTC eta a)) 145 | > NTSq (MkNT _ cs) = cs 146 | 147 | > syntax [s] "_" [a] = (NTC s) a 148 | 149 | 150 | -------------------------------------------------------------------------------- /DecProp.lidr: -------------------------------------------------------------------------------- 1 | > module DecProp 2 | > import Data.So 3 | > import Syntax.PreorderReasoning 4 | 5 | > %default total 6 | 7 | > %auto_implicits off 8 | 9 | > %access public export 10 | 11 | decidable props, praedicates a.s.o. with type interfaces 12 | ======================================================== 13 | 14 | Remark: depends on a "really_believe_me" to proof 15 | that any two functions f,g : a -> Void are equal. 16 | How far away is that from full function 17 | extensionality ? 18 | 19 | propositions 20 | ------------ 21 | 22 | > using (a : Type) 23 | > interface Prop a where 24 | > isProp : (x, y : a) -> x = y 25 | 26 | > implementation Prop Void where 27 | > isProp x _ = absurd x 28 | 29 | > implementation Prop Unit where 30 | > isProp () () = Refl 31 | 32 | > using (a : Type) 33 | > implementation Uninhabited a => Prop a where 34 | > isProp x _ = absurd x 35 | 36 | UIP 37 | 38 | > using (a : Type, x : a, y : a) 39 | > implementation Prop ((=) {A=a} {B=a} x y) where 40 | > isProp Refl Refl = Refl 41 | 42 | decidable propositions 43 | ---------------------- 44 | 45 | > using (a : Type) 46 | > interface Prop a => DecProp a where 47 | > decide : Dec a 48 | 49 | logic of decidable propositions 50 | ------------------------------- 51 | 52 | > implementation DecProp Void where 53 | > decide = No id 54 | 55 | > implementation DecProp Unit where 56 | > decide = Yes () 57 | 58 | Negation of a decidable proposition 59 | is a proposition (or, should be ... believe me...) 60 | 61 | > using (a : Type) 62 | > implementation DecProp a => Prop (Not a) where 63 | > isProp {a} f g = case decide {a} of 64 | > Yes x => absurd (f x) 65 | > No h => really_believe_me h 66 | 67 | and it is decidable 68 | 69 | > using (b : Type) 70 | > implementation DecProp b => DecProp (Not b) where 71 | > decide = decNot decide where 72 | > decNot : {a : Type} -> Dec a -> Dec (Not a) 73 | > decNot (Yes x ) = No (\notx => notx x) 74 | > decNot (No notx ) = Yes notx 75 | 76 | Conjunction 77 | 78 | > AND : (a, b : Type) -> Type 79 | > AND a b = (a,b) 80 | 81 | > syntax [a] "/\\" [b] = AND a b 82 | 83 | > using (a : Type, b : Type) 84 | > implementation (Prop a, Prop b) => Prop (a /\ b) where 85 | > isProp (x,y) (x',y') = 86 | > (x ,y ) ={ cong {f = \x => (x,y)} (isProp x x') }= 87 | > (x',y ) ={ cong {f = \y => (x',y)} (isProp y y') }= 88 | > (x',y') QED 89 | > 90 | > 91 | > implementation (DecProp a, DecProp b) => DecProp (a /\ b) where 92 | > decide = case decide {a = a} of 93 | > Yes prfa => case decide {a = b} of 94 | > Yes prfb => Yes (prfa,prfb) 95 | > No notb => No (\(pa,pb) => notb pb) 96 | > No nota => No (\(pa,pb) => nota pa) 97 | 98 | Disjunction 99 | 100 | > data OR : (a, b : Type) -> Type where 101 | > Both : {a, b : Type} -> a -> b -> OR a b 102 | > LeftO : {a, b : Type} -> a -> (Not b) -> OR a b 103 | > RightO : {a, b : Type} -> (Not a) -> b -> OR a b 104 | 105 | > syntax [a] "\\/" [b] = OR a b 106 | 107 | > using (a : Type, b : Type) 108 | > implementation (DecProp a, DecProp b) => Prop (a \/ b) where 109 | > isProp p1 p2 with (decide {a = a}, decide {a = b}) 110 | > isProp (Both x y) (Both x' y') | (Yes _, Yes _) = 111 | > (Both x y) 112 | > ={ cong {f = \x => (Both x y )} (isProp {a = a} x x') }= 113 | > (Both x' y) 114 | > ={ cong {f = \y => (Both x' y)} (isProp {a = b} y y') }= 115 | > (Both x' y') QED 116 | > isProp (LeftO x ny) (LeftO x' ny') | (Yes _, No _) = 117 | > (LeftO x ny) 118 | > ={ cong {f = \x => (LeftO x ny )} (isProp {a = a} x x') }= 119 | > (LeftO x' ny) 120 | > ={ cong {f = \ny => (LeftO x' ny )} (isProp {a = (Not b)} ny ny')}= 121 | > (LeftO x' ny') QED 122 | > isProp (RightO nx y) (RightO nx' y') | (No _, Yes _) = 123 | > (RightO nx y) 124 | > ={ cong {f = \nx => (RightO nx y)} (isProp {a = (Not a)} nx nx')}= 125 | > (RightO nx' y) 126 | > ={ cong {f = \y => (RightO nx' y)} (isProp {a = b} y y')}= 127 | > (RightO nx' y') QED 128 | > isProp (Both x _) _ | (No nx, _ ) = absurd (nx x) 129 | > isProp (LeftO x _) _ | (No nx, _ ) = absurd (nx x) 130 | > isProp (RightO nx _) _ | (Yes x, _ ) = absurd (nx x) 131 | > isProp _ (Both x _) | (No nx, _ ) = absurd (nx x) 132 | > isProp _ (LeftO x _) | (No nx, _ ) = absurd (nx x) 133 | > isProp _ (RightO nx _) | (Yes x, _ ) = absurd (nx x) 134 | > isProp (Both _ y) _ | (_ , No ny) = absurd (ny y) 135 | > isProp (RightO _ y) _ | (_ , No ny) = absurd (ny y) 136 | > isProp (LeftO _ ny) _ | (_ , Yes y) = absurd (ny y) 137 | > isProp _ (Both _ y) | (_ , No ny) = absurd (ny y) 138 | > isProp _ (RightO _ y) | (_ , No ny) = absurd (ny y) 139 | > isProp _ (LeftO _ ny) | (_ , Yes y) = absurd (ny y) 140 | > 141 | > implementation (DecProp a, DecProp b) => DecProp (a \/ b) where 142 | > decide with (decide {a = a}, decide {a = b}) 143 | > | (Yes x, Yes y) = Yes (Both x y) 144 | > | (Yes x, No ny) = Yes (LeftO x ny) 145 | > | (No nx, Yes y) = Yes (RightO nx y) 146 | > | (No nx, No ny) = No notxory where 147 | > notxory : (a \/ b) -> Void 148 | > notxory (Both x _) = absurd (nx x) 149 | > notxory (LeftO x _) = absurd (nx x) 150 | > notxory (RightO _ y) = absurd (ny y) 151 | 152 | > Implies : (a: Type) -> (b: Type) -> Type 153 | > Implies a b = (Not a) \/ b 154 | 155 | > syntax [a] "==>" [b] = Implies a b 156 | 157 | > Equiv : (a: Type) -> (b: Type) -> Type 158 | > Equiv a b = (a ==> b) /\ (b ==> a) 159 | 160 | > syntax [a] "<==>" [b] = Equiv a b 161 | 162 | > using (a : Type) 163 | > val : (DecProp a) => Bool 164 | > val {a} with (decide {a = a}) 165 | > | Yes _ = True 166 | > | No _ = False 167 | 168 | Praedicates 169 | 170 | a prepredicate is just a type family on a 171 | 172 | > data PrePred : Type -> Type where 173 | > MkPrePred : {a: Type} -> (a -> Type) -> PrePred a 174 | 175 | > using (a : Type) 176 | > unwrap : PrePred a -> (a -> Type) 177 | > unwrap (MkPrePred P) = P 178 | > 179 | > interface Pred a (P : PrePred a) where 180 | > isPred : (z : a) -> (x, y : (unwrap P) z) -> x = y 181 | > 182 | > interface Pred a P => DecPred a (P : PrePred a) where 183 | > decideAt : (z : a) -> Dec ((unwrap P) z) 184 | 185 | > Empty : {a : Type} -> PrePred a 186 | > Empty {a} = MkPrePred (\x => Void) 187 | 188 | > using (a : Type) 189 | > implementation Pred a (Empty {a}) where 190 | > isPred z = isProp 191 | > 192 | > implementation DecPred a (Empty {a}) where 193 | > decideAt z = decide 194 | 195 | > Full : {a : Type} -> PrePred a 196 | > Full {a} = MkPrePred (\x => ()) 197 | 198 | > using (a : Type) 199 | > implementation Pred a (Full {a}) where 200 | > isPred z = isProp 201 | > 202 | > implementation DecPred a (Full {a}) where 203 | > decideAt z = decide 204 | 205 | decidable relations a -> b are decidable predicates on a x b 206 | 207 | > interface Pred (a,b) P => DecRel a b (P : PrePred (a,b)) where { } 208 | 209 | > interface Pred (a,a) P => DecBinRel a (P : PrePred (a,a)) where { } 210 | 211 | 212 | > Singleton : {a : Type} -> (x : a) -> PrePred a 213 | > Singleton x = MkPrePred (\y => (x = y)) 214 | 215 | > data BoolPred : Type -> Type where 216 | > MkBoolPred : {a : Type} -> (a -> Bool) -> BoolPred a 217 | 218 | > using (a : Type, x : a) 219 | > implementation Pred a (Singleton {a} x) where 220 | > isPred z = isProp 221 | 222 | doesn't work yet: 223 | < implementation Eq a => DecPred a (Singleton x) where 224 | < decideAt z = if (x == z) then Yes Refl else ?lala 225 | 226 | any boolean predicate on a generates a decidable predicate on a: 227 | 228 | > predFromBPred : {a : Type} -> (a -> Bool) -> PrePred a 229 | > predFromBPred bp = MkPrePred (\x => bp x = True) 230 | 231 | < implementation Pred a (predFromBPred 232 | 233 | -------------------------------------------------------------------------------- /DependentCurrying.lidr: -------------------------------------------------------------------------------- 1 | > module DependentCurrying 2 | 3 | > import Control.Isomorphism 4 | > 5 | > %default total 6 | > %auto_implicits off 7 | > %access public export 8 | 9 | > uncurrySigma : 10 | > {A : Type} -> {B : A -> Type} -> {C : Type} -> 11 | > ({a : A} -> (b : B a) -> C) -> 12 | > ((w : (a : A ** B a)) -> C) 13 | > 14 | > uncurrySigma f (a ** b) = f b 15 | 16 | > uncurrySigmaD : 17 | > {A : Type} -> {B : A -> Type} -> 18 | > {C : ({a : A} -> (b : B a) -> Type)} -> 19 | > ({a : A} -> (b : B a) -> C b) -> 20 | > ( (w : (a : A ** B a)) -> 21 | > uncurrySigma {A} {B} {C=Type} C w 22 | > ) 23 | > 24 | > uncurrySigmaD f (a ** b) = f b 25 | 26 | 27 | > depPr : {A : Type} -> {B : A -> Type} -> 28 | > {a : A} -> (b : B a) -> A 29 | > depPr {a} b = a 30 | 31 | 32 | > currySigma : 33 | > {A : Type} -> {B : A -> Type} -> {C : Type} -> 34 | > ((w : (a : A ** B a)) -> C) -> 35 | > ({a : A} -> (b : B a) -> C) 36 | > 37 | > currySigma f b = f ((depPr b) ** b) 38 | 39 | > currySigmaD : 40 | > {A : Type} -> {B : A -> Type} -> 41 | > {C : ((a : A ** B a) -> Type)} -> 42 | > ((w : (a : A ** B a)) -> C w) -> 43 | > ({a : A} -> (b : B a) -> (currySigma C) b) 44 | > currySigmaD f b = f ((depPr b) ** b) 45 | 46 | 47 | -------------------------------------------------------------------------------- /EqCat.lidr: -------------------------------------------------------------------------------- 1 | > module EqCat 2 | > import Category 3 | > import Prop 4 | > %default total 5 | > %auto_implicits off 6 | > %access public export 7 | 8 | Each Idris type A forms a category where the class of 9 | objects is A and Hom x y = (x = y) 10 | 11 | Associativity and the properties of identity (Refl) are 12 | easily proved using Uip: 13 | 14 | > ass : {A : Type} -> {a,b,c,d : A} -> 15 | > (p: c = d) -> (q : b = c) -> (r : a = b) -> 16 | > (trans r (trans q p)) = (trans (trans r q) p) 17 | > ass p q r = Uip (trans r (trans q p)) (trans (trans r q) p) 18 | 19 | > idPre : {A : Type} -> {a, b : A} -> (p : a = b) -> (trans Refl p) = p 20 | > idPre p = Uip (trans Refl p) p 21 | 22 | > idPost : {A : Type} -> {a, b : A} -> (p : a = b) -> (trans p Refl) = p 23 | > idPost p = Uip (trans p Refl) p 24 | 25 | > eqCat : (A : Type) -> Cat 26 | > eqCat A = MkCat A 27 | > ((=) {A=A} {B=A}) 28 | > (\x => Refl) 29 | > (flip (trans {x=A} {y=A} {z=A})) 30 | > ass 31 | > idPre 32 | > idPost 33 | 34 | These are of course groupoids. 35 | TODO: define groupoids and prove this. 36 | 37 | And since we have Uip, these are all discrete. 38 | TODO: define "discrete" and prove this. 39 | 40 | -------------------------------------------------------------------------------- /FinSCat.lidr: -------------------------------------------------------------------------------- 1 | > module FinSCat 2 | > import Category 3 | > import Data.Fin 4 | > import Data.Vect 5 | > import Syntax.PreorderReasoning 6 | 7 | > %default total 8 | > %auto_implicits off 9 | > %access public export 10 | 11 | The sceleton of the category of finite sets with 12 | objects Fin n for n in Nat 13 | 14 | To get extensional equality of functions (Fin m) -> (Fin n), 15 | we identify such f with the vector [f(0),...,f(m-1)], i.e. an 16 | element of Vect m (Fin n) 17 | 18 | > FinMap : Nat -> Nat -> Type 19 | > FinMap m n = Vect m (Fin n) 20 | 21 | the identity functions 22 | 23 | > idVect : (n : Nat) -> FinMap n n 24 | > 25 | > idVect Z = [] 26 | > idVect (S n) = FZ :: map FS (idVect n) 27 | 28 | composition 29 | 30 | Fin m indexes Vect m A : 31 | 32 | > pick : {m : Nat} -> {A : Type} -> (Vect m A) -> Fin m -> A 33 | > 34 | > pick {m = Z} _ x = absurd x 35 | > pick {m = (S m')} (a::_) FZ = a 36 | > pick {m = (S m')} (_::as) (FS x') = pick as x' 37 | 38 | > compVect : {l, m, n : Nat} -> 39 | > (FinMap m n) -> (FinMap l m) -> (FinMap l n) 40 | > 41 | > compVect f = map (pick f) 42 | 43 | for the associativity proof 44 | 45 | > pickLemma : {l, m, n:Nat} -> 46 | > (f: FinMap m n) -> (g: FinMap l m) -> 47 | > (x: Fin l) -> 48 | > pick (compVect f g) x = pick f (pick g x) 49 | > 50 | > pickLemma {l=Z} _ _ x = absurd x 51 | > pickLemma {l=(S l')} f (gZ :: gR) FZ = Refl 52 | > pickLemma {l=(S l')} f (gZ :: gR) (FS x') = pickLemma {l=l'} f gR x' 53 | 54 | associativity 55 | 56 | > compVectAss : {k, l, m, n : Nat} -> 57 | > (f: FinMap m n) -> (g: FinMap l m) -> (h: FinMap k l) -> 58 | > (compVect (compVect f g) h) = (compVect f (compVect g h)) 59 | > 60 | > compVectAss {k=Z} _ _ [] = Refl 61 | > compVectAss {k=(S k')} f g (hZ :: hR) = 62 | > (compVect (compVect f g) (hZ :: hR)) 63 | > ={ Refl }= 64 | > ((pick (compVect f g) hZ) :: (compVect (compVect f g) hR)) 65 | > ={ cong {f = \x => x :: (compVect (compVect f g) hR)} 66 | > (pickLemma f g hZ) }= 67 | > ((pick f (pick g hZ)) :: (compVect (compVect f g) hR)) 68 | > ={ cong (compVectAss f g hR) }= 69 | > ((pick f (pick g hZ)) :: (compVect f (compVect g hR))) 70 | > ={ Refl }= 71 | > (compVect f (compVect g (hZ :: hR))) 72 | > QED 73 | 74 | idPre and idPost turn out to be trickier 75 | 76 | need 3 lemmata 77 | 78 | > compVectLemma : {l, m, n : Nat} -> (x : Fin n) -> 79 | > (f : FinMap m n) -> (g : FinMap l m) -> 80 | > (compVect (x::f) (map FS g) = compVect f g) 81 | > 82 | > compVectLemma {l=Z} x _ [] = Refl 83 | > compVectLemma {l=(S l')} x f (g::gs) = 84 | > (compVect (x::f) (map FS (g::gs))) 85 | > ={ Refl }= 86 | > (pick f g :: compVect (x::f) (map FS gs)) 87 | > ={ cong (compVectLemma x f gs) }= 88 | > (pick f g :: compVect f gs) 89 | > ={ Refl }= 90 | > (compVect f (g::gs)) 91 | > QED 92 | 93 | > pickMapLemma : {m : Nat} -> {A, B : Type} -> (f : Vect m A) -> 94 | > (x : Fin m) -> (g : A -> B) -> 95 | > pick (map g f) x = g (pick f x) 96 | > 97 | > pickMapLemma {m=Z} _ x _ = absurd x 98 | > pickMapLemma {m=(S m')} (fZ::_) FZ _ = Refl 99 | > pickMapLemma {m=(S m')} (_::fR) (FS x') g = pickMapLemma {m=m'} fR x' g 100 | 101 | > pickIdPostLemma : {n : Nat} -> (x : Fin n) -> 102 | > (pick (idVect n) x) = x 103 | > 104 | > pickIdPostLemma {n=Z} x = absurd x 105 | > pickIdPostLemma {n=(S n')} FZ = Refl 106 | > pickIdPostLemma {n=(S n')} (FS x') = 107 | > (pick (idVect (S n')) (FS x')) 108 | > ={ Refl }= 109 | > (pick (map FS (idVect n')) x') 110 | > ={ pickMapLemma (idVect n') x' FS }= 111 | > (FS (pick (idVect n') x')) 112 | > ={ cong (pickIdPostLemma x') }= 113 | > (FS x') 114 | > QED 115 | 116 | > idVectPre : {m, n : Nat} -> (f : Vect m (Fin n)) -> 117 | > (compVect f (idVect m)) = f 118 | > 119 | > idVectPre {m=Z} [] = Refl 120 | > idVectPre {m=(S m')} (fZ::fR) = 121 | > (compVect (fZ::fR) (idVect (S m'))) 122 | > ={ Refl }= 123 | > ( fZ :: (compVect (fZ::fR) (map FS (idVect m')))) 124 | > ={ cong (compVectLemma fZ fR (idVect m'))}= 125 | > ( fZ :: (compVect fR (idVect m'))) 126 | > ={ cong (idVectPre fR) }= 127 | > (fZ :: fR) 128 | > QED 129 | 130 | > idVectPost : {m, n : Nat} -> (f : FinMap m n) -> 131 | > (compVect (idVect n) f) = f 132 | > 133 | > idVectPost {m=Z} [] = Refl 134 | > idVectPost {m=(S m')} {n} (fZ::fR) = 135 | > (compVect (idVect n) (fZ::fR)) 136 | > ={ Refl }= 137 | > (pick (idVect n) fZ :: compVect (idVect n) fR) 138 | > ={ cong {f = \v => v :: compVect (idVect n) fR} (pickIdPostLemma fZ) }= 139 | > (fZ :: compVect (idVect n) fR) 140 | > ={ cong (idVectPost {m=m'} fR) }= 141 | > (fZ :: fR) 142 | > QED 143 | 144 | > finSCat : Cat 145 | > finSCat = MkCat Nat FinMap idVect compVect 146 | > compVectAss idVectPre idVectPost 147 | 148 | -------------------------------------------------------------------------------- /FreeCatOnGraph.lidr: -------------------------------------------------------------------------------- 1 | > module FreeCatOnGraph 2 | > import Graph 3 | > import Category 4 | > import Syntax.PreorderReasoning 5 | 6 | > %default total 7 | > %auto_implicits off 8 | > %access public export 9 | 10 | The free category on a directed graph: 11 | 12 | for the morphisms of the free Category, we need 13 | "heterogeneous" lists 14 | 15 | > data HList : (V : Type) -> (E : V -> V -> Type) -> 16 | > V -> V -> Type where 17 | > HLNil : {V : Type} -> {E : V -> V -> Type} -> 18 | > {v : V} -> HList V E v v 19 | > HLConc : {V : Type} -> {E : V -> V -> Type} -> 20 | > {a, b, c : V} -> 21 | > (f : HList V E b c) -> (g : E a b) -> 22 | > HList V E a c 23 | 24 | We need concatenation of HLists 25 | 26 | > infixl 5 +!+ 27 | 28 | > (+!+) : {V : Type} -> {E : V -> V -> Type} -> 29 | > {a, b, c : V} -> 30 | > HList V E b c -> HList V E a b -> HList V E a c 31 | > x +!+ HLNil = x 32 | > x +!+ (HLConc f g) = HLConc (x +!+ f) g 33 | 34 | , a proof that it is associative 35 | 36 | > assHList : {V : Type} -> {E : V -> V -> Type} -> 37 | > {a, b, c, d : V} -> 38 | > (f : HList V E c d) -> (g : HList V E b c) -> 39 | > (h : HList V E a b) -> 40 | > ((f +!+ g) +!+ h) = (f +!+ (g +!+ h)) 41 | > 42 | > assHList f g HLNil = Refl 43 | > assHList f g (HLConc h1 h2) = 44 | > ((f +!+ g) +!+ (HLConc h1 h2)) 45 | > ={ Refl }= 46 | > (HLConc ((f +!+ g) +!+ h1) h2) 47 | > ={ cong {f=(\ x => HLConc x h2)} (assHList f g h1) }= 48 | > (HLConc (f +!+ (g +!+ h1)) h2) 49 | > ={ Refl }= 50 | > (f +!+ (g +!+ (HLConc h1 h2))) 51 | > QED 52 | 53 | , and a proof that (HLNil +!+ f) = f 54 | 55 | > hLNilIdLeft : {V : Type} -> {E : V -> V -> Type} -> 56 | > {a, b : V} -> (f : HList V E a b) -> 57 | > (HLNil +!+ f) = f 58 | > hLNilIdLeft HLNil = Refl 59 | > hLNilIdLeft (HLConc fr ff) = 60 | > (HLNil +!+ (HLConc fr ff)) 61 | > ={ Refl }= 62 | > (HLConc (HLNil +!+ fr) ff) 63 | > ={ cong {f = (\x => HLConc x ff)} (hLNilIdLeft fr) }= 64 | > (HLConc fr ff) 65 | > QED 66 | 67 | > FreeCatOfGraph : Graph -> Cat 68 | > FreeCatOfGraph (MkGraph V E) = 69 | > MkCat V (HList V E) fcgId fcgComp fcgAss fcgIL fcgIR where 70 | > fcgId : (x : V) -> HList V E x x 71 | > fcgId x = HLNil {v = x} 72 | > fcgComp : {a, b, c : V} -> 73 | > (f: HList V E b c) -> (g : HList V E a b) -> HList V E a c 74 | > fcgComp = (+!+) 75 | > fcgAss : {a, b, c, d : V} -> (f : HList V E c d) -> 76 | > (g : HList V E b c) -> (h : HList V E a b) -> 77 | > ((f +!+ g) +!+ h) = (f +!+ (g +!+ h)) 78 | > fcgAss = assHList 79 | > fcgIL : {a, b : V} -> (f : HList V E a b) -> 80 | > (f +!+ HLNil) = f 81 | > fcgIL f = Refl 82 | > fcgIR : {a, b : V} -> (f : HList V E a b) -> 83 | > (HLNil +!+ f) = f 84 | > fcgIR f = hLNilIdLeft f 85 | 86 | 87 | -------------------------------------------------------------------------------- /FunExtAxiom.lidr: -------------------------------------------------------------------------------- 1 | > module FunExtAxiom 2 | 3 | > %default total 4 | > %auto_implicits off 5 | > %access public export 6 | 7 | If needed, we'll add function extensionality as an axiom 8 | 9 | > funext : {A, B : Type} -> 10 | > (f: A -> B) -> 11 | > (g: A -> B) -> 12 | > ((a : A) -> (f a) = (g a)) -> 13 | > f = g 14 | > funext f g h = really_believe_me h 15 | 16 | > funextD : {A : Type} -> 17 | > {B1 : A -> Type} -> 18 | > {B2 : A -> Type} -> 19 | > (f: (x : A) -> (B1 x)) -> 20 | > (g: (x : A) -> (B2 x)) -> 21 | > ((a : A) -> ((f a) = (g a))) -> 22 | > f = g 23 | > funextD f g h = really_believe_me h 24 | 25 | > funextD2 : {A : Type} -> 26 | > {B : A -> Type} -> 27 | > {C1 : (x : A) -> B x -> Type} -> 28 | > {C2 : (x : A) -> B x -> Type} -> 29 | > (f : (x : A) -> (y : B x) -> C1 x y) -> 30 | > (g : (x : A) -> (y : B x) -> C2 x y) -> 31 | > ((x : A) -> (y : B x) -> f x y = g x y) -> 32 | > f = g 33 | > funextD2 f g h = really_believe_me h 34 | 35 | 36 | -------------------------------------------------------------------------------- /FuncCat.lidr: -------------------------------------------------------------------------------- 1 | > module FuncCat 2 | > import Category 3 | > import FunExtAxiom 4 | > import Prop 5 | > import Syntax.PreorderReasoning 6 | 7 | > %default total 8 | > %auto_implicits off 9 | > %access public export 10 | 11 | Given two (small) categories cc and dd, we have 12 | the category of functors Funcs cc dd 13 | 14 | identity natural transformation: 15 | 16 | > idNT : {cc, dd : Cat} -> 17 | > (ff : Func cc dd) -> NT ff ff 18 | > idNT {cc} {dd} ff = 19 | > MkNT (cmpId ff) (commSqId ff) where 20 | > 21 | > cmpId : (ff: Func cc dd) -> 22 | > (a : Obj cc) -> 23 | > Hom dd (FO ff a) (FO ff a) 24 | > 25 | > cmpId ff a = Category.Id (FO ff a) 26 | > 27 | > 28 | > commSqId : (ff: Func cc dd) -> 29 | > {a, b : Obj cc} -> 30 | > (f : Hom cc a b) -> 31 | > ((cmpId ff b) ° (FH ff f)) = ((FH ff f) ° (cmpId ff a)) 32 | > 33 | > commSqId ff {a} {b} f = 34 | > ((cmpId ff b) ° (FH ff f)) ={ Refl }= 35 | > ((Id (FO ff b)) ° (FH ff f)) ={ IdPost (FH ff f) }= 36 | > (FH ff f) ={ sym (IdPre (FH ff f)) }= 37 | > ((FH ff f) ° (Id (FO ff a))) ={ Refl }= 38 | > ((FH ff f) ° (cmpId ff a)) QED 39 | 40 | composition of natural transformations: 41 | 42 | component maps are composed in dd: 43 | 44 | > cmpST : {cc, dd : Cat} -> 45 | > {ff, gg, hh : Func cc dd} -> 46 | > (s : NT gg hh) -> 47 | > (t : NT ff gg) -> 48 | > (a : Obj cc) -> 49 | > Hom dd (FO ff a) (FO hh a) 50 | > 51 | > cmpST s t a = (s _ a) ° (t _ a) 52 | 53 | squares commute since they are put together from the commtative squares 54 | of the transformations being composed 55 | 56 | > commSqST : 57 | > {cc, dd : Cat} -> 58 | > {ff, gg, hh : Func cc dd} -> 59 | > (s : NT gg hh) -> 60 | > (t : NT ff gg) -> 61 | > {a, b : Obj cc} -> 62 | > (f : Hom cc a b) -> 63 | > ((cmpST s t b) ° (FH ff f)) = ((FH hh f) ° (cmpST s t a)) 64 | > 65 | > commSqST {ff} {gg} {hh} s t {a} {b} f = 66 | > ((cmpST s t b) ° (FH ff f)) ={ Refl }= 67 | > (((s _ b) ° (t _ b)) ° (FH ff f)) ={ Ass (s _ b) (t _ b) (FH ff f) }= 68 | > ((s _ b) ° ((t _ b) ° (FH ff f))) ={ cong {f = \x => ((s _ b) ° x)} (NTSq t f) }= 69 | > ((s _ b) ° ((FH gg f) ° (t _ a))) ={ sym (Ass (s _ b) (FH gg f) (t _ a)) }= 70 | > (((s _ b) ° (FH gg f)) ° (t _ a) ) ={ cong {f = \x => x ° (t _ a)} (NTSq s f) }= 71 | > (((FH hh f) ° (s _ a)) ° (t _ a)) ={ Ass (FH hh f) (s _ a) (t _ a) }= 72 | > ((FH hh f) ° ((s _ a) ° (t _ a))) ={ Refl }= 73 | > ((FH hh f) ° (cmpST s t a)) QED 74 | 75 | > compNT : 76 | > {cc, dd : Cat} -> 77 | > {ff, gg, hh : Func cc dd} -> 78 | > NT gg hh -> 79 | > NT ff gg -> 80 | > NT ff hh 81 | > 82 | > compNT s t = MkNT (cmpST s t) (commSqST s t) 83 | 84 | 85 | associativity of compNT 86 | 87 | first the components 88 | 89 | > assCLemma : 90 | > {cc, dd : Cat} -> 91 | > {ff, gg, hh, kk: Func cc dd} -> 92 | > (t : NT hh kk) -> 93 | > (r : NT gg hh) -> 94 | > (s : NT ff gg) -> 95 | > NTC (compNT (compNT t r) s) = NTC (compNT t (compNT r s)) 96 | > 97 | > assCLemma {cc} {dd} {ff} {gg} {hh} {kk} t r s = 98 | > funextD {A = Obj cc} 99 | > {B1 = \a => Hom dd (FO ff a) (FO kk a)} 100 | > {B2 = \a => Hom dd (FO ff a) (FO kk a)} 101 | > (NTC (compNT (compNT t r) s)) 102 | > (NTC (compNT t (compNT r s))) 103 | > (\a => Ass (t _ a) (r _ a) (s _ a)) 104 | 105 | then the squares 106 | 107 | > assSqLemma : 108 | > {cc, dd : Cat} -> 109 | > {ff, gg, hh, kk: Func cc dd} -> 110 | > (t : NT hh kk) -> 111 | > (r : NT gg hh) -> 112 | > (s : NT ff gg) -> 113 | > NTSq (compNT (compNT t r) s) = NTSq (compNT t (compNT r s)) 114 | > 115 | > assSqLemma {cc} {dd} {ff} {gg} {hh} {kk} t r s = ?lala 116 | 117 | funextD {A = Hom cc a b} 118 | (NTSq (compNT (compNT t r) s)) 119 | (NTSq (compNT t (compNT r s))) 120 | (\f => Uip ()) 121 | 122 | 123 | > FuncCat : (cc, dd : Cat) -> Cat 124 | > FuncCat cc dd = MkCat 125 | > (Func cc dd) (NT {cc} {dd}) (idNT {cc} {dd}) (compNT {cc} {dd}) ?ass ?idPre ?idPost 126 | 127 | 128 | 129 | -------------------------------------------------------------------------------- /Graph.lidr: -------------------------------------------------------------------------------- 1 | > module Graph 2 | 3 | > %default total 4 | > %auto_implicits off 5 | > %access public export 6 | 7 | directed Graphs: 8 | 9 | > data Graph : Type where 10 | > MkGraph : (GVert: Type) -> -- Vertices 11 | > (GEdg: GVert -> GVert -> Type) -> -- directed edges 12 | > Graph 13 | 14 | getters: 15 | 16 | > GVert : Graph -> Type 17 | > GVert (MkGraph V _) = V 18 | 19 | > GEdg : (gg : Graph) -> (v : GVert gg) -> 20 | > (w : GVert gg) -> 21 | > Type 22 | > GEdg (MkGraph _ E) v w = E v w 23 | 24 | -------------------------------------------------------------------------------- /NSig.lidr: -------------------------------------------------------------------------------- 1 | > import Data.Vect 2 | 3 | > %default total 4 | > %auto_implicits off 5 | > %access public export 6 | 7 | multisorted signatures 8 | 9 | we have a type of (codes for) sorts 10 | 11 | a symbol has an arity in any sort and a 12 | destination sort: 13 | 14 | symbols are indexed by a pair (Sort -> Nat, Sort) 15 | 16 | > NSig : Type -> Type 17 | > NSig S = (arity : S -> Nat) -> (tgt: S) -> Type 18 | 19 | > arity : {S : Type} -> {nsig : NSig S} -> 20 | > {arity : S -> Nat} -> {tgt : S} -> 21 | > nsig arity tgt -> S -> Nat 22 | > arity {arity=ar} _ = ar 23 | 24 | > tgt : {S : Type} -> {nsig : NSig S} -> 25 | > {arity : S -> Nat} -> {tgt : S} -> 26 | > nsig arity tgt -> S 27 | > tgt {tgt=t} _ = t 28 | 29 | example: signature of Monoid acting on a set 30 | 31 | > data MonoidUnit = Unit 32 | > data MonoidOp = Op 33 | > data MonoidAct = Act 34 | 35 | > data SortsMonoidAction = M | X 36 | 37 | > MonoidAction : NSig SortsMonoidAction 38 | > MonoidAction arity M with (arity M, arity X) 39 | > | (Z,Z) = MonoidUnit 40 | > | (S(S Z),Z) = MonoidOp 41 | > | _ = Void 42 | > MonoidAction arity X with (arity M, arity X) 43 | > | ((S Z),(S Z)) = MonoidAct 44 | > | _ = Void 45 | 46 | 47 | now what about adding equality? 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /Preorder.lidr: -------------------------------------------------------------------------------- 1 | > module Preorder 2 | > import Prop 3 | > import Syntax.PreorderReasoning 4 | 5 | > %default total 6 | > %auto_implicits off 7 | > %access public export 8 | 9 | Preorders, partial orders, linear orders 10 | ======================================== 11 | 12 | Relations 13 | --------- 14 | 15 | A binary relation between types X and Y is a "subset" of the cartesian 16 | product XxY. How to model this? 17 | 18 | First attempt: 19 | -------------- 20 | 21 | as a boolean predicate in "curried" form: 22 | 23 | > RelB : Type -> Type -> Type 24 | > RelB A B = A -> B -> Bool 25 | 26 | binary relations on A then become 27 | 28 | > BinRelB : Type -> Type 29 | > BinRelB A = RelB A A 30 | 31 | Examples 32 | 33 | the empty relation between any two types 34 | 35 | > emptyRelB : {A, B : Type} -> RelB A B 36 | > emptyRelB x y = False 37 | 38 | and the "all" relation: 39 | 40 | > allRelB : {A, B : Type} -> RelB A B 41 | > allRelB x y = True 42 | 43 | "normal" greater or equal on Nat: 44 | 45 | > geq : BinRelB Nat 46 | > geq Z Z = True 47 | > geq Z (S n) = True 48 | > geq (S m) Z = False 49 | > geq (S m) (S n) = geq m n 50 | 51 | prefix order on lists 52 | (we need the element type to have a decidable equality) 53 | 54 | < lPre : DecEq a => BinRelB (List a) 55 | < lPre [] _ = True 56 | < lPre (x::xs) [] = False 57 | < lPre (x::xs) (y::ys) 58 | < with (decEq x y) 59 | < | Yes _ = lPre xs ys 60 | < | No _ = False 61 | 62 | But properties of relations are difficult to implement, e.g.: 63 | 64 | < isReflexiveB : {A : Type} -> BinRelB A -> Bool 65 | 66 | if A is infinite, such a "check" for reflexivity will never finish, 67 | so we cannot implement this as a total function! So 68 | 69 | 70 | Second attempt 71 | -------------- 72 | 73 | as a type valued function! 74 | 75 | > Rel : Type -> Type -> Type 76 | > Rel A B = A -> B -> Type 77 | 78 | A relation r in (Rel A B) is a "family" of types, one 79 | for each pair of elements a in A and b in B. Elements of 80 | this type r a b are the proves (evidences, witnesses, ...) that 81 | a and b are in relation r. 82 | 83 | the empty relation between any two types 84 | 85 | > emptyRel : {A, B : Type} -> Rel A B 86 | > emptyRel x y = Void 87 | 88 | the "all" relation: 89 | 90 | > allRel : {A, B : Type} -> Rel A B 91 | > allRel x y = () 92 | 93 | > BinRel : Type -> Type 94 | > BinRel A = Rel A A 95 | 96 | > data IsRefl : {A : Type} -> BinRel A -> Type where 97 | > PrfRefl : -- if for a relation r on A 98 | > {A : Type} -> {r : BinRel A} -> 99 | > -- we provide for each x in A an element of (r x x) 100 | > ( (x : A) -> r x x ) -> 101 | > -- then we have proved reflexivity of r 102 | > (IsRefl r) 103 | 104 | > data IsTrans : {A : Type} -> BinRel A -> Type where 105 | > PrfTrans : -- if for a relation r on A 106 | > {A : Type} -> {r : BinRel A} -> 107 | > -- for any x,y,z in A, given proofs (r x y) and (r y z) 108 | > -- we can produce a proof of (r x z) 109 | > ({x, y, z : A} -> r x y -> r y z -> r x z ) -> 110 | > -- then we have proved transitivity of r 111 | > (IsTrans r) 112 | 113 | 114 | Preorder 115 | -------- 116 | 117 | To model a preordered set: 118 | 119 | > data Preorder : Type where 120 | > MkPreorder : {- the set is modeled as a type -} 121 | > (O : Type) -> 122 | > {- the fact "a R b" is also modeled by a type -} 123 | > (R : O -> O -> Type) -> 124 | > {- R is reflexive -} 125 | > (Ref : (a : O) -> R a a) -> 126 | > {- R is transitive -} 127 | > (Trans : {a, b, c : O} -> 128 | > R a b -> R b c -> R a c) -> 129 | > {- the types "a R b" have at most one inhabitant, 130 | > i.e. they are "Propositions" -} 131 | > (IsPropR : {a, b : O} -> IsProp (R a b)) -> 132 | > Preorder 133 | 134 | > PObj : Preorder -> Type 135 | > PObj (MkPreorder o _ _ _ _) = o 136 | 137 | > PHom : (pp : Preorder) -> (PObj pp) -> (PObj pp) -> Type 138 | > PHom (MkPreorder _ rel _ _ _) = rel 139 | 140 | > PRefl : {pp : Preorder} -> (a : PObj pp) -> PHom pp a a 141 | > PRefl {pp=(MkPreorder _ _ ref _ _)} = ref 142 | 143 | > PTrans : {pp : Preorder} -> {a, b, c : PObj pp} -> 144 | > (PHom pp a b) -> (PHom pp b c) -> (PHom pp a c) 145 | > PTrans {pp=(MkPreorder _ _ _ trans _)} = trans 146 | 147 | > PProp : {pp : Preorder} -> {a, b : PObj pp} -> 148 | > IsProp ( PHom pp a b ) 149 | > PProp {pp=(MkPreorder _ _ _ _ isProp)} = isProp 150 | 151 | 152 | 153 | > namespace Preorder 154 | > using (pp : Preorder, a : PObj pp, b: PObj pp, c : PObj pp) 155 | > qed : (a : PObj pp) -> PHom pp a a 156 | > qed = PRefl 157 | > step : (a : PObj pp) -> PHom pp a b -> PHom pp b c -> PHom pp a c 158 | > step a p q = PTrans p q 159 | 160 | > isTrans' : (pp : Preorder) -> (a, b, c : PObj pp) -> 161 | > (PHom pp a b) -> (PHom pp b c) -> (PHom pp a c) 162 | > isTrans' pp a b c p q = 163 | > a ={ p }= 164 | > b ={ q }= 165 | > c QED 166 | 167 | Meets 168 | 169 | > data IsMeet : {pp : Preorder} -> (a, b, c : PObj pp) -> Type where 170 | > PrfIsMeet : {pp : Preorder} -> (a, b, c : PObj pp) -> 171 | > -- c is lower bound of {a,b} 172 | > (PHom pp c a) -> (PHom pp c b) -> 173 | > -- and for any other lower bound d, d is lower than c 174 | > ((d : PObj pp) -> PHom pp d a -> PHom pp d b -> PHom pp d c) -> 175 | > IsMeet a b c 176 | 177 | 178 | -------------------------------------------------------------------------------- /Prop.lidr: -------------------------------------------------------------------------------- 1 | > module Prop 2 | 3 | > %default total 4 | > %auto_implicits off 5 | > %access public export 6 | 7 | A type is called a proposition iff any two inhabitants of 8 | the type are equal: 9 | 10 | > IsProp : Type -> Type 11 | > IsProp t = (p, q : t) -> p = q 12 | 13 | Heterogeneous variant (useful?) 14 | 15 | > IsPropH : Type -> Type -> Type 16 | > IsPropH t1 t2 = (p : t1) -> (q : t2) -> p = q 17 | 18 | Void is a proposition 19 | 20 | > VoidIsProp : IsProp Void 21 | > VoidIsProp p q = absurd p 22 | 23 | Unit is a proposition 24 | 25 | > UnitIsProp : IsProp () 26 | > UnitIsProp () () = Refl 27 | 28 | Any equality type in Idris is a proposition 29 | (Uip = "uniqueness of identity proofs") 30 | 31 | > Uip : {A : Type} -> {a1, a2 : A} -> IsProp (a1 = a2) 32 | > Uip Refl Refl = Refl 33 | 34 | > UipWT : {A, B : Type} -> { teq: A = B } -> {a1 : A} -> {a2 : B} -> IsProp (a1 = a2) 35 | > UipWT {teq = Refl} Refl Refl = Refl 36 | 37 | > UipWTH : {A, B : Type} -> { teq: A = B } -> {a1, a2 : A} -> {b1, b2 : B} -> 38 | > (asEq : a1 = a2) -> (bsEq: b1 = b2) -> IsPropH (a1 = b1) (a2 = b2) 39 | > UipWTH {teq = Refl} Refl Refl Refl Refl = Refl 40 | 41 | heterogeneous equality implies type equality 42 | 43 | > eqToTypeEq : {A, B : Type} -> {a : A} -> {b : B} -> (a = b) -> A = B 44 | > eqToTypeEq Refl = Refl 45 | 46 | > UipWTH2 : {A1, A2, B1, B2 : Type} -> 47 | > {a1 : A1} -> {a2 : A2} -> {b1 : B1} -> {b2 : B2} -> 48 | > (teq1 : A1 = B1) -> (teq2 : A2 = B2) -> 49 | > (a1 = a2) -> (b1 = b2) -> IsPropH (a1 = b1) (a2 = b2) 50 | > UipWTH2 Refl Refl Refl Refl Refl Refl = Refl 51 | 52 | 53 | 54 | 55 | For subsets we also need families of Props, aka 56 | Praedicates 57 | 58 | > data Praed : (A : Type) -> Type where 59 | > MkPraed : {A : Type} -> (P : A -> Type) -> 60 | > ((a : A) -> IsProp (P a)) -> 61 | > Praed A 62 | 63 | The Sigma type of a Praedicate over A is a Subset 64 | 65 | > SubSet : {A : Type} -> Praed A -> Type 66 | > SubSet {A} (MkPraed P _) = ( a : A ** P a) 67 | 68 | > EmptyPraed : {A : Type} -> Praed A 69 | > EmptyPraed = MkPraed (\a => Void) (\a => VoidIsProp) 70 | 71 | > EmptySubSet : {A : Type} -> Type 72 | > EmptySubSet {A} = SubSet (EmptyPraed {A}) 73 | 74 | 75 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CId 2 | a little category theory in Idris 3 | 4 | This is an attempt to formalize some elementary category 5 | theory in Idris. Let's see how far we get. 6 | 7 | Typechecks (mostly, see below) in Idris Version 0.11 8 | 9 | ## What's in the files: 10 | 11 | ### Category.lidr 12 | 13 | Definitions of a category, a functor, a natural transformation. 14 | 15 | ### Graph.lidr 16 | 17 | Defines type of directed graphs 18 | 19 | ### FreeCatOnGraph.lidr 20 | 21 | Construction of the free category on a directed graph. 22 | 23 | ### EqCat.lidr 24 | 25 | The discrete category on a type: morphisms are the equalities. 26 | 27 | ### TypeCat.lidr 28 | 29 | Type is a category with maps as morphisms. 30 | 31 | ### FinSCat.lidr 32 | 33 | A sceleton of the category of finite sets: 34 | 35 | Nat is the type of objects. 36 | 37 | Hom m n is Vect m (Fin n) (rather than (Fin m) -> (Fin n)) 38 | to have function extensionality. 39 | 40 | ### DecProp.lidr 41 | 42 | Attempt to model decidable propositions using interfaces. 43 | Overlapping implementation... 44 | Not used anywhere... 45 | 46 | ### Prop.lidr 47 | 48 | Defines IsProp and proves Uip in some variants. 49 | 50 | ### Preorder.lidr 51 | 52 | Preorders (without Categories). May be unnecessary. 53 | 54 | ### FunExtAxiom.lidr 55 | 56 | Function extensionality axiom. Needed for FuncCat and CatCat. 57 | 58 | ### FuncCat.lidr 59 | 60 | Functor category ... incomplete. 61 | 62 | ### CatCat.lidr 63 | 64 | Category of categories ... incomplete. 65 | 66 | ### DependentCurrying 67 | 68 | Helper functions to establish the equivalence of 69 | dependent functions on Sigma-Types and dependent 70 | functions of several variables 71 | -------------------------------------------------------------------------------- /Signatures.lidr: -------------------------------------------------------------------------------- 1 | > module Signatures 2 | > import Data.Vect 3 | > import Syntax.PreorderReasoning 4 | 5 | > %default total 6 | > %auto_implicits off 7 | > %access public export 8 | 9 | A (onesorted) signature is just a type family over |Nat|. 10 | The elements of |sig n| are the n-ary symbols. 11 | 12 | > Sig : Type 13 | > Sig = Nat -> Type 14 | 15 | > arity : {s : Sig} -> {n : Nat} -> s n -> Nat 16 | > arity {n} _ = n 17 | 18 | The family of n-ary Terms over a signature is a tree 19 | type where m-ary symbols label the m-branching nodes 20 | and the leafs are the n-ary "projections" (indexed 21 | by 0,1,...,n-1) 22 | 23 | > infixr 7 ::: 24 | 25 | > data Term : Sig -> Nat -> Type where 26 | > Pr : {s : Sig} -> {n : Nat} -> 27 | > (i : Nat) -> {auto smaller: i `LT` n} -> Term s n 28 | > (:::) : {s : Sig} -> {m, n : Nat} -> s m -> Vect m (Term s n) -> Term s n 29 | 30 | We could have written 31 | 32 | < data Term : Sig -> Sig 33 | 34 | Indeed, we'll show that Sig is a category and Term is a monad 35 | on Sig.: 36 | 37 | morphisms of Sig: 38 | 39 | > SigMor : Sig -> Sig -> Type 40 | > SigMor s t = (n : Nat) -> s n -> t n 41 | 42 | identity signature morphisms: 43 | 44 | > idSigMor : {s : Sig} -> SigMor s s 45 | > idSigMor = (\n => id) 46 | 47 | composition of signature morphisms 48 | 49 | > compSigMor : 50 | > {s, t, u : Sig} -> 51 | > SigMor t u -> 52 | > SigMor s t -> 53 | > SigMor s u 54 | > compSigMor {s} {t} {u} f g = comp where 55 | > comp : (n : Nat) -> s n -> u n 56 | > comp = \n => (\sSymb => f n (g n sSymb)) 57 | 58 | associativity 59 | 60 | > assCompSigMor : 61 | > {s, t, u, v : Sig} -> 62 | > (f : SigMor u v) -> 63 | > (g : SigMor t u) -> 64 | > (h : SigMor s t) -> 65 | > compSigMor (compSigMor f g) h = compSigMor f (compSigMor g h) 66 | > assCompSigMor f g h = Refl 67 | 68 | identity precomposition is neutral 69 | 70 | > eta : {a, b : Type} -> 71 | > (f : a -> b) -> 72 | > f = (\x => f x) 73 | > eta f = Refl 74 | 75 | > etaD : {a : Type} -> 76 | > {b : a -> Type} -> 77 | > (f : (x : a) -> b x) -> 78 | > f = (\x => f x) 79 | > etaD f = Refl 80 | 81 | > eta2 : {a, b, c : Type} -> 82 | > (f : a -> b -> c) -> 83 | > f = (\x => (\y => (f x) y)) 84 | > eta2 f = Refl 85 | 86 | 87 | 88 | > etaNested : {a : Type} -> 89 | > {b, c : a -> Type} -> 90 | > (f : (x : a) -> b x -> c x) -> 91 | > (x : a) -> 92 | > f x = \sSymb => f x sSymb 93 | > etaNested f x = Refl 94 | 95 | 96 | idPreCompSigMor : 97 | {s, t : Sig} -> 98 | (f : SigMor s t) -> 99 | compSigMor f idSigMor = f 100 | idPreCompSigMor f = 101 | (compSigMor f idSigMor) 102 | ={ Refl }= 103 | (\n => (\sSymb => (f n) sSymb)) 104 | ={ sym (eta (f n)) }= 105 | (\n => f n) 106 | ={ Refl }= 107 | f 108 | QED 109 | 110 | 111 | 112 | Term is a functor 113 | 114 | > fmapT : 115 | > {s, t : Sig} -> 116 | > SigMor s t -> 117 | > SigMor (Term s) (Term t) 118 | > fmapT f _ (Pr i) = (Pr i) 119 | > fmapT {s} {t} f n (sSymb ::: args) = f (arity sSymb) sSymb ::: map (fmapT f n) args 120 | 121 | (laws postponed...) 122 | 123 | and a monad... need preparations for this: 124 | 125 | Since Terms have (Pr i) at the leaves, it is easy to weaken an 126 | n-Term to an (S n)-Term by adding a dummy variable 127 | 128 | > weakenT : {s : Sig} -> {n : Nat} -> Term s n -> Term s (S n) 129 | > weakenT (Pr {n} i {smaller=sm}) = Pr {n = S n} i {smaller = lteSuccRight sm} 130 | > weakenT (sym ::: args) = sym ::: map weakenT args 131 | 132 | This should be in a lib somewhere...? 133 | 134 | > plusOneRightSucc : (n : Nat) -> n + 1 = S n 135 | > plusOneRightSucc Z = Refl 136 | > plusOneRightSucc (S n) = cong (plusOneRightSucc n) 137 | 138 | The vector [Pr 0, Pr 1, ... , Pr n-1] 139 | 140 | > stdnVec : {s : Sig} -> (n : Nat) -> Vect n (Term s n) 141 | > stdnVec Z = [] 142 | > stdnVec (S n) = replace {P = \x => Vect x (Term s (S n))} (plusOneRightSucc n) 143 | > ((map weakenT (stdnVec n)) ++ [Pr n {smaller = lteRefl}]) 144 | 145 | since the index function of Vect needs Fin and we use Nat with an auto smaller, 146 | we need: 147 | 148 | > natToFin' : {n : Nat} -> (i : Nat) -> {auto smaller: i `LT` n} -> Fin n 149 | > natToFin' {n = Z} i {smaller} = absurd smaller 150 | > natToFin' {n = S n} Z = FZ 151 | > natToFin' {n = S n} (S i) {smaller = LTESucc sm} 152 | > = FS (natToFin' {n} i {smaller = sm}) 153 | 154 | Now we can define the unit of the Term monad: 155 | 156 | > unitT : {s: Sig} -> SigMor s (Term s) 157 | > unitT {s} n sSymb = sSymb ::: stdnVec n 158 | 159 | and its multiplication 160 | 161 | > multT : {s: Sig} -> SigMor (Term (Term s)) (Term s) 162 | > multT {s} n (Pr i) = Pr i 163 | > multT {s} n ((Pr j) ::: termsTT_n_m) = 164 | > multT {s} n (index (natToFin' j) termsTT_n_m) 165 | > multT {s} n ((symb_l ::: termsT_m_l) ::: termsTT_n_m) = 166 | > symb_l ::: map (\ term_m => multT {s} n (term_m ::: termsTT_n_m)) termsT_m_l 167 | 168 | > revbindT : 169 | > {s, t : Sig} -> 170 | > SigMor s (Term t) -> 171 | > SigMor (Term s) (Term t) 172 | > revbindT {s} {t} f n termTS_n = multT {s=t} n (fmapT f n termTS_n) 173 | 174 | > compKleisliT : 175 | > {s, t, u : Sig} -> 176 | > SigMor t (Term u) -> 177 | > SigMor s (Term t) -> 178 | > SigMor s (Term u) 179 | > compKleisliT {s} {t} {u} f g = compSigMor (multT {s=u}) (compSigMor (fmapT f) g) 180 | 181 | 182 | 183 | -------------------------------------------------------------------------------- /TypeCat.lidr: -------------------------------------------------------------------------------- 1 | > module TypeCat 2 | > import Category 3 | 4 | > %default total 5 | > %auto_implicits off 6 | > %access public export 7 | 8 | Idris types with functions form a category 9 | ------------------------------------------ 10 | 11 | Preparations: 12 | 13 | function composition is associative 14 | 15 | > funCompAss : {A, B, C, D : Type} -> 16 | > (f : C -> D) -> (g : B -> C) -> (h : A -> B) -> 17 | > (f . (g . h)) = ((f . g) . h) 18 | > funCompAss f g h = Refl 19 | 20 | 21 | > idPre : {A, B : Type} -> (f : A -> B) -> 22 | > (f . Prelude.Basics.id) = f 23 | > idPre f = Refl 24 | 25 | > idPost : {A, B : Type} -> (f : A -> B) -> 26 | > ((Prelude.Basics.id {a = B}). f) = f 27 | > idPost f = Refl 28 | 29 | Can't write (->) ... why? 30 | 31 | > Maps : Type -> Type -> Type 32 | > Maps A B = A -> B 33 | 34 | identity function with an explicit type argument 35 | 36 | > idExpl : (a : Type) -> (a -> a) 37 | > idExpl a = id 38 | 39 | > TypeCat : Cat 40 | > TypeCat = MkCat Type Maps idExpl (.) funCompAss idPre idPost 41 | 42 | --------------------------------------------------------------------------------