Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops Functor.Representable.Hom_Func_Prop.
Require Import Functor.Functor_Extender.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.
Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat.
Require Import Adjunction.Adjunction Adjunction.Duality Adjunction.Adj_Facts.
Require Import KanExt.Global KanExt.Local KanExt.LocalFacts.Uniqueness KanExt.GlobalDuality.

Local Open Scope functor_scope.

(** This module contains conversion from local to global kan extensions.
That is, we show that if we have all local kan extensions, we also have
the global kan extension.
 *)

(** To do this, we need to build a functor from (Func_Cat C D) to (Func_Cat C' D).
That means we have to prvide a natural transformation (a cone morph) from the
local kan extension of one functor to the local kan extension of another functor.
Of course, this is easy as each local right kan extension is the terminal object
of the category of cones there always is a cone morph to it. The only practical
difficulty is converting the local kan extension of a functor (which is a cone
for that functor) to the cone of another functor – and provide necessary tools
for conversion. This is waht we do below.
*)
Section Local_to_Global_Right.
  Context {C C' : Category}
          (p : C –≻ C')
          (D : Category)
          (rke : ∀ F : C –≻ D,  Local_Right_KanExt p F)
  .

  (** Conversion from a cone of a functor to the cone of another functor.
The appex remains the same (the objects in D are not changed) but the
cone_edge does – see below. *)
  Section Cone_conv.
    Context {F G : C –≻ D} (N : (F –≻ G)%nattrans) (Cn : LoKan_Cone p F).

    Definition Cone_conv : LoKan_Cone p G :=
      {|
        cone_apex := Cn;
        cone_edge := NatTrans_compose Cn N
      |}.

  End Cone_conv.

  Section Cone_conv_Morph_for_compose.
    Context {F G H : C –≻ D}
            (N : (F –≻ G)%nattrans)
            (N' : (G –≻ H)%nattrans)
            (Cn : LoKan_Cone p F)
    .

    (** If we convert using the composition of two natural transformations it is
the same as converting twice. We show this by building a cone morph from the former
to the latter whic is simply an identity natural transformation.
In cases such as this, proving equality requires destruction of equality proofs
in terms whereas composing with the identity natural transformation gives a
composition with identity morphism at the level of the terms produced. *)
    Program Definition Cone_conv_Morph_for_compose :
      LoKan_Cone_Morph (Cone_conv (N' ∘ N) Cn) (Cone_conv N' (Cone_conv N Cn)) :=
      {|
        cone_morph := NatTrans_id Cn
      |}.

    Next Obligation.
    Proof.
      rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_right.
      rewrite NatTrans_compose_assoc; trivial.
    Qed.

  End Cone_conv_Morph_for_compose.

  Section Cone_Morph_conv.
    Context {F G : C –≻ D}
            (N : (F –≻ G)%nattrans)
            {Cn Cn' : LoKan_Cone p F}
            (h : LoKan_Cone_Morph Cn Cn')
    .

    (** Conversion of cone morphs. *)
    Program Definition Cone_Morph_conv : LoKan_Cone_Morph (Cone_conv N Cn) (Cone_conv N Cn') :=
      {|
        cone_morph := h
      |}.

    Next Obligation.
    Proof.
      unfold Cone_conv; cbn.
      rewrite NatTrans_compose_assoc.
      rewrite (cone_morph_com h).
      trivial.
    Qed.

  End Cone_Morph_conv.

  (** For any functor (that can be the functor of a cone), there is a functor
for which it is cone trivially. *)
  Section Trivial_Cone.
    Context (F : C' –≻ D).

    Definition Trivial_Cone : LoKan_Cone p (Functor_compose p F) :=
      {|
        cone_apex := F;
        cone_edge := ((NatTrans_id F) ∘_h (NatTrans_id p))%nattrans
      |}.

  End Trivial_Cone.

  Section Trivial_Cone_Morph.
    Context {F G : C' –≻ D} (N : (F –≻ G)%nattrans).

    (** If N : F -> G is a natural transformation, then there is a trivial cone morphism
 from trivial cone of F to trivial cone of G – after conversion. *)
    Program Definition Trivial_Cone_Morph :
      LoKan_Cone_Morph
        (Cone_conv (N ∘_h (NatTrans_id p)) (Trivial_Cone F))
        (Trivial_Cone G) :=
      {|
        cone_morph := N
      |}.

    Next Obligation.
    Proof.
      repeat rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_left.
      rewrite NatTrans_id_unit_right.
      trivial.
    Qed.

  End Trivial_Cone_Morph.

  Section Cone_Morph_to_other_Cone.
    Context {L : C' –≻ D}
            {F : C –≻ D}
            (Cn : LoKan_Cone p F)
            (N : (L –≻ Cn)%nattrans)
    .

    (** Given a natrual transformation from some functor L : C' -> D to a cone (the
underlying functor) we construct a cone morphism from trivial cone of L (after
 conversion) to the given cone. *)
    Program Definition Cone_Morph_to_other_Cone :
      LoKan_Cone_Morph
        (Cone_conv (Cn ∘ (N ∘_h (NatTrans_id p))) (Trivial_Cone L))
        Cn :=
      {|
        cone_morph := N
      |}.

    Next Obligation.
      rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_right.
      trivial.
    Qed.

  End Cone_Morph_to_other_Cone.

  Local Obligation Tactic := idtac.

  (** The functor (mapping functors to their kan extensions) for global kan extension. *)
  Program Definition Local_to_Global_Right_Functor : (Func_Cat C D) –≻ (Func_Cat C' D) :=
    {|
      FO := fun F => LRKE (rke F);
      FA := fun F G N => LRKE_morph_ex (rke G) (Cone_conv N (LRKE (rke F)))
    |}.

  Next Obligation.
  Proof.
    intros F; cbn.
    unfold Cone_conv.
    rewrite NatTrans_id_unit_left.
    change (NatTrans_id (LRKE (rke F))) with (cone_morph (LoKan_id_Cone_Morph _ _ (LRKE (rke F)))).
    apply LRKE_morph_unique.
  Qed.

  Next Obligation.
  Proof.
    intros F G H N N'; cbn.
    match goal with
      [|- _ = ?A] =>
      match A with
      | ((cone_morph ?Y) ∘ (cone_morph ?X))%nattrans =>
        replace A with (A ∘(NatTrans_id _))%nattrans; [|apply NatTrans_id_unit_right];
        set (V := (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv N' X) Y));
        set (Z := Cone_conv_Morph_for_compose N N' (LRKE (rke F)));
        set (U := cone_morph (LoKan_Cone_Morph_compose _ _ Z V));
        unfold V, Z in U; clear V Z
      end
    end.
    match goal with
      [|- _ = ?A] =>
      change A with U
    end.
    apply (LRKE_morph_unique (rke H) (Cone_conv (N' ∘ N) (LRKE (rke F)))).
  Qed.

  (** The unit of adjunction for global kan extension. *)
  Program Definition Local_to_Global_Right_adj_unit :
      ((Functor_id (Func_Cat C' D))
        –≻ (Functor_compose (Left_Functor_Extender p D) Local_to_Global_Right_Functor))%nattrans
    :=
    {|
      Trans := fun F => LRKE_morph_ex (rke (F ∘ p)) (Trivial_Cone F)
    |}.

  Next Obligation.
  Proof.
    intros F G N.
    cbn.
    change N with (cone_morph (Trivial_Cone_Morph N)).
    match goal with
      [|- ?X = ?Y] =>
      match X with
        ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
        change X with (cone_morph (LoKan_Cone_Morph_compose _ _ A B))
      end;
        match Y with
          ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
          change Y
          with (cone_morph
                  (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv (N ∘_h (NatTrans_id p)) A) B
                  )
               )
        end
    end.
    apply (LRKE_morph_unique
             (rke (Functor_compose p G))
             (Cone_conv (N ∘_h (NatTrans_id p)) (Trivial_Cone F))
          ).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Local_to_Global_Right_adj_unit_obligation_1.
  Qed.

  (** Existence of conversion for adjunction – see definition of Adjunct. *)
  Definition Local_to_Global_Right_adj_morph_ex
             (L : C' –≻ D)
             (F : C –≻ D)
             (N : (L –≻ (LRKE (rke F)))%nattrans)
    : ((L ∘ p) –≻ F)%nattrans :=
    ((cone_edge (LRKE (rke F))) ∘ (N ∘_h (NatTrans_id p)))%nattrans.

  (** Conversion from local kan extensions (if we have all of them) to the
global kan extension. *)
  Program Definition Local_to_Global_Right : Right_KanExt p D :=
    {|
      right_kan_ext := Local_to_Global_Right_Functor;
      right_kan_ext_adj := {|
                            adj_unit := Local_to_Global_Right_adj_unit;
                            adj_morph_ex := Local_to_Global_Right_adj_morph_ex|}
    |}.

  Next Obligation.
  Proof.
    intros L F h.
    unfold Local_to_Global_Right_adj_morph_ex.
    cbn in *.
    match goal with
      [|- ?X = ?Y] =>
        match Y with
          ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
          change Y
          with (cone_morph
                  (LoKan_Cone_Morph_compose
                     _ _
                     (Cone_Morph_conv ((LRKE (rke F) ∘ (h ∘_h (NatTrans_id p)))) A) B
                  )
               )
        end
    end.
    change h with (cone_morph (Cone_Morph_to_other_Cone (LRKE (rke F)) h)).
    apply (LRKE_morph_unique
             (rke F)
             (Cone_conv ((LRKE (rke F)) ∘ (h ∘_h (NatTrans_id p))) (Trivial_Cone L))
          ).
  Qed.

  Next Obligation.
  Proof.
    intros L F h g g' H1 H2.
    cbn in *.
    match type of H1 with
      _ = ?X =>
      match X with
          NatTrans_compose (cone_morph ?A) (cone_morph ?B) =>
          change X with (cone_morph (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv g A) B)) in H1
      end
    end.
    match type of H2 with
      _ = ?X =>
      match X with
          NatTrans_compose (cone_morph ?A) (cone_morph ?B) =>
          change X with (cone_morph (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv g' A) B)) in H2
      end
    end.
    match type of H1 with
      _ = cone_morph ?X =>
      set (H4 := cone_morph_com X); rewrite <- H1 in H4; cbn in H4;
      match type of H2 with
        _ = cone_morph ?Y =>
        set (H3 := cone_morph_com Y); rewrite <- H2 in H3; cbn in H3
      end;
      rewrite <- H4 in H3; clear H4
    end.
    rewrite NatTrans_hor_comp_ids in H3.
    repeat rewrite NatTrans_id_unit_right in H3.
    symmetry; trivial.
  Qed.

End Local_to_Global_Right.

(** The conversion from local left kan extensions to global left kan extensions is
just the daul of that for right. *)
Section Local_to_Global_Left.
  Context {C C' : Category} (p : C –≻ C') (D : Category).

  Context (lke : ∀ F : C –≻ D,  Local_Left_KanExt p F).

  Definition Local_to_Global_Left : Left_KanExt p D :=
    KanExt_Right_to_Left _ _ (Local_to_Global_Right _ _ (fun (F : C^op –≻ D^op) => (lke (F^op)))).

End Local_to_Global_Left.


Fixpoint double n :=
  match n with
  | 0 => 0
  | 1 => 2
  | S (S n') => S (S (S (S (double n'))))
  end.

Definition task := forall n, double n = 2 * n.


(*
 * Types
 *)

Require Import List.
Require Import ZArith.
Require Import String.
Require Import Frap. (* For tactics *)
Require Import STLC.StructTactics. (* For tactics *)

Require Import STLC.Syntax. (* Syntax *)
Require Import STLC.Heap. (* Heaps *)

Open Scope string_scope.

Notation length := List.length.

(* Let's talk about types! *)

(* We'll need to add a type for references to the set of types we saw lecture. *)

Inductive typ : Set :=
| TBool : typ
| TInt  : typ
| TFun  : typ -> typ -> typ
| TRef  : typ -> typ.

Notation "X ~> Y" := (TFun X Y) (at level 60).

(* An environment maps variables to types. Make sure you understand
the difference between this and a heap, which maps indices to
terms! *)

Definition env : Type :=
  string -> option typ.

(* E0 is the empty environment *)
Definition E0 : env :=
  fun _ => None.

(*

Update an environment with a new variable and type.

NOTE: Environments are different from heaps!
      We change heaps with snoc and replace.
      We change environments with extend.

*)
Definition extend (e: env) x t : env :=
  fun y =>
    if string_dec y x then
      Some t
    else
      e y.

(* In addition to our usual environments,
   we also need to type our heaps in order
   to type references. *)

(* A heap type is just a list of types. *)
Definition heap_typ :=
  list typ.

(* lookup_typ works just like lookup. *)
Definition lookup_typ (h : heap_typ) n :=
  nth n h TBool.

(* What does it mean for a term to be well-typed?
   The first 5 constructors are the same as those
   in the STLC without references.
*)

Inductive typed : env -> heap_typ -> expr -> typ -> Prop :=
| WTBool :
    forall env ht b,
      typed env ht (Bool b) TBool
| WTInt :
    forall env ht i,
      typed env ht (Int i) TInt
| WTVar :
    forall env ht x t,
      env x = Some t ->
      typed env ht (Var x) t
| WTApp :
    forall env ht e1 e2 tA tB,
      typed env ht e1 (tA ~> tB) ->
      typed env ht e2 tA ->
      typed env ht (e1 @ e2) tB
| WTLam :
    forall env ht x e tA tB,
      typed (extend env x tA) ht e tB ->
      typed env ht (\x, e) (tA ~> tB)
| WTAddr :
    forall env ht a,
      a < length ht ->
      typed env ht (Addr a) (TRef (lookup_typ ht a))
| WTRef :
    forall env ht e t,
      typed env ht e t ->
      typed env ht (ref e) (TRef t)
| WTDeref :
    forall env ht e t,
      typed env ht e (TRef t) ->
      typed env ht (! e) t
| WTAssign :
    forall env ht e1 e2 t,
      typed env ht e1 (TRef t) ->
      typed env ht e2 t ->
      typed env ht (e1 <- e2) TBool.

(* Q: What does it mean for a heap to be well-typed?

   A: The heap must be the same length as the heap type, and the term
      stored at any valid address in the heap (i.e. any address less than
      the length of the heap) should have the type it has in the heap type.
 *)

Definition heap_typed (ht : heap_typ) (h : heap) :=
  length h = length ht /\
  forall a,
    a < length h ->
    typed E0 ht (lookup h a) (lookup_typ ht a).


Require Import FCF.FCF.
Require Import FCF.SplitVector.
Require Import RewriteUtil.

Lemma Rnd_split_eq n1 n2 : Comp_eq
                                (x <-$ { 0 , 1 }^ n1 + n2; ret splitVector n1 n2 x)
                                (x1 <-$ { 0 , 1 }^ n1; x2 <-$ { 0 , 1 }^ n2; ret (x1, x2)).
Proof. intro z. eapply Rnd_split_equiv. Qed.

Lemma list_vector_split a b (T : Set) (x : Vector.t T _) : skipn (b) (Vector.to_list x) = Vector.to_list (snd (splitVector (b) a x)).
  induction b; simpl; intuition.
  destruct (splitVector b a (Vector.tl x)) eqn:?.
  specialize (IHb (Vector.tl x)).
  rewrite Heqp in IHb.
  simpl in *.
  rewrite <- IHb.
  SearchAbout Vector.hd Vector.tl.
  rewrite (Vector.eta x).
  reflexivity.
Qed.


Theorem a_implies_a : (forall A : Prop, A -> A).
Proof.
intros A.
intros proof_of_A.
exact proof_of_A.
Print a_implies_a.

(*1 subgoal
______________________________________(1/1)
forall A : Prop, A -> A

1 subgoal
A : Prop
______________________________________(1/1)
A -> A

1 subgoal
A : Prop
proof_of_A : A
______________________________________(1/1)
A

No more subgoals.

a_implies_a is defined

a_implies_a =
fun (A : Prop) (proof_of_A : A) => proof_of_A
     : forall A : Prop, A -> A

Argument scopes are [type_scope _]*)

Theorem forward_small : (forall A B : Prop, A -> (A -> B) -> B).
Proof.
intros A.
intros B.
intros proof_of_A.
intros A_implies_B.
pose (proof_of_B := A_implies_B proof_of_A).
exact proof_of_B.
Qed.
Print forward_small.

(*1 subgoal
______________________________________(1/1)
forall A B : Prop,
A -> (A -> B) -> B

1 subgoal
______________________________________(1/1)
forall A B : Prop, A -> (A -> B) -> B

1 subgoal
A : Prop
______________________________________(1/1)
forall B : Prop, A -> (A -> B) -> B

1 subgoal
A, B : Prop
______________________________________(1/1)
A -> (A -> B) -> B

1 subgoal
A, B : Prop
proof_of_A : A
______________________________________(1/1)
(A -> B) -> B

1 subgoal
A, B : Prop
proof_of_A : A
A_implies_B : A -> B
______________________________________(1/1)
B

No more subgoals.

forward_small is defined

*forward_small =
fun (A B : Prop) (proof_of_A : A)
  (A_implies_B : A -> B) =>
let proof_of_B := A_implies_B proof_of_A in
proof_of_B
     : forall A B : Prop, A -> (A -> B) -> B

Argument scopes are [type_scope type_scope _ _]*)

Theorem backward_large : (forall A B C : Prop, A -> (A -> B) -> (B -> C) -> C).
Proof.
intros A B C.
intros proof_of_A A_implies_B B_implies_C.
refine (B_implies_C _).
refine (A_implies_B _).
exact proof_of_A.
Qed.
Print backward_large.

(*1 subgoal
______________________________________(1/1)
forall A B C : Prop,
A -> (A -> B) -> (B -> C) -> C

1 subgoal
A, B, C : Prop
______________________________________(1/1)
A -> (A -> B) -> (B -> C) -> C

1 subgoal
A, B, C : Prop
proof_of_A : A
A_implies_B : A -> B
B_implies_C : B -> C
______________________________________(1/1)
C

1 subgoal
A, B, C : Prop
proof_of_A : A
A_implies_B : A -> B
B_implies_C : B -> C
______________________________________(1/1)
A

backward_large is defined

backward_large =
fun (A B C : Prop) (proof_of_A : A)
  (A_implies_B : A -> B) (B_implies_C : B -> C) =>
B_implies_C (A_implies_B proof_of_A)
     : forall A B C : Prop,
       A -> (A -> B) -> (B -> C) -> C

Argument scopes are [type_scope type_scope
  type_scope _ _ _]*)

Theorem bigger_than_last : (forall A B C : Prop, A -> (A -> B) -> (A -> B -> C) -> C).
Proof.
intros A B C.
intros proof_of_A A_implies_B A_imp_B_imp_C.
pose (proof_of_B := A_implies_B proof_of_A).
pose (proof_of_C := A_imp_B_imp_C proof_of_A proof_of_B).
exact proof_of_C.
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall A B C : Prop,
A -> (A -> B) -> (A -> B -> C) -> C

1 subgoal
A, B, C : Prop
______________________________________(1/1)
A -> (A -> B) -> (A -> B -> C) -> C

1 subgoal
A, B, C : Prop
proof_of_A : A
A_implies_B : A -> B
A_imp_B_imp_C : A -> B -> C
______________________________________(1/1)
C

1 subgoal
A, B, C : Prop
proof_of_A : A
A_implies_B : A -> B
A_imp_B_imp_C : A -> B -> C
proof_of_B := A_implies_B proof_of_A : B
______________________________________(1/1)
C

1 subgoal
A, B, C : Prop
proof_of_A : A
A_implies_B : A -> B
A_imp_B_imp_C : A -> B -> C
proof_of_B := A_implies_B proof_of_A : B
proof_of_C := A_imp_B_imp_C proof_of_A
                proof_of_B : C
______________________________________(1/1)
C

No more subgoals.

(fun (A B C : Prop) (proof_of_A : A)
   (A_implies_B : A -> B)
   (A_imp_B_imp_C : A -> B -> C) =>
 let proof_of_B := A_implies_B proof_of_A in
 let proof_of_C :=
   A_imp_B_imp_C proof_of_A proof_of_B in
 proof_of_C)

bigger_than_last is defined

*)

Theorem inl : (forall A B : Prop, A -> A \/ B).
Proof.
intros A B.
intros proof_of_A.
pose (proof_of_A_or_B := or_introl proof_of_A : A \/ B).
exact proof_of_A_or_B.
Show Proof.
Qed.
(*
1 subgoal
______________________________________(1/1)
forall A B : Prop, A -> A \/ B

1 subgoal
A, B : Prop
______________________________________(1/1)
A -> A \/ B

1 subgoal
A, B : Prop
proof_of_A : A
______________________________________(1/1)
A \/ B

1 subgoal
A, B : Prop
proof_of_A : A
proof_of_A_or_B := (or_introl proof_of_A
                    :
                    A \/ B) : A \/ B
______________________________________(1/1)
A \/ B

No more subgoals.

(fun (A B : Prop) (proof_of_A : A) =>
 let proof_of_A_or_B :=
   or_introl proof_of_A : A \/ B in
 proof_of_A_or_B)

inl is defined

*)

Theorem inr : (forall A B : Prop, B -> A \/ B).
Proof.
intros A B.
intros proof_of_B.
refine (or_intror _).
exact proof_of_B.
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall A B : Prop, B -> A \/ B

1 subgoal
A, B : Prop
______________________________________(1/1)
B -> A \/ B

1 subgoal
A, B : Prop
proof_of_B : B
______________________________________(1/1)
A \/ B

1 subgoal
A, B : Prop
proof_of_B : B
______________________________________(1/1)
B

No more subgoals.

(fun (A B : Prop) (proof_of_B : B) =>
 or_intror proof_of_B)

inr is defined
*)

Theorem or_commutes : (forall A B, A \/ B -> B \/ A).
Proof.
intros A B.
intros A_or_B.
case A_or_B.
intros proof_of_A.
refine (or_intror _).
exact proof_of_A.
intros proof_of_B.
refine (or_introl _).
exact proof_of_B.
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall A B : Prop, A \/ B -> B \/ A

1 subgoal
A, B : Prop
______________________________________(1/1)
A \/ B -> B \/ A

1 subgoal
A, B : Prop
A_or_B : A \/ B
______________________________________(1/1)
B \/ A

2 subgoals
A, B : Prop
A_or_B : A \/ B
______________________________________(1/2)
A -> B \/ A
______________________________________(2/2)
B -> B \/ A

2 subgoals
A, B : Prop
A_or_B : A \/ B
proof_of_A : A
______________________________________(1/2)
B \/ A
______________________________________(2/2)
B -> B \/ A

2 subgoals
A, B : Prop
A_or_B : A \/ B
proof_of_A : A
______________________________________(1/2)
A
______________________________________(2/2)
B -> B \/ A

1 subgoal
A, B : Prop
A_or_B : A \/ B
______________________________________(1/1)
B -> B \/ A

1 subgoal
A, B : Prop
A_or_B : A \/ B
proof_of_B : B
______________________________________(1/1)
B \/ A

1 subgoal
A, B : Prop
A_or_B : A \/ B
proof_of_B : B
______________________________________(1/1)
B

No more subgoals.

(fun (A B : Prop) (A_or_B : A \/ B) =>
 match A_or_B with
 | or_introl proof_of_A => or_intror proof_of_A
 | or_intror proof_of_B => or_introl proof_of_B
 end)

*)

Theorem conj_intr : (forall A B : Prop, A -> B -> A /\ B).
Proof.
intros A B.
intros proof_of_A proof_of_B.
refine (conj _ _).
exact proof_of_A.
exact proof_of_B.
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall A B : Prop, A -> B -> A /\ B

1 subgoal
A, B : Prop
______________________________________(1/1)
A -> B -> A /\ B

1 subgoal
A, B : Prop
proof_of_A : A
proof_of_B : B
______________________________________(1/1)
A /\ B

2 subgoals
A, B : Prop
proof_of_A : A
proof_of_B : B
______________________________________(1/2)
A
______________________________________(2/2)
B

1 subgoal
A, B : Prop
proof_of_A : A
proof_of_B : B
______________________________________(1/1)
B

No more subgoals.

(fun (A B : Prop) (proof_of_A : A) (proof_of_B : B) =>
 conj proof_of_A proof_of_B)
*)

Theorem conj_commutes : (forall A B, A /\ B -> B /\ A).
Proof.
intros A B.
intros A_and_B.
case A_and_B.
intros proof_of_A proof_of_B.
refine (conj _ _).
exact proof_of_B.
exact proof_of_A.
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall A B : Prop,
A /\ B -> B /\ A

1 subgoal
A, B : Prop
______________________________________(1/1)
A /\ B -> B /\ A

1 subgoal
A, B : Prop
A_and_B : A /\ B
______________________________________(1/1)
B /\ A

1 subgoal
A, B : Prop
A_and_B : A /\ B
______________________________________(1/1)
A -> B -> B /\ A

1 subgoal
A, B : Prop
A_and_B : A /\ B
proof_of_A : A
proof_of_B : B
______________________________________(1/1)
B /\ A

2 subgoals
A, B : Prop
A_and_B : A /\ B
proof_of_A : A
proof_of_B : B
______________________________________(1/2)
B
______________________________________(2/2)
A

1 subgoal
A, B : Prop
A_and_B : A /\ B
proof_of_A : A
proof_of_B : B
______________________________________(1/1)
A

No more subgoals.

(fun (A B : Prop) (A_and_B : A /\ B) =>
 match A_and_B with
 | conj proof_of_A proof_of_B =>
     conj proof_of_B proof_of_A
 end)

*)

Theorem exists_forall : (forall P : Set -> Prop, ~(exists x, P x) -> (forall x, ~(P x))).
Proof.
intros P.
intros not_exists_x_Px.
intros x.
unfold not.
intros P_x.
unfold not in not_exists_x_Px.
refine (not_exists_x_Px _).
exact (ex_intro P x P_x).
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall P : Set -> Prop,
~ (exists x : Set, P x) ->
forall x : Set, ~ P x

1 subgoal
P : Set -> Prop
______________________________________(1/1)
~ (exists x : Set, P x) -> forall x : Set, ~ P x

1 subgoal
P : Set -> Prop
not_exists_x_Px : ~ (exists x : Set, P x)
______________________________________(1/1)
forall x : Set, ~ P x

1 subgoal
P : Set -> Prop
not_exists_x_Px : ~ (exists x : Set, P x)
x : Set
______________________________________(1/1)
~ P x

1 subgoal
P : Set -> Prop
not_exists_x_Px : ~ (exists x : Set, P x)
x : Set
______________________________________(1/1)
P x -> False

1 subgoal
P : Set -> Prop
not_exists_x_Px : ~ (exists x : Set, P x)
x : Set
P_x : P x
______________________________________(1/1)
False

1 subgoal
P : Set -> Prop
not_exists_x_Px : (exists x : Set, P x) -> False
x : Set
P_x : P x
______________________________________(1/1)
False

1 subgoal
P : Set -> Prop
not_exists_x_Px : (exists x : Set, P x) -> False
x : Set
P_x : P x
______________________________________(1/1)
exists x0 : Set, P x0

No more subgoals.

(fun (P : Set -> Prop)
   (not_exists_x_Px : ~ (exists x : Set, P x))
   (x : Set) (P_x : P x) =>
 not_exists_x_Px (ex_intro P x P_x))

*)

Theorem eq_sym : (forall x y : Set, x = y -> y = x).
Proof.
intros x y.
intros x_y.
destruct x_y as [].
exact (eq_refl x).
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall x y : Set, x = y -> y = x

1 subgoal
x, y : Set
______________________________________(1/1)
x = y -> y = x

1 subgoal
x, y : Set
x_y : x = y
______________________________________(1/1)
y = x

1 subgoal
x : Set
______________________________________(1/1)
x = x

No more subgoals.

(fun (x y : Set) (x_y : x = y) =>
 match x_y in (_ = y0) return (y0 = x) with
 | eq_refl => eq_refl
 end)

*)

Theorem eq_trans : (forall x y z : Set, x = y -> y = z -> x = z).
Proof.
intros x y z.
intros x_y y_z.
destruct x_y as [].
destruct y_z as [].
exact (eq_refl x).
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall x y z : Set, x = y -> y = z -> x = z

1 subgoal
x, y, z : Set
______________________________________(1/1)
x = y -> y = z -> x = z

1 subgoal
x, y, z : Set
x_y : x = y
y_z : y = z
______________________________________(1/1)
x = z

1 subgoal
x, z : Set
y_z : x = z
______________________________________(1/1)
x = z

1 subgoal
x : Set
______________________________________(1/1)
x = x

(fun (x y z : Set) (x_y : x = y) (y_z : y = z) =>
 match x_y in (_ = y0) return (y0 = z -> x = z) with
 | eq_refl =>
     fun y_z0 : x = z =>
     match y_z0 in (_ = y0) return (x = y0) with
     | eq_refl => eq_refl
     end
 end y_z)
*)

Theorem plus_sym : (forall n m, n + m = m + n).
Proof.
intros n m.
elim n.
elim m.
exact (eq_refl (0 + 0)).
  intros m'.
  intros inductive_hyp_m.
  simpl.
  rewrite <- inductive_hyp_m.
  simpl.
  exact (eq_refl (S m')).
intros n'.
intros inductive_hyp_n.
simpl.
rewrite inductive_hyp_n.
elim m.
  simpl.
  exact (eq_refl (S n')).
  intros m'.
  intros inductive_hyp_m.
  simpl.
  rewrite inductive_hyp_m.
  simpl.
  exact (eq_refl (S (m' + S n'))).
Show Proof.
Qed.

(*
1 subgoal
______________________________________(1/1)
forall n m : nat, n + m = m + n

1 subgoal
n, m : nat
______________________________________(1/1)
n + m = m + n

2 subgoals
n, m : nat
______________________________________(1/2)
0 + m = m + 0
______________________________________(2/2)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

3 subgoals
n, m : nat
______________________________________(1/3)
0 + 0 = 0 + 0
______________________________________(2/3)
forall n0 : nat,
0 + n0 = n0 + 0 -> 0 + S n0 = S n0 + 0
______________________________________(3/3)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

2 subgoals
n, m : nat
______________________________________(1/2)
forall n0 : nat,
0 + n0 = n0 + 0 -> 0 + S n0 = S n0 + 0
______________________________________(2/2)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

2 subgoals
n, m, m' : nat
______________________________________(1/2)
0 + m' = m' + 0 -> 0 + S m' = S m' + 0
______________________________________(2/2)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

2 subgoals
n, m, m' : nat
inductive_hyp_m : 0 + m' = m' + 0
______________________________________(1/2)
0 + S m' = S m' + 0
______________________________________(2/2)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

2 subgoals
n, m, m' : nat
inductive_hyp_m : 0 + m' = m' + 0
______________________________________(1/2)
S m' = S (m' + 0)
______________________________________(2/2)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

2 subgoals
n, m, m' : nat
inductive_hyp_m : 0 + m' = m' + 0
______________________________________(1/2)
S m' = S (0 + m')
______________________________________(2/2)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

2 subgoals
n, m, m' : nat
inductive_hyp_m : 0 + m' = m' + 0
______________________________________(1/2)
S m' = S m'
______________________________________(2/2)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

1 subgoal
n, m : nat
______________________________________(1/1)
forall n0 : nat,
n0 + m = m + n0 -> S n0 + m = m + S n0

1 subgoal
n, m, n' : nat
______________________________________(1/1)
n' + m = m + n' -> S n' + m = m + S n'

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
______________________________________(1/1)
S n' + m = m + S n'

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
______________________________________(1/1)
S (n' + m) = m + S n'

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
______________________________________(1/1)
S (m + n') = m + S n'

2 subgoals
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
______________________________________(1/2)
S (0 + n') = 0 + S n'
______________________________________(2/2)
forall n0 : nat,
S (n0 + n') = n0 + S n' -> S (S n0 + n') = S n0 + S n'

2 subgoals
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
______________________________________(1/2)
S n' = S n'
______________________________________(2/2)
forall n0 : nat,
S (n0 + n') = n0 + S n' -> S (S n0 + n') = S n0 + S n'

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
______________________________________(1/1)
forall n0 : nat,
S (n0 + n') = n0 + S n' -> S (S n0 + n') = S n0 + S n'

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
m' : nat
______________________________________(1/1)
S (m' + n') = m' + S n' -> S (S m' + n') = S m' + S n'

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
m' : nat
inductive_hyp_m : S (m' + n') = m' + S n'
______________________________________(1/1)
S (S m' + n') = S m' + S n'

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
m' : nat
inductive_hyp_m : S (m' + n') = m' + S n'
______________________________________(1/1)
S (S (m' + n')) = S (m' + S n')

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
m' : nat
inductive_hyp_m : S (m' + n') = m' + S n'
______________________________________(1/1)
S (m' + S n') = S (m' + S n')

1 subgoal
n, m, n' : nat
inductive_hyp_n : n' + m = m + n'
m' : nat
inductive_hyp_m : S (m' + n') = m' + S n'
______________________________________(1/1)
S (m' + S n') = S (m' + S n')

No more subgoals.

(fun n m : nat =>
 nat_ind (fun n0 : nat => n0 + m = m + n0)
   (nat_ind (fun m0 : nat => 0 + m0 = m0 + 0) eq_refl
      (fun (m' : nat)
         (inductive_hyp_m : 0 + m' = m' + 0) =>
       eq_ind (0 + m') (fun n0 : nat => S m' = S n0)
         eq_refl (m' + 0) inductive_hyp_m) m)
   (fun (n' : nat) (inductive_hyp_n : n' + m = m + n')
    =>
    eq_ind_r (fun n0 : nat => S n0 = m + S n')
      (nat_ind
         (fun m0 : nat => S (m0 + n') = m0 + S n')
         eq_refl
         (fun (m' : nat)
            (inductive_hyp_m : S (m' + n') = m' + S n')
          =>
          eq_ind_r
            (fun n0 : nat => S n0 = S (m' + S n'))
            eq_refl inductive_hyp_m) m)
      inductive_hyp_n) n)

*)


(*|
###############################################
Building up tree and decreasing argument of fix
###############################################

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

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

I'm attempting to implement a function to build up a Braun tree with
``n`` elements using the following function in Coq, but Coq gives me
the error that it cannot guess decreasing argument of fix:

.. coq:: none
|*)

Require Import Coq.Init.Nat.

Parameter V : Type.

Inductive BraunTree : Type :=
| E : BraunTree
| T : V -> BraunTree -> BraunTree -> BraunTree.

(*||*)

Fail Fixpoint copy (x : V) (n : nat) : BraunTree :=
  let
    fix copy2 (a : V) (i : nat) : (BraunTree * BraunTree) :=
    match i with
    | 0 => (T a E E, E)
    | _ => match Nat.odd i with
           | true => let m := (i - 1) / 2 in
                     let (s,t) := copy2 a m in
                     (T a s t, T a t t)
           | false => let m := (i - 2) / 2 in
                      let (s, t) := copy2 a m in
                      (T a s s, T a s t)
           end
    end
  in
  match copy2 x n with
  | (_, snd) => snd
  end. (* .fails *)

(*|
I know that it is not the separate even and odd cases that is the
problem because it gave the same error when I removed the even/odd
cases:
|*)

Fail Fixpoint copy (x : V) (n : nat) : BraunTree :=
  let
    fix copy2 (a : V) (i : nat) : (BraunTree * BraunTree) :=
    match i with
    | 0 => (T a E E, E)
    | _ => let m := (i - 1) / 2 in
           let (s, t) := copy2 a m in
           (T a s t, T a t t)
    end
  in
  match copy2 x n with
  | (_, snd) => snd
  end. (* .fails *)

(*|
How can I convince Coq that i is in fact a decreasing argument?

**EDIT** Type of ``BraunTree``:
|*)

Reset BraunTree. (* .none *)
Inductive BraunTree : Type :=
| E : BraunTree
| T : V -> BraunTree -> BraunTree -> BraunTree.

(*|
Answer
******

``Fixpoint``/``fix`` only allows recursive calls on a *syntactically*
smaller argument.

.. code-block:: coq

    Fixpoint example (n : nat) :=
      ... (* There must be a match on [n] somewhere *)
        ... match n with
            | O => base_case (* no recursive call allowed *)
            | S m =>
              ... (example m)
              (* We can only call [example] on [m], or some even
                 smaller value obtained by matching on [m] *)
            end ...

In particular, it's not allowed to make a recursive call on a value
obtained via some arbitrary function (in this case, ``div`` and
``sub`` in ``copy2 a ((i - 1) / 2)``).

Here are three options:

1. Pick another representation of natural numbers so that
   pattern-matching on it naturally decomposes into the different
   branches of the desired definition (base case (zero), even, odd).
2. Use the fact that the recursion depth is actually bounded by ``n``,
   so we can use ``n`` as "fuel", which we know will not actually
   deplete before we are done.
3. Cunningly extract a subterm of the decreasing argument to make the
   recursive call. This solution is less general and robust than the
   previous ones; it's a much harder fight against the termination
   checker.

----

Alternative representation
==========================

We have three cases: zero, even, and odd. Luckily the standard library
has a type with almost the same structure, ``positive``:
|*)

Inductive positive :=    (* p > 0 *)
| xH                     (* 1 *)
| xI (p : positive)      (* 2p + 1 *)
| xO (p : positive).     (* 2p     *)

(*|
Pointing the type ``positive`` with an additional zero, we get ``N``:
|*)

Inductive N :=
| N0                      (* 0 *)
| Npos (p : positive).    (* p > 0 *)

(*|
There is also a conversion function ``N.of_nat : nat -> N``, although
it might also be a good idea to use ``N`` everywhere instead of
``nat``, if the conversions become too annoying.

The final definition starts by case analysis on ``N``, and the case
revealing a ``positive`` number is handled with a ``fix``-point, where
the base case is ``1`` instead of ``0``. We have to shift some
details, because the even case is ``2p`` instead of ``2p + 2``, so
instead of a pair of trees of size ``(i+1, i)`` we have to do ``(i-1,
i)``. But overall the recursive cases still naturally match an
informal specification:
|*)

Reset Initial. (* .none *)
Require Import NArith PArith.

Parameter V : Type.

Inductive BraunTree : Type :=
| E : BraunTree
| T : V -> BraunTree -> BraunTree -> BraunTree.

Definition copy (x : V) (n : N) : BraunTree :=
  match n with
  | N0 => E
  | Npos p =>
    let
      (* copy2 a i : a tree of (i-1) copies of a, and another of i
         copies of a *)
      fix copy2 (a : V) (i : positive) : (BraunTree * BraunTree) :=
      match i with
      | xH => (* i = 1 *)
        (E, T a E E)
      | xI p => (* i = 2p + 1 *)
        let (s, t) := copy2 a p in
        (T a t s, T a t t)
      | xO p => (* i = 2p *)
        let (s, t) := copy2 a p in
          (T a s s, T a t s)
      end
    in
    match copy2 x p with
    | (_, snd) => snd
    end
  end.

(*|
----

Just enough fuel
================

We add fuel to the ``fix`` as the decreasing argument. We can only run
out if ``n = i = 0``, so we know what the result should be then.
|*)

Reset copy. (* .none *)
Require Import Coq.Init.Nat. (* .none *)
(* note: This doesn't need to be a Fixpoint *)
Definition copy (x : V) (n : nat) : BraunTree :=
  let
    fix copy2 (a : V) (n : nat) (i : nat) : (BraunTree * BraunTree) :=
    match n with
    | O => (T a E E, E)
    | S n' =>
      match i with
      | O => (T a E E, E)
      | _ =>
        if Nat.odd i then
          let m := div2 ((i - 1) / 2) in
          let (s, t) := copy2 a n' m in
          (T a s t, T a t t)
        else
          let m := div2 ((i - 2) / 2) in
          let (s, t) := copy2 a n' m in
          (T a s s, T a s t)
      end
    end
  in
  match copy2 x n n with
  | (_, snd) => snd
  end.
Reset copy. (* .none *)

(*|
This works nicely when:

- we can compute the amount of fuel needed;
- and there is a predictable answer to give when we run out of fuel.

If either of those assumption does *not* hold, we need to litter our
code with ``option``.

----

Nested recursion
================

As mentioned earlier, Coq has strict rules about decreasing arguments.
The usual explanation is that we can only make a recursive call on a
subterm obtained through pattern-matching on the decreasing argument
(or transitively, one of its subterms).

One apparent restriction is that, because the condition is syntactic
(i.e., Coq looks at the definition to track the provenance of the
decreasing argument), the argument ``n`` can only decrease by a
constant at most (constant with respect to ``n``), since there are
only finitely many ``match`` in a definition. In particular, there is
no way to make a recursive call on the result of a division by two, as
that represents a decrease by ``n/2``, a value linear in ``n``.

For better or for worse, Coq's termination criterion is actually a bit
smarter than that: one can pass the decreasing argument to a nested
fixpoint, and the "subterm" relation will be tracked through it.

Cons-free division
------------------

And indeed, the division of a Peano ``nat`` can be defined in such a
way that Coq can tell that the result is a subterm of the dividend:
|*)

Definition div2 (n : nat) :=
  let fix d2 (n1 : nat) (n2 : nat) {struct n1} :=
      match n2 with
      | S (S n2') =>
        match n1 with
        | O => n1
        | S n1' => d2 n1' n2'
        end
      | _ => n1
      end
  in d2 n n.

(*|
The idea is to write a ``fix``-point of two arguments (somewhat like
the fuel solution), which start out equal (``d2 n n``), and we remove
**two** ``S`` constructors from one (``n2``) of them for every **one**
``S`` we remove from the other (``n1``). Important details:

- In all the non-recursing cases, we return ``n1`` (and *not* ``0`` in
  any case), which is then guaranteed to be a subterm of the topmost
  ``n``.
- And the function must be decreasing in ``n1`` (the term we return),
  rather than ``n2`` (Coq only keeps track of subterms of decreasing
  arguments).

All that ensures that ``div2 n`` is a subterm of ``n`` (not a *strict
subterm* (or *proper subterm*\ ), because ``n`` could be ``O``).

This has similarities to the previous fuel-based solution, but here
the decreasing argument is a lot more relevant than just a device to
trick the type checker.

This technique is a variant of *cons-free programming*. (Note though
that the constraints are not quite the same as what is discussed in
the literature, for example when the focus is on avoiding *memory
allocations* rather than ensuring *termination* by structural
well-foundedness.)

Conclusion: definition of ``copy``
----------------------------------

Once we have ``div2``, we can define ``copy`` with a few tweaks to
obtain ``i-1`` and ``i-2`` as *proper subterms* of ``i``, again by
pattern-matching. Below, ``i'`` and ``i''`` are proper subterms of
``i`` (by visual inspection), and ``div2 i'`` and ``div2 i''`` are
subterms of ``i'`` and ``i''`` (by the definition of ``div2``). By
transitivity they are proper subterms of ``i``, so the termination
checker accepts.
|*)

Definition copy (x : V) (n : nat) : BraunTree :=
  let
    fix copy2 (a : V) (i : nat) : (BraunTree * BraunTree) :=
    match i with
    | 0 => (T a E E, E)
    | S i' => (* i' = i-1 *)
      if Nat.odd i then
        let m := div2 i' in
        let (s, t) := copy2 a m in
        (T a s t, T a t t)
      else
        match i' with
        | O => (* Unreachable *) (E, E)
        | S i'' => (* i'' = i-2 *)
          let m := div2 i'' in
          let (s, t) := copy2 a m in
          (T a s s, T a s t)
        end
    end
  in
  match copy2 x n with
  | (_, snd) => snd
  end.


From Coq Require Import Program.
From QuickChick Require Import QuickChick.
From mathcomp Require Import all_ssreflect.
Global Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Insertion.

Section InsertionSort.
Variable T: eqType.
Variable leT: rel T.
Implicit Types x y z : T.
Implicit Types s t u : seq T.

Fixpoint insert e s: seq T :=
  if s is x :: s'
    then
      if leT e x then [:: e & s] else x :: insert e s'
    else
      [:: e].

Fixpoint sort s: seq T :=
  if s is x :: s'
    then insert x (sort s')
    else [::].

Fixpoint sorted' s: bool :=
  if s is x1 :: ((x2 :: s') as tail)
    then leT x1 x2 && (sorted' tail)
    else true.

Print sorted.
Print path.

Lemma sorted_cons x s:
  sorted leT (x :: s) -> sorted leT s.
Proof.
by case: s => //= h t /andP [_ H].
Qed.

Definition fake_sort s: seq T := [::].
Lemma sorted_fake_sort s: sorted leT (fake_sort s).
Proof. done. Qed.

Print perm_eq.

Lemma insert_sorted e s:
  sorted leT s ->
  sorted leT (insert e s).
Proof.
elim: s => [// | x1 s IHs].
move=> /=.
move=> path_x1_s.
case: ifP => [e_le_x1 | e_gt_x1].
- by rewrite /= e_le_x1 path_x1_s.
Abort.

Hypothesis leT_total: total leT.
Print total.

Lemma insert_sorted e s:
  sorted leT s ->
  sorted leT (insert e s).
Proof.
elim: s => [// | x1 s IHs].
move=> /=.
move=> path_x1_s.
case: ifP => [e_le_x1 | e_gt_x1].
- by rewrite /= e_le_x1 path_x1_s.
have:=leT_total e x1.
rewrite {}e_gt_x1.
move=> /= x1_le_e.
About path_sorted.
move: path_x1_s => {}/path_sorted/IHs.
case: s => [| x2 s] /=; first by rewrite x1_le_e.
case: ifP => /=.
- move => -> ->. by rewrite x1_le_e.
Abort.

Lemma insert_path z e s:
  leT z e ->
  path leT z s ->
  path leT z (insert e s).
Proof.
elim: s z => [/=| x1 s IHs] z. (* gen z *)
- by move=> ->.
move => z_le_e /=.
case/andP=> z_le_x1 path_x1_s.
case: ifP => /=.
- by rewrite z_le_e path_x1_s => ->.
move => e_gt_x1.
rewrite z_le_x1.
have:= leT_total e x1.
rewrite {}e_gt_x1 /= => x1_le_e.
exact: IHs.
Qed.

Lemma insert_sorted e s :
  sorted leT s ->
  sorted leT (insert e s).
Proof.
rewrite /sorted.
case: s=> // x s.
move=> /=.
case: ifP; first by move=> /= ->->.
move=> e_gt_x.
apply: insert_path.
have:= leT_total e x.
by rewrite e_gt_x /= => ->.
Qed.

Lemma sort_sorted s :
  sorted leT (sort s).
Proof.
elim: s => [//|x s IHs] /=.
rewrite insert_sorted => //.
Qed.

End InsertionSort.

Arguments sort {T} _ _.
Arguments insert {T} _ _ _.

Section SortIsPermutation.

Variable T : eqType.
Variables leT : rel T.

Lemma count_insert p e s :
  count p (insert leT e s) = p e + count p s.
Proof.
by elim: s => //= x s; case: ifP=> _ //= ->; rewrite addnCA.
Qed.

About perm_eql.

Lemma perm_sort s : perm_eql (sort leT s) s.
Proof.
Search _ (perm_eq ?s1 =1 perm_eq ?s2).
apply/permPl/permP.
elim: s=> //= x s IHs p.
by rewrite count_insert IHs.
Qed.

(*| This is why we state `perm_sort` lemma using
`perm_eql` -- it can be used as an equation like
so |*)

Lemma mem_sort s : sort leT s =i s.
Proof. by apply: perm_mem; rewrite perm_sort. Qed.

Lemma sort_uniq s : uniq (sort leT s) = uniq s.
Proof. by apply: perm_uniq; rewrite perm_sort. Qed.

End SortIsPermutation.

Section SortProperties.
Variable T : eqType.
Variables leT : rel T.

Lemma sorted_sort s :
  sorted leT s -> sort leT s = s.
Proof.
elim: s=> // x1 s IHs S.
move: (S) => {}/sorted_cons/IHs /= ->.
move: S=> /=.
case: s=> //= x2 s.
by case/andP=> ->.
Qed.

End SortProperties.
End Insertion.

Module Merge.
Section MergeSortDef.
Context {disp : unit} {T : orderType disp}.
Implicit Types s t : seq T.

Fixpoint split s : seq T * seq T :=
  match s with
  | [::] => (s, s)
  | [:: x] => (s, [::])
  | [:: x, y & s] =>
      let '(t1, t2) := split s in
      (x :: t1, y :: t2)
  end.

Arguments split : simpl nomatch.

Lemma split_lt1 s2 s1 s :
  1 < size s ->
  split s = (s1, s2) ->
  (size s1 < size s).
Proof.
Admitted.

Lemma split_lt2 s1 s2 s :
  1 < size s ->
  split s = (s1, s2) ->
  (size s2 < size s).
Proof.
Admitted.

Fail Fixpoint merge s t : seq T :=
  match s, t with
  | [::], _ => t
  | _, [::] => s
  | x :: s', y :: t' =>
      if (x <= y)%O then x :: merge s' t else y :: merge s t'
  end.

(* Nested `fix`-combinator idiom *)
Fixpoint merge s t : seq T :=
  let fix merge_s t :=
    match s, t with
    | [::], _ => t
    | _, [::] => s
    | x :: s', y :: t' =>
      if (x <= y)%O
      then x :: merge s' t
      else y :: merge_s  t'
    end
  in merge_s t.

Fail Fixpoint sort s : seq T :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in merge (sort s1) (sort s2)
  end.

(*| There is a clever way to implement merge-sort
as a system of recursive functions but we are not
going to go this direction here. |*)

Fail Fixpoint sort s : seq T :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in merge (sort s1) (sort s2)
  end.

(*| A little trick: one can disable termination checker |*)

Print Typing Flags.

Unset Guard Checking.

Print Typing Flags.

(*| Now one can define the usual top-down
merge-sort function: |*)
Fixpoint sort_unguarded s : seq T :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in
         merge (sort_unguarded s1) (sort_unguarded s2)
  end.
Print Assumptions sort_unguarded.
Set Guard Checking.

(*| Here, the nested `fix` design pattern would not work |*)

Program Fixpoint sort s {measure (size s)} : seq T  :=
  match s with
  | [::] => s
  | [:: _] => s
  | _ => let '(s1, s2) := split s in
         merge (sort s1) (sort s2)
  end.
Next Obligation.
apply/ltP; rewrite (@split_lt1 s2) //.
by case: s sort H0 H Heq_anonymous=> // x1 [] // _ _ /(_ x1).
Qed.
Next Obligation.
apply/ltP; rewrite (@split_lt2 s1) //.
by case: s sort H0 H Heq_anonymous=> // x1 [] // _ _ /(_ x1).
Qed.
Next Obligation. by []. Qed.

End MergeSortDef.

(*|
Example: using `orderType` instances
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|*)
Section MergeSortTest.

Compute merge [:: 1; 3; 5] [:: 2; 4; 6].

Compute sort_unguarded [:: 6; 4; 2; 1; 3; 5].

Compute sort [:: 6; 4; 2; 1; 3; 5].

End MergeSortTest.

Section MergeSortCorrect.

Context {disp : unit} {T : orderType disp}.
Implicit Types s t : seq T.

(*| (Optional) exercise |*)
Lemma sort_sorted s :
  sorted (<=%O) (sort s).
Proof.
Admitted.

End MergeSortCorrect.
End Merge.

(*|
`Acc`-predicate
---------------
|*)

(*| Let's see why `Merge.sort` works: |*)
Print Merge.sort.
Print Fix_sub.
Print Fix_F_sub.
Print Acc.

(*| `Acc R x` can be read as "x is accessible
under relation R if all elements staying in
relation R with it are also accessible" |*)

(*| Coq allows us do structural recursion on a
term of type `Acc` which lives in `Prop` while
building a term of a type living in `Type`.
(structural recursion involves pattern-matching).
But the accessibility predicate is defined to be
non-informative (one constructor!). |*)

(*| This allows one do lots of interesting stuff, including
to counting up |*)

(*|
Accessibility predicate on natural numbers
========================================== *)

Section AccFrom.

Variable (p : pred nat).

(*| The `acc_from` predicate lets us count up: we
are not allowed to use `acc_from` to drive
computation (extract information from proofs of
propositions to make computationally relevant
terms), but you can define a recursive function
from a type like this to a type in `Type` and the
*termination checker* is totally (pun intended)
happy with it. We'll see this sort of example at
the end. |*)
Inductive acc_from i : Prop :=
| AccNow of p i
| AccLater of acc_from i.+1.

End AccFrom.

(*| Check out the corresponding induction principle. |*)
About acc_from_ind.

(*|
Simple examples
=============== |*)

Section SimpleExamples.

(*| Let's do a couple of proofs to get the gist of `acc_from` |*)

(*| 1. The property of "being equal to 42" is accessible from 0: |*)
Goal acc_from (fun n => n == 42) 0.
Proof.
do 42 apply: AccLater.
by apply: AccNow.
Qed.

(*| 2. But it's inaccessible from 43: |*)
Goal acc_from (fun n => n == 42) 43 -> False.
Proof.
(*| If you start proving the current goal
directly, you will quickly get stuck because your
goal is too specialised. Clearly, you need
induction over the accessibility predicate, but
`elim` messes up your base case (look at the type
of `acc_from_ind`). |*)
elim.
Show Proof.
(* the first subgoal is unprovable *)
Abort.

(*| We could try and create a more useful
induction principle for our case but we might as
well just use a low-level tactic `fix` which
translates directly to Gallina's fixed-point
combinator. |*)

Goal acc_from (fun n => n == 42) 43 -> False.
Proof.
fix inacc 1.
Show Proof.
(*| To recursively call `inacc` on a structurally
smaller argument we need to case analyse the top
of the goal stack: |*)
case.
(*| The base case is easy now: |*)
- by [].
(*| But here we are stuck. |*)
Abort.

(*| So we generalize the goal to make the proof go
through. |*)
Lemma inacc_from43 :
  forall x, 42 < x -> acc_from (fun n => n == 42) x -> False.
Proof.
fix inacc 3.
Show Proof.
move=> x x_gt42.
case=> [/eqP E|].
- by rewrite E in x_gt42.
apply: inacc.
by apply: (ltn_trans x_gt42).
Qed.

End SimpleExamples.

(*|
Getting a concrete value from an abstract existence proof
========================================================= |*)

Section Find.

Variable p : pred nat.

Lemma find_ex :
  (exists n, p n) -> {m | p m}.
Proof.
move=> exp.

have: acc_from p 0.
(*| `acc_from` lives in `Prop`, so we are allowed
to destruct `exp` in this context, see below. |*)
- case: exp => n.
  rewrite -(addn0 n).
  elim: n 0=> [|n IHn] j.
  - by left.
  rewrite addSnnS.
  right.
  apply: IHn.
  by [].

move: 0.
fix find_ex 2=> m IHm.
case pm: (p m).
- by exists m.
apply: find_ex m.+1 _.
(*| Observe we can only destruct `IHm` at this
point where we are tasked with building a proof
and not a computationally relevant term. |*)
case: IHm.
- by rewrite pm.
by [].
Defined.

End Insertion.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Lia.
Require Export Zwf.

(** multiplication by two *)

Fixpoint mult2 (n:nat) : nat :=
  match n with
  | O => 0%nat
  | S p => S (S (mult2 p))
  end.

(** We just consider an abstract predicate for primality.
    Its definition is irrelevant with respect to the contents of this
    file *)

Parameter prime : nat->Prop.

Section div_pair_section.
 Open Scope Z_scope.
 Variable div_pair :
    forall a b:Z, 0 < b ->
                       {p:Z*Z | a = fst p * b + snd p /\ 0 <= snd p < b}.

 Definition div_pair' (a:Z)(x:{b:Z | 0 < b}) : Z*Z :=
   match x with
   | exist _ b h => let (v, _) := div_pair a b h in v
   end.

End div_pair_section.

Section div2_of_even_section.
Open Scope nat_scope.

 Variable even : nat->Prop.

 Variables (div2_of_even : forall n:nat, even n -> {p:nat | n = p+p})
           (test_even : forall n:nat, {even n}+{even (pred n)} ).

 Definition div2_gen (n:nat) :
   {p:nat | n = p+p}+{p:nat | pred n = p+p} :=
   match test_even n with
   | left h => inl _ (div2_of_even n h)
   | right h' => inr _ (div2_of_even (pred n) h')
   end.

End div2_of_even_section.

Definition eq_dec (A:Type) := forall x y:A, {x = y}+{x <> y}.

Definition pred' (n:nat) : {p:nat | n = S p}+{n = 0} :=
  match n return {p:nat | n = S p}+{n = 0} with
  | O => inright _ (refl_equal 0)
  | S p =>
     inleft _
       (exist (fun p':nat => S p = S p') p (refl_equal (S p)))
  end.

Check ({p:nat | 0 = S p }+{0 = 0}).

Check (fun p:nat =>{p':nat | S p = S p'}+{S p = 0}).

Definition pred'' : forall n:nat, {p:nat | n = S p}+{n = 0}.
 intros n; case n.
 right; apply refl_equal.
 intros p; left; exists p; reflexivity.
Defined.

Definition pred_partial : forall n:nat, n <> 0 -> nat.
 intros n; case n.
 intros h; elim h; reflexivity.
 intros p h'; exact p.
Defined.

Theorem le_2_n_not_zero : forall n:nat, 2 <= n -> n <> 0.
Proof.
 intros n Hle; elim Hle; intros; discriminate.
Qed.

Theorem le_2_n_pred :
 forall (n:nat)(h: 2 <= n), pred_partial n (le_2_n_not_zero n h) <> 0.
 (*
 intros n h; elim h.
 *)
Abort.

Theorem le_2_n_pred' :
 forall n:nat, 2 <= n -> forall h:n <> 0, pred_partial n h <> 0.
Proof.
 intros n Hle; elim Hle.
 intros; discriminate.
 simpl; intros; apply le_2_n_not_zero; assumption.
Qed.

Theorem le_2_n_pred :
 forall (n:nat)(h:2 <= n), pred_partial n (le_2_n_not_zero n h) <> 0.
Proof.
 intros n h; exact (le_2_n_pred' n h (le_2_n_not_zero n h)).
Qed.

Definition pred_partial_2 (n:nat)(h:2 <= n) : nat :=
  pred_partial (pred_partial n (le_2_n_not_zero n h))
               (le_2_n_pred n h).

Check(forall n:nat, n <> 0 -> {v:nat | n = S v}).

Check (forall n:nat, 2 <= n -> {v:nat | n = S (S v)}).

Definition pred_strong : forall n:nat, n <> 0 -> {v:nat | n = S v}.
 intros n; case n;
  [intros H; elim H | intros p H'; exists p]; trivial.
Defined.

Theorem pred_strong2_th1 :
 forall n p:nat, 2 <= n -> n = S p -> p <> 0.
Proof.
 intros; lia.
Qed.

Theorem pred_th1 : forall n p q:nat, n = S p -> p = S q -> n = S (S q).
Proof.
 intros; subst n; auto.
Qed.

Definition pred_strong2 (n:nat)(h:2<=n):{v:nat | n = S (S v)} :=
  match pred_strong n (le_2_n_not_zero n h) with
  | exist _ p h' =>
      match pred_strong p (pred_strong2_th1 n p h h') with
      | exist _ p' h'' =>
          exist (fun x:nat => n = S (S x))
                p' (pred_th1 n p p' h' h'')
      end
  end.

Definition pred_strong2' :
  forall n:nat, 2 <= n -> {v:nat | n = S (S v)}.
Proof.
  intros n h; case (pred_strong n).
 -  apply le_2_n_not_zero; assumption.
 -  intros p h'; case (pred_strong p).
   +  apply (pred_strong2_th1 n); assumption.
   +  intros p' h''; exists p'; eapply pred_th1; eauto.
Defined.

Section minimal_specification_strengthening.

 Variable prime : nat->Prop.
 Definition divides (n p:nat) : Prop := exists q:_, q*p = n.
 Definition prime_divisor (n p:nat):= prime p /\ divides p n.

 Variable prime_test : nat->bool.
 Hypotheses
   (prime_test_t : forall n:nat, prime_test n = true -> prime n)
   (prime_test_f : forall n:nat, prime_test n = false -> ~prime n).

 Variable get_primediv_weak : forall n:nat, ~prime n -> nat.

 Hypothesis get_primediv_weak_ok :
     forall (n:nat)(H:~prime n), 1 < n ->
        prime_divisor n (get_primediv_weak n H).

 Lemma divides_refl : forall n:nat, divides n n.
  Proof.
  intro n; exists 1; simpl; auto.
 Qed.
 #[local] Hint Resolve divides_refl : core.

 Check (fun E:nat=>  fun n:nat => if prime_test n then n else E).

 Definition bad_get_prime : nat->nat.
  intro n; case_eq (prime_test n).
  -  intro; exact n.
  -  intro Hfalse; apply (get_primediv_weak n); auto.
 Defined.

 Print bad_get_prime.

 Theorem bad_get_primediv_ok :
  forall n:nat, 1 < n -> prime_divisor n (bad_get_prime n).
 Proof.
  intros n H; unfold bad_get_prime.
 Abort.

 Definition stronger_prime_test :
   forall n:nat, {(prime_test n)=true}+{(prime_test n)=false}.
 Proof.
  intro n; case (prime_test n);[left | right]; reflexivity.
 Defined.

 Definition get_prime (n:nat) : nat :=
  match stronger_prime_test n with
  | left H => n
  | right H => get_primediv_weak n (prime_test_f n H)
  end.

 Theorem get_primediv_ok :
  forall n:nat, 1 < n -> prime_divisor n (get_prime n).
 Proof.
  intros n H; unfold get_prime.
  case (stronger_prime_test n); auto.
  split; auto.
 Qed.

End minimal_specification_strengthening.

Definition pred_partial' : forall n:nat, n <> 0 -> nat.
 refine
  (fun n =>
    match n as x return x <> 0 -> nat with
    | O => fun h:0 <> 0 => _
    | S p => fun h:S p <> 0 => p
    end).
 elim h; trivial.
Defined.

Definition pred_partial_2' : forall n:nat, le 2 n -> nat.
Proof.
 refine
  (fun n h=>(fun h':n<>0 => pred_partial (pred_partial n h') _) _).
 - apply le_2_n_pred'; auto.
 - apply le_2_n_not_zero; auto.
Defined.

Definition pred_strong2'' : forall n:nat, 2<=n -> {v:nat | n = S (S v)}.
Proof.
 refine
  (fun n h =>
    match pred_strong n _ with
    | exist _ p h' =>
      match pred_strong p _ with exist _ p' h'' => exist _ p' _ end
    end).
 -  apply le_2_n_not_zero; assumption.
 -  eapply pred_strong2_th1; eauto.
 -  rewrite <- h''; trivial.
Qed.

Require Import Program.
Program  Definition pred_strong2''' (n:nat)(H:2<=n):{v:nat|n = S (S v)} :=
    pred  (pred n ).
Next Obligation.
(*

1 subgoal

  n : nat
  H : 2 <= n
  ============================
   n = S (S (pred (pred n)))

*)
lia.
Defined.

Fixpoint div2 (n:nat) : nat :=
  match n with 0 => 0 | 1 => 0 | S (S p) => S (div2 p) end.

Section bad_proof_for_div2_le.

 Theorem div2_le : forall n:nat, div2 n <= n.
 Proof.
  induction n as [ | n IHn].
  - simpl; auto.
  -  induction n.
    +  simpl;  auto.
    +  Abort.
End bad_proof_for_div2_le.

(** Put in one file (multiply used) *)

Theorem div2_rect (P: nat -> Type) :
 P 0 -> P 1 ->
 (forall n, P n -> P (S n) -> P(S (S n)))->
 forall n:nat, P n.
Proof.
 intros H0 H1 H n; assert (X: ( P n * P (S n))%type).
 - induction n; intuition.
 - now destruct X.
Defined.

Theorem div2_le : forall n:nat, div2 n <= n.
Proof.
 intro n; induction n using div2_rect; simpl; auto with arith.
Qed.

Lemma double_div2_le : forall x:nat, div2 x + div2 x <= x.
Proof.
 intro n; induction n using div2_rect; simpl; auto with arith.
 lia.
Qed.

Fixpoint div2'_aux (n:nat) : nat*nat :=
  match n with
  | 0 => (0, 0)
  | S p => let (v1,v2) := div2'_aux p in (v2, S v1)
  end.

Definition div2' (n:nat) : nat := fst (div2'_aux n).

Fixpoint plus' (n m:nat){struct m} : nat :=
  match m with O => n | S p => S (plus' n p)
  end.

Theorem plus'_O_n : forall n:nat, n=(plus' O n).
Proof.
 intros n; elim n; simpl; auto.
Qed.

Theorem plus'_Sn_m : forall n m:nat, S (plus' n m) = plus' (S n) m.
Proof.
 intros n m; elim m; simpl; auto.
Qed.

Theorem plus'_comm : forall n m:nat, plus' n m = plus' m n.
Proof.
 intros n m; elim m; simpl.
 -  apply plus'_O_n.
 -  intros p Hrec; rewrite <- plus'_Sn_m; auto.
Qed.

Theorem plus_plus' : forall n m:nat, n+m = plus' n m.
Proof.
 intros n m; rewrite plus'_comm; elim n; simpl; auto.
Qed.

Fixpoint plus'' (n m:nat){struct m} : nat :=
  match m with 0 => n | S p => plus'' (S n) p end.

Theorem plus''_Sn_m : forall n m:nat, S (plus'' n m) = plus'' (S n) m.
Proof.
 intros n m; generalize n; elim m; simpl.
 -  auto.
 - now  intros p Hrec n0.
Qed.

Open Scope Z_scope.

Fixpoint div_bin (n m:positive){struct n} : Z*Z :=
 match n with
 | 1%positive => match m with 1%positive =>(1,0) | _ =>(0,1) end
 | xO n' =>
   let (q',r'):=div_bin n' m in
   match Z_lt_ge_dec (2*r')(Zpos m) with
   | left Hlt => (2*q', 2*r')
   | right Hge => (2*q' + 1, 2*r' - (Zpos m))
   end
 | xI n' =>
   let (q',r'):=div_bin n' m in
   match Z_lt_ge_dec (2*r' + 1)(Zpos m) with
   | left Hlt => (2*q', 2*r' + 1)
   | right Hge => (2*q' + 1, (2*r' + 1)-(Zpos m))
   end
 end.

Theorem rem_1_1_interval : 0 <= 0 < 1.
Proof.
 lia.
Qed.

Theorem rem_1_even_interval : forall m:positive,  0 <= 1 < Zpos (xO m).
Proof.
 intros n'; split.
 -  auto with zarith.
 - reflexivity.
Qed.

Theorem rem_1_odd_interval : forall m:positive, 0 <= 1 < Zpos (xI m).
Proof.
 split;[auto with zarith | compute; auto].
Qed.

Theorem rem_even_ge_interval :
 forall m r:Z, 0 <= r < m ->  2*r >= m -> 0 <= 2*r - m < m.
Proof.
 intros; lia.
Qed.

Theorem rem_even_lt_interval :
 forall m r:Z, 0 <= r < m -> 2*r < m -> 0 <= 2*r < m.
Proof.
 intros; lia.
Qed.

Theorem rem_odd_ge_interval :
 forall m r:Z, 0 <= r < m -> 2*r + 1 >= m -> 2*r + 1 - m <  m.
Proof.
 intros; lia.
Qed.

Theorem rem_odd_lt_interval :
 forall m r:Z, 0 <= r < m -> 2*r + 1 < m -> 0 <= 2*r + 1 < m.
Proof.
 intros; lia.
Qed.
#[local] Hint Resolve rem_odd_ge_interval rem_even_ge_interval
 rem_odd_lt_interval rem_even_lt_interval rem_1_odd_interval
 rem_1_even_interval rem_1_1_interval : core.

Ltac div_bin_tac arg1 arg2 :=
  elim arg1;
   [intros p; lazy beta iota delta [div_bin]; fold div_bin;
      case (div_bin p arg2); unfold snd; intros q' r' Hrec;
      case (Z_lt_ge_dec (2*r' + 1)(Zpos arg2)); intros H
   | intros p; lazy beta iota delta [div_bin]; fold div_bin;
      case (div_bin p arg2); unfold snd; intros q' r' Hrec;
      case (Z_lt_ge_dec (2*r')(Zpos arg2)); intros H
   | case arg2; lazy beta iota delta [div_bin]; intros].

Theorem div_bin_rem_lt :
 forall n m:positive, 0 <= snd (div_bin n m) < Zpos m.
Proof.
 intros n m; div_bin_tac n m; unfold snd; auto.
 lia.
Qed.

(*
SearchRewrite (Zpos (xI _)).

SearchRewrite (Zpos (xO _)).
*)

Theorem div_bin_eq :
 forall n m:positive,
   Zpos n =  (fst (div_bin n m))*(Zpos m) + snd (div_bin n m).
Proof.
 intros n m; div_bin_tac n m;
  rewrite Zpos_xI || (try rewrite Zpos_xO);
  try rewrite Hrec; unfold fst, snd; ring.
Qed.

Inductive div_data (n m:positive) : Set :=
  div_data_def :
  forall q r:Z, Zpos n = q*(Zpos m)+r -> 0<= r < Zpos m -> div_data n m.

Definition div_bin2 : forall n m:positive, div_data n m.
 intros n m; elim n.
 -  intros n' [q r H_eq H_int];
   case (Z_lt_ge_dec (2*r + 1)(Zpos m)).
  + split with  (2*q) (2*r + 1).
    rewrite Zpos_xI; rewrite H_eq; ring.
    auto.
  + split with  (2*q+1)(2*r + 1 - (Zpos m)).
    rewrite Zpos_xI; rewrite H_eq; ring.
    lia.
 - intros n' [q r H_eq H_int].
   case (Z_lt_ge_dec (Zmult 2 r)(Zpos m)).
   split with (Zmult 2 q)(Zmult 2 r).
   +  rewrite Zpos_xO; rewrite H_eq; ring.
   +  auto.
   + split with  (Zplus (Zmult 2 q) 1)(Zminus (Zmult 2 r)(Zpos m)).
     * rewrite Zpos_xO; rewrite H_eq; ring.
     *  auto.
-  case m.
   + split with  0%Z 1%Z.
     *   ring;  auto.
     *  auto.
   + split with  0%Z 1%Z.
     *  ring.
     * auto.
    + split with  1%Z 0%Z.
     *  ring.
     *  auto.
Qed.

Definition div_bin3 : forall n m:positive, div_data n m.
 refine
  ((fix div_bin3 (n:positive) : forall m:positive, div_data n m :=
      fun m =>
        match n return div_data n m with
        | 1%positive =>
            match m return div_data 1 m with
            | 1%positive => div_data_def 1 1 1 0 _ _
            | xO p => div_data_def 1 (xO p) 0 1 _ _
            | xI p => div_data_def 1 (xI p) 0 1 _ _
            end
        | xO p =>
            match div_bin3 p m with
            | div_data_def _ _ q r H_eq H_int =>
                match Z_lt_ge_dec (Zmult 2 r)(Zpos m) with
                | left hlt =>
                    div_data_def (xO p) m (Zmult 2 q)
                                 (Zmult 2 r) _ _
                | right hge =>
                    div_data_def (xO p) m (Zplus (Zmult 2 q) 1)
                      (Zminus (Zmult 2 r)(Zpos m)) _ _
                end
            end
        | xI p =>
            match div_bin3 p m with
            | div_data_def _ _ q r H_eq H_int =>
                match Z_lt_ge_dec (Zplus (Zmult 2 r) 1)(Zpos m)
                with
                | left hlt =>
                    div_data_def (xI p) m (Zmult 2 q)
                      (Zplus (Zmult 2 r) 1) _ _
                | right hge =>
                    div_data_def (xI p) m (Zplus (Zmult 2 q) 1)
                      (Zminus (Zplus (Zmult 2 r) 1)(Zpos m)) _ _
                end
            end
        end));
      clear div_bin3; try rewrite Zpos_xI; try rewrite Zpos_xO;
      try rewrite H_eq; auto with zarith; try (ring; fail);
 try (split;[auto with zarith | compute; auto]).
Defined.


From mathcomp.ssreflect Require Import all_ssreflect seq.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Forall.

Notation member := List.In.

Lemma forall_member A P (l : seq A) :
  Forall P l <-> forall x, member x l -> P x.
Proof.
  elim l=>// x {l}l [IhL IhR] /=; split.
  + by move=>[Px /IhL-Pl] x0 [<-|/Pl].
  + move=> H; split.
    - by apply: H; left.
    - by apply: IhR=>x0 x0_l; apply: H; right.
Qed.

Lemma memberP (A : eqType) (x : A) l : reflect (member x l) (x \in l).
Proof.
  elim l; first by apply: ReflectF.
  move=> a {l}l Ih/=; rewrite in_cons; case: eqP=>[->|x_aF].
  + by apply: ReflectT; left.
  + case: Ih=>[x_l|x_lF].
    - by apply: ReflectT; right.
    - by apply: ReflectF=>[[/esym-x_a|x_l]].
Qed.

Lemma cat_eq_nil (A : eqType) (K1 K2 : seq A)
  : K1 ++ K2 == [::] <-> K1 == [::] /\ K2 == [::].
Proof.
  split.
  - by move=>/eqP; case: K1=>//=->.
  - by move=>[/eqP->/eqP->].
Qed.

Lemma flatten_eq_nil (A : eqType) (Ks : seq (seq A)) :
  flatten Ks == [::] <-> forall K, member K Ks -> K == [::].
Proof.
  split.
  - by elim: Ks=>//= K Ks Ih /cat_eq_nil-[/eqP-> /Ih-H {}K [->|/H]].
  - elim: Ks=>//= K Ks Ih H; apply/cat_eq_nil;split; first by apply/H; left.
      by apply/Ih=>K' H'; apply/H; right.
Qed.

Lemma member_map A B (P : B -> Prop) (f : A -> B) L :
  (forall x, member x [seq f x | x <- L] -> P x) <->
  (forall x, member x L -> P (f x)).
Proof.
  split=>H x M.
  - apply: H; elim: L M=>// y L Ih [<-|]; first by left.
    by rewrite -/(member _ _) => /Ih-H /=; right.
  - elim: L H M=>// y L /=Ih H [<-|H'].
    + by apply: H; left.
    + by apply: Ih=>// z M; apply: H; right.
Qed.
Hint Rewrite member_map : mpst.


(* Exercises in HoTT.
  Template from http://blog.ezyang.com/2013/07/hott-exercises-in-coq-in-progress/. *)

Require Import HoTT.

Definition admit {T: Type} : T. Admitted.

(* Exercise 1.1 *)
Definition mycompose {A B C : Type} (g : B -> C) (f : A -> B) : A -> C
  := fun x => g (f x).

Goal forall (A B C D : Type) (f : A -> B) (g : B -> C) (h : C -> D),
       mycompose h (mycompose g f) = mycompose (mycompose h g) f.
unfold mycompose.
reflexivity.
Qed.

(* Exercise 1.2 *)
Section ex_1_2_prod.
  Variable A B : Type.
  Check @fst.
  Check @snd.
  Definition my_prod_rec (C : Type) (g : A -> B -> C) (p : A * B) : C
    := g (fst p) (snd p).
  Goal fst = my_prod_rec A (fun a => fun b => a).
    unfold my_prod_rec.
    reflexivity.
  Qed.
  Goal snd = my_prod_rec B (fun a => fun b => b).
    unfold my_prod_rec.
    reflexivity.
  Qed.

End ex_1_2_prod.

Section ex_1_2_sig.
  Variable A : Type.
  Variable B : A -> Type.
  Check @projT1.
  Check @projT2.
  Definition my_sig_rec (C : Type) (g : forall (x : A), B x -> C) (p : exists (x : A), B x) : C
    := g (projT1 p) (projT2 p).
  Goal @projT1 A B = my_sig_rec A (fun a => fun b => a).
    reflexivity.
  Qed.
  (* What goes wrong when you try to prove this for projT2? *)

End ex_1_2_sig.

(* Exercise 1.3 *)

Definition refl {A : Type} (x : A) : x = x := 1%path.

Section ex_1_3_prod.
  Variable A B : Type.
  (* Given by the book *)
  Definition uppt : forall (x : A * B), ((fst x, snd x) = x) :=
    fun p => match p with (a,b) => refl (a,b) end.
  Definition my_prod_ind (C : A * B -> Type)
    (g : forall (x : A) (y : B), C (x, y)) (x : A * B) : C x
    := (paths_rew (A*B) (fst x, snd x) x C
      (g (fst x) (snd x)) (uppt x)).
  Goal forall C g a b, my_prod_ind C g (a, b) = g a b.
    intros C g a b.
    unfold my_prod_ind.
    simpl.
    reflexivity.
  Qed.
End ex_1_3_prod.

Section ex_1_3_sig.
  Variable A : Type.
  Variable B : A -> Type.
  Definition sig_uppt : forall (x : exists (a : A), B a), ((projT1 x; projT2 x) = x).
    intro x.
    destruct x.
    exact (refl (x;b)).
  Defined.
  Definition mysig_ind (C : (exists (a : A), B a) -> Type)
    (g : forall (a : A) (b : B a), C (a; b)) (x : exists (a : A), B a) : C x
    := paths_rew (exists (a:A), B a) (projT1 x; projT2 x) x C
      (g (projT1 x) (projT2 x)) (sig_uppt x).
  Goal forall C g a b, mysig_ind C g (a; b) = g a b.
    intros C g a b.
    unfold mysig_ind.
    simpl.
    reflexivity.
  Qed.
End ex_1_3_sig.

(* Exercise 1.4 *)
Fixpoint iter (C : Type) (c0 : C) (cs : C -> C) (n : nat) : C :=
  match n with
    | 0 => c0
    | S n' => cs (iter C c0 cs n')
  end.
Definition mynat_rec (C : Type) : C -> (nat -> C -> C) -> nat -> C.
  intros e s n.
  apply (snd : nat * C -> C).
  apply iter.
  exact (0, e).
  intro p.
  destruct p.
  exact (S n0, s n0 c).
  exact n.
Defined.
Eval compute in mynat_rec (list nat) nil (@cons nat) 2.
Eval compute in nat_rect (fun _ => list nat) nil (@cons nat) 2.

(* Exercise 1.5 *)
Definition mycoprod (A B : Type) := exists (x : Bool), Bool_rect (fun _ => Type) A B x.

Section ex_1_5.
  Variable A B : Type.
  Definition inl := existT (Bool_rect (fun _ => Type) A B) true.
  Definition inr := existT (Bool_rect (fun _ => Type) A B) false.
  Definition mycoprod_ind (C : mycoprod A B -> Type)
                          (l : forall (a : A), C (inl a))
                          (r : forall (b : B), C (inr b))
                          (x : mycoprod A B) : C x.
    destruct x.
    unfold inl in l.
    unfold inr in r.
    destruct x.
    exact (l b).
    exact (r b).
   Defined.
  Goal forall C l r x, mycoprod_ind C l r (inl x) = l x.
    unfold mycoprod_ind; simpl.
    intros C l b x.
    auto.
  Qed.
  Goal forall C l r x, mycoprod_ind C l r (inr x) = r x. auto. Qed.
End ex_1_5.

(* Exercise 1.6 *)

Definition myprod (A B : Type) := forall (x : Bool), Bool_rect (fun _ => Type) A B x.
Section ex_1_6.
  Context `{Funext}.
  Variable A B : Type.
  Definition mypr1 (p : myprod A B) := p true.
  Definition mypr2 (p : myprod A B) := p false.
  Definition mymkprod (a : A) (b : B) : myprod A B := Bool_rect (Bool_rect (fun _ => Type) A B) a b.
  Definition myprod_ind (C : myprod A B -> Type)
    (g : forall (x : A) (y : B), C (mymkprod x y)) (x : myprod A B) : C x.
    generalize (g (mypr1 x) (mypr2 x)); intro H1.
    unfold mymkprod in H1.
    unfold Bool_rect in H1.
    unfold mypr1 in H1.
    unfold mypr2 in H1.
    assert ((fun (b:Bool) => if b  return (if b then A else B)
           then x true else x false) = x).
    apply path_forall.
    compute.
    intro x0.
    case x0; auto.
    rewrite X in H1.
    exact H1.
  Defined.
  Goal forall C g a b, myprod_ind C g (mymkprod a b) = g a b.
    intros C g a b.
    unfold myprod_ind.
    simpl.
    compute.
    simpl.
    Check (let (equiv_inv, eisretr, eissect, _) :=
       isequiv_apD10 Bool
         (fun x : Bool => if x then A else B)
         (fun b0 : Bool =>
          if b0 as b1 return (if b1 then A else B)
          then a
          else b)
         (fun b0 : Bool =>
          if b0 as b1 return (if b1 then A else B)
          then a
          else b) in
   equiv_inv).
   Admitted.
   (*
    Check (fun x0 : Bool =>
     if x0 as b0
      return
        ((if b0 as b1 return (if b1 then A else B)
          then a
          else b) =
         (if b0 as b1 return (if b1 then A else B)
          then a
          else b))
     then 1
     else (1 : b = b)).
    Check a.
    assert (forall (x y: myprod A B) (z:C x) (a: x = y), match a in (_ = y) return (C y) with | 1 => z end = z).
    intros A0 B0 x y z a0.
    elim a0.
    reflexivity.
    simpl.
    compute.
    replace ((let (equiv_inv, eisretr, eissect, _) :=
       isequiv_apD10 Bool
         (fun x : Bool => if x then A else B)
         (fun b0 : Bool =>
          if b0 as b1 return (if b1 then A else B)
          then a
          else b)
         (fun b0 : Bool =>
          if b0 as b1 return (if b1 then A else B)
          then a
          else b) in
   equiv_inv)) with tt.
    apply X with (z := g a b).
    simpl.
  *)
End ex_1_6.

Section ex_1_7.

(* based path induction. given in 1.12 *)
  Definition path_ind: forall (A:Type)
    (C:(forall (x y:A), x=y -> Type)),
       (forall x, C x x 1)
     -> forall (x y:A) (p:x=y), C x y p.
    intros A C t x y p.
    case p.
    exact (t x).
  Defined.
(* equation which hold in based path induction. *)
  Lemma bpi_equality:
    forall (A:Type)
      (C:forall (x y:A), x = y -> Type)
      (x:A)
      (c:forall x, C x x 1),
         path_ind A C c x x 1 = c x.
    simpl.
    reflexivity.
  Qed.
  (* question: derive based_path_ind by path_ind. *)
  Definition based_path_ind: forall (A:Type) (a:A)
    (C:forall (x:A), a = x -> Type), C a 1 ->
      forall (x:A) (p: a = x), C x p.
  intros A a C c x p.
  (*
  change (C x p) with ((fun t u (p:t = u) => C u p) a x p).
  apply path_ind with (C:= (fun _ x0 => C x0)) (p:=p).
  exact c.
  Defined.
  *)
  Admitted.
End ex_1_7.

Section ex_1_7_inv.

(* based path induction. given in 1.12 *)
  Definition based_path_ind_i: forall (A:Type) (a:A)
    (C:forall (x:A), a = x -> Type), C a 1 ->
      forall (x:A) (p: a = x), C x p.
  intros A a C c x p.
  case p.
  exact c.
  Defined.
(* equation which hold in based path induction. *)
  Lemma bpi_equality_i:
    forall (A:Type) (a:A)
      (C:forall (x:A), a = x -> Type)
      (c:C a 1),
         based_path_ind_i A a C c a 1 = c.
    simpl.
    reflexivity.
  Qed.
  (* question: derive path_ind by based_path_ind. *)
  Definition path_ind_i: forall (A:Type)
    (C:(forall (x y:A), x=y -> Type)),
       (forall x, C x x 1)
     -> forall (x y:A) (p:x=y), C x y p.
    intros A C t x y p.
    apply based_path_ind_i.
    exact (t x).
  Defined.
End ex_1_7_inv.

Section ex_1_8.
  Fixpoint rec_N (C:Type) (init:C)
   (cs: nat -> C -> C) (n:nat) :C := match n with
    | 0 => init
    | S m => cs m (rec_N C init cs m)
   end.
End ex_1_8.

Section ex_1_9.
  Definition fin(n: nat) : Type.
  induction n.
  exact Empty.
  Print Empty.
  exact (option IHn).
  Defined.
  Definition fmax: forall n, fin (S n).
  induction n.
  simpl.
  exact None.
  simpl.
  exact (Some IHn).
  Defined.
End ex_1_9.

Section ex_1_10.
  Fixpoint ack(n m:nat):nat :=
    rec_N (nat->nat) S (fun _ q m' => rec_N nat (1%nat) (fun _ => q) (S m')) n m.
  Goal forall n, ack 0 n = S n.
  simpl.
  auto.
  Qed.
  Goal forall n, ack (S n) 0 = ack n 1.
  induction n.
  simpl.
  auto.
  auto.
  Qed.
End ex_1_10.

Section ex_1_11.
  Goal forall P:Type, ~~~P -> ~P.
  intros P H H1.
  apply H.
  intro H2.
  exact (H2 H1).
  Qed.
End ex_1_11.

Section ex_1_14.
  Goal forall (A:Type) (x:A)(p: x=x), p = 1.
  intros A x p.
  Admitted.
End ex_1_14.


Require Import List.

Definition task := forall l: list nat, app l (0 :: nil) <> nil.

Theorem solution: task.
Proof.
  unfold task.
  intros.
  destruct l.
  - simpl. congruence.
  - simpl. congruence.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) y)) (append (rev y) x).
Proof.
induction x.
  - intros. simpl. rewrite <- append_assoc. rewrite IHx. simpl.
    rewrite <- append_assoc. simpl. reflexivity.
  - intros.  simpl. lfind.  reflexivity.
Admitted.


Require Import ssreflect.
From coq_sortscan Require Import helper ops.
From stdpp Require Import sorting list.

Context (R : relation nat) `{∀ x y, Decision (R x y)}.
Implicit Types data : Data.

Section Phase1.
  Program Definition mem_sort data (len : nat) :=
    let M := mem data in
    {| disk := disk data;
      mem := merge_sort R (take len M) ++ drop len M |}.
  Next Obligation. intros. apply (disk_length data). Qed.
  Next Obligation.
    intros. rewrite app_length merge_sort_length
      take_length drop_length (mem_length data). lia.
  Qed.

  (* sort disk[i..i+M) *)
  Definition sort_disk data (i len : nat) :=
    let data' := read_range_disk data i len 0 in
    write_range_disk (mem_sort data' len) 0 len i.

  Definition phase1_single data (c : nat) :=
    let i := c * CAP_MEM in
    sort_disk data i (CAP_MEM `min` (CAP_DISK - i)).

  Fixpoint phase1_loop data (c : nat) :=
    match c with
    | O => phase1_single data 0
    | S c' => phase1_single (phase1_loop data c') (S c')
    end.

  Definition phase1 data :=
    phase1_loop data (CAP_DISK / CAP_MEM).

  Lemma mem_sort_take data len :
    take len (mem (mem_sort data len)) =
      merge_sort R (take len (mem data)).
  Admitted.
(*
  Lemma mem_sort_app l l' len :
    length l = len →
    mem_sort (l ++ l') len = merge_sort R l ++ l'.
  Admitted.
*)
  Lemma sort_disk_sorted data i len :
    len ≤ CAP_MEM → i + len ≤ CAP_DISK →
    slice (disk (sort_disk data i len)) i len =
      merge_sort R (slice (disk data) i len).
  Proof.
    intros Hmem Hdisk.
    rewrite write_range_disk_slice; auto.
    rewrite slice_0 mem_sort_take -slice_0.
    by rewrite read_range_disk_slice.
  Qed.

  Lemma sort_disk_perm data i len :
    len ≤ CAP_MEM → i + len ≤ CAP_DISK →
    disk (sort_disk data i len) ≡ₚ disk data.
  Proof.
    intros. unfold sort_disk.
    assert (length (slice (disk data) i len) = len) as Hlen.
      { rewrite slice_length; auto. by rewrite (disk_length data). }
    rewrite write_range_disk_eq. simpl.
    rewrite read_range_disk_disk slice_0.
    rewrite read_range_disk_eq take_0; simpl.
    rewrite -{2 5} Hlen take_app drop_app.
    assert (length (merge_sort R (slice (disk data) i len)) = len) as HlenM.
      { rewrite merge_sort_length slice_length; auto.
        by rewrite (disk_length data). }
    rewrite -{1} HlenM take_app.
    rewrite {4} (slice_cut (disk data) i len).
    do 2 (apply Permutation_app; auto).
    apply merge_sort_Permutation.
  Qed.

  Lemma phase1_single_spec data c :
    Transitive R → Total R →
    c ≤ CAP_DISK / CAP_MEM →
    let data' := phase1_single data c in
    disk data' ≡ₚ disk data ∧
    StronglySorted R (slice (disk data') (c * CAP_MEM) CAP_MEM).
  Proof.
    unfold phase1_single. intros TRANS TOT Hc.
    assert (c * CAP_MEM +
      CAP_MEM `min` (CAP_DISK - c * CAP_MEM)
      ≤ CAP_DISK
    ) as Hcle.
    { assert (c * CAP_MEM ≤ CAP_DISK); try lia.
      trans (CAP_DISK `div` CAP_MEM * CAP_MEM).
      - by apply PeanoNat.Nat.mul_le_mono_r.
      - rewrite div_mult_sub_mod; try lia. by unfold CAP_MEM.
    }
    split.
    - apply sort_disk_perm; lia.
    - rewrite slice_minlen disk_length.
      rewrite sort_disk_sorted; try lia.
      by apply StronglySorted_merge_sort.
  Qed.

  Lemma phase1_loop_spec data c :
    Transitive R → Total R →
    c ≤ CAP_DISK / CAP_MEM →
    let data' := phase1_loop data c in
    disk data' ≡ₚ disk data ∧
    ∀ i, i ≤ c → StronglySorted R (slice (disk data') (i * CAP_MEM) CAP_MEM).
  Proof.
    intros TRANS TOT Hc.
    induction c; intros.
    - assert (disk data' ≡ₚ disk data ∧
        StronglySorted R (slice (disk data') 0 CAP_MEM)
      ) as [HP HSS].
      { apply phase1_single_spec; auto. }
      split; auto. intros. destruct i; auto. lia.
    - simpl in data'.
      assert (
        disk data' ≡ₚ disk (phase1_loop data c)
        ∧ StronglySorted R (slice (disk data') (S c * CAP_MEM) CAP_MEM)
      ) as [HP HSS].
        { apply phase1_single_spec; auto. }
      assert (c ≤ CAP_DISK `div` CAP_MEM) as Hc' by lia.
      apply IHc in Hc' as [HP0 HSS0].
      split. { etrans; eauto. }
      intros. destruct (decide (i ≤ c)).
      + apply HSS0 in l. unfold data'. admit.
      + assert (i = S c) by lia. by subst.
  Admitted.

  Lemma phase1_spec data :
    Transitive R → Total R →
    let data' := phase1 data in
    disk data' ≡ₚ disk data ∧
    ∀ i, StronglySorted R (slice (disk data') (i * CAP_MEM) CAP_MEM).
  Proof.
    intros TRANS TOT.
    destruct (phase1_loop_spec data (CAP_DISK / CAP_MEM))
      as [HP HSS]; auto.
    intros. split. { apply HP. }
    intros. destruct (decide (i ≤ CAP_DISK `div` CAP_MEM)).
    - by apply HSS.
    - rewrite slice_to_nil. 2: constructor. rewrite disk_length.
      assert (i*CAP_MEM ≥ S (CAP_DISK `div` CAP_MEM)*CAP_MEM) by admit.
      assert (S (CAP_DISK `div` CAP_MEM)*CAP_MEM ≥ CAP_DISK) by admit.
      lia.
  Admitted.
End Phase1.

Section Phase2.
  Program Definition fill_zero data :=
    {| disk := disk data;
      mem := replicate CAP_MEM 0 |}.
  Next Obligation. intros. apply disk_length. Qed.
  Next Obligation. intros. apply replicate_length. Qed.

  Definition

  Definition find_min data :=
    0.

  Fixpoint phase2_loop data (rem : nat) :=
    match rem with
    | O => []
    | S rem' =>
        let chunk_id := find_min data in
        let i := (CAP_MEM * chunk_id) + read_mem data chunk_id in
        let data' := read_disk data i (CAP_MEM - 1) in
        let v := read_mem data' (CAP_MEM - 1) in
        let data'' := write_const_mem data' chunk_id (S i) in
        v :: phase2_loop data'' rem'
    end.

  Definition phase2 data := phase2_loop data CAP_DISK.
End Phase2.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.Eqdep.

Require Import Category.
Require Import Functor.
Require Import NaturalTransformation.
Require Import FunctorCategory.
Require Import MetaCategory.
Require Import Diagrams.

Polymorphic Definition deltaOb A {B: Cat}(X: B): Ob (FUN A B).
  refine {|
    funSig := {|
      fmap_o _   := X;
      fmap _ _ _ := id X
    |}
  |}.
  split.
  intros Y Z f f' Hf.
  reflexivity.
  intros Y.
  reflexivity.
  simpl. intros _ _ _ _ _.
  symmetry.
  apply (ident_r B).
Defined.

Polymorphic Definition deltaHom A {B: Cat}{X Y: B}(f: Hom X Y):
    Hom (deltaOb A X) (deltaOb A Y).
  refine {| natTrans a := f: Hom (deltaOb A X a) (deltaOb A Y a) |}.
  unfold natural.
  simpl.
  intros _ _ _.
  transitivity f.
  apply (ident_l B).
  symmetry.
  apply (ident_r B).
Defined.

Polymorphic Definition deltaSig(A B: Cat): FunSig B (FUN A B) := {|
  fmap_o   := deltaOb A;
  fmap X Y := deltaHom A
|}.

Polymorphic Lemma deltaAx(A B: Cat): FunAx (deltaSig A B).
Proof.
  split.
  intros X Y f f' Hf u.
  apply Hf.
  intros X u.
  reflexivity.
  intros X Y Z g h u.
  reflexivity.
Defined.

Polymorphic Definition delta(A B: Cat): Fun B (FUN A B) := {|
  funAx := deltaAx A B
|}.


Require Export Iron.Language.SystemF.TyEnv.
Require Export Iron.Language.SystemF.Ty.
Require Export Iron.Language.SystemF.Ki.

(* Expressions *)
Inductive exp : Type :=
 | XVar  : nat -> exp             (* deBruijn indices *)
 | XLAM  : exp -> exp             (* Type abstraction *)
 | XAPP  : exp -> ty  -> exp      (* Type application *)
 | XLam  : ty  -> exp -> exp      (* Value abstraction *)
 | XApp  : exp -> exp -> exp.     (* Value application *)

Hint Constructors exp.

(* Weak normal dorms cannot be reduced further by
   call-by-value evaluation. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XLAM
   : forall x1
   , wnfX (XLAM x1)

 | Wnf_XLam
   : forall t1 x2
   , wnfX (XLam t1 x2).

Hint Constructors wnfX.

(* A well formed expression is closed under the given environments *)
Fixpoint wfX (ke: kienv) (te: tyenv) (xx: exp) : Prop :=
 match xx with
 | XVar i     => exists t, get i te = Some t
 | XLAM x     => wfX (ke :> KStar) (liftTE 0 te) x
 | XAPP x t   => wfX ke te x  /\ wfT ke t
 | XLam t x   => wfT ke t     /\ wfX ke (te :> t) x
 | XApp x1 x2 => wfX ke te x1 /\ wfX ke te x2
 end.
Hint Unfold wfX.

(* Closed expressions are well formed under empty environments *)
Definition closedX (xx: exp) : Prop
 := wfX nil nil xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further. *)
Inductive value : exp -> Prop :=
 | Value
   :  forall xx
   ,  wnfX xx -> closedX xx
   -> value xx.
Hint Constructors value.

(********************************************************************)
(* Lift type indices in expressions. *)
Fixpoint liftTX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar _     => xx

  (* Increase type depth when moving across type abstractions. *)
  |  XLAM x
  => XLAM (liftTX (S d) x)

  |  XAPP x t
  => XAPP (liftTX d x)  (liftTT d t)

  |  XLam t x
  => XLam (liftTT d t)  (liftTX d x)

  |  XApp x1 x2
  => XApp (liftTX d x1) (liftTX d x2)
 end.

(* Lift value indices in expressions. *)
Fixpoint liftXX (d: nat) (xx: exp) : exp :=
  match xx with
  |  XVar ix
  => if le_gt_dec d ix
      then XVar (S ix)
      else xx

  |  XLAM x
  => XLAM (liftXX d x)

  |  XAPP x t
  => XAPP (liftXX d x) t

  (* Increase value depth when moving across value abstractions. *)
  |  XLam t x
  => XLam t (liftXX (S d) x)

  |  XApp x1 x2
  => XApp (liftXX d x1) (liftXX d x2)
 end.

(********************************************************************)
(* Substitution of types in expressions. *)
Fixpoint substTX (d: nat) (u: ty) (xx: exp) : exp :=
  match xx with
  | XVar _     => xx

  (* Lift free type variables in the type to be substituted
     when we move across type abstractions. *)
  |  XLAM x
  => XLAM (substTX (S d) (liftTT 0 u) x)

  |  XAPP x t
  => XAPP (substTX d u x)  (substTT d u t)

  |  XLam t x
  => XLam (substTT d u t)  (substTX d u x)

  |  XApp x1 x2
  => XApp (substTX d u x1) (substTX d u x2)
 end.

(* Substitution of expressions in expressions. *)
Fixpoint substXX (d: nat) (u: exp) (xx: exp) : exp :=
  match xx with
  | XVar ix
  => match nat_compare ix d with
     | Eq => u
     | Gt => XVar (ix - 1)
     | _  => XVar  ix
     end

  (* Lift free type variables in the expression to be substituted
     when we move across type abstractions. *)
  |  XLAM x
  => XLAM (substXX d (liftTX 0 u) x)

  |  XAPP x t
  => XAPP (substXX d u x) t

  (* Lift free value variables in the expression to be substituted
     when we move across value abstractions. *)
  |  XLam t x
  => XLam t (substXX (S d) (liftXX 0 u) x)

  |  XApp x1 x2
  => XApp (substXX d u x1) (substXX d u x2)
  end.