Require Import Notations.
Require Import Logic.
Require Import Relations.
Require Import Setoid.
Require Import Classical.

Require Import Coq.Strings.String.

Arguments clos_refl_trans_1n {A} R x _.
Arguments clos_trans {A} R x _.
Arguments union {A} R1 R2 x y.

Module Type atomPL.
  Parameters atomProg state : Set.
  Parameter meanFunc : atomProg -> relation state.
End atomPL.

Module M <: atomPL.

Inductive id : Type :=
  | Id : string -> id.

Definition beq_id x y :=
  match x,y with
    | Id n1, Id n2 => if string_dec n1 n2 then true else false
  end.

Definition total_map (A:Set) := id -> A.

Definition t_empty {A:Set} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A:Set} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

Definition state := total_map nat.

Definition W : id := Id "W".
Definition X : id := Id "X".
Definition Y : id := Id "Y".
Definition Z : id := Id "Z".

Inductive Assign : Set :=
  assign : id -> nat -> Assign.

Definition atomProg := Assign.

Notation "x '::=' a" :=
  (assign x a) (at level 60).

(* Check (X ::= 3). *)

(*
Definition meanFunc (a : atomProg) :=
match a with
| assign id rhs => fun st1 st2 : state => st1 = st2
end.
*)

Definition meanFunc (a : atomProg) :=
  let (id, rhs) := a in
    fun st1 st2 : state => st2 = (t_update st1 id rhs).
End M.

Section Compose.
  Variables U V T : Type.
  Variable R1 : U -> V -> Prop.
  Variable R2 : V -> T -> Prop.
  Definition composeRel (x : U) (z : T) : Prop :=
    exists y, R1 x y /\ R2 y z.
End Compose.

Arguments composeRel {U} {V} {T} R1 R2 _ _.

Module DL (Import D : atomPL).
 Definition assertion := state -> Prop.

(*
Bind Scope assertion_scope with assertion.
Delimit Scope hprop_scope with assert.
*)

 Definition implA (A B : assertion) : assertion := (fun x => (A x -> B x)).

 Inductive prog : Type :=
 | Elem : atomProg -> prog
 | Sequence : prog -> prog -> prog
 | Choice : prog -> prog -> prog
 | Iteration : prog -> prog
 | Test : assertion -> prog.

 Fixpoint progSemantics  (p : prog) : relation state :=
 match p with
 | Elem ap => meanFunc ap
 | Sequence p1 p2 => composeRel (progSemantics p1) (progSemantics p2)
 | Choice p1 p2 => union (progSemantics p1) (progSemantics p2)
 | Iteration p => clos_refl_trans_1n (progSemantics p)
 | Test A => (fun st st' => st=st' /\ A st)
 end.

 Definition box (pr : prog) (A : assertion) : assertion :=
   fun st => (forall st', progSemantics pr st st' -> A st').

 Definition trueA : assertion := (fun _ => True).
 Definition falseA : assertion := (fun _ => False).
 Definition skip := Test trueA.
 Definition fail := Test falseA.

 Notation "p1 ; p2" := (Sequence p1 p2) (at level 60, right associativity).
 Notation "p1 'U' p2" := (Choice p1 p2) (at level 55, right associativity).
 Notation "p *" := (Iteration p) (at level 50, left associativity).
 Notation "A ?" := (Test A) (at level 50, left associativity).
 Notation "[ p ] A" := (box p A) (at level 70, right associativity).

 Notation "A ->> B" := (implA A B) (at level 80, right associativity).

 Definition assertImpl (A B : assertion) := forall st, A st -> B st.
 Definition assertEquiv (A B : assertion) := forall st, A st <-> B st.
 Definition valid (A : assertion) := forall st, A st.

 Infix "|=" := assertImpl (at level 85, no associativity).
 Infix "=|=" := assertEquiv (at level 90, no associativity).
 Notation "||= A" := (valid A) (at level 90).

 Theorem equivImpl : forall A B, A =|= B <-> (A |= B) /\ (B |= A).
 Proof.
 intros A B; unfold assertImpl, assertEquiv. firstorder.
 Qed.

 Definition andA (A B : assertion) : assertion := (fun x => (A x /\ B x)).
 Notation "A /| B" := (andA A B) (at level 75, right associativity).

 Definition negA (A : assertion) : assertion :=
  fun st' => ~(A st').

 Notation "¬ A" := (negA A) (at level 55, right associativity).

 Definition diamond (p : prog) (A : assertion) : assertion := ¬[p](¬A).

 Notation "< p > A" := (diamond p A) (at level 70, right associativity).

 Definition orA (A B : assertion) : assertion := (fun x => (A x \/ B x)).
 Notation "A \| B" := (orA A B) (at level 75, right associativity).

Theorem implIntro : forall A B, ||= A ->> B <-> A |= B.
Proof.
intros A B; unfold assertImpl, valid, implA; split; trivial.
Qed.

Theorem implIntro1 : forall A B C, A |= B ->> C <-> A /| B |= C.
Proof.
intros A B C. unfold assertImpl, implA, andA. firstorder.
Qed.

Proposition assertImplRefl : Reflexive assertImpl.
Proof.
unfold Reflexive. intros A st H. assumption.
Qed.

Proposition assertImplTrans : Transitive assertImpl.
Proof.
unfold Transitive. intros A B C HAB HBC st HA; auto.
Qed.

Add Parametric Relation : assertion assertImpl
  reflexivity proved by assertImplRefl
  transitivity proved by assertImplTrans
as AssertImplSetoid.

Proposition assertEquivRefl : Reflexive assertEquiv.
Proof.
unfold Reflexive. intros A st. now split.
Qed.

Proposition assertEquivSymm : Symmetric assertEquiv.
Proof.
unfold Symmetric. intros x y H st. unfold assertEquiv in H.
firstorder.
Qed.

Proposition assertEquivTrans : Transitive assertEquiv.
Proof.
unfold Transitive. intros A B C HAB HBC st.
unfold assertEquiv in *. firstorder.
Qed.

Add Parametric Relation : assertion assertEquiv
  reflexivity proved by assertEquivRefl
  symmetry proved by assertEquivSymm
  transitivity proved by assertEquivTrans
as AssertEquivSetoid.

Add Parametric Morphism : andA
 with signature (assertEquiv ==> assertEquiv ==> assertEquiv)
 as andEquivMorphism.
Proof.
intros A B H1 A' B' H2.
intro st; unfold andA. unfold assertEquiv in *.
firstorder.
Qed.

Add Parametric Morphism : andA
 with signature (assertImpl ++> assertImpl ++> assertImpl)
 as andImplMorphism.
Proof.
intros A B H1 A' B' H2.
intro st; unfold andA. unfold assertEquiv in *.
firstorder.
Qed.

(*
Goal forall A B C, A |= B -> A /| C |= B /| C.
intros A B C H. now rewrite H.
*)

Add Parametric Morphism : orA
 with signature (assertEquiv ==> assertEquiv ==> assertEquiv)
 as orEquivMorphism.
Proof.
intros A B H1 A' B' H2.
intro st; unfold orA. unfold assertEquiv in *.
firstorder.
Qed.

Add Parametric Morphism : orA
 with signature (assertImpl ++> assertImpl ++> assertImpl)
 as orImplMorphism.
intros A B H1 A' B' H2.
intro st; unfold orA. unfold assertEquiv in *.
firstorder.
Qed.

Add Parametric Morphism : implA
 with signature (assertEquiv ==> assertEquiv ==> assertEquiv)
 as implEquivMorphism.
intros A B H1 A' B' H2.
intro st; unfold implA. unfold assertEquiv in *.
firstorder.
Qed.

Add Parametric Morphism : implA
 with signature (assertImpl --> assertImpl ++> assertImpl)
 as implImplMorphism.
Proof.
intros A B H1 A' B' H2 st H3 H4. now apply H2, H3, H1.
Qed.

Add Parametric Morphism : negA
 with signature (assertEquiv ==> assertEquiv)
 as negEquivMorphism.
Proof.
intros A B H st; unfold negA. unfold assertEquiv in *.
firstorder.
Qed.

Add Parametric Morphism : negA
 with signature (assertImpl --> assertImpl)
 as negImplMorphism.
Proof.
intros A B H st; unfold negA; auto.
Qed.

 (** See Axiom System 5.5, p.173 *)
 Theorem axiom_II : forall (p : prog) (A B : assertion),
    ||= ([p](A ->> B) ->> ([p]A ->> [p]B)).
 Proof.
 intros p A B. apply implIntro. unfold implA.
 intros st HA. unfold box in *. intros H st' H1.
 apply HA. apply H1. apply H. apply H1.
 Qed.

(* Корректность правила GEN *)
Theorem genSound: forall p A, ||= A -> ||= [p]A.
intros p A HA. unfold valid in *. intros st.
unfold box. intros st' HP. now apply HA.
Qed.

Add Parametric Morphism (p : prog) : (box p)
 with signature (assertImpl ++> assertImpl)
 as boxImplMorphism.
Proof.
intros A B H. rewrite <- implIntro in H. apply (genSound p) in H.
intro st; apply axiom_II, H.
Qed.

Add Parametric Morphism (p : prog) : (box p)
 with signature (assertEquiv ==> assertEquiv)
 as boxEquivMorphism.
