(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : test for matrix implmented with List List
  author    : ZhengPu Shi
  date      : 2021.05
*)

From FCS Require Export ListList.Matrix.

(** ** Definition of Matrix Type *)

Definition ex_dl1 := [[1;2];[3;4]].
Definition ex_dl1_len : length ex_dl1 = 2. auto. Qed.
Definition ex_dl1_wid : width ex_dl1 2. compute. auto. Qed.

Definition ex_mat1 : @mat nat 2 2 := mk_mat ex_dl1 ex_dl1_len ex_dl1_wid.
Definition ex_mat2 : mat 2 2 := mk_mat ex_dl1 ex_dl1_len ex_dl1_wid.
Definition ex_mat3 : mat 2 2 := {|
  mat_data := ex_dl1;
  mat_height := ex_dl1_len;
  mat_width := ex_dl1_wid
|}.

Compute mat_data ex_mat1.
Compute ex_mat1.(mat_data).

(** ** matrix with specific size *)

(** mat_1_1 *)

Compute mk_mat_1_1 3.

(** mat_1_2 *)

Compute mk_mat_1_2' nat 1 2.

(** mat_0_c *)

Compute mk_mat_0_c 3.

(** mat_1_c *)

Compute mk_mat_1_c [1;2;3] 3 eq_refl.

(** mat_1_2, mat_1_3, ... *)

Compute mk_mat_1_2 5 6.

Compute mk_mat_1_3 5 6 7.

Compute mk_mat_1_4 5 6 7 8.

(** mat_r_0 *)

Compute mk_mat_r_0 3.

(** mat_r_1 *)

Compute mk_mat_r_1 [1;2;3] 3 eq_refl.

(** mat_2_1, mat_3_1, ... *)

Compute mk_mat_2_1 5 6.

Compute mk_mat_3_1 5 6 7.

Compute mk_mat_4_1 5 6 7 8.

(** !Notice, this example might be error, HOW to explainate it?
  the base element could be a list, and list could be any length. *)
Compute mk_mat_4_1 [1;2] [2;3;4] [] [].

(** mat_3_3 *)

Compute mk_mat_3_3 1 2 3 4 5 6 7 8 9.

(** Get Matrix Element *)

Compute mat_nth 0 (mk_mat_3_3 1 2 3 4 5 6 7 8 9) 1 2.

(** TEST code, unfinished *)
Module test_alpha1.

  Require Import Reals.
  Open Scope R_scope.

  Require Import Arith.

  Section Complex.

    Record Complex := mkComplex {
      Re : R;
      Im : R
    }.

  End Complex.

  Section HermitonMatrix.
    Check mat.
    Variable mat_mul : forall {A r c t}, @mat A r c -> @mat A c t -> @mat A r t.
    Variable mat_H : forall {A r c}, @mat A r c -> @mat A r c.

    (* Hermiton Matrix is a matrix with a bit good properties *)
    Record HMat {A r c} := mkHMat {
      hmmat : @mat A r c;
      hmcond : mat_H hmmat = hmmat
    }.

  End HermitonMatrix.

End test_alpha1.

(** ** Matrix map to a dlist *)

Compute matmapdl Nat.succ ex_mat1.

(** ** Matrix map2 to a dlist *)

Compute matmap2dl Nat.add ex_mat1 ex_mat1.

(** ** Matrix map *)

Compute matmap Nat.succ ex_mat1.

(** ** Matrix map2 *)

Compute matmap2 Nat.add ex_mat1 ex_mat1.

(** ** zero matrix and unit matrix *)

Compute matzero 0 3 2.

Compute matunit 0 1 3.

(** ** matrix transpose *)

Compute ex_mat1.
Compute mat_trans ex_mat1.
Compute mat_trans (mk_mat_r_0 5).
Compute mat_trans (mk_mat_0_c 5).

(** ** matrix addition *)

Compute matadd Nat.add ex_mat1 ex_mat1.

(** ** matrix substraction and opposition *)

Compute matopp Nat.succ ex_mat1.
Compute matsub Nat.sub ex_mat1 ex_mat1.

(** ** matrix multiplication *)

Compute matmul 0 Nat.add Nat.mul ex_mat1 ex_mat1.

(** ** Multiplication with a constant and a matrix *)

Compute matcmul Nat.mul 3 ex_mat1.
Compute matmulc Nat.mul ex_mat1 3.


(** * Index.v: defining indexes *)

Require Import Omega.

Definition index := Z.

(*
Definition index_eqb: index -> index -> bool := Z.eqb.

Definition next_index: index -> index := Z.succ.

Definition prev_index: index -> index := Z.pred.

Definition idx_to_Z (i:index) : Z := i.

Definition im : index := (-1)%Z.
Definition ip (i: Z) : index :=  i.

Lemma next_idx_to_Z: forall i,
    (idx_to_Z (next_index i) = (idx_to_Z i) + 1)%Z.
Proof.
  intros. reflexivity.
Qed.
*)


(* Testing eta-expansion of elimination predicate *)

Section NATIND2.
Variable P : nat -> Type.
Variable H0 : P 0.
Variable H1 : P 1.
Variable H2 : forall n : nat, P n -> P (S (S n)).
Fixpoint nat_ind2 (n : nat) : P n :=
  match n as x return (P x) with
  | O => H0
  | S O => H1
  | S (S n) => H2 n (nat_ind2 n)
  end.
End NATIND2.


(*****************************************************************************)
(*                                                                           *)
(*  Vector.v                                                                 *)
(*                                                                           *)
(*  This file defines fixed-length vectors of natural numbers.               *)
(*                                                                           *)
(*  Some definitions and results about vectors are borrowed from a later     *)
(*  version of Coq.                                                          *)
(*                                                                           *)
(*****************************************************************************)

Require Import Vector.
Require Import PeanoNat.

Require Export Vector.

Import Vector.VectorNotations.

Open Scope vector_scope.

(* Notation for 'append' is available in Coq 8.10: *)

Infix "++" := append : vector_scope.

(* The function 'splitat' is available in Coq 8.10: *)

Fixpoint splitat {A} (l : nat) {r : nat} : t A (l + r) -> t A l * t A r :=
  match l with
  | 0 => fun v => ([], v)
  | S l' => fun v =>
    let (v1, v2) := splitat l' (tl v) in
    (hd v::v1, v2)
  end.

(* The Lemma 'splitat_append' is available in Coq 8.10: *)

Lemma splitat_append {A} (l : nat) {r : nat} (b0 : t A l) (b1 : t A r) :
  splitat l (b0 ++ b1) = (b0, b1).
Proof with auto.
  induction b0; simpl...
  rewrite IHb0...
Qed.

(* In the present development, only vectors of natural numbers are needed: *)

Definition NVect := Vector.t nat.

Lemma fst_splitat_append (l : nat) {r : nat} (b0 : NVect l) (b1 : NVect r) :
  fst (splitat l (b0 ++ b1)) = b0.
Proof with auto.
  rewrite splitat_append...
Qed.

Lemma snd_splitat_append (l : nat) {r : nat} (b0 : NVect l) (b1 : NVect r) :
  snd (splitat l (b0 ++ b1)) = b1.
Proof with auto.
  rewrite splitat_append...
Qed.

(* Equality is decidable for 'NVect': *)

Definition nvect_eq_dec := (@VectorEq.eq_dec nat Nat.eqb Nat.eqb_eq).

Close Scope vector_scope.


(*
Parts of this file are copied and modified from the Coq Demos of the lecture Semantics at UdS:
http://www.ps.uni-saarland.de/courses/sem-ws17/confluence.v
 *)

Set Implicit Arguments.
Require Import Morphisms FinFun std.tactics.

