Require Export section_08_contractible.

(** Section 9.1 Families of equivalences *)

(** Definition 9.1.1 *)

Definition tot {A} {B C : A -> Type} (f : forall x, B x -> C x) :
  Sigma A B -> Sigma A C :=
  fun t => pair (pr1 t) (f (pr1 t) (pr2 t)).

(** Lemma 9.1.2 *)

Definition fib_tot_fib_fmap {A} {B C : A -> Type} (f : forall x, B x -> C x)
           (t : Sigma A C) :
  fib (f (pr1 t)) (pr2 t) -> fib (tot f) t.
Proof.
  destruct t as [x z]; cbn.
  intro y; destruct y as [y p]; destruct p.
  exact (pair (pair x y) refl).
Defined.

Definition fib_fmap_fib_tot {A} {B C : A -> Type} (f : forall x, B x -> C x)
           (t : Sigma A C) :
  fib (tot f) t -> fib (f (pr1 t)) (pr2 t).
Proof.
  intro s; destruct s as [s p]; destruct p; destruct s as [x y].
  exact (pair y refl).
Defined.

Definition is_sec_fib_fmap_fib_tot {A} {B C : A -> Type}
           (f : forall x, B x -> C x) (t : Sigma A C) :
  comp (fib_tot_fib_fmap f t) (fib_fmap_fib_tot f t) ~ idmap.
Proof.
  intro s; destruct s as [s p]; destruct p; now destruct s as [x y].
Defined.

Definition is_retr_fib_fmap_fib_tot {A} {B C : A -> Type}
           (f : forall x, B x -> C x) (t : Sigma A C) :
  comp (fib_fmap_fib_tot f t) (fib_tot_fib_fmap f t) ~ idmap.
Proof.
  destruct t as [x z]; cbn.
  intro y; destruct y as [y p]; destruct p.
  reflexivity.
Defined.

Lemma is_equiv_fib_tot_fib_fmap {A} {B C : A -> Type}
      (f : forall x, B x -> C x) (t : Sigma A C) :
  is_equiv (fib_tot_fib_fmap f t).
Proof.
  apply (is_equiv_has_inverse (fib_fmap_fib_tot f t)).
  - exact (is_sec_fib_fmap_fib_tot f t).
  - exact (is_retr_fib_fmap_fib_tot f t).
Defined.

Definition fib_tot_fib_fmap_equiv {A} {B C : A -> Type}
           (f : forall x, B x -> C x) (t : Sigma A C) :
  (fib (f (pr1 t)) (pr2 t)) <~> (fib (tot f) t) :=
  pair (fib_tot_fib_fmap f t) (is_equiv_fib_tot_fib_fmap f t).

Lemma is_equiv_fib_fmap_fib_tot {A} {B C : A -> Type}
      (f : forall x, B x -> C x) (t : Sigma A C) :
  is_equiv (fib_fmap_fib_tot f t).
Proof.
  apply (is_equiv_has_inverse (fib_tot_fib_fmap f t)).
  - exact (is_retr_fib_fmap_fib_tot f t).
  - exact (is_sec_fib_fmap_fib_tot f t).
Defined.

Definition fib_fmap_fib_tot_equiv {A} {B C : A -> Type}
           (f : forall x, B x -> C x) (t : Sigma A C) :
  (fib (tot f) t) <~> (fib (f (pr1 t)) (pr2 t)) :=
  pair (fib_fmap_fib_tot f t) (is_equiv_fib_fmap_fib_tot f t).

(** Theorem 9.1.3 *)

Theorem is_equiv_is_equiv_tot {A} {B C : A -> Type} (f : forall x, B x -> C x) :
  is_equiv (tot f) -> forall x, is_equiv (f x).
Proof.
  intros H x.
  apply is_equiv_is_contr_map.
  intro z.
  apply (is_contr_equiv (fib_tot_fib_fmap_equiv f (pair x z))).
  now apply is_contr_map_is_equiv.
Defined.

Theorem is_equiv_tot_is_equiv {A} {B C : A -> Type} {f : forall x, B x -> C x} :
  (forall x, is_equiv (f x)) -> is_equiv (tot f).
Proof.
  intro H.
  apply is_equiv_is_contr_map.
  intro t; destruct t as [x z].
  apply (is_contr_equiv (fib_fmap_fib_tot_equiv f (pair x z))); cbn.
  now apply is_contr_map_is_equiv.
Defined.

Definition tot_equiv {A} {B C : A -> Type} :
  (forall x, (B x <~> C x)) -> ((Sigma A B) <~> (Sigma A C)) :=
  fun e =>
    pair
      (tot (fun x => map_equiv (e x)))
      (is_equiv_tot_is_equiv (fun x => is_equiv_map_equiv (e x))).

(** Lemma 9.1.4 *)

Definition btot {A B} (f : A -> B) (C : B -> Type) :
  Sigma A (fun x => C (f x)) -> Sigma B C :=
  fun t => pair (f (pr1 t)) (pr2 t).