Proof.
intros A B H. apply equivImpl. apply equivImpl in H.
destruct H as [H1 H2]. split; [rewrite H1|rewrite H2]; reflexivity.
Qed.
(* Здесь можно использовать equivImpl и переписывание A в B
и наоборот под [p] *)

 Theorem axiom_III : forall (p : prog) (A B : assertion),
   ([p](A /| B)) =|= ([p]A /| [p]B).
 Proof.
 intros p A B. apply equivImpl. split.
 * intros st H. split; unfold box in *; intros st' H1;
   apply H in H1; destruct H1 as [H1' H1'']; assumption.
 * unfold assertImpl . intros st [HA HB]. unfold andA in *.
   intros st' H1. split. now apply HA in H1. now apply HB in H1.
 Qed.

 Theorem axiom_IV : forall (p p': prog) (A : assertion),
  [p U p']A =|= [p]A /| [p']A.
 Proof.
 intros p p' A. split.
 * intros H. split;
   intros st' H1; unfold box in H; specialize H with st';
   simpl in H; unfold union in H; apply H; [now left|now right].
 * intros [H H']. intros st' H1. simpl in H1.
   unfold union in H1. destruct H1 as [H1|H1].
   now apply H in H1. now apply H' in H1.
 Qed.

 Theorem axiom_V : forall (p p': prog) (A : assertion),
  [p; p']A =|= [p][p']A.
 Proof.
 intros p p' A. split.
 * intros H st'' H1 st3 H2. apply H.
   simpl in *. exists st''. split; assumption.
 * intros H st'' H1. simpl in H1.
   inversion H1. destruct H0 as [H' H''].
   eapply H. apply H'. apply H''.
 Qed.

 Theorem axiom_VI : forall (A B : assertion),
  [A?]B =|= (A ->> B).
 Proof.
 intros A B. split.
 * intros H. unfold implA. intros HA. apply H.
   simpl. split; [reflexivity|assumption].
 * intros H st' HT. unfold implA in H. simpl in HT.
   destruct HT as [H1 H2].  rewrite <- H1. now apply H.
 Qed.

 Theorem axiom_VII: forall (p : prog) (A : assertion),
 A /| [p][Iteration p]A =|= [Iteration p]A.
 Proof.
 intros p A. split.
 * unfold andA. intros [HA HI]. (* не работает setoid_rewrite <- axiom_IV in HI. *)
   apply <- (axiom_V p (Iteration p) A st) in HI .
   unfold box in *. simpl in *. intros st' H. inversion H. subst. apply HA.
   apply HI. subst. unfold composeRel. exists y. split. apply H0. apply H1.
 * intros H. unfold andA. split.
   + unfold box in H. apply H. simpl. apply rt1n_refl.
   + unfold box at 1. intros. unfold box in *.
     intros st'' H1. apply H. simpl in *.
     apply Relation_Operators.rt1n_trans with (y:=st'). apply H0. apply H1.
 Qed.

 Theorem axiom_VIII : forall (p : prog) (A : assertion),
 (A /| [Iteration p](A ->> [p]A)) |= [Iteration p]A.
 Proof.
 intros p A st. unfold box in *. simpl in *.
 unfold implA. intros H. destruct H as [HA HI].
 intros st' H. rewrite <- clos_rt_rt1n_iff in *.
 apply clos_refl_trans_ind_left with (R:=(progSemantics p)) (x:=st).
 apply HA. intros y z Hyz Hy Hpyz. rewrite clos_rt_rt1n_iff in Hyz.
 apply HI with (st':=y) (st'0:=z) in Hyz. apply Hyz. apply Hy. apply Hpyz.
 assumption.
 Qed.

Theorem deMorgan1 : forall A B, ¬(A \| B) =|= ¬A /| ¬B.
Proof.
intros A B. unfold negA, orA, andA. unfold assertEquiv.
intros st. firstorder.
Qed.

Theorem deMorgan2 : forall A B, ¬(A /| B) =|= ¬A \| ¬B.
Proof.
intros A B. unfold negA, orA, andA. unfold assertEquiv.
intros st. split.
* apply not_and_or.
* firstorder.
Qed.

 (** See Theorem 5.6, p.174 *)
 Theorem theorem_I : forall (p : prog) (A B : assertion),
 diamond p (A \| B) =|= diamond p A \| diamond p B.
 Proof.
intros p A B.
unfold diamond.
now rewrite deMorgan1, axiom_III, deMorgan2.
Qed.

 Lemma dne : forall A, ¬¬A =|= A.
 Proof.
 intros A. split.
 * apply NNPP.
 * intros HA. unfold negA. unfold not.
   intros HNA. now apply HNA.
 Qed.

 Theorem theorem_II : forall (p : prog) (A : assertion),
 [p]A =|=  ¬(diamond p (¬ A)).
 Proof.
 intros p A. unfold diamond. now rewrite !dne.
 Qed.

 Theorem theorem_III : forall (p : prog) (A B : assertion),
 ([p]A \| [p]B) |= [p](A \| B).
 Proof.
 intros p A B. rewrite <- implIntro. unfold orA, implA.
 firstorder.
 Qed.

 Theorem theorem_IV : forall (p : prog) (A B : assertion),
  (diamond p (A /| B)) |= ((diamond p A) /| (diamond p B)).
 Proof.
 intros p A B. unfold diamond in *. rewrite <- implIntro.
 unfold andA, implA, negA. firstorder.
 Qed.

 Theorem theorem_V : forall (p : prog),
 (diamond p falseA) =|= falseA.
 Proof.
 intros p. unfold diamond, falseA, negA.
 apply equivImpl. split; rewrite <- implIntro; unfold implA; firstorder.
 Qed.

Add Parametric Morphism : valid
 with signature (assertEquiv ==> iff)
 as validEquivMorphism.
Proof.
intros A B H. unfold valid. unfold assertEquiv in H.
firstorder.
Qed.

Ltac replaceA e1 e2 :=
  setoid_replace e1 with e2;
    [| intro st; unfold andA, orA, implA, negA; tauto].

 Theorem theorem_VI : forall (p : prog) (A B : assertion),
 ((diamond p A) /| [p]B) |= diamond p (A /| B).
 Proof.
 intros p A B. unfold diamond.
 rewrite <- implIntro.
 replaceA (¬ ([p] ¬ A) /| [p] B ->> ¬ ([p] ¬ (A /| B)))
      ([p] ¬ (A /| B) /| [p] B ->> [p] ¬ A).
 rewrite <- axiom_III.
 rewrite implIntro.
 setoid_replace (¬ (A /| B) /| B) with (¬ A) using relation assertImpl;
 [reflexivity | intro st; unfold andA, orA, implA, negA; tauto].
 Qed.

 (** See Theorem 5.7, p.175 *)
 Theorem monDiamondSound : forall (A B : assertion) (p : prog),
 ||=(A ->> B) -> ||=(diamond p A ->> diamond p B).
 Proof.
 intros A B p. intros H st. unfold diamond, negA, implA. firstorder.
 Qed.

 Theorem monBoxSound : forall (A B : assertion) (p : prog),
 ||=(A ->> B) -> ||=([p]A ->> [p]B).
 Proof.
 intros A B p. intros H st.
 assert (H1 : ([p](A ->> B) |= ([p]A ->> [p]B)) ).
 { rewrite <- implIntro. apply axiom_II. } apply H1.
 now apply genSound.
 Qed.

(** See definitions, p.167 *)
 Definition hoare_triple (A : assertion) (p : prog) (B : assertion):=
  A ->> [p]B.
 Notation "{{ A }}  p  {{ B }}" := (hoare_triple A p B).

 Definition ifA (A : assertion) (p p' : prog) := (A? ; p) U ((¬A)? ; p').
 Notation "'IFA' A 'THEN' p 'ELSE' p' 'FI'" :=
  (ifA A p p') (at level 80, right associativity).

 Definition whileA (A : assertion) (p : prog) :=
 (Iteration (A? ; p)); (¬A)?.
 Notation "'WHILE' A 'DO' p 'END'" :=
  (whileA A p) (at level 80, right associativity).

 Definition repeatP (p : prog) (A : assertion) :=
  p; (whileA (¬A) p).
 Notation "'REPEAT' p 'UNTIL' A 'END'" :=
  (repeatP p A) (at level 80, right associativity).

 (** See Theorem 5.19, p.186 *)
 Theorem compos_rule : forall (A B C : assertion) (p p' : prog),
  ||=(hoare_triple A p B) -> ||=(hoare_triple B p' C) -> ||=(hoare_triple A (p;p') C).
 Proof.
 intros A B C p p' HAB HBC. unfold hoare_triple in *.
 unfold implA in *. firstorder.
 Qed.

 Theorem condit_rule : forall (A B C : assertion) (p p' : prog),
 ||=(hoare_triple (A /| B) p C) -> ||=(hoare_triple ((¬A) /| B) p' C) ->
  ||=(hoare_triple B (IFA A THEN p ELSE p' FI) C).
 Proof.
 intros A B C p p' HAB HNAB. unfold hoare_triple in *.
 unfold ifA. rewrite axiom_IV, axiom_V, axiom_VI.
 unfold andA, negA, implA in *. split; [firstorder|].
 apply axiom_V, axiom_VI. unfold implA. firstorder.
 Qed.

 Theorem loop_inv_rule : forall A p,
 ||=(A ->> [p]A) -> ||=(A ->> [Iteration p]A).
 Proof.
 intros A p H1 st HA. apply axiom_VIII. split. apply HA.
 now apply genSound.
 Qed.

 Theorem while_rule : forall (A B : assertion) (p : prog),
 ||=(hoare_triple (A /| B) p B) -> ||=(hoare_triple B (WHILE A DO p END) ((¬A) /| B)).
 Proof.
 intros A B p. unfold hoare_triple, whileA.
 replaceA (A /| B ->> [p]B) (B ->> (A ->> [p]B)).
 intros HABPB st.
 setoid_replace (B ->> (A ->> [p]B)) with (B ->> ([A?]([p]B))) in HABPB;
 [|rewrite axiom_VI; reflexivity]. rewrite <- axiom_V in HABPB.
 apply loop_inv_rule in HABPB.
 setoid_replace (B ->> [Iteration (A ?; p)]B)
 with (B ->> [Iteration  (A ?; p)]((¬A)  ->> ((¬A) /| B))) in HABPB.
 Focus 2. unfold implA, andA, negA. firstorder.
 setoid_replace (B ->> [Iteration  (A ?; p)]((¬A)  ->> ((¬A) /| B)))
 with (B ->> [(Iteration  (A ?; p))][(¬A)?]((¬A) /| B)) in HABPB.
 Focus 2. rewrite axiom_VI. reflexivity.
 rewrite <- axiom_V in HABPB. apply HABPB.
 Qed.

 Theorem weaken_rule : forall (A' A B B' : assertion) (p : prog),
 ||=(A' ->> A) -> ||=(hoare_triple A p B) ->
    ||=(B ->> B') -> ||=(hoare_triple A' p B').
 Proof.
 intros A' A B B' p HIA HAB HIB. unfold hoare_triple in *.
 rewrite implIntro in *. rewrite HIA, HAB, HIB. reflexivity.
 Qed.
End DL.


Require Import Ashley.Axioms.
Require Import Ashley.PartialOrder.
Require Import Ashley.Set.
Require Import Ashley.Category.

(* set_type takes a set and turns it into a type *)
Inductive set_type {A:Type} (s:A -> Type) : Type :=
  stc : forall (x:A), s x -> set_type s.

Definition val {A: Type} {s: A -> Type} (sv: set_type s): A.
destruct sv.
exact x.
Defined.

Definition stc' : forall {A:Type} {s:A -> Type} (x:A), s x -> set_type s.
intros.
apply (stc s x X).
Defined.

Lemma val_stc: forall {A:Type} (s:A -> Type) (v:A) (st:s v), val (stc s v st) = v.
unfold val.
trivial.
Qed.

Definition struct {A} {s:A -> Type} (st:set_type s): s (val st).
unfold val.
destruct st.
exact s0.
Defined.

(*
Inductive same (A B: Type) (a:A) (b:B): Type:=
  is_same: forall (T:Type) (a' b':A), a' = b' -> same T T a' b'.
*)
Definition converter: forall {T:Type} {A B: T} {f: T -> Type}, (A = B) -> f A -> f B.
intros.
rewrite <- H.
exact X.
Defined.

Lemma converter_eq: forall {T} {A} {f: T -> Type} {proof} (x: f A), converter proof x = x.
intros.
unfold converter. unfold eq_rect.
cut (proof = eq_refl).
intro.
rewrite H.
trivial.
apply proof_irrelevance.
Qed.

Lemma exist_ext: forall {A} (s: A -> Type) (p q: set_type s) (proof: val p = val q),
  ((converter proof (struct p)) = struct q) -> p = q.
intros.
destruct p.
destruct q.
unfold val in proof.
subst x.
unfold converter in H.
unfold struct in H.
unfold val in H.
unfold eq_rect in H.
rewrite H.
trivial.
Defined.

Lemma set_type_ext: forall {A} (s: A -> Prop) (p q: set_type s), (val p = val q) -> p = q.
intros.
apply (exist_ext s p q H).
apply proof_irrelevance.
Defined.

Lemma set_type_ext_eq: forall {A} (s: A -> Prop) (p q: set_type s), (val p = val q) = (p = q).
intros.
apply prop_ext. split.
apply set_type_ext.
intros.
rewrite H.
trivial.
Qed.

Variable Te : Type.
Variable Ve : Te.
Definition Se : set Te := fun x => x = Ve.

Definition eConstruct: set_type Se.
apply (stc Se Ve).
unfold Se.
trivial.
Defined.

Lemma eCheck: val eConstruct = Ve.
unfold eConstruct.
unfold val.
trivial.
Qed.

Instance subset_category A : Category (set A) :=
{
  hom sA sB := set_type sA -> set_type sB;
  id A := (fun p => p);
  compose A B C mbc mab a := mbc (mab a)
}.
intros.
apply fun_ext.
trivial.
intros.
apply fun_ext.
trivial.
intros.
apply fun_ext.
trivial.
Defined.

Lemma not_in_empty : forall A, forall a : set_type (empty : set A), False.
firstorder.
Qed.

Lemma subset_transitive : forall {A} {a b c: set A}, b <= c -> a <= b -> a <= c.
unfold subset.
intro.
intro.
intro.
intro.
apply within_trans.
Qed.

Instance inclusion_Preorder {A} (open : set (set A)) : Preorder (set_type open) :=
{
  within sv1 sv2 := (val sv1) <= (val sv2)
}.
intros.
apply within_reflex.
intros.
apply (within_trans (val p) (val q) (val r)).
exact H.
exact H0.
Defined.

Instance inclusion_PartialOrder {A} (open : set (set A)) : PartialOrder (set_type open) :=
{
}.
intros.
apply set_type_ext.
apply within_antisym.
exact H.
exact H0.
Defined.

Definition inclusion_category {A} (open : set (set A)) : Category (set_type open) :=
  Preorder_Category (inclusion_Preorder open).

Definition subset_type {A} (s : set A) : Type := set_type (superset s).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Omega Permutation.

Require Import list_focus utils_tac list_perm.

Set Implicit Arguments.

Create HintDb length_db.

Tactic Notation "rew" "length" := autorewrite with length_db.
Tactic Notation "rew" "length" "in" hyp(H) := autorewrite with length_db in H.

Local Infix "~p" := (@Permutation _) (at level 70).

Section In_t.

  Variable (X : Type).

  Fixpoint In_t (x : X) ll : Type :=
    match ll with
      | nil   => False
      | y::ll => ((x = y) + In_t x ll)%type
    end.

End In_t.

Section Forall_type_rect.

  Variable (X : Type) (P : X -> Type) (Q : list X -> Type)
           (HQ0 : Q nil) (HQ1 : forall x l, P x -> (forall y, In_t y l -> P y) -> Q l -> Q (x::l)).

  Theorem Forall_type_rect l : (forall x, In_t x l -> P x) -> Q l.
  Proof.
    induction l as [ | x l IHl ]; intros Hl.
    + apply HQ0.
    + apply HQ1.
      1,2: intros; apply Hl; simpl; auto.
      apply IHl.
      intros; apply Hl; simpl; auto.
  Qed.

End Forall_type_rect.

Fact Permutation_map_inv X Y (f : X -> Y) l m : map f l ~p m -> exists l', m = map f l' /\ l ~p l'.
Proof.
  assert (forall m1 m2, m1 ~p m2 -> forall l1, m1 = map f l1 -> exists l2, m2 = map f l2 /\ l1 ~p l2) as L.
  + induction 1 as [ | y m1 m2 H1 IH1 | y1 y2 m1 | m1 m2 m3 H1 IH1 H2 IH2 ].
    * intros [ | ]; exists nil; auto; discriminate.
    * intros [ | x l1 ]; simpl; try discriminate.
      intros H2; injection H2; clear H2; intros H2 H3; subst y.
      destruct (IH1 _ H2) as (l2 & ? & ?).
      exists (x::l2); simpl; subst; auto.
    * intros [ | x2 [ | x1 l1 ] ]; try discriminate; simpl.
      intros H2; injection H2; clear H2; intros H1 H2 H3; subst.
      exists (x1::x2::l1); simpl; split; auto; constructor.
    * intros l1 H3.
      destruct IH1 with (1 := H3) as (l2 & H4 & H5).
      destruct IH2 with (1 := H4) as (l3 & H6 & H7).
      exists l3; split; auto.
      constructor 4 with l2; auto.
  + intros H1; apply L with (2 := eq_refl); auto.
Qed.

Section Permutation_map_inv_t.

  Variable (X Y : Type) (eqY_dec : forall x y : Y, { x = y } + { x <> y }) (f : X -> Y).

  Let Q m1 m2 := forall l1, m1 = map f l1 -> { l2 | m2 = map f l2 /\ l1 ~p l2}.

  Let pmit : forall m1 m2, m1 ~p m2 -> Q m1 m2.
  Proof.
    apply Permutation_rect with (1 := eqY_dec); unfold Q; clear Q.
    * intros [ | ]; exists nil; auto; discriminate.
    * intros y m1 m2 H1 IH1 [ | x l1 ]; simpl; try discriminate.
      intros H2; injection H2; clear H2; intros H2 H3; subst y.
      destruct (IH1 _ H2) as (l2 & ? & ?).
      exists (x::l2); simpl; subst; auto.
    * intros y1 y2 m1 [ | x2 [ | x1 l1 ] ]; try discriminate; simpl.
      intros H2; injection H2; clear H2; intros H1 H2 H3; subst.
      exists (x1::x2::l1); simpl; split; auto; constructor.
    * intros m1 m2 m3 H1 IH1 H2 IH2 l1 H3.
      destruct IH1 with (1 := H3) as (l2 & H4 & H5).
      destruct IH2 with (1 := H4) as (l3 & H6 & H7).
      exists l3; split; auto.
      constructor 4 with l2; auto.
  Qed.

  Fact Permutation_map_inv_t l m : map f l ~p m -> { l' | m = map f l' /\ l ~p l' }.
  Proof. intro; apply pmit with (2 := eq_refl); auto. Qed.

End Permutation_map_inv_t.

Section length.

  Variable X : Type.

  Implicit Type l : list X.

  Fact length_nil : length (@nil X) = 0.
  Proof. auto. Qed.

  Fact length_cons x l : length (x::l) = S (length l).
  Proof. auto. Qed.

End length.

Hint Rewrite length_nil length_cons app_length map_length rev_length : length_db.

Section list_an.

  Fixpoint list_an a n :=
    match n with
      | 0   => nil
      | S n => a::list_an (S a) n
    end.

  Fact list_an_S a n : list_an a (S n) = a::list_an (S a) n.
  Proof. auto. Qed.

  Fact list_an_plus a n m : list_an a (n+m) = list_an a n ++ list_an (n+a) m.
  Proof.
    revert a; induction n; intros a; simpl; auto.
    rewrite IHn; do 3 f_equal; omega.
  Qed.

  Fact list_an_length a n : length (list_an a n) = n.
  Proof.
    revert a; induction n; intro; simpl; f_equal; auto.
  Qed.

  Fact list_an_spec a n m : In m (list_an a n) <-> a <= m < a+n.
  Proof.
    revert a; induction n as [ | n IHn ]; simpl; intros a; [ | rewrite IHn ]; omega.
  Qed.

  Fact map_S_list_an a n : map S (list_an a n) = list_an (S a) n.
  Proof. revert a; induction n; simpl; intro; f_equal; auto. Qed.

  Fact list_an_app_inv a n l r : list_an a n = l++r -> l = list_an a (length l) /\ r = list_an (a+length l) (length r).
  Proof.
    revert a l r; induction n as [ | n IHn ]; intros a l r; simpl.
    + destruct l; destruct r; intros; auto; discriminate.
    + destruct l as [ | x l ]; simpl; intros H1.
      * split; auto.
        rewrite <- H1; simpl; rewrite Nat.add_0_r, list_an_length; auto.
      * injection H1; clear H1; intros H1 H0.
        apply IHn in H1; destruct H1; split; f_equal; auto.
        rewrite H1 at 1; f_equal; omega.
  Qed.

End list_an.

Hint Rewrite list_an_length : length_db.

Section list_injective.

  Variable X : Type.

  Definition list_injective (ll : list X) :=  forall l a m b r, ll = l ++ a :: m ++ b :: r -> a <> b.

  Fact in_list_injective_0 : list_injective nil.
  Proof. intros [] ? ? ? ? ?; discriminate. Qed.

  Fact in_list_injective_1 x ll : ~ In x ll -> list_injective ll -> list_injective (x::ll).
  Proof.
    intros H1 H2 l a m b r H3.
    destruct l as [ | u l ].
    inversion H3; subst.
    destruct m as [ | v m ].
    contradict H1; subst; simpl; auto.
    contradict H1; subst; simpl; right; apply in_or_app; right; left; auto.
    inversion H3; subst.
    apply (H2 l _ m _ r); auto.
  Qed.

  Fact list_injective_inv x ll : list_injective (x::ll) -> ~ In x ll /\ list_injective ll.
  Proof.
    split.
    intros H1; apply in_split in H1; destruct H1 as (l & r & ?); subst.
    apply (H nil x l x r); auto.
    intros l a m b r ?; apply (H (x::l) a m b r); subst; solve list eq.
  Qed.

  Variable P : list X -> Type.

  Hypothesis (HP0 : P nil).
  Hypothesis (HP1 : forall x l, ~ In x l -> P l -> P (x::l)).

  Theorem list_injective_rect l : list_injective l -> P l.
  Proof.
    induction l as [ [ | x l ] IHl ] using (measure_rect (@length _)).
    intro; apply HP0.
    intros; apply HP1.
    apply list_injective_inv, H.
    apply IHl; simpl; auto.
    apply list_injective_inv with (1 := H).
  Qed.

End list_injective.

Fact list_injective_map X Y (f : X -> Y) ll :
       (forall x y, f x = f y -> x = y) -> list_injective ll -> list_injective (map f ll).
Proof.
  intros Hf.
  induction 1 as [ | x l Hl IHl ] using list_injective_rect.
  apply in_list_injective_0.
  simpl; apply in_list_injective_1; auto.
  contradict Hl.
  apply in_map_iff in Hl.
  destruct Hl as (y & Hl & ?).
  apply Hf in Hl; subst; auto.
Qed.

Section iter.

  Variable (X : Type) (f : X -> X).

  Fixpoint iter x n :=
    match n with
      | 0   => x
      | S n => iter (f x) n
    end.

  Fact iter_plus x a b : iter x (a+b) = iter (iter x a) b.
  Proof. revert x; induction a; intros x; simpl; auto. Qed.

End iter.

Fixpoint list_repeat X (x : X) n :=
  match n with
    | 0   => nil
    | S n => x::list_repeat x n
  end.

Fact list_repeat_plus X x a b : @list_repeat X x (a+b) = list_repeat x a ++ list_repeat x b.
Proof. induction a; simpl; f_equal; auto. Qed.

Fact list_repeat_length X x n : length (@list_repeat X x n) = n.
Proof. induction n; simpl; f_equal; auto. Qed.

Fact In_list_repeat X (x y : X) n : In y (list_repeat x n) -> x = y /\ 0 < n.
Proof.
  induction n; simpl; intros [].
  split; auto; omega.
  split; try omega; apply IHn; auto.
Qed.

Fact map_list_repeat X Y f x n : @map X Y f (list_repeat x n) = list_repeat (f x) n.
Proof. induction n; simpl; f_equal; auto. Qed.

Fact map_cst_repeat X Y (y : Y) ll : map (fun _ : X => y) ll = list_repeat y (length ll).
Proof. induction ll; simpl; f_equal; auto. Qed.

Fact map_cst_snoc X Y (y : Y) ll mm : y :: map (fun _ : X => y) ll++mm = map (fun _ => y) ll ++ y::mm.
Proof. induction ll; simpl; f_equal; auto. Qed.

Fact map_cst_rev  X Y (y : Y) ll : map (fun _ : X => y) (rev ll) = map (fun _ => y) ll.
Proof. do 2 rewrite map_cst_repeat; rewrite rev_length; auto. Qed.

Fact In_perm X (x : X) l : In x l -> exists m, x::m ~p l.
Proof.
  intros H; apply in_split in H.
  destruct H as (m & k & ?); subst.
  exists (m++k).
  apply Permutation_cons_app; auto.
Qed.

Fact list_app_eq_inv X (l1 l2 r1 r2 : list X) :
       l1++r1 = l2++r2 -> { m | l1++m = l2 /\ r1 = m++r2 }
                        + { m | l2++m = l1 /\ r2 = m++r1 }.
Proof.
  revert l2 r1 r2; induction l1 as [ | x l1 IH ].
  intros; left; exists l2; auto.
  intros [ | y l2 ] r1 r2; simpl; intros H.
  right; exists (x::l1); auto.
  inversion H.
  destruct (IH l2 r1 r2) as [ (m & Hm) | (m & Hm) ]; auto;
    [ left | right ]; exists m; split; f_equal; tauto.
Qed.

Fact list_app_cons_eq_inv X (l1 l2 r1 r2 : list X) x :
       l1++r1 = l2++x::r2 -> { m | l1++m = l2 /\ r1 = m++x::r2 }
                           + { m | l2++x::m = l1 /\ r2 = m++r1 }.
Proof.
  intros H.
  apply list_app_eq_inv in H.
  destruct H as [ H | (m & H1 & H2) ]; auto.
  destruct m as [ | y m ].
  left; exists nil; simpl in *; split; auto.
  revert H1; do 2 rewrite <- app_nil_end; auto.
  inversion H2; subst.
  right; exists m; auto.
Qed.

Fact list_app_inj X (l1 l2 r1 r2 : list X) : length l1 = length l2 -> l1++r1 = l2++r2 -> l1 = l2 /\ r1 = r2.
Proof.
  revert l2; induction l1 as [ | x l1 IH ]; intros [ | y l2 ]; try discriminate.
  simpl; auto.
  intros H1 H2; inversion H1; inversion H2.
  apply IH in H4; auto.
  split; f_equal; tauto.
Qed.

Fact list_split_length X (ll : list X) k : k <= length ll -> { l : _ & { r | ll = l++r /\ length l = k } }.
Proof.
  revert k; induction ll as [ | x ll IHll ]; intros k.
  exists nil, nil; split; simpl in * |- *; auto; omega.
  destruct k as [ | k ]; intros Hk.
  exists nil, (x::ll); simpl; split; auto.
  destruct (IHll k) as (l & r & H1 & H2).
  simpl in Hk; omega.
  exists (x::l), r; split; simpl; auto; f_equal; auto.
Qed.

Fact list_pick X (ll : list X) k : k < length ll -> { x : _ & { l : _ & { r | ll = l++x::r /\ length l = k } } }.
Proof.
  revert k; induction ll as [ | x ll IHll ]; intros k.
  simpl; omega.
  destruct k as [ | k ]; intros H.
  exists x, nil, ll; simpl; auto.
  simpl in H.
  destruct IHll with (k := k) as (y & l & r & ? & ?); try omega.
  exists y, (x::l), r; subst; simpl; split; auto.
Qed.

Fact list_split_middle X l1 (x1 : X) r1 l2 x2 r2 :
       ~ In x1 l2 -> ~ In x2 l1 -> l1++x1::r1 = l2++x2::r2 -> l1 = l2 /\ x1 = x2 /\ r1 = r2.
Proof.
  intros H1 H2 H.
  apply list_app_eq_inv in H.
  destruct H as [ (m & H3 & H4) | (m & H3 & H4) ]; destruct m.
  inversion H4; subst; rewrite <- app_nil_end; auto.
  inversion H4; subst; destruct H1; apply in_or_app; right; left; auto.
  inversion H4; subst; rewrite <- app_nil_end; auto.
  inversion H4; subst; destruct H2; apply in_or_app; right; left; auto.
Qed.

Section flat_map.

  Variable (X Y : Type) (f : X -> list Y).

  Fact flat_map_app l1 l2 : flat_map f (l1++l2) = flat_map f l1 ++ flat_map f l2.
  Proof.
    induction l1; simpl; auto; solve list eq; f_equal; auto.
  Qed.

  Fact flat_map_app_inv l r1 y r2 : flat_map f l = r1++y::r2 -> exists l1 m1 x m2 l2, l = l1++x::l2 /\ f x = m1++y::m2
                                                                  /\ r1 = flat_map f l1++m1 /\ r2 = m2++flat_map f l2.
  Proof.
    revert r1 y r2.
    induction l as [ | x l IHl ]; intros r1 y r2 H.
    + destruct r1; discriminate.
    + simpl in H.
      apply list_app_cons_eq_inv in H.
      destruct H as [ (m & Hm1 & Hm2) | (m & Hm1 & Hm2) ].
      - apply IHl in Hm2.
        destruct Hm2 as (l1 & m1 & x' & m2 & l2 & G1 & G2 & G3 & G4); subst.
        exists (x::l1), m1, x', m2, l2; simpl; repeat (split; auto).
        rewrite app_ass; auto.
      - exists nil, r1, x, m, l; auto.
  Qed.

End flat_map.

Definition prefix X (l ll : list X) := exists r, ll = l++r.

Infix "<p" := (@prefix _) (at level 70, no associativity).

Section prefix. (* as an inductive predicate *)

  Variable X : Type.

  Implicit Types (l ll : list X).

  Fact in_prefix_0 ll : nil <p ll.
  Proof.
    exists ll; auto.
  Qed.

  Fact in_prefix_1 x l ll : l <p ll -> x::l <p x::ll.
  Proof.
    intros (r & ?); subst; exists r; auto.
  Qed.

  Fact prefix_length l m : l <p m -> length l <= length m.
  Proof. intros (? & ?); subst; rew length; omega. Qed.

  Fact prefix_app_lft l r1 r2 : r1 <p r2 -> l++r1 <p l++r2.
  Proof.
    intros (a & ?); subst.
    exists a; rewrite app_ass; auto.
  Qed.

  Fact prefix_inv x y l ll : x::l <p y::ll -> x = y /\ l <p ll.
  Proof.
    intros (r & Hr).
    inversion Hr; split; auto.
    exists r; auto.
  Qed.

  Fact prefix_list_inv l r rr : l++r <p l++rr -> r <p rr.
  Proof.
    induction l as [ | x l IHl ]; simpl; auto.
    intros H; apply prefix_inv, proj2, IHl in H; auto.
  Qed.

  Fact prefix_refl l : l <p l.
  Proof. exists nil; rewrite <- app_nil_end; auto. Qed.

  Fact prefix_trans l1 l2 l3 : l1 <p l2 -> l2 <p l3 -> l1 <p l3.
  Proof. intros (m1 & H1) (m2 & H2); subst; exists (m1++m2); solve list eq. Qed.

  Section prefix_rect.

    Variables (P : list X -> list X -> Type)
              (HP0 : forall ll, P nil ll)
              (HP1 : forall x l ll, l <p ll -> P l ll -> P (x::l) (x::ll)).

    Definition prefix_rect l ll : prefix l ll -> P l ll.
    Proof.
      revert l; induction ll as [ | x ll IHll ]; intros l H.

      replace l with (nil : list X).
      apply HP0.
      destruct H as (r & Hr).
      destruct l; auto; discriminate.

      destruct l as [ | y l ].
      apply HP0.
      apply prefix_inv in H.
      destruct H as (? & E); subst y.
      apply HP1; [ | apply IHll ]; trivial.
    Qed.

  End prefix_rect.

  Fact prefix_app_inv l1 l2 r1 r2 : l1++l2 <p r1++r2 -> { l1 <p r1 } + { r1 <p l1 }.
  Proof.
    revert l2 r1 r2; induction l1 as [ | x l1 IH ].
    left; apply in_prefix_0.
    intros l2 [ | y r1 ] r2.
    right; apply in_prefix_0.
    simpl; intros H; apply prefix_inv in H.
    destruct H as (E & H); subst y.
    destruct IH with (1 := H); [ left | right ];
      apply in_prefix_1; auto.
  Qed.

End prefix.

Definition prefix_spec X (l ll : list X) : l <p ll -> { r | ll = l ++ r }.
Proof.
  induction 1 as [ ll | x l ll _ (r & Hr) ] using prefix_rect.
  exists ll; trivial.
  exists r; simpl; f_equal; auto.
Qed.

Fact prefix_app_lft_inv X (l1 l2 m : list X) : l1++l2 <p m -> { m2 | m = l1++m2 /\ l2 <p m2 }.
Proof.
  intros H.
  apply prefix_spec in H.
  destruct H as (r & H).
  exists (l2++r); simpl.
  solve list eq in H; split; auto.
  exists r; auto.
Qed.

Section list_assoc.

  Variables (X Y : Type) (eq_X_dec : eqdec X).

  Fixpoint list_assoc x l : option Y :=
    match l with
      | nil  => None
      | (y,a)::l => if eq_X_dec x y then Some a else list_assoc x l
    end.

  Fact list_assoc_eq x y l x' : x = x' -> list_assoc x' ((x,y)::l) = Some y.
  Proof.
    intros []; simpl.
    destruct (eq_X_dec x x) as [ | [] ]; auto.
  Qed.

  Fact list_assoc_neq x y l x' : x <> x' -> list_assoc x' ((x,y)::l) = list_assoc x' l.
  Proof.
    intros H; simpl.
    destruct (eq_X_dec x' x) as [ | ]; auto.
    destruct H; auto.
  Qed.

  Fact list_assoc_In x l :
    match list_assoc x l with
      | None   => ~ In x (map fst l)
      | Some y => In (x,y) l
    end.
  Proof.
    induction l as  [ | (x',y) l IHl ]; simpl; auto.
    destruct (eq_X_dec x x'); subst; auto.
    destruct (list_assoc x l); auto.
    intros [ ? | ]; subst; tauto.
  Qed.

  Fact In_list_assoc x l : In x (map fst l) -> { y | list_assoc x l = Some y /\ In (x,y) l }.
  Proof.
    intros H.
    generalize (list_assoc_In x l).
    destruct (list_assoc x l) as [ y | ].
    exists y; auto.
    tauto.
  Qed.

  Fact not_In_list_assoc x l : ~ In x (map fst l) -> list_assoc x l = None.
  Proof.
    intros H.
    generalize (list_assoc_In x l).
    destruct (list_assoc x l) as [ y | ]; auto.
    intros H1; contradict H.
    apply in_map_iff.
    exists (x,y); simpl; auto.
  Qed.

  Fact list_assoc_app x ll mm : list_assoc x (ll++mm)
                              = match list_assoc x ll with
                                  | None   => list_assoc x mm
                                  | Some y => Some y
                                end.
  Proof.
    induction ll as [ | (x',?) ]; simpl; auto.
    destruct (eq_X_dec x x'); auto.
  Qed.

End list_assoc.

Section list_first_dec.

  Variable (X : Type) (P : X -> Prop) (Pdec : forall x, { P x } + { ~ P x }).

  Theorem list_choose_dec ll : { l : _ & { x : _ & { r | ll = l++x::r /\ P x /\ forall y, In y l -> ~ P y } } }
                             + { forall x, In x ll -> ~ P x }.
  Proof.
    induction ll as [ | a ll IH ];
      [ | destruct (Pdec a) as [ Ha | Ha ]; [ | destruct IH as [ (l & x & r & H1 & H2 & H3) | H ]] ].
    * right; intros _ [].
    * left; exists nil, a, ll; repeat split; auto.
    * left; exists (a::l), x, r; repeat split; subst; auto.
      intros ? [ | ]; subst; auto.
    * right; intros ? [ | ]; subst; auto.
  Qed.

  Theorem list_first_dec a ll : P a -> In a ll -> { l : _ & { x : _ & { r | ll = l++x::r /\ P x /\ forall y, In y l -> ~ P y } } }.
  Proof.
    intros H1 H2.
    destruct (list_choose_dec ll) as [ H | H ]; trivial.
    destruct (H _ H2 H1).
  Qed.

End list_first_dec.

Section map.

  Variable (X Y : Type) (f : X -> Y).

  Fact map_cons_inv ll y m : map f ll = y::m -> { x : _ & { l | ll = x::l /\ f x = y /\ map f l = m } }.
  Proof.
    destruct ll as [ | x l ]; try discriminate; simpl.
    intros H; inversion H; subst; exists x, l; auto.
  Qed.

  Fact map_app_inv ll m n : map f ll = m++n -> { l : _  & { r | ll = l++r /\ m = map f l /\ n = map f r } }.
  Proof.
    revert m n; induction ll as [ | x ll IH ]; intros m n H.
    * destruct m; destruct n; try discriminate; exists nil, nil; auto.
    * destruct m as [ | y m ]; simpl in H.
      + exists nil, (x::ll); auto.
      + inversion H; subst y.
        destruct IH with (1 := H2) as (l & r & H3 & H4 & H5); subst.
        exists (x::l), r; auto.
  Qed.

  Fact map_middle_inv ll m y n : map f ll = m++y::n -> { l : _ & { x : _ & { r | ll = l++x::r /\ map f l = m /\ f x = y /\ map f r = n } } }.
  Proof.
    intros H.
    destruct map_app_inv with (1 := H) as (l & r & H1 & H2 & H3).
    symmetry in H3.
    destruct map_cons_inv with (1 := H3) as (x & r' & H4 & H5 & H6); subst.
    exists l, x, r'; auto.
  Qed.

End map.

Fact Forall2_mono X Y (R S : X -> Y -> Prop) :
         (forall x y, R x y -> S x y) -> forall l m, Forall2 R l m -> Forall2 S l m.
Proof.
  induction 2; constructor; auto.
Qed.

Fact Forall2_nil_inv_l X Y R m : @Forall2 X Y R nil m -> m = nil.
Proof.
  inversion_clear 1; reflexivity.
Qed.

Fact Forall2_nil_inv_r X Y R m : @Forall2 X Y R m nil -> m = nil.
Proof.
  inversion_clear 1; reflexivity.
Qed.

Fact Forall2_cons_inv X Y R x l y m : @Forall2 X Y R (x::l) (y::m) <-> R x y /\ Forall2 R l m.
Proof.
  split.
  inversion_clear 1; auto.
  intros []; constructor; auto.
Qed.

Fact Forall2_app_inv_l X Y R l1 l2 m :
    @Forall2 X Y R (l1++l2) m -> { m1 : _ & { m2 | Forall2 R l1 m1 /\ Forall2 R l2 m2 /\ m = m1++m2 } }.
Proof.
  revert l2 m;
  induction l1 as [ | x l1 IH ]; simpl; intros l2 m H.
  exists nil, m; repeat split; auto.
  destruct m as [ | y m ].
  apply Forall2_nil_inv_r in H; discriminate H.
  apply Forall2_cons_inv in H; destruct H as [ H1 H2 ].
  apply IH in H2.
  destruct H2 as (m1 & m2 & H2 & H3 & H4); subst m.
  exists (y::m1), m2; repeat split; auto.
Qed.

Fact Forall2_app_inv_r X Y R l m1 m2 :
    @Forall2 X Y R l (m1++m2) -> { l1 : _ & { l2 | Forall2 R l1 m1 /\ Forall2 R l2 m2 /\ l = l1++l2 } }.
Proof.
  revert m2 l;
  induction m1 as [ | y m1 IH ]; simpl; intros m2 l H.
  exists nil, l; repeat split; auto.
  destruct l as [ | x l ].
  apply Forall2_nil_inv_l in H; discriminate H.
  apply Forall2_cons_inv in H; destruct H as [ H1 H2 ].
  apply IH in H2.
  destruct H2 as (l1 & l2 & H2 & H3 & H4); subst l.
  exists (x::l1), l2; repeat split; auto.
Qed.

Fact Forall2_cons_inv_l X Y R a ll mm :
      @Forall2 X Y R (a::ll) mm
   -> { b : _ & { mm' | R a b /\ mm = b::mm' /\ Forall2 R ll mm' } }.
Proof.
  intros H.
  apply Forall2_app_inv_l with (l1 := a::nil) (l2 := ll) in H.
  destruct H as (l & mm' & H1 & H2 & H3).
  destruct l as [ | y l ].
  exfalso; inversion H1.
  apply Forall2_cons_inv in H1.
  destruct H1 as [ H1 H4 ].
  apply Forall2_nil_inv_l in H4; subst l.
  exists y, mm'; auto.
Qed.

Fact Forall2_cons_inv_r X Y R b ll mm :
      @Forall2 X Y R ll (b::mm)
   -> { a : _ & { ll' | R a b /\ ll = a::ll' /\ Forall2 R ll' mm } }.
Proof.
  intros H.
  apply Forall2_app_inv_r with (m1 := b::nil) (m2 := mm) in H.
  destruct H as (l & ll' & H1 & H2 & H3).
  destruct l as [ | x l  ].
  exfalso; inversion H1.
  apply Forall2_cons_inv in H1.
  destruct H1 as [ H1 H4 ].
  apply Forall2_nil_inv_r in H4; subst l.
  exists x, ll'; auto.
Qed.

Fact Forall2_map_left X Y Z (R : Y -> X -> Prop) (f : Z -> Y) ll mm : Forall2 R (map f ll) mm <-> Forall2 (fun x y => R (f x) y) ll mm.
Proof.
  split.
  revert mm.
  induction ll; intros [ | y mm ] H; simpl in H; auto; try (inversion H; fail).
  apply Forall2_cons_inv in H; constructor.
  tauto.
  apply IHll; tauto.
  induction 1; constructor; auto.
Qed.

Fact Forall2_map_right X Y Z (R : Y -> X -> Prop) (f : Z -> X) mm ll : Forall2 R mm (map f ll) <-> Forall2 (fun y x => R y (f x)) mm ll.
Proof.
  split.
  revert mm.
  induction ll; intros [ | y mm ] H; simpl in H; auto; try (inversion H; fail).
  apply Forall2_cons_inv in H; constructor.
  tauto.
  apply IHll; tauto.
  induction 1; constructor; auto.
Qed.

Fact Forall2_map_both X Y X' Y' (R : X -> Y -> Prop) (f : X' -> X) (g : Y' -> Y) ll mm : Forall2 R (map f ll) (map g mm) <-> Forall2 (fun x y => R (f x) (g y)) ll mm.
Proof.
  rewrite Forall2_map_left, Forall2_map_right; split; auto.
Qed.

Fact Forall2_Forall X (R : X -> X -> Prop) ll : Forall2 R ll ll <-> Forall (fun x => R x x) ll.
Proof.
  split.
  induction ll as [ | x ll ]; inversion_clear 1; auto.
  induction 1; auto.
Qed.

Fact Forall_app X (P : X -> Prop) ll mm : Forall P (ll++mm) <-> Forall P ll /\ Forall P mm.
Proof.
  repeat rewrite Forall_forall.
  split.
  firstorder.
  intros (H1 & H2) x Hx.
  apply in_app_or in Hx; firstorder.
Qed.

Fact Forall_cons_inv X (P : X -> Prop) x ll : Forall P (x::ll) <-> P x /\ Forall P ll.
Proof.
  split.
  + inversion 1; auto.
  + constructor; tauto.
Qed.

Fact Forall_rev X (P : X -> Prop) ll : Forall P ll -> Forall P (rev ll).
Proof.
  induction 1 as [ | x ll Hll IH ].
  constructor.
  simpl.
  apply Forall_app; split; auto.
Qed.

Fact Forall_map X Y (f : X -> Y) (P : Y -> Prop) ll : Forall P (map f ll) <-> Forall (fun x => P (f x)) ll.
Proof.
  split.
  + induction ll; simpl; try rewrite Forall_cons_inv; constructor; tauto.
  + induction 1; simpl; constructor; auto.
Qed.

Fact Forall_impl X (P Q : X -> Prop) ll : (forall x, In x ll -> P x -> Q x) -> Forall P ll -> Forall Q ll.
Proof.
  intros H; induction 1 as [ | x ll Hx Hll IH ]; constructor.
  + apply H; simpl; auto.
  + apply IH; intros ? ?; apply H; simpl; auto.
Qed.

Fact Forall_filter X (P : X -> Prop) (f : X -> bool) ll : Forall P ll -> Forall P (filter f ll).
Proof. induction 1; simpl; auto; destruct (f x); auto. Qed.


(* A general purpose array indexed by an arbitrary type *)

Set Implicit Arguments.
Require Import Crypto.
Require Import Fold.

Local Open Scope list_scope.

Section ListArray.

  Variable D R : Set.
  Hypothesis D_EqDec : EqDec D.

  Definition Array := list (D * R).

  Fixpoint arrayLookup(ls : list (D * R)) d :=
    match ls with
      | nil => None
      | (d', r') :: ls' =>
        if (eqb d d')
          then Some r'
          else (arrayLookup ls' d)
    end.

  Definition arrayEquiv(arr1 arr2 : Array) :=
    forall d,
      (arrayLookup arr1 d) = (arrayLookup arr2 d).

  Definition arrayLookupDef(ls : list (D * R)) d def :=
    match arrayLookup ls d with
        | None => def
        | Some r => r
    end.

  Definition arrayUpdate (arr_opt : option Array) d r_opt :=
    let arr := match arr_opt with
                 | None => nil
                 | Some arr => arr
               end in
    match r_opt with
        | None => arr
        | Some r =>
          (d, r) :: arr
    end.

  Lemma arrayLookup_app_some_eq : forall ls d v,
    arrayLookup ls d = None ->
    arrayLookup (ls ++ (d, v) :: nil) d = Some v.

    induction ls; intuition; simpl in *.
    rewrite eqb_refl.
    trivial.

    case_eq (eqb d a0); intuition;
      rewrite H0 in H.
    discriminate.
    eauto.

  Qed.

  Lemma arrayLookup_app_none : forall ls d d' v',
    arrayLookup ls d = None ->
    arrayLookup (ls ++ (d, v') :: nil) d' = arrayLookup ((d, v') :: ls) d'.

    induction ls; intuition; simpl in *.

    case_eq (eqb d a0); intuition;
    rewrite H0 in H.
    discriminate.
    case_eq (eqb d' d); intuition.
    rewrite eqb_leibniz in H1.
    subst.
    case_eq (eqb d a0); intuition.
    rewrite eqb_leibniz in H1.
    subst.
    rewrite eqb_refl in H0.
    discriminate.

    eapply arrayLookup_app_some_eq.
    trivial.

    specialize (IHls d d').
    case_eq (eqb d' a0); intuition.
    rewrite H1 in IHls.
    eapply IHls.
    trivial.

  Qed.

  Lemma arrayLookup_app_ne : forall ls d r d',
    d <> d' ->
    arrayLookup (ls ++ (d, r) :: nil) d' = arrayLookup ls d'.

    induction ls; intuition; simpl in *.
    case_eq (eqb d' d); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.

    case_eq (eqb d' a0); intuition.

  Qed.

  Lemma arrayLookup_app_some : forall ls d d' v v',
    arrayLookup ls d = Some v ->
    arrayLookup (ls ++ (d, v') :: nil) d' = arrayLookup ls d'.

    induction ls; intuition; simpl in *.
    discriminate.

    case_eq (eqb d a0); intuition.
    rewrite H0 in H.
    inversion H; clear H; subst.
    rewrite eqb_leibniz in H0. subst.
    case_eq (eqb d' a0); intuition.

    eapply arrayLookup_app_ne.
    intuition.
    subst.
    rewrite eqb_refl in H.
    discriminate.
    rewrite H0 in H.

    case_eq (eqb d' a0); intuition.
    eapply IHls; eauto.
  Qed.

  Theorem arrayLookup_arrayUpdate_eq :
    forall arr p v,
      arrayLookup (arrayUpdate arr p (Some v)) p = (Some v).

    intuition.
    unfold arrayUpdate.
    destruct arr.
    simpl.
    rewrite eqb_refl.
    trivial.

    simpl.
    rewrite eqb_refl.
    trivial.
  Qed.

   Theorem arrayLookup_arrayUpdate_ne :
    forall arr p1 p2 v,
      p1 <> p2 ->
      arrayLookup (arrayUpdate (Some arr) p1 (Some v)) p2 = arrayLookup arr p2.

    intuition.
    unfold arrayUpdate.
    simpl.
    case_eq (eqb p2 p1); intuition.
    rewrite eqb_leibniz in H0.
    subst.
    intuition.
  Qed.

   Theorem arrayLookup_arrayUpdate_None_ne :
     forall p1 p2 v,
       p1 <> p2 ->
       arrayLookup (arrayUpdate None p1 (Some v)) p2 = None.

     intuition.
     unfold arrayUpdate.
     simpl.
     case_eq (eqb p2 p1); intuition.
     rewrite eqb_leibniz in H0.
     subst.
     intuition.
  Qed.

End ListArray.

(* Some notation for array lookups *)
Notation "f '#' i " := (arrayLookup _ f i) (at level 70) : array_scope.

Local Open Scope array_scope.

(* A special case for array lookup when the range is lists -- returns nil instead of None when not found.  This is useful for multidimensional arrays. *)
Definition arrayLookupList(A B : Set)(eqd : EqDec A)(ls : list (A * (list B)))(a : A) :=
    match (arrayLookup _ ls a) with
      | None => nil
      | Some ls => ls
    end.

Require Import CompFold.

Lemma arrayLookup_Some_In_unzip :
  forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a b,
    (arr # a) = Some b ->
    In a (fst (unzip arr)).

  induction arr; intuition; simpl in *.
  discriminate.

  case_eq (eqb a a0); intuition;
  rewrite H0 in *.
  inversion H; clear H; subst.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.
  right.
  eapply IHarr.
  eauto.

Qed.

Lemma notInArrayLookupNone :
  forall (A B : Set)(eqd : EqDec A)(arr : Array A B) a,
    (~ In a (fst (unzip arr))) ->
    (arr # a) = None.

  induction arr; intuition; simpl in *.

  case_eq (eqb a a0); intuition.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.

Qed.

Fixpoint arrayLookupOpt(A B : Set)(eqd : EqDec A)(ls : list (option (A * B)))(a : A) :=
  match ls with
    | nil => None
      | o :: ls' =>
        match o with
          | None => arrayLookupOpt _ ls' a
          | Some (a', b') =>
            if (eqb a a') then (Some b') else (arrayLookupOpt _ ls' a)
        end
  end.

Theorem list_pred_arrayLookupOpt :
  forall (A B C : Set)(P : B -> C -> Prop)(eqda : EqDec A)(ls1 : list (option (A * B)))(ls2 : list (option (A * C))),
    list_pred (fun o1 o2 =>
                 match o1 with
                   | None => o2 = None
                   | Some x =>
                     match o2 with
                       | None => False
                       | Some y =>
                         fst x = fst y /\ P (snd x) (snd y)
                     end
                 end) ls1 ls2 ->
    forall a,
      match (arrayLookupOpt _ ls1 a) with
        | None => (arrayLookupOpt _ ls2 a) = None
        | Some x => exists y, (arrayLookupOpt _ ls2 a) = Some y /\ P x y
      end.

  induction 1; intuition; simpl in *.
  trivial.

  destruct a1.
  destruct a2.
  destruct p.
  simpl in *.
  intuition.
  subst.
  destruct p0. simpl in *.
  case_eq (eqb a a0); intuition.
  econstructor.
  intuition.
  eapply IHlist_pred.
  destruct p.
  case_eq (eqb a a0); intuition.

  subst.
  eapply IHlist_pred.

Qed.

Theorem arrayLookupOpt_getSomes_eq :
  forall (A B : Set)(eqda : EqDec A)(ls : list (option (A * B)))(a : A),
       arrayLookupOpt _ ls a = arrayLookup _ (getSomes ls) a.

  induction ls; intuition; simpl in *.
  destruct a.
  destruct p.
  simpl.
  case_eq (eqb a0 a); intuition.

  eapply IHls.

Qed.

Theorem arrayLookup_app_Some :
  forall (A B : Set)(eqd : EqDec A)(ls1 ls2 : list (A * B))(a : A)(b : B),
    arrayLookup eqd ls1 a = Some b ->
    arrayLookup eqd (ls1 ++ ls2) a = Some b.

  induction ls1; intuition; simpl in *.
  discriminate.

  case_eq (eqb a a0); intuition.
  rewrite H0 in H.
  trivial.

  rewrite H0 in H.
  eauto.

Qed.

Theorem arrayLookup_app_None :
  forall (A B : Set)(eqd : EqDec A)(ls1 ls2 : list (A * B))(a : A),
    arrayLookup eqd ls1 a = None ->
    arrayLookup eqd (ls1 ++ ls2) a =
    arrayLookup eqd ls2 a.

  induction ls1; intuition; simpl in *.
  case_eq (eqb a a0); intuition;
  rewrite H0 in H.
  discriminate.

  eauto.

Qed.

Theorem arrayLookupList_pred :
  forall (A B : Set) (eqda : EqDec A)P (ls : list (A * list B)) a,
    (forall x, In x ls -> P (snd x)) ->
    P nil ->
    P (arrayLookupList _ ls a).

  induction ls; intuition; simpl in *.
  unfold arrayLookupList.
  simpl.
  case_eq (eqb a a0); intuition.
  specialize (X (a0, b)).
  intuition.

  eapply IHls; intuition.

Qed.

Theorem arrayLookup_Some_impl_In :
  forall (A B : Set)(eqd : EqDec A)(ls : list (A * B)) a b,
    arrayLookup _ ls a = Some b ->
    In (a, b) ls.

  induction ls; intuition; simpl in *.
  discriminate.
  case_eq (eqb a a0); intuition;
  rewrite H0 in H.
  inversion H; clear H; subst.
  rewrite eqb_leibniz in H0.
  subst.
  intuition.

  right.
  eauto.
Qed.

Theorem list_pred_impl_arrayLookup :
  forall (A B C : Set) P (eqda : EqDec A)(ls1 : list (A * B))(ls2 : list (A * C)),
    list_pred (fun x y => fst x = fst y /\ P (snd x) (snd y)) ls1 ls2 ->
    (forall v z, arrayLookup _ ls1 v = Some z -> exists z', arrayLookup _ ls2 v = Some z' /\ P z z') /\
    (forall v, arrayLookup _ ls1 v = None -> arrayLookup _ ls2 v = None).

  induction 1; intros; simpl in *.

  intuition.
  discriminate.

  destruct a1.
  destruct a2.
  destruct H.
  simpl in *.
  subst.

  intuition.

  case_eq (eqb v a0); intuition.
  rewrite H4 in H3.
  inversion H3; clear H3; subst.
  econstructor; eauto.
  rewrite H4 in H3.
  edestruct H.
  eauto.
  intuition.

  case_eq (eqb v a0); intuition.
  rewrite H4 in H3.
  discriminate.
  rewrite H4 in H3.
  eauto.

Qed.

Theorem arrayLookup_In_NoDup :
  forall (A B : Set)(eqda : EqDec A)(ls : list (A * B)) a b,
    In (a, b) ls ->
    NoDup (fst (split ls)) ->
    arrayLookup _ ls a = Some b.

  induction ls; intuition; simpl in *.
  intuition.

  remember (split ls) as z.
  destruct z.
  intuition.
  pairInv.
  simpl in *.
  inversion H0; clear H0; subst.
  rewrite eqb_refl.
  trivial.

  simpl in *.
  inversion H0; clear H0; subst.
  case_eq (eqb a a0); intuition.
  rewrite eqb_leibniz in H.
  subst.
  eapply in_split_l in H1.
  rewrite <- Heqz in H1.
  simpl in *.
  intuition.

Qed.

Theorem arrayLookup_None_not_In :
  forall (A B : Set)(eqda : EqDec A)(ls : list (A * B)) a,
    arrayLookup _ ls a = None ->
    In a (fst (split ls)) -> False.

  induction ls; intuition; simpl in *.
  remember (split ls) as z.
  destruct z.
  simpl in *.
  intuition; subst.
  rewrite eqb_refl in H.
  discriminate.
  destruct (eqb a a0).
  discriminate.
  eauto.
Qed.

Theorem arrayLookup_pair_None :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B) (ls : list (A * B * C)) a b,
    (forall x, In x ls -> fst (fst x) <> a) ->
    arrayLookup _ ls (a, b) = None.

  induction ls; intuition; simpl in *.
  case_eq (eqbPair eqda eqdb (a0, b1) (a, b0)); intuition.
  exfalso.
  unfold eqbPair in *.
  simpl in *.
  apply andb_true_iff in H0.
  intuition.
  rewrite eqb_leibniz in H1.
  subst.
  eapply H.
  left.
  reflexivity.
  trivial.
  eauto.

Qed.

Theorem arrayLookup_pair_flatten_none :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B) keys (ls : list (list (A * B * C))) a b,
    list_pred (fun a b => forall x, In x b -> fst (fst x) = a) keys ls ->
    (~ In a keys) ->
    arrayLookup (pair_EqDec eqda eqdb) (flatten ls) (a, b) = None.

  induction keys; intuition; simpl in *.
  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  intuition.
  simpl.

  case_eq (arrayLookup (pair_EqDec eqda eqdb) a2 (a0, b)); intuition.
  rewrite  arrayLookup_pair_None in H0.
  discriminate.
  intuition.
  subst.
  eapply H.
  symmetry.
  eapply H3.
  trivial.

  rewrite arrayLookup_app_None; trivial.
  eauto.

Qed.

Theorem arrayLookup_flatten_eq :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B)(ls : list (list (A * B * C))) keys a b,
    list_pred (fun a b => forall x, In x b -> fst (fst x) = a) keys ls ->
    NoDup keys ->
    arrayLookup _ (flatten ls) (a, b) =
    arrayLookup _ (arrayLookupList _ (combine keys ls) a) (a, b).

  induction ls; intuition; simpl in *.
  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  simpl.
  unfold arrayLookupList.
  simpl.
  inversion H0; clear H0; subst.
  case_eq (eqb a0 a1); intuition.

  case_eq (arrayLookup (pair_EqDec eqda eqdb) a (a0, b)); intuition.
  eapply arrayLookup_app_Some.
  trivial.

  rewrite eqb_leibniz in H.
  subst.

  rewrite arrayLookup_app_None; intuition.

  eapply arrayLookup_pair_flatten_none.
  eauto.
  intuition.

  case_eq ( arrayLookup _ a (a0, b) ); intuition.
  rewrite  arrayLookup_pair_None in H0.
  discriminate.
  intuition.
  subst.
  eapply eqb_false_iff in H.
  intuition.
  rewrite arrayLookup_app_None.
  eapply IHls; intuition.
  trivial.
Qed.

Theorem arrayLookup_pair_snd :
  forall (A B C : Set)(eqda : EqDec A)(eqdb : EqDec B)(ls1 : list (A * B * C))(ls2 : list (B * C)) a b,
    list_pred (fun x y => fst (fst x) = a /\ snd (fst x) = fst y /\ snd x = snd y) ls1 ls2 ->
    arrayLookup _ ls1 (a, b) =
    arrayLookup _ ls2 b.

  induction ls1; intuition; simpl in *.
  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  simpl.
  intuition.
  subst.
  simpl in *.
  subst.
  destruct a2.
  simpl in *.
  unfold eqbPair.
  simpl.
  rewrite eqb_refl.
  simpl.
  case_eq (eqb b1 b); intuition.

Qed.

Theorem arrayLookup_pred_2 :
  forall (A B C: Set)(eqda : EqDec A) (P : list B -> list C -> Prop) (ls1 : list (A * list B))(ls2 : list (A * list C)) a,
    list_pred (fun x y => (fst x = a \/ fst y = a) -> (fst x = a /\ fst y = a /\ P (snd x) (snd y))) ls1 ls2 ->
    P nil nil ->
    P (arrayLookupList _ ls1 a) (arrayLookupList _ ls2 a).

  induction ls1; intuition; simpl in *.
  inversion H; clear H; subst.
  unfold arrayLookupList.
  simpl.
  trivial.

  inversion H; clear H; subst.
  unfold arrayLookupList.
  simpl.
  destruct a2.

  simpl in *.
  intuition.

  case_eq (eqb a a0); intuition.
  rewrite eqb_leibniz in H2.
  subst.
  intuition.
  subst.
  rewrite eqb_refl.
  trivial.

  case_eq (eqb a a1); intuition.
  rewrite eqb_leibniz in H3.
  subst.
  intuition.
  subst.
  rewrite eqb_refl in H2.
  discriminate.

  eapply IHls1; intuition.
Qed.

Theorem In_arrayLookupList :
  forall (A B : Set)(eqda : EqDec A)(a : A)(b : B) ls,
    In b (arrayLookupList _ ls a) ->
    exists ls', In (a, ls') ls /\
                In b ls'.

  intuition.
  unfold arrayLookupList in *.
  case_eq (arrayLookup eqda ls a); intuition;
  rewrite H0 in H.
  eapply arrayLookup_Some_impl_In in H0.
  econstructor.
  split.
  eauto.
  trivial.

  simpl in *.
  intuition.

Qed.

Theorem arrayLookupList_pred'
: forall (A B : Set) (eqda : EqDec A) (P : list B -> Type)
         (ls : list (A * list B)) (a : A),
    (forall x : list B, In (a, x) ls -> P x) ->
    (arrayLookup _ ls a = None -> P nil) ->
    P (arrayLookupList eqda ls a).

  induction ls; intuition; simpl in *.
  unfold arrayLookupList.
  simpl.
  case_eq (eqb a a0); intuition.
  eapply X.
  rewrite eqb_leibniz in H.
  subst.
  intuition.

  case_eq (arrayLookup eqda ls a); intuition.
  specialize (IHls a).
  unfold arrayLookupList in *.
  rewrite H0 in IHls.
  eapply IHls; eauto.
  intuition.
  discriminate.

  rewrite H in X0.
  intuition.
Qed.
Theorem arrayLookup_allNats_eq :
  forall (B : Set)(ls : list (nat * B)) i,
    fst (split ls) = allNatsLt (length ls) ->
    arrayLookup _ ls i =
    match nth_option ls i with
      | Some (_, v) => Some v
              | None => None
    end.

  induction ls using rev_ind; intuition; simpl in *.
  rewrite app_length in H.
  rewrite fst_split_app_eq in H.
  simpl in *.
  rewrite plus_comm in H.
  simpl in *.
  eapply app_inj_tail in H.
  intuition.
  subst.

  case_eq (nth_option ls i); intuition.

  erewrite nth_option_app_Some ; eauto.
  destruct p.

  case_eq (arrayLookup nat_EqDec ls i); intuition.
  erewrite arrayLookup_app_Some; eauto.
  rewrite IHls.
  rewrite H.
  trivial.
  trivial.

  eapply arrayLookup_None_not_In in H1.
  intuition.
  rewrite H0.
  eapply allNatsLt_lt_if.

  eapply nth_option_Some_lt.
  eauto.

  rewrite nth_option_app_None.
  simpl.
  case_eq (i - length ls); intuition.

  eapply nth_option_None_ge in H.
  assert (i = length ls).
  omega.
  subst.

  case_eq (arrayLookup _ ls (length ls)); intuition.
  exfalso.
  eapply arrayLookup_Some_impl_In in H2.
  eapply in_split_l in H2.
  simpl in *.
  rewrite H0 in H2.
  eapply allNatsLt_lt in H2.
  omega.
  rewrite arrayLookup_app_None; eauto.
  simpl.
  rewrite eqb_refl.
  trivial.

  case_eq (arrayLookup _ ls i); intuition.
  eapply arrayLookup_Some_impl_In in H2.
  eapply in_split_l in H2.
  simpl in *.
  rewrite H0 in H2.
  eapply allNatsLt_lt in H2.
  omega.

  rewrite arrayLookup_app_None; eauto.
  simpl.
  case_eq ( eqb i (length ls)); intuition.
  rewrite eqb_leibniz in H3.
  subst.
  omega.
  trivial.

Qed.


(* TPPmark 2017 dependently-typed DP version by Mitsuharu Yamamoto *)
From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive dseq (X : Type) (T : seq X -> Type) : seq X -> Type :=
| DNil : dseq T [::]
| DCons (x : X) (s : seq X) of T s & dseq T s : dseq T (x :: s).

Arguments DNil [X T].
Arguments DCons [X T x s] _ _.

Section DynamicProgramming.

Variables X Y : Type.
Variable Z : seq X -> seq Y -> Type.

Variable z00 : Z [::] [::].
Variable zc0 : forall x s, Z s [::] -> Z (x :: s) [::].
Variable z0c : forall y t, Z [::] t -> Z [::] (y :: t).
Variable zcc : forall x s y t, Z s t -> Z s (y :: t) -> Z (x :: s) t ->
                               Z (x :: s) (y :: t).

Fixpoint dp0t t : Z [::] t * dseq (Z [::]) t :=
  if t is y :: t' then let: (z, zs) := dp0t t' in (z0c y z, DCons z zs)
  else (z00, DNil).

Fixpoint dpt x s t : Z s t * dseq (Z s) t -> (* zs *)
                     Z (x :: s) t * dseq (Z (x :: s)) t :=
  if t is y :: t' then
    fun zs =>
      (if zs.2 is DCons y0 t'0 z' zs' in dseq _ t0 return t0 = y :: t' -> _ then
         fun E => let: Et' := congr1 behead E : t'0 = t' in
                  let: (zy, zt') := dpt x (ecast _ _ Et' (z', zs')) in
                  (zcc (ecast _ _ Et' z') zs.1 zy, DCons zy zt')
       else
         fun E => match List.nil_cons E with end) (erefl (y :: t'))
  else
    fun zs => (zc0 x zs.1, DNil).

(* Alternatively,
Definition dpt x s t (zs : Z s t * dseq (Z s) t)
  : Z (x :: s) t * dseq (Z (x :: s)) t.
  elim: t => [| y t IHt] in zs *; first by apply: (zc0 x zs.1, DNil).
  case: zs => z; case E: _ / => [| y' t' z' zs'] //.
  case: E => <- <- {y' t'} in z' zs' *; case/(_ (z', zs')): IHt => zy zt'.
  exact: (zcc z' z zy, DCons zy zt').
Defined.
*)

Fixpoint dps s t : Z s t * dseq (Z s) t :=
  if s is x :: s' then dpt x (dps s' t) else dp0t t.

Definition dp s t : Z s t := (dps s t).1.

(* unfolding lemmas; only used in the weakly-specified version *)

Lemma dp00 : dp [::] [::] = z00.
Proof.  by [].  Qed.

Lemma dp0c y t : dp [::] (y :: t) = z0c y (dp [::] t).
Proof.  by rewrite /dp /=; case: dp0t.  Qed.

Lemma dpc0 x s : dp (x :: s) [::] = zc0 x (dp s [::]).
Proof.
  by rewrite /dp; elim: s => [| x' s ->] //= in x *; case: dps => ? [| ? ?].
Qed.

Lemma dpscc x y s t :
  dps (x :: s) (y :: t) = (zcc (dp s t) (dp s (y :: t)) (dp (x :: s) t),
                           DCons (dp (x :: s) t) (dps (x :: s) t).2).
Proof.
  rewrite /dp; elim: s => /= [| x' s ->] in x *.
  - by case: dp0t => ? ? /=; case: dpt.
  - by rewrite /= -surjective_pairing; case: dpt.
Qed.

Lemma dpcc x y s t :
  dp (x :: s) (y :: t) = zcc (dp s t) (dp s (y :: t)) (dp (x :: s) t).
Proof.  by rewrite /dp dpscc.  Qed.

End DynamicProgramming.

Section LongestCommonSubsequence.

Definition argmax (X : Type) f (x y : X) := if f x < f y then y else x.

Lemma argmax_maxn (X : Type) f (x y : X) : f (argmax f x y) = maxn (f x) (f y).
Proof.  by rewrite /argmax fun_if.  Qed.

Variable T : eqType.

(* Strongly-specified version *)

Definition LCS_spec (s t lcs : seq T) :=
  [/\ subseq lcs s, subseq lcs t &
      forall u, subseq u s -> subseq u t -> size u <= size lcs].

Definition LCS_strong s t : {lcs | LCS_spec s t lcs}.
  apply: dp (exist _ [::] _)
            (fun _ _ _ => exist _ [::] _) (fun _ _ _ => exist _ [::] _)
            (fun x _ y _ st syt xst =>
               exist _ (if x == y then x :: sval st
                        else argmax size (sval syt) (sval xst)) _)
            s t.
  - by split=> //= ? /eqP ->.
  - by move=> ? ? ?; split=> // ? ? /eqP ->.
  - by move=> ? ? ?; split=> // ? /eqP ->.
  - move=> x s y t [st [Hst1 Hst2 Hst3]].
    move=> [syt [Hsyt1 Hsyt2 Hsyt3]] [xst [Hxst1 Hxst2 Hxst3]].
    rewrite ![sval _]/=; split.
    + case: ifP => [_ | Hxy]; first by rewrite /= eqxx.
      rewrite /argmax; case: ifP => _ //.
      by rewrite (subseq_trans Hsyt1) // subseq_cons.
    + case: ifP => [/eqP -> | Hxy]; first by rewrite /= eqxx.
      rewrite /argmax; case: ifP => _ //.
      by rewrite (subseq_trans Hxst2) // subseq_cons.
    + case=> [| z u] //; case: ifP => [/eqP <- | Hxy] /=.
      * by move=> Hs Ht; move: (Hst3 _ Hs Ht); case: ifP => _ // /leqW.
      * { rewrite argmax_maxn leq_max; case: ifP => [/eqP -> | _] Hs.
          - by rewrite Hxy => Ht; rewrite (Hxst3 (x :: u)) ?orbT //= eqxx.
          - by move=> Ht; rewrite (Hsyt3 (z :: u)).
        }
Defined.

(* Weakly-specified version; identical to the normal DP one *)

Definition LCS : seq T -> seq T -> seq T :=
  dp [::] (fun _ _ _ => [::]) (fun _ _ _ => [::])
     (fun x _ y _ st syt xst =>
        if x == y then x :: st else argmax size syt xst).

Lemma lcs_nil_l s : LCS [::] s = [::].
Proof.  by rewrite /LCS; case: s => [| ? ?]; rewrite ?dp00 ?dp0c.  Qed.

Lemma lcs_nil_r s : LCS s [::] = [::].
Proof.  by rewrite /LCS; case: s => [| ? ?]; rewrite ?dp00 ?dpc0.  Qed.

Lemma lcs_cons x s y t :
  LCS (x :: s) (y :: t) = if x == y then x :: LCS s t
                          else argmax size (LCS s (y :: t)) (LCS (x :: s) t).
Proof.  by rewrite /LCS dpcc.  Qed.

Lemma lcs_subseq s t : subseq (LCS s t) s /\ subseq (LCS s t) t.
Proof.
  elim: s => [| x s IHs] in t *; first by rewrite lcs_nil_l !sub0seq.
  elim: t => [| y t [IHts IHtt]]; first by rewrite lcs_nil_r sub0seq.
  rewrite lcs_cons; case: ifP => [/eqP -> | Hxy]; first by rewrite /= eqxx.
  case/IHs: (y :: t) => IHss IHst; rewrite /argmax; split; case: ifP => _ //.
  - by rewrite (subseq_trans IHss) // subseq_cons.
  - by rewrite (subseq_trans IHtt) // subseq_cons.
Qed.

Lemma lcs_longest s t u : subseq u s -> subseq u t -> size u <= size (LCS s t).
Proof.
  elim: s => [| x s IHs] in u t *; first by move=> /eqP ->.
  elim: t => [| y t IHt] in u *; first by move=> _ /eqP ->.
  case: u => [| z u] //; rewrite lcs_cons; case: ifP => [/eqP <- {y} | Hxy] /=.
  - by move=> Hs Ht; move: (IHs _ _ Hs Ht); case: ifP => _ // /leqW.
  - rewrite argmax_maxn leq_max; case: ifP => [/eqP -> | _] Hs.
    + by rewrite Hxy => Ht; rewrite (IHt (x :: u)) ?orbT //= eqxx.
    + by move=> Ht; rewrite (IHs (z :: u)).
Qed.

End LongestCommonSubsequence.


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path order bigop.
From favssr Require Import prelude.

Section Basics.
Context {T : Type}.
Implicit Types (xs ys zs: seq T).

(* 1.4 Proofs *)

(* TODO: 1.4.1 gcd example *)

(* 1.5 Running time *)

Fixpoint T_app xs ys : nat :=
  if xs is _ :: xs' then (T_app xs' ys).+1 else 1.

(* Not a real rev implementation from lib *)
Fixpoint rev' xs :=
  if xs is x :: xs' then rev' xs' ++ [:: x] else [::].

Fixpoint T_rev xs : nat :=
  if xs is x :: xs' then T_rev xs' + T_app (rev' xs') [:: x] + 1 else 1.

Lemma T_app_cons x xs ys : T_app (x :: xs) ys = (T_app xs ys).+1.
Proof. by []. Qed.

Lemma T_app_complexity xs ys : T_app xs ys = (size xs).+1.
Proof.
elim: xs => [| x xs IH] //.
by rewrite T_app_cons IH.
Qed.

(* Exercise 1.5.1 formula for T_rev *)

Fixpoint T_catrev xs ys : nat :=
  if xs is x :: xs' then (T_catrev xs' (x :: ys)).+1 else 1.

Lemma catrev_rev_equality xs ys : catrev xs ys = rev' xs ++ ys.
Proof.
rewrite /catrev.
elim: xs ys => [| x xs IH] ys //=.
by rewrite IH -catA.
Qed.

End Basics.


Set Universe Polymorphism.
Require Export eqv.

(* This file studies the properties of the following inductive type: *)
Inductive isStrongEqv : forall {A B} (f : A -> B), Type :=
| isStrongEqv_id : forall A, isStrongEqv (id A).

(* The main result is Univalence <-> (forall f, eqv (isEqv f) (isStrongEqv f))
                                 <-> (forall f, qinv f -> isStrongEqv f) *)

Definition seqv (A B : Type) := {f : A -> B & isStrongEqv f}.
Notation "A ≡ B" := (seqv A B) (at level 70).

Definition seqv_fun A B (e : A ≡ B) : A -> B :=
  let (f, _) := e in f.
Coercion seqv_fun : seqv >-> Funclass.

Lemma seqv_refl A : A ≡ A.
Proof.
  exists (id A).
  apply isStrongEqv_id.
Defined.

Lemma seqv_inv_fun {A B} (f : A ≡ B) : B -> A.
Proof.
  destruct f as (f, Hf).
  destruct Hf.
  apply id.
Defined.

Lemma seqv_sym {A B} (f : A ≡ B) : B ≡ A.
Proof.
  exists (seqv_inv_fun f).
  destruct f as (f, Hf).
  destruct Hf.
  apply isStrongEqv_id.
Defined.

Lemma seqv_sym_refl A : seqv_sym (seqv_refl A) == seqv_refl A.
Proof.
  reflexivity.
Defined.

Lemma seqv_sym_sym {A B} (f : A ≡ B) : seqv_sym (seqv_sym f) == f.
Proof.
  destruct f as (f, Hf).
  destruct Hf.
  reflexivity.
Defined.

Lemma seqv_trans {A B C} : A ≡ B -> B ≡ C -> A ≡ C.
Proof.
  intros (f, Hf) (g, Hg).
  exists (comp f g).
  destruct Hf.
  destruct Hg.
  apply isStrongEqv_id.
Defined.

Lemma seqv_refl_trans {A B} (e : A ≡ B) : seqv_trans (seqv_refl A) e = e.
Proof.
  destruct e as (f, Hf).
  destruct Hf.
  reflexivity.
Defined.

Lemma seqv_trans_refl {A B} (e : A ≡ B) : seqv_trans e (seqv_refl B) = e.
Proof.
  destruct e as (f, Hf).
  destruct Hf.
  reflexivity.
Defined.

Lemma seqv_sym_trans {A B C} (e1 : A ≡ B) (e2 : B ≡ C) :
  seqv_sym (seqv_trans e1 e2) = seqv_trans (seqv_sym e2) (seqv_sym e1).
Proof.
  destruct e1 as (f, Hf).
  destruct e2 as (g, Hg).
  destruct Hf.
  destruct Hg.
  reflexivity.
Defined.

Lemma seqv_to_eq {A B} : A ≡ B -> A == B.
Proof.
  intro f.
  destruct f as (f, Hf).
  destruct Hf.
  reflexivity.
Defined.

Lemma eq_to_seqv {A B} : A == B -> A ≡ B.
Proof.
  intros [].
  apply seqv_refl.
Defined.

Lemma is_seqv_to_eqv {A B} {f : A -> B} : isStrongEqv f -> isEqv f.
Proof.
  intro Hf.
  apply (isEqv_intro (seqv_inv_fun (existT _ f Hf))).
  - intro.
    destruct Hf.
    reflexivity.
  - intro.
    destruct Hf.
    reflexivity.
Defined.

Lemma seqv_to_eqv {A B} : A ≡ B -> A ≃ B.
Proof.
  intros (f, Hf).
  exists f.
  apply is_seqv_to_eqv.
  exact Hf.
Defined.

Lemma seqv_eqv_eq {A B} : (A ≡ B) ≃ (A == B).
Proof.
  exists seqv_to_eq.
  apply (isEqv_intro eq_to_seqv).
  - intros [].
    reflexivity.
  - intros (f, Hf).
    destruct Hf.
    reflexivity.
Defined.

Theorem seq_exponential : forall {A B} (s : A ≡ B) C, (C -> A) ≡ (C -> B).
Proof.
  intros A B (s, H) C.
  exists (fun h => comp h s).
  destruct H.
  apply isStrongEqv_id.
Defined.

Definition heq2 {A B} (f : A -> B) (a : A) (b : B) :=
  ((f a == b) * isStrongEqv f)%type.

Inductive heq : forall {A B : Type} (f : A -> B) (a : A) (b : B), Type :=
| refl {A} a : heq (id A) a a.

Lemma heq_heq2 {A B : Type} {f : A -> B} {a b} : heq f a b -> heq2 f a b.
Proof.
  intro h.
  destruct h.
  split.
  - reflexivity.
  - apply isStrongEqv_id.
Defined.

Lemma heq2_heq {A B : Type} {f : A -> B} {a b} : heq2 f a b -> heq f a b.
Proof.
  intros (e, Hf).
  destruct Hf.
  destruct e.
  apply refl.
Defined.

Lemma eqv_heq_heq2 {A B} {f : A -> B} {a b} : heq f a b ≃ heq2 f a b.
Proof.
  exists heq_heq2.
  apply (isEqv_intro heq2_heq).
  - intros (e, Hf).
    destruct Hf.
    destruct e.
    reflexivity.
  - intros [].
    reflexivity.
Defined.

(*
   We finally show that the following statements are equivalent:
   1. strong univalence : id_to_eqv is an equivalence
   2. funext + (A ≃ B) ≃ (A == B)
   3. eqv_induction (without beta)
   4. isEqv f -> isStrongEqv f
   5. eqv_induction (with beta)
   6. isEqv f ≃ isStrongEqv f
 *)

(*
   1->2 is folklore
 *)

Section from_weak_univ_and_funext_to_eqv_induction.

  Hypothesis funext : funext_statement.
  Hypothesis weak_univalence : forall A B, (A ≃ B) ≃ (A == B).

  Lemma eqv_is_eq : eqv == eq.
  Proof.
    apply funext.
    intro A.
    apply funext.
    intro B.
    apply weak_univalence.
    apply weak_univalence.
  Qed.

  (* From this equality, we can transport the induction principle for
     equality to equivalence. More precisely, we transfer the
     following variant of "based path induction" that avoids
     mentionning reflexivity. *)

  Definition has_eqind (eq : Type -> Type -> Type) :=
    forall (A : Type) (P : (forall B : Type, eq A B -> Type)) B e,
      {f : forall B' e', P B e -> P B' e' &
              f B e == id (P B e)}.

  (* @eq Type satisfies has_eqind *)
  Lemma eqind : forall (A : Type) (P : (forall B : Type, A == B -> Type)) B e B' e',
      P B e -> P B' e'.
  Proof.
    intros A P B e B' e'.
    destruct e.
    destruct e'.
    apply id.
  Defined.

  Lemma has_eqind_eq : has_eqind (@eq Type).
  Proof.
    intros A P B e.
    exists (eqind A P B e).
    destruct e.
    reflexivity.
  Defined.

  (* Hence eqv satisfies it. *)
  Lemma has_eqind_eqv : has_eqind eqv.
  Proof.
    rewrite eqv_is_eq.
    apply has_eqind_eq.
  Defined.

  Lemma eqv_eqind {A} (P : (forall B : Type, A ≃ B -> Type)) B e B' e' :
    P B e -> P B' e'.
  Proof.
    apply has_eqind_eqv.
  Defined.

  Lemma eqv_eqind_id {A} {P : forall B, A ≃ B -> Type} B e :
    eqv_eqind P B e B e == id (P B e).
  Proof.
    unfold eqv_eqind.
    destruct (has_eqind_eqv A P B e) as (F, H).
    exact H.
  Defined.

  Definition eqv_induction {A} (P : forall B, A ≃ B -> Type) B e :
    P A (eqv_refl A) -> P B e :=
    eqv_eqind P A (eqv_refl A) B e.

  Definition eqv_induction_beta {A} (P : forall B, A ≃ B -> Type) :
    eqv_induction P A (eqv_refl A) == id _ :=
    eqv_eqind_id A (eqv_refl A).

End from_weak_univ_and_funext_to_eqv_induction.

Section from_eqv_induction_and_isEqv_to_isStrongEqv.

  Variable eqv_induction : forall A (P : forall B, A ≃ B -> Type) B e,
    P A (eqv_refl A) -> P B e.

  Lemma eqv_to_isStrongEqv {A B} (f : A ≃ B) : isStrongEqv f.
  Proof.
    apply (eqv_induction A (fun B f => isStrongEqv f) B f).
    apply isStrongEqv_id.
  Defined.

  Lemma isEqv_to_isStrongEqv {A B} (f : A -> B) : isEqv f -> isStrongEqv f.
  Proof.
    intro H.
    pose (g := (existT _ f H : A ≃ B)).
    exact (eqv_to_isStrongEqv g).
  Defined.

End from_eqv_induction_and_isEqv_to_isStrongEqv.

Section from_eqvtoseqv_to_eqv_induction.

  Hypothesis iseqv_to_seqv : forall A B (f : A -> B), isEqv f -> isStrongEqv f.

  (* We first derive funext. This proof is taken from the HoTT book *)
  Section contractible_family.
    Variable A : Type.
    Variable P : A -> Type.
    Hypothesis C : forall x : A, isContr (P x).

    Lemma alpha : seqv (A -> {x : A & P x}) (A -> A).
    Proof.
      apply seq_exponential.
      exists (@projT1 A P).
      apply iseqv_to_seqv.
      intro x.
      exists (existT (fun w => projT1 w == x) (existT P x (projT1 (C x))) (eq_refl x)).
      intros ((x', p), Hx'x).
      simpl in Hx'x.
      destruct Hx'x.
      apply (f_equal (fun p => existT (fun x0 : {x : A & P x} => projT1 x0 == x') (existT P x' p) (eq_refl x'))).
      exact (projT2 (C x') p).
    Defined.

    Definition phi (f : forall x : A, P x) : fiber alpha (fun x : A => x) :=
      existT _ (fun x => existT P x (f x)) (eq_refl _).

    Definition psi (gp : fiber alpha (fun x : A => x)) (x : A) : P x.
      destruct gp as (g, p).
      unfold alpha in p.
      simpl in p.
      apply (transport (fun f => P (f x)) p).
      exact (projT2 (g x)).
    Defined.

    Lemma weak_extensionality : isContr (forall x, P x).
    Proof.
      apply (isContr_retract psi phi).
      - intro x.
        reflexivity.
      - destruct alpha as (alpha, Ha).
        simpl.
        apply is_seqv_to_eqv in Ha.
        apply Ha.
    Defined.
  End contractible_family.

  Definition funext :
    forall A B (f g : forall x : A, B x), (forall x, f x == g x) -> f == g :=
    eqv.funext weak_extensionality.

  Lemma eqv_to_seqv {A B} : A ≃ B -> A ≡ B.
  Proof.
    intros (f, Hf).
    exists f.
    apply iseqv_to_seqv.
    exact Hf.
  Defined.

  Lemma seqv_ind A (P : forall B, A ≡ B -> Type) B e B' e' :
    P B e -> P B' e'.
  Proof.
    destruct e' as (f', H').
    destruct H'.
    destruct e as (f, H).
    destruct H.
    apply id.
  Defined.

  Lemma seqv_ind_id A P B e : seqv_ind A P B e B e == id (P B e).
  Proof.
    destruct e as (f, H).
    destruct H.
    reflexivity.
  Defined.

  Lemma seqv_to_eqv_to_seqv A B (e : A ≃ B) : e == seqv_to_eqv (eqv_to_seqv e).
  Proof.
    destruct e as (f, H).
    simpl.
    apply f_equal.
    apply isProp_isEqv.
    exact funext.
  Defined.

  Lemma eqv_ind A (P : forall B, A ≃ B -> Type) B e B' e' :
    P B e -> P B' e'.
  Proof.
    intro p.
    rewrite seqv_to_eqv_to_seqv.
    pose (P' := fun B e => P B (seqv_to_eqv e)).
    apply (seqv_ind _ P' B (eqv_to_seqv e) B' (eqv_to_seqv e')).
    unfold P'.
    rewrite <- seqv_to_eqv_to_seqv.
    exact p.
  Defined.

  Lemma eqv_ind_id {A P} B e : eqv_ind A P B e B e == id (P B e).
  Proof.
    unfold eqv_ind.
    rewrite seqv_ind_id.
    unfold id.
    generalize (seqv_to_eqv_to_seqv A B e).
    intro H.
    destruct H.
    reflexivity.
  Defined.

  Definition eqv_induction' {A} (P : forall B, A ≃ B -> Type) B e :
    P A (eqv_refl A) -> P B e :=
    eqv_ind A P A (eqv_refl A) B e.

  Definition eqv_induction_beta' {A} (P : forall B, A ≃ B -> Type) :
    eqv_induction' P A (eqv_refl A) == id _ :=
    eqv_ind_id A (eqv_refl A).

End from_eqvtoseqv_to_eqv_induction.

Section from_eqv_induction_to_eqv_equivalence.

  Variable eqv_induction : forall A (P : forall B, A ≃ B -> Type) B e,
    P A (eqv_refl A) -> P B e.

  Hypothesis eqv_induction_beta : forall A (P : forall B, A ≃ B -> Type),
      eqv_induction A P A (eqv_refl A) == id _.

  Lemma iseqv_to_seqv {A B} (f : A -> B) : isEqv f -> isStrongEqv f.
  Proof.
    intro Hf.
    apply (eqv_induction A (fun B f => isStrongEqv f) B (existT _ f Hf)).
    apply isStrongEqv_id.
  Defined.

  Lemma isStrongEqv_to_isEqv {A B} (f : A -> B) : isStrongEqv f -> isEqv f.
  Proof.
    intros [].
    apply isEqv_id.
  Defined.

  Theorem eqv_eqv_seqv {A B} (f : A -> B) : eqv (isEqv f) (isStrongEqv f).
  Proof.
    exists (iseqv_to_seqv f).
    apply (isEqv_intro (isStrongEqv_to_isEqv f)).
    - intros [].
      simpl.
      unfold iseqv_to_seqv.
      rewrite eqv_induction_beta.
      reflexivity.
    - intro Hf.
      apply isProp_isEqv.
      exact (funext (@iseqv_to_seqv)).
  Defined.
End from_eqv_induction_to_eqv_equivalence.

Section from_eqv_equivalence_to_univalence.
  Hypothesis iseqv_eqv_isseqv : forall A B (f : A -> B), eqv (isEqv f) (isStrongEqv f).

  Lemma eqv_to_seqv' {A B} : A ≃ B -> A ≡ B.
  Proof.
    intros (f, e).
    exists f.
    apply iseqv_eqv_isseqv.
    exact e.
  Defined.

  Lemma seqv_to_eqv' {A B} : A ≡ B -> A ≃ B.
  Proof.
    intros (f, e).
    destruct e.
    apply eqv_refl.
  Defined.

  Lemma isProp_isEqv' {A B} {f : A -> B} : isProp (isEqv f).
  Proof.
    apply isProp_isEqv.
    exact (funext (@iseqv_eqv_isseqv)).
  Qed.

  Lemma isProp_isStrongEqv {A B} {f : A -> B} : isProp (isStrongEqv f).
  Proof.
    refine (isProp_eqv _ (iseqv_eqv_isseqv _ _ f)).
    apply isProp_isEqv'.
  Defined.

  Lemma eqv_eqv_seqv' {A B} : eqv (A ≃ B) (A ≡ B).
  Proof.
    exists eqv_to_seqv'.
    apply (isEqv_intro seqv_to_eqv').
    - intros (f, Hf).
      destruct Hf.
      simpl.
      destruct (iseqv_eqv_isseqv A A (id A)).
      apply f_equal.
      apply isProp_isStrongEqv.
    - intros (f, Hf).
      simpl.
      destruct (iseqv_eqv_isseqv A B f) as (g, Hg).
      destruct (g Hf).
      unfold eqv_refl.
      apply f_equal.
      apply isProp_isEqv'.
  Defined.

  Lemma ua {A B} : eqv (A ≃ B) (A == B).
  Proof.
    apply (eqv_trans eqv_eqv_seqv' seqv_eqv_eq).
  Defined.

  Lemma ua_refl A : ua (eqv_refl A) == eq_refl A.
  Proof.
    unfold ua.
    simpl.
    unfold comp.
    unfold eqv_to_seqv'.
    simpl.
    destruct (iseqv_eqv_isseqv A A (id A)) as (f, Hf).
    assert (f (isEqv_id A) == isStrongEqv_id A).
    - apply isProp_isStrongEqv.
    - rewrite X.
      reflexivity.
  Defined.

  Lemma ua_sym_refl A : eqv_sym ua (eq_refl A) == eqv_refl A.
  Proof.
    rewrite <- ua_refl.
    apply eqv_sym_eta.
  Defined.

  Lemma isEqv_id_to_eqv {A B} : isEqv (@id_to_eqv A B).
  Proof.
    apply (isEqv_homotopy (eqv_sym (@ua A B))).
    - destruct (eqv_sym (@ua A B)) as (e, He).
      exact He.
    - intros [].
      apply ua_sym_refl.
  Defined.

End from_eqv_equivalence_to_univalence.

Section corollaries.

  Hypothesis iseqv_eqv_isseqv : forall A B (f : A -> B), isEqv f ≃ isStrongEqv f.

  Corollary heq_eqv_eq {A B} (f : A ≡ B) {a b} : heq f a b ≃ (f a == b).
  Proof.
    apply (eqv_trans eqv_heq_heq2).
    apply (@eqv_trans _ ((f a == b) * unit)%type).
    - unfold heq2.
      apply eqv_prod.
      + apply eqv_refl.
      + apply isContr_unit.
        apply isProp_to_isContr.
        * destruct f.
          assumption.
        * apply isProp_isStrongEqv.
          apply iseqv_eqv_isseqv.
    - apply eqv_prod_unit.
  Defined.

  Corollary heq_id_eqv_eq {A} {a b} : heq (id A) a b ≃ (a == b).
  Proof.
    exact (@heq_eqv_eq A A (seqv_refl A) a b).
  Defined.

End corollaries.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Variable f : nat -> nat.
Toplevel input, characters 0-24:
> Variable f : nat -> nat.
> ^^^^^^^^^^^^^^^^^^^^^^^^
Warning: f is declared as a local axiom [local-declaration,scope]
f is declared

Coq < Hypothesis foo : f 0 = 0.
Toplevel input, characters 0-25:
> Hypothesis foo : f 0 = 0.
> ^^^^^^^^^^^^^^^^^^^^^^^^^
Warning: foo is declared as a local axiom [local-declaration,scope]
foo is declared

Coq < Theorem L1 : forall k:nat, k = 0 -> f k = k.
1 subgoal

  ============================
  forall k : nat, k = 0 -> f k = k

L1 < intros k E.
1 subgoal

  k : nat
  E : k = 0
  ============================
  f k = k

L1 < rewrite E.
1 subgoal

  k : nat
  E : k = 0
  ============================
  f 0 = 0

L1 < apply foo.
No more subgoals.

L1 < Qed.
L1 is defined


(**********************************************************************************
 * Fin.v                                                                          *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(* Finite nats and maps *)

Require Export ssreflect ssrnat.
Require Export NaryFunctions.
Require Import Program.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Inductive Fin : nat -> Type :=
| FinZ : forall n, Fin n.+1
| FinS : forall n, Fin n -> Fin n.+1.

Definition FMap n D := Fin n -> D.

(* Head, tail and cons *)
Definition tl n D (m:FMap n.+1 D) : FMap n D := fun v => m (FinS v).
Definition hd n D (m:FMap n.+1 D) : D := m (FinZ _).

Definition cons n D (hd:D) (tl : FMap n D) : FMap n.+1 D :=
  (fun var =>
    match var in Fin n return FMap n.-1 D -> D with
      | FinZ _      => fun _   => hd
      | FinS _ var' => fun tl' => tl' var'
    end tl).

Fixpoint nth n D (v : Fin n) : FMap n D -> D :=
  match v with
  | FinZ _ => fun m => hd m
  | FinS _ i => fun m => nth i (tl m)
  end.

Fixpoint asTuple n D : FMap n D -> D ^ n :=
  match n with
  | 0 => fun m => tt
  | n.+1 => fun m => (hd m, asTuple (tl m))
  end.

Lemma hdCons : forall n D (v : D) (m : FMap n D), hd (cons v m) = v.
Proof. by []. Qed.

Axiom Extensionality : forall n D (m1 m2 : FMap n D), (forall i, m1 i = m2 i) -> m1 = m2.

Lemma tlCons : forall n D (v : D) (s : FMap n D), tl (cons v s) = s.
Proof. move => n D v s. by apply Extensionality. Qed.

Ltac extFMap i :=  (apply Extensionality; intros i; dependent destruction i).

Lemma consEta : forall n D (m:FMap n.+1 D), m = cons (hd m) (tl m).
Proof. move => n D m. extFMap i; by []. Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearparallel.
Require Export GeoCoq.Elements.OriginalProofs.proposition_29.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_29C :
   forall B D E G H,
   Par G B H D -> OS B D G H -> BetS E G H ->
   CongA E G B G H D /\ RT B G H G H D.
Proof.
intros.
assert (nCol G B H) by (forward_using lemma_parallelNC).
assert (~ eq G B).
 {
 intro.
 assert (Col G B H) by (conclude_def Col ).
 contradict.
 }
assert (neq B G) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists A, (BetS B G A /\ Cong G A B G)) by (conclude lemma_extension);destruct Tf as [A];spliter.
assert (BetS A G B) by (conclude axiom_betweennesssymmetry).
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (Col A B G) by (conclude_def Col ).
assert (Col G B A) by (forward_using lemma_collinearorder).
assert (Par H D G B) by (conclude lemma_parallelsymmetric).
assert (Par H D A B) by (conclude lemma_collinearparallel).
assert (Par H D B A) by (forward_using lemma_parallelflip).
assert (Col B A G) by (forward_using lemma_collinearorder).
assert (neq G A) by (forward_using lemma_betweennotequal).
assert (Par H D G A) by (conclude lemma_collinearparallel).
assert (Par H D A G) by (forward_using lemma_parallelflip).
assert (Par A G H D) by (conclude lemma_parallelsymmetric).
let Tf:=fresh in
assert (Tf:exists a g h d m, (neq A G /\ neq H D /\ Col A G a /\ Col A G g /\ neq a g /\ Col H D h /\ Col H D d /\ neq h d /\ ~ Meet A G H D /\ BetS a m d /\ BetS h m g)) by (conclude_def Par );destruct Tf as [a[g[h[d[m]]]]];spliter.
assert (neq D H) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists C, (BetS D H C /\ Cong H C D H)) by (conclude lemma_extension);destruct Tf as [C];spliter.
assert (BetS H G E) by (conclude axiom_betweennesssymmetry).
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (neq B A) by (conclude lemma_inequalitysymmetric).
assert (neq D C) by (forward_using lemma_betweennotequal).
assert (neq C D) by (conclude lemma_inequalitysymmetric).
assert (Col A G B) by (conclude_def Col ).
assert (Col G A B) by (forward_using lemma_collinearorder).
assert (Col G A a) by (forward_using lemma_collinearorder).
assert (neq G A) by (conclude lemma_inequalitysymmetric).
assert (Col A B a) by (conclude lemma_collinear4).
assert (Col G A g) by (forward_using lemma_collinearorder).
assert (Col A B g) by (conclude lemma_collinear4).
assert (Col D H C) by (conclude_def Col ).
assert (Col H D C) by (forward_using lemma_collinearorder).
assert (Col D C h) by (conclude lemma_collinear4).
assert (Col C D h) by (forward_using lemma_collinearorder).
assert (Col D d C) by (conclude lemma_collinear4).
assert (Col C D d) by (forward_using lemma_collinearorder).
assert (~ Meet A B C D).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists M, (neq A B /\ neq C D /\ Col A B M /\ Col C D M)) by (conclude_def Meet );destruct Tf as [M];spliter.
 assert (Col B A G) by (forward_using lemma_collinearorder).
 assert (Col B A M) by (forward_using lemma_collinearorder).
 assert (Col A G M) by (conclude lemma_collinear4).
 assert (Col C D H) by (forward_using lemma_collinearorder).
 assert (Col D H M) by (conclude lemma_collinear4).
 assert (Col H D M) by (forward_using lemma_collinearorder).
 assert (Meet A G H D) by (conclude_def Meet ).
 contradict.
 }
assert (Par A B C D) by (conclude_def Par ).
assert (BetS C H D) by (conclude axiom_betweennesssymmetry).
assert (BetS E G H) by (conclude axiom_betweennesssymmetry).
assert (eq G G) by (conclude cn_equalityreflexive).
assert (Col G H G) by (conclude_def Col ).
assert (nCol G B H) by (forward_using lemma_parallelNC).
assert (nCol G H B) by (forward_using lemma_NCorder).
assert (OS D B G H) by (forward_using lemma_samesidesymmetric).
assert (TS B G H A) by (conclude_def TS ).
assert (TS D G H A) by (conclude lemma_planeseparation).
assert (TS A G H D) by (conclude lemma_oppositesidesymmetric).
assert ((CongA A G H G H D /\ CongA E G B G H D /\ RT B G H G H D)) by (conclude proposition_29).
close.
Qed.

End Euclid.