Section ClosureRelations.
  Variables (X: Type).
  Implicit Types (R S: X -> X -> Prop) (x y z : X).

  Notation "R <<= S" := (subrelation R S) (at level 70).
  Notation "R === S" := (R <<= S /\ S <<= R) (at level 70).

  Definition functional R :=
    forall x y z, R x y -> R x z -> y = z.

  Inductive star R : X -> X -> Prop :=
  | starRefl x     : star R x x
  | starStep x x' y : R x x' -> star R x' y -> star R x y.

  Inductive multiple R : X -> X -> Prop :=
  | multipleSingle x y: R x y -> multiple R x y
  | multipleStep x x' y: R x x' -> multiple R x' y -> multiple R x y.

  Inductive counted R : nat -> X -> X -> Prop :=
  | countedRefl x: counted R 0 x x
  | countedStep x x' y n: R x x' -> counted R n x' y -> counted R (S n) x y.

  Inductive sym R: X -> X -> Prop :=
  | symId x y: R x y -> sym R x y
  | symInv x y: R y x -> sym R x y.

  Hint Constructors star multiple counted.

  Definition Normal R x := forall y, ~ R x y.
  Definition evaluates R s t := star R s t /\ Normal R t.
  Definition equiv R := star (sym R).

  Fact Normal_star_stops R x:
    Normal R x -> forall y, star R x y -> x = y.
  Proof.
    destruct 2; firstorder.
  Qed.

  Lemma star_trans R x y z :
    star R x y -> star R y z -> star R x z.
  Proof.
    induction 1; eauto.
  Qed.

  Lemma multiple_trans R x y z :
    multiple R x y -> multiple R y z -> multiple R x z.
  Proof.
    induction 1; eauto.
  Qed.

  Fact counted_trans R x y z m n:
    counted R m x y -> counted R n y z -> counted R (m + n) x z.
  Proof.
    induction 1; cbn; eauto.
  Qed.

  Global Instance multiple_transitive R:
    Transitive (multiple R).
  Proof.
    intros ?; eapply multiple_trans.
  Qed.

  Global Instance star_preorder R: PreOrder (star R).
  Proof.
    constructor; hnf; eauto using star_trans.
  Qed.

  Global Instance star_exp R:
    R <<= star R.
  Proof.
    unfold subrelation; eauto.
  Qed.

  Global Instance multiple_exp R:
    R <<= multiple R.
  Proof.
    unfold subrelation; eauto.
  Qed.

  Fact counted_exp R:
    R === counted R 1.
  Proof.
    unfold subrelation; split; eauto.
    intros x y H; inv H; inv H2; eauto.
  Qed.

  Global Instance multiple_star R : multiple R <<= star R.
  Proof.
    induction 1; eauto.
  Qed.

  Lemma multiple_destruct R x y:
    multiple R x y <-> exists2 x', (R x x') & (star R x' y).
  Proof.
    split.
    - induction 1; eauto.
      destruct IHmultiple; eexists; eauto.
    - intros [? H1 H2]; revert x H1; induction H2; eauto.
  Qed.

  Lemma step_star_multiple R x y z:
    R x y -> star R y z -> multiple R x z.
  Proof.
    intros H1 H2; apply multiple_destruct; eauto.
  Qed.

  Lemma multiple_star_step R x y z :
    multiple R x y -> star R y z -> multiple R x z.
  Proof.
    intros [] % multiple_destruct ?. eapply multiple_destruct.
    eexists; eauto using star_trans.
  Qed.

  Hint Resolve star_trans multiple_trans counted_trans star_exp
       multiple_exp counted_exp.

  Global Instance star_mono R S :
    R <<= S -> star R <<= star S.
  Proof.
    intros H x y.
    induction 1; eauto.
  Qed.

  Global Instance multiple_mono R S :
    R <<= S -> multiple R <<= multiple S.
  Proof.
    intros H x y.
    induction 1; eauto.
  Qed.

  Global Instance eval_subrel R:
    (evaluates R) <<= (star R).
  Proof. intros x y []. assumption. Qed.

  Fact star_closure R S :
    PreOrder S -> R <<= S -> star R <<= S.
  Proof.
    intros H1 H2 x y.
    induction 1 as [x|x x' y H4 _ IH].
    - reflexivity.
    - transitivity x'; auto.
  Qed.

  Fact star_idem R :
    star (star R) === star R.
  Proof.
    split.
    - induction 1; eauto.
    - apply star_mono, star_exp.
  Qed.

  Fact multiple_idem R :
    multiple (multiple R) === multiple R.
  Proof.
    split; eauto.
    induction 1; eauto.
  Qed.

  Fact multiple_fixpoint R :
    multiple (star R) === star R.
  Proof.
    split.
    - induction 1; eauto.
    - eauto.
  Qed.

  Fact star_absorbtion R :
    star (multiple R) === star R.
  Proof.
    split.
    - induction 1; eauto.
      apply multiple_destruct in H. destruct H. eauto.
    - eapply star_mono. eauto.
  Qed.

  Lemma sym_symmetric R x y:
    sym R x y -> sym R y x.
  Proof.
    intros []; eauto using sym.
  Qed.

  Global Instance sym_Symmetric R:
    Symmetric (sym R).
  Proof.
    firstorder using sym_symmetric.
  Qed.

  Lemma refl_star R x y:
    x = y -> star R x y.
  Proof.
    intros ->; eauto.
  Qed.

  Lemma refl_equiv R x:
    equiv R x x.
  Proof.
    constructor.
  Qed.

  Lemma equiv_trans R x y z:
    equiv R x y -> equiv R y z -> equiv R x z.
  Proof. eapply star_trans. Qed.

  Lemma equiv_symm R x y:
    equiv R x y -> equiv R y x.
  Proof.
    induction 1.
    constructor; eauto.
    eapply star_trans; eauto.
    econstructor 2; eauto using refl_equiv, sym_symmetric.
  Qed.

  Global Instance equiv_star R:
    star R <<= equiv R.
  Proof.
    induction 1; unfold equiv in *; eauto using sym, star.
  Qed.

  Global Instance equiv_rel R:
    R <<= equiv R.
  Proof.
    transitivity (star R); typeclasses eauto.
  Qed.

  Lemma equiv_expand R x x' y y':
    star R x x' -> star R y y' -> equiv R x' y' -> equiv R x y.
  Proof.
    intros. eapply equiv_trans.
    eapply equiv_star, H. eapply equiv_symm.
    eapply equiv_trans. eapply equiv_star, H0.
    now eapply equiv_symm.
  Qed.

  Lemma equiv_reduce R x x' y y' :
    star R x x' -> star R y y' -> equiv R x y -> equiv R x' y'.
  Proof.
    intros. eapply equiv_trans.
    eapply equiv_symm, equiv_star, H.
    now eapply equiv_trans, equiv_star, H0.
  Qed.

  Lemma eq_equiv R (x y: X):
    x = y -> equiv R x y.
  Proof. intros ->;eapply refl_equiv. Qed.

  Global Instance equiv_equivalence R:
    Equivalence (equiv R).
  Proof.
    constructor; firstorder using refl_equiv, equiv_trans, equiv_symm.
  Qed.

  Lemma equiv_join R x y z:
    star R x z -> star R y z -> equiv R x y.
  Proof.
    intros. transitivity z.
    rewrite H; reflexivity. symmetry.
    rewrite H0; reflexivity.
  Qed.

  (** Right-recursive version of star. *)
  Inductive starL R x:  X -> Prop :=
  | starReflL : starL R x x
  | starStepL  y y':  starL R x y -> R y y' -> starL R x y'.

  Hint Constructors starL.

  Lemma star_starL R x y :
    starL R x y <-> star R x y .
  Proof.
    split.
    - induction 1; auto. induction IHstarL; eauto.
    - induction 1; eauto. clear H0. induction IHstar; eauto.
  Qed.

  Lemma subrel_unfold R S (H: R <<= S) x y: R x y -> S x y.
  Proof. eapply H. Qed.

End ClosureRelations.

Hint Extern 4 => eapply subrel_unfold; [ typeclasses eauto |].

Hint Constructors star multiple counted.
Hint Resolve star_trans multiple_trans counted_trans star_exp
     multiple_exp counted_exp equiv_join.


(*
Group:
Marc Skodborg, 201206073
*)

(* week_35_exercises.v *)
(* dIFP 2014-2015, Q1 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* ********** *)

(*

The learning goals of this first lecture are as follows:

* Install Coq on each student's laptop.

* Preferably use Emacs with Proof General,
  because it scales better than CoqIde
  (tick "3 Windows mode layout" in the Coq top menu;
  use the hybrid mode if your screen is not wide enough).

* Understand the basic idea of stepping forward and backwards through
  a Coq file, either with the arrows "Next" and "Undo" in the tool bar,
  or C-c C-n and C-c C-u on the keyboard.

* Visualize that a proof is a tree, similarly to an abstract-syntax tree
  and a typing-derivation tree.  (About that, it would be a good idea
  to read
    http://users-cs.au.dk/danvy/dProgSprog/Lecture-notes/week-22.html
  again.)  When proving a theorem in Coq, we interactively construct
  its proof tree.

* Make formal statements:

    <formal-statement> ::= <keyword> <identifier> : <logical-formula>
             <keyword> ::= Lemma
                         | Theorem
                         | Corollary
          <identifier> ::= ...
     <logical-formula> ::= forall {<identifier>}+, <logical-expression>
  <logical-expression> ::= <identifier>
                         | <logical-expression> -> <logical-expression>
                         | <logical-expression> /\ <logical-expression>
                         | <logical-expression> \/ <logical-expression>

  where
    "A -> B" is an implication,
    "A /\ B" is a conjunction, and
    "A /\ B" is a disjunction.

* Syntactic sugar: "A <-> B" is the conjunction
    "(A -> B) /\ (B -> A)"

* Prove formal statements:

  <proof-script> ::= Proof.  {<coq-commands>}+  Qed.

  At the end of a proof, either write "Qed." to tell Coq that the
  proof script is complete, or write "Admitted." if you can prove it
  but you believe in your heart that it holds, or write "Abort." if
  you can prove it and you don't want to rely on it later in the file.

* Processing goals:

  When the goal is "forall x : blah1, blah2", write "intro x."
  to move x from your goal to your assumptions.

  When the goal is "A -> B", write "intro H_A."
  to declare the hypothesis about A in your assumptions.

  When the goal is "P" and you have an assumption about it, H_P,
  write "apply H_P.".

  Instead of writing "intro X.  intro Y.  intro Z."
  you can more concisely write "intros X Y Z.".

  Instead of writing "intro H_X.  intro H_Y.  intro H_Z."
  you can more concisely write "intros H_X H_Y H_Z.".

  When the goal is "A /\ B -> C", use Coq's pattern-matching facility
  and write "intros [H_A H_B]."
  to directly name the hypotheses about A and B.

  When the goal is "A \/ B -> C", use Coq's pattern-matching facility
  and write "intros [H_A | H_B]."
  to directly name the hypotheses about A and B.
  (This will create a subgoal.)

  When the goal is a conjunction, write "split.".
  (This will create a subgoal.)

  So in particular, when the goal is an equivalence "A <-> B",
  write "split.".

  When the goal is a disjunction, write "left." or "right."
  depending on which disjunct you want to prove.

* Apply lemmas or theorems that were already proved.

* Load a library of lemmas and theorems:

    Require Import Arith.

* Use an equality lemma to rewrite a formula
  (see comm_a et al. below).

* Use "reflexivity." and "symmetry.".

* Restart a proof.

* Simple convention about indentation:
  the number of indentations (two white spaces) matches the number of subgoals.

* Readability:
  don't hesitate to put empty lines in your proofs,
  to delineate conceptual blocks.

*)

(* ********** *)

(* Exercise 1:
   Prove that conjunction and disjunctions are associative.
*)

Theorem conjunction_is_associative_either_way :
  forall P1 P2 P3 : Prop,
    P1 /\ (P2 /\ P3) <-> (P1 /\ P2) /\ P3.
Proof.
  intros P1 P2 P3.
  split.
    intros [H_P1 [H_P2 H_P3]].
    split.
      split.
        apply H_P1.
      apply H_P2.
    apply H_P3.

    intros [[H_P1 H_P2] H_P3].
    split.
      apply H_P1.
      split.
        apply H_P2.
        apply H_P3.
Qed.

Theorem disjunction_is_associative_either_way :
  forall P1 P2 P3 : Prop,
    P1 \/ (P2 \/ P3) <-> (P1 \/ P2) \/ P3.
Proof.
  intros P1 P2 P3.
  split.
    intros [H_P1 | [H_P2 | H_P3]].
          left. left. apply H_P1.
        left. right. apply H_P2.
      right. apply H_P3.

    intros [[H_P1 | H_P2] | H_P3].
        left. apply H_P1.
      right. left. apply H_P2.
    right. right. apply H_P3.
Qed.

(* ********** *)

(* Exercise 2:
   Prove that conjunction and disjunctions are commutative.
*)

Theorem conjunction_is_commutative_either_way :
  forall P1 P2 : Prop,
    P1 /\ P2 <-> P2 /\ P1.
Proof.
  intros P1 P2.
  split.
    intros [H_P1 H_P2].
    split.
      apply H_P2.
      apply H_P1.

    intros [H_P2 H_P1].
    split.
      apply H_P1.
      apply H_P2.
Qed.

Theorem disjunction_is_commutative_either_way :
  forall P1 P2 : Prop,
    P1 \/ P2 <-> P2 \/ P1.
Proof.
  intros P1 P2.
  split.
    intros [H_P1 | H_P2].
      right. apply H_P1.
      left. apply H_P2.

    intros [H_P2 | H_P1].
      right. apply H_P2.
      left. apply H_P1.
Qed.

(* ********** *)

(* Exercise 3:
   Prove the following lemma, Curry_and_unCurry.
*)

Lemma Curry_and_unCurry :
  forall P Q R : Prop,
    (P /\ Q -> R) <-> P -> Q -> R.
Proof.
  intros P Q R.
  split.
    intro H_P_and_Q_implies_R.
    intros H_P H_Q.
    apply H_P_and_Q_implies_R.
    split.
      apply H_P.
      apply H_Q.

    intro H_P_implies_Q_implies_R.
    intros [H_P H_Q].
    apply H_P_implies_Q_implies_R.
      apply H_P.
      apply H_Q.
Qed.

(* ********** *)

(* Here is how to import a Coq library about arithmetic expressions: *)

Require Import Arith.

Check plus_comm.

(*
plus_comm
     : forall n m : nat, n + m = m + n
*)

Lemma comm_a :
  forall a b c : nat,
    (a + b) + c = c + (b + a).
Proof.
  intros a b c.
  rewrite -> (plus_comm a b).
  rewrite -> (plus_comm (b + a) c).
  reflexivity.

  Restart.

  intros a b c.
  rewrite -> (plus_comm (a + b) c).
  rewrite -> (plus_comm a b).
  reflexivity.

  Restart.

  intros a b c.
  rewrite -> (plus_comm c (b + a)).
  rewrite -> (plus_comm b a).
  reflexivity.

  Restart.

  intros a b c.
  rewrite <- (plus_comm (b + a) c).
  rewrite <- (plus_comm a b).
  reflexivity.

  Restart.

  intros a b c.
  rewrite <- (plus_comm a b).
  rewrite <- (plus_comm (a + b) c).
  reflexivity.

  Restart.

  intros a b c.
  rewrite -> (plus_comm a b).
  rewrite <- (plus_comm (b + a) c).
  reflexivity.

  (*added: *)
  Restart.

  intros a b c.
  rewrite <- (plus_comm b a).
  rewrite -> (plus_comm (b+a) c).
  reflexivity.

  Restart.

  intros a b c.
  rewrite <- (plus_comm a b).
  rewrite -> (plus_comm (a+b) c).
  reflexivity.
Qed.

(* Exercise 4:
   Add a couple more proofs for Lemma comm_a.

   For the over-achievers:
   How many distinct proofs are there for Lemma comm_a?
*)

(* ********** *)

Lemma comm_b :
  forall x y z : nat,
    (x + y) + z = z + (y + x).
Proof.
  intros x y z.
  apply (comm_a x y z).

  Restart.

  apply comm_a.
Qed.

(* ********** *)

(* symmetry *)

Lemma comm_c :
  forall a b c : nat,
    c + (b + a) = (a + b) + c.
Proof.
  intros a b c.
  symmetry.
  apply (comm_a a b c).
Qed.

(* ********** *)

Check plus_assoc.

(*
plus_assoc
     : forall n m p : nat, n + (m + p) = n + m + p
*)

(* Exercise 5, for the over-achievers:
   find a couple of alternative proofs for the following lemma.
*)

Lemma assoc_a :
  forall a b c d : nat,
    a + (b + (c + d)) = ((a + b) + c) + d.
Proof.
  intros a b c d.
  rewrite -> (plus_assoc a b (c + d)).
  rewrite <- (plus_assoc (a + b) c d).
  reflexivity.
Qed.
(* You should replace "Abort." by a proof, if there is one. *)

(* ********** *)

(* Exercise 6:
   Prove the following lemma, mixed_a.
*)

Lemma mixed_a :
forall a b c d : nat,
    (c + (a + b)) + d = (b + (d + c)) + a.
Proof.
  intros a b c d.
  rewrite -> (plus_comm (b+(d+c)) a).
  rewrite -> (plus_comm d c).
  rewrite -> (plus_comm c (a+b)).
  symmetry.
  apply (assoc_a a b c d).
Qed.
(* You should replace "Abort." by a proof, if there is one. *)

(* ********** *)

(* end of week_35_exercises.v *)


From CoqAlgs Require Export Base.
From CoqAlgs Require Export Ord.
From CoqAlgs Require Export Data.EBTree.

Definition Tree (A : Type) : Type := EBTree nat A.

Definition height' {A : Type} (t : Tree A) : nat :=
match t with
    | E => 0
    | N h _ _ _ => h
end.

Definition prebalance {A : Type} (l : Tree A) (v : A) (r : Tree A) : Tree A :=
  N (1 + max (height l) (height r)) l v r.

Function rotateLR {A : Type} (t : Tree A) : Tree A :=
match t with
    | N _ (N _ a y b) x c => prebalance a y (prebalance b x c)
    | _ => t
end.

Function rotateRL {A : Type} (t : Tree A) : Tree A :=
match t with
    | N _ a x (N _ b y c) => prebalance (prebalance a x b) y c
    | _ => t
end.

Function balance {A : Type} (l : Tree A) (v : A) (r : Tree A) : Tree A :=
match height l <?> height r with
    | Lt =>
        match r with
            | N _ a x b => prebalance (prebalance l v a) x b
            | _ => prebalance l v r
        end
    | Eq => prebalance l v r
    | Gt =>
        match l with
            | N _ a x b => prebalance a x (prebalance b v r)
            | _ => prebalance l v r
        end
end.

Function insert {A : Type} (leb : A -> A -> bool) (x : A) (t : Tree A) : Tree A :=
match t with
    | E => N 1 E x E
    | N _ l v r =>
        if leb x v
        then balance (insert leb x l) v r
        else balance l v (insert leb x r)
end.

Fixpoint fromList {A : Type} (leb : A -> A -> bool) (l : list A) : Tree A :=
match l with
    | [] => E
    | h :: t => insert leb h (fromList leb t)
end.

Lemma height_prebalance :
  forall (A : Type) (v : A) (l r : Tree A),
    height (prebalance l v r) = 1 + max (height l) (height r).
Proof.
  cbn. reflexivity.
Qed.

(* TODO: height_rotate *)

Lemma height_balance :
  forall (A : Type) (v : A) (l r : Tree A),
    height (balance l v r) <= 1 + max (height l) (height r).
Proof.
  intros. functional induction balance l v r; trich; cbn in *.
    destruct (height b).
      rewrite (@cmp_spec1 natlt) in e. cbn in e. lia.
      rewrite (@cmp_spec1 natlt) in e. cbn in e. lia.
    destruct (height r).
      rewrite (@cmp_spec1 natlt) in e. cbn in e. lia.
      rewrite (@cmp_spec1 natlt) in e. cbn in e. lia.
Qed.

Lemma height_insert :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (t : Tree A),
    height (insert leb x t) <= 1 + height t.
Proof.
  intros.
  functional induction insert leb x t;
  cbn; rewrite ?height_balance; lia.
Qed.

(** Properties of [balance]. *)

(* Lemma Elem_balance :
  forall {A : Type} (c : color) (x v : A) (l r : RBTree A),
    Elem x (N c l v r) <-> Elem x (balance c l v r).
Proof.
  split;
  functional induction balance c l v r;
  auto; intros; Elem'.
Qed.
 *)

Lemma All_balance :
  forall {A : Type} (P : A -> Prop) (v : A) (l r : Tree A),
    All P (balance l v r) <-> All P l /\ P v /\ All P r.
Proof.
  intros.
  functional induction balance l v r;
  unfold prebalance;
  firstorder All'.
Qed.

Lemma isBST2_balance :
  forall (A : Ord) (h : nat) (v : A) (l r : Tree A),
    isBST2 (N h l v r) -> isBST2 (balance l v r).
Proof.
  intros.
  functional induction balance l v r;
  isBST2'; unfold prebalance; clear e.
    induction H4; isBST2'. trich.
    induction H5; isBST2'. trich.
Qed.

(** Properties of [insert]. *)

Lemma All_insert :
  forall {A : Type} (P : A -> Prop) (leb : A -> A -> bool) (x : A) (t : Tree A),
    All P (insert leb x t) <-> P x /\ All P t.
Proof.
  intros until t.
  functional induction insert leb x t;
  rewrite ?All_balance, ?IHt0;
  firstorder All'.
Qed.

Lemma isBST2_insert :
  forall {A : Ord} (x : A) (t : Tree A),
    isBST2 t -> isBST2 (insert trich_leb x t).
Proof.
  intros until t.
  functional induction insert trich_leb x t;
  isBST2'.
    apply isBST2_balance with 0. isBST2'. apply All_insert. split; trich.
    apply isBST2_balance with 0. isBST2'. apply All_insert. split; trich.
Qed.

(** Properties of [fromList]. *)

Lemma isBST2_fromList :
  forall (A : Ord) (l : list A),
    isBST2 (fromList trich_leb l).
Proof.
  induction l as [| h t]; cbn.
    constructor.
    apply isBST2_insert. assumption.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import ZArith Znumtheory.

Open Scope Z_scope.

(** * Euclid gcd algorithm *)

(** This was previously part of Coq standard library (in Znumtheory).
   But the new binary algorithm used there is much faster and also easier
   to prove correct (for the variant that is executable in coq).
*)

(** In this first variant, we use an explicit measure in [nat], and we
  prove later that using [2(d+1)] is enough, where [d] is the number of
  binary digits of the first argument. *)

Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b =>
 match n with
  | O => 1 (* arbitrary, since n should be big enough *)
  | S n => match a with
     | Z0 => Zabs b
     | Zpos _ => Zgcdn n (Zmod b a) a
     | Zneg a => Zgcdn n (Zmod b (Zpos a)) (Zpos a)
     end
   end.

(* For technical reason, we don't use [Ndigit.Psize] but this
   ad-hoc version: [Psize p = S (Psiz p)]. *)

Fixpoint Psiz (p:positive) : nat :=
  match p with
    | xH => O
    | xI p => S (Psiz p)
    | xO p => S (Psiz p)
  end.

Definition Zgcd_bound (a:Z) := match a with
 | Z0 => S O
 | Zpos p => let n := Psiz p in S (S (n+n))
 | Zneg p => let n := Psiz p in S (S (n+n))
end.

Definition Zgcd a b := Zgcdn (Zgcd_bound a) a b.

(** A first obvious fact : [Zgcd a b] is positive. *)

Lemma Zgcdn_is_pos : forall n a b,
  0 <= Zgcdn n a b.
Proof.
induction n.
simpl; auto with zarith.
destruct a; simpl; intros; auto with zarith; auto.
Qed.

Lemma Zgcd_is_pos : forall a b, 0 <= Zgcd a b.
Proof.
intros; unfold Zgcd; apply Zgcdn_is_pos; auto.
Qed.

(** We now prove that Zgcd is indeed a gcd. *)

Lemma Zis_gcd_0_abs : forall b,
 Zis_gcd 0 b (Zabs b) /\ Zabs b >= 0 /\ 0 = Zabs b * 0 /\ b = Zabs b * Zsgn b.
Proof.
intro b.
elim (Z_le_lt_eq_dec _ _ (Zabs_pos b)).
intros H0; split.
apply Zabs_ind.
intros; apply Zis_gcd_sym; apply Zis_gcd_0; auto.
intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto.
repeat split; auto with zarith.
symmetry; apply Zabs_Zsgn.

intros H0; rewrite <- H0.
rewrite <- (Zabs_Zsgn b); rewrite <- H0; simpl in |- *.
split; [ apply Zis_gcd_0 | idtac ]; auto with zarith.
Qed.

(** 1) We prove a weaker & easier bound. *)

Lemma Zgcdn_linear_bound : forall n a b,
 Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b).
