(* Chapter 1 *)

(* Prelude ... *)
(* For reasons that won't be clear until substantially
   later in reading through HoTT, we will need to redefine
   some of the standard functionality in Coq to coincide
   more accurately with the book.
   These definitions will be explained later.  In making
   these changes, I used
   https://mdnahas.github.io/doc/Reading_HoTT_in_Coq.pdf
   as a guide, along with the UniMath library
*)

Require Export Coq.Init.Notations.

Definition UU := Type.
Identity Coercion fromUUtoType : UU >-> Sortclass.

Notation "A -> B" := (forall (_ : A), B) : type_scope.

Inductive paths {A:UU} (a:A) : (A->UU) :=
  paths_refl : paths a a.
Arguments paths_refl {A a}, [A] a.
Arguments paths_rect [A].
Hint Resolve paths_refl : core .
Notation "a = b" := (paths a b)
  (at level 70, no associativity) : type_scope.
Notation idpath := paths_refl.

(* 1.2 Function Types *)
Section Function_Types.
  (* The use of 'Section' here is important in order
      to limit the definition scope of these
      Variables. *)
  Variables A B : UU.
  Variable f : A -> B.
  Variable y : B.
  (* note how we choose to declare A and B in the
      'universe' UU.  We could also declare them in the
      universe type 'Type'.  The exact consequences of
      the difference are beyond me. *)

  (* notice how we can use Definition (y1) to simply bind
      a term to a name.  We can also specify a type
      annotation on the term, (y2) in which case Coq
      will check that annotation for us.
      *** TRY: changing the type to something invalid.
               what does Coq do now? ***
      We can also define parameters/arguments on the
      left side of the := definition assignment. (y3)
      When we do so, those arguments can be typed or
      untyped.  If we then also provide a type annotation
      (y4) we can effectively provide a 'return type'
  *)
  Definition const_y1 := fun x:A => y.
  Definition const_y2 : A -> B := fun x => y.
  Definition const_y3 (x:A) := y.
  Definition const_y4 (x:A) : B := y.
  (* notice how the Print command will output the
     definition of the term and its type *)
  Print const_y3.

  (* TODO: Should we include more details on different
           ways of making definitions in Coq? *)
End Function_Types.

(* Now that we've exited our first Section, which
   names are still in scope? *)
Print const_y3.
(* Notice the parameter list and type for const_y3 now.
    Some of the variables seem to be explicit arguments.
    But did all the variables get 'captured' in this way? *)

(*  ** UNCOMMENT THIS COMMAND and TRY IT **
  Print A.
*)

(* 1.3 Universes and families *)
Section Universes_and_Families.
  Variables A B : UU.

  (* In the following, note the new command 'Check'
      This command runs the typechecker on the given term.
      If a type annotation is provided, the checker attempts
      to verify that the claimed judgement can be derived.
      If no annotation is provided, the checker attempts
      to infer an appropriate type annotation. *)
  Definition const_fam_example : A -> UU := fun(x:A) => B.
  Definition const_fam_ex2 (x:A) := B.
  Check const_fam_ex2.
  Check const_fam_ex2 : A -> UU.
End Universes_and_Families.