Definition fib_map_fib_btot {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  fib (btot f C) t -> fib f (pr1 t).
Proof.
  intro s; destruct s as [s p]; destruct p; destruct s as [x z]; cbn.
  exact (pair x refl).
Defined.

Definition fib_btot_fib_map {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  fib f (pr1 t) -> fib (btot f C) t.
Proof.
  destruct t as [y z]; cbn.
  intro s; destruct s as [x p]; destruct p.
  now apply (pair (pair x z)).
Defined.

Definition is_sec_fib_btot_fib_map
           {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  comp (fib_map_fib_btot f C t) (fib_btot_fib_map f C t) ~ idmap.
Proof.
  destruct t as [y z]; cbn.
  intro s; destruct s as [x p]; destruct p.
  reflexivity.
Defined.

Definition is_retr_fib_btot_fib_map
           {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  comp (fib_btot_fib_map f C t) (fib_map_fib_btot f C t) ~ idmap.
Proof.
  intro s; destruct s as [s p]; destruct p; destruct s as [x z]; cbn.
  reflexivity.
Defined.

Lemma is_equiv_fib_map_fib_btot
      {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  is_equiv (fib_map_fib_btot f C t).
Proof.
  apply (is_equiv_has_inverse (fib_btot_fib_map f C t)).
  - exact (is_sec_fib_btot_fib_map f C t).
  - exact (is_retr_fib_btot_fib_map f C t).
Defined.

Definition fib_map_fib_btot_equiv
           {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  fib (btot f C) t <~> fib f (pr1 t) :=
  pair (fib_map_fib_btot f C t) (is_equiv_fib_map_fib_btot f C t).

Lemma is_equiv_fib_btot_fib_map
      {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  is_equiv (fib_btot_fib_map f C t).
Proof.
  apply (is_equiv_has_inverse (fib_map_fib_btot f C t)).
  - exact (is_retr_fib_btot_fib_map f C t).
  - exact (is_sec_fib_btot_fib_map f C t).
Defined.

Definition fib_btot_fib_map_equiv
           {A B} (f : A -> B) (C : B -> Type) (t : Sigma B C) :
  fib f (pr1 t) <~> fib (btot f C) t :=
  pair (fib_btot_fib_map f C t) (is_equiv_fib_btot_fib_map f C t).

Lemma is_equiv_btot_is_equiv {A B} {f : A -> B} (C : B -> Type) :
  is_equiv f -> is_equiv (btot f C).
Proof.
  intro H.
  apply is_equiv_is_contr_map.
  intro t; destruct t as [x z].
  apply (is_contr_equiv (fib_map_fib_btot_equiv f C (pair x z))); cbn.
  now apply is_contr_map_is_equiv.
Defined.

Definition btot_equiv {A B} (e : A <~> B) (C : B -> Type) :
  Sigma A (comp C (map_equiv e)) <~> Sigma B C :=
  pair (btot (map_equiv e) C) (is_equiv_btot_is_equiv C (is_equiv_map_equiv e)).

(** Definition 9.1.5 *)

Definition toto {A B} (f : A -> B) {C : A -> Type} (D : B -> Type) :
  (forall x, C x -> D (f x)) -> Sigma A C -> Sigma B D :=
  fun g t => pair (f (pr1 t)) (g (pr1 t) (pr2 t)).

(** Theorem 9.1.6 *)

Definition triangle_toto {A B} (f : A -> B)
           {C : A -> Type} (D : B -> Type) (g : forall x, C x -> D (f x)) :
  toto f D g ~ comp (btot f D) (tot g).
Proof.
  exact refl_htpy.
Defined.

(** Tactics were again too annoying, but the proof term is easy to write down.
 *)

Definition is_equiv_toto_is_equiv {A B} {f : A -> B}
        {C : A -> Type} (D : B -> Type) {g : forall x, C x -> D (f x)} :
  is_equiv f -> (forall x, is_equiv (g x)) -> is_equiv (toto f D g) :=
  fun Ef Eg =>
    @is_equiv_comp _ _ _
                   (toto f D g)
                   (btot f D)
                   (pair (tot g) (triangle_toto f D g))
                   (is_equiv_tot_is_equiv Eg)
                   (is_equiv_btot_is_equiv D Ef).

Definition equiv_toto {A B} (e : A <~> B) {C : A -> Type} (D : B -> Type)
           (g : forall x, (C x <~> D (map_equiv e x))) :
  Sigma A C <~> Sigma B D :=
  pair (toto (map_equiv e) D (fun x => map_equiv (g x)))
       (is_equiv_toto_is_equiv D (is_equiv_map_equiv e)
                                 (fun x => is_equiv_map_equiv (g x))).

Definition is_equiv_is_equiv_toto {A B} {f : A -> B}
        {C : A -> Type} (D : B -> Type) {g : forall x, C x -> D (f x)} :
  is_equiv f -> is_equiv (toto f D g) -> (forall x, is_equiv (g x)) :=
  fun Ef Efg =>
    is_equiv_is_equiv_tot g
      (@is_equiv_right_factor _ _ _
                              (toto f D g)
                              (btot f D)
                              (pair (tot g) (triangle_toto f D g))
                              Efg
                              (is_equiv_btot_is_equiv D Ef)).

(** Section 9.2 The fundamental theorem *)

(** Definition 9.2.1 *)

(** We define a generalized ev_refl *)
Definition ev_refl_gen {A} (a : A) {B : A -> Type} (b : B a)
           (C : forall x, B x -> Type) : (forall x y, C x y) -> C a b :=
  fun h => h a b.

(* We also say that a family B over A with b : B a is an identity system if
   it satisfies the following path induction principle. *)

Definition Ind_path {A} {a : A} (B : A -> Type) (b : B a) : Type :=
  forall (C : forall x, B x -> Type), sec (ev_refl_gen a b C).

Definition Identity_System {A} (a : A) : Type :=
  Sigma (A -> Type) (fun B => Sigma (B a) (fun b => Ind_path B b)).

(** Theorem 9.2.3 The fundamental theorem of identity types *)

Theorem fundamental_thm_id {A} {a : A} {B : A -> Type} (b : B a)
        (f : forall x, a == x -> B x) :
  is_contr (Sigma A B) -> forall x, is_equiv (f x).
Proof.
  intro c.
  apply is_equiv_is_equiv_tot.
  apply is_equiv_is_contr.
  - apply is_contr_total_path.
  - assumption.
Defined.

Theorem fundamental_thm_id' {A} {a : A} (B : A -> Type) (b : B a) :
  is_contr (Sigma A B) -> forall x, is_equiv (fun (p : a == x) => tr B p b).
Proof.
  now apply fundamental_thm_id.
Defined.

Theorem conv_fundamental_thm_id {A} {a : A} {B : A -> Type} (b : B a)
        (f : forall x, a == x -> B x) :
  (forall x, is_equiv (f x)) -> is_contr (Sigma A B).
Proof.
  intro H.
  apply (is_contr_is_equiv' (is_equiv_tot_is_equiv H)).
  apply is_contr_total_path.
Defined.

Definition fam_Sigma {A} {B : A -> Type} (C : forall x, B x -> Type) :
  Sigma A B -> Type :=
  fun t =>
    match t with
    | pair x y => C x y
    end.

Definition ev_pair {A} {B : A -> Type} (C : Sigma A B -> Type) :
  (forall (t : Sigma A B), C t) -> (forall x y, C (pair x y)) :=
  fun h x y => h (pair x y).

Definition inv_ev_pair {A} {B : A -> Type} (C : Sigma A B -> Type) :
  (forall x y, C (pair x y)) -> (forall (t : Sigma A B), C t).
Proof.
  intros h t; destruct t as [x y].
  exact (h x y).
Defined.

Definition is_sec_inv_ev_pair {A} {B : A -> Type} (C : Sigma A B -> Type) :
  comp (ev_pair C) (inv_ev_pair C) ~ idmap := refl_htpy.

Definition sec_ev_pair {A} {B : A -> Type} (C : Sigma A B -> Type) :
  sec (ev_pair C) :=
  pair (inv_ev_pair C) (is_sec_inv_ev_pair C).

Definition triangle_path_ind
           {A} {a : A} {B : A -> Type} (b : B a) (C : Sigma A B -> Type) :
  @ev_pt (Sigma A B) C (pair a b) ~
         comp (ev_refl_gen a b (fun x y => C (pair x y))) (ev_pair C) :=
  refl_htpy.

Definition hom_slice_path_ind
           {A} {a : A} {B : A -> Type} (b : B a) (C : Sigma A B -> Type) :
  hom_slice (ev_pt (pair a b)) (ev_refl_gen a b (fun x y => C (pair x y))) :=
  pair (ev_pair C) (triangle_path_ind b C).

Theorem Ind_path_is_contr_total
        {A} {a : A} {B : A -> Type} (b : B a) (C : forall x, B x -> Type) :
  is_contr (Sigma A B) -> sec (ev_refl_gen a b C).
Proof.
  intro c.
  apply section_comp with (hom_slice_path_ind b (fam_Sigma C)).
  - exact (sec_ev_pair (fam_Sigma C)).
  - exact (Ind_sing_is_contr c (pair a b) (fam_Sigma C)).
Defined.

Definition ind_path_is_contr_total
           {A} {a : A} {B : A -> Type} (b : B a) (C : forall x, B x -> Type) :
  is_contr (Sigma A B) -> C a b -> forall x y, C x y :=
  fun is_contr_AB => pr1 (Ind_path_is_contr_total b C is_contr_AB).

Definition comp_path_is_contr_total
           {A} {a : A} {B : A -> Type} (b : B a) (C : forall x, B x -> Type)
           (is_contr_AB : is_contr (Sigma A B)) (c : C a b) :
  ind_path_is_contr_total b C is_contr_AB c a b == c :=
  pr2 (Ind_path_is_contr_total b C is_contr_AB) c.

Theorem is_contr_total_Ind_path
        {A} {a : A} {B : A -> Type} (b : B a) :
  Ind_path B b -> is_contr (Sigma A B).
Proof.
  intro P.
  apply (is_contr_Ind_sing (pair a b)).
  intro C.
  apply section_comp' with (hom_slice_path_ind b C).
  exact (sec_ev_pair C).
  exact (P (fun x y => C (pair x y))).
Defined.

(** Section 9.3 Embeddings *)

(** Definition 9.3.1 *)

Definition is_emb {A B} (f : A -> B) : Type :=
  forall x y, is_equiv (@ap A B f x y).

(** Theorem 9.3.2 *)

Definition fib' {A B} (f : A -> B) (b : B) : Type :=
  Sigma A (fun x => b == f x).

Definition fib_fib_equiv {A B} (f : A -> B) (b : B) :
  fib' f b <~> fib f b :=
  tot_equiv (fun x => @invmap_equiv B b (f x)).

Theorem is_emb_is_equiv {A B} (f : A -> B) :
  is_equiv f -> is_emb f.
Proof.
  intros H x.
  apply fundamental_thm_id.
  - reflexivity.
  - apply (is_contr_equiv (fib_fib_equiv f (f x))).
    now apply is_contr_map_is_equiv.
Defined.

(** Section 9.4 Disjointness of coproducts *)

(** Theorem 9.4.1 *)

(** This theorem is stated at the beginning of the section, and proven at the
    end. *)

(** Definition 9.4.2 *)

Definition Eq_coprod {A B} (x y : coprod A B) : Type.
Proof.
  destruct x as [a|b].
  - destruct y as [a'|b'].
    * exact (a == a').
    * exact empty.
  - destruct y as [a'|b'].
    * exact empty.
    * exact (b == b').
Defined.

(** Lemma 9.4.3 *)

Lemma refl_Eq_coprod {A B} (x : coprod A B) : Eq_coprod x x.
Proof.
  now destruct x.
Defined.

Definition Eq_coprod_eq {A B} {x y : coprod A B} (p : x == y) : Eq_coprod x y.
Proof.
  destruct p. apply refl_Eq_coprod.
Defined.

(** Lemma 9.4.4 *)

(** We show that Sigma distributes over coproducts *)

Definition map_distr_Sigma_coprod {A B} (P : coprod A B -> Type) :
  Sigma (coprod A B) P ->
  coprod (Sigma A (comp P inl)) (Sigma B (comp P inr)).
Proof.
  intro t; destruct t as [[a | b] y].
  - exact (inl (pair a y)).
  - exact (inr (pair b y)).
Defined.

Definition inv_map_distr_Sigma_coprod {A B} (P : coprod A B -> Type) :
  coprod (Sigma A (comp P inl)) (Sigma B (comp P inr)) ->
  Sigma (coprod A B) P.
Proof.
  intro x; destruct x as [[a p]|[b p]].
  - exact (pair (inl a) p).
  - exact (pair (inr b) p).
Defined.

Definition is_sec_inv_map_distr_Sigma_coprod {A B} (P : coprod A B -> Type) :
  comp (map_distr_Sigma_coprod P) (inv_map_distr_Sigma_coprod P) ~ idmap.
Proof.
    intro x; now destruct x as [[a p]|[b p]].
Defined.

Definition is_retr_inv_map_distr_Sigma_coprod {A B} (P : coprod A B -> Type) :
  comp (inv_map_distr_Sigma_coprod P) (map_distr_Sigma_coprod P) ~ idmap.
Proof.
  intro t; now destruct t as [[a | b] y].
Defined.

Lemma is_equiv_map_distr_Sigma_coprod {A B} (P : coprod A B -> Type) :
  is_equiv (map_distr_Sigma_coprod P).
Proof.
  simple refine (is_equiv_has_inverse _ _ _).
  - exact (inv_map_distr_Sigma_coprod P).
  - exact (is_sec_inv_map_distr_Sigma_coprod P).
  - exact (is_retr_inv_map_distr_Sigma_coprod P).
Defined.

Definition distr_Sigma_coprod {A B} (P : coprod A B -> Type) :
  Sigma (coprod A B) P
        <~>
        coprod (Sigma A (comp P inl)) (Sigma B (comp P inr)) :=
  pair (map_distr_Sigma_coprod P) (is_equiv_map_distr_Sigma_coprod P).

Lemma is_contr_total_Eq_coprod_inl {A B} (x : A) :
  is_contr (Sigma (coprod A B) (Eq_coprod (inl x))).
Proof.
  apply (is_contr_equiv (distr_Sigma_coprod (Eq_coprod (inl x)))).
  simple refine (is_contr_equiv _ _).
  - exact (coprod (total_path x) empty).
  - refine (coprod_equiv _ _).
    * exact id_equiv.
    * exact right_zero_law_prod.
  - simple refine (is_contr_equiv' _ _).
    * exact (total_path x).
    * exact right_unit_law_coprod.
    * apply is_contr_total_path.
Defined.

Lemma is_contr_total_Eq_coprod_inr {A B} (y : B) :
  is_contr (Sigma (coprod A B) (Eq_coprod (inr y))).
Proof.
  apply (is_contr_equiv (distr_Sigma_coprod (Eq_coprod (inr y)))).
  simple refine (is_contr_equiv _ _).
  - exact (coprod empty (total_path y)).
  - refine (coprod_equiv _ _).
    * exact right_zero_law_prod.
    * exact id_equiv.
  - simple refine (is_contr_equiv' _ _).
    * exact (total_path y).
    * exact left_unit_law_coprod.
    * apply is_contr_total_path.
Defined.

Theorem is_contr_total_Eq_coprod {A B} (x : coprod A B) :
  is_contr (Sigma (coprod A B) (Eq_coprod x)).
Proof.
  destruct x as [x|y].
  - apply is_contr_total_Eq_coprod_inl.
  - apply is_contr_total_Eq_coprod_inr.
Defined.

Theorem is_equiv_Eq_coprod_eq {A B} {x y : coprod A B} :
  is_equiv (@Eq_coprod_eq A B x y).
Proof.
  apply fundamental_thm_id.
  - apply refl_Eq_coprod.
  - apply is_contr_total_Eq_coprod.
Defined.


Require Import Bool Arith String List CpdtTactics.
Open Scope string_scope.

Definition var := string.

Inductive binop := Plus | Times | Minus.

Inductive aexp : Type :=
| Const : nat -> aexp
| Var : var -> aexp
| Binop : aexp -> binop -> aexp -> aexp.

Inductive bexp : Type :=
| Tt : bexp
| Ff : bexp
| Eq : aexp -> aexp -> bexp
| Lt : aexp -> aexp -> bexp
| And : bexp -> bexp -> bexp
| Or : bexp -> bexp -> bexp
| Not : bexp -> bexp.

Inductive com : Type :=
| Skip : com
| Assign : var -> aexp -> com
| Seq : com -> com -> com
| If : bexp -> com -> com -> com
| While : bexp -> com -> com.

Definition state := var -> nat.

Definition get (x:var) (s:state) : nat := s x.

Definition set (x:var) (n:nat) (s:state) : state :=
  fun y =>
    match string_dec x y with
        | left H => n
        | right H' => get y s
    end.

Definition eval_binop (b:binop) : nat -> nat -> nat :=
  match b with
    | Plus => plus
    | Times => mult
    | Minus => minus
  end.

Fixpoint eval_aexp (e:aexp) (s:state) : nat :=
  match e with
    | Const n => n
    | Var x => get x s
    | Binop e1 b e2 => (eval_binop b) (eval_aexp e1 s) (eval_aexp e2 s)
  end.

Fixpoint eval_bexp (b:bexp) (s:state) : bool :=
  match b with
    | Tt => true
    | Ff => false
    | Eq e1 e2 => NPeano.Nat.eqb (eval_aexp e1 s) (eval_aexp e2 s)
    | Lt e1 e2 => NPeano.ltb (eval_aexp e1 s) (eval_aexp e2 s)
    | And b1 b2 => eval_bexp b1 s && eval_bexp b2 s
    | Or b1 b2 => eval_bexp b1 s || eval_bexp b2 s
    | Not b => negb (eval_bexp b s)
  end.

Inductive eval_com : com -> state -> state -> Prop :=
| Eval_skip : forall s, eval_com Skip s s
| Eval_assign : forall s x e, eval_com (Assign x e) s (set x (eval_aexp e s) s)
| Eval_seq : forall c1 s0 s1 c2 s2,
               eval_com c1 s0 s1 -> eval_com c2 s1 s2 -> eval_com (Seq c1 c2) s0 s2
| Eval_if_true : forall b c1 c2 s s',
                   eval_bexp b s = true ->
                   eval_com c1 s s' -> eval_com (If b c1 c2) s s'
| Eval_if_false : forall b c1 c2 s s',
                   eval_bexp b s = false ->
                   eval_com c2 s s' -> eval_com (If b c1 c2) s s'
| Eval_while_false : forall b c s,
                       eval_bexp b s = false ->
                       eval_com (While b c) s s
| Eval_while_true : forall b c s1 s2 s3,
                      eval_bexp b s1 = true ->
                      eval_com c s1 s2 ->
                      eval_com (While b c) s2 s3 ->
                      eval_com (While b c) s1 s3.

Definition prog1 :=
  Seq (Assign "y" (Const 1))
  (Seq (Assign "x" (Const 3))
       (While (Lt (Const 0) (Var "x"))
              (Seq (Assign "y" (Binop (Var "y") Times (Const 2)))
                   (Assign "x" (Binop (Var "x") Minus (Const 1)))))).

Definition prog2 := While Tt Skip.

Ltac myinj H := injection H ; intros ; subst ; clear H.

Lemma while_true_imp_false : forall c s1 s2, eval_com c s1 s2 ->
                                             forall b c', (forall s, eval_bexp b s = true) ->
                                                          c = While b c' ->
                                                          False.
Proof.
  Ltac foo :=
  match goal with
    | [ H : ?x _ _ = ?x _ _ |- _ ] => myinj H
    | [ H : forall s, eval_bexp _ s = _,
        H' : eval_bexp _ ?s0 = _ |- _] =>
      specialize (H s0) ; congruence
    | [ H : forall b c, _ -> _ |- _ ] => eapply H ; eauto
  end.

  induction 1 ; intros ; try discriminate ; repeat foo.
Qed.

Lemma prog2_div : forall s1 s2, eval_com prog2 s1 s2 -> False.

  Lemma prog2_div' : forall c s1 s2, eval_com c s1 s2 -> c = prog2 -> False.
  Proof.
    unfold prog2 ; induction 1; crush.
  Qed.
  Show.
  intros. apply (prog2_div' _ _ _ H eq_refl).
Qed.

(* A simple chained tactic *)
Ltac myinv H := inversion H ; subst ; clear H ; simpl in *.

(* This tactic applies when we have a hypothesis involving
   eval_com of either a Seq or an Assign.  It inverts the
   hypothesis, and performs substitution, simplifying things.
*)
Ltac eval_inv :=
  match goal with
    | [ H : eval_com (Seq _ _) _ _ |- _ ] => myinv H
    | [ H : eval_com (Assign _ _) _ _ |- _ ] => myinv H
  end.

(* This tactic inverts an eval_com of a While, producing
   two sub-goals.  It tries to eliminate one (or both) of the goals
   through discrimination on the hypotheses.
*)
Ltac eval_while_inv :=
  match goal with
    | [ H : eval_com (While _ _) _ _ |- _ ] => myinv H ; try discriminate
  end.

Theorem prog1_prop : forall s1 s2, eval_com prog1 s1 s2 -> get "x" s2 = 0.
Proof.
  unfold prog1 ; intros.
  repeat ((repeat eval_inv) ; eval_while_inv).
  auto.
Qed.

Theorem seq_assoc :
  forall c1 c2 c3 s1 s2,
    eval_com (Seq (Seq c1 c2) c3) s1 s2 ->
    eval_com (Seq c1 (Seq c2 c3)) s1 s2.
  Lemma seq_assoc' :
    forall c s1 s2,
      eval_com c s1 s2 ->
      forall c1 c2 c3,
        c = Seq (Seq c1 c2) c3 ->
        eval_com (Seq c1 (Seq c2 c3)) s1 s2.
  Proof.
    (* Adds all of the eval_com constructors as hints for auto/crush *)
    Hint Constructors eval_com.
    induction 1 ; crush.
    inversion H ; clear H ; subst ;
    econstructor ; eauto.
  Qed.

  intros. eapply seq_assoc' ; eauto.
Qed.

(* Returns true when the variable x occurs as a subexpression of a *)
Fixpoint contains (x:var) (a:aexp) : bool :=
  match a with
    | Const _ => false
    | Var y => if string_dec x y then true else false
    | Binop a1 _ a2 => contains x a1 || contains x a2
  end.

(* Changing a variable x that doesn't occur in a doesn't effect the
   value of a. *)
Lemma eval_exp_set :
  forall s x n a,
    contains x a = false ->
    eval_aexp a (set x n s) = eval_aexp a s.
Proof.
  induction a ; unfold set, get ; simpl ; unfold get ; crush.
  destruct (string_dec x v) ; crush.
  destruct (contains x a1) ; crush.
Qed.

(* We can commute assignments x:=ax; y:=ay  as long as the
   variables don't overlap. *)
Lemma assign_comm :
  forall x ax y ay s1 s2,
    eval_com (Seq (Assign x ax) (Assign y ay)) s1 s2 ->
    contains x ay = false ->
    contains y ax = false ->
    x <> y ->
    forall s3, eval_com (Seq (Assign y ay) (Assign x ax)) s1 s3 -> s2 = s3.
(*
               forall z, get z s3 = get z s2.
*)
Proof.
  intros.
  repeat eval_inv.
  repeat unfold set, get.
  destruct (string_dec x z) ; destruct (string_dec y z) ; try congruence.
  specialize (eval_exp_set s1 y (eval_aexp ay s1) ax H1).
  unfold set. crush.
  specialize (eval_exp_set s1 x (eval_aexp ax s1) ay H0).
  unfold set. crush.
Qed.

Lemma assign_comm2 :
  forall x ax y ay s1 s2,
    eval_com (Seq (Assign x ax) (Assign y ay)) s1 s2 ->
    contains x ay = false ->
    contains y ax = false ->
    x <> y ->
    eval_com (Seq (Assign y ay) (Assign x ax)) s1 s2.
Proof.
  intros.
  remember (set x (eval_aexp ax (set y (eval_aexp ay s1) s1))
                (set y (eval_aexp ay s1) s1)) as s3.
  assert (eval_com (Seq (Assign y ay) (Assign x ax)) s1 s3).
  rewrite Heqs3.
  eauto.
  specialize (assign_comm x ax y ay s1 s2 H H0 H1 H2 _ H3).
  intro.
  assert (s3 = s2).
  Focus 2.
  rewrite <- H5.
  auto.
  Admitted.


Require Export NArith.
Require Import ZArith.

Open Scope N_scope.

Theorem Nle_le: forall n  m, (N.to_nat n <= N.to_nat m)%nat -> n <= m.
intros n m; case n; case m; unfold N.le; simpl; try (intros; discriminate).
intros p; elim p using Pind; simpl.
intros H1; inversion H1.
intros n1 _; rewrite nat_of_P_succ_morphism.
intros H1; inversion H1.
intros p1 p2 H1 H2; absurd (nat_of_P p2 > nat_of_P p1)%nat; auto with arith.
apply nat_of_P_gt_Gt_compare_morphism; auto.
Qed.

Theorem le_Nle: forall n m, N.of_nat n <= N.of_nat m -> (n <= m)%nat.
intros n m; case n; case m; unfold N.le; simpl; auto with arith.
intros n1 H1; case H1; auto.
intros m1 n1 H1; case (le_or_lt n1 m1); auto with arith.
intros H2; case H1.
apply nat_of_P_gt_Gt_compare_complement_morphism.
repeat rewrite  nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith.
Qed.

Theorem Nle_le_rev: forall n  m, n <= m -> (N.to_nat n <= N.to_nat m)%nat.
intros; apply le_Nle; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nlt_lt: forall n  m, (N.to_nat n < N.to_nat m)%nat -> n < m.
intros n m; case n; case m; unfold N.lt; simpl; try (intros; discriminate); auto.
intros H1; inversion H1.
intros p H1; inversion H1.
intros; apply nat_of_P_lt_Lt_compare_complement_morphism; auto.
Qed.

Theorem lt_Nlt: forall n m, N.of_nat n < N.of_nat m -> (n < m)%nat.
intros n m; case n; case m; unfold N.lt; simpl; try (intros; discriminate); auto with arith.
intros m1 n1 H1.
rewrite <- (Nat2N.id (S n1)); rewrite <- (Nat2N.id (S m1)).
simpl; apply nat_of_P_lt_Lt_compare_morphism; auto.
Qed.

Theorem Nlt_lt_rev: forall n  m, n < m -> (N.to_nat n < N.to_nat m)%nat.
intros; apply lt_Nlt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Nge_ge: forall n  m, (N.to_nat n >= N.to_nat m)%nat -> n >= m.
intros n m; case n; case m; unfold N.ge; simpl; try (intros; discriminate); auto.
intros p; elim p using Pind; simpl.
intros H1; inversion H1.
intros n1 _; rewrite nat_of_P_succ_morphism.
intros H1; inversion H1.
intros p1 p2 H1 H2; absurd (nat_of_P p2 < nat_of_P p1)%nat; auto with arith.
apply nat_of_P_lt_Lt_compare_morphism; auto.
Qed.

Theorem ge_Nge: forall n m, N.of_nat n >= N.of_nat m -> (n >= m)%nat.
intros n m; case n; case m; unfold N.ge; simpl; try (intros; discriminate); auto with arith.
intros n1 H1; case H1; auto.
intros m1 n1 H1.
case (le_or_lt m1 n1); auto with arith.
intros H2; case H1.
apply nat_of_P_lt_Lt_compare_complement_morphism.
repeat rewrite  nat_of_P_o_P_of_succ_nat_eq_succ; auto with arith.
Qed.

Theorem Nge_ge_rev: forall n  m, n >= m -> (N.to_nat n >= N.to_nat m)%nat.
intros; apply ge_Nge; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Ngt_gt: forall n  m, (N.to_nat n > N.to_nat m)%nat -> n > m.
intros n m; case n; case m; unfold N.gt; simpl; try (intros; discriminate); auto.
intros H1; inversion H1.
intros p H1; inversion H1.
intros; apply nat_of_P_gt_Gt_compare_complement_morphism; auto.
Qed.

Theorem gt_Ngt: forall n m, N.of_nat n > N.of_nat m -> (n > m)%nat.
intros n m; case n; case m; unfold N.gt; simpl; try (intros; discriminate); auto with arith.
intros m1 n1 H1.
rewrite <- (Nat2N.id (S n1)); rewrite <- (Nat2N.id (S m1)).
simpl; apply nat_of_P_gt_Gt_compare_morphism; auto.
Qed.

Theorem Ngt_gt_rev: forall n  m, n > m -> (N.to_nat n > N.to_nat m)%nat.
intros; apply gt_Ngt; repeat rewrite N2Nat.id; auto.
Qed.

Theorem Neq_eq_rev: forall n  m, n = m -> (N.to_nat n = N.to_nat m)%nat.
intros n m H; rewrite H; auto.
Qed.

Import BinPos.

Ltac to_nat_op  :=
  match goal with
      H: (N.lt _ _) |- _ => generalize (Nlt_lt_rev _ _ H); clear H; intros H
|     H: (N.gt _ _) |- _ => generalize (Ngt_gt_rev _ _ H); clear H; intros H
|     H: (N.le _ _) |- _ => generalize (Nle_le_rev _ _ H); clear H; intros H
|     H: (N.ge _ _) |- _ => generalize (Nge_ge_rev _ _ H); clear H; intros H
|     H: (@eq N _ _) |- _ => generalize (Neq_eq_rev _ _ H); clear H; intros H
|      |- (N.lt _ _)  => apply Nlt_lt
|      |- (N.le _ _)  => apply Nle_le
|      |- (N.gt _ _)  => apply Ngt_gt
|      |- (N.ge _ _)  => apply Nge_ge
|      |- (@eq N _ _)  => apply Nat2N.inj
end.

Ltac set_to_nat :=
let nn := fresh "nn" in
match goal with
       |- context [(N.to_nat (?X + ?Y)%N)]  => rewrite N2Nat.inj_add
|      |- context [(N.to_nat (?X * ?Y)%N)]  => rewrite N2Nat.inj_mul
|      |- context [(N.to_nat ?X)]  => set (nn:=N.to_nat X) in * |- *
|      H: context [(N.to_nat (?X + ?Y)%N)] |- _ => rewrite N2Nat.inj_add in H
|      H: context [(N.to_nat (?X + ?Y)%N)] |- _ => rewrite N2Nat.inj_mul in H
|      H: context [(N.to_nat ?X)] |- _ => set (nn:=N.to_nat X) in * |- *
end.

Ltac to_nat := repeat to_nat_op; repeat set_to_nat.

Theorem Nle_gt_trans: forall n m p, m <= n -> m > p -> n > p.
intros; to_nat; apply le_gt_trans with nn1; auto.
Qed.

Theorem Ngt_le_trans: forall n m p, n > m -> p <= m -> n > p.
intros; to_nat; apply gt_le_trans with nn1; auto.
Qed.

Theorem Nle_add_l :
  forall x y, x <= y + x.
intros; to_nat; auto with arith.
Qed.

Close Scope N_scope.


(* This file implements a 'chained list'. This can essentially be
thought of as the proof-relevant transitive reflexive closure of
a relation. That is, each link (element) has a "from" point that
must match the previous element's "to" point. *)
Require Import Automation.
Section ChainedList.
Context {Point : Type} {Link : Point -> Point -> Type}.

Inductive ChainedList : Point -> Point -> Type :=
  | clnil : forall {p}, ChainedList p p
  | snoc : forall {from mid to},
      ChainedList from mid -> Link mid to -> ChainedList from to.

Fixpoint clist_app
           {from mid to}
           (xs : ChainedList from mid)
           (ys : ChainedList mid to) : ChainedList from to :=
  match ys with
  | clnil => fun xs => xs
  | snoc ys' y => fun xs => snoc (clist_app xs ys') y
  end xs.

Infix "++" := clist_app (right associativity, at level 60).

Definition clist_prefix
           {from mid to}
           (prefix : ChainedList from mid)
           (full : ChainedList from to) : Prop :=
  exists suffix, full = prefix ++ suffix.

Definition clist_suffix
           {from mid to}
           (suffix : ChainedList mid to)
           (full : ChainedList from to) : Prop :=
  exists prefix, full = prefix ++ suffix.

Infix "`prefix_of`" := clist_prefix (at level 70).
Infix "`suffix_of`" := clist_suffix (at level 70).

Section Theories.
Lemma app_clnil_l {from to} (xs : ChainedList from to) :
  clnil ++ xs = xs.
Proof. induction xs; auto; cbn; solve_by_rewrite. Qed.

Lemma clist_app_assoc
      {c1 c2 c3 c4}
      (xs : ChainedList c1 c2)
      (ys : ChainedList c2 c3)
      (zs : ChainedList c3 c4) :
  xs ++ ys ++ zs = (xs ++ ys) ++ zs.
Proof. induction zs; intros; auto; cbn; solve_by_rewrite. Qed.
End Theories.

Lemma prefix_of_app
      {from mid to to'}
      {prefix : ChainedList from mid}
      {xs : ChainedList from to}
      {suffix : ChainedList to to'} :
  prefix `prefix_of` xs ->
  prefix `prefix_of` xs ++ suffix.
Proof.
  intros [ex_suffix ex_suffix_eq_app].
  exists (ex_suffix ++ suffix).
  rewrite clist_app_assoc; congruence.
Qed.
End ChainedList.

Delimit Scope clist_scope with trace.
Bind Scope clist_scope with ChainedList.
Infix "++" := clist_app (right associativity, at level 60) : clist_scope.

Infix "`prefix_of`" := clist_prefix (at level 70) : clist_scope.
Infix "`suffix_of`" := clist_suffix (at level 70) : clist_scope.

Arguments ChainedList : clear implicits.


Axiom classic : forall (P : Prop), {P} + {~P}.

Axiom prop_ext : forall {P : Prop} (p q : P), p = q.

Axiom fun_ext : forall {X Y} (f g : X -> Y), (forall x, f x = g x) -> f = g.

Theorem not_not_elim P : ~~P -> P.
Proof. destruct (classic P); intuition. Qed.

Definition definite {T} (V : T -> Prop) := exists! y, V y.
Axiom definite_description : forall {T} (V : T -> Prop), definite V -> sig V.
Definition the {T} (V : T -> Prop) {p : definite V} := proj1_sig (definite_description V p).

Theorem definite_compat {T} (V P : T -> Prop) : definite V -> (exists x, V x /\ P x) <-> (forall x, V x -> P x).
Proof.
  intros [y [? eq]].
  split.
  + intros [x []] z ?.
    replace x with y in *; auto.
    replace z with y in *; auto.
  + intros ?. exists y. auto.
Qed.


(** * Selection:  Selection Sort *)

(** If you don't recall selection sort or haven't seen it in
    a while, see Wikipedia or read any standard textbook; some
    suggestions can be found in [Sort]. *)

(** The specification for sorting algorithms we developed in
    [Sort] can also be used to verify selection sort.  The
    selection-sort program itself is interesting, because writing it
    in Coq will cause us to explore a new technique for convincing Coq
    that a function terminates. *)

(** A couple of notes on efficiency:

    - Selection sort, like insertion sort, runs in quadratic time.
      But selection sort typically makes many more comparisons than
      insertion sort, so insertion sort is usually preferable for
      sorting small inputs.  Selection sort can beat insertion sort if
      the cost of swapping elements is vastly higher than the cost of
      comparing them, but that doesn't apply to functional lists.

    - What you should really never use is bubble sort.  "Bubble sort
      would be the wrong way to go."  Everybody should know that!  See
      this video for a definitive statement:
        {https://www.youtube.com/watch?v=k4RRi_ntQc8&t=34} *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From VFA Require Import Perm.
Hint Constructors Permutation.
From Coq Require Export Lists.List.  (* for exercise involving [List.length] *)

(* ################################################################# *)
(** * The Selection-Sort Program  *)

(** Selection sort on lists is more challenging to code in Coq
    than insertion sort was. First, we write a helper function
    to select the smallest element. *)

(* [select x l] is [(y, l')], where [y] is the smallest element
   of [x :: l], and [l'] is all the remaining elements of [x :: l]
   in their original order. *)
Fixpoint select (x: nat) (l: list nat) : nat * list nat :=
  match l with
  | [] => (x, [])
  | h :: t =>
    if x <=? h
    then let (j, l') := select x t
         in (j, h :: l')
    else let (j, l') := select h t
         in (j, x :: l')
  end.

(** Selection sort should repeatedly extract the smallest element and
    make a list of the results. But the following attempted definition
    fails: *)

Fail Fixpoint selsort (l : list nat) : list nat :=
  match l with
  | [] => []
  | x :: r => let (y, r') := select x r
            in y :: selsort r'
  end.

(** Coq rejects [selsort] because it doesn't satisfy Coq's
    requirements for termination.  The problem is that the recursive
    call in [selsort] is not _structurally decreasing_: the argument
    [r'] at the call site is not known to be a smaller part of the
    original input [l]. Indeed, [select] might not return such a list.
    For example, [select 1 [0; 2]] is [(0, [1; 2])], but [[1; 2]] is
    not a part of [[0; 2]]. *)

(** There are severals ways to fix this problem. One programming
    pattern is to provide _fuel_: an extra argument that has no use in
    the algorithm except to bound the amount of recursion.  The [n]
    argument, below, is the fuel. When it reaches [0], the recursion
    terminates. *)

Fixpoint selsort (l : list nat) (n : nat) : list nat :=
  match l, n with
  | _, O => []  (* ran out of fuel *)
  | [], _ => []
  | x :: r, S n' => let (y, r') := select x r
                  in y :: selsort r' n'
end.

(** If fuel runs out, we get the wrong output. *)

Example out_of_fuel: selsort [3;1;4;1;5] 3 <> [1;1;3;4;5].
Proof.
  simpl. intro. discriminate.
Qed.

(** Extra fuel isn't a problem though. *)

Example extra_fuel: selsort [3;1;4;1;5] 10 = [1;1;3;4;5].
Proof.
  simpl. reflexivity.
Qed.

(** The exact amount of fuel needed is the length of the input list.
    So that's how we define [selection_sort]: *)

Definition selection_sort (l : list nat) : list nat :=
  selsort l (length l).

Example sort_pi :
  selection_sort [3;1;4;1;5;9;2;6;5;3;5] = [1;1;2;3;3;4;5;5;5;6;9].
Proof.
  unfold selection_sort.
  simpl. reflexivity.
Qed.

(* ################################################################# *)
(** * Proof of Correctness *)

(** We begin by repeating from [Sort] the specification of a
    correct sorting algorithm: it rearranges the elements into a list
    that is totally ordered. *)

Inductive sorted: list nat -> Prop :=
 | sorted_nil: sorted []
 | sorted_1: forall i, sorted [i]
 | sorted_cons: forall i j l, i <= j -> sorted (j :: l) -> sorted (i :: j :: l).

Hint Constructors sorted.

Definition is_a_sorting_algorithm (f: list nat -> list nat) := forall al,
    Permutation al (f al) /\ sorted (f al).

(** In the following exercises, you will prove that selection sort
    is a correct sorting algorithm.  You might wish to keep track
    of the lemmas you have proved, so that you can spot places to
    use them later. *)

(** Depending on the path you have followed through _Software
    Foundations_ it might have been a while since you have worked with
    pairs.  Here's a brief reminder of how [destruct] can be used to
    break a pair apart into its components.  A similar technique
    will be needed in many of the following proofs. *)
Example pairs_example : forall (a c x : nat) (b d l : list nat),
    (a, b) = (let (c, d) := select x l in (c, d)) ->
    (a, b) = select x l.
Proof.
  intros. destruct (select x l) eqn:E. auto.
Qed.

(** **** Exercise: 3 stars, standard (select_perm) *)

(** Prove that [select] returns a permutation of its
    input. Proceed by induction on [l].  The [inv] tactic defined at
    the end of [Perm] will be helpful. *)

Lemma select_perm: forall x l y r,
  (y, r) = select x l -> Permutation (x :: l) (y :: r).
Proof.
  intros x l.
  generalize dependent x.
  induction l; intros.
  (* nil *) inv H. auto.
  (* a :: l *)
  inv H.
  assert (Permutation (x :: a :: l) (a :: x :: l)) by constructor.
  bdestruct (a >=? x).
  - (* a >= x *)
    destruct (select x l) eqn:E.
    apply (Permutation_trans H).
    inv H1.
    assert (Permutation (x :: l) (n :: l0)) by auto.
    assert (Permutation (n :: a :: l0) (a :: n :: l0)) by constructor.
    apply Permutation_sym.
    apply (Permutation_trans H2).
    apply Permutation_sym.
    auto.
  - (* a < x *)
    destruct (select a l) eqn:E.
    inv H1.
    assert (Permutation (n :: x :: l0) (x :: n :: l0)) by constructor.
    apply Permutation_sym.
    apply (Permutation_trans H1).
    constructor.
    apply Permutation_sym.
    apply IHl.
    auto.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (selsort_perm) *)

(** Prove that if you provide sufficient fuel, [selsort] produces a
    permutation.  Proceed by induction on [n]. *)

Lemma selsort_perm: forall n l,
    length l = n -> Permutation l (selsort l n).
Proof.
  intro. induction n; intros.
  (* 0 *) apply length_zero_iff_nil in H. subst. auto.
  (* S n *)
  destruct l. auto.
  simpl in H.
  simpl.
  destruct (select n0 l) eqn:E.
  apply eq_sym in E.
  apply select_perm in E.
  apply (Permutation_trans E).
  constructor.
  apply IHn.
  apply Permutation_length in E.
  inv E. inv H. reflexivity.
Qed.

(** [] *)

(** **** Exercise: 1 star, standard (selection_sort_perm) *)

(** Prove that [selection_sort] produces a permutation. *)

Lemma selection_sort_perm: forall l,
    Permutation l (selection_sort l).
Proof.
  intro.
  unfold selection_sort.
  apply selsort_perm.
  reflexivity.
Qed.

(** [] *)

(** **** Exercise: 2 stars, standard (select_rest_length) *)

(** Prove that [select] returns a list that has the correct
    length. You can do this without induction if you make use of
    [select_perm]. *)

Lemma select_rest_length : forall x l y r,
    select x l = (y, r) -> length l = length r.
Proof.
  intros.
  apply eq_sym in H.
  apply select_perm in H.
  apply Permutation_length in H.
  inv H.
  reflexivity.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (select_fst_leq) *)

(** Prove that the first component of [select x _] is no bigger than
    [x]. Proceed by induction on [al]. *)

Lemma select_fst_leq: forall al bl x y,
    select x al = (y, bl) ->
    y <= x.
Proof.
  intro. induction al; intros.
  (* nil *) simpl in H. inv H. auto.
  (* a :: al *)
  simpl in H.
  bdestruct (a >=? x).
  - (* a >= x *)
    destruct (select x al) eqn:E.
    apply IHal in E.
    inv H.
    assumption.
  - (* a < x*)
    destruct (select a al) eqn:E.
    apply IHal in E.
    inv H.
    lia.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (select_smallest) *)

(** Prove that the first component of [select _ _] is no bigger
    than any of the elements in the second component. To represent
    that concept of comparing an element to a list, we introduce
    a new notation: *)

Definition le_all x xs := Forall (fun y => x <= y) xs.
Infix "<=*" := le_all (at level 70, no associativity).

(** Proceed by induction on [al]. *)

Lemma select_smallest: forall al bl x y,
    select x al = (y, bl) ->
    y <=* bl.
Proof.
  intro. induction al; intros.
  (* nil *) simpl in H. inv H. constructor.
  (* a :: al *)
  simpl in H.
  bdestruct (a >=? x).
  - (* a >= x *)
    destruct (select x al) eqn:E.
    apply IHal in E as H1.
    apply select_fst_leq in E.
    inv H.
    assert (y <= a) by lia.
    constructor; assumption.
  - (* a < x *)
    destruct (select a al) eqn:E.
    apply IHal in E as H1.
    apply select_fst_leq in E.
    inv H.
    assert (y <= x) by lia.
    constructor; assumption.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (select_in) *)

(** Prove that the element returned by [select] must be one of the
    elements in its input. Proceed by induction on [al]. *)

Lemma select_in : forall al bl x y,
    select x al = (y, bl) ->
    In y (x :: al).
Proof.
  intro. induction al; intros.
  (* nil *) inv H. constructor. reflexivity.
  (* a :: al *)
  apply select_fst_leq in H as H__yleqx.
  apply select_smallest in H as H__yleallbl.
  simpl in H.
  bdestruct (a >=? x).
  - (* a >= x *)
    destruct (select x al) eqn:E.
    inv H.
    apply IHal in E.
    apply in_cons with (a := a) in E.
    assert (Permutation (a :: x :: al) (x :: a :: al)) by constructor.
    apply (Permutation_in y H E).
  - (* a < x *)
    destruct (select a al) eqn:E.
    inv H.
    apply IHal in E.
    apply in_cons with (a := x) in E.
    assumption.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (cons_of_small_maintains_sort) *)

(** Prove that adding an element to the beginning of a
    selection-sorted list maintains sortedness, as long as the element
    is small enough and enough fuel is provided. *)

Lemma cons_of_small_maintains_sort: forall bl y n,
    n = length bl ->
    y <=* bl ->
    sorted (selsort bl n) ->
    sorted (y :: selsort bl n).
Proof.
  intro. induction bl; intros; subst.
  (* nil *) auto.
  (* a :: bl *)
  simpl. simpl in H1.
  destruct (select a bl) eqn:E.
  apply select_smallest in E as H2.
  apply select_in in E as H3.
  assert (y <= n). {
    unfold le_all in H0.
    rewrite Forall_forall in H0.
    specialize H0 with n.
    apply H0 in H3.
    assumption.
  }
  auto.
Qed.

(** [] *)

(** **** Exercise: 3 stars, standard (selsort_sorted) *)

(** Prove that [selsort] produced a sorted list when given
    sufficient fuel.  Proceed by induction on [n].  This proof
    will make use of a few previous lemmas. *)

Lemma selsort_sorted : forall n al,
    length al = n -> sorted (selsort al n).
Proof.
  intro n. induction n; intros.
  (* 0 *) apply length_zero_iff_nil in H. inv H. auto.
  (* S n *)
  destruct al eqn:E.
  (* nil *) discriminate.
  (* n0 :: l *)
  simpl in H.
  apply eq_add_S in H.
  assert (Hl__sorted: sorted (selsort l n))
    by (apply IHn in H; assumption).
  simpl. destruct (select n0 l) eqn:E0.
  assert (Hl0__length: length l0 = n). {
    apply select_rest_length in E0.
    subst.
    symmetry.
    assumption.
  }
  assert (Hl0__sorted: sorted (selsort l0 n))
    by (apply IHn in Hl0__length; assumption).
  assert (Hn0__lealll0: n1 <=* l0)
    by apply (select_smallest _ _ _ _ E0).
  symmetry in Hl0__length.
  apply cons_of_small_maintains_sort; assumption.
Qed.

(** [] *)

(** **** Exercise: 1 star, standard (selection_sort_sorted) *)

(** Prove that [selection_sort] produces a sorted list. *)

Lemma selection_sort_sorted : forall al,
    sorted (selection_sort al).
Proof.
  intro. unfold selection_sort.
  apply (selsort_sorted (length al) al eq_refl).
Qed.

(** [] *)

(** **** Exercise: 1 star, standard (selection_sort_is_correct) *)

(** Finish the proof of correctness! *)

Theorem selection_sort_is_correct :
  is_a_sorting_algorithm selection_sort.
Proof.
  unfold is_a_sorting_algorithm.
  intro. split.
  apply (selsort_perm (length al) al eq_refl).
  apply selection_sort_sorted.
Qed.
(** [] *)

(** **** Exercise: 5 stars, advanced, optional (selection_sort_is_correct_multiset) *)

(** Uncomment the next line, and prove the correctness of
    [selection_sort] using multisets instead of permutations.  We
    haven't tried this yet!  Send us your proof so we can add it as a
    solution. *)

(* From VFA Require Import Multiset. *)

(** [] *)

(* ################################################################# *)
(** * Recursive Functions That are Not Structurally Recursive *)

(** We used fuel above to create a structurally recursive
    version of [selsort] that Coq would accept as terminating.  The
    amount of fuel decreased at each call, until it reached zero.
    Since the fuel argument was structurally decreasing, Coq accepted
    the definition.  But it complicated the implementation of
    [selsort] and the proofs about it.

    Coq provides an experimental command [Function] that implements a
    similar idea as fuel, but without requiring the function
    definition to be structurally recursive.  Instead, the function is
    annotated with a _measure_ that is decreasing at each recursive
    call. To activate this experimental command, we need to load a
    library. *)

Require Import Recdef.  (* needed for [measure] feature *)

(** Now we can add a [measure] annotation on the definition of
    [selsort] to tell Coq that each recursive call decreases the
    length of [l]: *)

Function selsort' l {measure length l} :=
  match l with
  | [] => []
  | x :: r => let (y, r') := select x r
            in y :: selsort' r'
end.

(** The [measure] annotation takes two parameters, a measure
    function and an argument name.  Above, the function is [length]
    and the argument is [l].  The function must return a [nat] when
    applied to the argument.  Coq then challenges us to prove that
    [length] applied to [l] is actually decreasing at every recursive
    call. *)

Proof.
  intros.
  assert (Hperm: Permutation (x :: r) (y :: r')).
  { apply select_perm. auto. }
  apply Permutation_length in Hperm.
  inv Hperm. simpl. lia.
Defined.

(** The proof must end with [Defined] instead of [Qed].  That
    ensures the function's body can be used in computation.  For
    example, the following unit test succeeds, but try changing
    [Defined] to [Qed] and see how it gets stuck. *)

Example selsort'_example : selsort' [3;1;4;1;5;9;2;6;5] = [1;1;2;3;4;5;5;6;9].
Proof. reflexivity. Qed.

(** The definition of [selsort'] is completed by the [Function]
    command using a helper function that it generates,
    [selsort'_terminate].  Neither of them is going to be useful to
    unfold in proofs: *)

Print selsort'.
Print selsort'_terminate.

(** Instead, anywhere you want to unfold or simplify [selsort'], you
    should now rewrite with [selsort'_equation], which was
    automatically defined by the [Function] command: *)

Check selsort'_equation.

(** **** Exercise: 2 stars, standard (selsort'_perm) *)

(** Hint: Follow the same strategy as [selsort_perm]. In our solution,
    there was only a one-line change. *)

Lemma selsort'_perm : forall n l,
    length l = n -> Permutation l (selsort' l).
Proof.
  intro. induction n; intros.
  (* 0 *) apply length_zero_iff_nil in H. subst. auto.
  (* S n *)
  destruct l; simpl in H; inv H.
  rewrite selsort'_equation.
  destruct (select n0 l) eqn:E.
  apply eq_sym in E.
  apply select_perm in E.
  apply (Permutation_trans E).
  constructor.
  apply IHn.
  apply Permutation_length in E.
  inv E. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 5 stars, advanced, optional (selsort'_correct) *)

(** Prove the correctness of [selsort']. We haven't tried this yet!
    Send us your proof so we can add it as a solution. *)

(** [] *)

(* 2021-08-11 15:15 *)


Require Import Aux List Setoid Field VectorSpace.

Section Kn.

(* This is our scalar space with its dimension *)
Variable p : params.
(* The operations for scalar have the exprected properties *)
Hypothesis Hp : fparamsProp p.

(* We recover the usual mathematical notation *)
Notation "'K'" := (K p).

Declare Scope kn_scope.
Delimit Scope kn_scope with k.

Open Scope vector_scope.
Open Scope kn_scope.

(* A vector is a list of length n *)

Fixpoint kn (n: nat): Set :=
  match n with O => unit | S n1 => (K * kn n1)%type end.

(** We first build the functions of the vector space *)

(* Equality of two vectors as list *)
Fixpoint eq (n : nat) : kn n -> kn n -> bool :=
  match n return (kn n -> kn n -> bool) with
  | 0%nat => fun a b => true
  | S n1 =>
      fun l1 l2 =>
      let (v1, l3) := l1 in
      let (v2, l4) := l2 in
      if (v1 ?= v2)%f then eq n1 l3 l4 else false
  end.

(* Generate the constant k for the dimension n *)
Fixpoint genk (n: nat) (k: K) {struct n}: (kn n) :=
   match n return kn n with 0%nat => tt |
                            (S n1) => (k, genk n1 k) end.

Notation " [ k ] " := (genk _ k) (at level 10): kn_scope.

(* Adding two vectors as list *)
Fixpoint add (n : nat) : kn n -> kn n -> kn n :=
  match n return (kn n -> kn n -> kn n) with
  | 0%nat => fun a b => tt
  | S n1 =>
      fun l1 l2 =>
      let (v1, l3) := l1 in
      let (v2, l4) := l2 in ((v1 + v2)%f, add n1 l3 l4)
  end.

(* Multiplication by a scalar *)
Fixpoint scal (n : nat) (k: K) {struct n}: kn n -> kn n :=
  match n return (kn n -> kn n) with
  | 0%nat => fun a => tt
  | S n1 =>
      fun l1 =>
      let (v1,l2) := l1 in ((k * v1)%f , scal n1 k l2)
  end.

Canonical Structure vn_eparams (n: nat) :=
  Build_eparams (kn n) K (genk n 0%f) (eq n) (add n) (scal n).

Definition fn n : vparamsProp (vn_eparams n).
apply Build_vparamsProp; auto.
(* eq Dec *)
induction n as [| n IH]; simpl.
  intros [] []; auto.
intros (v1,l1) (v2, l2);
  generalize (eqK_dec _ Hp v1 v2); case eqK; intros HH; subst.
  generalize (IH l1 l2); unfold eqE; simpl.
case eq; intros HH; subst; auto.
  intros HH1; injection HH1; intros; case HH; auto.
intros HH1; injection HH1; intros; case HH; auto.
(* assoc *)
induction n as [| n IH]; simpl; auto.
intros (v1,l3) (v2, l4) (v3, l5); simpl in IH;
 rewrite IH, (addK_assoc _ Hp); auto.
(* comm *)
induction n as [| n IH]; simpl; auto.
intros (v1,l3) (v2, l4); simpl in IH;
  rewrite (addK_com _ Hp), (IH l3); auto.
(* 0 is  a left neutral element for + *)
induction n as [| n IH]; simpl; auto.
  intros []; auto.
intros (l1,l2); simpl in IH; rewrite (addK0l _ Hp), IH; auto.
(* Multiplication by 0 *)
induction n as [| n IH]; simpl; auto.
intros (l1, l2); simpl in IH; rewrite (multK0l _ Hp), IH; auto.
(* Multiplication by 1 *)
induction n as [| n IH]; simpl.
  intros []; auto.
intros (l1, l2); simpl in IH; rewrite (multK1l _ Hp), IH; auto.
(* Left addition of the multiplication by a scalar *)
induction n as [| n IH]; simpl; auto.
intros k1 k2 (l1, l2); simpl in IH; rewrite (add_multKl _ Hp), IH; auto.
(* Right addition of the multiplication by a scalar *)
induction n as [| n IH]; simpl; auto.
intros k (l1, l3) (l2, l4); simpl in IH; rewrite (add_multKr _ Hp), IH; auto.
(* Composition of the multiplication by a scalar *)
induction n as [| n IH]; simpl; auto.
intros k1 k2 (k, x); simpl in IH; rewrite (multK_assoc _ Hp), IH; auto.
Qed.

Hint Resolve fn : core.

Ltac Kfold n :=
     change (add n) with (addE (vn_eparams n));
     change (scal n) with (scalE (vn_eparams n));
     change (genk n 0%f) with (E0 (vn_eparams n)).

(* scal is integral *)
Lemma scal_integral n k (x: kn n) : k .* x = 0 -> k = 0%f \/ x = 0.
Proof.
induction n as [| n IH]; simpl; auto.
  destruct x; auto.
destruct x as (x1, x2); intros HH; injection HH; intros HH1 HH2.
case (IH _ _ HH1); case (multK_integral _ Hp k x1); auto.
intros; right; apply f_equal2 with (f := @pair _ _); auto.
Qed.

Lemma genk_inj n k1 k2 : [k1] = [k2] :> kn n.+1 -> k1 = k2.
Proof.
simpl; intros HH; injection HH; auto.
Qed.

Lemma genk0_dec n (x: kn n) :  x = 0 \/ x <> 0.
Proof.
induction n as [| n IH]; simpl; auto.
destruct x; auto.
destruct x as (x1, x2).
case (IH x2); intros H1; subst; auto.
generalize (eqK_dec _ Hp x1 0%f); case eqK;intros H1; subst; auto.
right; intro HH; case H1; injection HH; auto.
right; intro HH; case H1; injection HH; auto.
Qed.

(* Conversion from list to kn *)
Fixpoint l2kn (n:nat) (l:list K) {struct l} : kn n:=
  match n return kn n with
  | 0 => tt
  | S n1 => match l with
            | nil => genk (S n1) 0%f
            | a::l1 =>  (a,l2kn n1 l1)
            end
  end.

Fixpoint kn2l (n : nat) : kn n -> list K :=
  match n return (kn n -> list K) with
  | 0 => fun x => nil
  | S n1 => fun v => let (a, v1) := v in a :: kn2l n1 v1
  end.

Lemma kn2ll2knE n x : l2kn n (kn2l n x) = x.
Proof.
induction n as [| n IH]; destruct x; simpl; auto.
rewrite IH; auto.
Qed.

Lemma genk_id0 n i : In i (kn2l n (genk n 0%f)) -> i = 0%f.
Proof.
induction n as [| n IH]; simpl;
  intros HH; case HH; auto.
Qed.

Inductive eql_t0 : list K -> list K -> Prop :=
  eql_t0N: eql_t0 nil nil
| eql_t0Nl: forall l, eql_t0 l nil -> eql_t0 (0%f :: l) nil
| eql_t0Nr: forall l, eql_t0 nil l -> eql_t0 nil (0%f :: l)
| eql_t0R: forall a l1 l2, eql_t0 l1 l2 -> eql_t0 (a :: l1) (a :: l2).

Hint Constructors eql_t0 : core.

Lemma eql_refl l : eql_t0 l l.
Proof. elim l; auto. Qed.

Lemma eql_sym l1 l2 : eql_t0 l1 l2 -> eql_t0 l2 l1.
Proof. intros HH; elim HH; auto.
Qed.

Lemma eql_trans l2 l1 l3 : eql_t0 l1 l2 -> eql_t0 l2 l3 -> eql_t0 l1 l3.
Proof.
intros HH; generalize l3; elim HH; auto; clear l1 l2 l3 HH.
intros l1 HH IH l3 HH1.
  generalize (IH _ HH1); inversion_clear HH1; auto.
intros l1 HH IH l3 HH1.
  inversion_clear HH1; auto.
intros a l1 l2 HH IH l3 HH1.
  inversion_clear HH1; auto.
Qed.

Lemma dmap2_eql a l1 l2 l3 :
  eql_t0 l2 l3 ->
  eql_t0 (dmap2 (multK K) a l1 l2) (dmap2 (multK K) a l1 l3).
Proof.
intros HH; generalize l1; elim HH; clear l1 l2 l3 HH; simpl; auto.
intros [|b l1]; auto.
intros l2 HH IH [|b l1].
  rewrite multK0r; auto; apply eql_t0Nl.
  generalize (IH nil); auto.
  rewrite multK0r; auto; apply eql_t0Nl.
  generalize (IH l1); auto; case l1; auto.
intros l2 HH IH [|b l1].
  rewrite multK0r; auto; apply eql_t0Nr.
  generalize (IH nil); auto.
  rewrite multK0r; auto; apply eql_t0Nr.
  generalize (IH l1); auto; case l1; auto.
intros b l2 l3 HH IH [|c l1].
 apply eql_t0R; auto.
 apply eql_t0R; auto.
Qed.

Lemma kn2l_0 n : eql_t0 (kn2l n 0) nil.
Proof. elim n; simpl; auto. Qed.

(* Generate the p element of the base in dimension n *)
Fixpoint gen (n: nat) (p: nat) {struct n} : kn n :=
  match n return kn n with O => tt | S n1 =>
    match p with
      0 => (1%f, genk n1 0%f)
    | S p1 =>  (0%f, gen n1 p1)
    end
  end.

Notation " 'e_ p" := (gen _ p) (at level 70): kn_scope.

Lemma gen_inj n p1 p2 : p1 < n -> p2 < n ->
  'e_p1 = ('e_p2 : kn n)  -> p1 = p2.
Proof.
generalize p1 p2; clear p1 p2.
induction n as [| n IH]; auto.
intros p1 p2 Hp1; contradict Hp1; auto with arith.
intros [|p1] [|p2] HH1 HH2; simpl; auto.
intros HH; injection HH; intros; case (one_diff_zero _ Hp); auto.
intros HH; injection HH; intros; case (one_diff_zero _ Hp); auto.
intros HH; rewrite (IH p1 p2); auto with arith.
injection HH; auto.
Qed.

Lemma kn2l_e0 n : eql_t0 (kn2l n.+1 ('e_0)) (1%f :: nil).
Proof.
simpl; auto.
apply eql_t0R.
apply kn2l_0; auto.
Qed.

Lemma kn2l_ei n i :
  eql_t0 (kn2l n.+1 ('e_i.+1))  (0%f :: kn2l n ('e_i)).
Proof.
apply eql_refl.
Qed.

(* Lift a vector of dimension n into a vector of dimension n+1 whose
   first component is 0 *)
Definition lift (n: nat) (v: kn n) : (kn (S n)) :=  (0%f, v).

Lemma lift0 n : lift n 0 = 0.
Proof. auto. Qed.

(* Lift of generator of the base *)
Lemma lift_e : forall n i, 'e_(S i) = lift n ('e_i).
Proof. auto. Qed.

(* Lift on add *)
Lemma lift_add n x y : lift n (x + y) = lift n x + lift n y.
Proof. unfold lift; simpl; rewrite addK0l; auto. Qed.

(* Lift on scalar multiplication *)
Lemma lift_scal n k x :  lift n (k .* x) = scalE (vn_eparams (S n)) k (lift n x).
Proof. unfold lift; simpl; rewrite multK0r; auto. Qed.

(* Lift on the multiple product *)
Lemma lift_mprod (n: nat) ks vs : ks *X* map (lift n) vs =
  lift n (mprod (vn_eparams n) ks vs).
Proof.
generalize vs; clear vs; induction ks as [| k ks IH].
  intros vs; repeat rewrite mprod0l; auto.
intros [| v vs]; simpl; try rewrite mprod0r; auto.
rewrite (mprod_S (vn_eparams n.+1)); auto.
rewrite mprod_S; auto.
rewrite IH, lift_add, lift_scal; auto.
Qed.

(* The base as the list of all the generators *)
Fixpoint base (n : nat) : list (kn n) :=
  match n return list (kn n) with
  | 0 => nil
  | S n1 => ('e_0: kn (S n1)) :: map (lift n1) (base n1)
  end.

(* Each generator is in the base *)
Lemma e_in_base n i : i < n -> In ('e_i) (base n).
Proof.
generalize i; clear i; induction n as [| n IH].
  intros i HH; contradict HH; auto with arith.
intros [| p1] Hp1; simpl; Kfold n; auto; right.
refine (in_map _ _ _ _); auto with arith.
Qed.

(* An element of the base is a generator *)
Lemma e_in_base_ex n v :
  In v (base n) -> exists p1, p1 < n /\ v = 'e_p1.
Proof.
generalize v; clear v; induction n as [| n IH].
  intros v [].
simpl; intros [vv1 vv2] [H1 | H1].
  exists 0%nat; auto with arith.
rewrite in_map_iff in H1; case H1.
intros vv3 [Hvv3 Hvv3'].
case (IH _ Hvv3'); intros p1 [Hp1 Hp2].
exists (S p1); split; auto with arith.
rewrite <- Hvv3; rewrite Hp2; auto.
Qed.

(* The length of the base is n *)
Lemma base_length n : length (base n) = n.
Proof.
induction n as [| n IH]; simpl; auto.
rewrite map_length; rewrite IH; auto.
Qed.

(* The base is free *)
Lemma base_free n : free _ (base n).
Proof.
  induction n as [|n IH].
  *
     intro. simpl. intros H H0 k H1.
    assert (ks = nil) by (destruct ks; auto; discriminate).  subst.  inversion H1.
  * intro. destruct ks as [| k ks].
  - simpl. intros. discriminate.
  -
    intros H1. simpl base. rewrite mprod_S, lift_mprod; auto.
    simpl. intros HH. injection HH. clear HH.
    Kfold n.
    rewrite scalE0r, addE0l, addK0r; auto.
    intros H2 H3 k1 [Hk1 | Hk1].
    +
      case (multK_integral _ Hp _ _ H3); try subst; auto; intros Heq.
      case (one_diff_zero (vn_eparams n)); auto; apply (vgenk_inj _ _ _ Heq).
    +
      injection H1; rewrite map_length; auto.
      intros Hl; apply (IH ks); auto.
Qed.

Lemma k2l_mprod n (v: kn n) : kn2l n v *X* base n = v.
Proof.
generalize v; clear v; induction n as [| n IH].
simpl; intros []; auto.
simpl; intros (x, v).
rewrite (mprod_S (vn_eparams n.+1)); auto.
rewrite lift_mprod, IH.
simpl; Kfold n; auto.
Krm1; Vrm0.
Qed.

(* Every vector is a linear combination of the base *)
Lemma cbl_base n v : cbl _ (base n) v.
Proof. rewrite <- (k2l_mprod n v); apply mprod_cbl; auto. Qed.

Lemma  kn_induct n (P: kn n -> Prop) :
     P 0 ->
     (forall p, p < n -> P ('e_p)) ->
     (forall v1 v2, P v1 -> P v2 -> P (v1 + v2)) ->
     (forall k v, P v -> P (k .* v)) ->
     (forall x, P x).
Proof.
intros H1 H2 H3 H4 x.
elim (cbl_base n x); clear x; auto.
intros v HH; case (e_in_base_ex _ _ HH); intros m (Hl,Hm).
rewrite Hm; auto with arith.
Qed.

(* Coordinates for k vector *)
Fixpoint proj (n: nat) k : (kn n) -> K :=
  match n return kn n -> K with
  | O => fun _ => 0%f
  | S n1 => fun l => let (a,l1) := l in
          match k with | O => a | S k1 =>
           proj n1 k1 l1
          end
  end.

Lemma proj0 n i : proj n i 0 = 0%f.
Proof.
generalize i; clear i.
induction n as [| n IH]; intros [|i]; simpl; auto.
Qed.

Lemma proj_e n i j : j < n ->
  proj n i ('e_j) = if (i ?= j)%nat then 1%f else 0%f.
Proof.
generalize i j; clear i j.
induction n as [| n IH]; intros [|i] [|j] H;
  simpl; auto with arith; try (contradict H; auto with arith; fail).
rewrite proj0; auto.
Qed.

Lemma proj_scal n i k x :  proj n i (k .* x) = (k * proj n i x)%f.
Proof.
generalize i x; clear i x.
induction n as [| n IH]; simpl; auto.
Krm0.
intros [| i] [x1 x2]; auto.
exact (IH _ i x2).
Qed.

Lemma proj_add n i x y :
 proj n i (x + y) = (proj n i x + proj n i y)%f.
Proof.
generalize  i x y; clear i x y.
induction n as [| n IH]; simpl; auto.
intros [| i]; Krm0.
intros [| i] (x1,x2) (x3,x4); auto.
exact (IH i x2 x4).
Qed.

Fixpoint pscal (n: nat): (kn n) -> (kn n) -> K :=
  match n return kn n -> kn n -> K with
  | O => fun a b => 0%f
  | S n1 => fun l1 l2 => let (a,l3) := l1 in let (b,l4) := l2 in
                         (a * b + pscal n1 l3 l4)%f
  end.

Notation "a  [.]  b" := (pscal _ a b) (at level 40): kn_scope.

Lemma pscal0l n (x: kn n) : 0 [.] x = 0%f.
Proof.
induction n as [| n IH]; simpl.
 intros; Krm0.
destruct x; rewrite IH; Krm0.
Qed.

Lemma pscal0r n (x: kn n) : x [.] 0 = 0%f.
Proof.
induction n as [| n IH]; simpl.
 intros; Krm0.
destruct x; rewrite IH; Krm0.
Qed.

Lemma pscal_com n (x y: kn n) : x [.] y = y [.] x.
Proof.
induction n as [| n IH]; simpl.
 intros; Krm0.
destruct x; destruct y; rewrite multK_com, IH; auto.
Qed.

Lemma pscal_e n (i j: nat) : i < n -> j < n ->
  ('e_i: kn n) [.] ('e_j) = if (i ?= j)%nat then 1%f else 0%f.
Proof.
generalize i j; clear i j.
induction n as [| n IH].
  intros i j HH; contradict HH; auto with arith.
intros [|i] [|j] Hi Hj;
  simpl; auto with arith;
  try rewrite pscal0l; try rewrite pscal0r; Krm0; Krm1.
apply IH; auto with arith.
Qed.

Lemma pscal_scall n k (x y: kn n) :
  (k .* x) [.] y = (k * (x [.] y))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x; destruct y.
rewrite add_multKr, multK_assoc, IH; auto.
Qed.

Lemma pscal_scalr n k (x y: kn n) :
  x [.] (k .* y) = (k * (x [.] y))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x as [a x]; destruct y.
rewrite add_multKr, <-multK_assoc, (multK_com _ Hp a), multK_assoc, IH; auto.
Qed.

Lemma pscal_addl n (x y z: kn n) :
  (x + y) [.] z = (x [.] z + (y [.] z))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x; destruct y as [b y]; destruct z as [c z].
rewrite add_multKl, IH; auto.
rewrite !addK_assoc; auto.
rewrite <-(addK_assoc _ Hp (b * c)%f), (addK_com _ Hp (b * c)%f),
        !addK_assoc; auto.
Qed.

Lemma pscal_addr n (x y z: kn n) :
  z [.] (x + y) = (z [.] x + (z [.] y))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x; destruct y as [b y]; destruct z as [c z].
rewrite add_multKr, IH; auto.
rewrite !addK_assoc; auto.
rewrite <-(addK_assoc _ Hp (c * b)%f), (addK_com _ Hp (c * b)%f),
        !addK_assoc; auto.
Qed.

(* Our final vector *)
Definition Kn := kn p.
Definition K0 := genk p 0%f.
Definition Keq: Kn -> Kn -> bool := eq p.
Definition Kadd: Kn -> Kn -> Kn := add p.
Definition Kscal: K -> Kn -> Kn := scal p.
Definition Kproj: nat -> Kn -> K := proj p.
Definition Ksprod: Kn -> Kn -> K := pscal p.
Definition Kgen := gen p.

Canonical Structure v_eparams :=
  Build_eparams Kn K K0 Keq Kadd Kscal.
Definition f : vparamsProp v_eparams := fn p.

(* Prod of two vectors as list *)
Fixpoint kprod (n : nat) : kn n -> kn n -> kn n :=
  match n with
  | 0%nat => fun a b => tt
  | S n1 =>
      fun l1 l2 =>
      let (v1, l3) := l1 in
      let (v2, l4) := l2 in ((v1 * v2)%f, kprod n1 l3 l4)
  end.

Local Notation "a  [*]  b" := (kprod _ a b) (at level 40).

Lemma kprod0l n a : 0 [*] a = 0 :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; simpl; rewrite IH; Krm0.
Qed.

Lemma kprod0r n a : a [*] 0 = 0 :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; simpl; rewrite IH; Krm0.
Qed.

Lemma kprodkl n k a : [k] [*] a = k .* a :> kn n.
Proof.
induction n as [|n IH]; destruct a; simpl; auto.
rewrite IH; Krm1.
Qed.

Lemma kprodkr n k a : a [*] [k] = k .* a :> kn n.
Proof.
induction n as [|n IH]; destruct a; simpl; auto.
rewrite IH, multK_com; Krm1.
Qed.

Lemma kprod1l n a : [1%f] [*] a = a :> kn n.
Proof.
rewrite kprodkl, scalE1; auto.
Qed.

Lemma kprod1r n a : a [*] [1%f] = a :> kn n.
Proof.
rewrite kprodkr, scalE1; auto.
Qed.

Lemma kprod_addl n a b c :
  (a + b) [*] c = a [*] c + b [*] c :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; destruct c; simpl.
Kfold n; rewrite IH, add_multKl; Krm0.
Qed.

Lemma kprod_addr n a b c :
  a [*] (b + c) = a [*] b + a [*] c :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; destruct c; simpl.
Kfold n; rewrite IH, add_multKr; Krm0.
Qed.

Lemma kprod_scall n k a b :
  (k .* a) [*] b = k .* (a [*] b) :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; simpl.
Kfold n; rewrite IH, multK_assoc; Krm0.
Qed.

Lemma kprod_scalr n k a b :
  a [*] (k .* b) = k .* (a [*] b) :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; simpl.
Kfold n; rewrite IH, multK_swap; Krm0.
Qed.

Lemma kprod_assoc n a b c :
  (a [*] b) [*] c = a [*] (b [*] c) :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; destruct c; simpl.
Kfold n; rewrite IH, multK_assoc; Krm0.
Qed.

End Kn.

Declare Scope Kn_scope.

Notation " 'e_ p" := (gen _ _ p) (at level 8) : Kn_scope.
Notation " [ k ] " := (genk _ _ k) (at level 9) : Kn_scope.
Notation "a  [.]  b" := (pscal _ _ a b) (at level 40): Kn_scope.
Notation "a  [*]  b" := (kprod _ _ a b) (at level 40): Kn_scope.

Delimit Scope Kn_scope with Kn.

Global Hint Constructors eql_t0 : core.


Require Export Arith.
Require Export ArithRing.
Require Export Omega.
Require Export fib_ind.

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

(** An induction principle adapted to division by two *)

Theorem div2_rect:
 forall (P : nat ->  Type),
 P 0 -> P 1 -> (forall n, P n ->  P (S (S n))) -> forall (n : nat),  P n.
Proof.
intros P X0 X1 Xrec n; assert (P n * P (S n))%type.
 - elim n; intuition.
 - intuition.
Defined.

Theorem div2_spec:
 forall n,  ({x : nat | 2 * x = n}) + ({x : nat | 2 * x + 1 = n}).
Proof.
  intros n; induction  n  as [ | | n Hrec] using div2_rect.
  - left; now exists 0.
  - right; now exists 0.
  - destruct Hrec as  [[x Heq]|[x Heq]].
     + left; exists (S x); rewrite <- Heq; ring.
     + right; exists (S x); rewrite <- Heq; ring.
Qed.

Theorem half_smaller0: forall n x, 2 * x = S n ->  (x < S n).
Proof.
 intros; omega.
Qed.

Theorem half_smaller1: forall n x, 2 * x + 1 = n ->  (x < n).
Proof.
 intros; omega.
Qed.

Definition log2_F:
  forall (n : nat),
    (forall (y : nat),
        y < n -> y <> 0 ->  ({p : nat | exp2 p <= y /\ y < exp2 (p + 1)})) ->
    n <> 0 ->  ({p : nat | exp2 p <= n /\ n < exp2 (p + 1)}).
Proof.
  intros n; case n.
  - intros log2 Hn0; elim Hn0; trivial.
  - intros n' log2 _; elim (div2_spec (S n')).
    + intros [x]; case_eq x.
      * simpl; intros. subst; discriminate.
      * intros x' Heqx'; assert (Hn0: S x' <> 0) by auto with arith.
        subst x;  destruct (log2 (S x') (half_smaller0 _ _ e) Hn0) as [v Heqv].
        exists (S v); simpl;rewrite <- e;omega.
    + intros [x].  destruct x; simpl.
      *  rewrite <- e.  exists 0; simpl; auto with arith.
      * rewrite <- e.
        assert (Hn0: S x <> 0) by auto with arith.
        destruct (log2 (S x)) as [a Ha];[ omega | auto | ].
        exists (S a).  simpl.  omega.
Qed.


Require Export Arith NPeano.

Definition point := prod nat nat.
Bind Scope point_scope with point.
Delimit Scope point_scope with point.
Definition pt_x : point -> nat := @fst _ _.
Definition pt_y : point -> nat := @snd _ _.
Definition Build_point : nat -> nat -> point := pair.
Opaque point pt_x pt_y Build_point.
Notation "( x , y , .. , z )" := (Build_point .. (Build_point x y) .. z) : point_scope.

Notation "p '.(x)'" := (pt_x p) (at level 5, no associativity).
Notation "p '.(y)'" := (pt_y p) (at level 5, no associativity).

Section distance.
  Definition abs_minus (x y : nat) :=
    if le_dec x y then y - x else x - y.
  Local Infix "-" := abs_minus.

  Definition square_distance (x1 y1 x2 y2 : nat) := (x1 - x2)^2 + (y1 - y2)^2.
End distance.

Definition point_square_distance (p1 p2 : point) := square_distance p1.(x) p1.(y) p2.(x) p2.(y).

Notation "∥ p1 -- p2 ∥²" := (point_square_distance p1 p2) : nat_scope.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    EGroup.v

    Given an element a, create the group {e, a, a^2, ..., a^n}
 **********************************************************************)
Require Import ZArith.
Require Import Tactic.
Require Import List.
Require Import ZCAux.
Require Import ZArith Znumtheory.
Require Import Wf_nat.
Require Import UList.
Require Import FGroup.
Require Import Lagrange.

Open Scope Z_scope.

Section EGroup.

Variable A: Set.

Variable A_dec: forall a b: A, {a = b} + {~ a = b}.

Variable op: A -> A -> A.

Variable a: A.

Variable G: FGroup op.

Hypothesis a_in_G: In a G.(s).

(**************************************
  The power function for the group
 **************************************)

Set Implicit Arguments.
Definition gpow n := match n with  Zpos p => iter_pos _ (op a) G.(e) p | _ => G.(e) end.
Unset Implicit Arguments.

Theorem gpow_0: gpow 0 = G.(e).
simpl; sauto.
Qed.

Theorem gpow_1 : gpow 1 = a.
simpl; sauto.
Qed.

(**************************************
  Some properties of the power function
 **************************************)

Theorem gpow_in: forall n, In (gpow n) G.(s).
intros n; case n; simpl; auto.
intros p; apply iter_pos_invariant with (Inv := fun x => In x G.(s)); auto.
Qed.

Theorem gpow_op: forall b p, In b G.(s) -> iter_pos _ (op a) b p = op (iter_pos _ (op a) G.(e) p) b.
intros b p; generalize b; elim p; simpl; auto; clear  b p.
intros p Rec b Hb.
assert (H: In (gpow (Zpos p)) G.(s)).
apply gpow_in.
rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos A x y p)); auto.
repeat rewrite G.(assoc); auto.
intros p Rec b Hb.
assert (H: In (gpow (Zpos p)) G.(s)).
apply gpow_in.
rewrite (Rec b); try rewrite (fun x y => Rec (op x y)); try rewrite (fun x y => Rec (iter_pos A x y p)); auto.
repeat rewrite G.(assoc); auto.
intros b H; rewrite e_is_zero_r; auto.
Qed.

Theorem gpow_add: forall n m, 0 <= n -> 0 <= m -> gpow (n + m) = op (gpow n) (gpow m).
intros n; case n.
intros m _ _; simpl; apply sym_equal; apply e_is_zero_l; apply gpow_in.
2: intros p m H; contradict H; auto with zarith.
intros p1 m; case m.
intros _ _; simpl; apply sym_equal; apply e_is_zero_r.
exact (gpow_in (Zpos p1)).
2: intros p2 _ H; contradict H; auto with zarith.
intros p2 _ _; simpl.
rewrite iter_pos_plus; rewrite (fun x y => gpow_op (iter_pos A x y p2)); auto.
exact (gpow_in (Zpos p2)).
Qed.

Theorem gpow_1_more:
  forall n, 0 < n -> gpow n = G.(e) -> forall m, 0 <= m -> exists p, 0 <= p < n /\ gpow m = gpow p.
intros n H1 H2 m Hm;  generalize Hm; pattern m; apply Z_lt_induction; auto with zarith; clear m Hm.
intros m Rec Hm.
case (Zle_or_lt n m); intros H3.
case (Rec (m - n)); auto with zarith.
intros p (H4,H5); exists p; split; auto.
replace m with (n + (m - n)); auto with zarith.
rewrite gpow_add; try rewrite H2; try rewrite H5; sauto; auto with zarith.
generalize gpow_in; sauto.
exists m; auto.
Qed.

Theorem gpow_i: forall n m, 0 <= n -> 0 <= m -> gpow n = gpow (n + m) -> gpow m = G.(e).
intros n m H1 H2 H3; generalize gpow_in; intro PI.
apply g_cancel_l with (g:= G) (a := gpow n); sauto.
rewrite <- gpow_add; try rewrite <- H3; sauto.
Qed.

(**************************************
  We build the support by iterating the power function
 **************************************)

Set Implicit Arguments.

Fixpoint support_aux (b: A) (n: nat) {struct n}: list A :=
b::let c := op a b in
    match n with
       O => nil |
      (S n1) =>if A_dec c G.(e) then nil else  support_aux c n1
    end.

Definition support := support_aux G.(e) (Z.abs_nat (g_order G)).

Unset Implicit Arguments.

(**************************************
  Some properties of the support that helps to prove that we have a group
 **************************************)

Theorem support_aux_gpow:
  forall n m b, 0 <=  m -> In b (support_aux (gpow m) n) ->
        exists p, (0 <= p < length (support_aux (gpow m) n))%nat  /\ b = gpow (m + Z_of_nat p).
intros n; elim n; simpl.
intros n1 b Hm [H1 | H1]; exists 0%nat; simpl; rewrite Zplus_0_r; auto; case H1.
intros n1 Rec m b Hm [H1 | H1].
exists 0%nat; simpl; rewrite Zplus_0_r; auto; auto with arith.
generalize H1; case (A_dec (op a (gpow m)) G.(e)); clear H1; simpl; intros H1 H2.
case H2.
case (Rec (1 + m) b); auto with zarith.
rewrite gpow_add; auto with zarith.
rewrite gpow_1; auto.
intros p (Hp1, Hp2); exists (S p); split; auto with zarith.
rewrite <- gpow_1.
rewrite <- gpow_add; auto with zarith.
rewrite inj_S; rewrite Hp2; eq_tac; auto with zarith.
Qed.

Theorem gpow_support_aux_not_e:
  forall n m p, 0 <= m -> m < p < m + Z_of_nat (length (support_aux (gpow m) n)) -> gpow p <> G.(e).
intros n; elim n; simpl.
intros m p Hm (H1, H2); contradict H2; auto with zarith.
intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl.
intros _ (H1, H2); contradict H2; auto with zarith.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp.
intros H1 (H2, H3); case (Zle_lt_or_eq (1 + m) p); auto with zarith; intros H4; subst.
apply (Rec (1 + m)); try split; auto with zarith.
rewrite gpow_add; auto with zarith.
rewrite gpow_1; auto with zarith.
rewrite gpow_add; try rewrite gpow_1; auto with zarith.
Qed.

Theorem support_aux_not_e: forall n m b, 0 <= m -> In b (tail (support_aux (gpow m) n)) -> ~ b = G.(e).
intros n; elim n; simpl.
intros m b Hm H; case H.
intros n1 Rec m b Hm; case (A_dec (op a (gpow m)) G.(e)); intros H1 H2; simpl; auto.
assert (Hm1: 0 <= 1 + m); auto with zarith.
generalize( Rec (1 + m) b Hm1) H2; case n1; auto; clear Hm1.
intros _ [H3 | H3]; auto.
contradict H1; subst; auto.
rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith.
intros n2; case (A_dec (op a (op a (gpow m))) G.(e)); intros H3.
intros _ [H4 | H4].
contradict H1; subst; auto.
case H4.
intros H4 [H5 | H5]; subst; auto.
Qed.

Theorem support_aux_length_le: forall n a, (length (support_aux a n) <= n + 1)%nat.
intros n; elim n; simpl; auto.
intros n1 Rec a1; case (A_dec (op a a1) G.(e)); simpl; auto with arith.
Qed.

Theorem support_aux_length_le_is_e:
   forall n m, 0 <= m ->  (length (support_aux (gpow m) n) <= n)%nat ->
      gpow (m + Z_of_nat (length (support_aux (gpow m) n))) = G.(e) .
intros n; elim n; simpl; auto.
intros m _ H1; contradict H1; auto with arith.
intros n1 Rec m Hm; case (A_dec (op a (gpow m)) G.(e)); simpl;  intros H1.
intros H2; rewrite Zplus_comm; rewrite gpow_add; simpl; try rewrite e_is_zero_r; auto with zarith.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp.
rewrite <- gpow_1.
rewrite <- gpow_add; auto with zarith.
rewrite  Zplus_assoc; rewrite (Zplus_comm 1); intros H2; apply Rec; auto with zarith.
Qed.

Theorem support_aux_in:
  forall n m p, 0 <= m ->  (p < length (support_aux (gpow m) n))% nat ->
            (In (gpow (m + Z_of_nat p)) (support_aux (gpow m) n)).
intros n; elim n; simpl; auto; clear n.
intros m p Hm H1; replace p with 0%nat.
left; eq_tac; auto with zarith.
generalize H1; case p; simpl; auto with arith.
intros n H2; contradict H2; apply Nat.le_ngt; auto with arith.
intros n1 Rec m p Hm; case (A_dec (op a (gpow m)) G.(e)); simpl; intros H1 H2; auto.
replace p with 0%nat.
left; eq_tac; auto with zarith.
generalize H2; case p; simpl; auto with arith.
intros n H3; contradict H3; apply Nat.le_ngt; auto with arith.
generalize H2; case p; simpl; clear H2.
rewrite Zplus_0_r; auto.
intros n.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp.
rewrite <- gpow_1; rewrite <- gpow_add; auto with zarith.
rewrite  Zplus_assoc; rewrite (Zplus_comm 1); intros H2; right; apply Rec; auto with zarith.
Qed.

Theorem support_aux_ulist:
  forall n m, 0 <= m -> (forall p, 0 <= p < m -> gpow (1 + p) <> G.(e)) -> ulist (support_aux (gpow m) n).
intros n; elim n; auto; clear n.
intros m _ _; auto.
simpl; apply ulist_cons; auto.
intros n1 Rec m Hm H.
simpl; case (A_dec (op a (gpow m)) G.(e)); auto.
intros He; apply ulist_cons; auto.
intros H1; case  (support_aux_gpow n1 (1 + m) (gpow m)); auto with zarith.
rewrite gpow_add; try rewrite gpow_1; auto with zarith.
intros p (Hp1, Hp2).
assert (H2: gpow (1 + Z_of_nat p) = G.(e)).
apply gpow_i with m; auto with zarith.
rewrite Hp2; eq_tac; auto with zarith.
case (Zle_or_lt m  (Z_of_nat p)); intros H3; auto.
2: case (H (Z_of_nat p)); auto with zarith.
case (support_aux_not_e (S n1) m (gpow (1 + Z_of_nat p))); auto.
rewrite gpow_add; auto with zarith; simpl; rewrite e_is_zero_r; auto.
case (A_dec (op a (gpow m)) G.(e)); auto.
intros _; rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith.
replace (1 + Z_of_nat p) with ((1 + m) + (Z_of_nat (p - Z.abs_nat m))).
apply support_aux_in; auto with zarith.
rewrite inj_minus1.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply inj_le_rev.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
rewrite <- gpow_1; repeat rewrite <- gpow_add; auto with zarith.
apply (Rec (1 + m)); auto with zarith.
intros p H1; case (Zle_lt_or_eq p m); intros; subst; auto with zarith.
rewrite  gpow_add; auto with zarith.
rewrite gpow_1; auto.
Qed.

Theorem support_gpow: forall b, (In b support) -> exists p, 0 <= p < Z_of_nat (length support) /\ b = gpow p.
intros b H; case (support_aux_gpow  (Z.abs_nat (g_order G)) 0 b); auto with zarith.
intros p ((H1, H2), H3); exists (Z_of_nat p); repeat split; auto with zarith.
apply inj_lt; auto.
Qed.

Theorem support_incl_G: incl support G.(s).
intros a1 H; case (support_gpow a1); auto; intros p (H1, H2); subst; apply gpow_in.
Qed.

Theorem gpow_support_not_e: forall p, 0 < p < Z_of_nat (length support) -> gpow p <> G.(e).
intros p (H1, H2); apply gpow_support_aux_not_e with (m := 0) (n := length G.(s)); simpl;
  try split; auto with zarith.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
Qed.

Theorem support_not_e: forall b, In b (tail support) -> ~ b = G.(e).
intros b H; apply (support_aux_not_e (Z.abs_nat (g_order G)) 0); auto with zarith.
Qed.

Theorem support_ulist:  ulist support.
apply (support_aux_ulist (Z.abs_nat (g_order G)) 0); auto with zarith.
Qed.

Theorem support_in_e:  In G.(e) support.
unfold support; case (Z.abs_nat (g_order G)); simpl; auto with zarith.
Qed.

Theorem gpow_length_support_is_e: gpow (Z_of_nat (length support)) = G.(e).
apply (support_aux_length_le_is_e (Z.abs_nat (g_order G)) 0); simpl; auto with zarith.
unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_ulist.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_incl_G.
Qed.

Theorem support_in:  forall p, 0 <= p < Z_of_nat (length support) ->  In (gpow p) support.
intros p (H, H1); unfold support.
rewrite <-  (Z.abs_eq p); auto with zarith.
rewrite <-  (inj_Zabs_nat p); auto.
generalize (support_aux_in (Z.abs_nat (g_order G)) 0); simpl; intros H2; apply H2; auto with zarith.
rewrite <-  (fun x => Zabs_nat_Z_of_nat (@length A x)); auto.
apply Zabs_nat_lt; split; auto.
Qed.

Theorem support_internal: forall a b, In a support -> In b support -> In (op a b) support.
intros a1 b1 H1 H2.
case support_gpow with (1 := H1); auto; intros p1 ((H3, H4), H5); subst.
case support_gpow with (1 := H2); auto; intros p2 ((H5, H6), H7); subst.
rewrite <- gpow_add; auto with zarith.
case gpow_1_more with (m:= p1 + p2)   (2 := gpow_length_support_is_e); auto with zarith.
intros p3 ((H8, H9), H10); rewrite H10; apply support_in; auto with zarith.
Qed.

Theorem support_i_internal: forall a, In a support -> In (G.(i) a) support.
generalize gpow_in; intros Hp.
intros a1 H1.
case support_gpow with (1 := H1); auto.
intros p1 ((H2, H3), H4); case Zle_lt_or_eq with (1 := H2); clear H2; intros H2; subst.
2: rewrite gpow_0; rewrite i_e; apply support_in_e.
replace (G.(i) (gpow p1)) with (gpow (Z_of_nat (length support - Z.abs_nat p1))).
apply support_in.
rewrite inj_minus1.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply g_cancel_l with (g:= G) (a := gpow p1); sauto.
rewrite <- gpow_add; auto with zarith.
replace (p1 + Z_of_nat (length support - Z.abs_nat p1)) with (Z_of_nat (length support)).
rewrite gpow_length_support_is_e; sauto.
rewrite inj_minus1.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
Qed.

(**************************************
  We are now ready to build the group
 **************************************)

Definition Gsupport: (FGroup op).
generalize support_incl_G; unfold incl; intros Ho.
apply mkGroup with support G.(e) G.(i); sauto.
apply support_ulist.
apply support_internal.
intros a1 b1 c1 H1 H2 H3; apply G.(assoc); sauto.
apply support_in_e.
apply support_i_internal.
Defined.

(**************************************
  Definition of the order of an element
 **************************************)
Set Implicit Arguments.

Definition e_order := Z_of_nat (length support).

Unset Implicit Arguments.

(**************************************
 Some properties of the order of an element
 **************************************)

Theorem gpow_e_order_is_e: gpow e_order = G.(e).
apply (support_aux_length_le_is_e (Z.abs_nat (g_order G)) 0); simpl; auto with zarith.
unfold g_order; rewrite Zabs_nat_Z_of_nat; apply ulist_incl_length.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_ulist.
rewrite  <- (Zabs_nat_Z_of_nat (length G.(s))); auto.
exact support_incl_G.
Qed.

Theorem gpow_e_order_lt_is_not_e: forall n, 1 <= n < e_order -> gpow n <> G.(e).
intros n (H1, H2); apply gpow_support_not_e; auto with zarith.
Qed.

Theorem e_order_divide_g_order:  (e_order | g_order G).
change ((g_order Gsupport) | g_order G).
apply lagrange; auto.
exact support_incl_G.
Qed.

Theorem e_order_pos: 0 < e_order.
unfold e_order, support; case (Z.abs_nat (g_order G)); simpl; auto with zarith.
Qed.

Theorem e_order_divide_gpow: forall n, 0 <= n -> gpow n = G.(e) -> (e_order | n).
generalize gpow_in; intros Hp.
generalize e_order_pos; intros Hp1.
intros n Hn; generalize Hn; pattern n; apply Z_lt_induction; auto; clear n Hn.
intros n Rec Hn H.
case (Zle_or_lt  e_order n); intros H1.
case (Rec (n - e_order)); auto with zarith.
apply g_cancel_l with (g:= G) (a := gpow e_order); sauto.
rewrite G.(e_is_zero_r); auto with zarith.
rewrite <- gpow_add; try (rewrite gpow_e_order_is_e; rewrite <- H; eq_tac); auto with zarith.
intros k Hk; exists (1 + k).
rewrite Zmult_plus_distr_l; rewrite <- Hk; auto with zarith.
case (Zle_lt_or_eq 0 n); auto with arith; intros H2; subst.
contradict H; apply support_not_e.
generalize H1; unfold e_order, support.
case (Z.abs_nat (g_order G)); simpl; auto.
intros H3; contradict H3; auto with zarith.
intros n1; case (A_dec (op a G.(e)) G.(e)); simpl; intros _ H3.
contradict H3; auto with zarith.
generalize H3; clear H3.
assert (tmp: forall p, Zpos (P_of_succ_nat p) = 1 + Z_of_nat p).
intros p1; apply trans_equal with (Z_of_nat (S p1)); auto; rewrite inj_S; auto with zarith.
rewrite tmp; clear tmp; intros H3.
change (In (gpow n) (support_aux (gpow 1) n1)).
replace n with (1 + Z_of_nat (Z.abs_nat n - 1)).
apply support_aux_in; auto with zarith.
rewrite <- (fun x => Zabs_nat_Z_of_nat (@length A x)).
replace (Z.abs_nat n - 1)%nat  with (Z.abs_nat (n - 1)).
apply Zabs_nat_lt; split; auto with zarith.
rewrite G.(e_is_zero_r) in H3; try rewrite gpow_1; auto with zarith.
apply inj_eq_rev; rewrite inj_Zabs_nat.
rewrite Z.abs_eq by auto with zarith.
rewrite inj_minus1.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq; auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat; simpl.
rewrite Z.abs_eq; auto with zarith.
rewrite inj_minus1.
rewrite inj_Zabs_nat.
rewrite Z.abs_eq.
rewrite Zplus_comm; simpl; auto with zarith.
auto with zarith.
apply inj_le_rev; rewrite inj_Zabs_nat; simpl.
rewrite Z.abs_eq; auto with zarith.
exists 0; auto with arith.
Qed.

End EGroup.

Theorem gpow_gpow: forall (A : Set) (op : A -> A -> A) (a : A) (G : FGroup op),
       In a (s G) -> forall n m, 0 <= n -> 0 <= m -> gpow a G (n * m ) = gpow (gpow a G n) G m.
intros A op a G H n m; case n.
simpl; intros _ H1; generalize H1.
pattern m; apply natlike_ind; simpl; auto.
intros x H2 Rec _; unfold Z.succ; rewrite gpow_add; simpl; auto with zarith.
repeat rewrite G.(e_is_zero_r); auto with zarith.
apply gpow_in; sauto.
intros p1 _; case m; simpl; auto.
assert(H1: In (iter_pos A (op a) (e G) p1) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p1)); auto.
intros p2 _;  pattern p2; apply Pind; simpl; auto.
rewrite Pmult_1_r; rewrite G.(e_is_zero_r); try rewrite G.(e_is_zero_r); auto.
intros p3 Rec; rewrite Pplus_one_succ_r; rewrite Pmult_plus_distr_l.
rewrite Pmult_1_r.
simpl; repeat rewrite iter_pos_plus; simpl.
rewrite G.(e_is_zero_r); auto.
rewrite gpow_op with (G:= G); try rewrite Rec; auto.
apply sym_equal; apply gpow_op; auto.
intros p Hp; contradict Hp; auto with zarith.
Qed.

Theorem gpow_e: forall (A : Set) (op : A -> A -> A) (G : FGroup op) n, 0 <= n -> gpow G.(e) G n = G.(e).
intros A op G n; case n; simpl; auto with zarith.
intros p _; elim p; simpl; auto; intros p1 Rec; repeat rewrite Rec; auto.
Qed.

Theorem gpow_pow: forall (A : Set) (op : A -> A -> A) (a : A) (G : FGroup op),
       In a (s G) -> forall n, 0 <= n -> gpow a G (2 ^ n) = G.(e) -> forall m, n <= m -> gpow a G (2 ^ m) = G.(e).
intros A op a G H n H1 H2 m Hm.
replace m with (n + (m - n)); auto with zarith.
rewrite Zpower_exp; auto with zarith.
rewrite gpow_gpow; auto with zarith.
rewrite H2; apply gpow_e.
apply Zpower_ge_0; auto with zarith.
Qed.

Theorem gpow_mult: forall (A : Set) (op : A -> A -> A) (a b: A) (G : FGroup op)
       (comm: forall a b,  In a (s G) -> In b (s G) -> op a b = op b a),
       In a (s G) -> In b (s G) -> forall n, 0 <= n -> gpow (op a b) G n = op (gpow a G n) (gpow b G n).
intros A op a  b G comm Ha Hb n; case n; simpl; auto.
intros _; rewrite G.(e_is_zero_r); auto.
2: intros p Hp; contradict Hp; auto with zarith.
intros p _; pattern p; apply Pind; simpl; auto.
repeat rewrite G.(e_is_zero_r); auto.
intros p3 Rec; rewrite Pplus_one_succ_r.
repeat rewrite iter_pos_plus; simpl.
repeat rewrite (fun x y H z => gpow_op A  op x G H (op y z)) ; auto.
rewrite Rec.
repeat rewrite G.(e_is_zero_r); auto.
assert(H1: In (iter_pos A (op a) (e G) p3) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p3)); auto.
assert(H2: In (iter_pos A (op b) (e G) p3) (s G)).
refine (gpow_in _ _ _ _ _ (Zpos p3)); auto.
repeat rewrite <- G.(assoc); try eq_tac; auto.
rewrite (fun x y => comm (iter_pos A x y p3) b); auto.
rewrite (G.(assoc) a); try apply comm; auto.
Qed.

Theorem Zdivide_mult_rel_prime:  forall a b c : Z, (a | c) -> (b | c) -> rel_prime a b -> (a * b | c).
intros a b c (q1, H1) (q2, H2) H3.
assert (H4: (a | q2)).
apply Gauss with (2 := H3).
exists q1; rewrite <- H1; rewrite H2; auto with zarith.
case H4; intros q3 H5; exists q3; rewrite H2; rewrite H5; auto with zarith.
Qed.

Theorem order_mult: forall (A : Set) (op : A -> A -> A) (A_dec: forall a b: A, {a = b} + {~ a = b}) (G : FGroup op)
       (comm: forall a b,  In a (s G) -> In b (s G) -> op a b = op b a) (a b: A),
       In a (s G) -> In b (s G) -> rel_prime (e_order A_dec a G) (e_order A_dec b G) ->
        e_order A_dec (op a b) G = e_order A_dec a G * e_order A_dec b G.
intros A op A_dec G comm a b Ha Hb Hab.
assert (Hoat: 0 < e_order A_dec a G) by apply e_order_pos.
assert (Hobt: 0 < e_order A_dec b G) by apply e_order_pos.
assert (Hoabt: 0 < e_order A_dec (op a b) G) by apply e_order_pos.
assert (Hoa: 0 <= e_order A_dec a G) by auto with zarith.
assert (Hob: 0 <= e_order A_dec b G) by auto with zarith.
apply Zle_antisym; apply Zdivide_le. 1, 4-5: auto with zarith.
apply Zmult_lt_O_compat; auto.
apply e_order_divide_gpow; sauto; auto with zarith.
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto.
rewrite Zmult_comm.
rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto.
apply Zdivide_mult_rel_prime; auto.
apply Gauss with (2 := Hab).
apply e_order_divide_gpow; auto with zarith.
rewrite <- (gpow_e _ _ G (e_order A_dec b G)); auto.
rewrite <- (gpow_e_order_is_e _ A_dec  _ (op a b) G); auto with zarith.
rewrite <- gpow_gpow; auto with zarith.
rewrite (Zmult_comm (e_order A_dec (op a b) G)).
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow with (a := b); auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto with zarith.
rewrite G.(e_is_zero_r); auto with zarith.
apply gpow_in; auto.
apply Gauss with (2 := rel_prime_sym _ _ Hab).
apply e_order_divide_gpow; auto with zarith.
rewrite <- (gpow_e _ _ G (e_order A_dec a G)); auto.
rewrite <- (gpow_e_order_is_e _ A_dec  _ (op a b) G); auto with zarith.
rewrite <- gpow_gpow; auto with zarith.
rewrite (Zmult_comm (e_order A_dec (op a b) G)).
rewrite gpow_mult; auto with zarith.
rewrite gpow_gpow with (a := a); auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
rewrite gpow_e; auto with zarith.
rewrite G.(e_is_zero_l); auto with zarith.
apply gpow_in; auto.
Qed.

Theorem fermat_gen: forall (A : Set) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op),
       In a G.(s) ->  gpow a G (g_order G) = G.(e).
intros A A_dec op a G H.
assert (H1: (e_order A_dec a G | g_order G)).
apply e_order_divide_g_order; auto.
case H1; intros q; intros Hq; rewrite Hq.
assert (Hq1: 0 <= q).
apply Zmult_le_reg_r with (e_order A_dec a G); auto with zarith.
apply Z.lt_gt; apply e_order_pos.
rewrite Zmult_0_l; rewrite <- Hq; apply Zlt_le_weak; apply g_order_pos.
rewrite Zmult_comm; rewrite gpow_gpow; auto with zarith.
rewrite gpow_e_order_is_e; auto with zarith.
apply gpow_e; auto.
apply Zlt_le_weak; apply e_order_pos.
Qed.

Theorem order_div: forall (A : Set) (A_dec: forall (a b: A), {a = b} + {a <>b}) (op : A -> A -> A) (a: A) (G : FGroup op) m,
 0 < m -> (forall p, prime p -> (p | m) -> gpow a G (m / p) <> G.(e)) ->
 In a G.(s) -> gpow a G m = G.(e) -> e_order A_dec a G = m.
intros A Adec op a G m Hm H H1 H2.
assert (F1: 0 <= m); auto with zarith.
case (e_order_divide_gpow A Adec op a G H1 m F1 H2); intros q Hq.
assert (F2: 1 <= q).
  case (Zle_or_lt 0 q); intros HH.
    case (Zle_lt_or_eq _ _ HH). auto with zarith.
    intros HH1; generalize Hm; rewrite Hq; rewrite <- HH1;
      auto with zarith.
  assert (F2: 0 <= (- q) * e_order Adec a G).
    apply Zmult_le_0_compat; auto with zarith.
    apply Zlt_le_weak; apply e_order_pos.
  generalize F2; rewrite Zopp_mult_distr_l_reverse;
      rewrite <- Hq; auto with zarith.
case (Zle_lt_or_eq _ _ F2); intros H3; subst; auto with zarith.
case (prime_dec q); intros Hq.
  case (H q); auto with zarith.
    rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith.
  apply gpow_e_order_is_e; auto.
case (Zdivide_div_prime_le_square _ H3 Hq); intros r (Hr1, (Hr2, Hr3)).
case (H _ Hr1); auto.
  apply Z.divide_trans with (1 := Hr2).
  apply Zdivide_factor_r.
case Hr2; intros q1 Hq1; subst.
assert (F3: 0 < r).
  generalize (prime_ge_2 _ Hr1); auto with zarith.
rewrite <- Zmult_assoc; rewrite Zmult_comm; rewrite <- Zmult_assoc;
  rewrite Zmult_comm; rewrite Z_div_mult; auto with zarith.
rewrite gpow_gpow. 2: auto with zarith.
  rewrite gpow_e_order_is_e; try rewrite gpow_e; auto.
  apply Zmult_le_reg_r with r; auto with zarith.
  apply Zlt_le_weak; apply e_order_pos.
apply Zmult_le_reg_r with r; auto with zarith.
Qed.


(** Tarea 2 Lógica Minimal
    Autor: Luis Felipe Benítez Lluis
      Script de proposiciones a demostrar de la
      sección de lógica minimal  *)

Proposition LM_a: forall A: Prop, ~~~A <-> ~A.
Proof.
intros.
split.
+ intros.
  intro.
  apply H.
  intro.
  apply H1.
  assumption.
+ intros.
  unfold not.
  intros.
  apply H0 in H.
  assumption.
Qed.

Proposition LM_b: forall A B: Prop,
  ~~(A /\ B) -> ~~A /\ ~~B.
Proof.
intros.
split.
+ intro.
  apply H.
  intro.
  apply H0.
  destruct H1.
  assumption.
+ intro.
  apply H.
  intro.
  apply H0.
  destruct H1.
  assumption.
Qed.

Proposition LM_c: forall T, forall A : T->Prop,
  ~~(forall x : T, A x)-> (forall x : T, ~~ A x).
Proof.
  intros.
  intro.
  apply H.
  intro.
  apply H0.
  apply H1.
Qed.

Lemma PNNP: forall P : Prop,
  P-> ~~P.
Proof.
  intros. intro. apply H0. apply H.
Qed.


(**************************************************************)
(*   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 Lia Extraction.

Require Import measure_ind.

Set Implicit Arguments.

(** Several ways to define simple interleaving in Coq
    to get the algorithm defined by the two equations

      itl [] m = m
      itl (x::l) m = x::itl m l

   as following extracted code in OCaml

     let rec itl l m = match l with
       | []   -> m
       | x::l -> x::itl m l

   1) first itl_s is a functional equivalent by structural induction
      but of course with a different algorithm
   2) itl gives the correct algorithm but with hard correctness proof
   3) itl_paired follows the same recursive pattern but with paired
      arguments
   4) itl_f gives the correct algo. with simple correctness proof
   5) itl_g gives the correct algo. with simple and delayed correctness proof

 *)

Section interleave.

  Variable X : Type.

  Implicit Type l m : list X.

  Section interleave_struct.

    (** First an easily definable functional equivalent
        of itl, by structural induction on l *)

    Fixpoint itl_s l m :=
      match l, m with
        | nil,  _    => m
        | _::_, nil  => l
        | x::l, y::m => x::y::itl_s l m
      end.

    (** And we show itl_s satisfies the fixpoint equations of itl *)

    Fact itl_s_fix0 m : itl_s nil m = m.
    Proof. trivial. Qed.

    Fact itl_s_fix1 x l m : itl_s (x::l) m = x::itl_s m l.
    Proof.
      revert x.
      induction on l m as IH with measure (length l + length m).
      intros x; destruct m as [ | y m ]; trivial.
      simpl itl_s at 1; f_equal.
      symmetry; apply IH; simpl; lia.
    Qed.

  End interleave_struct.

  Section interleave_measure.

    (** Now by induction on the measure |l|+|m| *)

    Definition itl l m : list X.
    Proof.
      induction on l m as itl with measure (length l + length m).
      revert itl.
      refine (match l with
        | nil  => fun _   => m
        | x::l => fun itl => x::itl m l _
      end).
      simpl; lia.  (** the measure decreases *)
    Defined.

    (** Showing that itl_mes is ext-equal to itl_s
        is possible but NOT EASY because
        you have to use and thus prove the fixpoint
        equation for measure_double_rect...

        see measure_ind.v for this non-trivial proof *)

    Let itl_fix l m :
        itl l m = match l with
          | nil  => m
          | x::l => x::itl m l
        end.
    Proof.
      unfold itl at 1.
      rewrite measure_double_rect_fix.
      + destruct l; simpl; trivial.
      + (* Proof that the functor is extensional
           beware that the functor contains proofs
           automated with lia hence it is ugly *)
        clear l m.
        intros [ | x l ] m H1 H2 H; auto.
        rewrite H; trivial.
    Qed.

    Fact itl_fix0 m : itl nil m = m.
    Proof. rewrite itl_fix; trivial. Qed.

    Fact itl_fix1 x l m : itl (x::l) m = x::itl m l.
    Proof. rewrite itl_fix; trivial. Qed.

    (** Once the fixpoint equations are established, the
        proof is immediate *)

    Lemma itl_itl_s_eq l m : itl l m = itl_s l m.
    Proof.
      induction on l m as IH with measure (length l + length m).
      destruct l as [ | x l ].
      + rewrite itl_s_fix0, itl_fix0; trivial.
      + rewrite itl_s_fix1, itl_fix1; f_equal.
        apply IH; simpl; lia.
    Qed.

  End interleave_measure.

  Section interleave_measure_paired.

    (** Now by induction on the measure |l|+|m| but with paired arguments *)

    Definition itl_paired l m : list X.
    Proof.
      paired induction on l m as itl_mes with measure (length l + length m).
      revert itl_mes; refine (match l with
        | nil  => fun _       => m
        | x::l => fun itl_mes => x::itl_mes m l _
      end).
      simpl; lia.  (** the measure decreases *)
    Defined.

  End interleave_measure_paired.

  Section interleave_measure_full.

    (** Using dependent full specification allows for easy avoidance
        of the fixpoint equation of measure_double_rect *)

    Local Definition itl_full l m : { k | k = itl_s l m }.
    Proof.
      induction on l m as loop with measure (length l + length m).
      revert loop.
      refine (match l with
        | nil  => fun _    => exist _ m _
        | x::l => fun loop => let (k,Hk) := loop m l _
                              in  exist _ (x::k) _
      end).
      + rewrite itl_s_fix0; trivial.
      + simpl; lia.
      + rewrite Hk, itl_s_fix1; trivial.
    Defined.

    Extraction Inline itl_full.

    Definition itl_f l m := proj1_sig (itl_full l m).

    Fact itl_f_itl_s_eq l m : itl_f l m = itl_s l m.
    Proof. apply (proj2_sig (itl_full _ _)). Qed.

  End interleave_measure_full.

End interleave.

Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive list => "list" [ "[]" "(::)" ].

Recursive Extraction itl_s itl itl_paired itl_f.

Section interleave_without_knowledge_of_semantics.

  Variable X : Type.

  Implicit Type l m : list X.

  (** We implement interleave without knowledge of semantics
      and show correctness afterwards *)

  (** We use the graph (an always definable relation) to specify
      the algorithm *)

  Inductive itl_graph : list X -> list X -> list X -> Prop :=
    | in_itl_g0 : forall m, itl_graph nil m m
    | in_itl_g1 : forall x l m r, itl_graph m l r -> itl_graph (x::l) m (x::r).

  (** The graph is a functional relation by combined induction/inversion *)

  Fact itl_graph_fun l m r1 r2 : itl_graph l m r1 -> itl_graph l m r2 -> r1 = r2.
  Proof.
    intros H1; revert H1 r2.
    induction 1; inversion 1; f_equal; auto.
  Qed.

  (** We use more proving style for this the code.
      Thus is just to show that programming with tactics
      is just fine *)

  Local Definition itl_g_full l m : { k | itl_graph l m k }.
  Proof.
    induction on l m as loop with measure (length l + length m).
    destruct l as [ | x l ].
    + exists m; constructor.
    + refine (let (k,Hk) := loop m l _ in _).
      (* destruct (loop m l) instead of
         refine would introduce a
         parasitic "let in" the extracted code *)
      * simpl; lia.
      * exists (x::k).
        constructor; trivial.
  Defined.

  Extraction Inline itl_g_full.

  Definition itl_g l m := proj1_sig (itl_g_full l m).

  Fact itl_g_spec l m : itl_graph l m (itl_g l m).
  Proof. apply (proj2_sig _). Qed.

  (** We can show correctness after the definition using the graph *)

  Lemma itl_s_g_eq l m : itl_g l m = itl_s l m.
  Proof.
    apply itl_graph_fun with l m.
    * apply itl_g_spec.
    * induction on l m as IH with measure (length l + length m).
      destruct l as [ | x l ].
      + rewrite itl_s_fix0; constructor.
      + rewrite itl_s_fix1; constructor.
        apply IH; simpl; lia.
  Qed.

End interleave_without_knowledge_of_semantics.

Recursive Extraction itl_g.