Proof.
induction n.
simpl; intros.
elimtype False; generalize (Zabs_pos a); omega.
destruct a; intros; simpl;
 [ generalize (Zis_gcd_0_abs b); intuition | | ];
 unfold Zmod;
 generalize (Z_div_mod b (Zpos p) (refl_equal Gt));
 destruct (Zdiv_eucl b (Zpos p)) as (q,r);
 intros (H0,H1);
 rewrite inj_S in H; simpl Zabs in H;
 assert (H2: Zabs r < Z_of_nat n) by (rewrite Zabs_eq; auto with zarith);
 assert (IH:=IHn r (Zpos p) H2); clear IHn;
 simpl in IH |- *;
 rewrite H0.
 apply Zis_gcd_for_euclid2; auto.
 apply Zis_gcd_minus; apply Zis_gcd_sym.
 apply Zis_gcd_for_euclid2; auto.
Qed.

(** 2) For Euclid's algorithm, the worst-case situation corresponds
     to Fibonacci numbers. Let's define them: *)

Fixpoint fibonacci (n:nat) : Z :=
 match n with
   | O => 1
   | S O => 1
   | S (S n as p) => fibonacci p + fibonacci n
 end.

Lemma fibonacci_pos : forall n, 0 <= fibonacci n.
Proof.
cut (forall N n, (n<N)%nat -> 0<=fibonacci n).
eauto.
induction N.
inversion 1.
intros.
destruct n.
simpl; auto with zarith.
destruct n.
simpl; auto with zarith.
change (0 <= fibonacci (S n) + fibonacci n).
generalize (IHN n) (IHN (S n)); omega.
Qed.

Lemma fibonacci_incr :
 forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m.
Proof.
induction 1.
auto with zarith.
apply Zle_trans with (fibonacci m); auto.
clear.
destruct m.
simpl; auto with zarith.
change (fibonacci (S m) <= fibonacci (S m)+fibonacci m).
generalize (fibonacci_pos m); omega.
Qed.

(** 3) We prove that fibonacci numbers are indeed worst-case:
   for a given number [n], if we reach a conclusion about [gcd(a,b)] in
   exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *)

Lemma Zgcdn_worst_is_fibonacci : forall n a b,
 0 < a < b ->
 Zis_gcd a b (Zgcdn (S n) a b) ->
 Zgcdn n a b <> Zgcdn (S n) a b ->
 fibonacci (S n) <= a /\
 fibonacci (S (S n)) <= b.
Proof.
induction n.
simpl; intros.
destruct a; omega.
intros.
destruct a; [simpl in *; omega| | destruct H; discriminate].
revert H1; revert H0.
set (m:=S n) in *; (assert (m=S n) by auto); clearbody m.
pattern m at 2; rewrite H0.
simpl Zgcdn.
unfold Zmod; generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
destruct (Zdiv_eucl b (Zpos p)) as (q,r).
intros (H1,H2).
destruct H2.
destruct (Zle_lt_or_eq _ _ H2).
generalize (IHn _ _ (conj H4 H3)).
intros H5 H6 H7.
replace (fibonacci (S (S m))) with (fibonacci (S m) + fibonacci m) by auto.
assert (r = Zpos p * (-q) + b) by (rewrite H1; ring).
destruct H5; auto.
pattern r at 1; rewrite H8.
apply Zis_gcd_sym.
apply Zis_gcd_for_euclid2; auto.
apply Zis_gcd_sym; auto.
split; auto.
rewrite H1.
apply Zplus_le_compat; auto.
apply Zle_trans with (Zpos p * 1); auto.
ring (Zpos p * 1); auto.
apply Zmult_le_compat_l.
destruct q.
omega.
assert (0 < Zpos p0) by (compute; auto).
omega.
assert (Zpos p * Zneg p0 < 0) by (compute; auto).
omega.
compute; intros; discriminate.
(* r=0 *)
subst r.
simpl; rewrite H0.
intros.
simpl in H4.
simpl in H5.
destruct n.
simpl in H5.
simpl.
omega.
simpl in H5.
elim H5; auto.
Qed.

(** 3b) We reformulate the previous result in a more positive way. *)

Lemma Zgcdn_ok_before_fibonacci : forall n a b,
 0 < a < b -> a < fibonacci (S n) ->
 Zis_gcd a b (Zgcdn n a b).
Proof.
destruct a; [ destruct 1; elimtype False; omega | | destruct 1; discriminate].
cut (forall k n b,
         k = (S (nat_of_P p) - n)%nat ->
         0 < Zpos p < b -> Zpos p < fibonacci (S n) ->
         Zis_gcd (Zpos p) b (Zgcdn n (Zpos p) b)).
destruct 2; eauto.
clear n; induction k.
intros.
assert (nat_of_P p < n)%nat by omega.
apply Zgcdn_linear_bound.
simpl.
generalize (inj_le _ _ H2).
rewrite inj_S.
rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto.
omega.
intros.
generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros.
assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)).
 apply IHk; auto.
 omega.
 replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto.
 generalize (fibonacci_pos n); omega.
replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto.
generalize (H2 H3); clear H2 H3; omega.
Qed.

(** 4) The proposed bound leads to a fibonacci number that is big enough. *)

Lemma Zgcd_bound_fibonacci :
  forall a, 0 < a -> a < fibonacci (Zgcd_bound a).
Proof.
destruct a; [omega| | intro H; discriminate].
intros _.
induction p.
simpl Zgcd_bound in *.
rewrite Zpos_xI.
rewrite plus_comm; simpl plus.
set (n:=S (Psiz p+Psiz p)) in *.
change (2*Zpos p+1 <
 fibonacci (S n) + fibonacci n + fibonacci (S n)).
generalize (fibonacci_pos n).
omega.
simpl Zgcd_bound in *.
rewrite Zpos_xO.
rewrite plus_comm; simpl plus.
set (n:= S (Psiz p +Psiz p)) in *.
change (2*Zpos p <
 fibonacci (S n) + fibonacci n + fibonacci (S n)).