(* 1.4 Dependent Function Types *)
Section Dependent_Function_Types.
  Variable A : UU.
  Variable B : A -> UU.

  Definition pi_type_example := forall x:A, B x.

  Definition swap_explicit :
    forall (A:UU) (B:UU) (C:UU),
      (A -> B -> C) -> (B -> A -> C)
  :=
    fun A B C g =>
      fun b a => (g a b).

  (* these curly braces declare that A B C are implicit
     arguments.  So, Coq will try to infer their values
     rather than require them to be explicitly provided.
     Also notice how (and we've snuck this in a bit)
     we can declare multiple variable names with the same
     type by just placing spaces between them.
  *)
  Definition swap {A B C : UU}
  : (A -> B -> C) -> (B -> A -> C)
  := fun g => fun b a => (g a b).
End Dependent_Function_Types.

(* 1.5 Product Types *)
Section Product_Types.
  Variables A B : UU.

  (* Function and Dependent Function types are core parts
     of Coq, unlike pairs/products, sums, and the other
     stuff we'll be looking at.  These are all (to Coq)
     just different 'Inductive' datatypes.
     Unfortunately, the default such types in Coq conflict
     with our UU strategy and modifications for doing HoTT.
     So, to keep things consistent, and break everything
     down as much as possible, we'll be redefining as
     many of these basic constructs as possible.
  *)
  Inductive prod (A B : UU) : UU :=
    | pair : A -> B -> prod A B .
  Arguments pair [A B].
  Notation "X * Y" := (prod X Y) : type_scope.
  Notation "( x , y , .. , z )" :=
    (pair .. (pair x y) .. z) : core_scope.
  (* Mostly, we can ignore this all as required magic for
     now.  The 'Arguments' command is a different
     way of achieving the same goal as {A:UU} style
     implicit arguments.  The 'Notation' command allows
     us to do operator overloading by redefining the
     behavior of the Coq parser. *)

  (* Now let's check out what this name is bound to,
     and how we might form product types and pairs *)
  Print prod.
  Check prod A B.

  Variables (a:A) (b:B).
  Check pair a b.
  Check (a,b).
  Check (a,b) : A*B.

  (* If we look back at the preceding, we can see the
      (i) formation rule: prod A B, or equivalently A * B
      (ii) introduction rule: pair a b, or (a,b)
     So we can see any inductive datatype will have
     these two features at least *)

  (* For instance, the unit type is very very boring *)
  Inductive unit  : UU :=
          | tt    : unit.
  Print unit.
  Check tt : unit.

  (* projections for pairs are
      (iii) eliminators: ways to deconstruct a term
     Notice that we can use this special pattern matching
     construct to pull apart a term inside an inductive
     datatype.  In Coq, this pattern matching is actually
     more primitive than the induction principles (coming
     up). *)
  Definition fst {A B : UU} (p:A*B) :=
    match p with (a,b) => a end.
  Definition snd {A B : UU} (p:A*B) :=
    match p with (a,b) => b end.
  Print fst.
  Print snd.
  Check fst (a,b) : A.
  Check snd (a,b) : B.
  (* Here is a new command: 'Compute' which can be used
     to ask Coq's term reduction engine to process a
     term.  Because of the way we defined fst/snd,
     Compute will nicely reduce explicit pairs.  This
     kind of interaction is called a
      (iv) computation rule: which shows how to reduce
              eliminator( introduction( . ) )
     Because this computation rule is provided
     *definitionally*, it will be processed automatically
     by the computation engine.  However, this may not be
     true in general... *)
  Compute fst (a,b).
  Compute snd (a,b).

  (* Now let's do a 'proof' using the tactics subsystem.
     Rather than say 'Definition' we write the command
     'Lemma' which is just a different way of defining
     a term.  Note how everything looks like a definition,
     except we just put a period after the type without
     any := assignment.
     Then, we delimit the proof with the commands
      'Proof' and 'Qed'.  In between are a sequence of
     'tactics' that are applied to successively break
     down the goal.  While this is hardly a full Coq
     tutorial, I'll try to explain.

     Hopefully you're in an IDE or tool that shows you
     the intermediate proof state as you go.
     The first tactic pulls apart the quantifier and
     names the argument x.  Then, this x term, which is
     in the product type is 'destructed', which means
     consider all the cases of what x could be, and then
     simpl is applied, invoking the computation engine
     to reduce terms.  Finally, invoking reflexivity
     resolves a trivial equality.
  *)
  Lemma uniq_prod_try_1 {X Y} : forall (x : X*Y),
    (fst x, snd x) = x.
  Proof. intro x. destruct x. simpl. reflexivity. Qed.
  (* But what happens when we print this term we just
     defined?  Voila!  It's a term.  As we go, this will
     become more obvious--how each part of this term
     corresponds to / was constructed by one of these
     tactics we invoked. *)
  Print uniq_prod_try_1.
  Compute uniq_prod_try_1 (a,b).
  (* Hmm, this computation didn't appear to resolve
     the pattern match like the projection computations
     did.  What's wrong?  Let's try repeating the whole
     proof, but closing with 'Defined' instead of 'Qed' *)
  Lemma uniq_prod {X Y} : forall (x : X*Y),
    (fst x, snd x) = x.
  Proof. intro x. destruct x. simpl. reflexivity. Defined.
  Print uniq_prod.
  Compute uniq_prod (a,b).
  (* Now, the term is actually reduced down further.
     In Coq, when you write Qed this tells the Coq engine
     that you want to treat the proof (i.e. term) of the
     proposition (i.e. type) that you just proved as a
     black-box.  Usually this is the right thing to do,
     but it prevents exploiting any definitional equalities
     that have been created.
    Finally, note that this is a
      (v) uniqueness principle: specifying the behavior of
            introduction( elimination( . ) )
          which is kind of like the dual of a computation
          rule.
     Unlike the computation rules for 'prod A B', the
      uniqueness principle is given as a 'propositional
      equality' rather than a definitional one.  This means
      we'll have to invoke it explicitly rather than count
      on the computation engine to automatically resolve it.
  *)

  (* Note the following possible definitions.
      In Coq, we can build everything out of pattern
      matching. *)
  Definition prod_recurse : forall (C : UU),
    (A -> B -> C) -> A*B -> C
  := fun C g p => match p with | (a,b) => g a b end.

  Definition unit_recurse : forall (C : UU),
    C -> unit -> C := fun C c t => c.

  Definition prod_induction : forall (C : A*B -> UU),
    (forall (x:A) (y:B), C (x,y) ) ->
      forall (x:A*B), C(x)
  := fun C g x => match x with | (a,b) => g a b end.
  Print prod_rect.

  Definition unit_induction : forall (C : unit->UU),
    C tt -> forall (x:unit), C x
  := fun C c x => match x with tt => c end.

  (* But also, Coq gave us built-in versions of these
     induction schemes when we defined the Inductive
     Datatypes. *)
  Print prod_rect.
  Print unit_rect.

  Lemma uniq_unit : forall (x:unit), x = tt.
  Proof. destruct x. reflexivity. Defined.
  Print uniq_unit.
  Compute uniq_unit tt.
End Product_Types.

(* Unless we define notations outside the Sections
   they will not be available in the subsequent
   Sections *)

Arguments pair [A B].
Notation "X * Y" := (prod X Y) : type_scope.
Notation "( x , y , .. , z )" :=
  (pair .. (pair x y) .. z) : core_scope.

(* 1.6 Dependent Pair Types *)
Section Dependent_Pair_Types.

  (* We start with some more magic definitions and
     notations to create sigma types as desired *)
  Inductive sig { T: UU } ( P: T -> UU ) :=
    spair : forall x:T, P x -> sig P.
  Notation "'sigma' x .. y , p" :=
    (sig (fun x => .. (sig (fun y => p)) ..))
    (at level 200, x binder, y binder, right associativity)
  : type_scope.
  Notation "'exists' x .. y , p" :=
    (sig (fun x => .. (sig (fun y => p)) ..))
    (at level 200, x binder, y binder, right associativity)
  : type_scope.
  Check spair.
  Notation "{ x ; .. ; y ; z }"
    := (spair _ x .. (spair _ y z) ..) : fibration_scope.
  Open Scope fibration_scope.
  Delimit Scope fibration_scope with fiber.

  (* Here are different ways to write the type *)
  Variable A : Type.
  Variable B : A -> Type.
  Print sig.
  Check @sig A B.
  Check sig B.
  Check exists x, B x.
  Check sigma x, B x.

  (* and ways to introduce a member of the type *)
  Variables (a:A) (b : B a).
  Print spair.
  Check spair _ a b : exists x:A, B x.
  Check {a ; b}.

  (* Let's first look at projection functions *)
  Definition proj1 {A : UU} {B : A -> UU}
    (p : exists (x:A), B x) : A
  := match p with {a;b} => a end.
  Compute proj1 {a ; b}.
  Definition proj2 {A : UU} {B : A -> UU}
    (p : exists (x:A), B x) : B (proj1 p)
  := match p with {a;b} => b end.
  Compute proj2 {a ; b}.

  (* Now, here's the simple recursion principle, but
      also the automatically defined induction principle *)
  Definition sigma_recursion {C : UU}
    (g : forall x, B x -> C)
  : (exists x, B x) -> C
  := fun p => match p with
      | {a;b} => g a b
     end.
  Print sig_rect.

  (* intro a custom notation for deconstructing
     dependent pairs *)
  Notation "x .1" := (proj1 x)
    (at level 3) : fibration_scope.
  Notation "x .2" := (proj2 x)
    (at level 3) : fibration_scope.
  Check {a;b}.1 : A.
  Check {a;b}.2 : B a.
  Compute {a;b}.1.
  Compute {a;b}.2.

  (* type theoretic axiom of choice *)
  Definition ac {X Y : UU} {R : X -> Y -> UU}
    (g : forall x:X, exists y:Y, R x y)
  : exists (f:X->Y), forall x:X, R x (f x)
  := let F := (fun (f : X -> Y) =>
                    forall x : X, R x (f x))
     in spair F (fun x => (g x).1) (fun x => (g x).2).

  Definition Magma := exists X, X -> X -> X.

  Definition PointedMagma :=
    exists (X:Type) (m : X -> X -> X), X.
  Definition PointedMagma2 :=
    exists X, ((X -> X -> X) * X)%type.
  (* In some sense that I don't understand,
     these ought to be equal *)
End Dependent_Pair_Types.

Notation "'sigma' x .. y , p" :=
  (sig (fun x => .. (sig (fun y => p)) ..))
  (at level 200, x binder, y binder, right associativity)
  : type_scope.
Notation "'exists' x .. y , p" :=
  (sig (fun x => .. (sig (fun y => p)) ..))
  (at level 200, x binder, y binder, right associativity)
  : type_scope.
Notation "{ x ; .. ; y ; z }"
  := (spair _ x .. (spair _ y z) ..) : fibration_scope.
Open Scope fibration_scope.
Delimit Scope fibration_scope with fiber.
Notation "x .1" := (proj1 x)
  (at level 3) : fibration_scope.
Notation "x .2" := (proj2 x)
  (at level 3) : fibration_scope.

(* 1.7 Coproduct Types *)
Section Coproduct_Types.
  (* Note that coprod is the first type we've seen that
     has two different introduction forms *)
  Inductive coprod (A B : UU) : UU :=
            | inl : A -> coprod A B
            | inr : B -> coprod A B
            .
  (* set some implicit arguments *)
  Arguments coprod_rect {_ _} _ _ _ _.
  Arguments inl {A B} _, [A] B _.
  Arguments inr {A B} _, A [B] _.
  Notation "X + Y" := (coprod X Y) : type_scope.

  (* Forming coproduct types *)
  Variables A B : Type.
  Check (A + B)%type.
  Check coprod A B.

  Variables (a:A) (b:B).
  Check inl a.
  Check inl a : A + B.
  Check inr b.
  Check inr b : A + B.

  Definition coprod_recursion : forall (C:UU),
    (A -> C) ->
    (B -> C) ->
    A + B ->
    C
  := fun C f g p => match p with
      | inl a => f a
      | inr b => g b
     end.

  (* The empty type is uninhabited *)
  Inductive empty : UU := .
  (* and the recursion principle is that anything
     follows from 'false' *)
  Definition empty_recursion
    : forall (C:UU), empty -> C
  := fun C ff => match ff with end.
  (* latin name: ex falso quodlibet
                 from false follows anything *)

  Print coprod_rect.
  Print empty_rect.
End Coproduct_Types.

Arguments coprod_rect {_ _} _ _ _ _.
Arguments inl {A B} _, [A] B _.
Arguments inr {A B} _, A [B] _.
Notation "X + Y" := (coprod X Y) : type_scope.

(* 1.8 the type of Booleans *)
Section the_type_of_Booleans.

  (* Again, some stuff we don't need to understand to
      define the basic 'bool' type *)
  Inductive bool  : UU :=
            | true : bool
            | false : bool
            .
  (* and we'll define an inversion *)
  Definition negb (b:bool) := if b then false else true.
  Print negb.
  Print bool.
  Check false : bool.
  Check true : bool.

  (* Coq has already defined
      an induction principle for us *)
  Print bool_rect.

  (* We can prove an exclusion principle for bool *)
  Definition bool_true_or_false
  : forall (x:bool), (x=true) + (x=false)
  := bool_rect (fun x => ((x=true) + (x=false))%type)
               (inl idpath)
               (inr idpath).
  Print bool_true_or_false.
End the_type_of_Booleans.

(* 1.9 the Natural Numbers *)
Section the_Natural_Numbers.

  (* More magic stuff *)
  Inductive nat : UU :=
    | O : nat
    | S : nat -> nat.
  Definition succ := S.
  Delimit Scope nat_scope with nat.
  Bind Scope nat_scope with nat.
  Arguments S _%nat.
  Open Scope nat_scope.

  (* The usual Coq mode has a more sophisticated
     num constant parser. But we can kludge small constants
     for most of what we're interested in like this. *)
  Notation  "0" := (O) : nat_scope.
  Notation  "1" := (S 0) : nat_scope.
  Notation  "2" := (S 1) : nat_scope.
  Notation  "3" := (S 2) : nat_scope.
  Notation  "4" := (S 3) : nat_scope.
  Notation  "5" := (S 4) : nat_scope.
  Notation  "6" := (S 5) : nat_scope.
  Notation  "7" := (S 6) : nat_scope.
  Notation  "8" := (S 7) : nat_scope.
  Notation  "9" := (S 8) : nat_scope.
  Notation "10" := (S 9) : nat_scope.

  (* ok, pretty straightforward... *)
  Check nat.
  Print nat.

  (* here's a simple example of a function
     to double a natural number.  But note!
     We're using a new command, 'Fixpoint' here *)
  Fixpoint double (n : nat) : nat :=
    match n with
      | O   => O
      | S n => S (S (double n))
    end.
  (* We could have avoided this new command by using
     a special term instead, revealing that the
     Fixpoint command is just syntax sugar *)
  Definition double_2 :=
    (fix double_fix (n:nat) : nat :=
       match n with
       | O   => O
       | S n => S (S (double_fix n))
       end).
  (* note that the result is the same when we print
     modulo renamings *)
  Print double.
  Print double_2.

  Compute double 2.
  Compute double 4.
  Check idpath : double 3 = 6.

  (* Here is the basic addition function *)
  Fixpoint plus (n : nat) (m : nat) : nat :=
    match n with
      | O     => m
      | S n'  => S (plus n' m)
    end.
  Notation "x + y" := (plus x y) : nat_scope.

  Check idpath : plus 2 3 = 5.
  Check idpath : 2 + 3 = 5.

  (* If we define our own recursion principle,
     we can also define operations using that
     without having to use Coq's recursive functions *)
  Definition nat_recursion : forall (C:Type),
    C -> (nat -> C -> C) -> nat -> C
  := fix R C c0 cS n := match n with
        | O     => c0
        | S n'  => cS n' (R C c0 cS n')
     end.
  Definition double_rec :=
    nat_recursion nat 0 (fun n y => S (S y)).
  Definition plus_rec :=
    nat_recursion (nat->nat)
                  (fun n => n)
                  (fun n g m => S (g m)).

  (* Coq defines an induction principle for us *)
  Print nat_rect.

  (* Now, we can prove associativity explicitly. *)
  Definition assoc_plus_0 (j k : nat)
  : (0 + (j + k)) = ((0 + j) + k)
  := idpath (j + k).
  Definition assoc_plus_S : forall (i:nat),
    (forall (j k : nat), i + (j + k) = (i + j) + k) ->
    forall (j k : nat), (S i) + (j + k) = ((S i) + j) + k
  := let ap_succ (m n : nat) : m = n -> S m = S n
         := paths_rect m (fun x p => S m = S x) idpath n
     in fun i h j k => ap_succ _ _ (h j k).
  Definition assoc_plus_nat (i j k : nat)
  : i + (j + k) = (i + j) + k
  := nat_rect _ assoc_plus_0 assoc_plus_S i j k.

End the_Natural_Numbers.

Delimit Scope nat_scope with nat.
Bind Scope nat_scope with nat.
Arguments S _%nat.
Open Scope nat_scope.

Notation  "0" := (O) : nat_scope.
Notation  "1" := (S 0) : nat_scope.
Notation  "2" := (S 1) : nat_scope.
Notation  "3" := (S 2) : nat_scope.
Notation  "4" := (S 3) : nat_scope.
Notation  "5" := (S 4) : nat_scope.
Notation  "6" := (S 5) : nat_scope.
Notation  "7" := (S 6) : nat_scope.
Notation  "8" := (S 7) : nat_scope.
Notation  "9" := (S 8) : nat_scope.
Notation "10" := (S 9) : nat_scope.
Notation "x + y" := (plus x y) : nat_scope.

(* 1.10 Pattern Matching and Recursion *)
Section Pattern_Matching_and_Recursion.
  (* We've already seen how pattern matching is related
     to recursion/induction *)
  (* I'm going to use this section instead as an opportunity
     to explore the Ltac proof language/system in more excruciating
     detail.
     To do this, we need to have some boring theorems to prove.
     'nat' should do the trick! *)
  (* Here's a handy command you should try: 'Search'.
     Search will do a lookup of the name in question, trying to
     find all the Lemmas, theorems, etc. involving that object as
     it can.  So, here we'll search the *old* natural number type
     that we shadowed when we defined our own 'nat'. *)
  (* Search Datatypes.nat. *)
  (* The above command won't work once we turn on the command line
     argument that prevents the loading of the standard libraries *)
  (* It wouldn't hurt to try to prove some of these results anew *)
  (*
    plus_n_O  : forall n : nat, n = n + 0
    plus_0_n  : forall n : nat, 0 + n = n
    eq_add_S  : forall n m : nat, S n = S m -> n = m
    eq_S      : forall n m : nat, n = m -> S n = S m
    plus_Sn_m : forall n m : nat, S (n + m) = n + (S m)
   *)
  (* To start, let's do this simple one *)
  Lemma eq_S__0 : forall n m : nat, n = m -> S n = S m.
  Proof.
    intros n m Enm.
    induction Enm.
    reflexivity.
  Qed.
  Print eq_S__0.

  Lemma eq_S__1 : forall n m : nat, n = m -> S n = S m.
  Proof.
    intros n m Enm.
    destruct Enm.
    reflexivity.
  Qed.
  Print eq_S__1.

  (* So we can start to see some of the correspondence between
     the tactics (the name for the commands inside the proof)
     and the resulting proof term that is constructed.

     In order to explore this deeper, we're going to look at
     how to define our own proof commands, i.e. tactics *)
  Ltac my_intro x := intro x.
  Print my_intro.

  (* note that we can chain tactics together with ;  *)
  Lemma eq_S__20 : forall n m : nat, n = m -> S n = S m.
  Proof.
    my_intro n; my_intro m; my_intro E.
    Show Proof.
    destruct E.
    Show Proof.
    reflexivity.
  Qed.

  (* in fact, we can see that some of these tactics were defined
     elsewhere, even if we can't see their definition *)
  Print intro.
  Print reflexivity.
  Print elimtype.

  (* idtac is a useful way to debug tactics or give feedback *)
  (* also note that we can define anonymous functions in Ltac, although
     these functions are Ltac, not Coq functions *)
  Ltac my_intro2 := fun x => idtac "myintro_2 -" x; intro x.
  Lemma eq_S__21 : forall n m : nat, n = m -> S n = S m.
  Proof.
    my_intro2 n; my_intro2 m; my_intro2 E.
    destruct E. reflexivity.
  Qed.

  (* We can get much more complicated.  To do that, let's start
     looking at some ways to manage tactic scripts.  First here,
     we can see that let expressions help us capture anything we
     want to introspect on.  We show two useful bits of introspection
     here.  The first is a way to generate a 'fresh' i.e. unused
     name.  This is extremely valuable in order to ensure consistent
     ways to refer to evidence we introduce via one tactic, but then
     want to use in another.  We can give a standard prefix ('my' here)
     to help with debugging.  After introducing the variable, we use
     another introspection facility to get the type of the newly
     introduced term.  Then, we display all this information for
     development purposes. *)
  Ltac my_intro3 := let nm := fresh "my"
                    in intro nm;
                       let T := type of nm
                       in idtac "myintro_3 -" nm ":" T.
  Lemma eq_S__23 : forall n m : nat, n = m -> S n = S m.
  Proof.
    my_intro3. my_intro3. my_intro3.
    destruct my1. reflexivity.
  Qed.

  (* Now lets write a plausibly useful tactic *)
  Ltac in_destruct := let nm := fresh "in_dest_H"
                      in intro nm; destruct nm.
  Lemma eq_S__24 : forall n m : nat, n = m -> S n = S m.
  Proof.
    intros n m. in_destruct. reflexivity.
  Qed.

  (* We're really going overboard on this proof, since the original
     form was already pretty minimal, but let's see if we can
     create a tactic script that *FINDS* an instance of an equality
     proposition and then deliberately destructs it... *)
  Ltac destruct_paths :=
    match goal with
    | p : _ = _ |- _ => destruct p; destruct_paths
    | _ => try (simpl; reflexivity)
    end.
  (* Normally destruct requires that we specify which term/hypothesis
     we want to destruct.  However, Ltac allows us to match on the
     current proof state 'match goal with'.  When we do this match,
     notice that the pattern includes a turnstile '|-'.  This symbol
     is equivalent to the big horizontal line you see in the Coq
     Goal window of your interactive prover environment.  Therefore,
     any patterns before the turnstile are searched for in the
     collection of hypotheses, and the pattern afterwards is matched
     against the current goal directly. *)
  (* The special 'try' command takes another tactic and tries applying
     it.  If we don't use try, then an unsuccessful application will
     abort the entire Ltac script, including the previous 'destruct'
     invocations. *)
  Lemma eq_S__25 : forall n m : nat, n = m -> S n = S m.
  Proof.
    intros; destruct_paths.
  Qed.
  (* Notice that the proof now no longer needs to refer to any
     specific names.  This is a valuable goal for proof automation *)

  (* just going to prove this finally... *)
  Lemma eq_S : forall n m : nat, n = m -> S n = S m.
  Proof.
    intros n m E; destruct E; exact idpath.
  Qed. (* note that 'exact' simply plugs in the specified term *)

  (* note that while the definition of plus allows for reducing
     out a 0 on the left, it does not work if the zero is on the
     right *)
  Variable nn : nat.
  Compute 0 + nn.
  Compute nn + 0.

  (* So, we need to prove the latter equality propositionally *)
  Lemma plus_n_O__try0 : forall n : nat, n = n + 0.
  Proof.
    intro n.
    simpl. (* simpl, i.e. computation/reduction is not enough. *)
    (* we need to apply inductive reasoning here *)
    induction n.
    (* base case is all zeros *) reflexivity.
    (* inductive case will let us *rewrite* *)
      simpl. rewrite <- IHn. reflexivity.
    (* to really understand what 'rewrite' is doing, we'll have to
       wait until we've studied propositional equality more carefully *)
  Qed.

  (* This is all a bit messy, so let's see if we can at least
     concatenate the prior proof together into a single block *)
  Lemma plus_n_O : forall n : nat, n = n + 0.
  Proof.
    intro n; induction n;
      [ reflexivity |
        simpl; rewrite <- IHn; reflexivity ].
  Qed.
  (* Notice how we use the 'tac0; [ tac1 | tac2 ]' construct to
     specify *different* proof scripts for the two different subgoals
     generated by induction. *)

  (* finally, while this lemma seems incredibly odd, it's
     extremely valuable when building up basic proofs about nat,
     because it too expresses an obvious but computationally
     non-trivial fact *)
  Lemma plus_Sn_m : forall n m : nat, S (n + m) = n + (S m).
  Proof.
    (* Here, instead of branching in the script we use ONE common
       continuation to address all sub-goals.  This is a common
       case where 'try' can be valuable. *)
    intros n m; induction n; simpl; try reflexivity;
      apply eq_S; assumption.
  Qed.

  (* Now, what if we try to re-prove associativity, but we
     choose to do induction on the 'wrong' variable... *)
  Lemma assoc_plus_nat_again (i j k : nat) :
    i + (j + k) = (i + j) + k.
  Proof.
    induction k; simpl.
    repeat rewrite <- plus_n_O. reflexivity.
    repeat rewrite <- plus_Sn_m. apply eq_S; assumption.
  Qed.

  (* Ok, so now we're at the OH SHIT THAT IS A GOOD IDEA part of this.
     Since we know these extra rules we proved *ought* to be part of
     a computational reduction, but aren't, can we just come up with our
     own custom reduction? *)
  Ltac natred := simpl; repeat (rewrite <- plus_n_O);
                 repeat (rewrite <- plus_Sn_m; simpl);
                 repeat (apply eq_S).
  Lemma assoc_plus_nat_on_j_now (i j k : nat) :
    i + (j + k) = (i + j) + k.
  Proof.
    induction j; natred; trivial.
    (* trivial is some big bag of tricks, including reflexivity
       and assumption *)
  Qed.

(*
  For reference, here are some links
  General list of basic tactics:
    http://flint.cs.yale.edu/cs428/coq/doc/Reference-Manual010.html#Tactics
  List of constructions for combining tactics in Ltac scripts:
    http://flint.cs.yale.edu/cs428/coq/doc/Reference-Manual011.html
 *)

End Pattern_Matching_and_Recursion.

Ltac natred := simpl; repeat (rewrite <- plus_n_O);
               repeat (rewrite <- plus_Sn_m; simpl);
               repeat (apply eq_S).

(* 1.11 Propositions as Types *)
Section Propositions_as_Types.
  (* Define negation... *)
  Definition not (A:UU) : UU := A -> empty.
  Notation "~ A" := (not A) : type_scope.
  Arguments not _%type.

  Variables A B : UU.
  Variables f : A -> B.

  Check ~A.
  Compute ~A.
  Print not.

  Theorem DeMorgan1_with_tactics : (~A) * (~B) -> ~(A + B)%type.
  Proof.
    intro H; destruct H as [na nb].
    intro Nor; destruct Nor as [a | b].
    apply (na a). apply (nb b).
  Qed.
  Definition DeMorgan1_term : (~A) * (~B) -> ~(A + B)%type :=
    prod_rect (~A) (~B) (fun _ => ~(A + B)%type)
              (fun a b => coprod_rect (fun _ => empty) a b).

  Theorem DeMorgan2_natural : ~(A + B)%type -> (~A) * (~B).
  Proof.
    intro nAoB; split; intro x; apply nAoB.
      left; apply x.
      right; apply x.
  Qed.

  Lemma split_dep_func {P Q} :
    (forall x:A, (P x) * (Q x)) ->
    (forall x:A, P x) * (forall x:A, Q x).
  Proof.
    intro H; split; intro x; apply (H x).
  Qed.

  Definition split_dep_func_term {P Q} :
    (forall x:A, (P x) * (Q x)) ->
    (forall x:A, P x) * (forall x:A, Q x)
  :=
    fun H => pair (fun x => fst (H x))
                  (fun x => snd (H x)).

  Definition LEq n m := exists k:nat, n+k = m.
  Print LEq.
  Notation "n <= m" := (LEq n m) : type_scope.

  Print assoc_plus_nat.

  Lemma LEq_trans {n m p : nat}
  : (LEq n m) -> (LEq m p) -> (LEq n p).
  Proof.
    unfold LEq.
    intros LEnm LEmp.
    destruct LEnm as [dnm enm].
    destruct LEmp as [dmp emp].
    exists (dnm + dmp).
    rewrite <- emp.
    rewrite <- enm.
    rewrite assoc_plus_nat.
    reflexivity.
  Qed.

  Lemma LEq_O_n (n:nat) : LEq 0 n.
  Proof.
    exists n. reflexivity.
  Qed.
  Lemma LEq_n (n:nat) : LEq n n.
  Proof. exists 0. natred. trivial. Qed.
  Lemma LEq_S (n m:nat) : LEq n m -> LEq n (S m).
  Proof.
    intro Lnm; destruct Lnm as [p Enm].
    exists (S p); natred.
    trivial.
  Qed.
  Lemma LEq_n_S {n m:nat} : LEq n m -> LEq (S n) (S m).
  Proof.
    intro Lnm; destruct Lnm as [p Enm].
    exists p; natred; trivial.
  Qed.

  Definition SemiGroup := exists (A:Type) (m:A->A->A),
                            forall (x y z : A), m x (m y z) = m (m x y) z.

  Lemma logically_but_not_eqv : (nat -> unit)*(unit -> nat).
  Proof.
    split; [
      intro n; exact tt
    | intro u; exact 0
    ].
  Qed.
  (* more directly... *)
  Definition logically_but_not_eqv_explicit : (nat -> unit)*(unit -> nat)
    := pair (fun n => tt) (fun u => 0).
  Print logically_but_not_eqv.
  (* So natural numbers are 'equivalent' to unit
     logically, but that doesn't mean that unit and
     nat are really equivalent... *)

End Propositions_as_Types.

Notation "~ A" := (not A) : type_scope.
Arguments not _%type.
Notation "n <= m" := (LEq n m) : type_scope.

(* 1.12 Identity Types *)
Section Identity_Types.
  Variables A : UU.
  Variables a b : A.

  (* Now finally we can come back to our strange overloading
     of the equality operator that we began this file with *)
  Print paths.
  Check paths a b.
  Check @paths A a b.

  Check idpath a.
  Print idpath.
  Print paths_refl.

  (* The indiscernability of identicals is a key principle
     by which equalities may be used to rewrite an expression *)
  Lemma indiscernability_of_identicals :
    forall (C:A->UU),
    forall (x y : A) (p : x = y), (C x) -> (C y).
  Proof.
    intros C x y E Cx. induction E. apply Cx.
  Defined.

  (* but how does induction work??? *)

  Definition path_induction
    {C : forall x y : A, x=y -> UU}
    (c : forall x : A, C x x idpath)
  : forall x y : A, forall p : x=y, C x y p
  := fun x y p => match p with
      | idpath _ => c x
      end.

  Definition based_path_induction
    {a : A}
    {C : forall x : A, a=x -> UU}
    (c : C a idpath)
  : forall (x : A) (p : a=x), C x p
  := fun x p => match p with
      | idpath _ => c
     end.

  (* Which of these induction principles does the built-in look like? *)
  Print paths_rect.

  Definition normal_from_based_path_induction
    {C : forall x y : A, x=y -> Type}
    (c : forall x : A, C x x idpath)
  : forall x y : A, forall p : x=y, C x y p
  := fun x y p =>
      @based_path_induction x (C x) (c x) y p.

  Definition based_from_normal_path_induction
    {a : A}
    {C : forall x : A, a=x -> Type}
    (c : C a idpath)
  : forall (x : A) (p : a=x), C x p
  := fun x p =>
      let D : forall (x y : A), x=y -> Type
             := fun x y p =>
                  forall (C : forall z:A, x=z -> Type),
                    (C x idpath) -> (C y p)
      in
      let d : forall x:A, D x x idpath
             := fun x C (c : C x idpath) => c
      in (@path_induction D d a x p) C c.

  Notation "a <> b" := (not (a = b)) : type_scope.

End Identity_Types.

Notation "a <> b" := (not (a = b)) : type_scope.


(*
 * © 2019 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Frap Require Export Relations.

Set Implicit Arguments.

Section trc_tri.
  Variable A B : Type.
  Variable R : A -> B -> A -> Prop.
  (* Variable P : B -> Prop. *)

  Inductive trc3 (P : B -> Prop) : A -> A -> Prop :=
  | Trc3Refl : forall x, trc3 P x x
  | Trc3Front : forall x y z b,
      P b
      -> R x b y
      -> trc3 P y z
      -> trc3 P x z.

  Hint Constructors trc3 : core.

  Theorem trc3_one : forall x y b (P : B -> Prop), P b -> R x b y
    -> trc3 P x y.
  Proof.
    eauto.
  Qed.

  Theorem trc3_trans : forall x y (P : B -> Prop), trc3 P x y
    -> forall z, trc3 P y z
      -> trc3 P x z.
  Proof.
    induction 1; eauto.
  Qed.

End trc_tri.

#[export] Hint Constructors trc3 : core.


(*|
#########################################################
Nested recursion and ``Program Fixpoint`` or ``Function``
#########################################################

:Link: https://stackoverflow.com/q/46838928
|*)

(*|
Question
********

I'd like to define the following function using ``Program Fixpoint``
or ``Function`` in Coq:
|*)

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Program.Wf.
Require Import Recdef.

Inductive Tree := Node : nat -> list Tree -> Tree.

Fixpoint height (t : Tree) : nat :=
  match t with
  | Node x ts => S (fold_right Nat.max 0 (map height ts))
  end.

Program Fixpoint mapTree (f : nat -> nat) (t : Tree)
        {measure (height t)} : Tree :=
  match t with
    Node x ts => Node (f x) (map (fun t => mapTree f t) ts)
  end.
Next Obligation.
Admitted.

(*|
Unfortunately, at this point I have a proof obligation ``height t <
height (Node x ts)`` without knowing that ``t`` is a member of ``ts``.

Similarly with ``Function`` instead of ``Program Fixpoint``, only that
``Function`` detects the problem and aborts the definition:
|*)

Fail Function mapTree (f : nat -> nat) (t : Tree) {measure height t} : Tree :=
  match t with
    Node x ts => Node (f x) (map (fun t => mapTree f t) ts)
  end. (* .fails .unfold .messages *)

(*|
I would expect to get a proof obligation of ``In t ts -> height t <
height (Node x ts)``.

Is there a way of getting that that does not involve restructuring the
function definition? (I know work-arounds that require inlining the
definition of ``map`` here, for example – I'd like to avoid these.)

Isabelle
========

To justify that expectation, let me show what happens when I do the
same in Isabelle, using the ``function`` command, which is (AFAIK)
related to Coq's ``Function`` command:

.. code-block:: isabelle

    theory Tree imports Main begin

    datatype Tree = Node nat "Tree list"

    fun height where
      "height (Node _ ts) = Suc (foldr max (map height ts) 0)"

    function mapTree where
      "mapTree f (Node x ts) = Node (f x) (map (λ t. mapTree f t) ts)"
    by pat_completeness auto

    termination
    proof (relation "measure (λ(f, t). height t)")
      show "wf (measure (λ(f, t). height t))" by auto
    next
      fix f :: "nat ⇒ nat" and x :: nat and ts :: "Tree list" and t
      assume "t ∈ set ts"
      thus "((f, t), (f, Node x ts))  ∈ measure (λ(f, t). height t)"
        by (induction ts) auto
    qed

In the termination proof, I get the assumption ``t ∈ set ts``.

Note that Isabelle does not require a manual termination proof here,
and the following definition works just fine:

.. code-block:: isabelle

    fun mapTree where
      "mapTree f (Node x ts) = Node (f x) (map (λ t. mapTree f t) ts)"

This works because the ``map`` function has a "congruence lemma" of
the form

.. code-block:: isabelle

    "xs = ys ⟹ (⋀x. x ∈ set ys ⟹ f x = g x) ⟹ map f xs = map g ys"

that the ``function`` command uses to find out that the termination
proof only needs to consider ``t ∈ set ts``.

If such a lemma is not available, e.g. because I define

.. code-block:: isabelle

    definition "map' = map"

and use that in ``mapTree``, I get the same unprovable proof
obligation as in Coq. I can make it work again by declaring a
congruence lemma for ``map'``, e.g. using

.. code-block:: isabelle

    declare map_cong[folded map'_def,fundef_cong]
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

In this case, you actually do not need well-founded recursion in its
full generality:
|*)

Reset Initial. (* .none *)
Require Import Coq.Lists.List.

Set Implicit Arguments.

Inductive tree := Node : nat -> list tree -> tree.

Fixpoint map_tree (f : nat -> nat) (t : tree) : tree :=
  match t with
  | Node x ts => Node (f x) (map (fun t => map_tree f t) ts)
  end.

(*|
Coq is able to figure out by itself that recursive calls to
``map_tree`` are performed on strict subterms. However, proving
anything about this function is difficult, as the induction principle
generated for ``tree`` is not useful:
|*)

Check tree_ind. (* .unfold .messages *)

(*|
This is essentially the same problem you described earlier. Luckily,
we can fix the issue by proving our own induction principle with a
proof term.
|*)

Reset Initial. (* .none *)
Require Import Coq.Lists.List.
Import ListNotations.

Unset Elimination Schemes.
Inductive tree := Node : nat -> list tree -> tree.
Set Elimination Schemes.

Fixpoint tree_ind
         (P : tree -> Prop)
         (IH : forall (n : nat) (ts : list tree),
             fold_right (fun t => and (P t)) True ts ->
             P (Node n ts))
         (t : tree) : P t :=
  match t with
  | Node n ts =>
      let fix loop ts :=
        match ts return fold_right (fun t' => and (P t')) True ts with
        | [] => I
        | t' :: ts' => conj (tree_ind P IH t') (loop ts')
        end in
      IH n ts (loop ts)
  end.

Fixpoint map_tree (f : nat -> nat) (t : tree) : tree :=
  match t with
  | Node x ts => Node (f x) (map (fun t => map_tree f t) ts)
  end.

(*|
The ``Unset Elimination Schemes`` command prevents Coq from generating
its default (and not useful) induction principle for ``tree``. The
occurrence of ``fold_right`` on the induction hypothesis simply
expresses that the predicate ``P`` holds of every tree ``t'``
appearing in ``ts``.

Here is a statement that you can prove using this induction principle:
|*)

Lemma map_tree_comp f g t :
  map_tree f (map_tree g t) = map_tree (fun n => f (g n)) t.
Proof.
  induction t as [n ts IH]. simpl. f_equal.
  induction ts as [|t' ts' IHts]; try easy.
  simpl in *. destruct IH as [IHt' IHts'].
  specialize (IHts IHts'). now rewrite IHt', <- IHts.
Qed.

(*|
Answer (Joachim Breitner)
*************************

In general, it might be advisable to avoid this problem. But if one
really wants to obtain the proof obligation that Isabelle gives you,
here is a way:

In Isabelle, we can give an external lemma that stats that ``map``
applies its arguments only to members of the given list. In Coq, we
cannot do this in an external lemma, but we can do it in the type. So
instead of the normal type of map

.. code-block:: coq

    forall A B, (A -> B) -> list A -> list B

we want the type to say "f is only ever applied to elements of the list":

.. code-block:: coq

    forall A B (xs : list A), (forall x : A, In x xs -> B) -> list B

(It requires reordering the argument so that the type of ``f`` can
mention ``xs``).

Writing this function is not trivial, and I found it easier to use a
proof script:

.. coq:: none
|*)

Reset Initial.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Program.Wf.

Inductive Tree := Node : nat -> list Tree -> Tree.

Fixpoint height (t : Tree) : nat :=
  match t with
  | Node x ts => S (fold_right Nat.max 0 (map height ts))
  end.

(*||*)

Definition map {A B} (xs : list A) (f : forall x : A, In x xs -> B) : list B.
Proof.
  induction xs.
  - exact [].
  - refine (f a _ :: IHxs _).
    + left. reflexivity.
    + intros. eapply f. right. eassumption.
Defined.

(*| But you can also write it "by hand": |*)

Reset map. (* .none *)
Fixpoint map {A B} (xs : list A) :
  forall (f : forall x : A, In x xs -> B), list B :=
  match xs with
  | [] => fun _ => []
  | x :: xs =>
      fun f => f x (or_introl eq_refl) :: map xs (fun y h => f y (or_intror h))
  end.

(*|
In either case, the result is nice: I can use this function in
``mapTree``, i.e.
|*)

Program Fixpoint mapTree (f : nat -> nat) (t : Tree)
        {measure (height t)} : Tree :=
  match t with
    Node x ts => Node (f x) (map ts (fun t _ => mapTree f t))
  end.
Next Obligation.

(*|
and I don't have to do anything with the new argument to ``f``, but it
shows up in the the termination proof obligation, as ``In t ts ->
height t < height (Node x ts)`` as desired. So I can prove that and
define ``mapTree``:
|*)

  simpl. apply Lt.le_lt_n_Sm.
  clear mapTree. induction ts; inversion_clear H.
  - subst. apply PeanoNat.Nat.le_max_l.
  - rewrite IHts by assumption.
    apply PeanoNat.Nat.le_max_r.
Qed.

(*|
It only works with ``Program Fixpoint``, not with ``Function``,
unfortunately.
|*)

(*|
Answer (Matthieu Sozeau)
************************

You can now do this with Equations and get the right elimination
principle automatically, using either `structural nested recursion
<http://mattam82.github.io/Coq-Equations/examples/Examples.nested_mut_rec.html>`__
or `well-founded recursion
<http://mattam82.github.io/Coq-Equations/examples/Examples.RoseTree.html>`__.
|*)


(*******************************************************************************

Title: Pullbacks.v
Authors: Jeremy Avigad, Chris Kapulkin, Peter LeFanu Lumsdaine
Date: 1 March 2013

The standard pullback construction, the abstract characterization of pullbacks,
and properties of both of these.

*******************************************************************************)

Require Import HoTT.

Require Import Auxiliary CommutativeSquares.

(*******************************************************************************

The standard construction of a pullback.

*******************************************************************************)

Section Concrete_Pullbacks.

Definition pullback {A B C : Type} (f : A -> C) (g : B -> C)
:= { x : A & { y : B & (f x) = (g y) }} : Type.

Definition pullback_pr1 {A B C : Type} {f : A -> C} {g : B -> C}
  (x : pullback f g) := pr1 x.

Definition pullback_pr2 {A B C : Type} {f : A -> C} {g : B -> C}
  (x : pullback f g) := pr1 (pr2 x).

Definition pullback_comm {A B C : Type} {f : A -> C} {g : B -> C}
  (x : pullback f g) := pr2 (pr2 x).

(* Sometimes one wants to view one the pullback projections as the
pullback of a map. Arbitrarily, we choose the second projection as
the one to use in this way. *)
Notation "f ^* g" := (@pullback_pr2 _ _ _ g f) (at level 45).

Definition mk_pullback {A B C : Type} (f : A -> C) (g : B -> C)
  (a : A) (b : B) (p : (f a) = (g b))
: pullback f g.
Proof.
  exists a, b. exact p.
Defined.

Definition pullback_path {A B C : Type} {f : A -> C} {g : B -> C}
  (u u' : pullback f g)
  (p : pullback_pr1 u = pullback_pr1 u')
  (q : pullback_pr2 u = pullback_pr2 u')
  (r : (ap f p)^ @ (pullback_comm u) @ (ap g q)
       = pullback_comm u')
: u = u'.
Proof.
  destruct u as [a [b c]], u' as [a' [b' c']].
  unfold pullback_pr2 in q. simpl in p, q.
  destruct p, q. apply ap, ap. simpl in r.
  exact ((concat_1p _)^ @ (concat_p1 _)^ @ r).
Defined.

Global Arguments pullback_path : simpl never.

(* Alias of [pullback_path]; useful for [apply]ing and then using
   [exists] to supply the arguments (compare [path_sigma_uncurried]). *)
Definition pullback_path' {A B C : Type} {f : A -> C} {g : B -> C}
  (u u' : pullback f g)
: { p : pullback_pr1 u = pullback_pr1 u'
    & {q : pullback_pr2 u = pullback_pr2 u'
    & (ap f p)^ @ (pullback_comm u) @ (ap g q)
      = pullback_comm u' } }
  -> u = u'.
Proof.
  intros [p [q r]]. apply (pullback_path u u' p q r).
Defined.

Global Arguments pullback_path' [_ _ _ _ _] _ _ _ : simpl never.

Definition pullback_path_pr1 {A B C : Type} {f : A -> C} {g : B -> C}
  (u u' : pullback f g)
  (p : pullback_pr1 u = pullback_pr1 u')
  (q : pullback_pr2 u = pullback_pr2 u')
  (r : (ap f p)^ @ (pullback_comm u) @ (ap g q)
       = pullback_comm u')
: ap pullback_pr1 (pullback_path u u' p q r) = p.
Proof.
  destruct u as [a [b c]], u' as [a' [b' c']].
  unfold pullback_pr2 in q. simpl in p, q.
  destruct p, q. simpl.
  apply (concat (ap_compose (existT _ a) pullback_pr1 _)^).
  apply ap_const.
Defined.

Definition pullback_path_pr2 {A B C : Type} {f : A -> C} {g : B -> C}
  (u u' : pullback f g)
  (p : pullback_pr1 u = pullback_pr1 u')
  (q : pullback_pr2 u = pullback_pr2 u')
  (r : (ap f p)^ @ (pullback_comm u) @ (ap g q)
       = pullback_comm u')
: ap pullback_pr2 (pullback_path u u' p q r) = q.
Proof.
  destruct u as [a [b c]], u' as [a' [b' c']].
  unfold pullback_pr2 in q. simpl in p, q.
  destruct p, q. unfold pullback_path; simpl.
  rewrite <- ! ap_compose.
  apply ap_const.
Defined.

Definition pullback_path'_pr1 {A B C : Type} {f : A -> C} {g : B -> C}
  (u u' : pullback f g)
  (pqr : { p : pullback_pr1 u = pullback_pr1 u'
    & {q : pullback_pr2 u = pullback_pr2 u'
    & (ap f p)^ @ (pullback_comm u) @ (ap g q)
      = pullback_comm u' } })
: ap pullback_pr1 (pullback_path' u u' pqr) = pr1 pqr.
Proof.
  destruct pqr as [p [q r]]. apply pullback_path_pr1.
Defined.

Definition pullback_path'_pr2 {A B C : Type} {f : A -> C} {g : B -> C}
  (u u' : pullback f g)
  (pqr : { p : pullback_pr1 u = pullback_pr1 u'
    & {q : pullback_pr2 u = pullback_pr2 u'
    & (ap f p)^ @ (pullback_comm u) @ (ap g q)
      = pullback_comm u' } })
: ap pullback_pr2 (pullback_path' u u' pqr) = pr1 (pr2 pqr).
Proof.
  destruct pqr as [p [q r]]. apply pullback_path_pr2.
Defined.

End Concrete_Pullbacks.

Notation "f ^* g" := (@pullback_pr2 _ _ _ g f) (at level 45).

(*******************************************************************************

The standard pullback is symmetric.

*******************************************************************************)

Section Pullback_Symm.

Definition pullback_symm {A B C : Type} (f : A -> C) (g : B -> C)
: pullback f g -> pullback g f.
Proof.
  intros abp.
  exists (pullback_pr2 abp), (pullback_pr1 abp).
  exact ((pullback_comm abp)^).
Defined.

Lemma pullback_symm_isequiv {A B C : Type} (f : A -> C) (g : B -> C)
: IsEquiv (pullback_symm f g).
Proof.
apply (isequiv_adjointify (pullback_symm g f)).
  (* section *)
  intros [b [a q]]; simpl. apply pullback_path'.
  unfold pullback_pr2, pullback_comm; simpl.
  exists 1, 1. simpl. exact (concat_p1 _ @ concat_1p _ @ inv_V _).
  (* retraction *)
  intros [a [b p]]; simpl. apply pullback_path'.
  unfold pullback_pr2, pullback_comm; simpl.
  exists 1, 1. simpl. exact (concat_p1 _ @ concat_1p _ @ inv_V _).
Defined.

Definition pullback_symm_equiv {A B C : Type} (f : A -> C) (g : B -> C)
  := BuildEquiv (pullback_symm_isequiv f g)
  : pullback f g <~> pullback g f.

End Pullback_Symm.

(*******************************************************************************

Cospan cones, that is, cones on the data A, B, C, f : A -> C, g : B -> C.
(The pullback is a universal such cone.)

*******************************************************************************)

Section Cospan_Cone.

Definition cospan_cone {A B C : Type} (f : A -> C) (g : B -> C) (X : Type)
:= { h : (X -> A) & { k : (X -> B) & forall x, (f(h x)) = (g(k x)) }}.

Definition mk_cospan_cone {A B C : Type} {f : A -> C} {g : B -> C} {X : Type}
  {h : X -> A} {k : (X -> B)} (alpha : forall x, (f(h x)) = (g(k x)))
: cospan_cone f g X.
Proof.
  exists h. exists k. apply alpha.
Defined.

Definition cospan_cone_map1 {A B C : Type} {f : A -> C} {g : B -> C}
  {X : Type} (C : cospan_cone f g X) := pr1 C.

Definition cospan_cone_map2 {A B C : Type} {f : A -> C} {g : B -> C}
  {X : Type} (C : cospan_cone f g X) := pr1 (pr2 C).

Definition cospan_cone_comm {A B C : Type} {f : A -> C} {g : B -> C}
  {X : Type} (C : cospan_cone f g X) := pr2 (pr2 C).

(* TODO (mid): try redoing without triple_path
  (but then be careful to check Pullbacks3 over it). *)
Definition cospan_cone_path
  {A B C : Type} {f : A -> C} {g : B -> C} {X : Type}
  {Phi1 Phi2 : cospan_cone f g X}
  (p : cospan_cone_map1 Phi1 = cospan_cone_map1 Phi2)
  (q : cospan_cone_map2 Phi1 = cospan_cone_map2 Phi2)
  (r : forall x:X,
    cospan_cone_comm Phi1 x
    = (ap f (ap10 p x)) @ cospan_cone_comm Phi2 x @ (ap g (ap10 q x))^)
: Phi1 = Phi2.
Proof.
  apply (triple_path _ Phi1 Phi2 p q).
  destruct Phi1 as [h1 [k1 alpha1]], Phi2 as [h2 [k2 alpha2]].
  unfold cospan_cone_map2 in q; simpl in p, q. destruct p, q.
  unfold cospan_cone_comm in r; simpl in *.
  apply path_forall. intros x.
  apply (concat (r x)). apply (concat_p1 _ @ concat_1p _).
Defined.

Definition cospan_cone_path'
  {A B C : Type} {f : A -> C} {g : B -> C} {X : Type}
  {Phi1 Phi2 : cospan_cone f g X}
: { p : cospan_cone_map1 Phi1 = cospan_cone_map1 Phi2
  & { q : cospan_cone_map2 Phi1 = cospan_cone_map2 Phi2
  & forall x:X,
       cospan_cone_comm Phi1 x
     = (ap f (ap10 p x)) @ cospan_cone_comm Phi2 x @ (ap g (ap10 q x))^ }}
-> Phi1 = Phi2
  := fun pqr => cospan_cone_path (pr1 pqr) (pr1 (pr2 pqr)) (pr2 (pr2 pqr)).

(* a converse to the above *)
Definition cospan_cone_path_comm
  {A B C : Type} {f : A -> C} {g : B -> C} {X : Type}
  {Phi1 Phi2 : cospan_cone f g X} (e : Phi1 = Phi2)
: forall x:X,
    cospan_cone_comm Phi1 x
  = (ap f (ap10 (ap cospan_cone_map1 e) x))
    @ cospan_cone_comm Phi2 x
    @ (ap g (ap10 (ap cospan_cone_map2 e) x))^.
Proof.
  intros x. destruct e; simpl. exact ((concat_p1 _ @ concat_1p _)^).
Defined.

Definition cospan_cone_path_map1
  {A B C : Type} {f : A -> C} {g : B -> C} {X : Type}
  {Phi1 Phi2 : cospan_cone f g X}
  (p : cospan_cone_map1 Phi1 = cospan_cone_map1 Phi2)
  (q : cospan_cone_map2 Phi1 = cospan_cone_map2 Phi2)
  (r : forall x:X,
    cospan_cone_comm Phi1 x
    = (ap f (ap10 p x))
      @ cospan_cone_comm Phi2 x
      @ (ap g (ap10 q x))^) :
  ap cospan_cone_map1 (cospan_cone_path p q r) = p.
Proof.
  apply pr1_triple_path.
Defined.

Definition cospan_cone_path_map2
  {A B C : Type} {f : A -> C} {g : B -> C} {X : Type}
  {Phi1 Phi2 : cospan_cone f g X}
  (p : cospan_cone_map1 Phi1 = cospan_cone_map1 Phi2)
  (q : cospan_cone_map2 Phi1 = cospan_cone_map2 Phi2)
  (r : forall x:X,
    cospan_cone_comm Phi1 x
    = (ap f (ap10 p x))
      @ cospan_cone_comm Phi2 x
      @ (ap g (ap10 q x))^)
: ap cospan_cone_map2 (cospan_cone_path p q r) = q.
Proof.
  apply (pr2_triple_path _ Phi1 Phi2).
Defined.

Lemma cospan_cone_path'_map1
  {A B C : Type} {f : A -> C} {g : B -> C}
  {X : Type} {Phi1 Phi2 : cospan_cone f g X}
  (pqr : {p : cospan_cone_map1 Phi1 = cospan_cone_map1 Phi2 &
         {q : cospan_cone_map2 Phi1 = cospan_cone_map2 Phi2 &
         forall x : X, cospan_cone_comm Phi1 x
           = (ap f (ap10 p x) @ cospan_cone_comm Phi2 x)
             @ (ap g (ap10 q x)) ^}})
: ap cospan_cone_map1 (cospan_cone_path' pqr) = pr1 pqr.
Proof.
  apply cospan_cone_path_map1.
Defined.

Lemma cospan_cone_path'_map2
  {A B C : Type} {f : A -> C} {g : B -> C}
  {X : Type} {Phi1 Phi2 : cospan_cone f g X}
  (pqr : {p : cospan_cone_map1 Phi1 = cospan_cone_map1 Phi2 &
         {q : cospan_cone_map2 Phi1 = cospan_cone_map2 Phi2 &
         forall x : X, cospan_cone_comm Phi1 x
           = (ap f (ap10 p x) @ cospan_cone_comm Phi2 x)
             @ (ap g (ap10 q x)) ^}})
: ap cospan_cone_map2 (cospan_cone_path' pqr) = pr1 (pr2 pqr).
Proof.
  apply cospan_cone_path_map2.
Defined.

(* TODO (mid): cospan_cone_path_comm, cospan_cone_path'_comm *)

End Cospan_Cone.

(*******************************************************************************

The universal property of pullbacks.

*******************************************************************************)

Section Pullback_UP.

(* TODO (high): try finding a naming scheme more related to the idea of “composition”. *)
Definition map_to_cospan_cone {A B C : Type} {f : A -> C} {g : B -> C}
  {P : Type} (D: cospan_cone f g P) (X : Type) (u : X -> P)
: cospan_cone f g X.
Proof.
  exists ((cospan_cone_map1 D) o u), ((cospan_cone_map2 D) o u).
  intros z; apply (cospan_cone_comm D).
Defined.

Definition is_pullback_cone {A B C : Type} {f : A -> C} {g : B -> C}
  {P : Type} (D : cospan_cone f g P)
:= forall (X : UU), IsEquiv (map_to_cospan_cone D X).

Lemma hprop_is_pullback_cone {A B C : Type} {f : A -> C} {g : B -> C}
  {P : Type} (D : cospan_cone f g P)
: IsHProp (is_pullback_cone D).
Proof.
(* Coq automatically finds [trunc_forall] and [hprop_isequiv]: *)
  exact _.
Defined.

Definition pullback_cospan_cone {A B C : Type} (f : A -> C) (g : B -> C)
  : cospan_cone f g (pullback f g)
:= mk_cospan_cone (@pullback_comm _ _ _ f g).

Definition map_to_pullback_to_cospan_cone
  {A B C : Type} {f : A -> C} {g : B -> C} {X : Type} (m : X -> pullback f g)
  : cospan_cone f g X
:= map_to_cospan_cone (pullback_cospan_cone f g) _ m.

Definition cospan_cone_to_map_to_pullback
  {A B C : Type} {f : A -> C} {g : B -> C} {X : Type} (D : cospan_cone f g X)
  : (X -> pullback f g).
Proof.
  intros x. exists (cospan_cone_map1 D x), (cospan_cone_map2 D x).
  exact (cospan_cone_comm D x).
Defined.

(* Most of the time, one can use this universal property opaquely, and doing so improves efficiency significantly.  However, sometimes one wants to recover the computational content.  There are several ways one could do this; we do it by giving first a transparent and then an opaque form, and providing an “unlocking” lemma to convert the latter to the former when required. *)
Lemma pullback_universal_transparent {A B C : Type} (f : A -> C) (g : B -> C)
: is_pullback_cone (pullback_cospan_cone f g).
Proof.
  intros X.
  apply (isequiv_adjointify (cospan_cone_to_map_to_pullback)).
  (* is_section *)
  intros [y1 [y2 y3]].
  unfold map_to_cospan_cone, cospan_cone_to_map_to_pullback.
  unfold cospan_cone_map2, cospan_cone_comm; simpl.
  unfold pullback_comm; simpl.
  exact 1.
  (* is_retraction *)
  intros m. apply path_forall.
  intros x; simpl.
  apply pullback_path'.
  exists 1, 1. simpl.
  exact (concat_p1 _ @ concat_1p _).
Defined.

(* The opaque version, to be used by default. *)
Lemma pullback_universal {A B C : Type} (f : A -> C) (g : B -> C)
: is_pullback_cone (pullback_cospan_cone f g).
Proof.
  apply pullback_universal_transparent.
Qed.

Lemma pullback_universal_unlock
: @pullback_universal = @pullback_universal_transparent.
Proof.
  do 5 (apply path_forall; intro).
  apply hprop_is_pullback_cone.
Qed.

End Pullback_UP.

(*******************************************************************************

An equivalent, and small, formulation of the abstract pullback property.

*******************************************************************************)

Section Pullback_UP'.

Definition is_pullback_cone' {A B C : Type} {f : A -> C} {g : B -> C} {P : Type}
  (D : cospan_cone f g P)
:= IsEquiv (cospan_cone_to_map_to_pullback D).

Lemma is_pullback_cone'_to_is_pullback_cone
  {A B C : Type} {f : A -> C} {g : B -> C} {P : Type} (D : cospan_cone f g P)
: is_pullback_cone' D -> is_pullback_cone D.
Proof.
  unfold is_pullback_cone, is_pullback_cone'. intros D_is_PB' X.
  assert (H : map_to_cospan_cone D X
             = (map_to_cospan_cone (pullback_cospan_cone f g) X)
             o (fun m : X -> P => cospan_cone_to_map_to_pullback D o m)).
    apply path_forall. intros m.
    apply cospan_cone_path'. simpl.
    exists 1, 1. simpl.
    intros x. apply inverse. exact (concat_p1 _ @ concat_1p _).
  rewrite H; clear H.
  apply @isequiv_compose.
  apply isequiv_postcompose; assumption.
  apply pullback_universal.
Qed.

Lemma is_pullback_cone_to_is_pullback_cone'
  {A B C : Type} {f : A -> C} {g : B -> C} {P : Type} (D : cospan_cone f g P)
: is_pullback_cone D -> is_pullback_cone' D.
Proof.
  intros D_is_pullback. unfold is_pullback_cone, is_pullback_cone' in *.
  set (e1 := (BuildEquiv (D_is_pullback Unit))).
  set (e2 := equiv_inverse
          (BuildEquiv (pullback_universal_transparent f g Unit))).
  set (e := equiv_compose' (equiv_inverse (well_pointedness (pullback f g)))
           (equiv_compose' e2
           (equiv_compose' e1
                           (well_pointedness P)))).
  assert (H : cospan_cone_to_map_to_pullback D = e).
    apply path_forall. intros x.
    apply pullback_path'; simpl.
    exists 1, 1; simpl.
    exact (concat_p1 _ @ concat_1p _).
  rewrite H.
  apply equiv_isequiv.
Defined.

End Pullback_UP'.

(*******************************************************************************

Properties of pullbacks in general, via U.P.’s.

*******************************************************************************)

Section Pullback_UP_facts.

(* TODO (med): is this really needed, or would it be more natural to go directly from [is_pullback_cone] to [abstract_pullback]? *)
Definition pullback_cone {A B C : Type} (f : A -> C) (g : B -> C) (P : Type)
:= { CP : cospan_cone f g P & is_pullback_cone CP }.

Definition pullback_cone_cone {A B C : Type} {f : A -> C} {g : B -> C}
  {P : Type} (CP : pullback_cone f g P)
:= pr1 CP : cospan_cone f g P.
Coercion pullback_cone_cone : pullback_cone >-> cospan_cone.

(* TODO (low): would it affect anything to make this opaque? *)
Definition pullback_cone_UP {A B C : Type} {f : A -> C} {g : B -> C}
  {P : Type} (CP : pullback_cone f g P)
:= pr2 CP : is_pullback_cone CP.

Record abstract_pullback {A B C : Type} (f : A -> C) (g : B -> C)
:= mk_abstract_pullback
  { abstract_pullback_vertex :> Type;
    abstract_pullback_cone :> pullback_cone f g abstract_pullback_vertex }.

Global Arguments mk_abstract_pullback [A B C f g P] CP : rename.
Global Arguments abstract_pullback_vertex [A B C f g] PB : rename.
Global Arguments abstract_pullback_cone [A B C f g] PB : rename.

(* For convenience, one can specify a [abstract_pullback] just by its UP. *)
Definition mk_abstract_pullback' {A B C : Type} {f : A -> C} {g : B -> C}
  {P : Type} {CP : cospan_cone f g P} (CP_UP : is_pullback_cone CP)
  := (mk_abstract_pullback (existT _ CP CP_UP))
: abstract_pullback f g.

Definition standard_pullback {A B C : Type} (f : A -> C) (g : B -> C)
  := mk_abstract_pullback' (pullback_universal f g)
: abstract_pullback f g.

(* TODO (low): the following is currently broken due to a bug(?) with univ poly(?):
  Canonical Structure standard_pullback.
Once fixed, many references to [standard_pullback] below can be changed back to simply [pullback]. *)

(* TODO (high): improve the following section to better reflect the paper?? *)
Lemma is_pullback_cone_resp_equiv {A B C : Type} {f : A -> C} {g : B -> C}
  {P P' : Type} (e : P' <~> P) (CP : cospan_cone f g P)
: is_pullback_cone CP -> is_pullback_cone (map_to_cospan_cone CP P' e).
Proof.
  intros CP_UP X.
  set (e1 := isequiv_postcompose X e).
  apply (@isequiv_compose _ _ _ e1 _ _ (CP_UP X)).
Qed.

(* [pullback_cone f g X] is functorial along equivalences in [X]. *)
Lemma pullback_cone_fequiv {A B C : Type} {f : A -> C} {g : B -> C}
  {P P' : Type} (e : P' <~> P)
: pullback_cone f g P -> pullback_cone f g P'.
Proof.
  intros CP.
  exists (map_to_cospan_cone CP P' e).
  apply is_pullback_cone_resp_equiv.
  exact (pullback_cone_UP CP).
Defined.

Lemma equiv_pullback_to_pullback_cone {A B C : Type} {f : A -> C} {g : B -> C}
  {P : Type} (e : P <~> (pullback f g))
: pullback_cone f g P.
Proof.
  apply (pullback_cone_fequiv e).
  exists (pullback_cospan_cone f g).
  apply pullback_universal.
Defined.

Lemma abstract_pullback_equiv_cospan_cone_1 {A B C : Type}
  {f : A -> C} {g : B -> C} (P : abstract_pullback f g)
: P <~> (cospan_cone f g Unit).
Proof.
  equiv_via (Unit -> P).
    apply well_pointedness.
  exists (map_to_cospan_cone P Unit).
  apply pullback_cone_UP.
Defined.

Lemma abstract_pullback_unique {A B C : Type} {f : A -> C} {g : B -> C}
  (PB1 PB2 : abstract_pullback f g)
: PB1 <~> PB2.
Proof.
  equiv_via (cospan_cone f g Unit).
    apply abstract_pullback_equiv_cospan_cone_1.
  apply equiv_inverse, abstract_pullback_equiv_cospan_cone_1.
Defined.

(* TODO (mid): we should really show if possible, that this map is the same as the (unique by construction) map that takes the cone of PB2 to the cone of PB1. *)

End Pullback_UP_facts.

(*******************************************************************************

The main goal of the next few sections is to prove functoriality of
the standard pullback construction.

For this, we first need to define and show some basic properties of
*aps of cospans*; these follow from the analogous results about
commutative squares.

*******************************************************************************)

Section Cospan_maps.

Record cospan_map
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' B' C' : Type} (f' : A' -> C') (g' : B' -> C')
:= mk_cospan_map
  { cospan_map_A : A -> A';
    cospan_map_B : B -> B';
    cospan_map_C : C -> C';
    cospan_map_f : f' o cospan_map_A == cospan_map_C o f;
    cospan_map_g : g' o cospan_map_B == cospan_map_C o g }.

Global Arguments cospan_map_A [A B C f g A' B' C' f' g'] k a : rename.
Global Arguments cospan_map_B [A B C f g A' B' C' f' g'] k b : rename.
Global Arguments cospan_map_C [A B C f g A' B' C' f' g'] k c : rename.
Global Arguments cospan_map_f [A B C f g A' B' C' f' g'] k a : rename.
Global Arguments cospan_map_g [A B C f g A' B' C' f' g'] k b : rename.
Global Arguments mk_cospan_map [A B C f g A' B' C' f' g'] kA kB kC kf kg :
  rename.

Record cospan_map_homot
  {A B C : Type} {f : A -> C} {g : B -> C}
  {A' B' C' : Type} {f' : A' -> C'} {g' : B' -> C'}
  {k1 k2 : cospan_map f g f' g'}
:= mk_cospan_map_homot
  { cospan_map_homot_A : cospan_map_A k1 == cospan_map_A k2;
    cospan_map_homot_B : cospan_map_B k1 == cospan_map_B k2;
    cospan_map_homot_C : cospan_map_C k1 == cospan_map_C k2;
    cospan_map_homot_f : forall a:A,
                         cospan_map_f k1 a @ cospan_map_homot_C (f a)
                       = ap f' (cospan_map_homot_A a) @ cospan_map_f k2 a;
    cospan_map_homot_g : forall b:B,
                         cospan_map_g k1 b @ cospan_map_homot_C (g b)
                       = ap g' (cospan_map_homot_B b) @ cospan_map_g k2 b}.

Global Arguments cospan_map_homot [A B C f g A' B' C' f' g'] k1 k2.
Global Arguments mk_cospan_map_homot [A B C f g A' B' C' f' g'] k1 k2
  _ _ _ _ _.

Lemma cospan_map_homot_to_path   {A B C : Type} {f : A -> C} {g : B -> C}
  {A' B' C' : Type} {f' : A' -> C'} {g' : B' -> C'}
  {k1 k2 : cospan_map f g f' g'}
  (h : cospan_map_homot k1 k2)
: k1 = k2.
Proof.
  destruct k1 as [k1_A k1_B k1_C k1_f k1_g],
           k2 as [k2_A k2_B k2_C k2_f k2_g],
           h as [hA hB hC hf hg]. simpl in *.
  revert hA hB hC hf hg.
  equiv_intro (@apD10 _ _ k1_A k2_A) hA.
  equiv_intro (@apD10 _ _ k1_B k2_B) hB.
  equiv_intro (@apD10 _ _ k1_C k2_C) hC.
  intros hf hg.
  destruct hA, hB, hC. simpl in *.
  assert (p : k1_f = k2_f).
    apply path_forall. intros x.
    exact ((concat_p1 _)^ @ hf _ @ concat_1p _).
  destruct p.
  assert (p : k1_g = k2_g).
    apply path_forall. intros x.
    exact ((concat_p1 _)^ @ hg _ @ concat_1p _).
  destruct p. exact 1.
Defined.

Definition cospan_idmap {A B C : Type} (f : A -> C) (g : B -> C)
  := mk_cospan_map (f := f) (g := g) idmap idmap idmap
    (fun _ => 1) (fun _ => 1)
: cospan_map f g f g.

Definition cospan_comp
  {A B C : Type} {f : A -> C} {g : B -> C}
  {A' B' C' : Type} {f' : A' -> C'} {g' : B' -> C'}
  {A'' B'' C'' : Type} {f'' : A'' -> C''} {g'' : B'' -> C''}
: cospan_map f' g' f'' g'' -> cospan_map f g f' g'
  -> cospan_map f g f'' g''
:= fun h k => mk_cospan_map
    (cospan_map_A h o cospan_map_A k)
    (cospan_map_B h o cospan_map_B k)
    (cospan_map_C h o cospan_map_C k)
    (comm_square_comp (cospan_map_f h) (cospan_map_f k))
    (comm_square_comp (cospan_map_g h) (cospan_map_g k)).

(* Important fact: a cospan map whose components are equivalences is itself
   an equivalence in the category of cospans. *)
Lemma cospan_equiv_inverse
  {A B C : Type} {f : A -> C} {g : B -> C}
  {A' B' C' : Type} {f' : A' -> C'} {g' : B' -> C'}
  (w : cospan_map f g f' g')
  (is_eq_wA : IsEquiv (cospan_map_A w))
  (is_eq_wB : IsEquiv (cospan_map_B w))
  (is_eq_wC : IsEquiv (cospan_map_C w))
: cospan_map f' g' f g.
Proof.
  set (wA := BuildEquiv is_eq_wA).
  set (wB := BuildEquiv is_eq_wB).
  set (wC := BuildEquiv is_eq_wC).
  apply (mk_cospan_map (wA^-1) (wB^-1) (wC^-1)).
  apply (@comm_square_inverse _ _ _ _ _ _ wA wC (cospan_map_f w)).
  apply (@comm_square_inverse _ _ _ _ _ _ wB wC (cospan_map_g w)).
Defined.

Lemma cospan_inverse_is_section
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' B' C' : Type} (f' : A' -> C') (g' : B' -> C')
  (w : cospan_map f g f' g')
  (is_eq_wA : IsEquiv (cospan_map_A w))
  (is_eq_wB : IsEquiv (cospan_map_B w))
  (is_eq_wC : IsEquiv (cospan_map_C w))
: cospan_comp w (cospan_equiv_inverse w is_eq_wA is_eq_wB is_eq_wC) =
  cospan_idmap f' g'.
Proof.
  apply cospan_map_homot_to_path.
  set (wA := BuildEquiv is_eq_wA).
  set (wB := BuildEquiv is_eq_wB).
  set (wC := BuildEquiv is_eq_wC).
  exists (eisretr wA) (eisretr wB) (eisretr wC); simpl.
  (* Square from [f] to [f']. *)
    intros a. apply (concatR (concat_p1 _)^).
    apply (comm_square_inverse_is_retr wA wC _ a).
  (* Square from [g] to [g']. *)
    intros b. apply (concatR (concat_p1 _)^).
    apply (comm_square_inverse_is_retr wB wC _ b).
Defined.

Lemma cospan_inverse_is_retraction
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' B' C' : Type} (f' : A' -> C') (g' : B' -> C')
  (w : cospan_map f g f' g')
  (is_eq_wA : IsEquiv (cospan_map_A w))
  (is_eq_wB : IsEquiv (cospan_map_B w))
  (is_eq_wC : IsEquiv (cospan_map_C w))
: cospan_comp (cospan_equiv_inverse w is_eq_wA is_eq_wB is_eq_wC) w =
    cospan_idmap f g.
Proof.
  apply cospan_map_homot_to_path.
  set (wA := BuildEquiv is_eq_wA).
  set (wB := BuildEquiv is_eq_wB).
  set (wC := BuildEquiv is_eq_wC).
  exists (eissect wA) (eissect wB) (eissect wC). simpl.
  (* Square from [f] to [f']. *)
    intros a. apply (concatR (concat_p1 _)^).
    apply (comm_square_inverse_is_sect wA wC _ a).
  (* Square from [g] to [g']. *)
    intros b. apply (concatR (concat_p1 _)^).
    apply (comm_square_inverse_is_sect wB wC _ b).
  (* Require [comm_square_inverse_is_sect]. *)
Defined.

End Cospan_maps.

(*******************************************************************************

Functoriality of the standard pullback.

*******************************************************************************)

Section Pullbacks_Functoriality.

(* Functoriality of pullback *)
Lemma pullback_fmap
  {A B C : Type} {f : A -> C} {g : B -> C}
  {A' B' C' : Type} {f' : A' -> C'} {g' : B' -> C'}
: cospan_map f g f' g'
  -> pullback f g -> pullback f' g'.
Proof.
  intros k abp. set (a := pullback_pr1 abp); set (b := pullback_pr2 abp).
  apply (mk_pullback f' g' (cospan_map_A k a) (cospan_map_B k b)).
  path_via' (cospan_map_C k (f a)). apply cospan_map_f.
  path_via' (cospan_map_C k (g b)). apply ap, pullback_comm.
  apply inverse, cospan_map_g.
Defined.

Lemma pullback_fmap_id
  {A B C : Type} (f : A -> C) (g : B -> C)
  : pullback_fmap (cospan_idmap f g) == idmap.
Proof.
  intros abp. apply pullback_path'.
  exists 1, 1. simpl.
  unfold pullback_comm, pullback_pr2; simpl. hott_simpl.
Defined.

(* TODO (low): a better associativity tactic would vastly simplify this
   proof!
   TODO (low): rewrite to avoid destructing? *)
Lemma pullback_fmap_comp
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' B' C' : Type} (f' : A' -> C') (g' : B' -> C')
  {A'' B'' C'' : Type} (f'' : A'' -> C'') (g'' : B'' -> C'')
  (h : cospan_map f' g' f'' g'') (k : cospan_map f g f' g')
: pullback_fmap (cospan_comp h k)
  == (pullback_fmap h) o (pullback_fmap k).
Proof.
  destruct h as [hA hB hC hf hg], k as [kA kB kC kf kg].
  intros [a [b p]]. unfold cospan_comp; simpl.
  apply pullback_path'. simpl.
  exists 1, 1. simpl.
  apply (concat (concat_p1 _)), (concat (concat_1p _)).
  unfold pullback_comm, pullback_pr2; simpl.
  unfold comm_square_comp.
  apply (concat (concat_pp_p)), whiskerL.
  apply (concatR (whiskerR (ap_pp hC _ _)^ _)).
  apply (concatR (concat_p_pp)), whiskerL.
  path_via' (ap hC (ap kC p) @ ap hC (kg b)^ @ (hg (kB b))^).
    apply (concatR (concat_p_pp)).
    apply concat2.
      apply (ap_compose kC hC).
    apply (concat (inv_pp _ _)), whiskerR.
    apply inverse, ap_V.
  apply whiskerR, inverse, ap_pp.
Defined.

End Pullbacks_Functoriality.

(*******************************************************************************

Functoriality of pullbacks along equivalences.

The general form can be deduced from the general functoriality of pullbacks.

*******************************************************************************)

Section Pullbacks_Equiv_Functoriality.

Lemma pullback_fmap_isequiv
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' B' C' : Type} (f' : A' -> C') (g' : B' -> C')
  (w : cospan_map f g f' g')
  (ewA : IsEquiv (cospan_map_A w))
  (ewB : IsEquiv (cospan_map_B w))
  (ewC : IsEquiv (cospan_map_C w))
: IsEquiv (pullback_fmap w).
Proof.
  set (w_inv := cospan_equiv_inverse w ewA ewB ewC).
  apply isequiv_adjointify with (pullback_fmap w_inv).
  (* is_section *)
  intros y.
  path_via (pullback_fmap (cospan_comp w w_inv) y).
    apply inverse. apply pullback_fmap_comp.
  path_via (pullback_fmap (cospan_idmap f' g') y).
    apply ap10. apply ap.
    apply cospan_inverse_is_section.
  apply pullback_fmap_id.
  (* is_retraction *)
  intros x.
  path_via (pullback_fmap (cospan_comp w_inv w) x).
    apply inverse. apply pullback_fmap_comp.
  path_via (pullback_fmap (cospan_idmap f g) x).
    apply ap10. apply ap.
    apply cospan_inverse_is_retraction.
  apply pullback_fmap_id.
Qed.

Lemma pullback_fmap_equiv
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' B' C' : Type} (f' : A' -> C') (g' : B' -> C')
  (w : cospan_map f g f' g')
  (ewA : IsEquiv (cospan_map_A w))
  (ewB : IsEquiv (cospan_map_B w))
  (ewC : IsEquiv (cospan_map_C w))
: pullback f g <~> pullback f' g'.
Proof.
  exists (pullback_fmap w). apply pullback_fmap_isequiv; assumption.
Defined.

(* A handy re-currying of [pullback_fmap_equiv], allowing arguments to be
   given one at a time. *)
Lemma pullback_fmap_equiv'
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' B' C' : Type} (f' : A' -> C') (g' : B' -> C')
: { wA : A -> A'
    & { ewA : IsEquiv wA
    & { wB : B -> B'
    & { ewB : IsEquiv wB
    & { wC : C -> C'
    & { ewC : IsEquiv wC
    & { wf : f' o wA == wC o f
    &       g' o wB == wC o g
    }}}}}}}
  -> pullback f g <~> pullback f' g'.
Proof.
  intros [wA [ewA [wB [ewB [wC [ewC [wf wg]]]]]]].
  set (w := mk_cospan_map wA wB wC wf wg).
  apply pullback_fmap_equiv with w; assumption.
Defined.

Lemma pullback_resp_equiv_A
  {A B C : Type} (f : A -> C) (g : B -> C)
  {A' : Type} (w : A <~> A')
: pullback f g <~> pullback (f o (equiv_inv w)) g.
Proof.
  apply (pullback_fmap_equiv _ _ _ _
    (@mk_cospan_map _ _ _ _ _ _ _ _ (f o (w ^-1)) g
    w idmap idmap
    (fun a => ap f (eissect w a)) (fun b => 1)));
  simpl.
  apply equiv_isequiv. apply isequiv_idmap. apply isequiv_idmap.
Defined.

End Pullbacks_Equiv_Functoriality.

(*******************************************************************************

The two pullbacks lemma(ta).

Here we show (the “concrete” version) that the standardly-constructed
double pullback is equal to the standardly-constructed one-step pullback.

In Pullbacks3.v, we show (the “abstract” form) that given any pair of suitably
composable squares, if the right-hand square is a pullback, then the outer
rectangle is if and only if the left-hand square is.

*******************************************************************************)

(******************************************************************************

To show: when we package a cone up into a map and then unpack it,
we recover the components of the original cone.

*******************************************************************************)

Section cospan_cones_vs_UP_pullback.

Definition packed_cospan_cone_map1
  {A B C : Type} {f : A -> C} {g : B -> C} (P : abstract_pullback f g)
  {X : Type} (CX : cospan_cone f g X)
  (P_UP_at_X := BuildEquiv (pullback_cone_UP P X))
: (cospan_cone_map1 P) o (P_UP_at_X ^-1 CX) = cospan_cone_map1 CX.
Proof.
  change (cospan_cone_map1 P o P_UP_at_X^-1 CX)
    with (cospan_cone_map1 (P_UP_at_X (P_UP_at_X^-1 CX))).
  apply ap, eisretr.
Defined.

Definition packed_cospan_cone_map2
  {A B C : Type} {f : A -> C} {g : B -> C} (P : abstract_pullback f g)
  {X : Type} (CX : cospan_cone f g X)
  (P_UP_at_X := BuildEquiv (pullback_cone_UP P X))
: (cospan_cone_map2 P) o (P_UP_at_X ^-1 CX) = cospan_cone_map2 CX.
Proof.
  change (cospan_cone_map2 P o P_UP_at_X^-1 CX)
    with (cospan_cone_map2 (P_UP_at_X (P_UP_at_X^-1 CX))).
  apply ap, eisretr.
Defined.

Definition packed_cospan_cone_comm
  {A B C : Type} {f : A -> C} {g : B -> C} (P : abstract_pullback f g)
  {X : Type} (CX : cospan_cone f g X)
  (P_UP_at_X := BuildEquiv (pullback_cone_UP P X))
: forall x:X,
    (cospan_cone_comm P (P_UP_at_X ^-1 CX x))
  =
    (ap f (ap10 (packed_cospan_cone_map1 _ CX) x))
    @ (cospan_cone_comm CX x)
    @ (ap g (ap10 (packed_cospan_cone_map2 _ CX) x))^.
Proof.
  intros x.
  change (cospan_cone_comm P (P_UP_at_X ^-1 CX x))
  with (cospan_cone_comm (P_UP_at_X (P_UP_at_X ^-1 CX)) x).
  apply (cospan_cone_path_comm (eisretr P_UP_at_X CX)).
Defined.

End cospan_cones_vs_UP_pullback.

(*******************************************************************************
The *concrete* two pullbacks lemma:

This lemma states that given maps

                A
                |f
                V
B2 -h-> B1 -g-> C

the (standard) pullback of the overall rectangle, [pullback f (g o h)],
is equivalent to the pullback constructed in two steps.
*******************************************************************************)

Section Concrete_Two_Pullbacks_Lemma.

Context {A B1 B2 C : Type} (f : A -> C) (g : B1 -> C) (h : B2 -> B1).

Definition outer_to_double_pullback
: (pullback f (g o h)) -> (pullback (g ^* f) h).
Proof.
  intros adp.
  exists (mk_pullback f g (pullback_pr1 adp) (h (pullback_pr2 adp))
          (pullback_comm adp)).
  exists (pullback_pr2 adp). exact 1.
Defined.

Definition double_to_outer_pullback
: (pullback (g ^* f) h) -> (pullback f (g o h)).
Proof.
  intros abpdq.
  exists (pullback_pr1 (pullback_pr1 abpdq)),
         (pullback_pr2 (abpdq)).
  path_via (g (pullback_pr2 (pullback_pr1 abpdq))).
    apply pullback_comm.
  apply ap, pullback_comm.
Defined.

Lemma two_pullbacks_isequiv: IsEquiv (outer_to_double_pullback).
Proof.
  apply (isequiv_adjointify double_to_outer_pullback).
  (* is_section *)
  intros [[a [b p]] [d q]]. unfold pullback_pr2 in q; simpl in q.
  apply pullback_path'.
  exists (pullback_path (a; (h d; p @ ap g q)) (a; (b; p)) 1 q^
    (concat_pp_p @ concat_1p _ @ (whiskerL _ (ap_V _ _))
       @ concat_pp_V p (ap g q))).
  exists 1.
  apply (concat (concat_p1 _)), (concat (concat_p1 _)).
  apply (concatR (inv_V _)), ap.
  apply (pullback_path_pr2 (a; (h d; p @ ap g q)) (a; (b; p))).
  (* is_retraction *)
  intros [a [d p]]. simpl.
  apply pullback_path'. exists 1, 1. simpl.
  apply (concat (concat_p1 _)), (concat (concat_1p _)).
  apply concat_p1.
Qed.

Definition two_pullbacks_equiv
  : (pullback f (g o h)) <~> (pullback (g ^* f) h)
:= BuildEquiv two_pullbacks_isequiv.

End Concrete_Two_Pullbacks_Lemma.

(*
Local Variables:
coq-prog-name: "hoqtop"
End:
*)


Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Relations.Relation_Operators.
Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Arith.Even.
Require Import Coq.Arith.Div2.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Coq.Classes.RelationClasses.

Definition image_defined {A B} (R: A -> B -> Prop): Prop :=
  forall a, exists b, R a b.

Definition partial_functional {A B} (R: A -> B -> Prop): Prop :=
  forall a b1 b2, R a b1 -> R a b2 -> b1 = b2.

Definition injective {A B} (R: A -> B -> Prop): Prop :=
  forall a1 a2 b, R a1 b -> R a2 b -> a1 = a2.

Definition surjective {A B} (R: A -> B -> Prop): Prop :=
  forall b, exists a, R a b.

Definition function_injective {A B} (f: A -> B): Prop :=
  forall a1 a2, f a1 = f a2 -> a1 = a2.

Definition function_surjective {A B} (f: A -> B): Prop :=
  forall b, exists a, f a = b.

Record injection (A B: Type): Type := {
  inj_R:> A -> B -> Prop;
  im_inj: image_defined inj_R;
  pf_inj: partial_functional inj_R;
  in_inj: injective inj_R
}.

Record surjection (A B: Type): Type := {
  surj_R:> A -> B -> Prop;
  im_surj: image_defined surj_R;
  pf_surj: partial_functional surj_R;
  su_surj: surjective surj_R
}.

Record bijection (A B: Type): Type := {
  bij_R:> A -> B -> Prop;
  im_bij: image_defined bij_R;
  pf_bij: partial_functional bij_R;
  in_bij: injective bij_R;
  su_bij: surjective bij_R
}.

Definition FBuild_injection (A B: Type) (f: A -> B) (H: function_injective f): injection A B.
  apply (Build_injection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
Defined.

Definition FBuild_surjection (A B: Type) (f: A -> B) (H: function_surjective f): surjection A B.
  apply (Build_surjection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
Defined.

Definition FBuild_bijection (A B: Type) (f: A -> B) (H: function_injective f) (H0: function_surjective f): bijection A B.
  apply (Build_bijection _ _ (fun a b => f a = b)).
  + hnf; intros; eauto.
  + hnf; intros; congruence.
  + hnf; intros.
    apply H; congruence.
  + hnf; intros.
    apply H0.
Defined.

Lemma injective_compose {A B C} (R1: A -> B -> Prop) (R2: B -> C -> Prop):
  injective R1 ->
  injective R2 ->
  injective (fun a c => exists b, R1 a b /\ R2 b c).
Proof.
  unfold injective.
  intros.
  destruct H1 as [b1 [? ?]], H2 as [b2 [? ?]].
  specialize (H0 _ _ _ H3 H4).
  subst b2.
  specialize (H _ _ _ H1 H2).
  auto.
Qed.

Lemma injective_compose_rev {A B C} (R1: A -> B -> Prop) (R2: B -> C -> Prop):
  image_defined R2 ->
  injective (fun a c => exists b, R1 a b /\ R2 b c) ->
  injective R1.
Proof.
  unfold injective, image_defined.
  intros.
  pose proof H b as [c ?].
  apply H0 with c; exists b; auto.
Qed.

Definition injection_trans {A B C} (R1: injection A B) (R2: injection B C): injection A C.
  intros.
  apply (Build_injection _ _ (fun a c => exists b, R1 a b /\ R2 b c)).
  + hnf; intros.
    destruct (im_inj _ _ R1 a) as [b ?].
    destruct (im_inj _ _ R2 b) as [c ?].
    exists c; eauto.
  + hnf; intros a c1 c2 [b1 [? ?]] [b2 [? ?]].
    pose proof pf_inj _ _ R1 a b1 b2 H H1.
    subst b2.
    pose proof pf_inj _ _ R2 b1 c1 c2 H0 H2.
    auto.
  + hnf; intros a1 a2 c [b1 [? ?]] [b2 [? ?]].
    pose proof in_inj _ _ R2 b1 b2 c H0 H2.
    subst b2.
    pose proof in_inj _ _ R1 a1 a2 b1 H H1.
    auto.
Defined.

Definition bijection_sym {A B} (R: bijection A B): bijection B A.
  apply (Build_bijection _ _ (fun a b => R b a)).
  + hnf.
    apply (su_bij _ _ R).
  + hnf; intros.
    apply (in_bij _ _ R b1 b2 a); auto.
  + hnf; intros.
    apply (pf_bij _ _ R b a1 a2); auto.
  + hnf.
    apply (im_bij _ _ R).
Defined.

Definition bijection_refl {A}: bijection A A.
  apply (Build_bijection _ _ eq).
  + hnf; intros.
    eauto.
  + hnf; intros.
    congruence.
  + hnf; intros.
    congruence.
  + hnf; intros.
    eauto.
Defined.

Definition sum_injection {A1 B1 A2 B2} (R1: injection A1 B1) (R2: injection A2 B2): injection (sum A1 A2) (sum B1 B2).
Proof.
  intros.
  apply (Build_injection _ _ (fun a b =>
          match a, b with
          | inl a, inl b => R1 a b
          | inr a, inr b => R2 a b
          | _, _ => False
          end)).
  + hnf; intros.
    destruct a as [a | a].
    - destruct (im_inj _ _ R1 a) as [b ?].
      exists (inl b); auto.
    - destruct (im_inj _ _ R2 a) as [b ?].
      exists (inr b); auto.
  + hnf; intros.
    destruct a as [a | a], b1 as [b1 | b1], b2 as [b2 | b2]; try solve [inversion H | inversion H0].
    - f_equal; apply (pf_inj _ _ R1 a); auto.
    - f_equal; apply (pf_inj _ _ R2 a); auto.
  + hnf; intros.
    destruct a1 as [a1 | a1], a2 as [a2 | a2], b as [b | b]; try solve [inversion H | inversion H0].
    - f_equal; apply (in_inj _ _ R1 _ _ b); auto.
    - f_equal; apply (in_inj _ _ R2 _ _ b); auto.
Defined.

Definition prod_injection {A1 B1 A2 B2} (R1: injection A1 B1) (R2: injection A2 B2): injection (prod A1 A2) (prod B1 B2).
Proof.
  intros.
  apply (Build_injection _ _ (fun a b => R1 (fst a) (fst b) /\ R2 (snd a) (snd b))).
  + hnf; intros.
    destruct (im_inj _ _ R1 (fst a)) as [b1 ?].
    destruct (im_inj _ _ R2 (snd a)) as [b2 ?].
    exists (b1, b2); auto.
  + hnf; intros.
    destruct b1, b2, H, H0.
    pose proof pf_inj _ _ R1 (fst a) _ _ H H0.
    pose proof pf_inj _ _ R2 (snd a) _ _ H1 H2.
    simpl in *; subst; auto.
  + hnf; intros.
    destruct a1, a2, H, H0.
    pose proof in_inj _ _ R1 _ _ _ H H0.
    pose proof in_inj _ _ R2 _ _ _ H1 H2.
    simpl in *; subst; auto.
Defined.

Definition sigT_injection (I: Type) (A: I -> Type) (B: Type) (R: forall i: I, injection (A i) B): injection (sigT A) (I * B).
  apply (Build_injection _ _ (fun a b => projT1 a = fst b /\ (R (projT1 a)) (projT2 a) (snd b))).
  + hnf; intros.
    destruct a as [i a0].
    destruct (im_inj _ _ (R i) a0) as [b0 ?].
    exists (i, b0).
    auto.
  + hnf; intros.
    destruct b1 as [i1 b1]; simpl in H.
    destruct b2 as [i2 b2]; simpl in H0.
    destruct H, H0; subst.
    pose proof pf_inj _ _ (R (projT1 a)) _ _ _ H1 H2.
    subst; auto.
  + hnf; intros.
    destruct b, H, H0; simpl in *; subst.
    destruct a1, a2; simpl in *; subst.
    pose proof in_inj _ _ (R x) _ _ _ H1 H2.
    subst; auto.
Qed.

Definition bijection_injection {A B} (R: bijection A B): injection A B :=
  Build_injection _ _ R (im_bij _ _ R) (pf_bij _ _ R) (in_bij _ _ R).

Definition nat2_nat_bijection: bijection (sum nat nat) nat.
  apply (Build_bijection _ _ (fun n m => match n with | inl n => m = n + n | inr n => m = n + n +1 end)).
  + hnf; intros.
    destruct a; eauto.
  + hnf; intros.
    destruct a; inversion H; inversion H0; auto.
  + hnf; intros.
    destruct a1, a2; inversion H; inversion H0; destruct (lt_eq_lt_dec n n0) as [[? | ?] | ?]; try omega; subst; auto.
  + hnf; intros.
    destruct (Even.even_odd_dec b) as [H | H].
    - rewrite (proj1 (Div2.even_odd_double _)), NPeano.double_twice in H.
      exists (inl (Div2.div2 b)).
      rewrite H at 1. omega.
    - rewrite (proj2 (Div2.even_odd_double _)), NPeano.double_twice in H.
      exists (inr (Div2.div2 b)).
      rewrite H at 1. omega.
Defined.

Definition natnat_nat_bijection: bijection (prod nat nat) nat.
  apply (Build_bijection _ _
          (fun n m => m = match n with | (n1, n2) =>
                            (fix sum (x: nat): nat := match x with | O => O | S x => S x + sum x end)
                              (n1 + n2)
                            + n1
                          end)).
  + hnf; intros.
    destruct a; eauto.
  + hnf; intros.
    destruct a; omega.
  + hnf; intros.
    destruct a1 as [a11 a12], a2 as [a21 a22].
    assert (forall m1 m2, m1 < m2 ->
      (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) m1 + m1 <
      (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) m2).
    {
      intros.
      remember (m2 - m1 - 1) as d; assert (m2 = (S d) + m1) by omega.
      subst m2; clear.
      induction d.
      + simpl.
        omega.
      + simpl in *.
        omega.
    }
    destruct (lt_eq_lt_dec (a11 + a12) (a21 + a22)) as [[HH | HH] | HH].
    - specialize (H1 _ _ HH).
      omega.
    - rewrite HH in H.
      assert (a11 = a21) by omega.
      assert (a12 = a22) by omega.
      subst; auto.
    - specialize (H1 _ _ HH).
      omega.
  + hnf; intros.
    assert (exists s,
        (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) s <= b <
        (fix sum (x : nat) : nat :=
          match x with
          | 0 => 0
          | S x0 => S x0 + sum x0
          end) (S s)).
    {
      induction b.
      + exists 0; simpl.
        omega.
      + destruct IHb as [s ?].
        remember (b - (fix sum (x : nat) : nat :=
                         match x with
                         | 0 => 0
                         | S x0 => S x0 + sum x0
                         end) s) as d.
        destruct (lt_dec d s) as [HH | HH].
        - exists s; simpl in *; omega.
        - exists (S s); simpl in *; omega.
    }
    destruct H as [s ?].
    remember (b - (fix sum (x : nat) : nat :=
                match x with
                | 0 => 0
                | S x0 => S x0 + sum x0
                end) s) as a1.
    exists (a1, s - a1).
    replace (a1 + (s - a1)) with s by omega.
    omega.
Defined.


From Undecidability Require Import PSL.Prelim L.Prelim.MoreBase.
From Complexity.Complexity Require Import Monotonic.
Require Import smpl.Smpl.
Require Import Nat Lia.

(** ** O notation *)

Definition inO (f g : nat -> nat) : Prop := exists c n0, forall n, n0 <= n -> f n <= c * g n.

Notation " f ∈O g" := (inO f g) (at level 70).

#[export]
Instance inO_PreOrder : PreOrder inO.
Proof.
  split.
  -exists 1,0. intros. Lia.lia.
  -intros f g h (c&n0&H) (c'&n0'&H').
   exists (c*c'),(max n0 n0').
   intros n Hn.
   rewrite H,H'. all:Lia.lia.
Qed.

#[export]
Instance inO_pointwise_leq : Proper ( Basics.flip (pointwise_relation _ le)  ==>  (pointwise_relation _ le) ==> Basics.impl) inO.
Proof.
  intros ? ? R1 ? ? R2. unfold inO. hnf in R1,R2|-*.
  setoid_rewrite R1. setoid_rewrite R2. easy.
Qed.

#[export]
Instance inO_pointwise_eq: Proper ((pointwise_relation _ eq) ==> (pointwise_relation _ eq) ==> iff) inO.
Proof.
  intros ? ? R1 ? ? R2. hnf in R1,R2.
  unfold inO. setoid_rewrite R1. setoid_rewrite R2. easy.
Qed.

Lemma inO_add_l f1 f2  g:
  f1 ∈O g -> f2 ∈O g -> (fun n => f1 n + f2 n) ∈O g.
Proof.
  intros (c1&n1&H1) (c2&n2&H2).
  eexists (c1 + c2),(max n1 n2).
  intros.
  rewrite H1,H2.
  all:Lia.lia.
Qed.

Lemma inO_mul_c_l c f1  g:
  f1 ∈O g -> (fun n => c * f1 n) ∈O g.
Proof.
  intros (c1&n1&H1).
  eexists (c1*c), (n1).
  intros.
  rewrite H1.
  all:Lia.lia.
Qed.

Lemma inO_mul_c_r c f1  g:
  f1 ∈O g -> (fun n => f1 n * c) ∈O g.
Proof.
  intros (c1&n1&H1).
  eexists (c1*c),(n1).
  intros.
  rewrite H1.
  all:Lia.lia.
Qed.

Lemma inO_c c f':
  (fun _ => 1) ∈O f' ->
  (fun _ => c ) ∈O f'.
Proof.
  intros H'.
  assert (H:c<= 1*c) by lia.
  setoid_rewrite H. eapply inO_mul_c_r. easy.
Qed.
(*
Lemma inO_c c n0 f':
  (forall n', n0 <= n' -> 1 <= f' n') ->
  (fun _ => c ) ∈O f'.
Proof.
  eexists (c),(n0).
  intros. rewrite <- H. all:Lia.nia.
Qed. *)

Lemma inO_leq n0 f' g:
  (forall n', n0 <= n' -> f' n' <= g n') ->
  f' ∈O g.
Proof.
  eexists 1,(n0).
  intros. rewrite <- H. all:Lia.nia.
Qed.

Smpl Create inO.

Smpl Add 11 (smpl monotonic) : inO.

Smpl Add 10 (first [ simple eapply inO_add_l | simple eapply inO_mul_c_l | simple eapply inO_mul_c_r | progress (eapply inO_c) | reflexivity]) (*
                    | simple eapply inO_c with (n0:=1);intro;try rewrite <- !f_geq_n;Lia.nia
                                 | inO_leq 1])*) : inO.

Ltac smpl_inO := repeat (smpl inO).

Lemma inO_mul_l f1 f2  g1 g2:
  f1 ∈O g1 -> f2 ∈O g2 -> (fun n => f1 n * f2 n) ∈O (fun n => g1 n * g2 n).
Proof.
  intros (c1&n1&H1) (c2&n2&H2).
  eexists (c1 * c2),(max n1 n2).
  intros.
  rewrite H1,H2.
  all:Lia.lia.
Qed.

Lemma inO_comp_l f1 f2  g1 g2:
  f1 ∈O g1 -> f2 ∈O g2 ->
  monotonic f1 ->
  (forall x, x <= g2 x ) ->
  (forall c, (fun x => g1 (c*x)) ∈O g1) -> (fun n => f1 (f2 n)) ∈O (fun n => g1 (g2 n)).
Proof.
  intros (c1&n1&H1) (c2&n2&H2) mono2 H' H.
  specialize (H (c2+n1)) as (c2'&n2'&H).
  eexists (c1 * c2'),(max (max 1 n2') n2).
  intros.
  etransitivity.
  {hnf in mono2. rewrite mono2. reflexivity. transitivity ((c2+n1)*(g2 n)). 2:reflexivity. rewrite H2. Lia.nia. lia. }
  specialize (H' n).
  setoid_rewrite H1. 2:Lia.nia.
  rewrite H. Lia.nia. Lia.nia.
Qed.

Lemma inO__bound f g (H:f ∈O g) : exists c, forall n, f n <= c + c * g n.
Proof.
  destruct H as (c0&n0&H). cbn.
  exists (max c0 (maxl (map f (natsLess n0)))).
  intros n.
  decide (n0<=n).
  -rewrite H. all:Lia.nia.
  -rewrite (@maxl_leq (f n) (map f (natsLess n0))). Lia.nia. apply in_map_iff. setoid_rewrite natsLess_in_iff. exists n. lia.
Qed.

(** *** smallO *)

(** This variant of smallo does not need real nubers, as we moved the constant to the other side *)
Definition ino (f g : nat -> nat) : Prop := forall c__inv, exists n0 , forall n, n0 <= n -> c__inv * f n < g n.

Notation " f ∈o g" := (ino f g) (at level 70).

(*Definition n__ino f g (H:f ∈o g) c0 (H' : 0 < c0) : nat := proj1_sig (ino__correct H c0 H').

Definition correct_n__ino f g (H:f ∈o g) c0 (H' : 0 < c0)
  : forall n, n__ino H H' <= n -> f n < c0 * g n := proj2_sig (ino__correct H c0 H').
 *)

Lemma ino_inO_incl f g :
  f ∈o g -> f ∈O g.
Proof.
  intros H.
  specialize (H 1) as (c__ino&H).
  exists 1,c__ino. intros ? ?%H. lia.
Qed.

(** ** O(poly)*)

Definition inOPoly (f : nat -> nat) : Prop :=
  exists n, f ∈O (fun x => x ^ n).

Lemma inOPoly_c c: inOPoly (fun _ => c).
Proof.
  exists 1. eapply inO_c. cbn. eapply (inO_leq (n0:=1)). intros. lia.
Qed.

Lemma inOPoly_x: inOPoly (fun x => x).
Proof.
  exists 1. cbn. eapply (inO_leq (n0:=1)). intros. lia.
Qed.

Lemma inOPoly_add f1 f2: inOPoly f1 -> inOPoly f2 -> inOPoly (fun x => f1 x + f2 x).
Proof.
  intros (n1&?) (n2&?).
  exists (max n1 n2).
  eapply inO_add_l.
  all:etransitivity;[eassumption|].
  all:eapply inO_leq with (n0:=1).
  all:intros ? ?.
  all:eapply Nat.pow_le_mono_r. all:Lia.nia.
Qed.

Lemma inOPoly_mul f1 f2: inOPoly f1 -> inOPoly f2 -> inOPoly (fun x => f1 x * f2 x).
Proof.
  intros (n1&?) (n2&?).
  exists (n1+n2).
  transitivity (fun x : nat => x ^ n1 * x^n2).
  1:now eauto using inO_mul_l.
  all:eapply inO_leq with (n0:=0).
  all:intros ? _.
  rewrite Nat.pow_add_r. Lia.nia.
Qed.

Lemma inOPoly_pow f c: inOPoly f -> inOPoly (fun x => f x ^ c).
Proof.
  intros (n&H). exists (n*c).
  destruct H as (n0 & n1&H).
  eexists _, n1.
  intros ? H'%H. rewrite Nat.pow_le_mono_l. 2:eassumption.
  rewrite Nat.pow_mul_l,Nat.pow_mul_r. reflexivity.
Qed.

Lemma inOPoly_S f : inOPoly f -> inOPoly (fun x => S (f x)).
Proof.
  intros H. eapply (@inOPoly_add (fun _ => 1) f). 2: apply H.
  apply inOPoly_c.
Qed.

Lemma inOPoly_comp f1 f2: monotonic f1 -> inOPoly f1 -> inOPoly f2 -> inOPoly (fun x => f1 (f2 x)).
Proof.
  intros ? (n1&?) (n2&?).
  exists ((max 1 n2)*n1).
  etransitivity.
  {eapply inO_comp_l with (g2:=(fun x => x ^(max 1 n2))).
   1,3:eassumption.
   -rewrite H1. apply inO_leq with (n0:=1). intros.
    eapply Nat.pow_le_mono;lia.
   -intros. replace x with (x^1) at 1 by (cbn;Lia.nia).
    decide (x=0). 2:now eapply Nat.pow_le_mono;Lia.nia.
    subst x. rewrite !Nat.pow_0_l. all:Lia.nia.
   -cbn beta. intros c.
    exists (c^n1),0. intros.
    rewrite Nat.pow_mul_l. reflexivity.
  }
  cbn beta.
  eapply inO_leq with (n0:=0). intros.
  rewrite Nat.pow_mul_r. reflexivity.
Qed.

Smpl Add 10 (first [ simple eapply inOPoly_add | simple eapply inOPoly_S | simple eapply inOPoly_mul | simple eapply inOPoly_c | simple eapply inOPoly_pow | simple eapply inOPoly_x | eassumption])  : inO.

#[export]
Instance inO_inOPoly_trans : Proper (Basics.flip inO ==> Basics.impl) inOPoly.
Proof.
  intros ? ? ? [? R2]. unfold inOPoly. eexists. setoid_rewrite <- R2. easy.
Qed.

#[export]
Instance inOPoly_pointwise_leq: Proper (Basics.flip (pointwise_relation _ le) ==> Basics.impl) inOPoly.
Proof.
  unfold inOPoly.
  intros ? ? R1. hnf in |-*. setoid_rewrite R1. easy.
Qed.

#[export]
Instance inOPoly_pointwise_eq: Proper ((pointwise_relation _ eq) ==> iff) inOPoly.
Proof.
  unfold inOPoly. intros ? ? R1. hnf. setoid_rewrite R1. easy.
Qed.