├── TODO ├── CommaCategoryFunctors.v ├── .gitignore ├── .hgignore ├── report_time.sh ├── NatFacts.v ├── NatCategory.v ├── Subcategory.v ├── DecidableSmallCat.v ├── PullbackFunctor.v ├── EqualizerFunctor.v ├── DecidableSetCategory.v ├── DecidableComputableCategory.v ├── ProductFunctors.v ├── Graph.v ├── SimplicialSets.v ├── PathsCategory.v ├── make-each-time-file.sh ├── Products.v ├── ComputableCategory.v ├── ComputableGraphCategory.v ├── DefinitionSimplification.v ├── LICENSE ├── FunctorialComposition.v ├── StructureEquality.v ├── DualFunctor.v ├── FunctorCategory.v ├── ProductNaturalTransformation.v ├── EquivalenceRelationGenerator.v ├── ChainCategory.v ├── Group.v ├── SetCategoryProductFunctor.v ├── LimitFunctors.v ├── SetSchema.v ├── IndiscreteCategory.v ├── BoolCategory.v ├── make-one-time-file.py ├── DiscreteCategory.v ├── SemiSimplicialSets.v ├── PathsCategoryFunctors.v ├── Instance.v ├── SmallCat.v ├── TimeFileMaker.py ├── ProductCategory.v ├── CommaCategoryFunctorProperties.v ├── GroupCategory.v ├── DecidableDiscreteCategory.v ├── SigTSigInducedFunctors.v ├── make-both-time-files.py ├── FunctorProduct.v ├── Theorems.v ├── CommaCategoryProjection.v ├── deplists.v ├── Notations.v ├── InitialTerminalCategory.v ├── SigTInducedFunctors.v ├── replace_imports.py ├── ProductInducedFunctors.v ├── ComputableSchemaCategory.v ├── SumCategory.v ├── FunctorAttributes.v ├── Equalizer.v ├── AdjointPointwise.v ├── Groupoid.v ├── SubobjectClassifier.v ├── AdjointComposition.v ├── TypeclassSimplification.v ├── SigTSigCategory.v ├── DatabaseConstraints.v ├── Category.v ├── Coend.v ├── LimitFunctor2CategoryTheorems.v ├── SumInducedFunctors.v ├── MetaTranslation.v ├── SetLimits.v ├── GraphTranslation.v ├── CategoryEquality.v ├── GrothendieckCat.v ├── Makefile ├── Paths.v ├── Hom.v ├── LimitFunctorTheorems.v ├── SigSigTCategory.v ├── Grothendieck.v ├── GrothendieckFunctorial.v ├── NaturalNumbersObject.v ├── SQLQueries.v ├── ProductLaws.v ├── Duals.v ├── CoendFunctor.v ├── Graphs.v └── CanonicalStructureSimplification.v /TODO: -------------------------------------------------------------------------------- 1 | Try out [rsimplify_morphisms] in SpecializedLaxCommaCategory.v 2 | -------------------------------------------------------------------------------- /CommaCategoryFunctors.v: -------------------------------------------------------------------------------- 1 | Require Export CommaCategoryProjectionFunctors. 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | 3 | *.depend 4 | *.vo 5 | Makefile.coq 6 | Makefile-timed.coq 7 | *.glob 8 | *.v.d 9 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | syntax: glob 2 | 3 | *~ 4 | 5 | *.depend 6 | *.vo 7 | Makefile.coq 8 | Makefile-timed.coq 9 | *.glob 10 | *.v.d 11 | -------------------------------------------------------------------------------- /report_time.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # from http://stackoverflow.com/questions/6966877/measure-time-spent-in-each-target-of-a-makefile 3 | 4 | shift # get rid of the '-c' supplied by make. 5 | time sh -c "$*" 6 | -------------------------------------------------------------------------------- /NatFacts.v: -------------------------------------------------------------------------------- 1 | Require Import Omega. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | Section le_rel. 10 | Lemma le_refl n : n <= n. trivial. Qed. 11 | 12 | Lemma le_trans : forall n m p, n <= m -> m <= p -> n <= p. 13 | intuition. 14 | Qed. 15 | End le_rel. 16 | 17 | Add Parametric Relation : _ @le 18 | reflexivity proved by le_refl 19 | transitivity proved by le_trans 20 | as le_rel. 21 | -------------------------------------------------------------------------------- /NatCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory DiscreteCategory. 2 | Require Import Common. 3 | 4 | Fixpoint CardinalityRepresentative (n : nat) : Set := 5 | match n with 6 | | O => Empty_set 7 | | 1 => unit 8 | | S n' => (CardinalityRepresentative n' + unit)%type 9 | end. 10 | 11 | Coercion CardinalityRepresentative : nat >-> Sortclass. 12 | 13 | Definition NatCategory (n : nat) := Eval unfold DiscreteCategory, DiscreteCategory_Identity in DiscreteCategory n. 14 | 15 | Coercion NatCategory : nat >-> SpecializedCategory. 16 | -------------------------------------------------------------------------------- /Subcategory.v: -------------------------------------------------------------------------------- 1 | Require Export SigCategory. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | Definition Subcategory := @SpecializedCategory_sig. 10 | Definition SubcategoryInclusionFunctor := @proj1_sig_functor. 11 | Definition FullSubcategory := @SpecializedCategory_sig_obj. 12 | Definition FullSubcategoryInclusionFunctor := @proj1_sig_obj_functor. 13 | Definition WideSubcategory := @SpecializedCategory_sig_mor. 14 | Definition WideSubcategoryInclusionFunctor := @proj1_sig_mor_functor. 15 | -------------------------------------------------------------------------------- /DecidableSmallCat.v: -------------------------------------------------------------------------------- 1 | Require Export SmallCat SigTCategory. 2 | 3 | Set Implicit Arguments. 4 | 5 | Generalizable All Variables. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section SmallCat. 12 | Let eq_dec_on_cat `(C : @SpecializedCategory objC) := forall x y : objC, {x = y} + {x <> y}. 13 | 14 | Definition SmallCatDec := SpecializedCategory_sigT_obj SmallCat (fun C => eq_dec_on_cat C). 15 | Definition LocallySmallCatDec := SpecializedCategory_sigT_obj LocallySmallCat (fun C => eq_dec_on_cat C). 16 | End SmallCat. 17 | -------------------------------------------------------------------------------- /PullbackFunctor.v: -------------------------------------------------------------------------------- 1 | Require Export LimitFunctors Pullback. 2 | 3 | Set Implicit Arguments. 4 | 5 | Generalizable All Variables. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section Equalizer. 12 | Context `(C : @SpecializedCategory objC). 13 | 14 | Variable HasLimits : forall F : SpecializedFunctor PullbackIndex C, Limit F. 15 | Variable HasColimits : forall F : SpecializedFunctor PushoutIndex C, Colimit F. 16 | 17 | Definition PullbackFunctor := LimitFunctor HasLimits. 18 | Definition PushoutFunctor := ColimitFunctor HasColimits. 19 | End Equalizer. 20 | -------------------------------------------------------------------------------- /EqualizerFunctor.v: -------------------------------------------------------------------------------- 1 | Require Export LimitFunctors Equalizer. 2 | 3 | Set Implicit Arguments. 4 | 5 | Generalizable All Variables. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section Equalizer. 12 | Context `(C : @SpecializedCategory objC). 13 | 14 | Variable HasLimits : forall F : SpecializedFunctor EqualizerIndex C, Limit F. 15 | Variable HasColimits : forall F : SpecializedFunctor EqualizerIndex C, Colimit F. 16 | 17 | Definition EqualizerFunctor := LimitFunctor HasLimits. 18 | Definition CoequalizerFunctor := ColimitFunctor HasColimits. 19 | End Equalizer. 20 | -------------------------------------------------------------------------------- /DecidableSetCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SetCategory SigTCategory. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | (* There is a category [Set], where the objects are sets with decidable equality 10 | and the morphisms are set morphisms *) 11 | Section CSet. 12 | Let eq_dec_on T := forall x y : T, {x = y} + {x <> y}. 13 | 14 | Definition TypeCatDec := SpecializedCategory_sigT_obj TypeCat eq_dec_on. 15 | Definition SetCatDec := SpecializedCategory_sigT_obj SetCat eq_dec_on. 16 | Definition PropCatDec := SpecializedCategory_sigT_obj PropCat eq_dec_on. 17 | End CSet. 18 | -------------------------------------------------------------------------------- /DecidableComputableCategory.v: -------------------------------------------------------------------------------- 1 | Require Export ComputableCategory SigTCategory. 2 | 3 | Set Implicit Arguments. 4 | 5 | Generalizable All Variables. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section ComputableCategory. 12 | Variable I : Type. 13 | Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)). 14 | 15 | Local Coercion Index2Cat : I >-> SpecializedCategory. 16 | 17 | Let eq_dec_on_cat `(C : @SpecializedCategory objC) := forall x y : objC, {x = y} + {x <> y}. 18 | 19 | Definition ComputableCategoryDec := @SpecializedCategory_sigT_obj _ (@ComputableCategory _ _ Index2Cat) (fun C => eq_dec_on_cat C). 20 | End ComputableCategory. 21 | -------------------------------------------------------------------------------- /ProductFunctors.v: -------------------------------------------------------------------------------- 1 | Require Export Products LimitFunctors. 2 | Require Import Common Notations DiscreteCategory DiscreteCategoryFunctors. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section Products. 13 | Context `{C : @SpecializedCategory objC}. 14 | Variable I : Type. 15 | 16 | Variable HasLimits : forall F : SpecializedFunctor (DiscreteCategory I) C, Limit F. 17 | Variable HasColimits : forall F : SpecializedFunctor (DiscreteCategory I) C, Colimit F. 18 | 19 | Definition ProductFunctor := LimitFunctor HasLimits. 20 | Definition CoproductFunctor := ColimitFunctor HasColimits. 21 | End Products. 22 | -------------------------------------------------------------------------------- /Graph.v: -------------------------------------------------------------------------------- 1 | Require Import Notations. 2 | 3 | Set Implicit Arguments. 4 | 5 | Generalizable All Variables. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section Graph. 12 | Record Graph (v : Type) := { 13 | Vertex :> _ := v; 14 | Edge' : v -> v -> Type 15 | }. 16 | End Graph. 17 | 18 | Bind Scope graph_scope with Graph. 19 | Bind Scope vertex_scope with Vertex. 20 | Bind Scope edge_scope with Edge'. 21 | 22 | Arguments Vertex {v%type} G%graph : rename. 23 | 24 | Section GraphInterface. 25 | Context `(G : @Graph v). 26 | 27 | Definition Edge : forall s d : G, _ := Eval cbv beta delta [Edge'] in G.(Edge'). 28 | End GraphInterface. 29 | 30 | Bind Scope edge_scope with Edge. 31 | 32 | Arguments Vertex {v%type} G : rename, simpl never. 33 | Arguments Edge {v%type} G s d : rename, simpl nomatch. 34 | -------------------------------------------------------------------------------- /SimplicialSets.v: -------------------------------------------------------------------------------- 1 | Require Export ChainCategory Duals FunctorCategory. 2 | Require Import Notations ComputableCategory SetCategory. 3 | 4 | Generalizable Variables objC. 5 | 6 | Set Implicit Arguments. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section SimplicialSets. 13 | Definition SimplexCategory := @ComputableCategory nat _ (fun n => [n])%category. 14 | Local Notation Δ := SimplexCategory. 15 | 16 | Definition SimplicialCategory `(C : SpecializedCategory objC) := (C ^ (OppositeCategory Δ))%category. 17 | 18 | Definition SimplicialSet := SimplicialCategory SetCat. 19 | Definition SimplicialType := SimplicialCategory TypeCat. 20 | Definition SimplicialProp := SimplicialCategory PropCat. 21 | End SimplicialSets. 22 | 23 | Notation SimplicialOf obj := (let C := CatOf obj in SimplicialCategory C). 24 | -------------------------------------------------------------------------------- /PathsCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Paths. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Section PCategory. 11 | Variable V : Type. 12 | Variable E : V -> V -> Type. 13 | 14 | Hint Immediate concatenate_associative. 15 | Hint Rewrite concatenate_associative. 16 | 17 | Definition PathsCategory : @SpecializedCategory V. 18 | refine (@Build_SpecializedCategory _ 19 | (@path V E) 20 | (@NoEdges _ _) 21 | (fun _ _ _ p p' => concatenate p' p) 22 | _ 23 | _ 24 | _); 25 | abstract t_with t'. 26 | Defined. 27 | End PCategory. 28 | -------------------------------------------------------------------------------- /make-each-time-file.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | NEW_FILE="$1" 4 | OLD_FILE="$2" 5 | 6 | SHELF_NAME="compare-times-shelf" 7 | 8 | if [ ! -z "$OLD_FILE" ]; then 9 | trap "hg import --no-commit $SHELF_NAME" SIGINT SIGTERM 10 | 11 | # make the old version 12 | #hg shelve --all --name $SHELF_NAME 13 | hg diff > $SHELF_NAME && hg revert -a 14 | make clean 15 | make timed 2>&1 | tee "$OLD_FILE" 16 | 17 | 18 | # make the current version 19 | if [ -z "$(cat $SHELF_NAME)" ]; then 20 | # there is no diff, so just copy the time file 21 | cp "$OLD_FILE" "$NEW_FILE" 22 | else 23 | if [ -z "$(hg diff)" ]; then 24 | hg revert -a # clean up any, e.g., chmod +x 25 | fi 26 | hg import --no-commit $SHELF_NAME && mv $SHELF_NAME "$SHELF_NAME-$(date | base64).bak" 27 | make clean 28 | make timed 2>&1 | tee "$NEW_FILE" 29 | fi 30 | else 31 | make clean 32 | make timed 2>&1 | tee "$NEW_FILE" 33 | fi 34 | -------------------------------------------------------------------------------- /Products.v: -------------------------------------------------------------------------------- 1 | Require Export Limits. 2 | Require Import Common Notations DiscreteCategory DiscreteCategoryFunctors. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section Products. 13 | Context `{C : @SpecializedCategory objC}. 14 | Variable I : Type. 15 | Variable f : I -> C. 16 | 17 | Definition Product := Limit (InducedDiscreteFunctor C f). 18 | Definition Coproduct := Colimit (InducedDiscreteFunctor C f). 19 | End Products. 20 | 21 | (* XXX: [Reserved Notation] doesn't work here? *) 22 | Notation "∏_{ x } f" := (@Product _ _ _ (fun x => f)) (at level 0, x at level 99). 23 | Notation "∏_{ x : A } f" := (@Product _ _ A (fun x : A => f)) (at level 0, x at level 99). 24 | Notation "∐_{ x } f" := (@Coproduct _ _ _ (fun x => f)) (at level 0, x at level 99). 25 | Notation "∐_{ x : A } f" := (@Coproduct _ _ A (fun x : A => f)) (at level 0, x at level 99). 26 | -------------------------------------------------------------------------------- /ComputableCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Section ComputableCategory. 11 | Variable I : Type. 12 | Variable Index2Object : I -> Type. 13 | Variable Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i). 14 | 15 | Local Coercion Index2Cat : I >-> SpecializedCategory. 16 | 17 | Definition ComputableCategory : @SpecializedCategory I. 18 | refine (@Build_SpecializedCategory _ 19 | (fun C D : I => SpecializedFunctor C D) 20 | (fun o : I => IdentityFunctor o) 21 | (fun C D E : I => ComposeFunctors (C := C) (D := D) (E := E)) 22 | _ 23 | _ 24 | _); 25 | abstract functor_eq. 26 | Defined. 27 | End ComputableCategory. 28 | -------------------------------------------------------------------------------- /ComputableGraphCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Graph GraphTranslation. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Section ComputableGraphCategory. 11 | Variable I : Type. 12 | Variable Index2Vertex : I -> Type. 13 | Variable Index2Graph : forall i : I, @Graph (@Index2Vertex i). 14 | 15 | Local Coercion Index2Graph : I >-> Graph. 16 | 17 | Definition ComputableGraphCategory : @SpecializedCategory I. 18 | refine (@Build_SpecializedCategory _ 19 | (fun C D : I => GraphTranslation C D) 20 | (fun o : I => IdentityGraphTranslation o) 21 | (fun C D E : I => ComposeGraphTranslations (C := C) (D := D) (E := E)) 22 | _ 23 | _ 24 | _); 25 | abstract graph_translation_eq. 26 | Defined. 27 | End ComputableGraphCategory. 28 | -------------------------------------------------------------------------------- /DefinitionSimplification.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | (* Silly predicate that we can use to get Ltac to help us manipulate terms *) 10 | Definition focus A (_ : A) := True. 11 | 12 | (* This definition does most of the work of simplification. *) 13 | Ltac simpl_definition_by_tac_and_exact defn tac := 14 | assert (Hf : focus defn) by constructor; 15 | let defnH := head defn in try unfold defnH in Hf; try tac; simpl in Hf; 16 | rewrite_eta_in Hf; 17 | match type of Hf with 18 | | focus ?V => exact V 19 | end. 20 | 21 | Ltac simpl_definition_by_exact defn := simpl_definition_by_tac_and_exact defn idtac. 22 | 23 | (** To simplify something defined as [Ident'] of type [IdentT] into [Ident], do something like: 24 | Definition Ident'' : IdentT. 25 | simpl_definition_by_exact Ident'. 26 | Defined. 27 | 28 | (* Then we clean up a bit with reduction. *) 29 | Definition Ident := Eval cbv beta iota zeta delta [Ident''] in Ident''. 30 | *) 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2012 Jason Gross, Adam Chlipala, and David Spivak 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /FunctorialComposition.v: -------------------------------------------------------------------------------- 1 | Require Export FunctorCategory ProductCategory. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section FunctorialComposition. 13 | Context `(C : SpecializedCategory objC). 14 | Context `(D : SpecializedCategory objD). 15 | Context `(E : SpecializedCategory objE). 16 | 17 | Definition FunctorialComposition : SpecializedFunctor ((E ^ D) * (D ^ C)) (E ^ C). 18 | Proof. 19 | match goal with 20 | | [ |- SpecializedFunctor ?C ?D ] => 21 | refine (Build_SpecializedFunctor C D 22 | (fun fg => ComposeFunctors (fst fg) (snd fg)) 23 | (fun _ _ tu => NTComposeF (fst tu) (snd tu)) 24 | _ 25 | _ 26 | ) 27 | end; 28 | abstract ( 29 | intros; 30 | destruct_hypotheses; 31 | auto with category; 32 | nt_eq; 33 | repeat rewrite FIdentityOf; 34 | auto with category 35 | ). 36 | Defined. 37 | End FunctorialComposition. 38 | -------------------------------------------------------------------------------- /StructureEquality.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality ProofIrrelevance JMeq. 2 | Require Import Common Notations FEqualDep. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Local Infix "==" := JMeq. 11 | 12 | Ltac structures_eq_simpl_step_with tac := intros; simpl in *; 13 | match goal with 14 | | _ => reflexivity 15 | | [ |- (fun _ : ?A => _) = _ ] => apply functional_extensionality_dep; intro 16 | | [ |- (fun _ : ?A => _) == _ ] => apply (@functional_extensionality_dep_JMeq A); intro 17 | | [ |- (forall _ : ?A, _) = _ ] => apply (@forall_extensionality_dep A); intro 18 | | _ => tac 19 | end; simpl; JMeq_eq. 20 | 21 | Ltac structures_eq_step_with_tac structures_equal_tac tac := intros; simpl in *; 22 | match goal with 23 | | _ => reflexivity 24 | | [ |- _ = _ ] => expand; structures_equal_tac 25 | | [ |- _ == _ ] => expand; structures_equal_tac 26 | | _ => structures_eq_simpl_step_with tac 27 | end. 28 | 29 | Ltac structures_eq_step_with structures_equal_lemma tac := structures_eq_step_with_tac ltac:(apply structures_equal_lemma) tac. 30 | -------------------------------------------------------------------------------- /DualFunctor.v: -------------------------------------------------------------------------------- 1 | Require Export Duals SmallCat. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | Section OppositeCategory. 10 | Definition SmallOppositeFunctor : SpecializedFunctor SmallCat SmallCat. 11 | refine (Build_SpecializedFunctor SmallCat SmallCat 12 | (fun x => OppositeCategory x : SmallSpecializedCategory _) 13 | (fun _ _ m => OppositeFunctor m) 14 | _ 15 | _); 16 | simpl; abstract functor_eq. 17 | Defined. 18 | 19 | Definition LocallySmallOppositeFunctor : SpecializedFunctor LocallySmallCat LocallySmallCat. 20 | refine (Build_SpecializedFunctor LocallySmallCat LocallySmallCat 21 | (fun x => OppositeCategory x : LocallySmallSpecializedCategory _) 22 | (fun _ _ m => OppositeFunctor m) 23 | _ 24 | _); 25 | simpl; abstract functor_eq. 26 | Defined. 27 | End OppositeCategory. 28 | -------------------------------------------------------------------------------- /FunctorCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor NaturalTransformation. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section FunctorCategory. 13 | Context `(C : @SpecializedCategory objC). 14 | Context `(D : @SpecializedCategory objD). 15 | 16 | (* 17 | There is a category Fun(C, D) of functors from [C] to [D]. 18 | *) 19 | Definition FunctorCategory : @SpecializedCategory (SpecializedFunctor C D). 20 | refine (@Build_SpecializedCategory _ 21 | (SpecializedNaturalTransformation (C := C) (D := D)) 22 | (IdentityNaturalTransformation (C := C) (D := D)) 23 | (NTComposeT (C := C) (D := D)) 24 | _ 25 | _ 26 | _); 27 | abstract (nt_eq; auto with morphism). 28 | Defined. 29 | End FunctorCategory. 30 | 31 | Notation "C ^ D" := (FunctorCategory D C) : category_scope. 32 | -------------------------------------------------------------------------------- /ProductNaturalTransformation.v: -------------------------------------------------------------------------------- 1 | Require Export ProductCategory FunctorProduct NaturalTransformation. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section ProductNaturalTransformation. 13 | Context `{A : @SpecializedCategory objA}. 14 | Context `{B : @SpecializedCategory objB}. 15 | Context `{C : @SpecializedCategory objC}. 16 | Context `{D : @SpecializedCategory objD}. 17 | Variables F F' : SpecializedFunctor A B. 18 | Variables G G' : SpecializedFunctor C D. 19 | Variable T : SpecializedNaturalTransformation F F'. 20 | Variable U : SpecializedNaturalTransformation G G'. 21 | 22 | Definition ProductNaturalTransformation : SpecializedNaturalTransformation (F * G) (F' * G'). 23 | refine (Build_SpecializedNaturalTransformation (F * G) (F' * G') 24 | (fun ac : A * C => (T (fst ac), U (snd ac))) 25 | _ 26 | ); 27 | abstract (intros; simpl; simpl_eq; auto with natural_transformation). 28 | Defined. 29 | End ProductNaturalTransformation. 30 | 31 | Infix "*" := ProductNaturalTransformation : natural_transformation_scope. 32 | -------------------------------------------------------------------------------- /EquivalenceRelationGenerator.v: -------------------------------------------------------------------------------- 1 | Require Import Setoid. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Section Gen. 11 | Variable A : Type. 12 | Variable equiv : relation A. 13 | 14 | Inductive EquivalenceOf : A -> A -> Prop := 15 | | gen_underlying : forall a b, equiv a b -> EquivalenceOf a b 16 | | gen_refl : forall a, EquivalenceOf a a 17 | | gen_sym : forall a b, EquivalenceOf a b -> EquivalenceOf b a 18 | | gen_trans : forall a b c, EquivalenceOf a b -> EquivalenceOf b c -> EquivalenceOf a c. 19 | 20 | Hint Constructors EquivalenceOf. 21 | 22 | Lemma EquivalenceOf_Equivalence : Equivalence EquivalenceOf. 23 | constructor; eauto. 24 | Defined. 25 | 26 | Definition generateEquivalence : { equiv' : A -> A -> Prop | Equivalence equiv' & forall a b, equiv a b -> equiv' a b }. 27 | exists EquivalenceOf. 28 | exact EquivalenceOf_Equivalence. 29 | eauto. 30 | Defined. 31 | End Gen. 32 | 33 | Add Parametric Relation A equiv : _ (@EquivalenceOf A equiv) 34 | reflexivity proved by (@gen_refl _ _) 35 | symmetry proved by (@gen_sym _ _) 36 | transitivity proved by (@gen_trans _ _) 37 | as EquivalenceOf_rel. 38 | -------------------------------------------------------------------------------- /ChainCategory.v: -------------------------------------------------------------------------------- 1 | Require Import ProofIrrelevance. 2 | Require Export SpecializedCategory. 3 | Require Import NatFacts Subcategory DefinitionSimplification. 4 | 5 | Set Implicit Arguments. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section ChainCat. 12 | Definition OmegaCategory : @SpecializedCategory nat. 13 | refine (@Build_SpecializedCategory _ 14 | le 15 | le_refl 16 | (fun _ _ _ H0 H1 => le_trans H1 H0) 17 | _ 18 | _ 19 | _); 20 | abstract (intros; apply proof_irrelevance). 21 | Defined. 22 | 23 | Let ChainCategory' n : @SpecializedCategory { m | m <= n }. 24 | simpl_definition_by_tac_and_exact (FullSubcategory OmegaCategory (fun m => m <= n)) ltac:(unfold Subcategory in *). 25 | Defined. 26 | Definition ChainCategory n := Eval cbv beta iota zeta delta [ChainCategory'] in ChainCategory' n. 27 | End ChainCat. 28 | 29 | Notation "[ n ]" := (ChainCategory n) : category_scope. 30 | Notation "[ ∞ ]" := (OmegaCategory) : category_scope. 31 | Notation "[ 'ω' ]" := (OmegaCategory) : category_scope. 32 | -------------------------------------------------------------------------------- /Group.v: -------------------------------------------------------------------------------- 1 | Require Import Notations. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | Delimit Scope group_elements_scope with group. 10 | Delimit Scope groups_scope with groups. 11 | 12 | Section Group. 13 | Local Reserved Notation "'G'". 14 | Local Reserved Notation "1". 15 | 16 | Record Group := 17 | { 18 | GroupObjects :> Type where "'G'" := GroupObjects; 19 | GroupIdentity : G where "1" := GroupIdentity; 20 | GroupOperation : G -> G -> G where "a * b" := (GroupOperation a b); 21 | GroupInverse : G -> G where "i ⁻¹" := (GroupInverse i); 22 | GroupLeftInverse : forall x, x ⁻¹ * x = 1; 23 | GroupRightInverse : forall x, x * x ⁻¹ = 1; 24 | GroupAssociativity : forall a b c, a * (b * c) = (a * b) * c; 25 | GroupLeftIdentity : forall x, 1 * x = x; 26 | GroupRightIdentity : forall x, x * 1 = x 27 | }. 28 | End Group. 29 | 30 | Bind Scope groups_scope with Group. 31 | Bind Scope group_elements_scope with GroupObjects. 32 | 33 | Arguments GroupOperation {g%groups} _%group _%group. 34 | Arguments GroupIdentity {g%groups}. 35 | Arguments GroupInverse {g%groups} _%group. 36 | 37 | Notation "1" := (@GroupIdentity _) : group. 38 | Infix "*" := (@GroupOperation _) : group. 39 | Notation "i ⁻¹" := (@GroupInverse _ i) : group. 40 | -------------------------------------------------------------------------------- /SetCategoryProductFunctor.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Export ProductCategory SetCategory Functor. 3 | Require Import Common Notations. 4 | 5 | Set Implicit Arguments. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Local Close Scope nat_scope. 12 | 13 | Section ProductFunctor. 14 | Hint Extern 1 (@eq (_ -> _) _ _) => apply functional_extensionality_dep; intro. 15 | Hint Extern 2 => destruct_head @prod. 16 | 17 | Local Ltac build_functor := 18 | hnf; 19 | match goal with 20 | | [ |- @SpecializedFunctor ?objC ?C ?objD ?D ] => 21 | refine (@Build_SpecializedFunctor objC C objD D 22 | (fun ab => (fst ab) * (snd ab)) 23 | (fun _ _ fg => (fun xy => ((fst fg) (fst xy), (snd fg) (snd xy)))) 24 | _ 25 | _); 26 | abstract eauto 27 | end. 28 | 29 | Definition TypeProductFunctor : SpecializedFunctor (TypeCat * TypeCat) TypeCat. build_functor. Defined. 30 | Definition SetProductFunctor : SpecializedFunctor (SetCat * SetCat) SetCat. build_functor. Defined. 31 | Definition PropProductFunctor : SpecializedFunctor (PropCat * PropCat) PropCat. build_functor. Defined. 32 | End ProductFunctor. 33 | -------------------------------------------------------------------------------- /LimitFunctors.v: -------------------------------------------------------------------------------- 1 | Require Export Limits. 2 | Require Import Notations FunctorCategory Adjoint AdjointUniversalMorphisms. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Local Open Scope category_scope. 13 | 14 | Section LimitFunctors. 15 | Context `(C : @SpecializedCategory objC). 16 | Context `(D : @SpecializedCategory objD). 17 | 18 | Definition HasLimits' := forall F : SpecializedFunctor D C, exists _ : Limit F, True. 19 | Definition HasLimits := forall F : SpecializedFunctor D C, Limit F. 20 | 21 | Definition HasColimits' := forall F : SpecializedFunctor D C, exists _ : Colimit F, True. 22 | Definition HasColimits := forall F : SpecializedFunctor D C, Colimit F. 23 | 24 | Hypothesis HL : HasLimits. 25 | Hypothesis HC : HasColimits. 26 | 27 | Definition LimitFunctor : SpecializedFunctor (C ^ D) C 28 | := Eval unfold AdjointFunctorOfTerminalMorphism in AdjointFunctorOfTerminalMorphism HL. 29 | Definition ColimitFunctor : SpecializedFunctor (C ^ D) C 30 | := Eval unfold AdjointFunctorOfInitialMorphism in AdjointFunctorOfInitialMorphism HC. 31 | 32 | Definition LimitAdjunction : Adjunction (DiagonalFunctor C D) LimitFunctor 33 | := AdjunctionOfTerminalMorphism _. 34 | 35 | Definition ColimitAdjunction : Adjunction ColimitFunctor (DiagonalFunctor C D) 36 | := AdjunctionOfInitialMorphism _. 37 | End LimitFunctors. 38 | -------------------------------------------------------------------------------- /SetSchema.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Export Schema. 3 | Require Import Common. 4 | 5 | (* There is a category [Set], where the objects are sets and the morphisms are set morphisms *) 6 | Section SSet. 7 | Local Ltac t_set := 8 | unfold id in *; t_with t'; hnf; intros; simpl in *; etransitivity; eauto; 9 | repeat (apply functional_extensionality_dep; intro; simpl in *); t_with t'; 10 | match goal with 11 | | [ |- ?f ?x = ?g ?x ] => cut (f = g); 12 | assumption || 13 | solve [ let H := fresh in intro H; rewrite H; reflexivity ] 14 | end. 15 | 16 | Definition TypeSch : Schema. 17 | refine {| Vertex := Type; 18 | Edge := (fun s d => s -> d); 19 | PathsEquivalent := (fun _ _ p p' => compose _ (fun _ _ => id) p = compose _ (fun _ _ => id) p') 20 | |}; 21 | abstract t_set. 22 | Defined. 23 | 24 | Definition SetSch : Schema. 25 | refine {| Vertex := Set; 26 | Edge := (fun s d => s -> d); 27 | PathsEquivalent := (fun _ _ p p' => compose _ (fun _ _ => id) p = compose _ (fun _ _ => id) p') 28 | |}; 29 | abstract t_set. 30 | Defined. 31 | 32 | Definition PropSch : Schema. 33 | refine {| Vertex := Prop; 34 | Edge := (fun s d => s -> d); 35 | PathsEquivalent := (fun _ _ p p' => compose _ (fun _ _ => id) p = compose _ (fun _ _ => id) p') 36 | |}; 37 | abstract t_set. 38 | Defined. 39 | End SSet. 40 | -------------------------------------------------------------------------------- /IndiscreteCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section IndiscreteCategory. 13 | (** The indiscrete category has exactly one morphism between any two objects. *) 14 | Variable O : Type. 15 | 16 | Definition IndiscreteCategory : @SpecializedCategory O 17 | := @Build_SpecializedCategory O 18 | (fun _ _ => unit) 19 | (fun _ => tt) 20 | (fun _ _ _ _ _ => tt) 21 | (fun _ _ _ _ _ _ _ => eq_refl) 22 | (fun _ _ f => match f with tt => eq_refl end) 23 | (fun _ _ f => match f with tt => eq_refl end). 24 | End IndiscreteCategory. 25 | 26 | Section FunctorToIndiscrete. 27 | Variable O : Type. 28 | Context `(C : @SpecializedCategory objC). 29 | Variable objOf : objC -> O. 30 | 31 | Definition FunctorToIndiscrete : SpecializedFunctor C (IndiscreteCategory O) 32 | := Build_SpecializedFunctor C (IndiscreteCategory O) 33 | objOf 34 | (fun _ _ _ => tt) 35 | (fun _ _ _ _ _ => eq_refl) 36 | (fun _ => eq_refl). 37 | End FunctorToIndiscrete. 38 | -------------------------------------------------------------------------------- /BoolCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory. 2 | Require Import Bool. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Section BoolCat. 11 | Let obj := bool. 12 | Let mor s d := if (implb s d) then unit else Empty_set. 13 | 14 | Local Ltac t0 := unfold obj, mor in *; hnf in *; simpl in *; try subst obj mor. 15 | Local Ltac t1 := intros; 16 | repeat match goal with 17 | | [ |- unit ] => exact tt 18 | | [ H : Empty_set |- _ ] => destruct H 19 | | [ H : bool |- _ ] => destruct H; simpl in * 20 | end; trivial. 21 | Local Ltac t := t0; abstract t1. 22 | 23 | Definition BoolCat_Compose s d d' (m1 : mor d d') (m2 : mor s d) : mor s d'. 24 | t. 25 | Defined. 26 | 27 | Definition BoolCat_Identity x : mor x x := if x return mor x x then tt else tt. 28 | 29 | Global Arguments BoolCat_Compose [s d d'] m1 m2 : simpl never. 30 | Global Arguments BoolCat_Identity x : simpl never. 31 | 32 | Definition BoolCat : @SpecializedCategory bool. 33 | refine (@Build_SpecializedCategory _ 34 | mor 35 | BoolCat_Identity 36 | BoolCat_Compose 37 | _ 38 | _ 39 | _); 40 | t. 41 | Defined. 42 | End BoolCat. 43 | -------------------------------------------------------------------------------- /make-one-time-file.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | from __future__ import with_statement 3 | import os, sys, re 4 | from TimeFileMaker import * 5 | 6 | def make_table_string(times_dict, 7 | descending=True, 8 | tag="Time"): 9 | names = get_sorted_file_list_from_times_dict(times_dict, descending=descending) 10 | times_width = max(max(map(len, times_dict.values())), len(sum_times(times_dict.values()))) 11 | names_width = max(map(len, names + ["File Name", "Total"])) 12 | format_string = "%%-%ds | %%-%ds" % (times_width, names_width) 13 | header = format_string % (tag, "File Name") 14 | footer = format_string % (sum_times(times_dict.values()), 15 | "Total") 16 | sep = '-' * len(header) 17 | return '\n'.join([header, sep] + [format_string % (times_dict[name], 18 | name) 19 | for name in names] + 20 | [sep, footer]) 21 | 22 | if __name__ == '__main__': 23 | if len(sys.argv) < 2: 24 | print('Usage: %s FILE_NAME [OUTPUT_FILE_NAME]') 25 | sys.exit(1) 26 | else: 27 | times_dict = get_times(sys.argv[1]) 28 | table = make_table_string(times_dict) 29 | if len(sys.argv) == 2 or sys.argv[2] == '-': 30 | print(table) 31 | else: 32 | with open(sys.argv[2], 'w') as f: 33 | f.write(table) 34 | -------------------------------------------------------------------------------- /DiscreteCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Section DCategory. 11 | Variable O : Type. 12 | 13 | Local Ltac simpl_eq := subst_body; hnf in *; simpl in *; intros; destruct_type @inhabited; simpl in *; 14 | repeat constructor; 15 | repeat subst; 16 | auto; 17 | simpl_transitivity. 18 | 19 | Let DiscreteCategory_Morphism (s d : O) := s = d. 20 | 21 | Definition DiscreteCategory_Compose (s d d' : O) (m : DiscreteCategory_Morphism d d') (m' : DiscreteCategory_Morphism s d) : 22 | DiscreteCategory_Morphism s d'. 23 | simpl_eq. 24 | Defined. 25 | 26 | Definition DiscreteCategory_Identity o : DiscreteCategory_Morphism o o. 27 | simpl_eq. 28 | Defined. 29 | 30 | Global Arguments DiscreteCategory_Compose [s d d'] m m' /. 31 | Global Arguments DiscreteCategory_Identity o /. 32 | 33 | Definition DiscreteCategory : @SpecializedCategory O. 34 | refine (@Build_SpecializedCategory _ 35 | DiscreteCategory_Morphism 36 | DiscreteCategory_Identity 37 | DiscreteCategory_Compose 38 | _ 39 | _ 40 | _); 41 | abstract ( 42 | unfold DiscreteCategory_Compose, DiscreteCategory_Identity; 43 | simpl_eq 44 | ). 45 | Defined. 46 | End DCategory. 47 | -------------------------------------------------------------------------------- /SemiSimplicialSets.v: -------------------------------------------------------------------------------- 1 | Require Export SimplicialSets. 2 | Require Import Notations Subcategory SetCategory FunctorCategoryFunctorial. 3 | 4 | Generalizable Variables objC. 5 | 6 | Set Implicit Arguments. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Local Notation Δ := SimplexCategory. 13 | 14 | Section SemiSimplicialSets. 15 | (* Quoting David Spivak: 16 | 17 | Consider the subcategory of Δ with the same objects (wide) but 18 | only injective morphisms. If we call that Γ (which is 19 | nonstandard), then semi-simplicial sets (also a non-standard 20 | term) are Fun(Γᵒᵖ,Set). Define the obvious inclusion Γ -> Δ, 21 | which we will use to make simplicial sets without having to worry 22 | about "degneracies". *) 23 | 24 | Definition SemiSimplexCategory : SpecializedCategory nat. 25 | eapply (WideSubcategory Δ (@IsMonomorphism _ _)); 26 | abstract eauto with morphism. 27 | Defined. 28 | 29 | Local Notation Γ := SemiSimplexCategory. 30 | 31 | Definition SemiSimplexCategoryInclusionFunctor : SpecializedFunctor Γ Δ 32 | := WideSubcategoryInclusionFunctor _ _ _ _. 33 | 34 | Definition SemiSimplicialCategory `(C : SpecializedCategory objC) := (C ^ (OppositeCategory Γ))%category. 35 | 36 | Definition SemiSimplicialSet := SemiSimplicialCategory SetCat. 37 | Definition SemiSimplicialType := SemiSimplicialCategory TypeCat. 38 | Definition SemiSimplicialProp := SemiSimplicialCategory PropCat. 39 | End SemiSimplicialSets. 40 | 41 | Notation SemiSimplicialOf obj := (let C := CatOf obj in SemiSimplicialCategory C). 42 | -------------------------------------------------------------------------------- /PathsCategoryFunctors.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Export PathsCategory Functor SetCategory ComputableCategory SmallCat NaturalTransformation. 3 | Require Import Common Adjoint. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Section FunctorFromPaths. 14 | Variable V : Type. 15 | Variable E : V -> V -> Type. 16 | Context `(D : @SpecializedCategory objD). 17 | Variable objOf : V -> objD. 18 | Variable morOf : forall s d, E s d -> Morphism D (objOf s) (objOf d). 19 | 20 | Fixpoint path_compose s d (m : Morphism (PathsCategory E) s d) : Morphism D (objOf s) (objOf d) := 21 | match m with 22 | | NoEdges => Identity _ 23 | | AddEdge _ _ m' e => Compose (morOf e) (path_compose m') 24 | end. 25 | 26 | Lemma FunctorFromPaths_FCompositionOf s d d' (p1 : path E s d) (p2 : path E d d') : 27 | path_compose (concatenate p1 p2) = Compose (path_compose p2) (path_compose p1). 28 | Proof. 29 | induction p2; t_with t'; autorewrite with morphism; reflexivity. 30 | Qed. 31 | 32 | Definition FunctorFromPaths : SpecializedFunctor (PathsCategory E) D. 33 | Proof. 34 | refine {| 35 | ObjectOf := objOf; 36 | MorphismOf := path_compose; 37 | FCompositionOf := FunctorFromPaths_FCompositionOf 38 | |}; 39 | abstract intuition. 40 | Defined. 41 | End FunctorFromPaths. 42 | 43 | Section Underlying. 44 | Definition UnderlyingGraph `(C : @SpecializedCategory objC) := @PathsCategory objC (Morphism C). 45 | End Underlying. 46 | -------------------------------------------------------------------------------- /Instance.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality Setoid. 2 | Require Export Schema. 3 | Require Import Common Translation SetSchema. 4 | 5 | Set Implicit Arguments. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section Schema. 12 | Variable S : Schema. 13 | 14 | Record Instance := { 15 | TypeOf :> S -> Type; 16 | FunctionOf : forall s d (E : S.(Edge) s d), TypeOf s -> TypeOf d; 17 | EquivalenceOf : forall s d (p1 p2 : path S s d), S.(PathsEquivalent) p1 p2 18 | -> forall x, compose TypeOf FunctionOf p1 x = compose TypeOf FunctionOf p2 x 19 | }. 20 | 21 | Record ProgressiveUpdate (I J : Instance) := { 22 | PUComponentsOf :> forall c, I c -> J c; 23 | PUCommutes : forall s d (p : path S s d), 24 | forall x, PUComponentsOf d (compose I I.(FunctionOf) p x) 25 | = compose J J.(FunctionOf) p (PUComponentsOf s x) 26 | }. 27 | 28 | Variable I : Instance. 29 | 30 | Lemma compose_transferPath : forall s d (p : path S s d) x, 31 | compose I.(TypeOf) I.(FunctionOf) p x 32 | = compose (fun x => x) (fun _ _ e => e) (transferPath (I.(TypeOf) : S -> TypeSch) 33 | (fun _ _ e => AddEdge NoEdges (I.(FunctionOf) _ _ e)) p) x. 34 | induction p; simpl; intuition; f_equal; auto. 35 | Qed. 36 | 37 | Definition translationOf : Translation S TypeSch. 38 | refine (@Build_Translation S TypeSch 39 | I.(TypeOf) 40 | (fun _ _ e => AddEdge NoEdges (I.(FunctionOf) _ _ e)) 41 | _); 42 | abstract (intros; hnf; extensionality x; 43 | do 2 rewrite <- compose_transferPath; apply EquivalenceOf; assumption). 44 | Defined. 45 | 46 | End Schema. 47 | 48 | Coercion translationOf : Instance >-> Translation. 49 | -------------------------------------------------------------------------------- /SmallCat.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality JMeq ProofIrrelevance. 2 | Require Export Category CategoryIsomorphisms InitialTerminalCategory Functor ComputableCategory. 3 | Require Import Common FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section SmallCat. 12 | Definition SmallCat := ComputableCategory _ SUnderlyingCategory. 13 | Definition LocallySmallCat := ComputableCategory _ LSUnderlyingCategory. 14 | End SmallCat. 15 | 16 | Local Ltac destruct_simple_types := 17 | repeat match goal with 18 | | [ |- context[?T] ] => let T' := type of T in 19 | let T'' := fresh in 20 | match eval hnf in T' with 21 | | unit => set (T'' := T); destruct T'' 22 | | _ = _ => set (T'' := T); destruct T'' 23 | end 24 | end. 25 | 26 | Section Objects. 27 | Hint Unfold Morphism Object. 28 | 29 | Local Arguments Object / {obj} C : rename. 30 | Local Arguments Morphism / {obj} _ _ _ : rename. 31 | 32 | Hint Extern 1 => destruct_simple_types. 33 | Hint Extern 3 => destruct_to_empty_set. 34 | 35 | Lemma TerminalCategory_Terminal : IsTerminalObject (C := SmallCat) TerminalCategory. 36 | repeat intro; 37 | exists (FunctorToTerminal _). 38 | abstract ( 39 | repeat intro; functor_eq; eauto 40 | ). 41 | Defined. 42 | 43 | Lemma InitialCategory_Initial : IsInitialObject (C := SmallCat) InitialCategory. 44 | repeat intro; 45 | exists (FunctorFromInitial _). 46 | abstract ( 47 | repeat intro; functor_eq; eauto 48 | ). 49 | Qed. 50 | End Objects. 51 | -------------------------------------------------------------------------------- /TimeFileMaker.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | from __future__ import with_statement 3 | import os, sys, re 4 | 5 | def get_times(file_name): 6 | with open(file_name, 'r') as f: 7 | lines = f.readlines() 8 | lines = [i for i in 9 | [re.sub('"?coqc"?.*?\\s([^\\s]+)$', r'coqc \1', i.replace('\n', '').strip()) 10 | for i in lines] 11 | if i[:4] in ('coqc', 'real')] 12 | times_dict = {} 13 | for i in range(len(lines) - 1): 14 | if lines[i][:4] == 'coqc': 15 | if lines[i + 1][:4] == 'real': 16 | name = lines[i][4:].strip() 17 | time = lines[i + 1][4:].strip() 18 | minutes, seconds = time.split('m') 19 | if seconds[0].isdigit() and seconds[1] == '.': 20 | # we want,e.g., 0m05.111s, not 0m5.111s 21 | seconds = '0' + seconds 22 | time = '%sm%s' % (minutes, seconds) 23 | times_dict[name] = time 24 | return times_dict 25 | 26 | def get_sorted_file_list_from_times_dict(times_dict, descending=True): 27 | def get_key(name): 28 | minutes, seconds = times_dict[name].replace('s', '').split('m') 29 | return (int(minutes), float(seconds)) 30 | return sorted(times_dict.keys(), key=get_key, reverse=descending) 31 | 32 | def sum_times(times): 33 | def to_seconds(time): 34 | minutes, seconds = time.replace('s', '').split('m') 35 | return int(minutes) * 60 + float(seconds) 36 | seconds = sum(map(to_seconds, times)) 37 | minutes = int(seconds) / 60 38 | seconds -= minutes * 60 39 | full_seconds = int(seconds) 40 | partial_seconds = int(1000 * (seconds - full_seconds)) 41 | return '%dm%02d.%03ds' % (minutes, full_seconds, partial_seconds) 42 | -------------------------------------------------------------------------------- /ProductCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section ProductCategory. 13 | Context `(C : @SpecializedCategory objC). 14 | Context `(D : @SpecializedCategory objD). 15 | 16 | Definition ProductCategory : @SpecializedCategory (objC * objD)%type. 17 | refine (@Build_SpecializedCategory _ 18 | (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type) 19 | (fun o => (Identity (fst o), Identity (snd o))) 20 | (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))) 21 | _ 22 | _ 23 | _); 24 | abstract (intros; simpl_eq; auto with morphism). 25 | Defined. 26 | End ProductCategory. 27 | 28 | Infix "*" := ProductCategory : category_scope. 29 | 30 | Section ProductCategoryFunctors. 31 | Context `{C : @SpecializedCategory objC}. 32 | Context `{D : @SpecializedCategory objD}. 33 | 34 | Definition fst_Functor : SpecializedFunctor (C * D) C 35 | := Build_SpecializedFunctor (C * D) C 36 | (@fst _ _) 37 | (fun _ _ => @fst _ _) 38 | (fun _ _ _ _ _ => eq_refl) 39 | (fun _ => eq_refl). 40 | 41 | Definition snd_Functor : SpecializedFunctor (C * D) D 42 | := Build_SpecializedFunctor (C * D) D 43 | (@snd _ _) 44 | (fun _ _ => @snd _ _) 45 | (fun _ _ _ _ _ => eq_refl) 46 | (fun _ => eq_refl). 47 | End ProductCategoryFunctors. 48 | -------------------------------------------------------------------------------- /CommaCategoryFunctorProperties.v: -------------------------------------------------------------------------------- 1 | Require Import JMeq. 2 | Require Export CommaCategoryFunctors. 3 | Require Import Common Notations FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Open Scope category_scope. 14 | 15 | Local Ltac slice_t := 16 | repeat match goal with 17 | | [ |- @eq (SpecializedFunctor _ _) _ _ ] => apply Functor_eq; intros 18 | | [ |- @JMeq (sig _) _ (sig _) _ ] => apply sig_JMeq 19 | | [ |- (_ -> _) = (_ -> _) ] => apply f_type_equal 20 | | _ => progress (intros; simpl in *; trivial; subst_body) 21 | | _ => progress simpl_eq 22 | | _ => progress (repeat rewrite Associativity; repeat rewrite LeftIdentity; repeat rewrite RightIdentity) 23 | | _ => progress JMeq_eq 24 | | _ => apply f_equal 25 | | [ |- JMeq (?f ?x) (?f ?y) ] => 26 | apply (@f_equal1_JMeq _ _ x y f) 27 | | [ |- JMeq (?f ?x) (?g ?y) ] => 28 | apply (@f_equal_JMeq _ _ _ _ x y f g) 29 | | _ => 30 | progress ( 31 | destruct_type @CommaSpecializedCategory_Object; 32 | destruct_type @CommaSpecializedCategory_Morphism; 33 | destruct_sig 34 | ) 35 | end. 36 | 37 | Section FCompositionOf. 38 | Context `(A : @SpecializedCategory objA). 39 | Context `(B : @SpecializedCategory objB). 40 | Context `(C : @SpecializedCategory objC). 41 | 42 | Lemma CommaCategoryInducedFunctor_FCompositionOf s d d' 43 | (m1 : Morphism ((OppositeCategory (C ^ A)) * (C ^ B)) s d) 44 | (m2 : Morphism ((OppositeCategory (C ^ A)) * (C ^ B)) d d') : 45 | CommaCategoryInducedFunctor (Compose m2 m1) 46 | = ComposeFunctors (CommaCategoryInducedFunctor m2) (CommaCategoryInducedFunctor m1). 47 | Time slice_t. (* 44 s *) 48 | Qed. 49 | 50 | Lemma CommaCategoryInducedFunctor_FIdentityOf (x : (OppositeCategory (C ^ A)) * (C ^ B)) : 51 | CommaCategoryInducedFunctor (Identity x) 52 | = IdentityFunctor _. 53 | Time slice_t. (* 11 s *) 54 | Qed. 55 | End FCompositionOf. 56 | -------------------------------------------------------------------------------- /GroupCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Group. 2 | Require Import Notations ComputableCategory SetCategory. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Ltac destruct_first_if_not_second a b := 13 | (constr_eq a b; fail 1) || (let H := fresh in set (H := a : unit) in *; destruct H). 14 | 15 | Ltac destruct_singleton_constructor c := 16 | let t := type of c in 17 | repeat match goal with 18 | | [ H : t |- _ ] => destruct H 19 | | [ H : context[?e] |- _ ] => destruct_first_if_not_second e c 20 | | [ |- context[?e] ] => destruct_first_if_not_second e c 21 | end. 22 | 23 | Ltac destruct_units := destruct_singleton_constructor tt. 24 | Ltac destruct_Trues := destruct_singleton_constructor I. 25 | 26 | Section as_category. 27 | Definition CategoryOfGroup (G : Group) : SpecializedCategory unit. 28 | refine (@Build_SpecializedCategory unit 29 | (fun _ _ => G) 30 | (fun _ => @GroupIdentity G) 31 | (fun _ _ _ => @GroupOperation G) 32 | _ 33 | _ 34 | _); 35 | abstract (destruct G; intuition). 36 | Defined. 37 | End as_category. 38 | 39 | Coercion CategoryOfGroup : Group >-> SpecializedCategory. 40 | 41 | Section category_of_groups. 42 | Definition GroupCat : SpecializedCategory Group 43 | := Eval unfold ComputableCategory in ComputableCategory _ CategoryOfGroup. 44 | End category_of_groups. 45 | 46 | Section forgetful_functor. 47 | Definition GroupForgetfulFunctor : SpecializedFunctor GroupCat TypeCat. 48 | refine (Build_SpecializedFunctor GroupCat TypeCat 49 | GroupObjects 50 | (fun s d m => MorphismOf m (s := tt) (d := tt)) 51 | _ 52 | _); 53 | simpl; abstract (intros; destruct_units; reflexivity). 54 | Defined. 55 | End forgetful_functor. 56 | -------------------------------------------------------------------------------- /DecidableDiscreteCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Local Hint Extern 2 (_ = _) => simpl in *; tauto. 11 | 12 | Section DCategoryDec. 13 | Variable O : Type. 14 | 15 | Variable eq_dec : forall a b : O, {a = b} + {~a = b}. 16 | 17 | Local Infix "==" := eq_dec. 18 | Local Notation "x == y == z" := (orb (x == y) (y == z)). 19 | 20 | Local Ltac contradict_by_transitivity := 21 | match goal with 22 | | [ H : ~ _ |- _ ] => solve [ contradict H; etransitivity; eauto ] 23 | end. 24 | 25 | Let DiscreteCategoryDec_Morphism s d : Set := if s == d then unit else Empty_set. 26 | 27 | Local Ltac simpl_eq_dec := subst_body; simpl in *; intros; 28 | (* unfold eq_b in *;*) 29 | repeat match goal with 30 | | [ _ : context[eq_dec ?a ?b] |- _ ] => destruct (eq_dec a b); try contradict_by_transitivity 31 | | [ |- context[eq_dec ?a ?b] ] => destruct (eq_dec a b); try contradict_by_transitivity 32 | end; 33 | auto. 34 | 35 | Definition DiscreteCategoryDec_Compose (s d d' : O) (m : DiscreteCategoryDec_Morphism d d') (m' : DiscreteCategoryDec_Morphism s d) : 36 | DiscreteCategoryDec_Morphism s d'. 37 | simpl_eq_dec. 38 | Defined. 39 | 40 | Definition DiscreteCategoryDec_Identity o : DiscreteCategoryDec_Morphism o o. 41 | simpl_eq_dec. 42 | Defined. 43 | 44 | Definition DiscreteCategoryDec : @SpecializedCategory O. 45 | refine (@Build_SpecializedCategory _ 46 | DiscreteCategoryDec_Morphism 47 | DiscreteCategoryDec_Identity 48 | DiscreteCategoryDec_Compose 49 | _ 50 | _ 51 | _); 52 | abstract ( 53 | unfold DiscreteCategoryDec_Compose, DiscreteCategoryDec_Identity; 54 | simpl_eq_dec 55 | ). 56 | Defined. 57 | End DCategoryDec. 58 | 59 | Hint Unfold DiscreteCategoryDec_Compose DiscreteCategoryDec_Identity. 60 | -------------------------------------------------------------------------------- /SigTSigInducedFunctors.v: -------------------------------------------------------------------------------- 1 | Require Import ProofIrrelevance. 2 | Require Export SigTInducedFunctors SigTSigCategory. 3 | Require Import Common FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Section T2. 14 | (* use dummy variables so we don't have to specify the types of 15 | all these hypotheses *) 16 | Context `(dummy0 : @SpecializedCategory_sigT_sig objA A Pobj0 Pmor0 Pidentity0 Pcompose0). 17 | Context `(dummy1 : @SpecializedCategory_sigT_sig objA A Pobj1 Pmor1 Pidentity1 Pcompose1). 18 | 19 | Let sigT_sig_cat0 := @SpecializedCategory_sigT_sig objA A Pobj0 Pmor0 Pidentity0 Pcompose0. 20 | Let sigT_sig_cat1 := @SpecializedCategory_sigT_sig objA A Pobj1 Pmor1 Pidentity1 Pcompose1. 21 | 22 | Variable P_ObjectOf : forall x, Pobj0 x -> Pobj1 x. 23 | 24 | Let InducedT2Functor_sigT_sig_ObjectOf (x : sigT Pobj0) : sigT Pobj1 25 | := existT _ (projT1 x) (P_ObjectOf (projT2 x)). 26 | 27 | Hypothesis P_MorphismOf : forall (s d : sigT Pobj0) (m : sig (Pmor0 s d)), 28 | Pmor1 29 | (existT Pobj1 (projT1 s) (P_ObjectOf (projT2 s))) 30 | (existT Pobj1 (projT1 d) (P_ObjectOf (projT2 d))) 31 | (proj1_sig m). 32 | 33 | Let InducedT2Functor_sigT_sig_MorphismOf (s d : sigT Pobj0) (m : sig (Pmor0 s d)) : 34 | sig (Pmor1 (InducedT2Functor_sigT_sig_ObjectOf s) (InducedT2Functor_sigT_sig_ObjectOf d)) 35 | := exist _ (proj1_sig m) (@P_MorphismOf s d m). 36 | 37 | Let sig_of_sigT' (A : Type) (P : A -> Prop) (X : sigT P) := exist P (projT1 X) (projT2 X). 38 | Let sigT_of_sig' (A : Type) (P : A -> Prop) (X : sig P) := existT P (proj1_sig X) (proj2_sig X). 39 | 40 | Definition InducedT2Functor_sigT_sig : SpecializedFunctor sigT_sig_cat0 sigT_sig_cat1. 41 | eapply (ComposeFunctors (sigT_functor_sigT_sig _ _ _ _) (ComposeFunctors _ (sigT_sig_functor_sigT _ _ _ _))). 42 | Grab Existential Variables. 43 | eapply (@InducedT2Functor_sigT _ A Pobj0 Pmor0 Pidentity0 Pcompose0 _ _ _ Pobj1 Pmor1 Pidentity1 Pcompose1 _ _ _ 44 | P_ObjectOf (fun s d m => @P_MorphismOf s d (sig_of_sigT' m))); 45 | subst_body; 46 | abstract (simpl; intros; apply proof_irrelevance). 47 | Defined. 48 | End T2. 49 | -------------------------------------------------------------------------------- /make-both-time-files.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/python 2 | from __future__ import with_statement 3 | import os, sys, re 4 | from TimeFileMaker import * 5 | 6 | def make_table_string(left_times_dict, right_times_dict, 7 | descending=True, 8 | left_tag="After", right_tag="Before"): 9 | all_names_dict = dict() 10 | all_names_dict.update(right_times_dict) 11 | all_names_dict.update(left_times_dict) # do the left (after) last, so that we give precedence to those ones 12 | names = get_sorted_file_list_from_times_dict(all_names_dict, descending=descending) 13 | left_width = max(max(map(len, left_times_dict.values())), len(sum_times(left_times_dict.values()))) 14 | right_width = max(max(map(len, right_times_dict.values())), len(sum_times(right_times_dict.values()))) 15 | middle_width = max(map(len, names + ["File Name", "Total"])) 16 | format_string = "%%-%ds | %%-%ds | %%-%ds" % (left_width, middle_width, right_width) 17 | header = format_string % (left_tag, "File Name", right_tag) 18 | footer = format_string % (sum_times(left_times_dict.values()), 19 | "Total", 20 | sum_times(right_times_dict.values())) 21 | sep = '-' * len(header) 22 | left_rep, right_rep = ("%%-%ds" % left_width) % 0, ("%%-%ds" % right_width) % 0 23 | return '\n'.join([header, sep] + [format_string % (left_times_dict.get(name, 0), 24 | name, 25 | right_times_dict.get(name, 0)) 26 | for name in names] + 27 | [sep, footer]).replace(left_rep, 'N/A'.center(len(left_rep))).replace(right_rep, 'N/A'.center(len(right_rep))) 28 | 29 | if __name__ == '__main__': 30 | if len(sys.argv) < 3: 31 | print('Usage: %s LEFT_FILE_NAME RIGHT_FILE_NAME [OUTPUT_FILE_NAME]') 32 | sys.exit(1) 33 | else: 34 | left_dict = get_times(sys.argv[1]) 35 | right_dict = get_times(sys.argv[2]) 36 | table = make_table_string(left_dict, right_dict) 37 | if len(sys.argv) == 3 or sys.argv[3] == '-': 38 | print(table) 39 | else: 40 | with open(sys.argv[3], 'w') as f: 41 | f.write(table) 42 | -------------------------------------------------------------------------------- /FunctorProduct.v: -------------------------------------------------------------------------------- 1 | Require Export ProductCategory Functor NaturalTransformation. 2 | Require Import Common TypeclassUnreifiedSimplification. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section FunctorProduct. 13 | Context `(C : @SpecializedCategory objC). 14 | Context `(D : @SpecializedCategory objD). 15 | Context `(D' : @SpecializedCategory objD'). 16 | 17 | Definition FunctorProduct (F : Functor C D) (F' : Functor C D') : SpecializedFunctor C (D * D'). 18 | match goal with 19 | | [ |- SpecializedFunctor ?C0 ?D0 ] => 20 | refine (Build_SpecializedFunctor 21 | C0 D0 22 | (fun c => (F c, F' c)) 23 | (fun s d m => (MorphismOf F m, MorphismOf F' m)) 24 | _ 25 | _) 26 | end; 27 | abstract (intros; expand; apply f_equal2; rsimplify_morphisms; reflexivity). 28 | Defined. 29 | 30 | Definition FunctorProductFunctorial 31 | (F G : Functor C D) 32 | (F' G' : Functor C D') 33 | (T : SpecializedNaturalTransformation F G) 34 | (T' : SpecializedNaturalTransformation F' G') 35 | : SpecializedNaturalTransformation (FunctorProduct F F') (FunctorProduct G G'). 36 | match goal with 37 | | [ |- SpecializedNaturalTransformation ?F ?G ] => 38 | refine (Build_SpecializedNaturalTransformation F G 39 | (fun x => (T x, T' x)) 40 | _) 41 | end. 42 | abstract (simpl; intros; repeat rewrite Commutes; reflexivity). 43 | Defined. 44 | End FunctorProduct. 45 | 46 | Section FunctorProduct'. 47 | Context `(C : @SpecializedCategory objC). 48 | Context `(D : @SpecializedCategory objD). 49 | Context `(C' : @SpecializedCategory objC'). 50 | Context `(D' : @SpecializedCategory objD'). 51 | Variable F : Functor C D. 52 | Variable F' : Functor C' D'. 53 | 54 | Definition FunctorProduct' : SpecializedFunctor (C * C') (D * D') 55 | := FunctorProduct (ComposeFunctors F fst_Functor) (ComposeFunctors F' snd_Functor). 56 | End FunctorProduct'. 57 | 58 | (** XXX TODO(jgross): Change this to [FunctorProduct]. *) 59 | Infix "*" := FunctorProduct' : functor_scope. 60 | -------------------------------------------------------------------------------- /Theorems.v: -------------------------------------------------------------------------------- 1 | Require Import Program. 2 | Require Import Common Schema Category Instance Translation. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | Section Translation_Instance. 11 | Variables C D : Schema. 12 | Variable F : Translation C D. 13 | Variable I : Instance D. 14 | 15 | Lemma compose_prepend : forall s d (p : path D s d) s' (E : D.(Edge) s' s) x, 16 | compose I (FunctionOf I) (prepend p E) x 17 | = compose I (FunctionOf I) p (I.(FunctionOf) _ _ E x). 18 | induction p; t. 19 | Qed. 20 | 21 | Lemma compose_append : forall s d (p : path D s d) d' (E : D.(Edge) d d') x, 22 | compose I (FunctionOf I) (AddEdge p E) x 23 | = I.(FunctionOf) _ _ E (compose I (FunctionOf I) p x). 24 | induction p; t. 25 | Qed. 26 | 27 | Hint Rewrite compose_prepend. 28 | Hint Rewrite compose_append. 29 | Hint Rewrite concatenate_noedges_p. 30 | Hint Rewrite concatenate_p_noedges. 31 | 32 | Lemma compose_concatenate : forall s d (p : path D s d) d' (p' : path D d d') x, 33 | compose I (FunctionOf I) (concatenate p p') x 34 | = compose I (FunctionOf I) p' (compose I (FunctionOf I) p x). 35 | induction p'; t. 36 | Qed. 37 | 38 | Hint Rewrite compose_concatenate. 39 | 40 | Lemma compose_PathOf : forall s d (p : path C s d) x, 41 | compose I (FunctionOf I) (TransferPath F p) x 42 | = compose (fun x0 : C => I (F x0)) 43 | (fun s0 d0 (E : Edge C s0 d0) => 44 | compose I (FunctionOf I) (PathOf F _ _ E)) p x. 45 | induction p; t. 46 | Qed. 47 | 48 | Hint Rewrite <- compose_transferPath compose_PathOf. 49 | 50 | Hint Resolve EquivalenceOf TEquivalenceOf. 51 | 52 | Definition Translation_Instance : Instance C. 53 | refine {| TypeOf := (fun x => I (F x)); 54 | FunctionOf := (fun _ _ E => compose _ (I.(FunctionOf)) (F.(PathOf) _ _ E)) |}; 55 | abstract (t_with t'; auto). 56 | Defined. 57 | End Translation_Instance. 58 | 59 | Section Categories. 60 | Variable C : Category. 61 | 62 | Hint Resolve LeftIdentity RightIdentity. 63 | Hint Extern 1 => symmetry. 64 | 65 | Theorem identity_unique : forall a (id' : C.(Morphism) a a), 66 | (forall f : C.(Morphism) a a, Compose id' f = f) -> 67 | id' = Identity a. 68 | intros; transitivity (Compose id' (Identity a)); eauto. 69 | Qed. 70 | End Categories. 71 | -------------------------------------------------------------------------------- /CommaCategoryProjection.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCommaCategory ProductCategory. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Local Open Scope category_scope. 13 | 14 | Section CommaCategory. 15 | Context `(A : @SpecializedCategory objA). 16 | Context `(B : @SpecializedCategory objB). 17 | Context `(C : @SpecializedCategory objC). 18 | Variable S : SpecializedFunctor A C. 19 | Variable T : SpecializedFunctor B C. 20 | 21 | Definition CommaCategoryProjection : SpecializedFunctor (S ↓ T) (A * B) 22 | := Build_SpecializedFunctor (S ↓ T) (A * B) 23 | (@projT1 _ _) 24 | (fun _ _ m => proj1_sig m) 25 | (fun _ _ _ _ _ => eq_refl) 26 | (fun _ => eq_refl). 27 | End CommaCategory. 28 | 29 | Section SliceCategory. 30 | Context `(A : @SpecializedCategory objA). 31 | 32 | Local Arguments ComposeFunctors' / . 33 | 34 | Definition ArrowCategoryProjection : SpecializedFunctor (ArrowSpecializedCategory A) A 35 | := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection _ (IdentityFunctor A)). 36 | 37 | Definition SliceCategoryOverProjection (a : A) : SpecializedFunctor (A / a) A 38 | := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection (IdentityFunctor A) _). 39 | 40 | Definition CosliceCategoryOverProjection (a : A) : SpecializedFunctor (a \ A) A 41 | := ComposeFunctors' snd_Functor (CommaCategoryProjection _ (IdentityFunctor A)). 42 | 43 | Section Slice_Coslice. 44 | Context `(C : @SpecializedCategory objC). 45 | Variable a : C. 46 | Variable S : SpecializedFunctor A C. 47 | 48 | Section Slice. 49 | Definition SliceCategoryProjection : SpecializedFunctor (S ↓ a) A 50 | := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection S (FunctorFromTerminal C a)). 51 | End Slice. 52 | 53 | Section Coslice. 54 | Definition CosliceCategoryProjection : SpecializedFunctor (a ↓ S) A 55 | := Eval simpl in ComposeFunctors' snd_Functor (CommaCategoryProjection (FunctorFromTerminal C a) S). 56 | Check CosliceCategoryProjection. 57 | Eval simpl in SpecializedFunctor (a ↓ S) A. 58 | End Coslice. 59 | End Slice_Coslice. 60 | End SliceCategory. 61 | -------------------------------------------------------------------------------- /deplists.v: -------------------------------------------------------------------------------- 1 | Require Import List String. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | (* Largely copied from CPDT *) 10 | Section ilist. 11 | Variable A : Type. 12 | 13 | Inductive ilist : nat -> Type := 14 | | inil : ilist 0 15 | | icons : forall n, A -> ilist n -> ilist (S n). 16 | 17 | Inductive fin : nat -> Set := 18 | | First : forall n, fin (S n) 19 | | Next : forall n, fin n -> fin (S n). 20 | 21 | End ilist. 22 | 23 | Arguments inil [A]. 24 | Arguments First [n]. 25 | 26 | Local Infix "::" := (@icons _ _). 27 | 28 | Definition ihd' n (il : ilist Type n) : Type := 29 | match il with 30 | | inil => Set 31 | | icons _ T _ => T 32 | end. 33 | 34 | Definition ihd n (il : ilist Type (S n)) : Type := ihd' il. 35 | 36 | Definition itl' n (il : ilist Type n) := 37 | match il in ilist _ N return ilist Type (pred N) with 38 | | inil => inil 39 | | icons _ _ il' => il' 40 | end. 41 | 42 | Definition itl n (il : ilist Type (S n)) : ilist Type n := itl' il. 43 | 44 | Fixpoint iget n (i : fin n) : ilist Type n -> Type := 45 | match i with 46 | | First _ => fun il => ihd il 47 | | Next _ i' => fun il => iget i' (itl il) 48 | end. 49 | 50 | Section ilist_map. 51 | Variables A B : Type. 52 | Variable f : A -> B. 53 | 54 | Fixpoint imap n (ls : ilist A n) : ilist B n := 55 | match ls with 56 | | inil => inil 57 | | icons _ x ls' => icons (f x) (imap ls') 58 | end. 59 | End ilist_map. 60 | 61 | (* heterogeneous indexed lists *) 62 | Section hilist. 63 | Inductive hilist : forall n, ilist Type n -> Type := 64 | | hinil : hilist inil 65 | | hicons : forall n x (ls : ilist _ n), x -> hilist ls -> hilist (icons x ls). 66 | 67 | Definition hihd n (il : ilist Type (S n)) (hl : hilist il) : ihd il := 68 | match hl in hilist il return ihd' il with 69 | | hinil => unit 70 | | hicons _ _ _ v _ => v 71 | end. 72 | 73 | Definition hitl n (il : ilist Type (S n)) (hl : hilist il) : hilist (itl il) := 74 | match hl in hilist il return hilist (itl' il) with 75 | | hinil => hinil 76 | | hicons _ _ _ _ hl' => hl' 77 | end. 78 | 79 | Fixpoint higet n (i : fin n) : forall (ils : ilist Type n), hilist ils -> iget i ils := 80 | match i in fin n return forall (ils : ilist Type n), hilist ils -> iget i ils with 81 | | First _ => fun _ hl => hihd hl 82 | | Next _ i' => fun _ hl => higet i' (hitl hl) 83 | end. 84 | End hilist. 85 | -------------------------------------------------------------------------------- /Notations.v: -------------------------------------------------------------------------------- 1 | Reserved Notation "x == y" (at level 70, no associativity). 2 | Reserved Notation "x == y == z" (at level 70, no associativity, y at next level). 3 | 4 | Reserved Notation "x ~= y" (at level 70, no associativity). 5 | Reserved Notation "x ~= y ~= z" (at level 70, no associativity, y at next level). 6 | 7 | Reserved Notation "i ⁻¹" (at level 10). 8 | Reserved Notation "C ᵒᵖ" (at level 10). 9 | 10 | Reserved Notation "C ★^ M D" (at level 70, no associativity). 11 | Reserved Notation "C ★^{ M } D" (at level 70, no associativity). 12 | 13 | Reserved Notation "S ↓ T" (at level 70, no associativity). 14 | 15 | Reserved Notation "S ⇑ T" (at level 70, no associativity). 16 | Reserved Notation "S ⇓ T" (at level 70, no associativity). 17 | Reserved Notation "'CAT' ⇑ D" (at level 70, no associativity). 18 | Reserved Notation "'CAT' ⇓ D" (at level 70, no associativity). 19 | 20 | Reserved Notation "x ⊗ y" (at level 40, left associativity). 21 | Reserved Notation "x ⊗m y" (at level 40, left associativity). 22 | 23 | Reserved Notation "f ○ g" (at level 70, right associativity). 24 | 25 | Reserved Notation "x ~> y" (at level 99, right associativity, y at level 200). 26 | 27 | Reserved Notation "x ∏ y" (at level 40, left associativity). 28 | Reserved Notation "x ∐ y" (at level 50, left associativity). 29 | 30 | Reserved Notation "∏_{ x } f" (at level 0, x at level 99). 31 | Reserved Notation "∏_{ x : A } f" (at level 0, x at level 99). 32 | Reserved Notation "∐_{ x } f" (at level 0, x at level 99). 33 | Reserved Notation "∐_{ x : A } f" (at level 0, x at level 99). 34 | 35 | (* I'm not terribly happy with this notation, but '('s don't work 36 | because they interfere with things like [prod]s and grouping, 37 | and '['s interfere with list notation in Program. *) 38 | Reserved Notation "F ⟨ c , - ⟩" (at level 70, no associativity). 39 | Reserved Notation "F ⟨ - , d ⟩" (at level 70, no associativity). 40 | 41 | (* Forced by the notation in Program *) 42 | Reserved Notation "[ x ]" (at level 0, x at level 200). 43 | 44 | Reserved Notation "∫ F" (at level 0). 45 | 46 | Delimit Scope object_scope with object. 47 | Delimit Scope morphism_scope with morphism. 48 | Delimit Scope category_scope with category. 49 | Delimit Scope functor_scope with functor. 50 | Delimit Scope natural_transformation_scope with natural_transformation. 51 | 52 | Delimit Scope graph_scope with graph. 53 | Delimit Scope group_elements_scope with group. 54 | Delimit Scope groups_scope with groups. 55 | Delimit Scope vertex_scope with vertex. 56 | Delimit Scope edge_scope with edge. 57 | -------------------------------------------------------------------------------- /InitialTerminalCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor. 2 | Require Import Common Notations NatCategory. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section InitialTerminal. 13 | Definition InitialCategory : SmallSpecializedCategory _ := 0. 14 | Definition TerminalCategory : SmallSpecializedCategory _ := 1. 15 | End InitialTerminal. 16 | 17 | Section Functors. 18 | Context `(C : SpecializedCategory objC). 19 | 20 | Definition FunctorTo1 : SpecializedFunctor C 1 21 | := Build_SpecializedFunctor C 1 (fun _ => tt) (fun _ _ _ => eq_refl) (fun _ _ _ _ _ => eq_refl) (fun _ => eq_refl). 22 | Definition FunctorToTerminal : SpecializedFunctor C TerminalCategory := FunctorTo1. 23 | 24 | Definition FunctorFrom1 (c : C) : SpecializedFunctor 1 C 25 | := Build_SpecializedFunctor 1 C (fun _ => c) (fun _ _ _ => Identity c) (fun _ _ _ _ _ => eq_sym (@RightIdentity _ _ _ _ _)) (fun _ => eq_refl). 26 | Definition FunctorFromTerminal (c : C) : SpecializedFunctor TerminalCategory C := FunctorFrom1 c. 27 | 28 | Definition FunctorFrom0 : SpecializedFunctor 0 C 29 | := Build_SpecializedFunctor 0 C (fun x => match x with end) (fun x _ _ => match x with end) (fun x _ _ _ _ => match x with end) (fun x => match x with end). 30 | Definition FunctorFromInitial : SpecializedFunctor InitialCategory C := FunctorFrom0. 31 | End Functors. 32 | 33 | Section FunctorsUnique. 34 | Context `(C : @SpecializedCategory objC). 35 | 36 | Lemma InitialCategoryFunctorUnique 37 | : forall F F' : SpecializedFunctor InitialCategory C, 38 | F = F'. 39 | Proof. 40 | functor_eq; destruct_head_hnf @Empty_set. 41 | Qed. 42 | 43 | Lemma InitialCategoryFunctor'Unique 44 | : forall F F' : SpecializedFunctor C InitialCategory, 45 | F = F'. 46 | Proof. 47 | intros F F'. 48 | functor_eq; auto. 49 | match goal with 50 | | [ x : _ |- _ ] => solve [ let H := fresh in assert (H := F x); destruct H ] 51 | end. 52 | Qed. 53 | 54 | Lemma InitialCategoryInitial 55 | : forall F, F = FunctorFromInitial C. 56 | Proof. 57 | intros; apply InitialCategoryFunctorUnique. 58 | Qed. 59 | 60 | Lemma TerminalCategoryFunctorUnique 61 | : forall F F' : SpecializedFunctor C TerminalCategory, 62 | F = F'. 63 | Proof. 64 | functor_eq; auto. 65 | Qed. 66 | 67 | Lemma TerminalCategoryTerminal 68 | : forall F, F = FunctorToTerminal C. 69 | Proof. 70 | intros; apply TerminalCategoryFunctorUnique. 71 | Qed. 72 | End FunctorsUnique. 73 | -------------------------------------------------------------------------------- /SigTInducedFunctors.v: -------------------------------------------------------------------------------- 1 | Require Export SigTCategory Functor. 2 | Require Import Common FEqualDep. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section T2. 13 | (* use dummy variables so we don't have to specify the types of 14 | all these hypotheses *) 15 | Context `(dummy0 : @SpecializedCategory_sigT objA A Pobj0 Pmor0 Pidentity0 Pcompose0 P_Associativity0 P_LeftIdentity0 P_RightIdentity0). 16 | Context `(dummy1 : @SpecializedCategory_sigT objA A Pobj1 Pmor1 Pidentity1 Pcompose1 P_Associativity1 P_LeftIdentity1 P_RightIdentity1). 17 | 18 | Let sigT_cat0 := @SpecializedCategory_sigT objA A Pobj0 Pmor0 Pidentity0 Pcompose0 P_Associativity0 P_LeftIdentity0 P_RightIdentity0. 19 | Let sigT_cat1 := @SpecializedCategory_sigT objA A Pobj1 Pmor1 Pidentity1 Pcompose1 P_Associativity1 P_LeftIdentity1 P_RightIdentity1. 20 | 21 | Variable P_ObjectOf : forall x, Pobj0 x -> Pobj1 x. 22 | 23 | Let InducedT2Functor_sigT_ObjectOf (x : sigT Pobj0) : sigT Pobj1 24 | := existT _ (projT1 x) (P_ObjectOf (projT2 x)). 25 | 26 | Variable P_MorphismOf : forall (s d : sigT Pobj0) (m : sigT (Pmor0 s d)), 27 | Pmor1 28 | (existT Pobj1 (projT1 s) (P_ObjectOf (projT2 s))) 29 | (existT Pobj1 (projT1 d) (P_ObjectOf (projT2 d))) 30 | (projT1 m). 31 | 32 | Let InducedT2Functor_sigT_MorphismOf (s d : sigT Pobj0) (m : sigT (Pmor0 s d)) : sigT (Pmor1 (InducedT2Functor_sigT_ObjectOf s) (InducedT2Functor_sigT_ObjectOf d)) 33 | := existT _ (projT1 m) (@P_MorphismOf s d m). 34 | 35 | Hypothesis P_CompositionOf : forall s d d' (m1 : sigT (Pmor0 s d)) (m2 : sigT (Pmor0 d d')), 36 | P_MorphismOf (existT (Pmor0 s d') (Compose (projT1 m2) (projT1 m1)) (Pcompose0 (projT2 m2) (projT2 m1))) = 37 | Pcompose1 (P_MorphismOf m2) (P_MorphismOf m1). 38 | 39 | Hypothesis P_IdentityOf : forall o, 40 | P_MorphismOf (existT (Pmor0 o o) (Identity (projT1 o)) (Pidentity0 o)) = 41 | Pidentity1 (InducedT2Functor_sigT_ObjectOf o). 42 | 43 | Definition InducedT2Functor_sigT : SpecializedFunctor sigT_cat0 sigT_cat1. 44 | match goal with 45 | | [ |- SpecializedFunctor ?C ?D ] => 46 | refine (Build_SpecializedFunctor C D 47 | InducedT2Functor_sigT_ObjectOf 48 | InducedT2Functor_sigT_MorphismOf 49 | _ 50 | _ 51 | ) 52 | end; 53 | subst_body; 54 | abstract ( 55 | simpl in *; intros; unfold Morphism; simpl_eq; try reflexivity; JMeq_eq; 56 | apply @P_CompositionOf || apply @P_IdentityOf 57 | ). 58 | Defined. 59 | End T2. 60 | -------------------------------------------------------------------------------- /replace_imports.py: -------------------------------------------------------------------------------- 1 | from __future__ import with_statement 2 | import os 3 | 4 | file_contents = {} 5 | file_imports = {} 6 | 7 | def get_file(file_name): 8 | if file_name[-2:] != '.v': file_name += '.v' 9 | if file_name not in file_contents.keys(): 10 | print(file_name) 11 | try: 12 | with open(file_name, 'r', encoding='UTF-8') as f: 13 | file_contents[file_name] = f.read() 14 | except TypeError: 15 | with open(file_name, 'r') as f: 16 | file_contents[file_name] = f.read() 17 | return file_contents[file_name] 18 | 19 | def get_imports(file_name): 20 | if file_name[-2:] != '.v': file_name += '.v' 21 | if file_name not in file_imports.keys(): 22 | lines = get_file(file_name).split('\n') 23 | import_lines = [i.strip('. ') for i in lines if 24 | i.strip()[:len('Require ')] == 'Require ' or 25 | i.strip()[:len('Import ')] == 'Import '] 26 | imports = set((' ' + ' '.join(import_lines)).replace(' Require ', ' ').replace(' Import ', ' ').replace(' Export ', ' ').strip().split(' ')) 27 | file_imports[file_name] = tuple(sorted(imports)) 28 | return file_imports[file_name] 29 | 30 | def merge_imports(*imports): 31 | rtn = [] 32 | for import_list in imports: 33 | for i in import_list: 34 | if i not in rtn: 35 | rtn.append(i) 36 | return rtn 37 | 38 | def recursively_get_imports(file_name): 39 | if file_name[-2:] != '.v': file_name += '.v' 40 | if os.path.exists(file_name): 41 | imports = get_imports(file_name) 42 | imports_list = [recursively_get_imports(i) for i in imports] 43 | return merge_imports(*imports_list) + [file_name[:-2]] 44 | return [file_name[:-2]] 45 | 46 | def contents_without_imports(file_name): 47 | if file_name[-2:] != '.v': file_name += '.v' 48 | contents = get_file(file_name) 49 | lines = [i for i in contents.split('\n') if 50 | i.strip()[:len('Require ')] != 'Require ' and 51 | i.strip()[:len('Import ')] != 'Import '] 52 | return '\n'.join(lines) 53 | 54 | def include_imports(file_name): 55 | if file_name[-2:] != '.v': file_name += '.v' 56 | all_imports = recursively_get_imports(file_name) 57 | remaining_imports = [] 58 | rtn = '' 59 | for import_name in all_imports: 60 | if os.path.exists(import_name + '.v'): 61 | rtn += contents_without_imports(import_name) 62 | else: 63 | remaining_imports.append(import_name) 64 | rtn = 'Require Import %s.\n%s' % (' '.join(remaining_imports), rtn) 65 | return rtn 66 | -------------------------------------------------------------------------------- /ProductInducedFunctors.v: -------------------------------------------------------------------------------- 1 | Require Export ProductCategory Functor NaturalTransformation. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Local Ltac t := 13 | intros; simpl; repeat (rewrite <- FCompositionOf || rewrite <- FIdentityOf); 14 | apply f_equal; expand; autorewrite with morphism; 15 | reflexivity. 16 | 17 | Section ProductInducedFunctors. 18 | Context `(C : @SpecializedCategory objC). 19 | Context `(D : @SpecializedCategory objD). 20 | Context `(E : @SpecializedCategory objE). 21 | 22 | Variable F : SpecializedFunctor (C * D) E. 23 | 24 | Definition InducedProductFstFunctor (d : D) : SpecializedFunctor C E. 25 | refine {| ObjectOf := (fun c => F (c, d)); 26 | MorphismOf := (fun _ _ m => MorphismOf F (s := (_, d)) (d := (_, d)) (m, Identity d)) 27 | |}; 28 | abstract t. 29 | Defined. 30 | 31 | Definition InducedProductSndFunctor (c : C) : SpecializedFunctor D E. 32 | refine {| ObjectOf := (fun d => F (c, d)); 33 | MorphismOf := (fun _ _ m => MorphismOf F (s := (c, _)) (d := (c, _)) (Identity c, m)) 34 | |}; 35 | abstract t. 36 | Defined. 37 | End ProductInducedFunctors. 38 | 39 | Notation "F ⟨ c , - ⟩" := (InducedProductSndFunctor F c) : functor_scope. 40 | Notation "F ⟨ - , d ⟩" := (InducedProductFstFunctor F d) : functor_scope. 41 | 42 | Section ProductInducedNaturalTransformations. 43 | Context `(C : @SpecializedCategory objC). 44 | Context `(D : @SpecializedCategory objD). 45 | Context `(E : @SpecializedCategory objE). 46 | 47 | Variable F : SpecializedFunctor (C * D) E. 48 | 49 | Definition InducedProductFstNaturalTransformation {s d} (m : Morphism C s d) : SpecializedNaturalTransformation (F ⟨ s, - ⟩) (F ⟨ d, - ⟩). 50 | match goal with 51 | | [ |- SpecializedNaturalTransformation ?F0 ?G0 ] => 52 | refine (Build_SpecializedNaturalTransformation F0 G0 53 | (fun d => MorphismOf F (s := (_, d)) (d := (_, d)) (m, Identity (C := D) d)) 54 | _ 55 | ) 56 | end; 57 | abstract t. 58 | Defined. 59 | 60 | Definition InducedProductSndNaturalTransformation {s d} (m : Morphism D s d) : SpecializedNaturalTransformation (F ⟨ -, s ⟩) (F ⟨ - , d ⟩). 61 | match goal with 62 | | [ |- SpecializedNaturalTransformation ?F0 ?G0 ] => 63 | refine (Build_SpecializedNaturalTransformation F0 G0 64 | (fun c => MorphismOf F (s := (c, _)) (d := (c, _)) (Identity (C := C) c, m)) 65 | _ 66 | ) 67 | end; 68 | abstract t. 69 | Defined. 70 | End ProductInducedNaturalTransformations. 71 | 72 | Notation "F ⟨ f , - ⟩" := (InducedProductSndNaturalTransformation F f) : natural_transformation_scope. 73 | Notation "F ⟨ - , f ⟩" := (InducedProductFstNaturalTransformation F f) : natural_transformation_scope. 74 | -------------------------------------------------------------------------------- /ComputableSchemaCategory.v: -------------------------------------------------------------------------------- 1 | Require Import Setoid. 2 | Require Export Category Schema SmallSchema. 3 | Require Import Common SmallTranslation EquivalenceClass. 4 | 5 | Set Implicit Arguments. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section ComputableSchema. 12 | Variable O : Type. 13 | Variable Object2Sch : O -> SmallSchema. 14 | 15 | Local Coercion Object2Sch : O >-> SmallSchema. 16 | 17 | Hint Resolve LeftIdentitySmallTranslation RightIdentitySmallTranslation f_equal2 ComposeSmallTranslationsAssociativity. 18 | 19 | Hint Resolve PreComposeSmallTranslationsEquivalent PostComposeSmallTranslationsEquivalent. 20 | 21 | Hint Rewrite LeftIdentitySmallTranslation RightIdentitySmallTranslation. 22 | Hint Rewrite ComposeSmallTranslationsAssociativity. 23 | 24 | (* XXX TODO: Automate this better. *) 25 | Definition ComputableSchemaCategory : @SpecializedCategory O (fun s d : O => EquivalenceClass (@SmallTranslationsEquivalent s d)). 26 | refine (Build_SpecializedCategory (fun s d : O => EquivalenceClass (@SmallTranslationsEquivalent s d)) 27 | (fun o => @classOf _ _ (@SmallTranslationsEquivalent_rel _ _) 28 | (IdentitySmallTranslation o)) 29 | (fun (s d d' : O) F G => @apply2_to_class _ _ _ _ _ _ (@SmallTranslationsEquivalent_rel _ _) 30 | (@ComposeSmallTranslations s d d') (@ComposeSmallTranslations_mor s d d') F G) 31 | _ 32 | _ 33 | _ 34 | ); 35 | (* abstract ( *) 36 | t_with t'; apply EquivalenceClass_forall__eq; intros; split; intros; simpl in *; destruct_hypotheses; clear_InClass; unfold equiv in *; 37 | t_with t'; 38 | repeat match goal with 39 | | [ |- exists _, _ ] => exists (IdentitySmallTranslation _) 40 | | [ |- exists _, _ ] => eexists; eauto; clear_InClass; repeat split; clear_InClass; try reflexivity; eauto 41 | end; t_with t'; unfold equiv in *; try reflexivity; subst; simpl in *; t_with t'. 42 | repeat_subst_mor_of_type @SmallTranslation; autorewrite with core in *; eauto; try reflexivity; 43 | t_with t'. (* 44 | etransitivity. 45 | simpl in H2. 46 | Set Printing Coercions. 47 | subst. 48 | rewrite H6. 49 | pose ({| SVertexOf := x1; SPathOf := x3; STEquivalenceOf := x5 |}) as H10. 50 | move H10 at top. 51 | change_in_all ({| SVertexOf := x1; SPathOf := x3; STEquivalenceOf := x5 |}) with H10. 52 | repeat_subst_mor_of_type @SmallTranslation. 53 | rewrite H2. 54 | repeat_subst 55 | matc 56 | apply stranslations_equivalent; simpl. 57 | apply functional_extensionality_dep 58 | repeat_subst_mor_of_type @SmallTranslation; autorewrite with core in *; eauto; try reflexivity; 59 | clear_InClass; unfold equiv in *. 60 | ). *) 61 | Defined. 62 | End ComputableSchema. 63 | 64 | (*Definition Sch := @ComputableSchemaCategory Schema id.*) 65 | -------------------------------------------------------------------------------- /SumCategory.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section SumCategory. 13 | Context `(C : @SpecializedCategory objC). 14 | Context `(D : @SpecializedCategory objD). 15 | 16 | Definition SumCategory_Morphism (s d : objC + objD) : Type 17 | := match (s, d) with 18 | | (inl s, inl d) => C.(Morphism) s d 19 | | (inr s, inr d) => D.(Morphism) s d 20 | | _ => Empty_set 21 | end. 22 | 23 | Global Arguments SumCategory_Morphism _ _ /. 24 | 25 | Definition SumCategory_Identity (x : C + D) : SumCategory_Morphism x x 26 | := match x with 27 | | inl x => Identity x 28 | | inr x => Identity x 29 | end. 30 | 31 | Global Arguments SumCategory_Identity _ /. 32 | 33 | Definition SumCategory_Compose (s d d' : C + D) (m1 : SumCategory_Morphism d d') (m2 : SumCategory_Morphism s d) : SumCategory_Morphism s d'. 34 | (* XXX NOTE: try to use typeclasses and work up to existance of morphisms here *) 35 | case s, d, d'; simpl in *; try destruct_to_empty_set; 36 | eapply Compose; eassumption. 37 | Defined. 38 | 39 | Global Arguments SumCategory_Compose [_ _ _] _ _ /. 40 | 41 | Definition SumCategory : @SpecializedCategory (objC + objD)%type. 42 | refine (@Build_SpecializedCategory _ 43 | SumCategory_Morphism 44 | SumCategory_Identity 45 | SumCategory_Compose 46 | _ 47 | _ 48 | _); 49 | abstract ( 50 | repeat match goal with 51 | | [ H : Empty_set |- _ ] => case H 52 | | _ => let H := fresh in intro H; try (case H; clear H); simpl in * 53 | end; 54 | auto with morphism 55 | ). 56 | Defined. 57 | End SumCategory. 58 | 59 | Infix "+" := SumCategory : category_scope. 60 | 61 | Section SumCategoryFunctors. 62 | Context `(C : @SpecializedCategory objC). 63 | Context `(D : @SpecializedCategory objD). 64 | 65 | Definition inl_Functor : SpecializedFunctor C (C + D) 66 | := Build_SpecializedFunctor C (C + D) 67 | (@inl _ _) 68 | (fun _ _ m => m) 69 | (fun _ _ _ _ _ => eq_refl) 70 | (fun _ => eq_refl). 71 | 72 | Definition inr_Functor : SpecializedFunctor D (C + D) 73 | := Build_SpecializedFunctor D (C + D) 74 | (@inr _ _) 75 | (fun _ _ m => m) 76 | (fun _ _ _ _ _ => eq_refl) 77 | (fun _ => eq_refl). 78 | End SumCategoryFunctors. 79 | -------------------------------------------------------------------------------- /FunctorAttributes.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Export Functor. 3 | Require Import Common Hom Duals FunctorProduct NaturalTransformation SetCategory. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Open Scope category_scope. 14 | 15 | Section FullFaithful. 16 | Context `(C : @SpecializedCategory objC). 17 | Context `(C' : @LocallySmallSpecializedCategory objC'). 18 | Context `(D : @SpecializedCategory objD). 19 | Context `(D' : @LocallySmallSpecializedCategory objD'). 20 | Variable F : SpecializedFunctor C D. 21 | Variable F' : SpecializedFunctor C' D'. 22 | Let COp := OppositeCategory C. 23 | Let DOp := OppositeCategory D. 24 | Let FOp := OppositeFunctor F. 25 | Let C'Op := OppositeCategory C'. 26 | Let D'Op := OppositeCategory D'. 27 | Let F'Op := OppositeFunctor F'. 28 | 29 | Definition InducedHomNaturalTransformation : 30 | SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F)). 31 | refine (Build_SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F)) 32 | (fun sd : (COp * C) => 33 | MorphismOf F (s := _) (d := _)) 34 | _ 35 | ); 36 | abstract ( 37 | simpl; intros; 38 | destruct_type @prod; 39 | simpl in *; 40 | repeat (apply functional_extensionality_dep; intro); 41 | repeat rewrite FCompositionOf; reflexivity 42 | ). 43 | Defined. 44 | 45 | (* We really want surjective/injective here, but we only have epi/mono. 46 | They're equivalent in the category of sets. Are they equivalent in the 47 | category of [Type]s? *) 48 | Definition FunctorFull := forall x y : C, IsEpimorphism (InducedHomNaturalTransformation.(ComponentsOf) (x, y)). 49 | Definition FunctorFaithful := forall x y : C, IsMonomorphism (InducedHomNaturalTransformation.(ComponentsOf) (x, y)). 50 | 51 | Definition FunctorFullyFaithful := forall x y : C, IsIsomorphism (InducedHomNaturalTransformation.(ComponentsOf) (x, y)). 52 | 53 | Lemma FunctorFullyFaithful_split : FunctorFullyFaithful -> FunctorFull /\ FunctorFaithful. 54 | unfold FunctorFullyFaithful, FunctorFull, FunctorFaithful; intro H; split; intros; 55 | apply iso_is_epi || apply iso_is_mono; auto. 56 | Qed. 57 | 58 | (* 59 | (* Depends on injective + surjective -> isomorphism, and epi = surj, mono = inj *) 60 | Definition FunctorFullFaithful_and : FunctorFull /\ FunctorFaithful -> FunctorFullyFaithful. 61 | intro H; destruct H as [ e m ]. 62 | unfold FunctorFullyFaithful, FunctorFull, FunctorFaithful in *. 63 | intros x y; specialize (e x y); specialize (m x y). 64 | unfold IsEpimorphism, IsMonomorphism in *; simpl in *. 65 | unfold IsIsomorphism; simpl. 66 | eexists; 67 | split. 68 | destruct C, D, F; simpl in *; clear C D F. 69 | *) 70 | End FullFaithful. 71 | -------------------------------------------------------------------------------- /Equalizer.v: -------------------------------------------------------------------------------- 1 | Require Export Limits. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section Equalizer. 13 | Context `(C : @SpecializedCategory objC). 14 | Variables A B : objC. 15 | Variables f g : C.(Morphism) A B. 16 | 17 | Inductive EqualizerTwo := EqualizerA | EqualizerB. 18 | 19 | Definition EqualizerIndex_Morphism (a b : EqualizerTwo) : Set := 20 | match (a, b) with 21 | | (EqualizerA, EqualizerA) => unit 22 | | (EqualizerB, EqualizerB) => unit 23 | | (EqualizerB, EqualizerA) => Empty_set 24 | | (EqualizerA, EqualizerB) => EqualizerTwo 25 | end. 26 | 27 | Global Arguments EqualizerIndex_Morphism a b /. 28 | 29 | Definition EqualizerIndex_Compose s d d' (m1 : EqualizerIndex_Morphism d d') (m2 : EqualizerIndex_Morphism s d) : 30 | EqualizerIndex_Morphism s d'. 31 | destruct s, d, d'; simpl in *; trivial. 32 | Defined. 33 | 34 | Definition EqualizerIndex : @SpecializedCategory EqualizerTwo. 35 | refine (@Build_SpecializedCategory _ 36 | EqualizerIndex_Morphism 37 | (fun x => match x with EqualizerA => tt | EqualizerB => tt end) 38 | EqualizerIndex_Compose 39 | _ 40 | _ 41 | _); 42 | abstract ( 43 | intros; destruct_type EqualizerTwo; simpl in *; destruct_type Empty_set; trivial 44 | ). 45 | Defined. 46 | 47 | Definition EqualizerDiagram_ObjectOf x := 48 | match x with 49 | | EqualizerA => A 50 | | EqualizerB => B 51 | end. 52 | 53 | Global Arguments EqualizerDiagram_ObjectOf x /. 54 | 55 | Definition EqualizerDiagram_MorphismOf s d (m : Morphism EqualizerIndex s d) : 56 | Morphism C (EqualizerDiagram_ObjectOf s) (EqualizerDiagram_ObjectOf d). 57 | destruct s, d; simpl in *; try apply Identity; 58 | try solve [ destruct m ]; 59 | exact match m with 60 | | EqualizerA => f 61 | | EqualizerB => g 62 | end. 63 | Defined. 64 | 65 | Definition EqualizerDiagram : SpecializedFunctor EqualizerIndex C. 66 | match goal with 67 | | [ |- SpecializedFunctor ?C ?D ] => 68 | refine (Build_SpecializedFunctor C D 69 | EqualizerDiagram_ObjectOf 70 | EqualizerDiagram_MorphismOf 71 | _ 72 | _ 73 | ) 74 | end; 75 | abstract ( 76 | unfold EqualizerDiagram_MorphismOf; simpl; intros; 77 | destruct_type EqualizerTwo; 78 | repeat rewrite LeftIdentity; repeat rewrite RightIdentity; 79 | trivial; try destruct_to_empty_set 80 | ). 81 | Defined. 82 | 83 | Definition Equalizer := Limit EqualizerDiagram. 84 | Definition Coequalizer := Colimit EqualizerDiagram. 85 | End Equalizer. 86 | -------------------------------------------------------------------------------- /AdjointPointwise.v: -------------------------------------------------------------------------------- 1 | Require Export Adjoint. 2 | Require Import Notations Common FunctorCategoryFunctorial Duals TypeclassSimplification. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section AdjointPointwise. 13 | Context `(C : @SpecializedCategory objC). 14 | Context `(D : @SpecializedCategory objD). 15 | Context `(E : @SpecializedCategory objE). 16 | Context `(C' : @SpecializedCategory objC'). 17 | Context `(D' : @SpecializedCategory objD'). 18 | 19 | Variable F : SpecializedFunctor C D. 20 | Variable G : SpecializedFunctor D C. 21 | 22 | Variable A : Adjunction F G. 23 | Let A' : AdjunctionUnitCounit F G := A. 24 | 25 | Variables F' G' : SpecializedFunctor C' D'. 26 | 27 | (* Variable T' : SpecializedNaturalTransformation F' G'.*) 28 | 29 | Definition AdjointPointwise_NT_Unit : SpecializedNaturalTransformation (IdentityFunctor (C ^ E)) 30 | (ComposeFunctors (G ^ IdentityFunctor E) (F ^ IdentityFunctor E)). 31 | clearbody A'; clear A. 32 | pose proof (A' : AdjunctionUnit _ _) as A''. 33 | refine (NTComposeT _ (LiftIdentityPointwise _ _)). 34 | refine (NTComposeT _ (projT1 A'' ^ (IdentityNaturalTransformation (IdentityFunctor E)))). 35 | refine (NTComposeT (LiftComposeFunctorsPointwise _ _ (IdentityFunctor E) (IdentityFunctor E)) _). 36 | refine (LiftNaturalTransformationPointwise (IdentityNaturalTransformation _) _). 37 | exact (LeftIdentityFunctorNaturalTransformation2 _). 38 | Defined. 39 | 40 | Definition AdjointPointwise_NT_Counit : SpecializedNaturalTransformation (ComposeFunctors (F ^ IdentityFunctor E) (G ^ IdentityFunctor E)) 41 | (IdentityFunctor (D ^ E)). 42 | clearbody A'; clear A. 43 | pose proof (A' : AdjunctionCounit _ _) as A''. 44 | refine (NTComposeT (LiftIdentityPointwise_Inverse _ _) _). 45 | refine (NTComposeT (projT1 A'' ^ (IdentityNaturalTransformation (IdentityFunctor E))) _). 46 | refine (NTComposeT _ (LiftComposeFunctorsPointwise_Inverse _ _ (IdentityFunctor E) (IdentityFunctor E))). 47 | refine (LiftNaturalTransformationPointwise (IdentityNaturalTransformation _) _). 48 | exact (LeftIdentityFunctorNaturalTransformation1 _). 49 | Defined. 50 | 51 | Definition AdjointPointwise : Adjunction (F ^ (IdentityFunctor E)) (G ^ (IdentityFunctor E)). 52 | clearbody A'; clear A. 53 | match goal with 54 | | [ |- Adjunction ?F ?G ] => 55 | refine (_ : AdjunctionUnitCounit F G) 56 | end. 57 | exists AdjointPointwise_NT_Unit 58 | AdjointPointwise_NT_Counit; 59 | simpl; 60 | abstract ( 61 | destruct A'; 62 | simpl in *; 63 | nt_eq; 64 | rsimplify_morphisms; 65 | try match goal with 66 | | [ H : _ |- _ ] => apply H 67 | end 68 | ). 69 | Defined. 70 | End AdjointPointwise. 71 | -------------------------------------------------------------------------------- /Groupoid.v: -------------------------------------------------------------------------------- 1 | Require Import ProofIrrelevance. 2 | Require Export SpecializedCategory Functor. 3 | Require Import Common CategoryIsomorphisms. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Section GroupoidOf. 14 | Context `(C : @SpecializedCategory objC). 15 | 16 | Inductive GroupoidOf_Morphism (s d : objC) := 17 | | hasMorphism : C.(Morphism) s d -> GroupoidOf_Morphism s d 18 | | hasInverse : C.(Morphism) d s -> GroupoidOf_Morphism s d 19 | | byComposition : forall e, GroupoidOf_Morphism e d -> GroupoidOf_Morphism s e -> GroupoidOf_Morphism s d. 20 | 21 | Definition GroupoidOf_Compose (s d d' : C) : 22 | inhabited (GroupoidOf_Morphism d d') -> 23 | inhabited (GroupoidOf_Morphism s d) -> 24 | inhabited (GroupoidOf_Morphism s d'). 25 | intros; destruct_type @inhabited; constructor; eapply byComposition; eauto. 26 | Defined. 27 | 28 | (** Quoting Wikipedia: 29 | A groupoid is a small category in which every morphism is an isomorphism, and hence invertible. 30 | *) 31 | Definition GroupoidOf : @SpecializedCategory objC. 32 | refine (@Build_SpecializedCategory _ 33 | (fun s d => inhabited (GroupoidOf_Morphism s d)) 34 | (fun o : C => inhabits (hasMorphism _ _ (Identity o))) 35 | (@GroupoidOf_Compose) 36 | _ 37 | _ 38 | _); 39 | abstract (simpl; intros; apply proof_irrelevance). 40 | Defined. 41 | 42 | Definition CategoryIsGroupoid : Prop := 43 | forall s d : C, forall m : Morphism C s d, IsIsomorphism m. 44 | End GroupoidOf. 45 | 46 | Hint Constructors GroupoidOf_Morphism : category. 47 | 48 | Section Groupoid. 49 | Context `(C : @SpecializedCategory objC). 50 | 51 | Lemma GroupoidOf_Groupoid : CategoryIsGroupoid (GroupoidOf C). 52 | hnf; intros s d m; hnf; destruct m as [ m ]; induction m; 53 | repeat 54 | match goal with 55 | | [ H : exists _, _ |- _ ] => destruct H; destruct_type @inhabited 56 | | [ m : _ |- _ ] => exists m 57 | | [ m : _ |- _ ] => unique_pose (inhabits (hasMorphism C _ _ m)) 58 | | [ m : _ |- _ ] => unique_pose (inhabits (hasInverse C _ _ m)) 59 | | [ m : _, m' : _ |- _ ] => unique_pose (inhabits (byComposition C _ _ _ m m')) 60 | | [ m : _, m' : _ |- _ ] => unique_pose (Compose m m') 61 | | [ |- @eq ?T ?a ?b ] => progress let T' := eval hnf in T in change T with T' 62 | | [ |- _ = _ ] => apply proof_irrelevance 63 | | _ => progress (hnf; repeat split) 64 | end. 65 | Qed. 66 | 67 | Definition Groupoid_Functor : SpecializedFunctor C (GroupoidOf C). 68 | refine (Build_SpecializedFunctor C (GroupoidOf C) 69 | (fun c => c) 70 | (fun s d m => inhabits (hasMorphism C _ _ m)) 71 | _ 72 | _ 73 | ); 74 | abstract (simpl; intros; apply proof_irrelevance). 75 | Defined. 76 | End Groupoid. 77 | -------------------------------------------------------------------------------- /SubobjectClassifier.v: -------------------------------------------------------------------------------- 1 | Require Export Pullback Limits. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section subobject_classifier. 13 | (** Quoting Wikipedia: 14 | 15 | For the general definition, we start with a category [C] that has 16 | a terminal object, which we denote by [1]. The object [Ω] of [C] 17 | is a subobject classifier for [C] if there exists a morphism [m : 18 | 1 → Ω] with the following property: for each monomorphism [j : U → 19 | X] there is a unique morphism [χj : X → Ω] such that the following 20 | commutative diagram: 21 | 22 | [[ 23 | U ----> 1 24 | | | 25 | j | | m 26 | ↓ ↓ 27 | X ----> Ω 28 | χj 29 | ]] 30 | 31 | is a pullback diagram — that is, [U] is the limit of the diagram: 32 | 33 | [[ 34 | 1 35 | | 36 | | m 37 | ↓ 38 | X ----> Ω 39 | χj 40 | ]] 41 | 42 | The morphism [χj] is then called the classifying morphism for the 43 | subobject represented by [j]. 44 | *) 45 | 46 | (** Quoting nCatLab: 47 | 48 | Definition 1. In a category [C] with finite limits, a subobject 49 | classifier is a monomorphism [true : * → Ω] out of the terminal 50 | object, such that for every monomorphism [U → X] in [C] there is a unique 51 | morphism [χU : X → Ω] such that there is a pullback diagram 52 | 53 | [[ 54 | U ----> * 55 | | | 56 | | | true 57 | ↓ ↓ 58 | X ----> Ω 59 | χU 60 | ]] 61 | 62 | See for instance (MacLane-Moerdijk, p. 22). 63 | *) 64 | 65 | Context `(C : @SpecializedCategory objC). 66 | 67 | Local Reserved Notation "'Ω'". 68 | 69 | Record SubobjectClassifier := 70 | { 71 | SubobjectClassifierOne : TerminalObject C where "1" := (TerminalObject_Object SubobjectClassifierOne); 72 | ObjectOfTruthValues : C where "'Ω'" := ObjectOfTruthValues; 73 | TrueValue : C.(Morphism) 1 Ω; 74 | TrueIsMonomorphism : IsMonomorphism TrueValue; 75 | SubobjectClassifyingMap : forall U X (j : C.(Morphism) U X), 76 | IsMonomorphism j 77 | -> { χj : Morphism C X Ω & 78 | { H : Compose χj j = 79 | Compose TrueValue (TerminalObject_Morphism SubobjectClassifierOne U) 80 | & IsPullbackGivenMorphisms 81 | X 1 Ω 82 | χj TrueValue 83 | U j 84 | (TerminalObject_Morphism SubobjectClassifierOne U) 85 | H } } 86 | }. 87 | End subobject_classifier. 88 | -------------------------------------------------------------------------------- /AdjointComposition.v: -------------------------------------------------------------------------------- 1 | Require Export Adjoint. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section compose. 13 | Context `(C : SpecializedCategory objC). 14 | Context `(D : SpecializedCategory objD). 15 | Context `(E : SpecializedCategory objE). 16 | 17 | Variable F : SpecializedFunctor C D. 18 | Variable F' : SpecializedFunctor D E. 19 | Variable G : SpecializedFunctor D C. 20 | Variable G' : SpecializedFunctor E D. 21 | 22 | Variable A' : Adjunction F' G'. 23 | Variable A : Adjunction F G. 24 | 25 | Definition ComposeAdjunctionsUnitMorphism 26 | : NaturalTransformation (IdentityFunctor C) 27 | (ComposeFunctors (ComposeFunctors G G') (ComposeFunctors F' F)). 28 | pose (projT1 (A : AdjunctionUnit _ _)) as η. 29 | pose (projT1 (A' : AdjunctionUnit _ _)) as η'. 30 | refine (NTComposeT _ (* associator *) 31 | (NTComposeT (NTComposeF (IdentityNaturalTransformation G) (NTComposeF η' (IdentityNaturalTransformation F))) 32 | (NTComposeT _ (* identity *) 33 | η))); 34 | nt_solve_associator. 35 | match goal with 36 | | [ |- SpecializedNaturalTransformation ?F ?G ] => 37 | refine (Build_SpecializedNaturalTransformation F G 38 | (fun _ => Identity _) 39 | _) 40 | end. 41 | simpl; 42 | abstract ( 43 | intros; 44 | autorewrite with morphism; 45 | reflexivity 46 | ). 47 | Defined. 48 | 49 | (* TODO(jgross): speed this up, automate it more *) 50 | Definition ComposeAdjunctions : Adjunction (ComposeFunctors F' F) (ComposeFunctors G G'). 51 | refine (_ : AdjunctionUnit (ComposeFunctors F' F) (ComposeFunctors G G')). 52 | exists ComposeAdjunctionsUnitMorphism. 53 | pose (projT2 (A : AdjunctionUnit _ _)) as Hη. 54 | pose (projT2 (A' : AdjunctionUnit _ _)) as Hη'. 55 | intros c d f. 56 | exists (proj1_sig (Hη' _ _ (proj1_sig (Hη _ _ f)))). 57 | abstract ( 58 | subst_body; intro_proj2_sig_from_goal; 59 | hnf in *; split_and; split; 60 | simpl in *; 61 | autorewrite with category; 62 | [ try_associativity ltac:(progress repeat rewrite <- FCompositionOf); 63 | simpl in *; 64 | repeat match goal with 65 | | [ H : _ |- _ ] => apply f_equal; solve [ trivial ] 66 | | [ H : _ |- _ ] => symmetry; rewrite <- H at 1; apply f_equal2; try reflexivity; []; symmetry 67 | end 68 | | intros x' H; 69 | repeat match goal with 70 | | [ H : _ |- _ ] => apply H 71 | | [ H : _ |- _ ] => symmetry; apply H 72 | end; 73 | rewrite <- H; 74 | try_associativity ltac:(progress repeat rewrite FCompositionOf); 75 | autorewrite with morphism; 76 | reflexivity ] 77 | ). 78 | Defined. 79 | End compose. 80 | -------------------------------------------------------------------------------- /TypeclassSimplification.v: -------------------------------------------------------------------------------- 1 | Require Export LtacReifiedSimplification. 2 | Require Import SpecializedCategory Functor NaturalTransformation. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section SimplifiedMorphism. 13 | Section single_category. 14 | Context `{C : SpecializedCategory objC}. 15 | 16 | Class SimplifiedMorphism {s d} (m : Morphism C s d) := 17 | SimplifyMorphism { reified_morphism : ReifiedMorphism C s d; 18 | reified_morphism_ok : m = ReifiedMorphismDenote reified_morphism }. 19 | 20 | Lemma SimplifyReifiyMorphismOk `(@SimplifiedMorphism s d m) 21 | : m 22 | = ReifiedMorphismDenote (ReifiedMorphismSimplify (reified_morphism (m := m))). 23 | rewrite <- ReifiedMorphismSimplifyOk. 24 | rewrite <- reified_morphism_ok. 25 | reflexivity. 26 | Qed. 27 | 28 | Global Instance unchanged_morphism s d (m : Morphism C s d) : SimplifiedMorphism m | 1000 29 | := SimplifyMorphism (m := m) (ReifiedGenericMorphism C s d m) eq_refl. 30 | 31 | Global Instance identity_morphism x : SimplifiedMorphism (Identity x) | 10 32 | := SimplifyMorphism (m := Identity x) (ReifiedIdentityMorphism C x) eq_refl. 33 | 34 | Global Instance composition_morphism s d d' 35 | `(@SimplifiedMorphism d d' m1) `(@SimplifiedMorphism s d m2) 36 | : SimplifiedMorphism (Compose m1 m2) | 10 37 | := SimplifyMorphism (m := Compose m1 m2) 38 | (ReifiedComposedMorphism (reified_morphism (m := m1)) 39 | (reified_morphism (m := m2))) 40 | (f_equal2 _ 41 | reified_morphism_ok 42 | reified_morphism_ok). 43 | End single_category. 44 | 45 | Section functor. 46 | Context `{C : SpecializedCategory objC}. 47 | Context `{D : SpecializedCategory objD}. 48 | Variable F : SpecializedFunctor C D. 49 | 50 | Global Instance functor_morphism `(@SimplifiedMorphism objC C s d m) 51 | : SimplifiedMorphism (MorphismOf F m) | 50 52 | := SimplifyMorphism (m := MorphismOf F m) 53 | (ReifiedFunctorMorphism F (reified_morphism (m := m))) 54 | (f_equal _ reified_morphism_ok). 55 | End functor. 56 | 57 | Section natural_transformation. 58 | Context `{C : SpecializedCategory objC}. 59 | Context `{D : SpecializedCategory objD}. 60 | Variables F G : SpecializedFunctor C D. 61 | Variable T : SpecializedNaturalTransformation F G. 62 | 63 | Global Instance nt_morphism x 64 | : SimplifiedMorphism (T x) | 50 65 | := SimplifyMorphism (m := T x) (ReifiedNaturalTransformationMorphism T x) eq_refl. 66 | End natural_transformation. 67 | End SimplifiedMorphism. 68 | 69 | Ltac rsimplify_morphisms := 70 | match goal with 71 | | [ |- @eq (Morphism _ _ _) ?A ?B ] => 72 | erewrite (SimplifyReifiyMorphismOk (m := A)); 73 | erewrite (SimplifyReifiyMorphismOk (m := B)) 74 | | _ => erewrite SimplifyReifiyMorphismOk 75 | end; 76 | simpl. 77 | -------------------------------------------------------------------------------- /SigTSigCategory.v: -------------------------------------------------------------------------------- 1 | Require Import JMeq ProofIrrelevance. 2 | Require Export SpecializedCategory Functor SigTCategory. 3 | Require Import Common Notations FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Infix "==" := JMeq. 14 | 15 | Section sigT_sig_obj_mor. 16 | Context `(A : @SpecializedCategory objA). 17 | Variable Pobj : objA -> Type. 18 | Variable Pmor : forall s d : sigT Pobj, A.(Morphism) (projT1 s) (projT1 d) -> Prop. 19 | 20 | Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _). 21 | Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2). 22 | 23 | Definition SpecializedCategory_sigT_sig : @SpecializedCategory (sigT Pobj). 24 | match goal with 25 | | [ |- @SpecializedCategory ?obj ] => 26 | refine (@Build_SpecializedCategory obj 27 | (fun s d => sig (@Pmor s d)) 28 | (fun x => existT _ (Identity (C := A) (projT1 x)) (Pidentity x)) 29 | (fun s d d' m1 m2 => existT _ (Compose (C := A) (proj1_sig m1) (proj1_sig m2)) (Pcompose (proj2_sig m1) (proj2_sig m2))) 30 | _ 31 | _ 32 | _ 33 | ) 34 | end; 35 | abstract (intros; simpl_eq; auto with category). 36 | Defined. 37 | 38 | Let SpecializedCategory_sigT_sig_as_sigT : @SpecializedCategory (sigT Pobj). 39 | apply (@SpecializedCategory_sigT _ A _ _ Pidentity Pcompose); 40 | abstract ( 41 | simpl; intros; 42 | match goal with 43 | | [ |- @JMeq ?Ta ?a ?Tb ?b ] => cut (@eq Prop Ta Tb); [ 44 | generalize Ta Tb a b || generalize Tb Ta b a; intros; repeat subst; JMeq_eq; try apply proof_irrelevance 45 | | ] 46 | end; 47 | rewrite Associativity || rewrite LeftIdentity || rewrite RightIdentity; 48 | reflexivity 49 | ). 50 | Defined. 51 | 52 | Definition sigT_sig_functor_sigT : SpecializedFunctor SpecializedCategory_sigT_sig SpecializedCategory_sigT_sig_as_sigT. 53 | refine (Build_SpecializedFunctor SpecializedCategory_sigT_sig SpecializedCategory_sigT_sig_as_sigT 54 | (fun x => x) 55 | (fun s d m => m) 56 | _ 57 | _ 58 | ); 59 | abstract (intros; simpl; destruct_sig; reflexivity). 60 | Defined. 61 | 62 | Definition sigT_functor_sigT_sig : SpecializedFunctor SpecializedCategory_sigT_sig_as_sigT SpecializedCategory_sigT_sig. 63 | refine (Build_SpecializedFunctor SpecializedCategory_sigT_sig_as_sigT SpecializedCategory_sigT_sig 64 | (fun x => x) 65 | (fun s d m => m) 66 | _ 67 | _ 68 | ); 69 | abstract (intros; simpl; destruct_sig; reflexivity). 70 | Defined. 71 | 72 | Lemma sigT_sig_sigT_compat : 73 | ComposeFunctors sigT_sig_functor_sigT sigT_functor_sigT_sig = IdentityFunctor _ /\ 74 | ComposeFunctors sigT_functor_sigT_sig sigT_sig_functor_sigT = IdentityFunctor _. 75 | split; functor_eq; destruct_sig; reflexivity. 76 | Qed. 77 | 78 | Definition proj1_functor_sigT_sig : SpecializedFunctor SpecializedCategory_sigT_sig A 79 | := ComposeFunctors projT1_functor sigT_sig_functor_sigT. 80 | End sigT_sig_obj_mor. 81 | -------------------------------------------------------------------------------- /DatabaseConstraints.v: -------------------------------------------------------------------------------- 1 | Require Import List Setoid Classes.RelationClasses. 2 | Require Export Database. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | (** * Constraints *) 11 | Section keys. 12 | (** A [KeyConstraint] is an assertion that some column in some table 13 | is a key. Morally, this amounts to requiring that [forall x y : 14 | row in table, x.key_col = y.key_col -> x = y]. *) 15 | 16 | Inductive KeyConstraint (R : RowType) T (c : Column T R) : Prop := ColumnIsKey. 17 | 18 | Definition KeyConstraintDenote (R : RowType) T (c : Column T R) (KC : KeyConstraint c) (Tbl : Table R) : Prop 19 | := forall x y, In x Tbl -> In y Tbl -> getColumn c x = getColumn c y -> x = y. 20 | 21 | (** A [ForeignKeyConstraint] is an assertion that some column in 22 | some table points to some column in some other table. We 23 | require that foreign key columns point only to columns which are 24 | keys. Morally, this amounts to requiring that [forall x : row 25 | in table 1, exists y : row in table 2, x.fk_source = 26 | y.fk_destination]. *) 27 | 28 | Inductive ForeignKeyConstraint 29 | (R_src R_dst : RowType) T (c_src : Column T R_src) (c_dst : Column T R_dst) 30 | (destination_is_key : KeyConstraint c_dst) : Prop 31 | := ColumnsAreForeignKeys. 32 | 33 | Definition ForeignKeyConstraintDenote R_src R_dst T c_src c_dst destination_is_key 34 | (FKC : @ForeignKeyConstraint R_src R_dst T c_src c_dst destination_is_key) 35 | (Tbl_src : Table R_src) (Tbl_dst : Table R_dst) 36 | : Prop 37 | := KeyConstraintDenote destination_is_key Tbl_dst 38 | /\ forall x, 39 | In x Tbl_src 40 | -> exists y, 41 | In y Tbl_dst 42 | /\ getColumn c_src x = getColumn c_dst y. 43 | 44 | Inductive DatabaseTypeConstraintList (D : DatabaseType) : Type := 45 | | DTCNil : DatabaseTypeConstraintList D 46 | | KeyConstraintCons : forall (R : RowType) T (c : Column T R) (TN : TableName R D), 47 | @KeyConstraint R T c 48 | -> DatabaseTypeConstraintList D 49 | -> DatabaseTypeConstraintList D 50 | | ForeignKeyConstraintCons : forall (R_src R_dst : RowType) T (c_src : Column T R_src) (c_dst : Column T R_dst) 51 | (destination_is_key : KeyConstraint c_dst) 52 | (TN_src : TableName R_src D) (TN_dst : TableName R_dst D), 53 | @ForeignKeyConstraint R_src R_dst T c_src c_dst destination_is_key 54 | -> DatabaseTypeConstraintList D 55 | -> DatabaseTypeConstraintList D. 56 | 57 | Fixpoint DatabaseTypeConstraintListDenote DT (D : DatabaseInstance DT) (l : DatabaseTypeConstraintList DT) 58 | : Prop 59 | := match l with 60 | | DTCNil => True 61 | | KeyConstraintCons R T c TN KC xs 62 | => DatabaseTypeConstraintListDenote D xs 63 | /\ KeyConstraintDenote KC (getTable TN D) 64 | | ForeignKeyConstraintCons R_src R_dst T c_src c_dst destination_is_key TN_src TN_dst FKC xs 65 | => DatabaseTypeConstraintListDenote D xs 66 | /\ ForeignKeyConstraintDenote FKC (getTable TN_src D) (getTable TN_dst D) 67 | end. 68 | End keys. 69 | -------------------------------------------------------------------------------- /Category.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory. 2 | Require Import Common. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Record > Category := { 13 | CObject : Type; 14 | 15 | UnderlyingCategory :> @SpecializedCategory CObject 16 | }. 17 | 18 | Record > SmallCategory := { 19 | SObject : Set; 20 | 21 | SUnderlyingCategory :> @SmallSpecializedCategory SObject 22 | }. 23 | 24 | Record > LocallySmallCategory := { 25 | LSObject : Type; 26 | 27 | LSUnderlyingCategory :> @LocallySmallSpecializedCategory LSObject 28 | }. 29 | 30 | Bind Scope category_scope with Category. 31 | Bind Scope category_scope with SmallCategory. 32 | Bind Scope category_scope with LocallySmallCategory. 33 | 34 | 35 | 36 | (** * The saturation prover: up to some bound on number of steps, consider all ways to extend equivalences with pre- or post-composition. *) 37 | 38 | (** The main tactic, which tries a single round of making deductions from hypotheses that exist at the start of the round. 39 | Only variables in the goal are chosen to compose. *) 40 | 41 | Ltac saturate := repeat match goal with 42 | | [ H : @eq (Morphism _ _ _) ?M ?N |- _ ] => 43 | let tryIt G := 44 | match goal with 45 | | [ _ : G |- _ ] => fail 1 46 | | [ |- context[G] ] => fail 1 47 | | _ => let H' := fresh "H" in assert (H' : G) by eauto; generalize dependent H' 48 | end in 49 | repeat match goal with 50 | | [ m : Morphism _ _ _ |- _ ] => 51 | tryIt (Compose M m = Compose N m) 52 | | [ m : Morphism _ _ _ |- _ ] => 53 | tryIt (Compose m M = Compose m N) 54 | end; generalize dependent H 55 | end; intros; autorewrite with core in *. 56 | 57 | (** To be sure that all relevant terms are represented as variables, we use this tactic to create variables for 58 | all non-[Compose] subterms of a morphism expression. *) 59 | 60 | Ltac extractMorphisms G := 61 | match G with 62 | | Compose ?G1 ?G2 => 63 | extractMorphisms G1; 64 | extractMorphisms G2 65 | | _ => 66 | match goal with 67 | | [ x := G |- _ ] => idtac 68 | | [ x : _ |- _ ] => 69 | match x with 70 | | G => idtac 71 | end 72 | | _ => pose G 73 | end 74 | end. 75 | 76 | (** This tactic calls the above on two morphisms being compared for equivalence in the goal. *) 77 | 78 | Ltac createVariables := 79 | match goal with 80 | | [ |- @eq (Morphism _ _ _) ?X ?Y ] => 81 | extractMorphisms X; 82 | extractMorphisms Y 83 | end. 84 | 85 | (** After we are done with our variable-related hijinks, we can clean up by removing the new variables, 86 | replacing them by their definitions. *) 87 | 88 | Ltac removeVariables := 89 | repeat match goal with 90 | | [ x := _ |- _ ] => subst x 91 | end. 92 | 93 | (** This notation ties it all together, taking as argument the number of [saturate] rounds to run. *) 94 | 95 | Tactic Notation "morphisms" integer(numSaturations) := 96 | t; createVariables; do numSaturations saturate; removeVariables; eauto 3. 97 | -------------------------------------------------------------------------------- /Coend.v: -------------------------------------------------------------------------------- 1 | Require Export Equalizer Duals FunctorProduct DiscreteCategoryFunctors Products. 2 | Require Import Common Notations LimitFunctorTheorems. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Local Ltac t := simpl in *; subst_body; 13 | repeat (let H := fresh in intro H; hnf in H); subst; 14 | simpl in *; 15 | repeat rewrite LeftIdentity; repeat rewrite RightIdentity; 16 | try reflexivity. 17 | 18 | Section Coend. 19 | (* Quoting David Spivak: 20 | Given [F : COp * C -> D], the coend of [F] is an object [∫ F] of 21 | [D]; it is the coequalizer of the diagram 22 | [[ 23 | dom 24 | Mor C ---> Ob C 25 | \ F(f, 1) / 26 | (f : c₀ → c₁) \ ==> / c ↦ F(c, c) 27 | ↦ F(c₁, c₀) ↘ ↙ 28 | D 29 | ∐ F(c₁, c₀) --------------> ∐ F(c, c) 30 | (c₀, c₁, f) --------------> c ∈ Ob C 31 | f : c₀ → c₁ cod 32 | Mor C ---> Ob C 33 | \ F(1, f) / 34 | (f : c₀ → c₁) \ ==> / c ↦ F(c, c) 35 | ↦ F(c₀, c₁) ↘ ↙ 36 | D 37 | ]] 38 | where the triangles denote induced colimit morphisms. 39 | *) 40 | Context `(C : @SpecializedCategory objC). 41 | Context `(D : @SpecializedCategory objD). 42 | 43 | Let COp := OppositeCategory C. 44 | 45 | Variable F : SpecializedFunctor (COp * C) D. 46 | 47 | Let MorC := @MorphismFunctor _ _ (fun _ : unit => C) tt. (* [((c0, c1) & f : morC c0 c1)], the set of morphisms of C *) 48 | 49 | Variable Fmor : ∐_{ c0c1f : MorC } (F (snd (projT1 c0c1f), fst (projT1 c0c1f)) : D). 50 | Variable Fob : ∐_{ c } (F (c, c) : D). 51 | 52 | (* There is a morphism in D from [Fmor] to [Fob] which takes the domain of the relevant morphism. *) 53 | Definition Coend_Fdom : Morphism D (ColimitObject Fmor) (ColimitObject Fob). 54 | apply (InducedColimitMap (G := InducedDiscreteFunctor _ (DomainNaturalTransformation _ (fun _ => C) tt))). 55 | hnf; simpl. 56 | match goal with 57 | | [ |- SpecializedNaturalTransformation ?F0 ?G0 ] => 58 | refine (Build_SpecializedNaturalTransformation F0 G0 59 | (fun sdf => let s := fst (projT1 sdf) in MorphismOf F (s := (_, s)) (d := (_, s)) (projT2 sdf, Identity (C := C) s)) 60 | _ 61 | ) 62 | end; 63 | abstract t. 64 | Defined. 65 | 66 | (* There is a morphism in D from [Fmor] to [Fob] which takes the codomain of the relevant morphism. *) 67 | Definition Coend_Fcod : Morphism D (ColimitObject Fmor) (ColimitObject Fob). 68 | apply (InducedColimitMap (G := InducedDiscreteFunctor _ (CodomainNaturalTransformation _ (fun _ => C) tt))). 69 | hnf; simpl. 70 | match goal with 71 | | [ |- SpecializedNaturalTransformation ?F0 ?G0 ] => 72 | refine (Build_SpecializedNaturalTransformation F0 G0 73 | (fun sdf => let d := snd (projT1 sdf) in MorphismOf F (s := (d, _)) (d := (d, _)) (Identity (C := C) d, projT2 sdf)) 74 | _ 75 | ) 76 | end; 77 | abstract t. 78 | Defined. 79 | 80 | Definition Coend := Coequalizer D _ _ Coend_Fdom Coend_Fcod. 81 | End Coend. 82 | 83 | (* TODO: Figure out why the notation for this is the same as the notation for the Grothendieck construction *) 84 | (*Notation "∫ F" := (Coend F).*) 85 | -------------------------------------------------------------------------------- /LimitFunctor2CategoryTheorems.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Export Adjoint Functor Category. 3 | Require Import Common Notations FunctorCategory NaturalTransformation Hom Duals CommaCategoryFunctors SetLimits SetColimits LimitFunctors LimitFunctorTheorems InducedLimitFunctors DefinitionSimplification FEqualDep CommaCategoryFunctorProperties. 4 | 5 | Set Implicit Arguments. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Local Open Scope category_scope. 12 | 13 | (* This should be useful for proving that the data migration functors 14 | in DataMigrationFunctors.v are adjoint, for 15 | DataMigrationFunctorsAdjoint.v *) 16 | 17 | Section LimReady. 18 | (* Variables C D : LocallySmallCategory. *) 19 | Variable S : Category. 20 | 21 | Local Notation "A ↓ F" := (CosliceSpecializedCategory A F). 22 | (*Local Notation "C / c" := (@SliceSpecializedCategoryOver _ _ C c).*) 23 | 24 | Variable I : Type. 25 | Variable Index2Object : I -> Type. 26 | Variable Index2Cat : forall i : I, SpecializedCategory (Index2Object i). 27 | 28 | Local Coercion Index2Cat : I >-> SpecializedCategory. 29 | 30 | Local Notation "'CAT' ⇑ D" := (@LaxCosliceSpecializedCategory _ _ Index2Cat _ D). 31 | 32 | Variable HasLimits : forall C0 : CAT ⇑ S, Limit (projT2 C0). 33 | 34 | Definition CatUpSet2Morphism A B (m1 m2 : Morphism (CAT ⇑ S) A B) : Type 35 | := { T : SpecializedNaturalTransformation (snd (projT1 m1)) (snd (projT1 m2)) | 36 | NTComposeT (projT2 m2) (NTComposeF (IdentityNaturalTransformation (projT2 A)) T) = projT2 m1 }. 37 | 38 | Lemma LimReady A B m1 m2 (LimitF := @InducedLimitFunctor _ _ Index2Cat _ S HasLimits) : 39 | @CatUpSet2Morphism A B m1 m2 -> MorphismOf LimitF m1 = MorphismOf LimitF m2. 40 | intro X; destruct X. 41 | simpl in *. 42 | unfold InducedLimitFunctor_MorphismOf. 43 | unfold InducedLimitMap. 44 | 45 | apply f_equal. 46 | match goal with 47 | | [ |- @eq ?T ?A ?B ] => let T' := eval hnf in T in change (@eq T' A B) 48 | end. 49 | 50 | 51 | subst_body. 52 | simpl in *. 53 | hnf in *. 54 | destruct A as [A], B as [B], m1 as [m1], m2 as [m2]. 55 | simpl in *. 56 | destruct A, B, m1, m2; simpl in *. 57 | 58 | 59 | repeat subst; simpl in *. 60 | 61 | apply NaturalTransformation_eq; 62 | apply functional_extensionality_dep; intro; simpl. 63 | repeat rewrite RightIdentity. 64 | repeat rewrite LeftIdentity. 65 | try_associativity ltac:(apply f_equal). 66 | try_associativity ltac:(rewrite <- FCompositionOf). 67 | simpl. 68 | present_spcategory. 69 | repeat rewrite FIdentityOf. 70 | repeat rewrite RightIdentity. 71 | repeat rewrite LeftIdentity. 72 | unfold Object in *. 73 | 74 | destruct_head @prod; simpl in *. 75 | destruct_head unit. 76 | clear. 77 | 78 | rename i0 into D, i into C. 79 | rename s into H, S into SET. 80 | rename s3 into F', s1 into F, x into b. 81 | rename x4 into c. 82 | 83 | match goal with 84 | | [ |- appcontext[@TerminalMorphism_Morphism ?C ?D ?U ?X ?M] ] => 85 | let T := fresh "T" in 86 | set (T := @TerminalMorphism_Morphism C D U X M); 87 | hnf in T 88 | end. 89 | match goal with 90 | | [ T : SpecializedNaturalTransformation _ _ |- _ ] => 91 | let H := fresh in 92 | pose proof (Commutes T) as H; 93 | simpl in H; 94 | symmetry; etransitivity; try apply H; [] 95 | end. 96 | rewrite RightIdentity. 97 | reflexivity. 98 | Defined. 99 | -------------------------------------------------------------------------------- /SumInducedFunctors.v: -------------------------------------------------------------------------------- 1 | Require Export SumCategory NaturalTransformation. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section SumCategoryFunctors. 13 | Section sum_functor. 14 | Context `(C : @SpecializedCategory objC). 15 | Context `(C' : @SpecializedCategory objC'). 16 | Context `(D : @SpecializedCategory objD). 17 | 18 | Definition sum_Functor (F : SpecializedFunctor C D) (F' : SpecializedFunctor C' D) 19 | : SpecializedFunctor (C + C') D. 20 | match goal with 21 | | [ |- SpecializedFunctor ?C ?D ] => 22 | refine (Build_SpecializedFunctor C D 23 | (fun cc' => match cc' with 24 | | inl c => F c 25 | | inr c' => F' c' 26 | end) 27 | (fun s d => match s, d with 28 | | inl cs, inl cd => MorphismOf F (s := cs) (d := cd) 29 | | inr c's, inr c'd => MorphismOf F' (s := c's) (d := c'd) 30 | | _, _ => fun m => match m with end 31 | end) 32 | _ 33 | _) 34 | end; 35 | abstract ( 36 | repeat intros [?|?]; 37 | intros; 38 | simpl in *; 39 | destruct_head_hnf Empty_set; 40 | repeat rewrite FIdentityOf; 41 | repeat rewrite FCompositionOf; 42 | reflexivity 43 | ). 44 | Defined. 45 | 46 | Definition sum_Functor_Functorial (F G : SpecializedFunctor C D) (F' G' : SpecializedFunctor C' D) 47 | (T : SpecializedNaturalTransformation F G) 48 | (T' : SpecializedNaturalTransformation F' G') 49 | : SpecializedNaturalTransformation (sum_Functor F F') (sum_Functor G G'). 50 | match goal with 51 | | [ |- SpecializedNaturalTransformation ?A ?B ] => 52 | refine (Build_SpecializedNaturalTransformation 53 | A B 54 | (fun x => match x with 55 | | inl c => T c 56 | | inr c' => T' c' 57 | end) 58 | _) 59 | end; 60 | abstract ( 61 | repeat intros [?|?]; simpl; intros; destruct_head_hnf Empty_set; apply Commutes 62 | ). 63 | Defined. 64 | End sum_functor. 65 | 66 | Section swap_functor. 67 | Definition sum_swap_Functor 68 | `(C : @SpecializedCategory objC) 69 | `(D : @SpecializedCategory objD) 70 | : SpecializedFunctor (C + D) (D + C) 71 | := sum_Functor (inr_Functor _ _) (inl_Functor _ _). 72 | 73 | Lemma sum_swap_swap_id 74 | `(C : @SpecializedCategory objC) 75 | `(D : @SpecializedCategory objD) 76 | : ComposeFunctors (sum_swap_Functor C D) (sum_swap_Functor D C) = IdentityFunctor _. 77 | apply Functor_eq; repeat intros [?|?]; simpl; trivial. 78 | Qed. 79 | End swap_functor. 80 | End SumCategoryFunctors. 81 | 82 | Notation "F + G" := (sum_Functor F G) : functor_scope. 83 | Notation "T + U" := (sum_Functor_Functorial T U) : natural_transformation_scope. 84 | -------------------------------------------------------------------------------- /MetaTranslation.v: -------------------------------------------------------------------------------- 1 | Require Import Setoid. 2 | Require Export Translation. 3 | Require Import Common. 4 | 5 | Set Implicit Arguments. 6 | 7 | Set Asymmetric Patterns. 8 | 9 | Set Universe Polymorphism. 10 | 11 | Section MetaTranslation. 12 | Variable C D : Schema. 13 | Variable F G : Translation C D. 14 | 15 | (* See MetaTranslation for documentation *) 16 | Record MetaTranslation := { 17 | SComponentsOf :> forall c : C, path D (F c) (G c); 18 | SCommutes : forall s d (e : C.(Edge) s d), 19 | PathsEquivalent _ (concatenate (F.(PathOf) _ _ e) (SComponentsOf d)) (concatenate (SComponentsOf s) (G.(PathOf) _ _ e)) 20 | }. 21 | 22 | Hint Rewrite SCommutes. 23 | 24 | Lemma SCommutes_TransferPath MT : forall s d (p : path C s d), 25 | PathsEquivalent _ (concatenate (F.(TransferPath) p) (MT.(SComponentsOf) d)) (concatenate (MT.(SComponentsOf) s) (G.(TransferPath) p)). 26 | intros s d p; induction p; t. 27 | repeat rewrite concatenate_associative. 28 | rewrite SCommutes. 29 | repeat rewrite <- concatenate_associative. 30 | t. 31 | Qed. 32 | 33 | End MetaTranslation. 34 | 35 | Section MetaTranslationComposition. 36 | Variable C D E : Schema. 37 | Variable F F' F'' : Translation C D. 38 | Variable G G' : Translation D E. 39 | 40 | Hint Resolve SCommutes f_equal f_equal2. 41 | Hint Resolve post_concatenate_equivalent pre_concatenate_equivalent. 42 | 43 | (* See NaturalTransformation for documentation *) 44 | Definition MTComposeMT (T' : MetaTranslation F' F'') (T : MetaTranslation F F') : 45 | MetaTranslation F F''. 46 | refine {| SComponentsOf := (fun c => concatenate (T c) (T' c)) |}; 47 | (* XXX TODO: Find a way to get rid of [e] in the transitivity call *) 48 | abstract (intros; transitivity (concatenate (concatenate (T _) (PathOf F' _ _ e)) (T' _)); 49 | solve_repeat_rewrite concatenate_associative eauto). 50 | Defined. 51 | 52 | Hint Rewrite SCommutes. 53 | 54 | Ltac strip_concatenate' := 55 | match goal with 56 | | [ |- ?Rel (concatenate _ _) (concatenate _ _) ] => apply pre_concatenate_equivalent || apply post_concatenate_equivalent 57 | end. 58 | Ltac strip_concatenate := 59 | repeat (repeat strip_concatenate'; 60 | repeat (rewrite concatenate_associative; try strip_concatenate'); repeat strip_concatenate'; 61 | repeat (rewrite <- concatenate_associative; try strip_concatenate'); repeat strip_concatenate'). 62 | 63 | Hint Extern 1 => strip_concatenate. 64 | 65 | Hint Extern 1 => 66 | match goal with 67 | | [ |- ?Rel (concatenate (TransferPath _ ?p) _) (concatenate _ (TransferPath _ ?p)) ] => 68 | induction p; simpl; try rewrite concatenate_noedges_p; try reflexivity; 69 | repeat rewrite concatenate_associative; rewrite SCommutes; strip_concatenate; auto 70 | end. 71 | 72 | Definition MTComposeT (U : MetaTranslation G G') (T : MetaTranslation F F'): 73 | MetaTranslation (ComposeTranslations G F) (ComposeTranslations G' F'). 74 | refine (Build_MetaTranslation (ComposeTranslations G F) (ComposeTranslations G' F') 75 | (fun c => concatenate (U.(SComponentsOf) (F c)) (G'.(TransferPath) (T.(SComponentsOf) c))) 76 | _); 77 | abstract ( 78 | intros; simpl; 79 | repeat rewrite concatenate_associative; 80 | rewrite <- concatenate_TransferPath; 81 | rewrite <- SCommutes; 82 | rewrite concatenate_TransferPath; 83 | auto 84 | ). 85 | Defined. 86 | End MetaTranslationComposition. 87 | 88 | Section IdentityMetaTranslation. 89 | Variable C D : Schema. 90 | Variable F : Translation C D. 91 | 92 | (* There is an identity natrual transformation. *) 93 | Definition IdentityMetaTranslation : MetaTranslation F F. 94 | refine {| SComponentsOf := (fun c => NoEdges) 95 | |}; 96 | abstract t. 97 | Defined. 98 | End IdentityMetaTranslation. 99 | -------------------------------------------------------------------------------- /SetLimits.v: -------------------------------------------------------------------------------- 1 | Require Import Setoid FunctionalExtensionality. 2 | Require Export SetCategory. 3 | Require Import Common Limits Functor NaturalTransformation FunctorCategory InitialTerminalCategory. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Ltac limit_t := 14 | repeat (repeat intro; repeat split); 15 | simpl in *; 16 | 17 | nt_eq; 18 | subst; expand; 19 | 20 | repeat (apply functional_extensionality_dep; intro; try simpl_eq); 21 | 22 | destruct_head @SpecializedNaturalTransformation; 23 | fg_equal; 24 | 25 | destruct_sig; 26 | 27 | trivial; t_with t'; intuition. 28 | 29 | Section SetLimits. 30 | Context `(C : @SmallSpecializedCategory objC). 31 | Variable F : SpecializedFunctor C SetCat. 32 | 33 | (* Quoting David: 34 | let F:C-->Set be a functor. An element of the limit is a collection of elements x_c, 35 | one for each c in C, such that under every arrow g: c-->c' in C, x_c is sent to x_{c'}. 36 | *) 37 | Definition SetLimit_Object : SetCat := 38 | { S : forall c : objC, F c | forall c c' (g : C.(Morphism) c c'), F.(MorphismOf) g (S c) = (S c') }. 39 | 40 | Definition SetLimit_Morphism : SpecializedNaturalTransformation 41 | ((DiagonalFunctor SetCat C) SetLimit_Object) 42 | F. 43 | match goal with 44 | | [ |- SpecializedNaturalTransformation ?F ?G ] => 45 | refine (Build_SpecializedNaturalTransformation F G 46 | (fun c : objC => (fun S => (proj1_sig S) c)) 47 | _ 48 | ) 49 | end. 50 | abstract limit_t. 51 | Defined. 52 | 53 | Definition SetLimit_Property_Morphism A' 54 | (φ' : SpecializedNaturalTransformation ((DiagonalFunctor SetCat C) A') F) : 55 | A' -> SetLimit_Object. 56 | intro x; hnf. 57 | exists (fun c => ComponentsOf φ' c x). 58 | abstract limit_t. 59 | Defined. 60 | 61 | Definition SetLimit : Limit F. 62 | refine (Build_TerminalMorphism (DiagonalFunctor SetCat C) F SetLimit_Object SetLimit_Morphism _). 63 | intros A' φ'. 64 | exists (SetLimit_Property_Morphism φ'). 65 | abstract limit_t. 66 | Defined. 67 | End SetLimits. 68 | 69 | Section TypeLimits. 70 | Context `(C : @SmallSpecializedCategory objC). 71 | Variable F : SpecializedFunctor C TypeCat. 72 | 73 | (* Quoting David: 74 | let F:C-->Type be a functor. An element of the limit is a collection of elements x_c, 75 | one for each c in C, such that under every arrow g: c-->c' in C, x_c is sent to x_{c'}. 76 | *) 77 | Definition TypeLimit_Object : TypeCat := 78 | { S : forall c : objC, F c | forall c c' (g : C.(Morphism) c c'), F.(MorphismOf) g (S c) = (S c') }. 79 | 80 | Definition TypeLimit_Morphism : SpecializedNaturalTransformation 81 | ((DiagonalFunctor TypeCat C) TypeLimit_Object) 82 | F. 83 | match goal with 84 | | [ |- SpecializedNaturalTransformation ?F ?G ] => 85 | refine (Build_SpecializedNaturalTransformation F G 86 | (fun c : objC => (fun S => (proj1_sig S) c)) 87 | _ 88 | ) 89 | end. 90 | abstract limit_t. 91 | Defined. 92 | 93 | Definition TypeLimit_Property_Morphism A' 94 | (φ' : SpecializedNaturalTransformation ((DiagonalFunctor TypeCat C) A') F) : 95 | A' -> TypeLimit_Object. 96 | intro x; hnf. 97 | exists (fun c => ComponentsOf φ' c x). 98 | abstract limit_t. 99 | Defined. 100 | 101 | Definition TypeLimit : Limit F. 102 | refine (Build_TerminalMorphism (DiagonalFunctor TypeCat C) F TypeLimit_Object TypeLimit_Morphism _). 103 | intros A' φ'. 104 | exists (TypeLimit_Property_Morphism φ'). 105 | abstract limit_t. 106 | Defined. 107 | End TypeLimits. 108 | -------------------------------------------------------------------------------- /GraphTranslation.v: -------------------------------------------------------------------------------- 1 | Require Import ProofIrrelevance JMeq. 2 | Require Export Graph Paths. 3 | Require Import Common StructureEquality Notations FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Infix "==" := JMeq. 14 | 15 | Section Graphs. 16 | Context `(G : Graph v). 17 | Context `(H : Graph w). 18 | 19 | Record GraphTranslation := { 20 | VertexOf' : v -> w; 21 | EdgeOf' : forall s d, G.(Edge') s d -> H.(Edge') (VertexOf' s) (VertexOf' d) 22 | }. 23 | 24 | Section GraphInterface. 25 | Context `(T : GraphTranslation). 26 | 27 | Definition VertexOf : G -> H := Eval cbv beta delta [VertexOf'] in T.(VertexOf'). 28 | Definition EdgeOf : forall s d : G, G.(Edge) s d -> H.(Edge) (VertexOf s) (VertexOf d) := 29 | Eval cbv beta delta [EdgeOf'] in T.(EdgeOf'). 30 | End GraphInterface. 31 | End Graphs. 32 | 33 | Coercion VertexOf : GraphTranslation >-> Funclass. 34 | 35 | Arguments VertexOf {v G w H} T x : simpl nomatch. 36 | Arguments EdgeOf {v G w H} T [s d] p : simpl nomatch. 37 | 38 | Section GraphTranslations_Equal. 39 | Lemma GraphTranslations_Equal v G w H : forall (T U : @GraphTranslation v G w H), 40 | VertexOf T = VertexOf U 41 | -> (VertexOf T = VertexOf U -> EdgeOf T == EdgeOf U) 42 | -> T = U. 43 | Proof. 44 | destruct T, U; simpl; intros; specialize_all_ways; repeat subst; 45 | reflexivity. 46 | Qed. 47 | 48 | Lemma GraphTranslations_JMeq v G w H v' G' w' H' : 49 | forall (T : @GraphTranslation v G w H) (U : @GraphTranslation v' G' w' H'), 50 | v = v' 51 | -> w = w' 52 | -> (v = v' -> G == G') 53 | -> (w = w' -> H == H') 54 | -> (v = v' -> G == G' 55 | -> w = w' -> H == H' 56 | -> VertexOf T == VertexOf U) 57 | -> (v = v' -> G == G' 58 | -> w = w' -> H == H' 59 | -> VertexOf T == VertexOf U 60 | -> EdgeOf T == EdgeOf U) 61 | -> T == U. 62 | Proof. 63 | simpl; intros; intuition; repeat subst; destruct T, U; simpl in *. 64 | repeat subst; reflexivity. 65 | Qed. 66 | End GraphTranslations_Equal. 67 | 68 | Ltac graph_translation_eq_step_with tac := 69 | structures_eq_step_with_tac ltac:(apply GraphTranslations_Equal || apply GraphTranslations_JMeq) tac. 70 | 71 | Ltac graph_translation_eq_with tac := repeat graph_translation_eq_step_with tac. 72 | 73 | Ltac graph_translation_eq_step := graph_translation_eq_step_with idtac. 74 | Ltac graph_translation_eq := graph_translation_eq_with idtac. 75 | 76 | Section GraphTranslationComposition. 77 | Context `(B : @Graph vertB). 78 | Context `(C : @Graph vertC). 79 | Context `(D : @Graph vertD). 80 | Context `(E : @Graph vertE). 81 | 82 | Definition ComposeGraphTranslations (G : GraphTranslation D E) (F : GraphTranslation C D) : GraphTranslation C E := 83 | {| VertexOf' := (fun c => G (F c)); 84 | EdgeOf' := (fun _ _ m => G.(EdgeOf) (F.(EdgeOf) m)) |}. 85 | End GraphTranslationComposition. 86 | 87 | Section IdentityGraphTranslation. 88 | Context `(C : @Graph vertC). 89 | 90 | (* There is an identity graph translation. It does the obvious thing. *) 91 | Definition IdentityGraphTranslation : GraphTranslation C C := 92 | {| VertexOf' := (fun x => x); 93 | EdgeOf' := (fun _ _ x => x) |}. 94 | End IdentityGraphTranslation. 95 | 96 | Section GraphTranslationCompositionLemmas. 97 | Context `(B : @Graph vertB). 98 | Context `(C : @Graph vertC). 99 | Context `(D : @Graph vertD). 100 | Context `(E : @Graph vertE). 101 | 102 | Lemma ComposeGraphTranslationsAssociativity (F : GraphTranslation B C) (G : GraphTranslation C D) (H : GraphTranslation D E) : 103 | ComposeGraphTranslations (ComposeGraphTranslations H G) F = ComposeGraphTranslations H (ComposeGraphTranslations G F). 104 | Proof. 105 | reflexivity. 106 | Qed. 107 | End GraphTranslationCompositionLemmas. 108 | -------------------------------------------------------------------------------- /CategoryEquality.v: -------------------------------------------------------------------------------- 1 | Require Import ProofIrrelevance JMeq. 2 | Require Export Category FEqualDep. 3 | Require Import Common Notations StructureEquality SpecializedCategory. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Infix "==" := JMeq. 14 | 15 | Section Categories_Equal. 16 | Lemma Category_eq : forall (A B : Category), 17 | Object A = Object B 18 | -> Morphism A == Morphism B 19 | -> @Identity _ A == @Identity _ B 20 | -> @Compose _ A == @Compose _ B 21 | -> A = B. 22 | unfold Object, Morphism, Identity, Compose; intros; 23 | destruct_type @Category; destruct_type @SpecializedCategory; simpl in *; 24 | subst_body; repeat subst. 25 | repeat f_equal; apply proof_irrelevance. 26 | Qed. 27 | 28 | Lemma SmallCategory_eq : forall (A B : SmallCategory), 29 | SObject A = SObject B 30 | -> Morphism A == Morphism B 31 | -> @Identity _ A == @Identity _ B 32 | -> @Compose _ A == @Compose _ B 33 | -> A = B. 34 | unfold SObject, Morphism, Identity, Compose; intros; 35 | destruct_type @SmallCategory; destruct_type @SmallSpecializedCategory; simpl in *; 36 | subst_body; repeat (subst; JMeq_eq). 37 | repeat f_equal; apply proof_irrelevance. 38 | Qed. 39 | 40 | Lemma LocallySmallCategory_eq : forall (A B : LocallySmallCategory), 41 | LSObject A = LSObject B 42 | -> Morphism A == Morphism B 43 | -> @Identity _ A == @Identity _ B 44 | -> @Compose _ A == @Compose _ B 45 | -> A = B. 46 | unfold LSObject, Morphism, Identity, Compose; intros; 47 | destruct_type @LocallySmallCategory; destruct_type @LocallySmallSpecializedCategory; simpl in *; 48 | subst_body; repeat (subst; JMeq_eq). 49 | repeat f_equal; apply proof_irrelevance. 50 | Qed. 51 | End Categories_Equal. 52 | 53 | Ltac cat_eq_step_with tac := 54 | structures_eq_step_with_tac 55 | ltac:(apply SmallCategory_eq || apply LocallySmallCategory_eq || apply Category_eq) 56 | tac. 57 | 58 | Ltac cat_eq_with tac := repeat cat_eq_step_with tac. 59 | 60 | Ltac cat_eq_step := cat_eq_step_with idtac. 61 | Ltac cat_eq := cat_eq_with idtac. 62 | 63 | Section RoundtripCat. 64 | Context `(C : @SpecializedCategory obj). 65 | Variable C' : Category. 66 | 67 | Lemma SpecializedCategory_Category_SpecializedCategory_Id : ((C : Category) : SpecializedCategory _) = C. 68 | spcat_eq. 69 | Qed. 70 | 71 | Lemma Category_SpecializedCategory_Category_Id : ((C' : SpecializedCategory _) : Category) = C'. 72 | cat_eq. 73 | Qed. 74 | End RoundtripCat. 75 | 76 | Hint Rewrite @SpecializedCategory_Category_SpecializedCategory_Id @Category_SpecializedCategory_Category_Id : category. 77 | 78 | Section RoundtripLSCat. 79 | Context `(C : @LocallySmallSpecializedCategory obj). 80 | Variable C' : LocallySmallCategory. 81 | 82 | Lemma LocallySmall_SpecializedCategory_Category_SpecializedCategory_Id : ((C : LocallySmallCategory) : LocallySmallSpecializedCategory _) = C. 83 | spcat_eq. 84 | Qed. 85 | 86 | Lemma LocallySmall_Category_SpecializedCategory_Category_Id : ((C' : LocallySmallSpecializedCategory _) : LocallySmallCategory) = C'. 87 | cat_eq. 88 | Qed. 89 | End RoundtripLSCat. 90 | 91 | Hint Rewrite @LocallySmall_SpecializedCategory_Category_SpecializedCategory_Id LocallySmall_Category_SpecializedCategory_Category_Id : category. 92 | 93 | Section RoundtripSCat. 94 | Context `(C : @SmallSpecializedCategory obj). 95 | Variable C' : SmallCategory. 96 | 97 | Lemma Small_SpecializedCategory_Category_SpecializedCategory_Id : ((C : SmallCategory) : SmallSpecializedCategory _) = C. 98 | spcat_eq. 99 | Qed. 100 | 101 | Lemma Small_Category_SpecializedCategory_Category_Id : ((C' : SmallSpecializedCategory _) : SmallCategory) = C'. 102 | cat_eq. 103 | Qed. 104 | End RoundtripSCat. 105 | 106 | Hint Rewrite @Small_SpecializedCategory_Category_SpecializedCategory_Id Small_Category_SpecializedCategory_Category_Id : category. 107 | -------------------------------------------------------------------------------- /GrothendieckCat.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor ComputableCategory. 2 | Require Import Common Notations NaturalTransformation. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section Grothendieck. 13 | Context `(Index2Cat : forall i : Index, SpecializedCategory (Index2Object i)). 14 | Let Cat := @ComputableCategory _ Index2Object Index2Cat. 15 | 16 | Local Coercion Index2Cat : Index >-> SpecializedCategory. 17 | 18 | (** 19 | Quoting Wikipedia: 20 | The Grothendieck construction is an auxiliary construction used 21 | in the mathematical field of category theory. 22 | 23 | Let 24 | [F : C -> Set] 25 | be a functor from any small category to the category of sets. 26 | The Grothendieck construct for [F] is the category [Γ F] whose 27 | objects are pairs [(c, x)], where [c : C] is an 28 | object and [x : F c] is an element, and for which the set 29 | [Hom (Γ F) (c1, x1) (c2, x2)] is the set of morphisms 30 | [f : c1 -> c2] in [C] such that [F.(MorphismOf) f x1 = x2]. 31 | *) 32 | Context `(C : @SpecializedCategory objC). 33 | Variable F : SpecializedFunctor C Cat. 34 | 35 | Record CatGrothendieckPair := { 36 | CatGrothendieckC' : objC; 37 | CatGrothendieckX' : F CatGrothendieckC' 38 | }. 39 | 40 | Section GrothendieckInterface. 41 | Variable G : CatGrothendieckPair. 42 | 43 | Definition CatGrothendieckC : C := G.(CatGrothendieckC'). 44 | Definition CatGrothendieckX : F CatGrothendieckC := G.(CatGrothendieckX'). 45 | End GrothendieckInterface. 46 | 47 | Lemma CatGrothendieckPair_eta (x : CatGrothendieckPair) : Build_CatGrothendieckPair (CatGrothendieckC x) (CatGrothendieckX x) = x. 48 | destruct x; reflexivity. 49 | Qed. 50 | 51 | Definition CatGrothendieckCompose cs xs cd xd cd' xd' : 52 | { f : C.(Morphism) cd cd' & Morphism _ (F.(MorphismOf) f xd) xd' } 53 | -> { f : C.(Morphism) cs cd & Morphism _ (F.(MorphismOf) f xs) xd } 54 | -> { f : C.(Morphism) cs cd' & Morphism _ (F.(MorphismOf) f xs) xd' }. 55 | intros m2 m1. 56 | exists (Compose (projT1 m2) (projT1 m1)). 57 | refine (Compose (projT2 m2) _). 58 | rewrite FCompositionOf. (* ugh *) 59 | refine (MorphismOf (MorphismOf F (projT1 m2)) (projT2 m1)). 60 | Defined. 61 | 62 | Arguments CatGrothendieckCompose [cs xs cd xd cd' xd'] / _ _. 63 | 64 | Definition CatGrothendieckIdentity c x : { f : C.(Morphism) c c & Morphism _ (F.(MorphismOf) f x) x }. 65 | exists (Identity c). 66 | rewrite FIdentityOf. 67 | exact (Identity _). 68 | Defined. 69 | (* 70 | Local Hint Extern 1 (@eq (sig _) _ _) => simpl_eq : category. 71 | Local Hint Extern 1 (@eq (sigT _) _ _) => simpl_eq : category. 72 | 73 | Definition CategoryOfCatElements : @SpecializedCategory CatGrothendieckPair. 74 | refine {| 75 | Morphism := (fun s d => _); 76 | Compose' := (fun _ _ _ m1 m2 => CatGrothendieckCompose m1 m2); 77 | Identity' := (fun o => CatGrothendieckIdentity (CatGrothendieckC o) (CatGrothendieckX o)) 78 | |}; 79 | repeat intro; hnf in *; expand; 80 | simpl_eq; 81 | destruct_sig; 82 | auto with category. 83 | Focus 3. 84 | unfold eq_rect_r. 85 | unfold eq_rect. 86 | unfold eq_sym. 87 | repeat match goal with 88 | | [ |- context[match ?E with _ => _ end] ] => (atomic E; fail 1) || let H := fresh in set (H := E) 89 | end. 90 | etransitivity. 91 | destruct 92 | Focus 2. 93 | rewrite FIdentityOf. 94 | destruct H0. 95 | 96 | simpl. 97 | repeat rewrite Associativity. 98 | repeat rewrite <- FCompositionOf. 99 | unfold eq_rect_r. 100 | unfold eq_sym. 101 | unfold eq_rect. 102 | destruct H0. 103 | destruct H. 104 | unfold 105 | destruct_head CatGrothendieckPair; 106 | simpl_eq. 107 | abstract ( 108 | repeat intro; hnf in *; expand; 109 | destruct_head CatGrothendieckPair; 110 | destruct_sig; 111 | eauto with category 112 | ). 113 | Defined. 114 | 115 | Definition CatGrothendieckProjectionFunctor1 : SpecializedFunctor CategoryOfCatElements C. 116 | refine {| 117 | ObjectOf := (fun o : CategoryOfCatElements => CatGrothendieckC o); 118 | MorphismOf := (fun s d (m : CategoryOfCatElements.(Morphism) s d) => proj1_sig m) 119 | |}; 120 | abstract (eauto with category; intros; simpl; reflexivity). 121 | Defined. *) 122 | End Grothendieck. 123 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | MODULES := Notations \ 2 | Common \ 3 | GetArguments \ 4 | FEqualDep \ 5 | StructureEquality \ 6 | DefinitionSimplification \ 7 | NatFacts \ 8 | EquivalenceSet \ 9 | EquivalenceClass \ 10 | EquivalenceRelationGenerator \ 11 | Paths \ 12 | EqdepFacts_one_variable \ 13 | Eqdep_dec_one_variable \ 14 | \ 15 | SpecializedCategory \ 16 | Functor \ 17 | NaturalTransformation \ 18 | ProductCategory \ 19 | SumCategory \ 20 | \ 21 | LtacReifiedSimplification \ 22 | TypeclassSimplification \ 23 | TypeclassUnreifiedSimplification \ 24 | CanonicalStructureSimplification \ 25 | \ 26 | Category \ 27 | CategoryEquality \ 28 | CategoryIsomorphisms \ 29 | FunctorIsomorphisms \ 30 | NaturalEquivalence \ 31 | \ 32 | Graph \ 33 | GraphTranslation \ 34 | ComputableGraphCategory \ 35 | \ 36 | NaturalNumbersObject \ 37 | ChainCategory \ 38 | BoolCategory \ 39 | NatCategory \ 40 | FunctorCategory \ 41 | ComputableCategory \ 42 | DiscreteCategory \ 43 | IndiscreteCategory \ 44 | PathsCategory \ 45 | FunctorProduct \ 46 | ProductNaturalTransformation \ 47 | ProductInducedFunctors \ 48 | SumInducedFunctors \ 49 | ExponentialLaws \ 50 | ProductLaws \ 51 | FunctorialComposition \ 52 | MonoidalCategory \ 53 | EnrichedCategory \ 54 | SetCategory \ 55 | SetCategoryProductFunctor \ 56 | InitialTerminalCategory \ 57 | SmallCat \ 58 | CommaCategory \ 59 | SpecializedCommaCategory \ 60 | LaxCommaCategory \ 61 | SpecializedLaxCommaCategory \ 62 | CommaCategoryProjection \ 63 | CommaCategoryInducedFunctors \ 64 | CommaCategoryProjectionFunctors \ 65 | CommaCategoryFunctors \ 66 | CommaCategoryFunctorProperties \ 67 | UniversalProperties \ 68 | Duals \ 69 | DualFunctor \ 70 | FunctorCategoryFunctorial \ 71 | Hom \ 72 | FunctorAttributes \ 73 | SigCategory \ 74 | SigTCategory \ 75 | SigTSigCategory \ 76 | SigSigTCategory \ 77 | SigTInducedFunctors \ 78 | SigTSigInducedFunctors \ 79 | Subcategory \ 80 | DecidableDiscreteCategory \ 81 | DecidableComputableCategory \ 82 | DecidableSmallCat \ 83 | DecidableSetCategory \ 84 | SimplicialSets \ 85 | SemiSimplicialSets \ 86 | Correspondences \ 87 | Groupoid \ 88 | AdjointUnit \ 89 | Adjoint \ 90 | AdjointUniversalMorphisms \ 91 | AdjointComposition \ 92 | AdjointPointwise \ 93 | DiscreteCategoryFunctors \ 94 | DecidableDiscreteCategoryFunctors \ 95 | PathsCategoryFunctors \ 96 | \ 97 | Group \ 98 | GroupCategory \ 99 | \ 100 | Limits \ 101 | LimitFunctors \ 102 | LimitFunctorTheorems \ 103 | InducedLimitFunctors \ 104 | Graphs \ 105 | Equalizer \ 106 | EqualizerFunctor \ 107 | Pullback \ 108 | PullbackFunctor \ 109 | Products \ 110 | ProductFunctors \ 111 | Coend \ 112 | CoendFunctor \ 113 | SubobjectClassifier \ 114 | Grothendieck \ 115 | GrothendieckFunctorial \ 116 | SetLimits \ 117 | SetColimits \ 118 | SetCategoryFacts \ 119 | Yoneda \ 120 | \ 121 | Schema \ 122 | SmallSchema \ 123 | SetSchema \ 124 | Instance \ 125 | Translation \ 126 | SmallTranslation \ 127 | MetaTranslation \ 128 | MetaEquivalence \ 129 | Examples \ 130 | Theorems \ 131 | \ 132 | Database \ 133 | SQLQueries \ 134 | DatabaseConstraints \ 135 | DatabaseMorphisms # \ 136 | DataMigrationFunctors \ 137 | CategorySchemaEquivalence \ 138 | ComputableSchemaCategory 139 | VS := $(MODULES:%=%.v) 140 | VDS := $(MODULES:%=%.v.d) 141 | 142 | NEW_TIME_FILE=time-of-build-after.log 143 | OLD_TIME_FILE=time-of-build-before.log 144 | BOTH_TIME_FILE=time-of-build-both.log 145 | NEW_PRETTY_TIME_FILE=time-of-build-after-pretty.log 146 | TIME_SHELF_NAME=time-of-build-shelf 147 | 148 | 149 | 150 | .PHONY: coq clean timed pretty-timed pretty-timed-files html 151 | 152 | coq: Makefile.coq 153 | $(MAKE) -f Makefile.coq 154 | 155 | html: Makefile.coq 156 | $(MAKE) -f Makefile.coq html 157 | 158 | # TODO(jgross): Look into combining this with the time-make.sh script 159 | timed: Makefile.coq 160 | chmod +x ./report_time.sh 161 | ./report_time.sh -c $(MAKE) -f Makefile.coq SHELL=./report_time.sh 162 | 163 | pretty-timed-diff: 164 | sh ./make-each-time-file.sh "$(NEW_TIME_FILE)" "$(OLD_TIME_FILE)" 165 | $(MAKE) combine-pretty-timed 166 | 167 | combine-pretty-timed: 168 | python ./make-both-time-files.py "$(NEW_TIME_FILE)" "$(OLD_TIME_FILE)" "$(BOTH_TIME_FILE)" 169 | cat "$(BOTH_TIME_FILE)" 170 | 171 | pretty-timed: 172 | sh ./make-each-time-file.sh "$(NEW_TIME_FILE)" 173 | python ./make-one-time-file.py "$(NEW_TIME_FILE)" "$(NEW_PRETTY_TIME_FILE)" 174 | 175 | Makefile.coq: Makefile $(VS) 176 | coq_makefile $(VS) -arg -dont-load-proofs -o Makefile.coq 177 | 178 | clean:: Makefile.coq 179 | $(MAKE) -f Makefile.coq clean 180 | rm -f Makefile.coq .depend 181 | -------------------------------------------------------------------------------- /Paths.v: -------------------------------------------------------------------------------- 1 | Require Import Common. 2 | 3 | Set Implicit Arguments. 4 | 5 | Set Asymmetric Patterns. 6 | 7 | Set Universe Polymorphism. 8 | 9 | Section path. 10 | Variable V : Type. 11 | Variable E : V -> V -> Type. 12 | 13 | Inductive path (s : V) : V -> Type := 14 | | NoEdges : path s s 15 | | AddEdge : forall d d', path s d -> E d d' -> path s d'. 16 | 17 | Fixpoint prepend s d (p : path s d) : forall s', E s' s -> path s' d := 18 | match p with 19 | | NoEdges => fun _ E' => AddEdge (NoEdges _) E' 20 | | AddEdge _ _ p' E => fun _ E' => AddEdge (prepend p' E') E 21 | end. 22 | 23 | Fixpoint concatenate s d d' (p : path s d) (p' : path d d') : path s d' := 24 | match p' with 25 | | NoEdges => p 26 | | AddEdge _ _ p' E => AddEdge (concatenate p p') E 27 | end. 28 | 29 | Fixpoint concatenate' s d (p : path s d) : forall d', path d d' -> path s d' := 30 | match p with 31 | | NoEdges => fun _ p' => p' 32 | | AddEdge _ _ p E => fun _ p' => concatenate' p (prepend p' E) 33 | end. 34 | 35 | Variable typeOf : V -> Type. 36 | Variable functionOf : forall s d, E s d -> typeOf s -> typeOf d. 37 | 38 | Fixpoint compose_path s d (p : path s d) : typeOf s -> typeOf d := 39 | match p with 40 | | NoEdges => fun x => x 41 | | AddEdge _ _ p' E => fun x => functionOf E (compose_path p' x) 42 | end. 43 | End path. 44 | 45 | Arguments NoEdges [V E s]. 46 | Arguments AddEdge [V E s d d'] _ _. 47 | Arguments prepend [V E s d] p [s'] p'. 48 | 49 | Section path_Theorems. 50 | Variable V : Type. 51 | Variable E : V -> V -> Type. 52 | 53 | Lemma concatenate_noedges_p : forall s d (p : path E s d), concatenate NoEdges p = p. 54 | Proof. 55 | induction p; t. 56 | Qed. 57 | 58 | Lemma concatenate_p_noedges : forall s d (p : path E s d), concatenate p NoEdges = p. 59 | Proof. 60 | t. 61 | Qed. 62 | 63 | Lemma concatenate'_p_addedge : forall s d d' d'' (p : path E s d) (p' : path E d d') (e : E d' d''), 64 | concatenate' p (AddEdge p' e) = AddEdge (concatenate' p p') e. 65 | Proof. 66 | induction p; t. 67 | Qed. 68 | 69 | Hint Rewrite concatenate'_p_addedge. 70 | 71 | Lemma concatenate'_p_noedges : forall s d (p : path E s d), concatenate' p NoEdges = p. 72 | Proof. 73 | induction p; t. 74 | Qed. 75 | 76 | Lemma concatenate'_noedges_p : forall s d (p : path E s d), concatenate' NoEdges p = p. 77 | Proof. 78 | t. 79 | Qed. 80 | 81 | Hint Rewrite concatenate'_p_noedges. 82 | 83 | Lemma concatenate_addedge_concatenate'_prepend : forall s d d'0 d' (p : path E s d) (e : E d d'0) (p' : path E d'0 d'), 84 | concatenate (AddEdge p e) p' = concatenate' p (prepend p' e). 85 | Proof. 86 | induction p'; t. 87 | Qed. 88 | 89 | Hint Resolve concatenate_noedges_p concatenate_addedge_concatenate'_prepend. 90 | 91 | Lemma concatenate_concatenate'_equivalent : forall s d d' (p : path E s d) (p' : path E d d'), concatenate p p' = concatenate' p p'. 92 | Proof. 93 | induction p; t. 94 | Qed. 95 | 96 | Hint Rewrite concatenate_noedges_p concatenate_addedge_concatenate'_prepend. 97 | Hint Rewrite <- concatenate_concatenate'_equivalent. 98 | 99 | Lemma concatenate_p_addedge : forall s d d' d'' (p : path E s d) (p' : path E d d') (e : E d' d''), 100 | concatenate p (AddEdge p' e) = AddEdge (concatenate p p') e. 101 | Proof. 102 | induction p; t. 103 | Qed. 104 | 105 | Lemma concatenate_prepend_p : forall s s' d d' (p1 : path E s' d) (p2 : path E d d') (e : E s s'), 106 | (prepend (concatenate p1 p2) e) = (concatenate (prepend p1 e) p2). 107 | Proof. 108 | induction p1; t. 109 | Qed. 110 | 111 | Hint Rewrite concatenate_prepend_p. 112 | 113 | Lemma concatenate_associative o1 o2 o3 o4 : forall (p1 : path E o1 o2) (p2 : path E o2 o3) (p3 : path E o3 o4), 114 | (concatenate (concatenate p1 p2) p3) = (concatenate p1 (concatenate p2 p3)). 115 | Proof. 116 | induction p1; t. 117 | Qed. 118 | 119 | Lemma compose_path_addedge s d d' (p : path E s d) (e : E _ d') typeOf functionOf : forall x, compose_path typeOf functionOf (AddEdge p e) x = functionOf _ _ e (compose_path typeOf functionOf p x). 120 | Proof. 121 | induction p; t_with t'. 122 | Qed. 123 | 124 | Lemma compose_path_prepend s' s d (p : path E s d) (e : E s' _) typeOf functionOf : forall x, compose_path typeOf functionOf (prepend p e) x = (compose_path typeOf functionOf p (functionOf _ _ e x)). 125 | Proof. 126 | induction p; t_with t'. 127 | Qed. 128 | End path_Theorems. 129 | 130 | Hint Rewrite compose_path_prepend compose_path_addedge. 131 | Hint Rewrite concatenate_p_noedges concatenate_noedges_p. 132 | Hint Resolve concatenate_p_noedges concatenate_noedges_p. 133 | -------------------------------------------------------------------------------- /Hom.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Export SpecializedCategory Functor Duals SetCategory ProductCategory. 3 | Require Import Common. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Open Scope category_scope. 14 | 15 | (* 16 | We could do covariant and contravariant as 17 | 18 | Section covariant_contravariant. 19 | Local Arguments InducedProductSndFunctor / _ _ _ _ _ _ _ _ _ _ _. 20 | Definition CovariantHomFunctor `(C : @SpecializedCategory objC) (A : OppositeCategory C) := 21 | Eval simpl in ((HomFunctor C) [ A, - ])%functor. 22 | Definition ContravariantHomFunctor `(C : @SpecializedCategory objC) (A : C) := ((HomFunctor C) [ -, A ])%functor. 23 | 24 | Definition CovariantHomSetFunctor `(C : @LocallySmallSpecializedCategory objC morC) (A : OppositeCategory C) := ((HomSetFunctor C) [ A, - ])%functor. 25 | Definition ContravariantHomSetFunctor `(C : @LocallySmallSpecializedCategory objC morC) (A : C) := ((HomSetFunctor C) [ -, A ])%functor. 26 | End covariant_contravariant. 27 | 28 | but that would introduce an extra identity morphism which some tactics 29 | have a bit of trouble with. *sigh* 30 | *) 31 | 32 | Section HomFunctor. 33 | Context `(C : @SpecializedCategory objC). 34 | Let COp := OppositeCategory C. 35 | 36 | Section Covariant. 37 | Variable A : COp. 38 | 39 | Definition CovariantHomFunctor : SpecializedFunctor C TypeCat. 40 | refine (Build_SpecializedFunctor C TypeCat 41 | (fun X : C => C.(Morphism) A X : TypeCat) 42 | (fun X Y f => (fun g : C.(Morphism) A X => Compose f g)) 43 | _ 44 | _ 45 | ); 46 | abstract (simpl; intros; repeat (apply functional_extensionality_dep; intro); auto with morphism). 47 | Defined. 48 | End Covariant. 49 | 50 | Section Contravariant. 51 | Variable B : C. 52 | 53 | Definition ContravariantHomFunctor : SpecializedFunctor COp TypeCat. 54 | refine (Build_SpecializedFunctor COp TypeCat 55 | (fun X : COp => COp.(Morphism) B X : TypeCat) 56 | (fun X Y (h : COp.(Morphism) X Y) => (fun g : COp.(Morphism) B X => Compose h g)) 57 | _ 58 | _ 59 | ); 60 | abstract (simpl; intros; repeat (apply functional_extensionality_dep; intro); auto with morphism). 61 | Defined. 62 | End Contravariant. 63 | 64 | Definition hom_functor_object_of (c'c : COp * C) := C.(Morphism) (fst c'c) (snd c'c) : TypeCat. 65 | 66 | Definition hom_functor_morphism_of (s's : (COp * C)%type) (d'd : (COp * C)%type) (hf : (COp * C).(Morphism) s's d'd) : 67 | TypeCat.(Morphism) (hom_functor_object_of s's) (hom_functor_object_of d'd). 68 | unfold hom_functor_object_of in *. 69 | destruct s's as [ s' s ], d'd as [ d' d ]. 70 | destruct hf as [ h f ]. 71 | intro g. 72 | exact (Compose f (Compose g h)). 73 | Defined. 74 | 75 | Definition HomFunctor : SpecializedFunctor (COp * C) TypeCat. 76 | refine (Build_SpecializedFunctor (COp * C) TypeCat 77 | (fun c'c : COp * C => C.(Morphism) (fst c'c) (snd c'c) : TypeCat) 78 | (fun X Y (hf : (COp * C).(Morphism) X Y) => hom_functor_morphism_of hf) 79 | _ 80 | _ 81 | ); 82 | abstract ( 83 | intros; simpl in *; destruct_hypotheses; 84 | simpl in *; 85 | repeat (apply functional_extensionality_dep; intro); 86 | autorewrite with morphism; reflexivity 87 | ). 88 | Defined. 89 | End HomFunctor. 90 | 91 | Section SplitHomFunctor. 92 | Context `(C : @SpecializedCategory objC). 93 | Let COp := OppositeCategory C. 94 | 95 | Lemma SplitHom (X Y : COp * C) : forall gh, 96 | MorphismOf (HomFunctor C) (s := X) (d := Y) gh = 97 | (Compose 98 | (MorphismOf (ContravariantHomFunctor C (snd Y)) (s := fst X) (d := fst Y) (fst gh)) 99 | (MorphismOf (CovariantHomFunctor C (fst X)) (s := snd X) (d := snd Y) (snd gh))). 100 | Proof. 101 | destruct X, Y. 102 | intro gh; destruct gh. 103 | simpl in *. 104 | apply functional_extensionality_dep; intro. 105 | autorewrite with morphism. 106 | reflexivity. 107 | Qed. 108 | 109 | Lemma SplitHom' (X Y : COp * C) : forall gh, 110 | MorphismOf (HomFunctor C) (s := X) (d := Y) gh = 111 | (Compose 112 | (MorphismOf (CovariantHomFunctor C (fst Y)) (s := snd X) (d := snd Y) (snd gh)) 113 | (MorphismOf (ContravariantHomFunctor C (snd X)) (s := fst X) (d := fst Y) (fst gh))). 114 | Proof. 115 | destruct X, Y. 116 | intro gh; destruct gh. 117 | simpl in *. 118 | apply functional_extensionality_dep; intro. 119 | autorewrite with morphism. 120 | reflexivity. 121 | Qed. 122 | End SplitHomFunctor. 123 | -------------------------------------------------------------------------------- /LimitFunctorTheorems.v: -------------------------------------------------------------------------------- 1 | Require Export LimitFunctors. 2 | Require Import Common DefinitionSimplification SpecializedCategory Functor NaturalTransformation. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section InducedMaps. 13 | (** Quoting David: 14 | Given a commutative triangle consisting of 15 | [[ 16 | G 17 | C_1 -------> C_2 18 | \ / 19 | \ / 20 | \ / 21 | F_1 \ / F_2 22 | _\| |/_ 23 | D 24 | ]] 25 | there are induced maps in [D], 26 | [colim G : colim F_1 -> colim F_2] 27 | and 28 | [lim G : lim F_2 -> lim F_1] 29 | 30 | To get a feel for why this is true (and for the variance of colim 31 | vs. lim), imagine that [C_1] is the discrete category on 1 object, 32 | that [C_2] is the discrete category on 2 objects, that that [G] 33 | is one or the other inclusion, and that [D = Set]. Then [colim G] 34 | injects one set into its union with another and [lim G] projects a 35 | product of two sets onto one factor. 36 | *) 37 | Context `(C1 : @SpecializedCategory objC1). 38 | Context `(C2 : @SpecializedCategory objC2). 39 | Context `(D : @SpecializedCategory objD). 40 | Variable F1 : SpecializedFunctor C1 D. 41 | Variable F2 : SpecializedFunctor C2 D. 42 | Variable G : SpecializedFunctor C1 C2. 43 | 44 | Section Limit. 45 | Variable T : NaturalTransformation (ComposeFunctors F2 G) F1. 46 | 47 | Hypothesis F1_Limit : Limit F1. 48 | Hypothesis F2_Limit : Limit F2. 49 | 50 | Let limF1 := LimitObject F1_Limit. 51 | Let limF2 := LimitObject F2_Limit. 52 | 53 | Definition InducedLimitMapNT' : SpecializedNaturalTransformation ((DiagonalFunctor D C1) limF2) F1. 54 | unfold LimitObject, Limit in *; 55 | intro_universal_morphisms. 56 | subst limF1 limF2. 57 | match goal with 58 | | [ t : _, F : _, T : _ |- _ ] => eapply (NTComposeT (NTComposeT T (NTComposeF t (IdentityNaturalTransformation F))) _) 59 | end. 60 | Grab Existential Variables. 61 | unfold ComposeFunctors at 1. 62 | simpl. 63 | match goal with 64 | | [ |- SpecializedNaturalTransformation ?F ?G ] => 65 | refine (Build_SpecializedNaturalTransformation F G 66 | (fun x => Identity _) 67 | _ 68 | ) 69 | end. 70 | simpl; reflexivity. 71 | Defined. 72 | 73 | Definition InducedLimitMapNT'' : SpecializedNaturalTransformation ((DiagonalFunctor D C1) limF2) F1. 74 | simpl_definition_by_exact InducedLimitMapNT'. 75 | Defined. 76 | 77 | (* Then we clean up a bit with reduction. *) 78 | Definition InducedLimitMapNT : SpecializedNaturalTransformation ((DiagonalFunctor D C1) limF2) F1 79 | := Eval cbv beta iota zeta delta [InducedLimitMapNT''] in InducedLimitMapNT''. 80 | 81 | Definition InducedLimitMap : D.(Morphism) limF2 limF1 82 | := TerminalProperty_Morphism F1_Limit _ InducedLimitMapNT. 83 | End Limit. 84 | 85 | Section Colimit. 86 | Variable T : NaturalTransformation F1 (ComposeFunctors F2 G). 87 | 88 | Hypothesis F1_Colimit : Colimit F1. 89 | Hypothesis F2_Colimit : Colimit F2. 90 | 91 | Let colimF1 := ColimitObject F1_Colimit. 92 | Let colimF2 := ColimitObject F2_Colimit. 93 | 94 | Definition InducedColimitMapNT' : SpecializedNaturalTransformation F1 ((DiagonalFunctor D C1) colimF2). 95 | unfold ColimitObject, Colimit in *; 96 | intro_universal_morphisms. 97 | subst colimF1 colimF2. 98 | match goal with 99 | | [ t : _, F : _, T : _ |- _ ] => eapply (NTComposeT _ (NTComposeT (NTComposeF t (IdentityNaturalTransformation F)) T)) 100 | end. 101 | Grab Existential Variables. 102 | unfold ComposeFunctors at 1. 103 | simpl. 104 | match goal with 105 | | [ |- SpecializedNaturalTransformation ?F ?G ] => 106 | refine (Build_SpecializedNaturalTransformation F G 107 | (fun x => Identity _) 108 | _ 109 | ) 110 | end. 111 | simpl; reflexivity. 112 | Defined. 113 | 114 | Definition InducedColimitMapNT'' : SpecializedNaturalTransformation F1 ((DiagonalFunctor D C1) colimF2). 115 | simpl_definition_by_exact InducedColimitMapNT'. 116 | Defined. 117 | 118 | (* Then we clean up a bit with reduction. *) 119 | Definition InducedColimitMapNT : SpecializedNaturalTransformation F1 ((DiagonalFunctor D C1) colimF2) 120 | := Eval cbv beta iota zeta delta [InducedColimitMapNT''] in InducedColimitMapNT''. 121 | 122 | Definition InducedColimitMap : Morphism D colimF1 colimF2 123 | := InitialProperty_Morphism F1_Colimit _ InducedColimitMapNT. 124 | End Colimit. 125 | End InducedMaps. 126 | -------------------------------------------------------------------------------- /SigSigTCategory.v: -------------------------------------------------------------------------------- 1 | Require Import JMeq. 2 | Require Export SpecializedCategory Functor SigTCategory. 3 | Require Import Common Notations. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Infix "==" := JMeq. 14 | 15 | Section sig_sigT_obj_mor. 16 | Context `(A : @SpecializedCategory objA). 17 | Variable Pobj : objA -> Prop. 18 | Variable Pmor : forall s d : sig Pobj, A.(Morphism) (proj1_sig s) (proj1_sig d) -> Type. 19 | 20 | Variable Pidentity : forall x, @Pmor x x (Identity (C := A) _). 21 | Variable Pcompose : forall s d d', forall m1 m2, @Pmor d d' m1 -> @Pmor s d m2 -> @Pmor s d' (Compose (C := A) m1 m2). 22 | 23 | Hypothesis P_Associativity : forall o1 o2 o3 o4 m1 m2 m3 m1' m2' m3', 24 | @Pcompose o1 o2 o4 _ m1 (@Pcompose o2 o3 o4 m3 m2 m3' m2') m1' == 25 | @Pcompose o1 o3 o4 m3 _ m3' (@Pcompose o1 o2 o3 m2 m1 m2' m1'). 26 | 27 | Hypothesis P_LeftIdentity : forall a b f f', 28 | @Pcompose a b b _ f (@Pidentity b) f' == 29 | f'. 30 | 31 | Hypothesis P_RightIdentity : forall a b f f', 32 | @Pcompose a a b f _ f' (@Pidentity a) == 33 | f'. 34 | 35 | Definition SpecializedCategory_sig_sigT : @SpecializedCategory (sig Pobj). 36 | match goal with 37 | | [ |- @SpecializedCategory ?obj ] => 38 | refine (@Build_SpecializedCategory obj 39 | (fun s d => sigT (@Pmor s d)) 40 | (fun x => existT _ (Identity (C := A) (proj1_sig x)) (Pidentity x)) 41 | (fun s d d' m1 m2 => existT _ (Compose (C := A) (projT1 m1) (projT1 m2)) (Pcompose (projT2 m1) (projT2 m2))) 42 | _ 43 | _ 44 | _ 45 | ) 46 | end; 47 | abstract (intros; simpl_eq; auto with category). 48 | Defined. 49 | 50 | Let sig_of_sigT' (A : Type) (P : A -> Prop) (X : sigT P) := exist P (projT1 X) (projT2 X). 51 | Let sigT_of_sig' (A : Type) (P : A -> Prop) (X : sig P) := existT P (proj1_sig X) (proj2_sig X). 52 | 53 | Let Pmor' (s d : sigT Pobj) : A.(Morphism) (projT1 s) (projT1 d) -> Type := @Pmor (sig_of_sigT' s) (sig_of_sigT' d). 54 | Let Pidentity' x : @Pmor' x x (Identity (C := A) _) := Pidentity (sig_of_sigT' x). 55 | Let Pcompose' s d d' : forall m1 m2, @Pmor' d d' m1 -> @Pmor' s d m2 -> @Pmor' s d' (Compose (C := A) m1 m2) 56 | := @Pcompose (sig_of_sigT' s) (sig_of_sigT' d) (sig_of_sigT' d'). 57 | Let P_Associativity' o1 o2 o3 o4 m1 m2 m3 m1' m2' m3' : 58 | @Pcompose' o1 o2 o4 _ m1 (@Pcompose' o2 o3 o4 m3 m2 m3' m2') m1' == 59 | @Pcompose' o1 o3 o4 m3 _ m3' (@Pcompose' o1 o2 o3 m2 m1 m2' m1') 60 | := P_Associativity m1' m2' m3'. 61 | Let P_LeftIdentity' a b f f' : 62 | @Pcompose' a b b _ f (@Pidentity' b) f' == 63 | f' 64 | := P_LeftIdentity f'. 65 | Let P_RightIdentity' a b f f' : 66 | @Pcompose' a a b f _ f' (@Pidentity' a) == 67 | f' 68 | := P_RightIdentity f'. 69 | 70 | Let SpecializedCategory_sig_sigT_as_sigT : @SpecializedCategory (sigT Pobj). 71 | eapply (@SpecializedCategory_sigT _ A 72 | Pobj 73 | Pmor' 74 | Pidentity' 75 | Pcompose' 76 | ); 77 | trivial. 78 | Defined. 79 | 80 | Definition sig_sigT_functor_sigT_MorphismOf (s d : {x | Pobj x}) (m : sigT (Pmor s d)) : sigT (Pmor' s d). 81 | subst_body; destruct s, d; simpl in *; eta_red; exact m. 82 | Defined. 83 | 84 | Definition sig_sigT_functor_sigT : SpecializedFunctor SpecializedCategory_sig_sigT SpecializedCategory_sig_sigT_as_sigT. 85 | refine (Build_SpecializedFunctor SpecializedCategory_sig_sigT SpecializedCategory_sig_sigT_as_sigT 86 | (fun x => x) 87 | (@sig_sigT_functor_sigT_MorphismOf) 88 | _ 89 | _ 90 | ); 91 | abstract (intros; simpl; destruct_sig; reflexivity). 92 | Defined. 93 | 94 | Definition sigT_functor_sig_sigT_MorphismOf (s d : sigT Pobj) (m : sigT (Pmor' s d)) : sigT (Pmor s d). 95 | subst_body; destruct s, d; simpl in *; eta_red; exact m. 96 | Defined. 97 | 98 | Definition sigT_functor_sig_sigT : SpecializedFunctor SpecializedCategory_sig_sigT_as_sigT SpecializedCategory_sig_sigT. 99 | refine (Build_SpecializedFunctor SpecializedCategory_sig_sigT_as_sigT SpecializedCategory_sig_sigT 100 | (fun x => x) 101 | (@sigT_functor_sig_sigT_MorphismOf) 102 | _ 103 | _ 104 | ); 105 | abstract (intros; simpl; destruct_sig; reflexivity). 106 | Defined. 107 | 108 | Lemma sig_sigT_sigT_compat : 109 | ComposeFunctors sig_sigT_functor_sigT sigT_functor_sig_sigT = IdentityFunctor _ /\ 110 | ComposeFunctors sigT_functor_sig_sigT sig_sigT_functor_sigT = IdentityFunctor _. 111 | split; functor_eq; destruct_sig; reflexivity. 112 | Qed. 113 | 114 | Definition proj1_functor_sig_sigT : SpecializedFunctor SpecializedCategory_sig_sigT A 115 | := ComposeFunctors projT1_functor sig_sigT_functor_sigT. 116 | End sig_sigT_obj_mor. 117 | -------------------------------------------------------------------------------- /Grothendieck.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory Functor. 2 | Require Import Common SetCategory. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section Grothendieck. 13 | (** 14 | Quoting Wikipedia: 15 | The Grothendieck construction is an auxiliary construction used 16 | in the mathematical field of category theory. 17 | 18 | Let 19 | [F : C -> Set] 20 | be a functor from any small category to the category of sets. 21 | The Grothendieck construct for [F] is the category [Γ F] whose 22 | objects are pairs [(c, x)], where c\in C is an 23 | object and [x : F c] is an element, and for which the set 24 | [Hom (Γ F) (c1, x1) (c2, x2)] is the set of morphisms 25 | [f : c1 -> c2] in [C] such that [F.(MorphismOf) f x1 = x2]. 26 | *) 27 | Context `(C : @SpecializedCategory objC). 28 | Variable F : SpecializedFunctor C TypeCat. 29 | Variable F' : SpecializedFunctor C SetCat. 30 | 31 | Record GrothendieckPair := { 32 | GrothendieckC' : objC; 33 | GrothendieckX' : F GrothendieckC' 34 | }. 35 | 36 | Section GrothendieckInterface. 37 | Variable G : GrothendieckPair. 38 | 39 | Definition GrothendieckC : C := G.(GrothendieckC'). 40 | Definition GrothendieckX : F GrothendieckC := G.(GrothendieckX'). 41 | End GrothendieckInterface. 42 | 43 | Lemma GrothendieckPair_eta (x : GrothendieckPair) : Build_GrothendieckPair (GrothendieckC x) (GrothendieckX x) = x. 44 | destruct x; reflexivity. 45 | Qed. 46 | 47 | Record SetGrothendieckPair := { 48 | SetGrothendieckC' : objC; 49 | SetGrothendieckX' : F' SetGrothendieckC' 50 | }. 51 | 52 | Section SetGrothendieckInterface. 53 | Variable G : SetGrothendieckPair. 54 | 55 | Definition SetGrothendieckC : C := G.(SetGrothendieckC'). 56 | Definition SetGrothendieckX : F' SetGrothendieckC := G.(SetGrothendieckX'). 57 | End SetGrothendieckInterface. 58 | 59 | Lemma SetGrothendieckPair_eta (x : SetGrothendieckPair) : Build_SetGrothendieckPair (SetGrothendieckC x) (SetGrothendieckX x) = x. 60 | destruct x; reflexivity. 61 | Qed. 62 | 63 | Definition GrothendieckCompose cs xs cd xd cd' xd' : 64 | { f : C.(Morphism) cd cd' | F.(MorphismOf) f xd = xd' } -> { f : C.(Morphism) cs cd | F.(MorphismOf) f xs = xd } -> 65 | { f : C.(Morphism) cs cd' | F.(MorphismOf) f xs = xd' }. 66 | intros m2 m1. 67 | exists (Compose (proj1_sig m2) (proj1_sig m1)). 68 | abstract ( 69 | destruct m1, m2; 70 | rewrite FCompositionOf; 71 | unfold TypeCat, Compose; 72 | t_rev_with t' 73 | ). 74 | Defined. 75 | 76 | Arguments GrothendieckCompose [cs xs cd xd cd' xd'] / _ _. 77 | 78 | Definition GrothendieckIdentity c x : { f : C.(Morphism) c c | F.(MorphismOf) f x = x }. 79 | exists (Identity c). 80 | abstract ( 81 | rewrite FIdentityOf; 82 | unfold TypeCat, Identity; 83 | reflexivity 84 | ). 85 | Defined. 86 | 87 | Hint Extern 1 (@eq (sig _) _ _) => simpl_eq : category. 88 | 89 | Definition CategoryOfElements : @SpecializedCategory GrothendieckPair. 90 | refine (@Build_SpecializedCategory _ 91 | (fun s d => 92 | { f : C.(Morphism) (GrothendieckC s) (GrothendieckC d) | F.(MorphismOf) f (GrothendieckX s) = (GrothendieckX d) }) 93 | (fun o => GrothendieckIdentity (GrothendieckC o) (GrothendieckX o)) 94 | (fun _ _ _ m1 m2 => GrothendieckCompose m1 m2) 95 | _ 96 | _ 97 | _); 98 | abstract ( 99 | unfold GrothendieckC, GrothendieckX, GrothendieckCompose, GrothendieckIdentity in *; 100 | intros; destruct_type GrothendieckPair; destruct_sig; eauto with category 101 | ). 102 | Defined. 103 | 104 | Definition GrothendieckFunctor : SpecializedFunctor CategoryOfElements C. 105 | refine {| ObjectOf := (fun o : CategoryOfElements => GrothendieckC o); 106 | MorphismOf := (fun s d (m : CategoryOfElements.(Morphism) s d) => proj1_sig m) 107 | |}; abstract (eauto with category; intros; destruct_type CategoryOfElements; simpl; reflexivity). 108 | Defined. 109 | End Grothendieck. 110 | 111 | Section SetGrothendieckCoercion. 112 | Context `(C : @SpecializedCategory objC). 113 | Variable F : SpecializedFunctor C SetCat. 114 | Let F' := (F : SpecializedFunctorToSet _) : SpecializedFunctorToType _. 115 | 116 | Definition SetGrothendieck2Grothendieck (G : SetGrothendieckPair F) : GrothendieckPair F' 117 | := {| GrothendieckC' := G.(SetGrothendieckC'); GrothendieckX' := G.(SetGrothendieckX') : F' _ |}. 118 | End SetGrothendieckCoercion. 119 | 120 | Coercion SetGrothendieck2Grothendieck : SetGrothendieckPair >-> GrothendieckPair. 121 | -------------------------------------------------------------------------------- /GrothendieckFunctorial.v: -------------------------------------------------------------------------------- 1 | Require Import JMeq. 2 | Require Export Grothendieck FunctorCategory SetCategory. 3 | Require Import Common Notations SmallCat SpecializedCommaCategory NatCategory FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Section GrothendieckNondependentFunctorial. 14 | Local Open Scope category_scope. 15 | Local Notation "Cat / C" := (SliceSpecializedCategoryOver Cat C). 16 | 17 | Context `(C : @LocallySmallSpecializedCategory objC). 18 | 19 | Let Cat := LocallySmallCat. 20 | 21 | Section functorial. 22 | Section object_of. 23 | Definition CategoryOfElementsFunctorial_ObjectOf 24 | (x : TypeCat ^ C) 25 | : Cat / C. 26 | hnf. 27 | match goal with 28 | | [ |- CommaSpecializedCategory_Object ?F ?G ] => refine (_ : CommaSpecializedCategory_ObjectT F G) 29 | end. 30 | hnf; simpl. 31 | exists (((CategoryOfElements x 32 | : LocallySmallSpecializedCategory _) 33 | : LocallySmallCategory), 34 | tt). 35 | exact (GrothendieckFunctor _). 36 | Defined. 37 | End object_of. 38 | 39 | Section morphism_of. 40 | Variables F G : SpecializedFunctor C TypeCat. 41 | Variable T : SpecializedNaturalTransformation F G. 42 | 43 | Definition CategoryOfElementsFunctorial'_MorphismOf_ObjectOf 44 | : CategoryOfElements F -> CategoryOfElements G 45 | := fun x => Build_GrothendieckPair _ 46 | _ 47 | (T (GrothendieckC x) (GrothendieckX x)). 48 | 49 | Definition CategoryOfElementsFunctorial'_MorphismOf_MorphismOf 50 | s d (m : Morphism (CategoryOfElements F) s d) 51 | : Morphism (CategoryOfElements G) 52 | (CategoryOfElementsFunctorial'_MorphismOf_ObjectOf s) 53 | (CategoryOfElementsFunctorial'_MorphismOf_ObjectOf d). 54 | exists (proj1_sig m). 55 | abstract ( 56 | destruct m; 57 | let H := fresh in 58 | pose proof (Commutes T) as H; 59 | simpl in *; 60 | fg_equal; 61 | repeat rewrite_rev_hyp; 62 | reflexivity 63 | ). 64 | Defined. 65 | 66 | Definition CategoryOfElementsFunctorial'_MorphismOf 67 | : Functor (CategoryOfElements F) (CategoryOfElements G). 68 | refine (Build_SpecializedFunctor (CategoryOfElements F) (CategoryOfElements G) 69 | CategoryOfElementsFunctorial'_MorphismOf_ObjectOf 70 | CategoryOfElementsFunctorial'_MorphismOf_MorphismOf 71 | _ 72 | _); 73 | abstract (simpl; simpl_eq; reflexivity). 74 | Defined. 75 | 76 | Definition CategoryOfElementsFunctorial_MorphismOf 77 | : Morphism (Cat / C) 78 | (CategoryOfElementsFunctorial_ObjectOf F) 79 | (CategoryOfElementsFunctorial_ObjectOf G). 80 | hnf. 81 | match goal with 82 | | [ |- CommaSpecializedCategory_Morphism ?F ?G ] 83 | => refine (_ : CommaSpecializedCategory_MorphismT F G) 84 | end. 85 | hnf; simpl. 86 | exists (CategoryOfElementsFunctorial'_MorphismOf, eq_refl). 87 | abstract (simpl; functor_eq). 88 | Defined. 89 | End morphism_of. 90 | 91 | Local Ltac t := 92 | repeat match goal with 93 | | _ => intro 94 | | _ => reflexivity 95 | | _ => progress simpl_eq 96 | | _ => progress destruct_head_hnf @GrothendieckPair 97 | | _ => progress apply f_equal 98 | | _ => progress apply Functor_eq 99 | | _ => progress JMeq_eq 100 | | _ => progress expand 101 | end. 102 | 103 | Definition CategoryOfElementsFunctorial' 104 | : SpecializedFunctor (TypeCat ^ C) Cat. 105 | refine (Build_SpecializedFunctor (TypeCat ^ C) Cat 106 | (fun x => CategoryOfElements x : LocallySmallSpecializedCategory _) 107 | CategoryOfElementsFunctorial'_MorphismOf 108 | _ 109 | _); 110 | abstract t. 111 | Defined. 112 | 113 | Definition CategoryOfElementsFunctorial 114 | : SpecializedFunctor (TypeCat ^ C) (Cat / C). 115 | refine (Build_SpecializedFunctor (TypeCat ^ C) (Cat / C) 116 | CategoryOfElementsFunctorial_ObjectOf 117 | CategoryOfElementsFunctorial_MorphismOf 118 | _ 119 | _); 120 | abstract t. 121 | Defined. 122 | End functorial. 123 | End GrothendieckNondependentFunctorial. 124 | -------------------------------------------------------------------------------- /NaturalNumbersObject.v: -------------------------------------------------------------------------------- 1 | Require Export SpecializedCategory. 2 | Require Import CategoryIsomorphisms. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section preobject. 13 | (** Quoting nCatLab (http://ncatlab.org/nlab/show/natural+numbers+object): 14 | 15 | Idea 16 | 17 | Recall that a topos is a category that behaves likes the category 18 | Set of sets. 19 | 20 | A natural numbers object (NNO) in a topos is an object that 21 | behaves in that topos like the set ℕ of natural numbers does in 22 | Set; thus it provides a formulation of the “axiom of infinity” in 23 | structural set theory (such as ETCS). The definition is due to 24 | William Lawvere. 25 | 26 | Definition 27 | 28 | In a topos or cartesian closed category: 29 | 30 | A natural numbers object in a topos (or any cartesian closed 31 | category) E with terminal object 1 is 32 | * an object ℕ in E 33 | * equipped with 34 | + a morphism [z : 1 → ℕ] from the terminal object 1; 35 | + a morphism [s : ℕ → ℕ] (successor); 36 | * such that 37 | + for every other diagram [1 -- q --> A -- f --> A] 38 | + there is a unique morphism [u : ℕ → A] such that 39 | [[ 40 | z s 41 | 1 -----> ℕ -----> ℕ 42 | \ | | 43 | q \ | u | u 44 | \ | | 45 | ↘ ↓ f ↓ 46 | A -----> A 47 | ]] 48 | 49 | All this may be summed up by saying that a natural numbers 50 | object is an initial algebra for the endofunctor 51 | [X ↦ 1 + X]. Equivalently, it is an initial algebra for the 52 | endo-profunctor [Hom E (1 , =) × Hom E (− , =)]. 53 | 54 | By the universal property, the natural numbers object is unique 55 | up to isomorphism. 56 | 57 | In a general category with finite products 58 | 59 | Note that this definition actually makes sense in any category E 60 | having finite products. However, if E is not cartesian closed, 61 | then it is better to explicitly assume a stronger version of 62 | this definition “with parameters” (which follows automatically 63 | when E is cartesian closed, such as when E is a topos). What 64 | this amounts to is demanding that (ℕ,z,s) not only be a natural 65 | numbers object (in the above, unparametrized sense) in E, but 66 | that also, for each object A, this is preserved by the free 67 | coalgebra functor into the Kleisli category of the comonad X↦A×X 68 | (which may be thought of as the category of maps parametrized by 69 | A). (Put another way, the finite product structure of E gives 70 | rise to a canonical self-indexing, and we are demanding the 71 | existence of an (unparametrized) NNO within this indexed 72 | category, rather than just within the base E). 73 | 74 | The functions which are constructable out of the structure of a 75 | category with finite products and such a “parametrized NNO” are 76 | precisely the primitive recursive? ones. Specifically, the 77 | unique structure-preserving functor from the free such category 78 | F into Set yields a bijection between Hom F(1,ℕ) and the actual 79 | natural numbers, as well as surjections from Hom F(ℕ m,ℕ) onto 80 | the primitive recursive functions of arity m for each finite 81 | m. With cartesian closure, however, this identification no 82 | longer holds, since non-primitive recursive functions (such as 83 | the Ackermann function?) become definable as well. 84 | *) 85 | 86 | (** XXX nCatLab says that we're not in a topos, we need a stronger 87 | notion of natural numbers object. But I want the natural 88 | numbers object to prove that [Set] is cartesian, and I don't 89 | have the other notions yet. So I'll call this a 90 | [NaturalNumbersPreObject], to make the distinction slightly 91 | more obvious. *) 92 | 93 | Context `(E : SpecializedCategory objE). 94 | 95 | Local Reserved Notation "'ℕ'". 96 | Local Reserved Notation "'S'". 97 | 98 | Record NaturalNumbersPreObject := 99 | { 100 | NaturalNumbersPreObject_Object :> E where "'ℕ'" := NaturalNumbersPreObject_Object; 101 | NaturalNumbersPreObject_TerminalObject : TerminalObject E where "1" := (NaturalNumbersPreObject_TerminalObject : E); 102 | NaturalNumbersPreObject_Zero : Morphism E 1 ℕ where "0" := NaturalNumbersPreObject_Zero; 103 | NaturalNumbersPreObject_Successor : Morphism E ℕ ℕ where "'S'" := NaturalNumbersPreObject_Successor; 104 | NaturalNumbersPreObject_Property : forall A (q : Morphism E 1 A) (f : Morphism E A A), 105 | { u : Morphism E ℕ A | 106 | unique (fun u => Compose u 0 = q 107 | /\ Compose f u = Compose u S) 108 | u } 109 | }. 110 | End preobject. 111 | -------------------------------------------------------------------------------- /SQLQueries.v: -------------------------------------------------------------------------------- 1 | Require Import List Setoid Classes.RelationClasses. 2 | Require Export Database. 3 | 4 | Set Implicit Arguments. 5 | 6 | Set Asymmetric Patterns. 7 | 8 | Set Universe Polymorphism. 9 | 10 | (** * Operations *) 11 | Section sql. 12 | (** [SelectFromTable fromR toR cs] is the SQL query [SELECT cs FROM 13 | fromR], and [toR] is the resulting schema. This operation is 14 | specific to a single table. *) 15 | 16 | Fixpoint SelectFromTable fromR toR (cs : ColumnList fromR toR) : Row fromR -> Row toR 17 | := match cs in (ColumnList fromR toR) return (Row fromR -> Row toR) with 18 | | CNil _ => 19 | fun _ => RNil 20 | | CCons T fromTs toTs c cs' => 21 | fun r => RCons (getColumn c r) (SelectFromTable cs' r) 22 | end. 23 | 24 | (** [UnionAllTables2 r t1 t2] is the SQL query [SELECT * 25 | FROM t1 UNION ALL SELECT * FROM t2]. *) 26 | Definition UnionAllTables2 (r : RowType) (t1 t2 : Table r) : Table r 27 | := t1 ++ t2. 28 | 29 | (** [UnionAllTables r [t1, t2, ..., tn]] is the SQL query [SELECT * 30 | FROM t1 UNION ALL SELECT * FROM t2 UNION ALL ... UNION ALL SELECT 31 | * FROM tn]. *) 32 | Definition UnionAllTables (r : RowType) (ts : list (Table r)) : Table r 33 | := fold_left (@UnionAllTables2 r) ts nil. 34 | 35 | (** [UnionTables2 r t1 t2] is the SQL query [SELECT * FROM t1 UNION 36 | SELECT * FROM t2]; it removes duplicates *) 37 | 38 | Definition UnionTables2 (r : RowType) (H : RowTypeDecidable _ _ r) (t1 t2 : Table r) : Table r 39 | := unique_from (Row_eq H) (UnionAllTables2 t1 t2). 40 | 41 | (** [UnionTables r [t1, t2, ..., tn]] is the SQL query [SELECT * 42 | FROM t1 UNION SELECT * FROM t2 UNION ... UNION SELECT * FROM 43 | tn]. It removes duplicates. *) 44 | 45 | Definition UnionTables (r : RowType) (H : RowTypeDecidable _ _ r) (ts : list (Table r)) : Table r 46 | := unique_from (Row_eq H) (UnionAllTables ts). 47 | 48 | 49 | (** ** CROSS JOIN *) 50 | (** Quoting Wikipedia (http://en.wikipedia.org/wiki/Join_(SQL)): 51 | 52 | CROSS JOIN returns the Cartesian product of rows from tables in 53 | the join. In other words, it will produce rows which combine 54 | each row from the first table with each row from the second 55 | table.[1] 56 | 57 | Example of an explicit cross join: 58 | 59 | << 60 | SELECT * 61 | FROM employee CROSS JOIN department; 62 | >> 63 | 64 | Example of an implicit cross join: 65 | 66 | << 67 | SELECT * 68 | FROM employee, department; 69 | >> 70 | *) 71 | 72 | (** [app_list [a b c ...] = a ++ b ++ c ++ ...] *) 73 | Let app_list A := fold_right (@app A) nil. 74 | 75 | Definition CrossJoinRowTypes2 (r1 r2 : RowType) : RowType := r1 ++ r2. 76 | Definition CrossJoinRowTypes (rs : list RowType) : RowType := app_list rs. 77 | 78 | Fixpoint CrossJoinTables2_helper r1 (t10 : Row r1) r2 (t2 : Table r2) 79 | : Table (CrossJoinRowTypes2 r1 r2) 80 | := match t2 with 81 | | nil => nil 82 | | t20 :: t2s => (RowApp t10 t20) 83 | :: CrossJoinTables2_helper t10 t2s 84 | end. 85 | 86 | (** [CrossJoinTables2 r1 t1 r2 t2] is the SQL query [SELECT * FROM 87 | t1 CROSS JOIN t2]. It contains all pairs of rows from [t1] and 88 | [t2]. *) 89 | 90 | Fixpoint CrossJoinTables2 r1 (t1 : Table r1) r2 (t2 : Table r2) 91 | : Table (CrossJoinRowTypes2 r1 r2) 92 | := match t1 with 93 | | nil => nil 94 | | t10 :: t1s => (CrossJoinTables2_helper t10 t2) 95 | ++ CrossJoinTables2 t1s t2 96 | end. 97 | 98 | (** A [Database] is a list of tables. We can cross join all of them. *) 99 | Fixpoint CrossJoinTables (DT : list RowType) (ts : DatabaseInstance DT) 100 | : Table (CrossJoinRowTypes DT) 101 | := match ts with 102 | | DNil => nil 103 | | DCons _ _ t ts => CrossJoinTables2 t (CrossJoinTables ts) 104 | end. 105 | 106 | (** [Filter1 r T P c t] is the SQL query [SELECT * FROM t WHERE P(c)] 107 | *) 108 | 109 | Definition Filter1 (r : RowType) T (P : T -> bool) (c : Column T r) 110 | : Table r -> Table r 111 | := filter (fun r0 : Row r => P (getColumn c r0)). 112 | Definition Filter2 (r : RowType) T1 T2 (P : T1 -> T2 -> bool) (c1 : Column T1 r) (c2 : Column T2 r) 113 | : Table r -> Table r 114 | := filter (fun r0 : Row r => P (getColumn c1 r0) (getColumn c2 r0)). 115 | 116 | (* TODO(jgross): Add [Filter n] for arbitrary [n] *) 117 | 118 | (** [FilterEqual r T eq_dec c1 c2 t] is the SQL query [SELECT * FROM t WHERE c1 119 | = c2]. *) 120 | Definition FilterEqual r T (eq_dec : forall x y : T, {x = y} + {x <> y}) 121 | := @Filter2 r T T (fun x y => if eq_dec x y then true else false). 122 | 123 | (** [InnerJoinTables2 r1 t1 r2 t2 T c1 c2] is the SQL query [SELECT * FROM t1 124 | INNTER JOIN t2 ON t1.c1 = t2.c2]. *) 125 | Definition InnerJoinTables2 r1 (t1 : Table r1) r2 (t2 : Table r2) 126 | T 127 | (eq_dec : forall x y : T, {x = y} + {x <> y}) 128 | (c1 : Column T r1) 129 | (c2 : Column T r2) 130 | (t1 : Table r1) 131 | (t2 : Table r2) 132 | : Table (CrossJoinRowTypes2 r1 r2) 133 | := FilterEqual eq_dec 134 | (@Column_RowApp_Left r1 r2 T c1) 135 | (@Column_RowApp_Right r1 r2 T c2) 136 | (CrossJoinTables2 t1 t2). 137 | End sql. 138 | -------------------------------------------------------------------------------- /ProductLaws.v: -------------------------------------------------------------------------------- 1 | Require Export NatCategory ProductCategory. 2 | Require Import Common Notations. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Local Open Scope category_scope. 13 | 14 | Section swap. 15 | Definition SwapFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) 16 | : SpecializedFunctor (C * D) (D * C) 17 | := Build_SpecializedFunctor (C * D) (D * C) 18 | (fun cd => (snd cd, fst cd)) 19 | (fun _ _ m => (snd m, fst m)) 20 | (fun _ _ _ _ _ => eq_refl) 21 | (fun _ => eq_refl). 22 | 23 | Lemma ProductLawSwap `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) 24 | : ComposeFunctors (SwapFunctor C D) (SwapFunctor D C) = IdentityFunctor _. 25 | functor_eq; intuition. 26 | Qed. 27 | End swap. 28 | 29 | Section Law0. 30 | Context `(C : @SpecializedCategory objC). 31 | 32 | Definition ProductLaw0Functor : SpecializedFunctor (C * 0) 0. 33 | refine (Build_SpecializedFunctor (C * 0) 0 34 | (@snd _ _) 35 | (fun _ _ => @snd _ _) 36 | _ 37 | _); 38 | abstract ( 39 | intros; 40 | destruct_head_hnf @prod; 41 | destruct_head Empty_set 42 | ). 43 | Defined. 44 | 45 | Definition ProductLaw0Functor_Inverse : SpecializedFunctor 0 (C * 0). 46 | repeat esplit; 47 | intros; destruct_head_hnf Empty_set. 48 | Grab Existential Variables. 49 | intros; destruct_head_hnf Empty_set. 50 | intros; destruct_head_hnf Empty_set. 51 | Defined. 52 | 53 | Lemma ProductLaw0 : ComposeFunctors ProductLaw0Functor ProductLaw0Functor_Inverse = IdentityFunctor _ /\ 54 | ComposeFunctors ProductLaw0Functor_Inverse ProductLaw0Functor = IdentityFunctor _. 55 | Proof. 56 | split; functor_eq; 57 | destruct_head_hnf @prod; 58 | destruct_head_hnf Empty_set. 59 | Qed. 60 | End Law0. 61 | 62 | Section Law0'. 63 | Context `(C : @SpecializedCategory objC). 64 | 65 | Let ProductLaw0'Functor' : SpecializedFunctor (0 * C) 0. 66 | functor_simpl_abstract_trailing_props (ComposeFunctors (ProductLaw0Functor C) (SwapFunctor _ _)). 67 | Defined. 68 | Definition ProductLaw0'Functor : SpecializedFunctor (0 * C) 0 := Eval hnf in ProductLaw0'Functor'. 69 | 70 | Let ProductLaw0'Functor_Inverse' : SpecializedFunctor 0 (0 * C). 71 | functor_simpl_abstract_trailing_props (ComposeFunctors (SwapFunctor _ _) (ProductLaw0Functor_Inverse C)). 72 | Defined. 73 | Definition ProductLaw0'Functor_Inverse : SpecializedFunctor 0 (0 * C) := Eval hnf in ProductLaw0'Functor_Inverse'. 74 | 75 | Lemma ProductLaw0' : ComposeFunctors ProductLaw0'Functor ProductLaw0'Functor_Inverse = IdentityFunctor _ /\ 76 | ComposeFunctors ProductLaw0'Functor_Inverse ProductLaw0'Functor = IdentityFunctor _. 77 | Proof. 78 | split; functor_eq; 79 | destruct_head_hnf @prod; 80 | destruct_head_hnf Empty_set. 81 | Qed. 82 | End Law0'. 83 | 84 | Section Law1. 85 | Context `(C : @SpecializedCategory objC). 86 | 87 | Let ProductLaw1Functor' : SpecializedFunctor (C * 1) C. 88 | functor_simpl_abstract_trailing_props (fst_Functor (C := C) (D := 1)). 89 | Defined. 90 | Definition ProductLaw1Functor : SpecializedFunctor (C * 1) C 91 | := Eval hnf in ProductLaw1Functor'. 92 | 93 | Definition ProductLaw1Functor_Inverse : SpecializedFunctor C (C * 1). 94 | refine (Build_SpecializedFunctor C (C * 1) 95 | (fun c => (c, tt)) 96 | (fun s d m => (m, eq_refl)) 97 | _ 98 | _); 99 | abstract ( 100 | intros; simpl in *; simpl_eq; reflexivity 101 | ). 102 | Defined. 103 | 104 | Lemma ProductLaw1 : ComposeFunctors ProductLaw1Functor ProductLaw1Functor_Inverse = IdentityFunctor _ /\ 105 | ComposeFunctors ProductLaw1Functor_Inverse ProductLaw1Functor = IdentityFunctor _. 106 | Proof. 107 | split; functor_eq; 108 | destruct_head_hnf @prod; 109 | destruct_head_hnf @eq; 110 | destruct_head_hnf unit; 111 | reflexivity. 112 | Qed. 113 | End Law1. 114 | 115 | Section Law1'. 116 | Context `(C : @SpecializedCategory objC). 117 | 118 | Definition ProductLaw1'Functor' : SpecializedFunctor (1 * C) C. 119 | functor_simpl_abstract_trailing_props (ComposeFunctors (ProductLaw1Functor C) (SwapFunctor _ _)). 120 | Defined. 121 | Definition ProductLaw1'Functor : SpecializedFunctor (1 * C) C := Eval hnf in ProductLaw1'Functor'. 122 | 123 | Let ProductLaw1'Functor_Inverse' : SpecializedFunctor C (1 * C). 124 | functor_simpl_abstract_trailing_props (ComposeFunctors (SwapFunctor _ _) (ProductLaw1Functor_Inverse C)). 125 | Defined. 126 | Definition ProductLaw1'Functor_Inverse : SpecializedFunctor C (1 * C) := Eval hnf in ProductLaw1'Functor_Inverse'. 127 | 128 | Lemma ProductLaw1' : ComposeFunctors ProductLaw1'Functor ProductLaw1'Functor_Inverse = IdentityFunctor _ /\ 129 | ComposeFunctors ProductLaw1'Functor_Inverse ProductLaw1'Functor = IdentityFunctor _. 130 | Proof. 131 | split; functor_eq; 132 | destruct_head_hnf @prod; 133 | destruct_head_hnf @eq; 134 | destruct_head_hnf unit; 135 | reflexivity. 136 | Qed. 137 | End Law1'. 138 | -------------------------------------------------------------------------------- /Duals.v: -------------------------------------------------------------------------------- 1 | Require Import JMeq Eqdep. 2 | Require Export SpecializedCategory CategoryIsomorphisms Functor ProductCategory NaturalTransformation. 3 | Require Import Common Notations FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Infix "==" := JMeq. 14 | 15 | Local Open Scope category_scope. 16 | 17 | Section OppositeCategory. 18 | Definition OppositeCategory `(C : @SpecializedCategory objC) : @SpecializedCategory objC 19 | := @Build_SpecializedCategory' objC 20 | (fun s d => Morphism C d s) 21 | (Identity (C := C)) 22 | (fun _ _ _ m1 m2 => Compose m2 m1) 23 | (fun _ _ _ _ _ _ _ => @Associativity_sym _ _ _ _ _ _ _ _ _) 24 | (fun _ _ _ _ _ _ _ => @Associativity _ _ _ _ _ _ _ _ _) 25 | (fun _ _ => @RightIdentity _ _ _ _) 26 | (fun _ _ => @LeftIdentity _ _ _ _). 27 | End OppositeCategory. 28 | 29 | (*Notation "C ᵒᵖ" := (OppositeCategory C) : category_scope.*) 30 | 31 | Section DualCategories. 32 | Context `(C : @SpecializedCategory objC). 33 | Context `(D : @SpecializedCategory objD). 34 | 35 | Lemma op_op_id : OppositeCategory (OppositeCategory C) = C. 36 | clear D objD. 37 | unfold OppositeCategory; simpl. 38 | repeat change (fun a => ?f a) with f. 39 | destruct C; intros; simpl; reflexivity. 40 | Qed. 41 | 42 | Lemma op_distribute_prod : OppositeCategory (C * D) = (OppositeCategory C) * (OppositeCategory D). 43 | spcat_eq. 44 | Qed. 45 | End DualCategories. 46 | 47 | Hint Rewrite @op_op_id @op_distribute_prod : category. 48 | 49 | Section DualObjects. 50 | Context `(C : @SpecializedCategory objC). 51 | 52 | Definition terminal_opposite_initial (o : C) : IsTerminalObject o -> IsInitialObject (C := OppositeCategory C) o 53 | := fun H o' => H o'. 54 | 55 | Definition initial_opposite_terminal (o : C) : IsInitialObject o -> IsTerminalObject (C := OppositeCategory C) o 56 | := fun H o' => H o'. 57 | 58 | Definition terminal_to_opposite_initial : TerminalObject C -> InitialObject (OppositeCategory C) 59 | := Eval cbv beta iota zeta delta [terminal_opposite_initial TerminalObject_IsTerminalObject IsInitialObject_InitialObject proj1_sig proj2_sig] in 60 | fun x => terminal_opposite_initial x. 61 | 62 | Definition initial_to_opposite_terminal : InitialObject C -> TerminalObject (OppositeCategory C) 63 | := Eval cbv beta iota zeta delta [initial_opposite_terminal IsTerminalObject_TerminalObject InitialObject_IsInitialObject proj1_sig proj2_sig] in 64 | fun x => initial_opposite_terminal x. 65 | End DualObjects. 66 | 67 | Section OppositeFunctor. 68 | Context `(C : @SpecializedCategory objC). 69 | Context `(D : @SpecializedCategory objD). 70 | Variable F : SpecializedFunctor C D. 71 | Let COp := OppositeCategory C. 72 | Let DOp := OppositeCategory D. 73 | 74 | Definition OppositeFunctor : SpecializedFunctor COp DOp. 75 | refine (Build_SpecializedFunctor COp DOp 76 | (fun c : COp => F c : DOp) 77 | (fun (s d : COp) (m : C.(Morphism) d s) => MorphismOf F (s := d) (d := s) m) 78 | (fun d' d s m1 m2 => FCompositionOf F s d d' m2 m1) 79 | (FIdentityOf F) 80 | ). 81 | Defined. 82 | End OppositeFunctor. 83 | 84 | (*Notation "C ᵒᵖ" := (OppositeFunctor C) : functor_scope.*) 85 | 86 | Section OppositeFunctor_Id. 87 | Context `(C : @SpecializedCategory objC). 88 | Context `(D : @SpecializedCategory objD). 89 | Variable F : SpecializedFunctor C D. 90 | 91 | Lemma op_op_functor_id : OppositeFunctor (OppositeFunctor F) == F. 92 | functor_eq; autorewrite with category; trivial. 93 | Qed. 94 | End OppositeFunctor_Id. 95 | 96 | (* not terribly useful, given that this would make [autorewrite with core] give "Anomaly: Uncaught exception Failure("nth"). Please report." *) 97 | (*Hint Rewrite op_op_functor_id.*) 98 | 99 | Section OppositeNaturalTransformation. 100 | Context `(C : @SpecializedCategory objC). 101 | Context `(D : @SpecializedCategory objD). 102 | Variables F G : SpecializedFunctor C D. 103 | Variable T : SpecializedNaturalTransformation F G. 104 | Let COp := OppositeCategory C. 105 | Let DOp := OppositeCategory D. 106 | Let FOp := OppositeFunctor F. 107 | Let GOp := OppositeFunctor G. 108 | 109 | Definition OppositeNaturalTransformation : SpecializedNaturalTransformation GOp FOp. 110 | refine (Build_SpecializedNaturalTransformation GOp FOp 111 | (fun c : COp => T.(ComponentsOf) c : DOp.(Morphism) (GOp c) (FOp c)) 112 | (fun s d m => eq_sym (Commutes T d s m)) 113 | ). 114 | Defined. 115 | End OppositeNaturalTransformation. 116 | 117 | (*Notation "C ᵒᵖ" := (OppositeNaturalTransformation C) : natural_transformation_scope.*) 118 | 119 | Section OppositeNaturalTransformation_Id. 120 | Context `(C : @SpecializedCategory objC). 121 | Context `(D : @SpecializedCategory objD). 122 | Variables F G : SpecializedFunctor C D. 123 | Variable T : SpecializedNaturalTransformation F G. 124 | 125 | Lemma op_op_nt_id : OppositeNaturalTransformation (OppositeNaturalTransformation T) == T. 126 | nt_eq; intros; try functor_eq; autorewrite with category; subst; trivial. 127 | Qed. 128 | End OppositeNaturalTransformation_Id. 129 | 130 | (* not terribly useful, given that this would make [autorewrite with core] give "Anomaly: Uncaught exception Failure("nth"). Please report." *) 131 | (*Hint Rewrite op_op_nt_id.*) 132 | -------------------------------------------------------------------------------- /CoendFunctor.v: -------------------------------------------------------------------------------- 1 | Require Import ProofIrrelevance. 2 | Require Export Coend LimitFunctors LimitFunctors FunctorCategory ProductInducedFunctors FunctorialComposition. 3 | Require Import Common Notations. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Local Open Scope type_scope. 14 | 15 | Section Coend. 16 | Context `(C : @SpecializedCategory objC). 17 | 18 | Let COp := OppositeCategory C. 19 | 20 | Definition CoendFunctor_Index_Object := { ds : objC * objC & Morphism C (snd ds) (fst ds) } + objC. 21 | 22 | Global Arguments CoendFunctor_Index_Object /. 23 | 24 | Definition CoendFunctor_Index_Morphism (s d : CoendFunctor_Index_Object) : Set := 25 | match (s, d) with 26 | | (inl sdm, inr c) => (fst (projT1 sdm) = c) + (snd (projT1 sdm) = c) 27 | | _ => (s = d) 28 | end. 29 | 30 | Global Arguments CoendFunctor_Index_Morphism s d /. 31 | 32 | Definition CoendFunctor_Index_Identity x : CoendFunctor_Index_Morphism x x := 33 | match x as s return (CoendFunctor_Index_Morphism s s) with 34 | | inl s => eq_refl 35 | | inr s => eq_refl 36 | end. 37 | 38 | Global Arguments CoendFunctor_Index_Identity x /. 39 | 40 | Ltac inj H := injection H; clear H; intros; subst. 41 | 42 | Definition CoendFunctor_Index_Compose s d d' : 43 | CoendFunctor_Index_Morphism d d' 44 | -> CoendFunctor_Index_Morphism s d 45 | -> CoendFunctor_Index_Morphism s d'. 46 | Proof. 47 | destruct s, d, d'; simpl; intros; 48 | match goal with 49 | | [ H : _ + _ |- _ ] => destruct H; [ left | right ]; 50 | abstract congruence 51 | | _ => abstract congruence 52 | end. 53 | Defined. 54 | 55 | Definition CoendFunctor_Index : SpecializedCategory CoendFunctor_Index_Object. 56 | Proof. 57 | refine (@Build_SpecializedCategory _ 58 | CoendFunctor_Index_Morphism 59 | CoendFunctor_Index_Identity 60 | CoendFunctor_Index_Compose 61 | _ 62 | _ 63 | _); 64 | abstract ( 65 | simpl; intros; 66 | repeat (match goal with 67 | | [ x : _ + _ |- _ ] => destruct x; simpl in * 68 | | _ => apply proof_irrelevance 69 | | _ => congruence 70 | | _ => f_equal 71 | end) 72 | ). 73 | Defined. 74 | 75 | Definition CoendFunctor_Diagram_ObjectOf_pre : CoendFunctor_Index -> (COp * C) := 76 | fun x => match x with 77 | | inl c0c1 => (projT1 c0c1) 78 | | inr c => (c, c) 79 | end. 80 | 81 | Global Arguments CoendFunctor_Diagram_ObjectOf_pre _ /. 82 | 83 | Hint Extern 1 (Morphism _ ?X ?X) => apply Identity : morphism. 84 | (* Hint Extern 1 (Morphism _ _ _) => hnf. *) 85 | 86 | Definition CoendFunctor_Diagram_MorphismOf_pre s d : 87 | CoendFunctor_Index_Morphism s d 88 | -> Morphism (COp * C) (CoendFunctor_Diagram_ObjectOf_pre s) (CoendFunctor_Diagram_ObjectOf_pre d). 89 | Proof. 90 | destruct s, d; simpl in *; intros; split; 91 | repeat match goal with 92 | | _ => discriminate 93 | | _ => assumption 94 | | [ H : inl _ = inl _ |- _ ] => inj H 95 | | [ H : inr _ = inr _ |- _ ] => inj H 96 | | [ H : sigT _ |- _ ] => destruct H; simpl in * 97 | | [ H : _ + _ |- _ ] => destruct H; subst 98 | end; 99 | apply Identity. 100 | Defined. 101 | 102 | Ltac inj' H := 103 | match type of H with 104 | | ?X = ?X => fail 1 105 | | _ => injection H; intros; subst 106 | end. 107 | 108 | Definition CoendFunctor_Diagram_pre : SpecializedFunctor CoendFunctor_Index (COp * C). 109 | Proof. 110 | refine (Build_SpecializedFunctor 111 | CoendFunctor_Index (COp * C) 112 | CoendFunctor_Diagram_ObjectOf_pre 113 | CoendFunctor_Diagram_MorphismOf_pre 114 | _ 115 | _); 116 | abstract ( 117 | repeat match goal with 118 | | [ |- forall x : CoendFunctor_Index_Object, _ ] => 119 | destruct x 120 | end; simpl; intros; 121 | repeat match goal with 122 | | _ => discriminate 123 | | _ => progress (subst; unfold eq_rect_r) 124 | | [ H : inl _ = inl _ |- _ ] => inj' H 125 | | [ H : inr _ = inr _ |- _ ] => inj' H 126 | | [ x : sigT _ |- _ ] => destruct x; simpl in * 127 | | [ H : _ + _ |- _ ] => destruct H 128 | | _ => rewrite <- eq_rect_eq 129 | | _ => apply injective_projections; simpl 130 | end; auto with category 131 | ). 132 | Defined. 133 | End Coend. 134 | 135 | Section CoendFunctor. 136 | Context `(C : @SpecializedCategory objC). 137 | Context `(D : @SpecializedCategory objD). 138 | 139 | Let COp := OppositeCategory C. 140 | 141 | Hypothesis HasColimits : forall F : SpecializedFunctor (CoendFunctor_Index C) D, Colimit F. 142 | 143 | Let CoendFunctor_post := ColimitFunctor HasColimits. 144 | 145 | Let o := (FunctorialComposition (CoendFunctor_Index C) (COp * C) D). 146 | Let CoendFunctor_pre := (o ⟨ - , (CoendFunctor_Diagram_pre C) ⟩)%functor. 147 | 148 | Definition CoendFunctor := ComposeFunctors CoendFunctor_post CoendFunctor_pre. 149 | End CoendFunctor. 150 | -------------------------------------------------------------------------------- /Graphs.v: -------------------------------------------------------------------------------- 1 | Require Import FunctionalExtensionality. 2 | Require Export Functor SetCategory SmallCat FunctorCategory Paths. 3 | Require Import Common FEqualDep. 4 | 5 | Set Implicit Arguments. 6 | 7 | Generalizable All Variables. 8 | 9 | Set Asymmetric Patterns. 10 | 11 | Set Universe Polymorphism. 12 | 13 | Section GraphObj. 14 | Context `(C : @SpecializedCategory objC). 15 | 16 | Inductive GraphIndex := GraphIndexSource | GraphIndexTarget. 17 | 18 | Definition GraphIndex_Morphism (a b : GraphIndex) : Set := 19 | match (a, b) with 20 | | (GraphIndexSource, GraphIndexSource) => unit 21 | | (GraphIndexTarget, GraphIndexTarget) => unit 22 | | (GraphIndexTarget, GraphIndexSource) => Empty_set 23 | | (GraphIndexSource, GraphIndexTarget) => GraphIndex 24 | end. 25 | 26 | Global Arguments GraphIndex_Morphism a b /. 27 | 28 | Definition GraphIndex_Compose s d d' (m1 : GraphIndex_Morphism d d') (m2 : GraphIndex_Morphism s d) : 29 | GraphIndex_Morphism s d'. 30 | destruct s, d, d'; simpl in *; trivial. 31 | Defined. 32 | 33 | Definition GraphIndexingCategory : @SpecializedCategory GraphIndex. 34 | refine (@Build_SpecializedCategory _ 35 | GraphIndex_Morphism 36 | (fun x => match x with GraphIndexSource => tt | GraphIndexTarget => tt end) 37 | GraphIndex_Compose 38 | _ 39 | _ 40 | _); 41 | abstract ( 42 | intros; destruct_type GraphIndex; simpl in *; destruct_type Empty_set; trivial 43 | ). 44 | Defined. 45 | 46 | Definition UnderlyingGraph_ObjectOf x := 47 | match x with 48 | | GraphIndexSource => { sd : objC * objC & C.(Morphism) (fst sd) (snd sd) } 49 | | GraphIndexTarget => objC 50 | end. 51 | 52 | Global Arguments UnderlyingGraph_ObjectOf x /. 53 | 54 | Definition UnderlyingGraph_MorphismOf s d (m : Morphism GraphIndexingCategory s d) : 55 | UnderlyingGraph_ObjectOf s -> UnderlyingGraph_ObjectOf d := 56 | match (s, d) as sd return 57 | Morphism GraphIndexingCategory (fst sd) (snd sd) -> 58 | UnderlyingGraph_ObjectOf (fst sd) -> UnderlyingGraph_ObjectOf (snd sd) 59 | with 60 | | (GraphIndexSource, GraphIndexSource) => fun _ => @id _ 61 | | (GraphIndexSource, GraphIndexTarget) => fun m' => 62 | match m' with 63 | | GraphIndexSource => fun sdm => fst (projT1 sdm) 64 | | GraphIndexTarget => fun sdm => snd (projT1 sdm) 65 | end 66 | | (GraphIndexTarget, GraphIndexSource) => fun m' => match m' with end 67 | | (GraphIndexTarget, GraphIndexTarget) => fun _ => @id _ 68 | end m. 69 | 70 | Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat. 71 | Proof. 72 | match goal with 73 | | [ |- SpecializedFunctor ?C ?D ] => 74 | refine (Build_SpecializedFunctor C D 75 | UnderlyingGraph_ObjectOf 76 | UnderlyingGraph_MorphismOf 77 | _ 78 | _ 79 | ) 80 | end; 81 | abstract ( 82 | unfold UnderlyingGraph_MorphismOf; simpl; intros; 83 | destruct_type GraphIndex; 84 | autorewrite with morphism; 85 | trivial; try destruct_to_empty_set 86 | ). 87 | Defined. 88 | End GraphObj. 89 | 90 | Section GraphFunctor. 91 | Let UnderlyingGraphFunctor_ObjectOf (C : SmallCat) : SpecializedFunctor GraphIndexingCategory TypeCat := 92 | UnderlyingGraph C. 93 | 94 | Local Ltac t := 95 | intros; destruct_head GraphIndex; 96 | repeat match goal with 97 | | [ H : Empty_set |- _ ] => destruct H 98 | | _ => reflexivity 99 | | _ => progress destruct_head GraphIndex; simpl in * 100 | | _ => progress repeat (apply functional_extensionality_dep; intro) 101 | | _ => progress simpl_eq 102 | | _ => progress destruct_sig; simpl in * 103 | end. 104 | 105 | Definition UnderlyingGraphFunctor_MorphismOf C D (F : Morphism SmallCat C D) : 106 | Morphism (TypeCat ^ GraphIndexingCategory) (UnderlyingGraph C) (UnderlyingGraph D). 107 | Proof. 108 | exists (fun c => match c as c return (UnderlyingGraph C) c -> (UnderlyingGraph D) c with 109 | | GraphIndexSource => fun sdm => existT _ (F (fst (projT1 sdm)), F (snd (projT1 sdm))) (F.(MorphismOf) (projT2 sdm)) 110 | | GraphIndexTarget => ObjectOf F 111 | end); 112 | abstract t. 113 | Defined. 114 | 115 | Definition UnderlyingGraphFunctor : SpecializedFunctor SmallCat (TypeCat ^ GraphIndexingCategory). 116 | Proof. 117 | match goal with 118 | | [ |- SpecializedFunctor ?C ?D ] => 119 | refine (Build_SpecializedFunctor C D 120 | UnderlyingGraphFunctor_ObjectOf 121 | UnderlyingGraphFunctor_MorphismOf 122 | _ 123 | _ 124 | ) 125 | end; 126 | abstract ( 127 | repeat match goal with 128 | | _ => progress simpl in * 129 | | _ => progress functor_eq 130 | | _ => progress nt_eq 131 | | _ => progress t 132 | | _ => progress unfold ComponentsOf 133 | | [ |- appcontext[match ?x with _ => _ end] ] => destruct x 134 | end 135 | ). 136 | Defined. 137 | End GraphFunctor. 138 | 139 | Section FreeCategory. 140 | Variable F : SpecializedFunctor GraphIndexingCategory TypeCat. 141 | 142 | Let vertices := F GraphIndexTarget. 143 | 144 | Hint Rewrite concatenate_p_noedges concatenate_noedges_p concatenate_associative. 145 | 146 | Definition FreeCategory : SpecializedCategory vertices. 147 | Proof. 148 | refine (@Build_SpecializedCategory 149 | vertices 150 | _ 151 | (@NoEdges _ _) 152 | (fun s d d' m m' => @concatenate _ _ s d d' m' m) 153 | _ 154 | _ 155 | _ 156 | ); 157 | intros; autorewrite with core; reflexivity. 158 | Grab Existential Variables. 159 | (* what goes here, of type [vertices -> vertices -> Type]? *) 160 | (* morphisms are paths *) 161 | Admitted. 162 | End FreeCategory. 163 | -------------------------------------------------------------------------------- /CanonicalStructureSimplification.v: -------------------------------------------------------------------------------- 1 | Require Export LtacReifiedSimplification. 2 | Require Import SpecializedCategory Functor NaturalTransformation. 3 | 4 | Set Implicit Arguments. 5 | 6 | Generalizable All Variables. 7 | 8 | Set Asymmetric Patterns. 9 | 10 | Set Universe Polymorphism. 11 | 12 | Section SimplifiedMorphism. 13 | Section single_category. 14 | Context `{C : SpecializedCategory objC}. 15 | 16 | (* structure for packaging a morphism and its reification *) 17 | 18 | Structure TaggedMorphism s d := Tag { untag :> Morphism C s d }. 19 | 20 | Structure SimplifiedMorphism s d := 21 | ReifyMorphism 22 | { 23 | morphism_of : TaggedMorphism s d; 24 | reified_morphism_of : ReifiedMorphism C s d; 25 | reified_morphism_ok : untag morphism_of = ReifiedMorphismDenote reified_morphism_of 26 | }. 27 | Global Arguments ReifyMorphism [s d] morphism_of _ _. 28 | 29 | (* main overloaded lemma for simplification *) 30 | 31 | Lemma rsimplify_morphisms `(r : SimplifiedMorphism s d) 32 | : untag (morphism_of r) = ReifiedMorphismDenote (ReifiedMorphismSimplify (reified_morphism_of r)). 33 | rewrite <- ReifiedMorphismSimplifyOk. 34 | destruct r; assumption. 35 | Qed. 36 | 37 | (* tags to control the order of application *) 38 | 39 | 40 | Definition generic_tag {s d} := Tag s d. 41 | Definition compose_tag {s d} := @generic_tag s d. 42 | Definition functor_tag {s d} := @compose_tag s d. 43 | Definition nt_tag {s d} := @functor_tag s d. 44 | Canonical Structure identity_tag {s d} m := @nt_tag s d m. 45 | End single_category. 46 | 47 | (* canonical instances reifying each propositional constructor *) 48 | (* into a respective value from reified *) 49 | 50 | Local Ltac t := simpl; 51 | repeat rewrite <- reified_morphism_ok; 52 | reflexivity. 53 | 54 | Section more_single_category. 55 | Context `{C : SpecializedCategory objC}. 56 | 57 | Lemma reifyIdentity x : Identity x = ReifiedMorphismDenote (ReifiedIdentityMorphism C x). reflexivity. Qed. 58 | Canonical Structure reify_identity_morphism x := ReifyMorphism (identity_tag _) _ (reifyIdentity x). 59 | 60 | Lemma reifyCompose s d d' 61 | `(m1' : @SimplifiedMorphism objC C d d') `(m2' : @SimplifiedMorphism objC C s d) 62 | : Compose (untag (morphism_of m1')) (untag (morphism_of m2')) 63 | = ReifiedMorphismDenote (ReifiedComposedMorphism (reified_morphism_of m1') (reified_morphism_of m2')). 64 | t. 65 | Qed. 66 | Canonical Structure reify_composition_morphism s d d' m1' m2' := ReifyMorphism (compose_tag _) _ (@reifyCompose s d d' m1' m2'). 67 | End more_single_category. 68 | 69 | Section functor. 70 | Context `{C : SpecializedCategory objC}. 71 | Context `{D : SpecializedCategory objD}. 72 | Variable F : SpecializedFunctor C D. 73 | 74 | Lemma reifyFunctor `(m' : @SimplifiedMorphism objC C s d) 75 | : MorphismOf F (untag (morphism_of m')) = ReifiedMorphismDenote (ReifiedFunctorMorphism F (reified_morphism_of m')). 76 | t. 77 | Qed. 78 | Canonical Structure reify_functor_morphism s d m' := ReifyMorphism (functor_tag _) _ (@reifyFunctor s d m'). 79 | End functor. 80 | 81 | Section natural_transformation. 82 | Context `{C : SpecializedCategory objC}. 83 | Context `{D : SpecializedCategory objD}. 84 | Variables F G : SpecializedFunctor C D. 85 | Variable T : SpecializedNaturalTransformation F G. 86 | 87 | Lemma reifyNT (x : C) : T x = ReifiedMorphismDenote (ReifiedNaturalTransformationMorphism T x). reflexivity. Qed. 88 | Canonical Structure reify_nt_morphism x := ReifyMorphism (nt_tag _) _ (@reifyNT x). 89 | End natural_transformation. 90 | Section generic. 91 | Context `{C : SpecializedCategory objC}. 92 | 93 | Lemma reifyGeneric s d (m : Morphism C s d) : m = ReifiedMorphismDenote (ReifiedGenericMorphism C s d m). reflexivity. Qed. 94 | Canonical Structure reify_generic_morphism s d m := ReifyMorphism (generic_tag m) _ (@reifyGeneric s d m). 95 | End generic. 96 | 97 | End SimplifiedMorphism. 98 | 99 | Ltac rsimplify_morphisms := 100 | simpl; 101 | (* [refine] uses a unification algorithm compatible with 102 | ssreflect-style canonical structures; [apply] is not (but 103 | [apply:] in ssreflect is *) 104 | etransitivity; [ refine (rsimplify_morphisms _) | ]; 105 | etransitivity; [ | symmetry; refine (rsimplify_morphisms _) ]; 106 | instantiate; 107 | simpl. 108 | (* Note: Using [lazy] in the above tactic makes ExponentialLaws die on 109 | OOM after 1-2 GB of RAM and 40 minutes. *) 110 | 111 | (*******************************************************************************) 112 | (** Goals which are solved by [rsimplify_morphisms] **) 113 | (*******************************************************************************) 114 | Section good_examples. 115 | Section id. 116 | Context `(C : @SpecializedCategory objC). 117 | Context `(D : @SpecializedCategory objC). 118 | Variables F G : SpecializedFunctor C D. 119 | Variable T : SpecializedNaturalTransformation F G. 120 | 121 | Lemma good_example_00001 (x : C) :Compose (Identity x) (Identity x) = Identity (C := C) x. 122 | rsimplify_morphisms. 123 | reflexivity. 124 | Qed. 125 | 126 | Lemma good_example_00002 s d (m : Morphism C s d) 127 | : MorphismOf F (Compose m (Identity s)) = MorphismOf F m. 128 | rsimplify_morphisms. 129 | reflexivity. 130 | Qed. 131 | 132 | Lemma good_example_00003 s d (m : Morphism C s d) 133 | : MorphismOf F (Compose (Identity d) m) = MorphismOf F m. 134 | rsimplify_morphisms. 135 | reflexivity. 136 | Qed. 137 | End id. 138 | End good_examples. 139 | 140 | 141 | (***************************************************) 142 | (* Confusing examples that don't quite work *) 143 | Section bad_examples. 144 | Require Import SumCategory. 145 | Section bad_example_0001. 146 | Context `(C0 : SpecializedCategory objC0). 147 | Context `(C1 : SpecializedCategory objC1). 148 | Context `(D : SpecializedCategory objD). 149 | 150 | Variables s d d' : C0. 151 | Variable m1 : Morphism C0 s d. 152 | Variable m2 : Morphism C0 d d'. 153 | Variable F : SpecializedFunctor (C0 + C1) D. 154 | 155 | Goal MorphismOf F (s := inl _) (d := inl _) (Compose m2 m1) = Compose (MorphismOf F (s := inl _) (d := inl _) m2) (MorphismOf F (s := inl _) (d := inl _) m1). 156 | simpl in *. 157 | etransitivity; [ refine (rsimplify_morphisms _) | ]. 158 | Fail reflexivity. 159 | Abort. 160 | End bad_example_0001. 161 | End bad_examples. 162 | --------------------------------------------------------------------------------