generalize (fibonacci_pos n).
omega.
simpl; auto with zarith.
Qed.

(* 5) the end: we glue everything together and take care of
   situations not corresponding to [0<a<b]. *)

Lemma Zgcd_is_gcd :
  forall a b, Zis_gcd a b (Zgcd a b).
Proof.
unfold Zgcd; destruct a; intros.
simpl; generalize (Zis_gcd_0_abs b); intuition.
(*Zpos*)
generalize (Zgcd_bound_fibonacci (Zpos p)).
simpl Zgcd_bound.
set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n.
simpl Zgcdn.
unfold Zmod.
generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
destruct (Zdiv_eucl b (Zpos p)) as (q,r).
intros (H1,H2) H3.
rewrite H1.
apply Zis_gcd_for_euclid2.
destruct H2.
destruct (Zle_lt_or_eq _ _ H0).
apply Zgcdn_ok_before_fibonacci; auto; omega.
subst r n; simpl.
apply Zis_gcd_sym; apply Zis_gcd_0.
(*Zneg*)
generalize (Zgcd_bound_fibonacci (Zpos p)).
simpl Zgcd_bound.
set (n:=S (Psiz p+Psiz p)); (assert (n=S (Psiz p+Psiz p)) by auto); clearbody n.
simpl Zgcdn.
unfold Zmod.
generalize (Z_div_mod b (Zpos p) (refl_equal Gt)).
destruct (Zdiv_eucl b (Zpos p)) as (q,r).
intros (H1,H2) H3.
rewrite H1.
apply Zis_gcd_minus.
apply Zis_gcd_sym.
apply Zis_gcd_for_euclid2.
destruct H2.
destruct (Zle_lt_or_eq _ _ H0).
apply Zgcdn_ok_before_fibonacci; auto; omega.
subst r n; simpl.
apply Zis_gcd_sym; apply Zis_gcd_0.
Qed.

(** A generalized gcd: it additionnally keeps track of the divisors. *)

Fixpoint Zggcdn (n:nat) : Z -> Z -> (Z*(Z*Z)) := fun a b =>
 match n with
  | O => (1,(a,b))   (*(Zabs b,(0,Zsgn b))*)
  | S n => match a with
     | Z0 => (Zabs b,(0,Zsgn b))
     | Zpos _ =>
               let (q,r) := Zdiv_eucl b a in   (* b = q*a+r *)
               let (g,p) := Zggcdn n r a in
               let (rr,aa) := p in        (* r = g *rr /\ a = g * aa *)
               (g,(aa,q*aa+rr))
     | Zneg a =>
               let (q,r) := Zdiv_eucl b (Zpos a) in  (* b = q*(-a)+r *)
               let (g,p) := Zggcdn n r (Zpos a) in
               let (rr,aa) := p in         (* r = g*rr /\ (-a) = g * aa *)
               (g,(-aa,q*aa+rr))
     end
   end.

Definition Zggcd a b : Z * (Z * Z) := Zggcdn (Zgcd_bound a) a b.

(** The first component of [Zggcd] is [Zgcd] *)

Lemma Zggcdn_gcdn : forall n a b,
 fst (Zggcdn n a b) = Zgcdn n a b.
Proof.
induction n; simpl; auto.
destruct a; unfold Zmod; simpl; intros; auto;
 destruct (Zdiv_eucl b (Zpos p)) as (q,r);
 rewrite <- IHn;
 destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)); simpl; auto.
Qed.

Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b.
Proof.
intros; unfold Zggcd, Zgcd; apply Zggcdn_gcdn; auto.
Qed.

(** [Zggcd] always returns divisors that are coherent with its
 first output. *)

Lemma Zggcdn_correct_divisors : forall n a b,
  let (g,p) := Zggcdn n a b in
  let (aa,bb):=p in
  a=g*aa /\ b=g*bb.
Proof.
induction n.
simpl.
split; [destruct a|destruct b]; auto.
intros.
simpl.
destruct a.
rewrite Zmult_comm; simpl.
split; auto.
symmetry; apply Zabs_Zsgn.
generalize (Z_div_mod b (Zpos p));
destruct (Zdiv_eucl b (Zpos p)) as (q,r).
generalize (IHn r (Zpos p));
destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)).
intuition.
destruct H0.
compute; auto.
rewrite H; rewrite H1; rewrite H2; ring.
generalize (Z_div_mod b (Zpos p));
destruct (Zdiv_eucl b (Zpos p)) as (q,r).
destruct 1.
compute; auto.
generalize (IHn r (Zpos p));
destruct (Zggcdn n r (Zpos p)) as (g,(rr,aa)).
intuition.
destruct H0.
replace (Zneg p) with (-Zpos p) by compute; auto.
rewrite H4; ring.
rewrite H; rewrite H4; rewrite H0; ring.
Qed.

Lemma Zggcd_correct_divisors : forall a b,
  let (g,p) := Zggcd a b in
  let (aa,bb):=p in
  a=g*aa /\ b=g*bb.
Proof.
unfold Zggcd; intros; apply Zggcdn_correct_divisors; auto.
Qed.

(** Due to the use of an explicit measure, the extraction of [Zgcd]
  isn't optimal. We propose here another version [Zgcd_spec] that
  doesn't suffer from this problem (but doesn't compute in Coq). *)

Definition Zgcd_spec_pos :
  forall a:Z,
    0 <= a -> forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}.
Proof.
intros a Ha.
apply
 (Zlt_0_rec
    (fun a:Z => forall b:Z, {g : Z | 0 <= a -> Zis_gcd a b g /\ g >= 0}));
 try assumption.
intro x; case x.
intros _ _ b; exists (Zabs b).
generalize (Zis_gcd_0_abs b); intuition.

intros p Hrec _ b.
generalize (Z_div_mod b (Zpos p)).
case (Zdiv_eucl b (Zpos p)); intros q r Hqr.
elim Hqr; clear Hqr; intros; auto with zarith.
elim (Hrec r H0 (Zpos p)); intros g Hgkl.
inversion_clear H0.
elim (Hgkl H1); clear Hgkl; intros H3 H4.
exists g; intros.
split; auto.
rewrite H.
apply Zis_gcd_for_euclid2; auto.

intros p _ H b.
elim H; auto.
Defined.

Definition Zgcd_spec : forall a b:Z, {g : Z | Zis_gcd a b g /\ g >= 0}.
Proof.
intros a; case (Z_gt_le_dec 0 a).
intros; assert (0 <= - a).
omega.
elim (Zgcd_spec_pos (- a) H b); intros g Hgkl.
exists g.
intuition.
intros Ha b; elim (Zgcd_spec_pos a Ha b); intros g; exists g; intuition.
Defined.

(** A last version aimed at extraction that also returns the divisors. *)

Definition Zggcd_spec_pos :
  forall a:Z,
    0 <= a -> forall b:Z, {p : Z*(Z*Z) | let (g,p):=p in let (aa,bb):=p in
                                       0 <= a -> Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}.
Proof.
intros a Ha.
pattern a; apply Zlt_0_rec; try assumption.
intro x; case x.
intros _ _ b; exists (Zabs b,(0,Zsgn b)).
intros _; apply Zis_gcd_0_abs.

intros p Hrec _ b.
generalize (Z_div_mod b (Zpos p)).
case (Zdiv_eucl b (Zpos p)); intros q r Hqr.
elim Hqr; clear Hqr; intros; auto with zarith.
destruct (Hrec r H0 (Zpos p)) as ((g,(rr,pp)),Hgkl).
destruct H0.
destruct (Hgkl H0) as (H3,(H4,(H5,H6))).
exists (g,(pp,pp*q+rr)); intros.
split; auto.
rewrite H.
apply Zis_gcd_for_euclid2; auto.
repeat split; auto.
rewrite H; rewrite H6; rewrite H5; ring.

intros p _ H b.
elim H; auto.
Defined.

Definition Zggcd_spec :
 forall a b:Z, {p : Z*(Z*Z) |  let (g,p):=p in let (aa,bb):=p in
                                          Zis_gcd a b g /\ g >= 0 /\ a=g*aa /\ b=g*bb}.
Proof.
intros a; case (Z_gt_le_dec 0 a).
intros; assert (0 <= - a).
omega.
destruct (Zggcd_spec_pos (- a) H b) as ((g,(aa,bb)),Hgkl).
exists (g,(-aa,bb)).
intuition.
rewrite <- Zopp_mult_distr_r.
rewrite <- H2; auto with zarith.
intros Ha b; elim (Zggcd_spec_pos a Ha b); intros p; exists p.
 repeat destruct p; intuition.
Defined.


Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Fixpoint All T P (l : seq T) :=
  match l with
    | nil => True
    | a :: l' => [/\ P a & All P l']
  end.

Fixpoint All2 T (P : T -> T -> Prop) (l : seq T) :=
  if l is [:: a & l'] then [/\ All (P a) l' & All2 P l']
  else True.

Lemma All2_cons T P (a : T) (l : seq T) :
  All2 P [:: a & l] <-> [/\ All (P a) l & All2 P l].
Proof. by split=> /= => [][]A B; split. Qed.

Lemma All_sub T (P P' : T -> Prop) l :
  All P l -> (forall a, P a -> P' a) -> All P' l.
Proof.
move=> A B; move: A; elim: l=> // a' l' IH /= []C D; split.
by apply: (B _ C).
by apply: IH.
Qed.

Lemma All2_sub T (P P' : T -> T -> Prop) l :
  All2 P l -> (forall a a', P a a' -> P' a a') -> All2 P' l.
Proof.
move=> A B; move: A; elim: l=> // a l' IH /= []C D; split.
by apply: (All_sub C); apply: B.
by apply: (IH D).
Qed.

Lemma All2C T (P : T -> T -> Prop) a b l :
  All2 P (a :: b :: l) ->
  (forall a b, P a b -> P b a) ->
  All2 P (b :: a :: l).
Proof.
move=> /= => [][][]A B []C D HC; split=> //.
by split=> //; apply: (HC _ _ A).
Qed.

Lemma All_comp T U (P : T -> Prop) (f : U -> T) l :
  All (P \o f) l <-> All P (map f l).
Proof.
elim: l=> // a' l' IH; split.
by move=> /= []A B; split=> //; rewrite -IH.
by move=> /= []A B; split=> //; rewrite IH.
Qed.

Lemma All_comp2 T U (P : T -> Prop) (f : U -> T) l :
  (All P \o map f) l <-> All P (map f l).
Proof. by []. Qed.

Lemma All_comp3 T U (P : T -> Prop) (f : U -> T) l :
  All (fun a => P (f a)) l <-> All P (map f l).
Proof.
elim: l=> // a' l' IH; split=> //= [][]A B; split=> //.
by rewrite -IH.
by rewrite IH.
Qed.

Lemma All2_comp T U (P : T -> T -> Prop) (f : U -> T) l :
  All2 (fun a b => P (f a) (f b)) l <-> (All2 P \o map f) l.
Proof.
elim: l=> // a l' IH; split.
move=> /= []A B; split; first by rewrite -All_comp.
by case: IH; move/(_ B)=> C _; apply: C.
move=> /= []A B; split; first by rewrite All_comp.
by case: IH=> _; move/(_ B).
Qed.

Lemma All2_comp2 T U (P : T -> T -> Prop) (f : U -> T) l :
  (All2 P \o map f) l <-> All2 P (map f l).
Proof. by []. Qed.

Lemma All2_comp3 T U (P : T -> T -> Prop) (f : U -> T) l :
  All2 (fun a b => P (f a) (f b)) l <->
  All2 P (map f l).
Proof. by rewrite All2_comp All2_comp2. Qed.


Require Import List PeanoNat Omega Bool FinSets AutomataTactics.

Import ListNotations.

Section Strings.

Context {A : Type} `{EqA : DecEq A}.

Definition prefix (pre : list A) (x : list A) :=
  { suf : list A | pre ++ suf = x }.

Definition suffix (suf : list A) (x : list A) :=
  { pre : list A | pre ++ suf = x }.

Definition substring (sub : list A) (x : list A) :=
  { pair : list A * list A | let (pre,suf) := pair in pre ++ sub ++ suf = x }.

Fixpoint count (a : A) (s : list A) : nat :=
  match s with
  | []      => 0
  | x :: xs => if x =? a then 1 + count a xs else count a xs
  end.

Lemma count_concat :
  forall (a b : list A) (x : A),
    count x (a ++ b) = count x a + count x b.
Proof.
autoinduction a with (induction (deq a x)).
Qed.

Hint Rewrite count_concat : standard.

Lemma count_reverse :
  forall (s : list A) (x : A), count x s = count x (rev s).
Proof.
autoinduction s with (rewrite IHs; simpl; induction (deq a x)).
Qed.

Hint Rewrite count_reverse : standard.

Lemma empty_always_prefix : forall (str : list A), prefix [] str.
Proof.
intros.
quick (exists str).
Qed.

Lemma whole_string_is_prefix : forall (str : list A), prefix str str.
Proof.
quick (exists []).
Qed.

Lemma empty_always_suffix : forall (str : list A), suffix [] str.
Proof.
intros.
quick (exists str).
Qed.

Lemma whole_string_is_suffix : forall (str : list A), suffix str str.
Proof.
quick (exists []).
Qed.

Lemma empty_always_substring : forall (str : list A), substring [] str.
Proof.
intros.
quick (exists ([], str)).
Qed.

Lemma whole_string_is_substring : forall (str : list A), substring str str.
Proof.
quick (exists ([],[])).
Qed.

End Strings.


Require Import Classical.
Require Import FunctionalExtensionality.
Require Import IndefiniteDescription.
Require Import PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import  Wf_nat.
Require Import WfInf.
Require Import Lia.

Definition Seq{A:Type} := nat -> A.

Definition sin{A : Type}(a : A)(q: Seq(A:=A)) := exists i, a = q i.

Lemma sin_nth{A:Type}(q: Seq(A:=A)): forall n,  sin (q n) q.
Proof.
intro n.
now exists n.
Qed.

Definition increasing {A: Type} (R: A -> A -> Prop)(q : Seq) : Prop  :=
  forall n,  R (q n) (q (S n)).

Definition strictly_increasing{A : Type}(R: A -> A -> Prop)(q : Seq(A := A)) :=
  increasing R q /\
  forall n,  (q (S n)) <> (q n).

Definition stabilizing_to{A : Type}(q : Seq(A := A)) (a:A) :=
  exists n, forall m, n <= m -> q m = a.

Definition stabilizing{A : Type}(q : Seq(A := A)) :=
  exists a, stabilizing_to q a.

Definition ascending {A: Type} (R: A -> A -> Prop)(q : Seq) : Prop  :=
 increasing R q /\ ~stabilizing q.

Definition subsequence {A : Type}(q1 q2 : Seq(A := A)): Prop :=
  exists (f : Seq(A:=nat)),  strictly_increasing le f /\
                             forall n,  q1 n= q2 (f n).

Definition sup{A: Type} (R : A -> A-> Prop) (sup_val: A) (q : Seq(A:=A)) :=
  (forall a, sin a q -> R a sup_val) /\
  (forall sup_val',  (forall a, sin a q -> R a sup_val')  -> R sup_val sup_val').

Lemma increasing_alt{A:Type}(R: A -> A -> Prop)(R_refl : forall a,  R a a)
(R_trans : forall a b c,  R a b -> R b c ->  R a c)
(R_antisym : forall a b,  R a b -> R b a -> a = b)
  : forall (q: Seq (A := A)),
    increasing R q  <-> forall (i j : nat),  i <= j -> R (q i) (q j).
Proof.
split.
{
  intros Hr i j Hle.
  induction Hle.
  *
    apply R_refl.
  *
    specialize (Hr m).
    eapply R_trans  ; eauto.
}
{
  intros Hall.
  intro n.
  apply Hall; auto.
}
Qed.

Definition constant{A:Type}(q: Seq(A := A)) := exists(a:A), forall n, q n = a.

Section NatSequences.

Fixpoint star(f: Seq(A:= nat))(n : nat):=
  match n with
    0 => f 0
    | S m =>   max (f n) (f (star f m))
  end.

Lemma strictly_increasing_alt : forall f,
    strictly_increasing le f <-> (forall n m, n < m -> f n < f m).
Proof.
split.
{
  intros Hs n m Hlt.
  induction Hlt.
  {
    destruct Hs as (Hi & Hall).
    specialize (Hi n).
    specialize (Hall n).
    lia.
  }
  {
    destruct Nat.lt_strorder as (_ & Hllt).
    eapply Hllt; eauto.
    destruct Hs as (Hi & Hall).
    specialize (Hi m).
    specialize (Hall m).
    lia.
  }
}
{
  intros Hall.
  split.
  *
    intros n.
    specialize (Hall n  _ (Nat.lt_succ_diag_r n)).
    lia.
  *
    intros n.
    specialize (Hall n  _ (Nat.lt_succ_diag_r n)).
    lia.
}
Qed.

Definition above_diagonal (f: Seq(A:= nat)) := forall n,  n <= f n.

Lemma stringly_increasing_above_diag : forall (f :Seq(A:= nat)),
    strictly_increasing le f-> above_diagonal f.
Proof.
intros f Hs n.
destruct Hs as (Hi & Hn).
unfold increasing in Hi.
assert(Hlt : forall n,  f n < f (S n)).
{
  intros m; specialize (Hi m); specialize (Hn m); lia.
}
clear Hi Hn.
induction n; try lia.
specialize (Hlt n);  lia.
Qed.

Definition strictly_above_diagonal (f: Seq(A:= nat)) := forall n,  n < f n.

Lemma star_strictly_increasing : forall f,  strictly_above_diagonal f ->
                             strictly_increasing le (star f).
Proof.
intros f Hf.
rewrite strictly_increasing_alt.
intros  i j Hle.
induction Hle.
*
  cbn.
  eapply Nat.le_trans with (m := f (star f i)); try lia.
  apply Hf.
*
  cbn.
  eapply Nat.le_trans; eauto.
  specialize (Hf (star f m)); lia.
Qed.

Lemma strictly_increasing_unbounded: forall f,  strictly_increasing le f ->
                                                forall N,  exists n, N <= f n.
Proof.
intros f.
induction N.
*
  exists 0; lia.
*
  destruct IHN as (n & Hle).
  exists (S n).
  rewrite strictly_increasing_alt in H.
  apply Nat.le_trans with (m := S (f n)); try lia.
  apply H; lia.
Qed.

End NatSequences.

Section OrderedSequences.

Variable A  : Type.
Variable R : A -> A -> Prop.
Hypothesis R_refl : forall a,  R a a.
Hypothesis R_trans : forall a b c,  R a b -> R b c ->  R a c.
Hypothesis R_antisym : forall a b,  R a b -> R b a -> a = b.

Lemma constant_intervals :
  forall (q : Seq(A:=A)) i j,  increasing R q ->  i <= j -> q j = q i ->
    forall  k, i <= k -> k <= j -> q k = q i.
Proof.
intros q i j Hi Hle Heq k Hlei Hlej.
apply R_antisym.
*
  rewrite <- Heq.
  rewrite increasing_alt in Hi; eauto.
*
  rewrite  increasing_alt in Hi; eauto.
Qed.

Lemma subsequence_increasing : forall (q' q :Seq(A := A)),
    increasing R q -> subsequence q' q -> increasing R q'.
Proof.
intros q' q Hi Hs.
destruct Hs as (f & Hf & Hall).
rewrite increasing_alt; auto.
intros i j Hle.
repeat rewrite Hall.
rewrite increasing_alt in Hi; auto.
apply Hi.
destruct Hf as (Hfi & _).
rewrite increasing_alt in Hfi; [apply Hfi ; auto | apply Nat.le_refl | apply Nat.le_trans | apply Nat.le_antisymm].
Qed.

Lemma ascending_subsequence : forall q  : Seq(A :=A),
    ascending R q -> exists q',  subsequence q' q /\ strictly_increasing R q'.
Proof.
intros q Ha.
destruct Ha as (Hi & Hns).
assert (Hex : forall n,  exists m,  n <= m /\  q m <>  q n).
{
  intro n.
  unfold stabilizing in Hns.
  generalize (not_ex_all_not _ _ Hns); intro Hns'.
  unfold stabilizing_to in Hns'.
  specialize (Hns' (q n)).
  clear Hns.
  generalize (not_ex_all_not _ _ Hns'); intro Hns.
  specialize (Hns n).
  clear Hns'.
  apply  not_all_ex_not in Hns.
  destruct Hns as (m & Hnim).
  apply imply_to_and in Hnim.
  now exists m.
}
apply functional_choice in Hex.
clear Hns.
destruct Hex as (f & Hall).
exists (fun n => q (star f n)).
split.
*
  exists (star f); split; intros ; auto.
  apply star_strictly_increasing.
  intros n.
  destruct (Hall n) as (Ha1 & Ha2).
  case (Nat.eq_dec n (f n)); intros; subst; try lia.
  exfalso.
  apply Ha2.
    now rewrite <- e.
*
  split.
  +
    intros n.
    cbn.
    apply (increasing_alt R); auto.
    eapply Nat.le_trans with (m := f (star f n)); try lia.
    destruct (Hall (star f n)) as (Ha1 & _ ); auto.
  +
    intro n.
    destruct (Hall (star f n)) as (Ha1 & Ha2 ).
    intro Heq.
    apply Ha2; clear Ha2.
    assert (Hle : (star f n <= star f (S n))); cbn; try lia.
    apply (constant_intervals _ _ _ Hi Hle Heq); auto; cbn; lia.
Qed.

Lemma subsequence_ascending : forall q' q : Seq(A :=A),
    increasing R q -> subsequence q' q ->
    strictly_increasing R q' -> ascending R q.
Proof.
intros q' q Hi Hs Hsi.
split ; auto.
intros (a & n & Hst).
destruct Hsi as (Hi' & Hnq).
destruct Hs as (f & Hf1 & Hf2).
destruct (strictly_increasing_unbounded _ Hf1 n) as (m & Hle).
generalize (Hst _ Hle); intro Heq.
rewrite <- Hf2 in Heq.
apply (Hnq m).
rewrite Heq.
rewrite Hf2.
apply Hst.
apply Nat.le_trans with (m := f m); auto.
destruct Hf1 as (Hni & _).
apply Hni.
Qed.

Lemma subsequence_iff_ascending : forall q  : Seq(A :=A),
    ascending R q <-> increasing R q /\ exists q',  subsequence q' q /\ strictly_increasing R q'.
Proof.
split.
*
  intro Ha.
  split; destruct Ha; auto.
  apply ascending_subsequence; split; auto.
*
  intros (q' & q'' & Hs & Hsi).
  apply (subsequence_ascending q'' q); auto.
Qed.

End OrderedSequences.


(precise)admin@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables W X Y Z : Prop.
W is assumed
X is assumed
Y is assumed
Z is assumed

Coq < Goal ((W -> (X -> Y)) /\ (X -> (Y -> Z))) -> (W -> (X -> Z)).
1 subgoal

  W : Prop
  X : Prop
  Y : Prop
  Z : Prop
  ============================
   (W -> X -> Y) /\ (X -> Y -> Z) -> W -> X -> Z

Unnamed_thm < intros.
1 subgoal

  W : Prop
  X : Prop
  Y : Prop
  Z : Prop
  H : (W -> X -> Y) /\ (X -> Y -> Z)
  H0 : W
  H1 : X
  ============================
   Z

Unnamed_thm < elim H.
1 subgoal

  W : Prop
  X : Prop
  Y : Prop
  Z : Prop
  H : (W -> X -> Y) /\ (X -> Y -> Z)
  H0 : W
  H1 : X
  ============================
   (W -> X -> Y) -> (X -> Y -> Z) -> Z

Unnamed_thm < intro.
1 subgoal

  W : Prop
  X : Prop
  Y : Prop
  Z : Prop
  H : (W -> X -> Y) /\ (X -> Y -> Z)
  H0 : W
  H1 : X
  H2 : W -> X -> Y
  ============================
   (X -> Y -> Z) -> Z

Unnamed_thm < intro.
1 subgoal

  W : Prop
  X : Prop
  Y : Prop
  Z : Prop
  H : (W -> X -> Y) /\ (X -> Y -> Z)
  H0 : W
  H1 : X
  H2 : W -> X -> Y
  H3 : X -> Y -> Z
  ============================
   Z

Unnamed_thm < tauto.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
tauto.

Unnamed_thm is defined

Coq <


Require Import List ListSet ListSetFacts basic.
Generalizable All Variables.
Set Implicit Arguments.
Inductive PR_InDom {A B} : list (A * B) -> A -> Type :=
  | pr_dom_fst : `{PR_InDom ((a,b)::rst) a}
  | pr_dom_rst : `{PR_InDom l a -> PR_InDom ((a',b')::l) a}.

Inductive InDom {A B} : list (A * B) -> A -> Prop :=
  | dom_fst : `{InDom ((a,b)::rst) a}
  | dom_rst : `{InDom l a -> InDom ((a',b')::l) a}.

Inductive MapsTo {A B} : list (A * B) -> A -> B -> Prop :=
  | map_fst : `{MapsTo ((a,b)::rst) a b}
  | map_rst : `{a <> a' -> MapsTo l a b -> MapsTo ((a',b')::l) a b}.

Inductive Unmapped {A B} : list (A * B) -> A -> Prop :=
  | unil : forall a, Unmapped nil a
  | ucons : forall a a' b l, Unmapped l a' -> a <> a' -> Unmapped ((a,b)::l) a'.

Inductive Functional {A B} : list (A * B) -> Prop :=
  | empty_fn : Functional nil
  | extend_fn : `{Functional l -> Unmapped l a -> Functional ((a,b)::l)}.

Fixpoint in_dom {A B} (Aeq_dec : dec_type A) (l : list (A * B)) (a : A) : bool :=
  match l with
      nil => false
    | (a',b)::l => if (Aeq_dec a a') then true else in_dom Aeq_dec l a
  end.

Hint Constructors MapsTo Unmapped InDom : fmaplist.

Lemma MapsTo_In : forall A B (l : list (A * B)) a b (H: MapsTo l a b), In (a,b) l.
Proof.
  induction l as [|(a,b) l' IH];
  intros a' b' H; inversion H; (* finishes base case *)
  subst; [constructor|right; apply IH]; auto.
Qed.

Theorem InDom_is_mapped : forall A B (eq_dec : dec_type A) (l : list (A * B)) a, InDom l a <-> exists b, MapsTo l a b.
Proof.
  induction l as [|(a_,b_) l_ IH].
  split; [intro H; inversion H |intros [x H]; inversion H].
  intro a; destruct (eq_dec a_ a) as [Heq|Hneq].
  subst; split; [exists b_|]; constructor.
  split; intro H;
   [inversion H as [|? ? ? ? H']; subst;
    [contradict Hneq
    |rewrite IH in H'; destruct H' as [b H'']; exists b; constructor]
   |destruct H as [b H'']; inversion H''; subst; [contradict Hneq|constructor; rewrite IH; exists b]]; auto.
Qed.

Theorem InDom_In : forall A B (eq_dec : dec_type A) (l : list (A * B)) a, InDom l a <-> exists b, In (a,b) l.
Proof.
  intros; split; intro H;
  [rewrite InDom_is_mapped in H; auto; destruct H as [b H']; apply MapsTo_In in H'; exists b
  |destruct H as [b H']; induction l as [|(a_,b_) l_ IH]; inversion H'; [inject_pair|];constructor]; auto.
Qed.

Theorem in_dom_reflect : forall A B (eq_dec : dec_type A) (l : list (A * B)) a, InDom l a <-> in_dom eq_dec l a = true.
Proof.
  induction l as [|(a',b') l IH]; intros; split; intro H;
  solve [inversion H
        |simpl; destruct (eq_dec a a');
         [|inversion H; subst; [bad_eq|rewrite <- IH]]; auto
        |simpl in H; destruct (eq_dec a a'); [subst; constructor|constructor; rewrite IH; auto]].
Qed.

Theorem unmapped_not_mapped : forall A B
                                     (eq_dec : dec_type A)
                                     (l : list (A*B)) a,
                                (Unmapped l a <-> forall b, ~ MapsTo l a b).
Proof.
  intros A B eq_dec l a; induction l as [|(a',b') l' [IHl'0 IHl'1]];
  split;
  [intros H b bad; inversion bad
  |constructor
  |intros H b0 bad;
    inversion H as [| ? ? ? ? Hunmapped Hbad];
    inversion bad as [| ? ? ? ? ? ? Hbadmap]; subst;
    [contradict Hbad; reflexivity
    |specialize IHl'0 with Hunmapped; apply IHl'0 in Hbadmap]
  |intros H; constructor;
  [apply IHl'1; intros bb bad; destruct (eq_dec a a'); subst;
      [pose (HC := (H b')); contradict HC; constructor
      |pose (HC := (H bb)); contradict HC; constructor; auto]
     |intro Heq; subst; apply H with (b := b'); constructor]]; auto.
Qed.

Lemma in_not_unmapped : forall A B (l : list (A * B)) a b (H:In (a,b) l), ~ Unmapped l a.
Proof.
  induction l as [|(a,b) l' IH]; intros a0 b0 H bad; inversion H; subst.
  inject_pair;
    inversion bad; auto.
  inversion bad as [|? ? ? ? bad']; apply IH with (b:= b0) in bad'; auto.
Qed.

Lemma in_functional_mapsto : forall A B (eq_dec : dec_type A) (l : list (A * B)) (F : Functional l)
                                    a b (H : In (a,b) l), MapsTo l a b.
Proof.
  induction l as [|(a,b) l' IH];
  intros F a' b' H; inversion H;[ (* finishes base case *)
    inject_pair; subst; constructor; auto
  |inversion F as [|? ? ? Hfun Hunmapped]; subst;
   destruct (eq_dec a a'); [subst; contradict Hunmapped; apply in_not_unmapped with (b:=b')
                           |constructor]]; auto.
Qed.

Remark functional_exchange : forall A B (l : list (A * B)) a b (F: Functional ((a,b)::l)) b', Functional ((a,b')::l).
Proof. intros; inversion F; constructor; auto. Qed.

Lemma MapsTo_same : forall A B (l : list (A * B)) a b b', MapsTo l a b -> MapsTo l a b' -> b = b'.
Proof.
  induction l as [|a0 l_ IH]; intros;
   inversion H;
   subst; inversion H0; subst; solve [reflexivity | bad_eq | apply IH with (a := a); auto].
Qed.

Section ExtendLookup.
Variables (A B : Type) (eq_dec : (dec_type A)).
Fixpoint extend_map (a : A) (b : B) (ρ : list (A * B)) :=
  match ρ with
    | nil => (a, b)::nil
    | (a',b')::ρ' => if eq_dec a a' then
                       (a,b)::ρ'
                     else (a',b')::(extend_map a b ρ')
  end.
Fixpoint lookup_map (a : A) (ρ : list (A * B)) : option B :=
  match ρ with
    | nil => None
    | (a',b)::ρ' => if eq_dec a a' then
                       Some b
                     else (lookup_map a ρ')
  end.

Theorem extend_map_MapsTo : forall a b (ρ : list (A * B)), MapsTo (extend_map a b ρ) a b.
Proof.
  induction ρ as [|(a_,b_) ρ_ IH];
  [constructor
  |simpl; destruct (eq_dec a a_); constructor; auto].
Qed.

Theorem extend_map_MapsTo_eq : forall a b c (ρ : list (A * B)), MapsTo (extend_map a b ρ) a c -> b = c.
Proof.
  intros a b c ρ Hmap.
  assert (Hmap' : MapsTo (extend_map a b ρ) a b) by apply extend_map_MapsTo.
  exact (MapsTo_same Hmap' Hmap).
Qed.

Theorem extend_map_old : forall (ρ : list (A * B)) a a' b c , a <> a' -> MapsTo (extend_map a b ρ) a' c -> MapsTo ρ a' c.
Proof.
  induction ρ as [|(a_,b_) ρ_ IH]; intros a a' b c Hneq Hmap;
  [inversion Hmap as [|? ? ? ? ? ? bad]; [subst; bad_eq |inversion bad]
  |simpl in Hmap; destruct (eq_dec a a_);
    [subst; constructor; [|inversion Hmap; subst; [bad_eq |]]
    |inversion Hmap; subst; [constructor|constructor; [|apply (IH a a' b)]]]; auto].
Qed.

Theorem extend_mapsto_elim : forall a a' b b' (ρ : list (A * B)), MapsTo (extend_map a b ρ) a' b' -> (a = a' /\ b = b') \/ (a <> a' /\ MapsTo ρ a' b').
Proof.
  intros; destruct (eq_dec a a') as [Heq|Hneq];
  [subst; left; split; [|apply (extend_map_MapsTo_eq _ _ H)]
  |right; split;[|apply (extend_map_old _ _ Hneq H)]]; auto.
Qed.

Theorem lookup_mapsto : forall (l : list (A * B)) a b,
                          (MapsTo l a b) <-> (lookup_map a l) = Some b.
Proof.
  induction l as [|(a,b) l' IH]; [intros a b; split; intro Hvac; inversion Hvac|].
  intros a' b'; split; intro H; simpl in *;
  destruct (eq_dec a' a) as [Hleft|Hright];
  solve
   [inversion H;
   try solve [contradict Hleft; auto
             |contradict Hright; auto
             |apply IH; auto
             |auto]
   |injection H; intros; subst; constructor
   |constructor; [|apply IH];auto].
Qed.

Theorem InDom_lookup : forall (l : list (A * B)) a,
                         InDom l a -> exists b, lookup_map a l = Some b.
Proof.
  intros l a H; rewrite InDom_is_mapped in H;
                [destruct H as [b Hmap]; rewrite lookup_mapsto in Hmap;
                 exists b; auto
                |exact eq_dec].
Qed.
End ExtendLookup.

Section RangeRestriction.

Variables (A B : Type) (Aeq_dec : dec_type A) (Beq_dec : dec_type B).

Definition functional_restrict_to_set (l : list (A * B)) (s : set A) :=
  filter (fun ab => match ab with (a,b) => if (set_In_dec Aeq_dec a s) then true else false end) l.

Fixpoint restrict_to_set (l : list (A * B)) (s : set A) : list (A * B) :=
  match l with
      nil => nil
    | (a,b)::l => if (set_In_dec Aeq_dec a s) then
                     (a,b)::(restrict_to_set l (set_remove Aeq_dec a s))
                  else restrict_to_set l s
  end.

Definition functional_range_in_set (l : list (A * B)) (s : set A) :=
  fold_right (fun ab acc =>
             match ab with (a,b) => if (set_In_dec Aeq_dec a s) then
                                       set_add Beq_dec b acc
                                    else acc
             end)
             (empty_set _) l.

Fixpoint collect_domain (l : list (A * B)) : set A :=
  match l with
      nil => (empty_set _)
    | (a,_)::l => set_add Aeq_dec a (collect_domain l)
  end.
Open Scope list_scope.

Lemma collect_domain_nodup : forall l, NoDup (collect_domain l).
Proof.
  induction l as [|(a,b) l IH]; simpl; [constructor|apply set_add_nodup; auto].
Qed.

Fixpoint range_in_set (l : list (A * B)) (s : set A) : set B :=
  match l with
      nil => (empty_set _)
    | (a,b)::l => if (set_In_dec Aeq_dec a s) then
                     set_add Beq_dec b (range_in_set l (set_remove Aeq_dec a s))
                  else range_in_set l s
  end.

Lemma range_in_set_nodup : forall l s, NoDup (range_in_set l s).
Proof.
  induction l as [|(a,b) l IH]; intros; [constructor|].
  simpl.
  destruct (set_In_dec Aeq_dec a s);[apply set_add_nodup|]; apply IH.
Qed.

Definition collect_range (l : list (A * B)) : set B :=
  range_in_set l (collect_domain l).

Theorem collect_range_nodup : forall l, NoDup (collect_range l).
Proof.
  intro l; apply range_in_set_nodup.
Qed.

Theorem restrict_is_restriction : forall l s a b, MapsTo (restrict_to_set l s) a b ->
                                                  MapsTo l a b /\ set_In a s.
Proof.
  induction l as [|(a_,b_) l_ IH]; intros s a b Hmap.
  inversion Hmap.
  simpl in Hmap;
    destruct (set_In_dec Aeq_dec a_ s) as [Hin|Hnin].

  inversion Hmap as [|? ? ? ? ? ? Hmap']; subst;
  [|apply IH in Hmap'; destruct Hmap' as [? Hinrem];apply set_remove_in in Hinrem];auto with fmaplist.

   apply IH in Hmap; destruct Hmap; split; [constructor; [intro bad; subst; contradiction|] |]; auto.
Qed.

End RangeRestriction.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import ZArith.
Require Import Decision.
Open Scope Z_scope.

(** * The [xomega] tactic *)

(** Calculations involving page addresses and the like involve some
  integer divisions, which [omega] and friends cannot handle as is.
  To remedy this, we can add a preprocessing step where we prove
  inequalities which characterize the subterms which [omega] does not
  understand.

  So for instance, if the subexpression [a / b] appears, we can add
  the hypothesis [0 <= a - a / b * b < b] to the context.  Then when
  [omega] abstracts the division as a variable [q], it will
  nonetheless know that [0 <= a - q * b < b] which is equivalent to
  [q = a / b].

  The [xomega] tactic applies this principle to enable [omega] to
  solve goals involving [Z.div], [Z.modulo] and [Z.max]. *)

Module XOmega.

  (** ** Inject [nat]'s into [Z] *)

  (** Although we mostly use [Z], occasionally some goals or hypotheses
    involving [nat] show up. This is the case for instance when doing
    induction on the [Calculate_foo] family of fixpoints. The rewrite
    base below makes sure everything is expressed in terms of [Z]:
    relations on [nat] are converted into relations on [Z], and the
    resulting [Z.of_nat]'s are pushed inwards in all expressions. *)

  (** Use [Z.max] to avoid side conditions. *)
  Lemma Nat2Z_inj_to_nat_max z:
    Z.of_nat (Z.to_nat z) = Z.max 0 z.
  Proof.
    destruct (decide (0 <= z)) as [Hz | Hz].
    * rewrite Z2Nat.id by assumption.
      rewrite Zmax_right by assumption.
      reflexivity.
    * destruct z.
      - elim Hz.
        reflexivity.
      - elim Hz.
        apply Pos2Z.is_nonneg.
      - rewrite Z2Nat.inj_neg.
        rewrite Nat2Z.inj_0.
        rewrite Zmax_left by omega.
        reflexivity.
  Qed.

  Hint Rewrite <-
    Nat2Z.inj_iff
    Nat2Z.inj_compare
    : nat2z.

  Hint Rewrite ->
    Nat2Z.inj_le
    Nat2Z.inj_lt
    Nat2Z.inj_ge
    Nat2Z.inj_gt
    Nat2Z.inj_0
    Nat2Z.inj_succ
    Nat2Z.inj_abs_nat
    Nat2Z.inj_add
    Nat2Z.inj_mul
    Nat2Z.inj_sub_max
    Nat2Z.inj_pred_max
    Nat2Z.inj_min
    Nat2Z.inj_max
    Nat2Z_inj_to_nat_max
    : nat2z.

  Ltac nat2z :=
    autorewrite with nat2z in *.

  (** ** Characterize [Z.div] and [Z.max] by inequalities *)

  (** Ensure that no hypothesis of type [P] already exists, then use
    the provided tactic to add one. *)
  Ltac assert_new P tac :=
    match goal with
      | H_already_there : P |- _ => fail 1
      | _ => assert P by tac
    end.

  (** Characterize [Z.div a b]. *)

  Notation DIVSPEC a b :=
    ((b < 0 /\ b < a - a / b * b <= 0) \/
     (b = 0 /\ a / b = 0) \/
     (b > 0 /\ 0 <= a - a / b * b < b))%Z.

  Lemma specify_division a b:
    DIVSPEC a b.
  Proof with try omega.
    destruct (decide (b < 0)) as [Hbn | Hbn]; [left | right;
    destruct (decide (b = 0)) as [Hbz | Hbz]; [left | right]];
    split...
    * rewrite <- Zmod_eq_full...
      apply Z.mod_neg_bound...
    * subst.
      apply Zdiv_0_r...
    * rewrite <- Zmod_eq_full...
      apply Z.mod_pos_bound...
  Qed.

  Ltac specify_division a b :=
    let tac := (apply specify_division) in
    assert_new (DIVSPEC a b) tac.

  (** Characterize [Z.modulo a b]. *)

  Notation MODSPEC a b :=
    ((b  = 0 /\ a mod b = 0) \/
     (b <> 0 /\ a mod b = a - a / b * b))%Z.

  Lemma specify_modulo a b:
    MODSPEC a b.
  Proof with try omega.
    destruct (decide (b = 0)); [left | right];
    split...
    * subst; apply Zmod_0_r.
    * apply Zmod_eq_full...
  Qed.

  Ltac specify_modulo a b :=
    let tac := (apply specify_modulo) in
    assert_new (MODSPEC a b) tac.

  (** Characterize [Z.max a b]. *)

  Notation MAXSPEC a b :=
    ((a >= b /\ Z.max a b = a) \/
     (a <  b /\ Z.max a b = b))%Z.

  Lemma specify_max a b:
    MAXSPEC a b.
  Proof.
    apply Zmax_spec.
  Qed.

  Ltac specify_max a b :=
    let tac := (apply specify_max) in
    assert_new (MAXSPEC a b) tac.

  (** Now look in the hypotheses and goal for occurences of division and
    max, then instantiate the corresponding hypotheses. *)

  Ltac instantiate_extra_hypotheses_for P :=
    match P with
      | context [Z.div ?a ?b] => specify_division a b
      | context [Z.modulo ?a ?b] => specify_modulo a b
      | context [Z.max ?a ?b] => specify_max a b
    end;
    (* If we found at least one, go on. *)
    try instantiate_extra_hypotheses_for P.

  Ltac instantiate_extra_hypotheses :=
    repeat
      match goal with
        | H: ?P |- _ => instantiate_extra_hypotheses_for P
        | |- ?G => instantiate_extra_hypotheses_for G
      end.

  (** ** Assembling the pieces *)

  Ltac omegify :=
    nat2z;
    instantiate_extra_hypotheses.

End XOmega.

(** Random hint: the extra hypotheses are a little hairy, so if you
  use [omegify] manually on its own, you may want to import the
  [XOmega] module to get the [FOOSPEC] notations. *)

Ltac xomega :=
  XOmega.omegify;
  omega.

(** These should work as well if we ever need them. *)

(*
Require Import Psatz.
Ltac xlia := XOmega.omegify; lia.
Ltac xnia := XOmega.omegify; nia.
*)

(** Finally, a quick test. *)

Goal
  forall (x: Z) (y: nat),
    (y >= max 2 17)%nat ->
    (~ Z.to_nat x < y)%nat ->
    - x * 5 / - 4 > x + x / 0.
Proof.
  intros.
  xomega.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Basic_Cons.Terminal.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import NatTrans.NatTrans NatTrans.Func_Cat.
Require Import Basic_Cons.Terminal.
Require Import PreSheaf.PreSheaf.

Section Initial.
  Context (C : Category).

  (** The initial element of the category of presheaves. *)
  Program Definition PSh_Init_Func : Functor (C^op) Type_Cat :=
    {|
      FO := fun _ => (Empty : Type)
    |}.

  Local Hint Resolve NatTrans_eq_simplify.
  Local Hint Extern 1 => progress cbn in *.

  (** The functor that maps to the empty type in coq is the terminal object of
      presheaves. *)
  Program Instance PSh_Initial : (𝟘_ (PShCat C))%object :=
    {|
      terminal := PSh_Init_Func;
      t_morph := fun u => {|Trans := fun x y => _ |}
    |}.

End Initial.


Require Export Paths Fibrations Contractible Equivalences.

(** Any two contractible types are equivalent. *)

Definition contr_contr_equiv {A B} (f : A -> B) :
  is_contr A -> is_contr B -> is_equiv f.
Proof.
  intros Acontr Bcontr.
  apply @equiv_cancel_left with
    (g := contr_equiv_unit B Bcontr).
  exact (pr2 (contr_equiv_unit A Acontr)).
Defined.

(* A type is equivalent to its product with [unit]. *)

Definition prod_unit_right_equiv A : A <~> A * unit.
Proof.
  exists (fun a => (a,tt)).
  apply hequiv_is_equiv with (g := fun att:A*unit => let (a,t):=att in a).
  intros [a t]; destruct t; auto.
  auto.
Defined.

Definition prod_unit_left_equiv A : A <~> unit * A.
Proof.
  exists (fun a => (tt,a)).
  apply hequiv_is_equiv with (g := fun att:unit*A => let (t,a):=att in a).
  intros [t a]; destruct t; auto.
  auto.
Defined.

(** The action of an equivalence on paths is an equivalence. *)

Theorem equiv_map_inv {A B} {x y : A} (f : A <~> B) :
  (f x == f y) -> (x == y).
Proof.
  intros p.
  path_via (f^-1 (f x)).
  apply opposite, inverse_is_retraction.
  path_via' (f^-1 (f y)).
  apply map. assumption.
  apply inverse_is_retraction.
Defined.

Theorem equiv_map_is_equiv {A B} {x y : A} (f : A <~> B) :
  is_equiv (@map A B x y f).
Proof.
  apply @hequiv_is_equiv with (g := equiv_map_inv f).
  intro p.
  unfold equiv_map_inv.
  do_concat_map.
  do_opposite_map.
  moveright_onleft.
  undo_compose_map.
  path_via (map (f o (f ^-1)) p @ inverse_is_section f (f y)).
  apply inverse_triangle.
  path_via (inverse_is_section f (f x) @ p).
  apply homotopy_naturality_toid with (f := f o (f^-1)).
  apply opposite, inverse_triangle.
  intro p.
  unfold equiv_map_inv.
  moveright_onleft.
  undo_compose_map.
  apply homotopy_naturality_toid with (f := (f^-1) o f).
Defined.

Definition equiv_map_equiv {A B} {x y : A} (f : A <~> B) :
  (x == y) <~> (f x == f y) :=
  (@map A B x y f ; equiv_map_is_equiv f).

(** Path-concatenation is an equivalence. *)

Lemma concat_is_equiv_left {A} (x y z : A) (p : x == y) :
  is_equiv (fun q: y == z => p @ q).
Proof.
  apply @hequiv_is_equiv with (g := @concat A y x z (!p)).
  intro q.
  associate_left.
  intro q.
  associate_left.
Defined.

Definition concat_equiv_left {A} (x y z : A) (p : x == y) :
  (y == z) <~> (x == z) :=
  (fun q: y == z => p @ q  ;  concat_is_equiv_left x y z p).

Lemma concat_is_equiv_right {A} (x y z : A) (p : y == z) :
  is_equiv (fun q : x == y => q @ p).
Proof.
  apply @hequiv_is_equiv with (g := fun r : x == z => r @ !p).
  intro q.
  associate_right.
  intro q.
  associate_right.
Defined.

Definition concat_equiv_right {A} (x y z : A) (p : y == z) :
  (x == y) <~> (x == z) :=
  (fun q: x == y => q @ p  ;  concat_is_equiv_right x y z p).

(** Oppositizing is an equivalence. *)

Definition opposite_equiv {A} (x y : A) : (x == y) <~> (y == x).
Proof.
  exists opposite.
  apply hequiv_is_equiv with opposite.
  intros p; apply opposite_opposite.
  intros p; apply opposite_opposite.
Defined.

(** The same for opposite2. *)

Definition unopposite2 {A} {x y : A} (p q : x == y) : (!p == !q) -> (p == q).
Proof.
  intros r.
  path_via (!!p).
  apply @concat with (!!q).
  apply opposite2; assumption.
  auto with path_hints.
Defined.

Lemma opposite2_functor {A} (x y : A) (p q r : x == y) (s : p == q) (t : q == r) :
  opposite2 (s @ t) == opposite2 s @ opposite2 t.
Proof.
  path_induction.
Defined.

Lemma opposite2_opposite {A} (x y : A) (p q : x == y) (s : p == q) :
  opposite2 (!s) == !opposite2 s.
Proof.
  path_induction.
Defined.

Lemma opposite_opposite_opposite {A} (x y : A) (p : x == y) :
  opposite2 (opposite_opposite A x y p) ==
  opposite_opposite A y x (!p).
Proof.
  path_induction.
Defined.

Lemma opposite_opposite_natural {A} (x y : A) (p q : x == y) (r : p == q) :
  opposite2 (opposite2 r) @ opposite_opposite A x y q ==
  opposite_opposite A x y p @ r.
Proof.
  path_induction.
Defined.

Definition opposite2_equiv {A} (x y : A) (p q : x == y) : (p == q) <~> (!p == !q).
Proof.
  exists opposite2.
  apply hequiv_is_equiv with (g := unopposite2 p q).
  intros r.
  unfold unopposite2.
  path_via (opposite2 (!opposite_opposite A x y p) @
    opposite2 (opposite2 r @ opposite_opposite A x y q)).
  apply opposite2_functor.
  path_via (!opposite2 (opposite_opposite A x y p) @
    opposite2 (opposite2 r @ opposite_opposite A x y q)).
  apply opposite2_opposite.
  path_via (!(opposite_opposite A y x (!p)) @
   opposite2 (opposite2 r @ opposite_opposite A x y q)).
  apply opposite_opposite_opposite.
  moveright_onleft.
  path_via (opposite2 (opposite2 r) @ opposite2 (opposite_opposite A x y q)).
  apply opposite2_functor.
  path_via (opposite2 (opposite2 r) @ opposite_opposite A y x (!q)).
  apply opposite_opposite_opposite.
  apply opposite_opposite_natural.
  intros r.
  unfold unopposite2.
  moveright_onleft.
  apply opposite_opposite_natural.
Defined.

(** Transporting is an equivalence. *)

Theorem trans_equiv {A} {P : A -> Type} {x y : A} (p : x == y) :
  P x <~> P y.
Proof.
  exists (transport p).
  apply @hequiv_is_equiv with (transport (!p)).
  intros z.
  path_via (transport (!p @ p) z).
  apply opposite, trans_concat.
  path_via (transport (idpath _) z).
  apply happly. apply map.
  cancel_opposites.
  intros z.
  path_via (transport (p @ !p) z).
  apply opposite, trans_concat.
  path_via (transport (idpath _) z).
  apply happly. apply map.
  cancel_opposites.
Defined.

(** We can characterize the path types of the total space of a
   fibration, up to equivalence. *)

Theorem total_paths_equiv (A : Type) (P : A -> Type) (x y : sigT P) :
  (x == y) <~> { p : pr1 x == pr1 y & transport p (pr2 x) == pr2 y }.
Proof.
  exists (fun r => existT (fun p => transport p (pr2 x) == pr2 y) (base_path r) (fiber_path r)).
  eapply @hequiv_is_equiv.
  instantiate (1 := fun pq => let (p,q) := pq in total_path A P x y p q).
  intros [p q].
  eapply total_path.
  instantiate (1 := base_total_path A P x y p q).
  simpl.
  apply fiber_total_path.
  intro r.
  simpl.
  apply total_path_reconstruction.
Defined.

(** And similarly for products. *)

Program Definition prod_path_equiv A B (x y : A * B) :
  (x == y) <~> ((fst x == fst y) * (snd x == snd y))
  := (fun p => (map (@fst A B) p, map (@snd A B) p) ;
    hequiv_is_equiv _ _ _ _).
Next Obligation.
  intros A B [a1 b1] [a2 b2] [p q].
  apply prod_path; assumption.
Defined.
Next Obligation.
  intros A B [a1 b1] [a2 b2] [p q].
  unfold prod_path_equiv_obligation_1.
  simpl in p, q.
  apply prod_path; induction p; induction q; auto.
Defined.
Next Obligation.
  intros A B x1 x2 pq.
  induction pq as [[a b]].
  unfold prod_path_equiv_obligation_1; auto.
Defined.

(** The homotopy fiber of a fibration is equivalent to the actual fiber. *)

Section hfiber_fibration.

  Hypothesis X:Type.
  Hypothesis P : X -> Type.

  Let hfiber_fibration_map (x : X) : { z : sigT P & pr1 z == x } -> P x.
  Proof.
    intros [z p].
    apply (transport p).
    exact (pr2 z).
  Defined.

  Let hfiber_fibration_map_path (x : X) (z : sigT P) (p : pr1 z == x) :
    (x ; hfiber_fibration_map x (z ; p)) == z.
  Proof.
    apply total_path with (p := !p).
    destruct z as [x' y']. simpl.
    path_via (transport (p @ !p) y').
    apply opposite, trans_concat.
    path_via (transport (idpath _) y').
    apply map with (f := fun q => transport q y').
    cancel_opposites.
  Defined.

  Definition hfiber_fibration (x : X) :
    P x <~> { z : sigT P & pr1 z == x }.
  Proof.
    exists (fun y: P x => (((x ; y) ; idpath _)
      : {z : sigT P & pr1 z == x})).
    apply hequiv_is_equiv with (g := hfiber_fibration_map x).
    intros [z p].
    apply total_path with (p := hfiber_fibration_map_path x z p). simpl.
    path_via (transport (P := fun x' => x' == x)
      (map pr1 (hfiber_fibration_map_path x z p))
      (idpath x)).
    apply @map_trans with (P := fun x' => x' == x).
    unfold hfiber_fibration_map_path.
    path_via (transport (P := fun x' => x' == x) (!p) (idpath x)).
    apply map with (f := fun r => transport (P := fun x' => x' == x) r (idpath x)).
    apply @base_total_path with
      (x := (x ; hfiber_fibration_map x (z ; p))).
    path_via ((!!p) @ idpath x).
    apply trans_is_concat_opp.
    cancel_units.
    intros y.
    unfold hfiber_fibration_map. simpl. auto.
  Defined.

End hfiber_fibration.

(** Replacement of a map by an equivalent fibration. *)

Section FibrationReplacement.

  Hypothesis A B : Type.
  Hypothesis f : A -> B.

  Definition fibration_replacement (x:A) : {y:B & {x:A & f x == y}} :=
    (f x ; (x ; idpath (f x))).

  Definition fibration_replacement_equiv : A <~> {y:B & {x:A & f x == y}}.
  Proof.
    exists fibration_replacement.
    apply hequiv_is_equiv with
      (g := fun yxp => match yxp with
                         existT y (existT x p) => x
                       end).
    intros [y [x p]].
    unfold fibration_replacement.
    apply total_path with (p := p). simpl.
    path_via (existT (fun x' => f x' == y) x (idpath (f x) @ p)).
    path_via (existT (fun x' => f x' == y) x (transport p (idpath (f x)))).
    apply opposite.
    apply @trans_map with
      (P := fun y' => f x == y')
      (Q := fun y' => {x':A & f x' == y'})
      (f := fun y' q => existT (fun x' => f x' == y') x q).
    apply trans_is_concat.
    intros x. auto.
  Defined.

  Definition fibration_replacement_factors (x:A) :
    pr1 (fibration_replacement_equiv x) == f x.
  Proof.
    auto.
  Defined.

End FibrationReplacement.

(** The construction of total spaces of fibrations is "associative". *)

Section TotalAssoc.

  Hypotheses (A:Type) (P : A -> Type) (Q : forall x, P x -> Type).

  Let ta1 : { x:A & { p:P x & Q x p}} -> { xp : sigT P & Q (pr1 xp) (pr2 xp) }.
  Proof.
    intros [x [p q]].
    exists (x;p).
    exact q.
  Defined.

  Let ta2 : { xp : sigT P & Q (pr1 xp) (pr2 xp) } -> { x:A & { p:P x & Q x p}}.
  Proof.
    intros [[x p] q].
    exists x. exists p. exact q.
  Defined.

  Definition total_assoc :
    { x:A & { p:P x & Q x p}} <~> { xp : sigT P & Q (pr1 xp) (pr2 xp) }.
  Proof.
    exists ta1.
    apply hequiv_is_equiv with ta2.
    intros [[x p] q]; auto.
    intros [x [p q]]; auto.
  Defined.

End TotalAssoc.

Section TotalAssocSum.

  Hypotheses (A:Type) (P : A -> Type) (Q : sigT P -> Type).

  Let ta1 : { x:A & { p:P x & Q (x;p)}} -> { xp : sigT P & Q xp }.
  Proof.
    intros [x [p q]].
    exists (x;p).
    exact q.
  Defined.

  Let ta2 : { xp : sigT P & Q xp } -> { x:A & { p:P x & Q (x;p)}}.
  Proof.
    intros [[x p] q].
    exists x. exists p. exact q.
  Defined.

  Definition total_assoc_sum :
    { x:A & { p:P x & Q (x;p)}} <~> { xp : sigT P & Q xp }.
  Proof.
    exists ta1.
    apply hequiv_is_equiv with ta2.
    intros [[x p] q]; auto.
    intros [x [p q]]; auto.
  Defined.

End TotalAssocSum.

(** And "commutative" *)

Section TotalComm.

  Hypotheses (A:Type) (B:Type) (P : A -> B -> Type).

  Let tc1 : {x:A & {y:B & P x y}} -> {y:B & {x:A & P x y}}.
  Proof.
    intros [x [y p]].
    exists y.  exists x.  exact p.
  Defined.

  Let tc2 : {y:B & {x:A & P x y}} -> {x:A & {y:B & P x y}}.
  Proof.
    intros [y [x p]].
    exists x.  exists y.  exact p.
  Defined.

  Definition total_comm :
    {x:A & {y:B & P x y}} <~> {y:B & {x:A & P x y}}.
  Proof.
    exists tc1.
    apply hequiv_is_equiv with tc2.
    intros [x [y p]]; auto.
    intros [y [x p]]; auto.
  Defined.

End TotalComm.

(** Transporting along a path is an "adjoint equivalence". *)

Lemma transport_adjoint X (P : X -> Type) (x y : X) (p : x == y)
  (a : P x) (b : P y) :
  (transport p a == b) <~> (a == transport (!p) b).
Proof.
  path_induction.
  simpl.
  apply idequiv.
Defined.

(** The product of two equivalences is an equivalence. *)

Lemma product_equiv A B C D :
  (A <~> B) -> (C <~> D) -> (A*C <~> B*D).
Proof.
  intros f g.
  exists (fun ac => (f (fst ac), g (snd ac))).
  apply @hequiv_is_equiv with
    (g := fun bd => (f ^-1 (fst bd), g ^-1 (snd bd))).
  intros [b d]; simpl.
  apply prod_path; simpl; cancel_inverses.
  intros [a c] ;simpl.
  apply prod_path; simpl; cancel_inverses.
Defined.

(** Products are equivalent to pullbacks over any contractible type. *)

Section PullbackContr.

  Hypotheses A B C : Type.
  Hypothesis Cc : is_contr C.
  Hypothesis (f : A -> C) (g : B -> C).

  Let pbu1 : {x:A & {y:B & f x == g y}} -> A * B.
  Proof.
    intros [a [b p]].
    exact (a,b).
  Defined.

  Let pbu2 : A * B -> {x:A & {y:B & f x == g y}}.
  Proof.
    intros [a b].
    exists a; exists b; apply contr_path, Cc.
  Defined.

  Definition pullback_over_contr : {x:A & {y:B & f x == g y}} <~> A * B.
  Proof.
    exists pbu1.
    apply hequiv_is_equiv with pbu2.
    intros [a b]. simpl. auto.
    intros [a [b p]]. simpl.
    apply total_path with (idpath a). simpl.
    apply total_path with (idpath b); simpl.
    apply contr_path2. apply Cc.
  Defined.

End PullbackContr.


Require Import Arith.
Require Import Ascii.
Require Import Bool.
Require Import Coq.Strings.Byte.
Require Import String.
Local Open Scope string_scope.

Compute eqb "asa" "asa".

Inductive lambda_aexp :=
| anum : nat -> lambda_aexp
| aparam : string -> lambda_aexp
| aplus : lambda_aexp -> lambda_aexp -> lambda_aexp.

Inductive Array :=
| empty_array
| array_el : nat -> Array
| array_cons : Array -> Array -> Array.

Coercion array_el : nat >-> Array.

Notation "#[ #]" := empty_array (format "#[ #]", at level 60).
Notation "#[ A #]" := (array_el A) (at level 60).
Notation "#[ A , B , .. , N , M #]" := (array_cons (array_el A) (array_cons (array_el B) .. (array_cons (array_el N) (array_el M))..)) (at level 60).

Check array_cons empty_array (array_el 5).
Check #[ #].
Check #[ 2 #].
Check #[ 3, 6, 8#].

Inductive Params :=
| empty_params
| params_el : string -> Params
| params_cons : Params -> Params -> Params.

Coercion params_el : string >-> Params.

Notation "$( $)" := empty_params (format "$( $)", at level 60).
Notation "$( A $)" := (params_el A) (at level 60).
Notation "$( A , B , .. , N , M $)" := (params_cons (params_el A) (params_cons (params_el B) .. (params_cons (params_el N) (params_el M))..)) (at level 60).

Fixpoint get_element (arguments : Array) (current_index index : nat) : nat :=
  match arguments with
  | empty_array => 1000
  | array_el a => if Nat.eqb current_index index
                  then a
                  else 1000
  | array_cons a1 a2 => if Nat.eqb current_index index
                        then (match a1 with
                             | empty_array => 1000
                             | array_el a' => a'
                             | array_cons a'' a''' => 1000
                             end)
                        else get_element a2 (current_index + 1) index
  end.

Compute get_element (#[ 1, 11, 111, 1111 #]) 0 2.

Fixpoint get_value (param : string) (params : Params) (arguments : Array) (current_index : nat) : nat :=
  match params with
  | empty_params => 1000
  | params_el a => if eqb a param
                   then get_element arguments 0 current_index
                   else 1000
  | params_cons a1 a2 => (match a1 with
                         | empty_params => 1000
                         | params_el a' => if eqb a' param
                                          then get_element arguments 0 current_index
                                          else get_value param a2 arguments (current_index + 1)
                         | params_cons a'' a''' => 1000
                         end)
  end.

Compute get_value ("a") ( $("b", "d", "c", "a", "e" $) ) ( #[2, 4, 3, 1, 5#] ) (0).

Fixpoint aeval_lambda_aexp (params : Params) (arguments : Array) (exp : lambda_aexp) : nat :=
  match exp with
  | anum a => a
  | aparam a => get_value a params arguments 0
  | aplus a1 a2 => (aeval_lambda_aexp params arguments a1) + (aeval_lambda_aexp params arguments a2)
  end.

Definition my_exp := aplus (aparam "b") (aparam "e").

Compute aeval_lambda_aexp ( $("b", "d", "c", "a", "e" $) ) ( #[2, 4, 3, 1, 5#] ) (my_exp).

Inductive Lambda_pairs : Set :=
| basic_pair : Params -> lambda_aexp -> Lambda_pairs.

Definition lambda_Env := string -> Lambda_pairs.

Definition env1 : lambda_Env :=
  fun l_func => basic_pair ($( $)) (anum 1000).

Definition update (env : lambda_Env) (l_func : string) (l_pair : Lambda_pairs) : lambda_Env :=
  fun var' => if eqb var' l_func
              then l_pair
              else (env var').

Definition env2 := update env1 "adunare_3" (basic_pair ($("x", "y", "z"$)) (aplus (aparam "x") (aplus (aparam "y") (aparam "z"))) ).

Compute env2 "adunare_3".

Definition calculate_lambda (lambda_name : string) (l_env : lambda_Env) (arguments : Array) : nat :=
  match (l_env lambda_name) with
  | basic_pair a b => aeval_lambda_aexp a arguments b
  end.

Compute calculate_lambda "adunare_3" env2 ( #[ 3, 4, 5#]).

Notation " '@lambda(' A , B , C )" := (calculate_lambda A B C) (at level 60).

Compute @lambda("adunare_3", env2, (#[ 3, 4, 5#])).