(** DEPRECATED?
    \o notation for composition is used in LibFixDemos
*)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Functions                                                               *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibContainer LibSet.
Generalizable Variables A.

(* ********************************************************************** *)
(* ================================================================= *)
(** ** Indentity function *)

Definition id {A} (x : A) :=
  x.

(* ********************************************************************** *)
(** Constant functions *)

Definition const {A B} (v : B) : A -> B :=
  fun _ => v.
Definition const1 :=
  @const.
Definition const2 {A1 A2 B} (v:B) : A1->A2->B :=
  fun _ _ => v.
Definition const3 {A1 A2 A3 B} (v:B) : A1->A2->A3->B :=
  fun _ _ _ => v.
Definition const4 {A1 A2 A3 A4 B} (v:B) : A1->A2->A3->A4->B :=
  fun _ _ _ _ => v.
Definition const5 {A1 A2 A3 A4 A5 B} (v:B) : A1->A2->A3->A4->A5->B :=
  fun _ _ _ _ _ => v.

(* ********************************************************************** *)
(** Function application *)

Definition apply {A B} (f : A -> B) (x : A) :=
  f x.

Definition apply_to (A : Type) (x : A) (B : Type) (f : A -> B) :=
  f x.

(* ********************************************************************** *)
(** Function composition *)

Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x => g (f x).

Notation "f1 \o f2" := (compose f1 f2)
  (at level 49, right associativity) : fun_scope.

Section Combinators.
Open Scope fun_scope.
Variables (A B C D : Type).

Lemma compose_id_l : forall (f:A->B),
  id \o f = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_id_r : forall (f:A->B),
  f \o id = f.
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_assoc : forall (f:C->D) (g:B->C) (h:A->B),
  (f \o g) \o h = f \o (g \o h).
Proof using. intros. apply~ fun_ext_1. Qed.

Lemma compose_eq_l : forall (f:B->C) (g1 g2:A->B),
  g1 = g2 -> f \o g1 = f \o g2.
Proof using. intros. subst~. Qed.

Lemma compose_eq_r : forall (f:A->B) (g1 g2:B->C),
  g1 = g2 -> g1 \o f = g2 \o f.
Proof using. intros. subst~. Qed.

(** Composition of [LibList.map] behaves well. **)
(* Could not be put in [LibList] because of circular dependencies. *)
Require Import LibList.

Lemma list_map_compose : forall A B C (f : A -> B) (g : B -> C) l,
  LibList.map g (LibList.map f l) = LibList.map (g \o f) l.
Proof using.
  introv. induction l.
   reflexivity.
   rew_listx. fequals~.
Qed.

End Combinators.

(** Tactic for simplifying function compositions *)
(* --TODO: not used; might become deprecated *)

Hint Rewrite compose_id_l compose_id_r compose_assoc : rew_compose.
Tactic Notation "rew_compose" :=
  autorewrite with rew_compose.
Tactic Notation "rew_compose" "in" "*" :=
  autorewrite with rew_compose in *.
Tactic Notation "rew_compose" "in" hyp(H) :=
  autorewrite with rew_compose in H.

(* ********************************************************************** *)
(* ================================================================= *)
(** ** Function update *)

(** [fupdate f a b x] is like [f] except that it returns [b] for input [a] *)

Definition fupdate A B (f : A -> B) (a : A) (b : B) : A -> B :=
  fun x => If (x = a) then b else f x.

Lemma fupdate_eq : forall A B (f:A->B) a b x,
  fupdate f a b x = If (x = a) then b else f x.
Proof using. auto. Qed.

Lemma fupdate_same : forall A B (f:A->B) a b,
  fupdate f a b a = b.
Proof using. intros. unfold fupdate. case_if*. Qed.

Lemma fupdate_neq : forall A B (f:A->B) a b x,
  x <> a ->
  fupdate f a b x = f x.
Proof using. intros. unfold fupdate. case_if*. Qed.

(* Opaque fupdate. -- could be added in the future *)

(* ********************************************************************** *)
(* ================================================================= *)
(** ** Function image *)

Section FunctionImage.
Open Scope set_scope.
Require Import LibList.

Definition image A B (f : A -> B) (E : set A) : set B :=
  \set{ y | exists_ x \in E, y = f x }.

Lemma in_image_prove_eq : forall A B x (f : A -> B) (E : set A),
  x \in E -> f x \in image f E.
Proof using. introv N. unfold image. rew_set. exists* x. Qed.

Lemma in_image_prove : forall A B x y (f : A -> B) (E : set A),
  x \in E -> y = f x -> y \in image f E.
Proof using. intros. subst. applys* in_image_prove_eq. Qed.

Lemma in_image_inv : forall A B y (f : A -> B) (E : set A),
  y \in image f E -> exists x, x \in E /\ y = f x.
Proof using. introv N. unfolds image. rew_set in N. auto. Qed.

Lemma finite_image : forall A B (f : A -> B) (E : set A),
  finite E ->
  finite (image f E).
Proof using.
  introv M. lets (L&H): finite_inv_list_covers M.
  applys finite_of_list_covers (LibList.map f L). introv N.
  lets (y&Hy&Ey): in_image_inv (rm N). subst x. applys* mem_map.
Qed.

Lemma image_covariant : forall A B (f : A -> B) (E F : set A),
  E \c F ->
  image f E \c image f F.
Proof using.
  introv. do 2 rewrite incl_in_eq. introv M N.
  lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
Qed.

Lemma image_union : forall A B (f : A -> B) (E F : set A),
  image f (E \u F) = image f E \u image f F.
Proof using.
  Hint Resolve in_image_prove.
  introv. apply in_extens. intros x. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_union_eq in Hy.
     rewrite in_union_eq. destruct* Hy.
    rewrite in_union_eq in N. destruct N as [N|N].
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
Qed.

Lemma image_singleton : forall A B (f : A -> B) (x : A),
  image f \{x} = \{f x}.
Proof using.
  intros. apply in_extens. intros z. rewrite in_single_eq. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_single_eq in Hy. subst~.
    applys* in_image_prove. rewrite~ @in_single_eq. typeclass.
Qed.

End FunctionImage.

Hint Resolve finite_image : finite.

(* ********************************************************************** *)
(* ================================================================= *)
(** ** Function preimage *)

Section FunctionPreimage.
Open Scope set_scope.

Definition preimage A B (f : A -> B) (E : set B) : set A :=
  \set{ x | exists_ y \in E, y = f x }.

End FunctionPreimage.

(* ********************************************************************** *)
(* ================================================================= *)
(** ** Function iteration *)

Fixpoint applyn A n (f : A -> A) x :=
  match n with
  | O => x
  | S n' => f (applyn n' f x)
  end.

Lemma applyn_fix : forall A n f (x : A),
  applyn (S n) f x = applyn n f (f x).
Proof using. introv. induction~ n. simpls. rewrite~ IHn. Qed.

Lemma applyn_comp : forall A n m f (x : A),
  applyn n f (applyn m f x) = applyn (n + m) f x.
Proof using.
  introv. gen m; induction n; introv; simpls~.
  rewrite~ IHn.
Qed.

Lemma applyn_nested : forall A n m f (x : A),
  applyn n (applyn m f) x = applyn (n * m) f x.
Proof using.
  introv. gen m. induction n; introv; simpls~.
  rewrite IHn. rewrite~ applyn_comp.
Qed.

Lemma applyn_altern : forall A B (f : A -> B) (g : B -> A) x n,
  applyn n (fun x => f (g x)) (f x) =
    f (applyn n (fun x => g (f x)) x).
Proof using. introv. gen x. induction~ n. introv. repeat rewrite applyn_fix. autos~. Qed.

Lemma applyn_ind : forall A (P : A -> Prop) (f : A -> A) x n,
  (forall x, P x -> P (f x)) ->
  P x ->
  P (applyn n f x).
Proof using. introv I. induction n; introv Hx; autos*. Qed.

(* --TODO: rename applyn to iter *)
(* --TODO: migrate iteration of functionals from LibFix to here *)


Set Implicit Arguments.
Require Export Omega.
Require Export ArithRing.
Require Export Coq.Numbers.Natural.Peano.NPeano.
  (* [Nat] is a sub-module of [NPeano], which seems to contain many things.
     E.g. it defines [Nat.div], [Nat.pow], [Nat.log2].
     E.g. it defines [Nat.max], which is the same as [max].
     E.g. it has many properties of [max], see [Coq.Structures.GenericMinMax].
     Unfortunately [Nat.le] is NOT the same as [le], which is [Peano.le].
     For this reason, we do NOT import [Nat]. *)
  Notation log2 := Nat.log2.
Require Import TLC.LibTactics.
Require Import LibFunOrd.

(* ---------------------------------------------------------------------------- *)

(* A few simplification lemmas. *)

Lemma plus_lt_plus:
  forall a x y,
  x < y ->
  x + a < y + a.
Proof using.
  intros. omega.
Qed.

Lemma plus_le_plus:
  forall a x y,
  x <= y ->
  x + a <= y + a.
Proof using.
  intros. omega.
Qed.

(* ---------------------------------------------------------------------------- *)

(* [a <= b] is equivalent to [b = a + n] for some unknown [n]. *)

Lemma leq_to_eq_plus:
  forall a b,
  a <= b ->
  exists n,
  b = a + n.
Proof.
  intros. exists (b - a). omega.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Make [omega] a hint. *)

Hint Extern 1 => omega : omega.

(* ---------------------------------------------------------------------------- *)

(* This lemma allows simplifying a [max] expression, by cases. *)

Lemma max_case:
  forall m1 m2,
  m2 <= m1 /\ max m1 m2 = m1 \/
  m1 <= m2 /\ max m1 m2 = m2.
Proof using.
  intros. destruct (@le_gt_dec m1 m2); eauto using max_r, max_l with omega.
Qed.

(* This tactic looks for a [max] expression in the hypotheses or in the goal
   and applies the above lemma. *)

Ltac max_case_m_n_as m n h :=
  let i := fresh in
  destruct (max_case m n) as [ [ h i ] | [ h i ] ];
  rewrite i in *;
  clear i.

Ltac max_case_as h :=
  match goal with
  | |- context[max ?m ?n] =>
      max_case_m_n_as m n h
  | foo: context[max ?m ?n] |- _ =>
      max_case_m_n_as m n h
  end.

Ltac max_case :=
  let h := fresh in
  max_case_as h.

(* [max m1 m2] is an upper bound for [m1] and [m2]. This can be sufficient
   to reason about [max] without introducing a case split. *)

Lemma max_ub:
  forall m1 m2,
  m1 <= max m1 m2 /\ m2 <= max m1 m2.
Proof using.
  intros. eauto using Nat.le_max_l, Nat.le_max_r.
Qed.

Ltac max_ub_m_n_as m n h1 h2 :=
  destruct (max_ub m n) as [ h1 h2 ];
  generalize dependent (max m n);
  intros.

Ltac max_ub_as h1 h2 :=
  match goal with
  | |- context[max ?m ?n] =>
      max_ub_m_n_as m n h1 h2
  | foo: context[max ?m ?n] |- _ =>
      max_ub_m_n_as m n h1 h2
  end.

Ltac max_ub :=
  let h1 := fresh in
  let h2 := fresh in
  max_ub_as h1 h2.

(* ---------------------------------------------------------------------------- *)

(* Properties of multiplication. *)

Lemma mult_positive:
  forall m n,
  0 < m ->
  0 < n ->
  0 < m * n.
Proof using.
  intros.
  destruct (eq_nat_dec (m * n) 0).
  forwards [ ? | ? ]: mult_is_O. eauto. omega. omega.
  generalize dependent (m * n). intros. omega.
Qed.

Hint Resolve mult_positive : positive.

Lemma mult_magnifies_left:
  forall m n,
  0 < n ->
  m <= n * m.
Proof using.
  intros.
  destruct n; [ omega | simpl ].
  generalize (n * m); intro.
  omega.
Qed.

Lemma mult_magnifies_right:
  forall m n,
  0 < n ->
  m <= m * n.
Proof using.
  intros. rewrite mult_comm. eauto using mult_magnifies_left.
Qed.

Lemma mult_magnifies_right_strict:
  forall m n,
  0 < m ->
  1 < n ->
  m < m * n.
Proof using.
  intros.
  do 2 (destruct n; [ omega | ]).
  rewrite mult_comm. simpl.
  generalize (n * m). intros. omega.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Properties of division. *)

(* It is strange that the Coq standard library offers [divmod_spec],
   but lacks its corollary [div_spec]. *)

Lemma div_spec:
  forall n k,
  0 < k ->
  exists r,
  k * (n / k) + r = n /\ 0 <= r < k.
Proof using.
  intros. unfold Nat.div.
  destruct k; [ false; omega | simpl ].
  forwards: Nat.divmod_spec n k 0 k. eauto.
  destruct (Nat.divmod n k 0 k) as [ q r ]. unpack. simpl.
  exists (k - r). omega.
Qed.

(* Avoid undesired simplifications. *)
(* TEMPORARY [plus] should be opaque too? *)
Global Opaque mult Nat.div max.

(* A tactic to reason about [n/2] in terms of its specification. *)

Ltac div2 :=
  match goal with |- context[?n/2] =>
    let h := fresh in
    forwards h: div_spec n 2; [ omega |
      gen h; generalize (n/2); intros; unpack
    ]
  end.

(* [./2] is monotonic. *)

Lemma div2_monotonic:
  forall m n,
  m <= n ->
  m / 2 <= n / 2.
Proof using.
  intros. repeat div2. omega.
Qed.

Lemma div2_step:
  forall n,
  (n + 2) / 2 = n/2 + 1.
Proof using.
  intros. repeat div2. omega.
Qed.

Lemma div2_monotonic_strict:
  forall m n,
  m + 2 <= n ->
  m / 2 < n / 2.
Proof using.
  intros. cut (m/2 + 1 <= n/2). omega.
  rewrite <- div2_step.
  eauto using div2_monotonic.
Qed.

Lemma mult_div_2:
  forall n,
  2 * (n / 2) <= n.
Proof using.
  intros. div2. omega.
Qed.

Lemma div_mult_2:
  forall n,
  (2 * n) / 2 = n.
Proof using.
  intros. div2. omega.
Qed.

(* A collection of lemmas about division by two and ordering. *)

Lemma prove_div2_le:
  forall m n,
  m <= 2 * n + 1 -> (* tight *)
  m / 2 <= n.
Proof using.
  intros. div2. omega.
Qed.

Lemma use_div2_plus1_le:
  forall m n,
  (n + 1) / 2 <= m -> (* tight *)
  n <= 2 * m.
Proof using.
  intros m n. div2. omega.
Qed.

Lemma use_div2_le:
  forall m n,
  n / 2 <= m -> (* tight *)
  n <= 2 * m + 1.
Proof using.
  intros m n. div2. omega.
Qed.

Lemma prove_le_div2:
  forall m n,
  2 * m <= n -> (* tight *)
  m <= n / 2.
Proof using.
  intros. div2. omega.
Qed.

Lemma use_le_div2:
  forall m n,
  n <= m / 2 -> (* tight *)
  2 * n <= m.
Proof using.
  intros m n. div2. omega.
Qed.

Lemma prove_div2_lt:
  forall m n,
  m < 2 * n -> (* tight *)
  m / 2 < n.
Proof using.
  intros. div2. omega.
Qed.

Lemma use_div2_lt:
  forall m n,
  m / 2 < n -> (* tight *)
  m < 2 * n.
Proof using.
  intros m n. div2. omega.
Qed.

Lemma prove_lt_div2:
  forall m n,
  2 * m < n - 1 -> (* tight *)
  m < n / 2.
Proof using.
  intros. div2. omega.
Qed.

Lemma prove_lt_div2_zero:
  forall n,
  1 < n -> (* tight *)
  0 < n / 2.
Proof using.
  intros. div2. omega.
Qed.

Lemma use_lt_div2:
  forall m n,
  m < (n + 1) / 2 -> (* tight *)
  2 * m < n.
Proof using.
  intros m n. div2. omega.
Qed.

Hint Resolve prove_lt_div2_zero : positive.

Hint Resolve prove_div2_le use_div2_plus1_le use_div2_le prove_le_div2
use_le_div2 prove_div2_lt use_div2_lt prove_lt_div2 use_lt_div2 :
div2.

Goal
  forall n,
  n <= 2 * (n / 2) + 1.
Proof using.
  eauto with div2.
Qed.

(* ---------------------------------------------------------------------------- *)

(* The [pow] function. *)

Lemma power_positive:
  forall k n,
  0 < n ->
  0 < n^k.
Proof using.
  induction k; simpl; intros.
  omega.
  eauto using mult_positive.
Qed.

Hint Resolve power_positive : positive.

Lemma power_plus:
  forall k1 k2 n,
  n^(k1 + k2) = n^k1 * n^k2.
Proof using.
  induction k1; simpl; intros.
  omega.
  rewrite IHk1. ring.
Qed.

Lemma power_of_zero:
  forall k,
  0 < k ->
  0^k = 0.
Proof using.
  induction k; simpl; intros; omega.
Qed.

Lemma power_monotonic_in_k:
  (* We must assume [n > 0], because [0^0] is 1, yet [0^1] is 0. *)
  forall n,
  0 < n ->
  monotonic le le (fun k => n^k).
Proof using.
  intros. intros k1 k2 ?.
  assert (f: k2 = k1 + (k2 - k1)). omega.
  rewrite f. rewrite power_plus.
  eapply mult_magnifies_right.
  eapply power_positive.
  assumption.
Qed.

Lemma power_strictly_monotonic_in_k:
  forall n,
  1 < n ->
  monotonic lt lt (fun k => n^k).
Proof using.
  intros. intros k1 k2 ?.
  assert (f: k2 = k1 + S (k2 - k1 - 1)). omega.
  rewrite f. rewrite power_plus.
  eapply mult_magnifies_right_strict.
    { eauto with positive omega. }
    { simpl.
      eapply lt_le_trans with (m := n). omega.
      eapply mult_magnifies_right.
      eauto with positive omega. }
Qed.

Lemma power_strictly_monotonic_in_n:
  forall k,
  0 < k ->
  monotonic lt lt (fun n => n^k).
Proof using.
  (* We first prove that this holds when [n1] is nonzero,
     and reformulate the hypothesis [k > 0] so that it is
     amenable to induction. *)
  assert (f:
    forall k n1 n2,
    0 < n1 < n2 ->
    n1^(S k) < n2^(S k)
  ).
  { induction k; simpl; intros.
    omega.
    eapply lt_le_trans; [ eapply mult_lt_compat_r | eapply mult_le_compat_l ]. (* wow *)
      omega.
      eapply power_positive with (k := S k). omega.
      forwards: IHk. eauto. simpl in *. omega. }
  (* There remains to treat separately the case where [n1] is 0. *)
  intros. intros n1 n2 ?.
  destruct (le_gt_dec n1 0).
    { assert (n1 = 0). omega. subst.
      rewrite power_of_zero by assumption.
      eapply power_positive. omega. }
    { destruct k; [ omega | ].
      eapply f. omega. } (* ouf *)
Qed.

Hint Resolve power_monotonic_in_k power_strictly_monotonic_in_k
power_strictly_monotonic_in_n : monotonic typeclass_instances.

Lemma power_monotonic_in_n:
  forall k,
  monotonic le le (fun n => n^k).
Proof using.
  intros.
  destruct (eq_nat_dec k 0).
  { subst. simpl. repeat intro. omega. }
  { eauto with monotonic omega. }
Qed.

Hint Resolve power_monotonic_in_n : monotonic typeclass_instances.

(* TEMPORARY maybe explicitly use [inverse_monotonic] in lemmas below *)

Lemma power_inverse_monotonic_in_k:
  forall n,
  1 < n ->
  forall k1 k2,
  n^k1 <= n^k2 ->
  k1 <= k2.
Proof using.
  intros.
  eapply monotonic_lt_lt_implies_inverse_monotonic_le_le with (f := fun k => n^k);
  eauto using power_strictly_monotonic_in_k.
Qed.

Lemma power_strictly_inverse_monotonic_in_k:
  forall n k1 k2,
  0 < n ->
  n^k1 < n^k2 ->
  k1 < k2.
Proof using.
  intros.
  eapply monotonic_le_le_implies_inverse_monotonic_lt_lt with (f := fun k => n^k);
  eauto using power_monotonic_in_k.
Qed.

Lemma power_strictly_inverse_monotonic_in_k_variant:
  forall n k1 k2,
  0 < n ->
  n^k1 < n^(1 + k2) ->
  k1 <= k2.
Proof using.
  intros. cut (k1 < 1 + k2). { omega. }
  eauto using power_strictly_inverse_monotonic_in_k.
Qed.

Lemma power_strictly_inverse_monotonic_in_k_frame:
  forall n k1 k2,
  1 < n ->
  n^k2 <= n^k1 < n^(1 + k2) ->
  k1 = k2.
Proof using.
  intros.
  assert (k2 <= k1).
    { eapply power_inverse_monotonic_in_k with (n := n); eauto with omega. }
  assert (k1 < 1 + k2).
    { eapply power_strictly_inverse_monotonic_in_k with (n := n); eauto with omega. }
  omega.
Qed.

Lemma power_inverse_monotonic_in_n:
  forall k,
  0 < k ->
  forall n1 n2,
  n1^k <= n2^k ->
  n1 <= n2.
Proof using.
  intros.
  eapply monotonic_lt_lt_implies_inverse_monotonic_le_le with (f := fun n => n^k);
  eauto using power_strictly_monotonic_in_n.
Qed.

(* A lower bound on [2^n]. *)

Lemma n_lt_power:
  forall n,
  n < 2^n.
Proof using.
  induction n; simpl; omega.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Base 2 logarithm. *)

(* The Coq standard library gives us the following:
     Lemma log2_spec : forall n, 0<n ->
       2^(log2 n) <= n < 2^(S (log2 n)).
*)

Ltac log2_spec :=
  match goal with |- context[log2 ?n] =>
    let h := fresh in
    forwards h: Nat.log2_spec n; [ eauto with positive omega |
      gen h; generalize (log2 n); intros; unpack
    ]
  end.

(* The above specification is functional, i.e., it defines [log2 n] in a
   unique manner. *)

Lemma log2_uniqueness_half:
  forall n k1 k2,
  2^k1 <= n < 2^(1 + k1) ->
  2^k2 <= n < 2^(1 + k2) ->
  k1 <= k2.
Proof using.
  simpl. intros. unpack.
  eapply power_strictly_inverse_monotonic_in_k_variant with (n := 2). omega.
  eauto using le_lt_trans.
Qed.

Lemma log2_uniqueness:
  forall n k1 k2,
  2^k1 <= n < 2^(1 + k1) ->
  2^k2 <= n < 2^(1 + k2) ->
  k1 = k2.
Proof using.
  intros.
  forwards: log2_uniqueness_half n k1 k2; eauto.
  forwards: log2_uniqueness_half n k2 k1; eauto.
  omega.
Qed.

(* When applied to a power of two, [log2] yields the exponent. *)

Lemma log2_pow:
  forall k,
  log2 (2^k) = k.
Proof using.
  intros k. log2_spec.
  symmetry. eapply power_strictly_inverse_monotonic_in_k_frame with (n := 2). omega.
  eauto.
Qed.

(* This is just a repetition of one half of [log2_spec]. *)

Lemma pow_log2:
  forall n,
  0 < n ->
  2 ^ (log2 n) <= n.
Proof using.
  intros. eapply Nat.log2_spec. eauto.
Qed.

Lemma pow_succ_log2:
  forall n,
  n < 2^(1 + log2 n).
Proof using.
  intros.
  destruct (eq_nat_dec n 0).
  { subst. simpl. omega. }
  { eapply Nat.log2_spec. omega. }
Qed.

(* The inductive step of many arguments that involve divide-and-conquer. *)

Lemma log2_step:
  forall n,
  2 <= n ->
  1 + log2 (n/2) = log2 n.
Proof using.
  intros. repeat log2_spec.
  eapply log2_uniqueness; [ | eauto ].
  simpl. eauto with div2.
Qed.

(* [log2] is monotonic. *)

Lemma log2_monotonic:
  monotonic le le log2.
Proof using.
  intros m n ?.
  (* A special case for [m = 0]. *)
  destruct (eq_nat_dec m 0).
  { subst. unfold log2. simpl. omega. }
  (* Case [m > 0]. *)
  do 2 log2_spec.
  eapply power_strictly_inverse_monotonic_in_k_variant with (n := 2); simpl; omega.
Qed.

Hint Resolve log2_monotonic : monotonic typeclass_instances.

(* A collection of lemmas involving [log2] and ordering. *)

Lemma prove_le_log2:
  forall k n,
  2^k <= n ->
  k <= log2 n.
Proof using.
  intros.
  forwards: log2_monotonic. eauto.
  rewrite log2_pow in *.
  assumption.
Qed.

Lemma prove_log2_le:
  forall k n,
  n <= 2^k ->
  log2 n <= k.
Proof using.
  intros.
  forwards: log2_monotonic. eauto.
  rewrite log2_pow in *.
  assumption.
Qed.

Lemma prove_log2_lt:
  forall k n,
  0 < n ->
  n < 2^k ->
  log2 n < k.
Proof using.
  intros.
  eapply monotonic_le_le_implies_inverse_monotonic_lt_lt with (f := fun n => 2^n).
    { eauto with monotonic. }
  eauto using le_lt_trans, pow_log2.
Qed.

Hint Resolve prove_le_log2 prove_log2_le prove_log2_lt : log2.

(* An upper bound on [log2 n]. *)

Lemma log2_lt_n:
  forall n,
  0 < n ->
  log2 n < n.
Proof using.
  eauto using prove_log2_lt, n_lt_power.
Qed.

(* ---------------------------------------------------------------------------- *)

(* The existence of the function [log2] means that the sequence [n], [n/2],
   [n/4], etc. tends towards zero. We can exploit this by giving the following
   induction principle. *)

Lemma div2_induction:
  forall (P : nat -> Prop),
  P 0 ->
  (forall n, P (n/2) -> P n) ->
  forall n, P n.
Proof using.
  introv hbase hstep.
  assert (f: forall k n, log2 n < k -> P n).
  { induction k; intros.
    false. omega.
    (* Special cases for [n = 0] and [n = 1]. *)
    destruct (eq_nat_dec n 0); [ subst n | ]. { eauto. }
    destruct (eq_nat_dec n 1); [ subst n | ]. { eauto. }
    (* In the general case, [2 <= n], we use [log2_step]. *)
    eapply hstep. eapply IHk.
    cut (1 + log2 (n / 2) <= k). { omega. }
    rewrite log2_step by omega.
    omega.
  }
  intros. eapply f with (k := log2 n + 1). omega.
Qed.

(* The following variant of the above induction principle allows
   establishing a property [P] that mentions both [log2 n] and [n]. *)

Lemma log2_induction:
  forall (P : nat -> nat -> Prop),
  P 0 0 ->
  P 0 1 ->
  (forall k n, 2 <= n -> P k (n/2) -> P (1+k) n) ->
  forall n, P (log2 n) n.
Proof using.
  introv h00 h01 hkn.
  (* Maybe one could give a direct proof; anyway, we choose to give
     a proof based on the previous induction principle. *)
  assert (forall n, 1 <= n -> P (log2 n) n).
  { eapply (@div2_induction (fun n => 1 <= n -> P (log2 n) n)).
    (* The base case cannot arise. *)
    { intro. false. omega. }
    (* Step. *)
    { intros n IH ?.
      (* Special case for [n = 1]. *)
      destruct (eq_nat_dec n 1); [ subst n; exact h01 | ].
      (* In the general case, [2 <= n], we use [log2_step]. *)
      assert (2 <= n). { omega. }
      rewrite <- log2_step by assumption.
      eauto with div2. }
  }
  intro n.
  (* Special case for [n = 0]. *)
  destruct (eq_nat_dec n 0); [ subst n; exact h00 | ].
  (* General case. *)
  eauto with omega.
Qed.


(*************************************************************)
(*      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      *)
(*************************************************************)

(**********************************************************************
    Permutation.v

    Defintion and properties of permutations
   **********************************************************************)
Require Export List.
Require Export ListAux.

Section permutation.
Variable A : Set.

(**************************************
   Definition of permutations as sequences of adjacent transpositions
 **************************************)

Inductive permutation : list A -> list A -> Prop :=
  | permutation_nil : permutation nil nil
  | permutation_skip :
      forall (a : A) (l1 l2 : list A),
      permutation l2 l1 -> permutation (a :: l2) (a :: l1)
  | permutation_swap :
      forall (a b : A) (l : list A), permutation (a :: b :: l) (b :: a :: l)
  | permutation_trans :
      forall l1 l2 l3 : list A,
      permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3.
Hint Constructors permutation : core.

(**************************************
   Reflexivity
 **************************************)

Theorem permutation_refl : forall l : list A, permutation l l.
simple induction l.
apply permutation_nil.
intros a l1 H.
apply permutation_skip with (1 := H).
Qed.
Hint Resolve permutation_refl : core.

(**************************************
   Symmetry
   **************************************)

Theorem permutation_sym :
 forall l m : list A, permutation l m -> permutation m l.
intros l1 l2 H'; elim H'.
apply permutation_nil.
intros a l1' l2' H1 H2.
apply permutation_skip with (1 := H2).
intros a b l1'.
apply permutation_swap.
intros l1' l2' l3' H1 H2 H3 H4.
apply permutation_trans with (1 := H4) (2 := H2).
Qed.

(**************************************
   Compatibility with list length
   **************************************)

Theorem permutation_length :
 forall l m : list A, permutation l m -> length l = length m.
intros l m H'; elim H'; simpl in |- *; auto.
intros l1 l2 l3 H'0 H'1 H'2 H'3.
rewrite <- H'3; auto.
Qed.

(**************************************
   A permutation of the nil list is the nil list
   **************************************)

Theorem permutation_nil_inv : forall l : list A, permutation l nil -> l = nil.
intros l H; generalize (permutation_length _ _ H); case l; simpl in |- *;
 auto.
intros; discriminate.
Qed.

(**************************************
   A permutation of the singleton list is the singleton list
   **************************************)

Let permutation_one_inv_aux :
  forall l1 l2 : list A,
  permutation l1 l2 -> forall a : A, l1 = a :: nil -> l2 = a :: nil.
intros l1 l2 H; elim H; clear H l1 l2; auto.
intros a l3 l4 H0 H1 b H2.
injection H2; intros; subst; auto.
rewrite (permutation_nil_inv _ (permutation_sym _ _ H0)); auto.
intros; discriminate.
Qed.

Theorem permutation_one_inv :
 forall (a : A) (l : list A), permutation (a :: nil) l -> l = a :: nil.
intros a l H; apply permutation_one_inv_aux with (l1 := a :: nil); auto.
Qed.

(**************************************
   Compatibility with the belonging
   **************************************)

Theorem permutation_in :
 forall (a : A) (l m : list A), permutation l m -> In a l -> In a m.
intros a l m H; elim H; simpl in |- *; auto; intuition.
Qed.

(**************************************
   Compatibility with the append function
   **************************************)

Theorem permutation_app_comp :
 forall l1 l2 l3 l4,
 permutation l1 l2 -> permutation l3 l4 -> permutation (l1 ++ l3) (l2 ++ l4).
intros l1 l2 l3 l4 H1; generalize l3 l4; elim H1; clear H1 l1 l2 l3 l4;
 simpl in |- *; auto.
intros a b l l3 l4 H.
cut (permutation (l ++ l3) (l ++ l4)); auto.
intros; apply permutation_trans with (a :: b :: l ++ l4); auto.
elim l; simpl in |- *; auto.
intros l1 l2 l3 H H0 H1 H2 l4 l5 H3.
apply permutation_trans with (l2 ++ l4); auto.
Qed.
Hint Resolve permutation_app_comp : core.

(**************************************
   Swap two sublists
   **************************************)

Theorem permutation_app_swap :
 forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1).
intros l1; elim l1; auto.
intros; rewrite <- app_nil_end; auto.
intros a l H l2.
replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l).
apply permutation_trans with (l ++ l2 ++ a :: nil); auto.
apply permutation_trans with (((a :: nil) ++ l2) ++ l); auto.
simpl in |- *; auto.
apply permutation_trans with (l ++ (a :: nil) ++ l2); auto.
apply permutation_sym; auto.
replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l).
apply permutation_app_comp; auto.
elim l2; simpl in |- *; auto.
intros a0 l0 H0.
apply permutation_trans with (a0 :: a :: l0); auto.
apply (app_ass l2 (a :: nil) l).
apply (app_ass l2 (a :: nil) l).
Qed.

(**************************************
   A transposition is a permutation
   **************************************)

Theorem permutation_transposition :
 forall a b l1 l2 l3,
 permutation (l1 ++ a :: l2 ++ b :: l3) (l1 ++ b :: l2 ++ a :: l3).
intros a b l1 l2 l3.
apply permutation_app_comp; auto.
change
  (permutation ((a :: nil) ++ l2 ++ (b :: nil) ++ l3)
     ((b :: nil) ++ l2 ++ (a :: nil) ++ l3)) in |- *.
repeat rewrite <- app_ass.
apply permutation_app_comp; auto.
apply permutation_trans with ((b :: nil) ++ (a :: nil) ++ l2); auto.
apply permutation_app_swap; auto.
repeat rewrite app_ass.
apply permutation_app_comp; auto.
apply permutation_app_swap; auto.
Qed.

(**************************************
   An element of a list can be put on top of the list to get a permutation
   **************************************)

Theorem in_permutation_ex :
 forall a l, In a l -> exists l1 : list A, permutation (a :: l1) l.
intros a l; elim l; simpl in |- *; auto.
intros H; case H; auto.
intros a0 l0 H [H0| H0].
exists l0; rewrite H0; auto.
case H; auto; intros l1 Hl1; exists (a0 :: l1).
apply permutation_trans with (a0 :: a :: l1); auto.
Qed.

(**************************************
   A permutation of a cons can be inverted
   **************************************)

Let permutation_cons_ex_aux :
  forall (a : A) (l1 l2 : list A),
  permutation l1 l2 ->
  forall l11 l12 : list A,
  l1 = l11 ++ a :: l12 ->
  exists l3 : list A,
    (exists l4 : list A,
       l2 = l3 ++ a :: l4 /\ permutation (l11 ++ l12) (l3 ++ l4)).
intros a l1 l2 H; elim H; clear H l1 l2.
intros l11 l12; case l11; simpl in |- *; intros; discriminate.
intros a0 l1 l2 H H0 l11 l12; case l11; simpl in |- *.
exists (nil (A:=A)); exists l1; simpl in |- *; split; auto.
injection H1; intros; subst; auto.
injection H1; intros H2 H3; rewrite <- H2; auto.
intros a1 l111 H1.
case (H0 l111 l12); auto.
injection H1; auto.
intros l3 (l4, (Hl1, Hl2)).
exists (a0 :: l3); exists l4; split; simpl in |- *; auto.
injection H1; intros; subst; auto.
injection H1; intros H2 H3; rewrite H3; auto.
intros a0 b l l11 l12; case l11; simpl in |- *.
case l12; try (intros; discriminate).
intros a1 l0 H; exists (b :: nil); exists l0; simpl in |- *; split; auto.
injection H; intros; subst; auto.
injection H; intros H1 H2 H3; rewrite H2; auto.
intros a1 l111; case l111; simpl in |- *.
intros H; exists (nil (A:=A)); exists (a0 :: l12); simpl in |- *; split; auto.
injection H; intros; subst; auto.
injection H; intros H1 H2 H3; rewrite H3; auto.
intros a2 H1111 H; exists (a2 :: a1 :: H1111); exists l12; simpl in |- *;
 split; auto.
injection H; intros; subst; auto.
intros l1 l2 l3 H H0 H1 H2 l11 l12 H3.
case H0 with (1 := H3).
intros l4 (l5, (Hl1, Hl2)).
case H2 with (1 := Hl1).
intros l6 (l7, (Hl3, Hl4)).
exists l6; exists l7; split; auto.
apply permutation_trans with (1 := Hl2); auto.
Qed.

Theorem permutation_cons_ex :
 forall (a : A) (l1 l2 : list A),
 permutation (a :: l1) l2 ->
 exists l3 : list A,
   (exists l4 : list A, l2 = l3 ++ a :: l4 /\ permutation l1 (l3 ++ l4)).
intros a l1 l2 H.
apply (permutation_cons_ex_aux a (a :: l1) l2 H nil l1); simpl in |- *; auto.
Qed.

(**************************************
   A permutation can be simply inverted if the two list starts with a cons
   **************************************)

Theorem permutation_inv :
 forall (a : A) (l1 l2 : list A),
 permutation (a :: l1) (a :: l2) -> permutation l1 l2.
intros a l1 l2 H; case permutation_cons_ex with (1 := H).
intros l3 (l4, (Hl1, Hl2)).
apply permutation_trans with (1 := Hl2).
generalize Hl1; case l3; simpl in |- *; auto.
intros H1; injection H1; intros H2; rewrite H2; auto.
intros a0 l5 H1; injection H1; intros H2 H3; rewrite H2; rewrite H3; auto.
apply permutation_trans with (a0 :: l4 ++ l5); auto.
apply permutation_skip; apply permutation_app_swap.
apply (permutation_app_swap (a0 :: l4) l5).
Qed.

(**************************************
   Take a list and return tle list of all pairs of an element of the
   list and the remaining list
   **************************************)

Fixpoint split_one (l : list A) : list (A * list A) :=
  match l with
  | nil => nil (A:=A * list A)
  | a :: l1 =>
      (a, l1)
      :: map (fun p : A * list A => (fst p, a :: snd p)) (split_one l1)
  end.

(**************************************
   The pairs of the list are a permutation
   **************************************)

Theorem split_one_permutation :
 forall (a : A) (l1 l2 : list A),
 In (a, l1) (split_one l2) -> permutation (a :: l1) l2.
intros a l1 l2; generalize a l1; elim l2; clear a l1 l2; simpl in |- *; auto.
intros a l1 H1; case H1.
intros a l H a0 l1 [H0| H0].
injection H0; intros H1 H2; rewrite H2; rewrite H1; auto.
generalize H H0; elim (split_one l); simpl in |- *; auto.
intros H1 H2; case H2.
intros a1 l0 H1 H2 [H3| H3]; auto.
injection H3; intros H4 H5; (rewrite <- H4; rewrite <- H5).
apply permutation_trans with (a :: fst a1 :: snd a1); auto.
apply permutation_skip.
apply H2; auto.
case a1; simpl in |- *; auto.
Qed.

(**************************************
   All elements of the list are there
   **************************************)

Theorem split_one_in_ex :
 forall (a : A) (l1 : list A),
 In a l1 -> exists l2 : list A, In (a, l2) (split_one l1).
intros a l1; elim l1; simpl in |- *; auto.
intros H; case H.
intros a0 l H [H0| H0]; auto.
exists l; left; subst; auto.
case H; auto.
intros x H1; exists (a0 :: x); right; auto.
apply
 (in_map (fun p : A * list A => (fst p, a0 :: snd p)) (split_one l) (a, x));
 auto.
Qed.

(**************************************
   An auxillary function to generate all permutations
   **************************************)

Fixpoint all_permutations_aux (l : list A) (n : nat) {struct n} :
 list (list A) :=
  match n with
  | O => nil :: nil
  | S n1 =>
      flat_map
        (fun p : A * list A =>
         map (cons (fst p)) (all_permutations_aux (snd p) n1)) (
        split_one l)
  end.
(**************************************
   Generate all the permutations
   **************************************)

Definition all_permutations (l : list A) := all_permutations_aux l (length l).

(**************************************
   All the elements of the list are permutations
   **************************************)

Let all_permutations_aux_permutation :
  forall (n : nat) (l1 l2 : list A),
  n = length l2 -> In l1 (all_permutations_aux l2 n) -> permutation l1 l2.
intros n; elim n; simpl in |- *; auto.
intros l1 l2; case l2.
simpl in |- *; intros H0 [H1| H1].
rewrite <- H1; auto.
case H1.
simpl in |- *; intros; discriminate.
intros n0 H l1 l2 H0 H1.
case in_flat_map_ex with (1 := H1).
clear H1; intros x; case x; clear x; intros a1 l3 (H1, H2).
case in_map_inv with (1 := H2).
simpl in |- *; intros y (H3, H4).
rewrite H4; auto.
apply permutation_trans with (a1 :: l3); auto.
apply permutation_skip; auto.
apply H with (2 := H3).
apply eq_add_S.
apply trans_equal with (1 := H0).
change (length l2 = length (a1 :: l3)) in |- *.
apply permutation_length; auto.
apply permutation_sym; apply split_one_permutation; auto.
apply split_one_permutation; auto.
Qed.

Theorem all_permutations_permutation :
 forall l1 l2 : list A, In l1 (all_permutations l2) -> permutation l1 l2.
intros l1 l2 H; apply all_permutations_aux_permutation with (n := length l2);
 auto.
Qed.

(**************************************
   A permutation is in the list
   **************************************)

Let permutation_all_permutations_aux :
  forall (n : nat) (l1 l2 : list A),
  n = length l2 -> permutation l1 l2 -> In l1 (all_permutations_aux l2 n).
intros n; elim n; simpl in |- *; auto.
intros l1 l2; case l2.
intros H H0; rewrite permutation_nil_inv with (1 := H0); auto with datatypes.
simpl in |- *; intros; discriminate.
intros n0 H l1; case l1.
intros l2 H0 H1;
 rewrite permutation_nil_inv with (1 := permutation_sym _ _ H1) in H0;
 discriminate.
clear l1; intros a1 l1 l2 H1 H2.
case (split_one_in_ex a1 l2); auto.
apply permutation_in with (1 := H2); auto with datatypes.
intros x H0.
apply in_flat_map with (b := (a1, x)); auto.
apply in_map; simpl in |- *.
apply H; auto.
apply eq_add_S.
apply trans_equal with (1 := H1).
change (length l2 = length (a1 :: x)) in |- *.
apply permutation_length; auto.
apply permutation_sym; apply split_one_permutation; auto.
apply permutation_inv with (a := a1).
apply permutation_trans with (1 := H2).
apply permutation_sym; apply split_one_permutation; auto.
Qed.

Theorem permutation_all_permutations :
 forall l1 l2 : list A, permutation l1 l2 -> In l1 (all_permutations l2).
intros l1 l2 H; unfold all_permutations in |- *;
 apply permutation_all_permutations_aux; auto.
Qed.

(**************************************
   Permutation is decidable
   **************************************)

Definition permutation_dec :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l1 l2 : list A, {permutation l1 l2} + {~ permutation l1 l2}.
intros H l1 l2.
case (In_dec (list_eq_dec H) l1 (all_permutations l2)).
intros i; left; apply all_permutations_permutation; auto.
intros i; right; contradict i; apply permutation_all_permutations; auto.
Defined.

End permutation.

(**************************************
   Hints
   **************************************)

Global Hint Constructors permutation : core.
Global Hint Resolve permutation_refl : core.
Global Hint Resolve permutation_app_comp : core.
Global Hint Resolve permutation_app_swap : core.

(**************************************
   Implicits
   **************************************)

Arguments permutation [A] _ _.
Arguments split_one [A] _.
Arguments all_permutations [A] _.
Arguments permutation_dec [A].

(**************************************
   Permutation is compatible with map
   **************************************)

Theorem permutation_map :
 forall (A B : Set) (f : A -> B) l1 l2,
 permutation l1 l2 -> permutation (map f l1) (map f l2).
intros A B f l1 l2 H; elim H; simpl in |- *; auto.
intros l0 l3 l4 H0 H1 H2 H3; apply permutation_trans with (2 := H3); auto.
Qed.
Global Hint Resolve permutation_map : core.

(**************************************
  Permutation  of a map can be inverted
  *************************************)

Local Definition permutation_map_ex_aux :
  forall (A B : Set) (f : A -> B) l1 l2 l3,
  permutation l1 l2 ->
  l1 = map f l3 -> exists l4, permutation l4 l3 /\ l2 = map f l4.
intros A1 B1 f l1 l2 l3 H; generalize l3; elim H; clear H l1 l2 l3.
intros l3; case l3; simpl in |- *; auto.
intros H; exists (nil (A:=A1)); auto.
intros; discriminate.
intros a0 l1 l2 H H0 l3; case l3; simpl in |- *; auto.
intros; discriminate.
intros a1 l H1; case (H0 l); auto.
injection H1; auto.
intros l5 (H2, H3); exists (a1 :: l5); split; simpl in |- *; auto.
injection H1; intros; subst; auto.
intros a0 b l l3; case l3.
intros; discriminate.
intros a1 l0; case l0; simpl in |- *.
intros; discriminate.
intros a2 l1 H; exists (a2 :: a1 :: l1); split; simpl in |- *; auto.
injection H; intros; subst; auto.
intros l1 l2 l3 H H0 H1 H2 l0 H3.
case H0 with (1 := H3); auto.
intros l4 (HH1, HH2).
case H2 with (1 := HH2); auto.
intros l5 (HH3, HH4); exists l5; split; auto.
apply permutation_trans with (1 := HH3); auto.
Qed.

Theorem permutation_map_ex :
 forall (A B : Set) (f : A -> B) l1 l2,
 permutation (map f l1) l2 ->
 exists l3, permutation l3 l1 /\ l2 = map f l3.
intros A0 B f l1 l2 H; apply permutation_map_ex_aux with (l1 := map f l1);
 auto.
Qed.

(**************************************
   Permutation is compatible with flat_map
 **************************************)

Theorem permutation_flat_map :
 forall (A B : Set) (f : A -> list B) l1 l2,
 permutation l1 l2 -> permutation (flat_map f l1) (flat_map f l2).
intros A B f l1 l2 H; elim H; simpl in |- *; auto.
intros a b l; auto.
repeat rewrite <- app_ass.
apply permutation_app_comp; auto.
intros k3 l4 l5 H0 H1 H2 H3; apply permutation_trans with (1 := H1); auto.
Qed.


(* Software Foundations *)
(* Exercice 2 stars, hd_opt *)

Inductive natlist: Type:=
|nil: natlist
|cons: nat -> natlist -> natlist.

Notation "[]" := nil.
Notation " x :: l" := (cons x l).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Inductive natoption: Type :=
|Some: nat -> natoption
|None: natoption.

Definition hd_opt(l: natlist): natoption :=
match l with
|nil  => None
|h::_ => Some h
end.

Example test_hd_opt1: hd_opt [] = None.
Proof. reflexivity. Qed.
Example test_hd_opt2: hd_opt [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt3: hd_opt [5;6] = Some 5.
Proof. reflexivity. Qed.


(* vectors *)

Set Nested Proofs Allowed.
Set Implicit Arguments.

Require Import Utf8 Arith.
Import Init.Nat.
Import List List.ListNotations.

Require Import Misc.
Require Import RingLike IterAdd.

Record vector T := mk_vect
  { vect_list : list T }.

Definition vect_size {T} (v : vector T) := length (vect_list v).

Definition vect_el {T} {ro : ring_like_op T} (V : vector T) i :=
  nth (i - 1) (vect_list V) 0%L.

Theorem fold_vect_size {T} : ∀ (V : vector T),
  length (vect_list V) = vect_size V.
Proof. easy. Qed.

Theorem vector_eq : ∀ T {ro : ring_like_op T} (U V : vector T),
  (∀ i, 1 ≤ i ≤ vect_size U → vect_el U i = vect_el V i)
  → vect_size U = vect_size V
  → U = V.
Proof.
intros * Heq Huv.
destruct U as (lu).
destruct V as (lv).
cbn in Heq, Huv; f_equal.
rewrite (List_map_nth_seq _ 0%L); symmetry.
rewrite (List_map_nth_seq _ 0%L); symmetry.
rewrite <- Huv.
apply map_ext_in.
intros i Hi; apply in_seq in Hi.
destruct Hi as (_, Hi); cbn in Hi.
specialize (Heq (S i)).
rewrite Nat_sub_succ_1 in Heq.
apply Heq.
split; [ now apply -> Nat.succ_le_mono | easy ].
Qed.

Section a.

Context {T : Type}.
Context (ro : ring_like_op T).
Context {rp : ring_like_prop T}.

Theorem fold_vect_el : ∀ (V : vector T) i,
  nth i (vect_list V) 0%L = vect_el V (S i).
Proof.
intros.
unfold vect_el.
now rewrite Nat_sub_succ_1.
Qed.

Definition vect_zero n : vector T := mk_vect (repeat 0%L n).

(* addition, subtraction of vector *)

Definition vect_add (U V : vector T) :=
  mk_vect (map2 rngl_add (vect_list U) (vect_list V)).

Definition vect_opp (V : vector T) :=
  mk_vect (map rngl_opp (vect_list V)).

Definition vect_sub (U V : vector T) := vect_add U (vect_opp V).

(* multiplication of a vector by a scalar *)

Definition vect_mul_scal_l s (V : vector T) :=
  mk_vect (map (λ x, (s * x)%L) (vect_list V)).

(* dot product *)

Definition vect_dot_mul (U V : vector T) :=
  ∑ (t ∈ map2 rngl_mul (vect_list U) (vect_list V)), t.
Definition vect_dot_mul' (U V : vector T) :=
  ∑ (i = 1, min (vect_size U) (vect_size V)),
  vect_el U i * vect_el V i.

Theorem vect_dot_mul_dot_mul' :
  rngl_has_opp_or_subt = true →
  ∀ U V,
  vect_dot_mul U V = vect_dot_mul' U V.
Proof.
intros Hos *.
unfold vect_dot_mul, vect_dot_mul'.
destruct U as (lu).
destruct V as (lv).
cbn.
revert lv.
induction lu as [| a]; intros. {
  now cbn; rewrite rngl_summation_empty.
}
destruct lv as [| b]. {
  now cbn; rewrite rngl_summation_empty.
}
cbn - [ nth ].
rewrite rngl_summation_shift with (s := 1). 2: {
  split; [ easy | ].
  now apply -> Nat.succ_le_mono.
}
rewrite Nat.sub_diag, Nat_sub_succ_1.
rewrite rngl_summation_split_first; [ | easy ].
do 2 rewrite List_nth_0_cons.
rewrite rngl_summation_list_cons.
f_equal.
destruct (Nat.eq_dec (length lu) 0) as [Huz| Huz]. {
  rewrite Huz; cbn - [ nth ].
  apply length_zero_iff_nil in Huz; subst lu.
  rewrite rngl_summation_empty; [ | easy ].
  now rewrite map2_nil_l; unfold iter_list.
}
destruct (Nat.eq_dec (length lv) 0) as [Hvz| Hvz]. {
  rewrite Hvz; cbn - [ nth ].
  apply length_zero_iff_nil in Hvz; subst lv.
  rewrite Nat.min_r; [ | easy ].
  rewrite rngl_summation_empty; [ | easy ].
  now rewrite map2_nil_r; unfold iter_list.
}
erewrite rngl_summation_eq_compat. 2: {
  intros i Hi.
  rewrite <- Nat.add_sub_assoc; [ | easy ].
  now do 2 rewrite List_nth_succ_cons.
}
apply IHlu.
Qed.

Definition vect_squ_norm (V : vector T) := vect_dot_mul V V.

Declare Scope V_scope.
Delimit Scope V_scope with V.

Arguments vect_dot_mul (U V)%V.
Arguments vector_eq {T}%type {ro} (U V)%V.

Notation "μ × V" := (vect_mul_scal_l μ V) (at level 40) : V_scope.
Notation "≺ U , V ≻" := (vect_dot_mul U V) (at level 35).
Notation "μ × V" := (vect_mul_scal_l μ V) (at level 40) : V_scope.

Arguments vect_el {T}%type {ro} V%V i%nat.
Arguments vect_size {T}%type v%V.

Theorem vect_mul_scal_l_mul_assoc : ∀ (a b : T) (V : vector T),
  (a × (b × V))%V = ((a * b)%L × V)%V.
Proof.
intros.
unfold vect_mul_scal_l.
f_equal; cbn.
rewrite map_map.
apply map_ext_in.
intros x Hx.
apply rngl_mul_assoc.
Qed.

Theorem vect_mul_scal_reg_r :
  rngl_has_inv_or_quot = true →
  rngl_has_eqb = true →
  ∀ (V : vector T) a b,
  V ≠ vect_zero (vect_size V)
  → (a × V = b × V)%V
  → a = b.
Proof.
intros Hii Heq * Hvz Habv.
unfold vect_mul_scal_l in Habv.
injection Habv; clear Habv; intros Habv.
specialize (ext_in_map Habv) as H1.
cbn in H1.
remember (rngl_eqb a b) as ab eqn:Hab; symmetry in Hab.
destruct ab; [ now apply rngl_eqb_eq | ].
apply (rngl_eqb_neq Heq) in Hab.
exfalso; apply Hvz; clear Hvz.
apply vector_eq; [ | now cbn; rewrite repeat_length ].
intros i Hi; cbn.
rewrite nth_repeat.
specialize (H1 (vect_el V i)) as H2.
assert (H : vect_el V i ∈ vect_list V). {
  unfold vect_el.
  apply nth_In.
  rewrite fold_vect_size.
  now apply Nat_1_le_sub_lt.
}
specialize (H2 H); clear H.
remember (rngl_eqb (vect_el V i) 0%L) as vz eqn:Hvz; symmetry in Hvz.
destruct vz; [ now apply rngl_eqb_eq | ].
apply (rngl_eqb_neq Heq) in Hvz.
now apply rngl_mul_cancel_r in H2.
Qed.

Theorem vect_mul_scal_size : ∀ a V, vect_size (a × V) = vect_size V.
Proof. now intros; cbn; rewrite map_length. Qed.

Theorem vect_dot_mul_scal_mul_comm :
  rngl_has_opp_or_subt = true →
  rngl_mul_is_comm = true →
  ∀ (a : T) (U V : vector T),
  ≺ U, a × V ≻ = (a * ≺ U, V ≻)%L.
Proof.
intros Hom Hic *.
unfold vect_dot_mul.
rewrite rngl_mul_summation_list_distr_l; [ | easy ].
unfold "×"; cbn.
unfold iter_list.
rewrite map2_map_r.
rewrite List_fold_left_map2.
rewrite List_fold_left_map2.
apply List_fold_left_ext_in.
intros * Hb.
f_equal.
do 2 rewrite rngl_mul_assoc.
f_equal.
now apply rngl_mul_comm.
Qed.

Theorem vect_scal_mul_dot_mul_comm :
  rngl_has_opp_or_subt = true →
  ∀ (a : T) (U V : vector T),
  ≺ a × U, V ≻ = (a * ≺ U, V ≻)%L.
Proof.
intros Hom *.
unfold vect_dot_mul; cbn.
rewrite rngl_mul_summation_list_distr_l; [ | easy ].
unfold "×"; cbn.
unfold iter_list.
rewrite map2_map_l.
rewrite List_fold_left_map2.
rewrite List_fold_left_map2.
apply List_fold_left_ext_in.
intros * Hb.
f_equal; symmetry.
apply rngl_mul_assoc.
Qed.

Theorem vect_eq_dec :
  rngl_has_eqb = true →
  ∀ (U V : vector T), {U = V} + {U ≠ V}.
Proof.
intros Heq *.
destruct U as (lu).
destruct V as (lv).
remember (list_eqv rngl_eqb lu lv) as uv eqn:Huv.
symmetry in Huv.
destruct uv. {
  left; f_equal.
  apply list_eqb_eq in Huv; [ easy | ].
  unfold equality.
  apply (rngl_eqb_eq Heq).
} {
  right; f_equal.
  apply list_eqb_neq in Huv. {
    intros H; apply Huv; clear Huv.
    now injection H.
  }
  unfold equality.
  apply (rngl_eqb_eq Heq).
}
Qed.

End a.

Declare Scope V_scope.
Delimit Scope V_scope with V.

Arguments vect_add {T}%type {ro} (U V)%V.
Arguments vect_sub {T ro} U%V V%V.
Arguments vect_opp {T ro} V%V.
Arguments vect_mul_scal_l {T ro} s%L V%V.
Arguments vect_mul_scal_reg_r {T}%type {ro rp} Hde Hii V%V (a b)%L.
Arguments vect_zero {T ro} n%nat.
Arguments vect_dot_mul {T}%type {ro} (U V)%V.
Arguments vect_dot_mul' {T}%type {ro} (U V)%V.
Arguments vect_dot_mul_dot_mul' {T}%type {ro rp} Hop (U V)%V.
Arguments vect_dot_mul_scal_mul_comm {T}%type {ro rp} Hom Hic a%L (U V)%V.
Arguments vect_scal_mul_dot_mul_comm {T}%type {ro rp} Hom a%L (U V)%V.
Arguments vect_eq_dec {T}%type {ro rp} Hde U%V V%V.
Arguments vect_el {T}%type {ro} V%V i%nat.
Arguments vect_size {T}%type v%V.
Arguments vect_squ_norm {T}%type {ro} V%V.
Arguments vector_eq {T}%type {ro} (U V)%V.

Notation "U + V" := (vect_add U V) : V_scope.
Notation "U - V" := (vect_sub U V) : V_scope.
Notation "μ × V" := (vect_mul_scal_l μ V) (at level 40) : V_scope.
Notation "≺ U , V ≻" := (vect_dot_mul U V) (at level 35).
Notation "- V" := (vect_opp V) : V_scope.


(* ================================================================== *)
(* ==================== Programming and proving ===================== *)
(* ================================================================== *)

Require Import ZArith.

Require Import List.

Set Implicit Arguments.

Fixpoint elem (a:Z) (l:list Z) {struct l} : bool :=   (* !!!!!!!!!!! *)
    match l with
      | nil => false
      | cons x xs => if Z.eq_dec x a then true else (elem a xs)
    end.

Proposition elem_corr : forall (a:Z) (l1 l2:list Z),
                  elem a (app l1 l2) = orb (elem a l1) (elem a l2).
Proof.
  induction l1.
  - intros. simpl. reflexivity.
  - intros. simpl.
    elim (Z.eq_dec a0 a).
    +  SearchAbout orb.
      rewrite Bool.orb_true_l.
      trivial.
    + auto.
Qed.

(* Exercise: *)
Lemma ex : forall (a:Z) (l1 l2:list Z), elem a (app l1 (cons a l2)) = true.
Proof.
  intros. rewrite elem_corr.
 SearchAbout "orb".
  apply Bool.orb_true_iff. right. simpl.
  elim (Z.eq_dec a a); auto.
Qed.

(* ================================================================== *)
(* ======================== Partiality ============================== *)

(* defining the function head *)

Definition head (A:Type) (l:list A) : l<>nil -> A.
(* "refine term" tactic applies to any goal. It behaves like exact with
a big difference: the user can leave some holes (denoted by _ or (_:type))
in the term.
refine will generate as many subgoals as there are holes in the term. *)
  refine (
  match l as l' return l'<>nil -> A with
  | nil => fun H => _
  | cons x xs => fun H => x
  end ).
  elimtype False.         (* cut False; intro H1; elim H1; clear H1. *)
  apply H; reflexivity.  (* elim H. reflexivity. *)
Defined.

Print  head.
Print Implicit head.

(* head precondition *)
Definition headPre (A:Type) (l:list A) : Prop := l<>nil.

(* the specification of head *)
Inductive headRel (A:Type) (x:A) : list A -> Prop :=
  headIntro : forall l, headRel x (cons x l).

Print Implicit headRel.

(* we can prove the correctness of head w.r.t. its specification *)
Lemma head_correct : forall (A:Type) (l:list A) (p:headPre l), headRel (head  p) l.
Proof.
  destruct l.
  - intro H; elim H; reflexivity.
  - intros;  destruct l; [simpl; constructor | simpl; constructor].
    (* change de proof script so that you can see effect each tactic *)
Qed.

Print head.
Check head.

(* ================================================================== *)
(* ==================== Program Extraction ========================== *)

Require Extraction.  (* the extraction framework must be loaded explicitly *)

(* we can convert to Haskell the function head defined *)
Extraction Language Haskell.

Extraction head.

Extraction False_rect.
Extraction Inline False_rect.  (* will make the code more readable *)
Extraction head.

Recursive Extraction head.
Extraction "exemplo1" head.

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

Recursive Extraction head.
Extraction "exemplo2" head.

(* We have just followed the "weak specification" approach:
   we defined the function and add, as a companion lemma, that the function
   satisfies its specification.
*)

(* ================================================================== *)

(* Instead of this approach, we can give a "strong specification" of a
   function  (using specification types), and extract the function from
   its proof (the prove that the specification is inhabited).
*)

(* An inductive relation "x is the last element of list l" *)
Inductive Last (A:Type) (x:A) : list A -> Prop :=
| last_base : Last x (cons x nil)
| last_step : forall l y, Last x l -> Last x (cons y l).

Theorem last_correct : forall (A:Type) (l:list A), l<>nil -> { x:A | Last x l }.
Proof.
  induction l.
  - intro H. elim H. reflexivity.
  - intros. destruct l.
    + exists a. constructor.
    + elim IHl.
      * intros. exists x. constructor. assumption.
      * discriminate.
Qed.

Recursive Extraction last_correct.

Extraction Inline False_rect.
Extraction Inline sig_rect.
Extraction Inline list_rect.

Recursive Extraction last_correct.

(* ================================================================== *)

(* Following this alternative approach we can give a "strong specification" of
   function head (using specification types), and extract the function from
   its proof (the prove that the specification is inhabited).
*)

(* Exercise: built an alternative definition of function head called “head corr”
   based on the strong specification mechanism *)

(* ================================================================== *)
(* ======================= Sorting a list =========================== *)

Open Scope Z_scope.

Inductive Sorted : list Z -> Prop :=
  | sorted0 : Sorted nil
  | sorted1 : forall z:Z, Sorted (z :: nil)
  | sorted2 : forall (z1 z2:Z) (l:list Z),
        z1 <= z2 -> Sorted (z2 :: l) -> Sorted (z1 :: z2 :: l).

Fixpoint count (z:Z) (l:list Z) {struct l} : nat :=
  match l with
  | nil => 0%nat     (* %nat to force the interpretation in nat, since have we open Z_scope *)
  | (z' :: l') =>
      match Z.eq_dec z z' with
      | left _ => S (count z l')
      | right _ => count z l'
      end
  end.

Definition Perm (l1 l2:list Z) : Prop :=
                                 forall z, count z l1 = count z l2.

(*
 Exercise: prove that Perm is an equivalence relation (i.e. is reflexive, symmetric and transitive)
*)

Lemma Perm_reflex : forall l:list Z, Perm l l.
Proof.
  unfold Perm.
  intros.
  reflexivity.
Qed.

Lemma Perm_sym : forall l1 l2, Perm l1 l2 -> Perm l2 l1.
Proof.
  unfold Perm.
  intros.
  symmetry.
  generalize z.
  assumption.
Qed.

Lemma Perm_trans : forall l1 l2 l3, Perm l1 l2 -> Perm l2 l3 -> Perm l1 l3.
Proof.
  unfold Perm.
  induction l1.
  intros.
  - rewrite H. apply H0.
  - intros. rewrite H. apply H0.
Qed.

(*  Exercise: prove the following lemmas: *)

Lemma Perm_cons : forall a l1 l2, Perm l1 l2 -> Perm (a::l1) (a::l2).
Proof.
  unfold Perm.
  intros.
  simpl.
  elim Z.eq_dec.
    - rewrite H. trivial.
    - intros. generalize z. apply H.
Qed.

Lemma Perm_cons_cons : forall x y l, Perm (x::y::l) (y::x::l).
Proof.
  unfold Perm.
  intros.
  simpl.
  elim  Z.eq_dec.
  - intros. elim Z.eq_dec.
    + trivial.
    + trivial.
  - elim  Z.eq_dec.
    + trivial.
    + trivial.
Qed.

Fixpoint insert (x:Z) (l:list Z) {struct l} : list Z :=
  match l with
    nil => cons x (@nil Z)
  | cons h t =>
        match Z_lt_ge_dec x h with
          left _ => cons x (cons h t)
        | right _ => cons h (insert x t)
        end
  end.

Fixpoint isort (l:list Z) : list Z :=
  match l with
    nil => nil
  | cons h t => insert h (isort t)
  end.

Print isort.

(* some  usefull lemmas about count *)

Lemma count_insert_eq : forall x l,
                       count x (insert x l) = S (count x l).
Proof.
  induction l.
  - simpl. destruct (Z.eq_dec x x).
    + reflexivity.
    + destruct n. reflexivity.
  - simpl insert. destruct (Z_lt_ge_dec x a).
    + simpl. destruct (Z.eq_dec x x).
      * reflexivity.
      * easy.
    + simpl. destruct (Z.eq_dec x a).
      * rewrite IHl. reflexivity.
      * assumption.
Qed.

Lemma count_cons_diff : forall z x l, z <> x -> count z l = count z  (x :: l).
Proof.
  intros. induction l.
  - simpl. destruct (Z.eq_dec z x); easy.
  - simpl. destruct (Z.eq_dec z a).
    + destruct (Z.eq_dec z x); easy.
    + destruct (Z.eq_dec z x); easy.
Qed.

Lemma count_insert_diff : forall z x l, z <> x -> count z l = count z (insert x l).
Proof.
  intros. induction l.
  - simpl. destruct (Z.eq_dec z x); easy.
  - simpl insert. destruct (Z_lt_ge_dec x a).
    + simpl. destruct (Z.eq_dec z x); try easy.
    + simpl. destruct (Z.eq_dec z a); try easy.
      apply f_equal. apply IHl.
Qed.

(* the two auxiliary lemmas *)

Lemma insert_Perm : forall x l, Perm (x::l) (insert x l).
Proof.
  unfold Perm; induction l.
 - simpl. reflexivity.
 - simpl insert. destruct (Z_lt_ge_dec x a).
   + reflexivity.
   + intros. rewrite Perm_cons_cons.
     destruct (Z.eq_dec z a).
     * simpl. destruct (Z.eq_dec z a).
       -- destruct (Z.eq_dec z x).
          ++ apply f_equal. rewrite e1. rewrite count_insert_eq. reflexivity.
          ++ apply f_equal. apply count_insert_diff. assumption.
       -- destruct (Z.eq_dec z x).
          ++ destruct n. assumption.
          ++ destruct n. assumption.
     * simpl. destruct (Z.eq_dec z a).
       -- destruct (Z.eq_dec z x); easy.
       -- destruct (Z.eq_dec z x).
          ++ rewrite e. rewrite count_insert_eq. reflexivity.
          ++ rewrite <- count_insert_diff; [reflexivity|assumption].
Qed.

Lemma insert_Sorted : forall x l, Sorted l -> Sorted (insert x l).
Proof.
  - intros x l H; elim H; simpl.
    + constructor.
    + intro z; elim (Z_lt_ge_dec x z); intros.
      * constructor.
        auto with zarith. constructor.
      * constructor.
        -- auto with zarith.
        -- constructor.
    + intros z1 z2 l0 H0 H1.
      elim (Z_lt_ge_dec x z2); elim (Z_lt_ge_dec x z1).
      * intros. constructor.
        -- omega. (* auto with zarith.*)
        -- constructor.
           ++ omega.
           ++ assumption.
      * intros. constructor.
        -- omega.
        -- assumption.
      * intros. constructor.
        -- omega.
        -- constructor; [omega|assumption].
      * intros. constructor; [omega|assumption].
Qed.

(* the proof that isort is correct *)
Theorem isort_correct : forall (l l':list Z), l'=isort l -> Perm l l' /\ Sorted l'.
Proof.
  induction l; intros.
  - unfold Perm; rewrite H; split; auto. simpl. constructor.
  - simpl in H.
    rewrite H. (* ??????????? *)
    elim (IHl (isort l)); intros; split.
    + apply Perm_trans with (a::isort l).
      * unfold Perm. intro z. simpl. elim (Z.eq_dec z a).
        -- intros. elim H0; reflexivity.   (* auto with zarith. *)
        -- auto with zarith.   (* intros. elim H0. reflexivity. *)
      * apply insert_Perm.
    + apply insert_Sorted. assumption.
Qed.

(* EXTRACTION *)
(* using specification types *)
Definition inssort : forall (l:list Z), { l' | Perm l l' & Sorted l' }.
Proof.
  induction l.
  - exists nil. constructor. constructor.
  - elim IHl. intros. exists (insert a x).
(* FILL IN HERE *)
    + apply Perm_trans with (a::x).
      * apply Perm_cons. assumption.
      * apply insert_Perm.
    + apply insert_Sorted. assumption.
Defined.

Extraction Language Haskell.
Recursive Extraction inssort.

Extraction Inline list_rec.
Extraction Inline list_rect.
Extraction Inline sig2_rec.
Extraction Inline sig2_rect.

Extraction inssort.
Recursive Extraction inssort.
Extraction "exemplo4"inssort.

(* ================================================================== *)
(* =================== Non-structural recursion ===================== *)

Close Scope Z_scope.

Require Import Recdef. (* because of Function *)

Function div (p:nat*nat) {measure fst} : nat*nat :=
  match p with
  | (_,0) => (0,0)
  | (a,b) => if le_lt_dec b a
             then let (x,y):=div (a-b,b) in (1+x,y)
             else (0,a)
  end.
Proof.
 intros. simpl. omega.
Qed.

(* Exercise  *)
Function merge (p:list Z*list Z)
{measure (fun p=>(length (fst p))+(length (snd p)))} : list Z :=
  match p with
  | (nil,l) => l
  | (l,nil) => l
  | (x::xs,y::ys) => if Z_lt_ge_dec x y
                     then x::(merge (xs,y::ys))
                     else y::(merge (x::xs,ys))
  end.
  Admitted.

Theorem merge_correct_sorted : forall l1 l2 :list Z, Sorted l1 /\ Sorted l2 -> Sorted (merge(l1, l2)).
  Admitted.

Theorem merge_correct_permuted : forall l1 l2:list Z, Perm (l1++l2) (merge (l1 ,l2)).
  Admitted.

(* ========== Euclidean division correction =========== *)

Definition divRel (args:nat*nat) (res:nat*nat) : Prop :=
          let (n,d):=args in let (q,r):=res in q*d+r=n /\ r<d.

Definition divPre (args:nat*nat) : Prop := (snd args)<>0.

Theorem div_correct : forall (p:nat*nat),  divPre p -> divRel p (div p).
Proof.
  unfold divPre, divRel.
  intro p.
  (* we make use of the specialised induction principle to conduct the proof... *)
  functional induction (div p); simpl.
  - intro H; elim H; reflexivity.
  - (* a first trick: we expand (div (a-b,b)) in order to get rid of the let (q,r)=... *)
    replace (div (a-b,b)) with (fst (div (a-b,b)),snd (div (a-b,b))) in IHp0.
    + simpl in *. intro H; elim (IHp0 H); intros. split.
      * (* again a similar trick: we expand "x" and "y0" in order to use an hypothesis *)
        change (b + (fst (x,y0)) * b + (snd (x,y0)) = a).
        rewrite <- e1. omega.
      * (* and again... *)
        change (snd (x,y0)<b); rewrite <- e1; assumption.
    + symmetry; apply surjective_pairing.
  - auto.
Qed.

(* Exercício 4.3 (a)*)

Print length.

Lemma correct_ln : forall l:list Z, {x : nat | length l = x}.
  Proof.
  intros. induction l.
  - simpl. exists 0. reflexivity.
  - simpl. inversion IHl. exists (S x). rewrite H. reflexivity.
  Qed.

Extraction "length" correct_ln.

(* Exercício 4.3 (b)*)

Function sum_pair (l:list (nat*nat)) : nat :=
  match l with
  | nil => 0
  | (_,y)::t => y + sum_pair t
  end.

Lemma correct_sum_pair : forall l:list (nat*nat), {x : nat | sum_pair l = x}.
  Proof.
  intros.
  induction l.
    - exists 0. simpl. auto.
    - simpl. inversion IHl. elim a. intros. exists (b+x). auto.
  Qed.

Recursive Extraction correct_sum_pair.

Extraction Inline prod_rec.
Extraction Inline prod_rect.
Extraction "sum_pair" correct_sum_pair.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Export Cbase.
Require Import Omega.

Open Scope C_scope.

(** * Power definition on C *)

Fixpoint Cpow (z : C) (n : nat) {struct n} : C  :=
match n with
| 0%nat => 1
| S m => z * (Cpow z m)
end.

Infix "^" := Cpow : C_scope.

(** Rewrite lemmas on Cpow *)

Lemma Cpow_0 : forall z, z ^ 0 = 1.
Proof.
auto with complex.
Qed.

Lemma C0_pow : forall n, (0 < n)%nat -> 0 ^ n = 0.
Proof.
intros n n_lb ; induction n.
 inversion n_lb.
 simpl.
 destruct (0 ^ n) ; CusingR_f.
Qed.

Lemma Cpow_S : forall (z : C) (n : nat), z ^ (S n) = z ^ n * z.
Proof.
intros. simpl. intuition.
Qed.

Lemma Cpow_add : forall (z : C) (n m : nat), z ^ (n + m) = z ^ n * z ^ m.
Proof.
intros z n m.
induction n.
 auto with complex.
 replace (z ^ (S n + m)%nat) with (z * z ^ (n+m)%nat).
  rewrite IHn. replace (z ^ S n) with (z * (z ^ n)).
   auto with complex.
  destruct n ; simpl ; auto with complex.
 replace (S n + m)%nat with (S (n + m))%nat.
  destruct n; destruct m ; simpl ; auto with complex.
  simpl ; reflexivity.
Qed.

Lemma Cpow_mul : forall z n m, z ^ (n * m) = (z ^ n) ^ m.
Proof.
intros z n m ; induction m.
 rewrite mult_0_r ; reflexivity.
 simpl ; rewrite <- IHm ; rewrite <- Cpow_add ;
 replace (n * S m)%nat with (n + n * m)%nat by ring ; reflexivity.
Qed.

Lemma Cpow_mul_distr_l : forall z1 z2 n, (z1 * z2) ^ n = z1 ^ n * z2 ^ n.
Proof.
intros z1 z2 n; induction n.
  simpl; CusingR_f.
  repeat rewrite Cpow_S; rewrite IHn.
  rewrite Cmult_assoc.
  rewrite <- (Cmult_assoc (z2 ^ n) z1 z2).
  rewrite (Cmult_comm (z2 ^ n) z1).
  repeat rewrite Cmult_assoc.
  reflexivity.
Qed.

Lemma IRC_pow_compat : forall x n, IRC x ^ n = IRC (x ^ n).
Proof.
intros x n ; induction n.
 reflexivity.
 simpl ; rewrite IHn.
 CusingR_f.
Qed.


Require Import Arith.
Require Import List.
Require Import ListSet.

Inductive Ty : Set :=
| Bas : nat -> Ty
| Arr : Ty -> Ty -> Ty.
Notation "T ⇒ S" := (Arr T S) (at level 30, right associativity).

Inductive Term : Set :=
| v : nat -> Term
| ƛ : Ty -> Term -> Term
| app : Term -> Term -> Term.
Notation "t · s" := (app t s) (at level 20, left associativity).

Fixpoint Free (n : nat) (A : Set) : Set :=
  match n with
    | O => A
    | S n' => Term -> Free n' A
  end.

Notation "[]" := nil.
Notation "[ x ]" := (cons x nil).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) .. ).

Fixpoint idx (A : Set) (n : nat) (G : list A) : option A :=
  match G with
    | [] => None
    | (x::t) => match n with
                  | O => Some x
                  | S n' => idx A n' t
                end
  end.
Implicit Arguments idx [A].

Definition Ctx := list Ty.

(* Note : is \colon, using TeX mode, and not : *)
Reserved Notation "Γ ⊢ t @ A" (at level 70, no associativity).
Inductive Derivation : Ctx -> Term -> Ty -> Set :=
| VarIntro : forall Γ n A,
  idx n Γ = Some A ->
  Γ ⊢ (v n) @ A
| ImpIntro : forall Γ t A B,
  A::Γ ⊢ t @ B ->
  Γ ⊢ ƛ A t @ A ⇒ B
| ImpElim : forall Γ f t A B,
  Γ ⊢ f @ A ⇒ B ->
  Γ ⊢ t @ A ->
  Γ ⊢ f · t @ B
 where "Γ ⊢ r @ A " := (Derivation Γ r A) : type_scope.

Hint Constructors Derivation : derivation.

Fixpoint shiftat (d : nat) (x : Term) {struct x} : Term :=
  match x with
    | v m => if le_lt_dec d m then v (S m) else v m
    | ƛ A t => ƛ A (shiftat (S d) t)
    | r · s => (shiftat d r) · (shiftat d s)
  end.
Definition shift := shiftat 0.

Definition sub : forall (t : Term) (n : nat) (u : Term), Term.
Proof.
  refine
    (fix sub (t : Term) (n : nat) (u : Term) :=
      match t with
        | v m => match le_lt_dec n m with
                   | left p =>
                     match eq_nat_dec n m with
                       | left _ => u
                       | right p' =>
                         (match m as m' return (m = m' -> Term) with
                            | 0 => (fun p'' => False_rec _ _ )
                            | S m' => (fun _ => v m')
                          end) (refl_equal m)
                     end
                   | right _ => v m
                 end
        | ƛ A t => ƛ A (sub t (S n) (shift u))
        | r · s => (sub r n u) · (sub s n u)
      end) ; subst ; auto.
  destruct n. apply le_n_O_eq in p. apply p'. reflexivity.
  inversion p.
Defined.

Inductive Ev : Term -> Term -> Prop :=
| ev_app : forall r s t, Ev r s -> Ev (r · t) (s · t)
| ev_beta : forall r s A, Ev ((ƛ A r) · s) (sub r 0 s).

Inductive Value : Term -> Prop :=
| Value_lam : forall A r, Value (ƛ A r).

Require Import Relations.

Notation "r ↝ s" := (Ev r s) (at level 40, no associativity).
Definition Evplus := clos_trans Term Ev.
Notation "r ↝⁺ s" := (Evplus r s) (at level 40, no associativity).
Definition Evstar := clos_refl_trans Term Ev.
Notation "r ↝* s" := (Evstar r s) (at level 40, no associativity).
Notation "r ⇓ s" := (r ↝* s /\ Value s) (at level 40, no associativity).
Notation "t ⇓" := (exists s, t ⇓ s) (at level 40, no associativity).


Require Import String.
Require Import Ascii.
Require Import NArith.

(* Binary numbers. The operations assume little-endianness,
   but this can also be used as a big-endian representation. *)
Inductive binary : Type :=
| b0 : binary -> binary
| b1 : binary -> binary
| b_ : binary (* End *)
.

Fixpoint zeroes (d : nat) : binary :=
  match d with
  | O => b_
  | S d => b0 (zeroes d)
  end.

Fixpoint positive_to_binary (d : nat) (n : positive) :=
  match n, d with
  | xI n, S d => b1 (positive_to_binary d n)
  | xO n, S d => b0 (positive_to_binary d n)
  | xH, _ => b1 (zeroes d)
  | _, O => b_
  end.

Definition N_to_binary (d : nat) (n : N) :=
  match n with
  | N0 => zeroes d
  | Npos n => positive_to_binary d n
  end.

Fixpoint binary_to_N (z : binary) :=
  match z with
  | b_ => 0%N
  | b1 z => N.succ_double (binary_to_N z)
  | b0 z => N.double (binary_to_N z)
  end.

Example binary_from_to : (binary_to_N (N_to_binary 64 10) = 10)%N.
Proof. reflexivity. Qed.

Fixpoint length_binary (z : binary) : nat :=
  match z with
  | b0 z | b1 z => S (length_binary z)
  | b_ => O
  end.

Fixpoint rev' (y z : binary) : binary :=
  match z with
  | b0 z => rev' (b0 y) z
  | b1 z => rev' (b1 y) z
  | b_ => y
  end.

(* big-endian <-> little-endian *)
Definition rev : binary -> binary := rev' b_.

(* Bitwise xor. The second operand is
   extended/truncated to the length of the first one. *)
Fixpoint xor (z1 z2 : binary) :=
  match z1, z2 with
  | b0 z1, b0 z2 | b1 z1, b1 z2 => b0 (xor z1 z2)
  | b0 z1, b1 z2 | b1 z1, b0 z2 => b1 (xor z1 z2)
  | _, _ => z1
  end.

Lemma xor_length :
  forall z1 z2, length_binary (xor z1 z2) = length_binary z1.
Proof.
  induction z1; destruct z2; simpl; try f_equal; auto.
Qed.

Fixpoint shiftr (n : nat) (z : binary) :=
  match n, z with
  | S n, (b0 z | b1 z) => shiftr n z
  | _, _ => z
  end.

Example shiftr_test :
  shiftr 3 (N_to_binary 10 30) = (N_to_binary 7 3%N).
Proof. reflexivity. Qed.

Lemma shiftr_length :
  forall n z, length_binary (shiftr n z) = length_binary z - n.
Proof.
  induction n; destruct z; simpl; auto.
Qed.

(* [z ^ (z >>> n)]*)
Definition shift_xor z (n : nat) :=
  xor z (shiftr n z).

Inductive bit := zero | one.

Definition of_bit (a : bit) : binary -> binary :=
  match a with
  | zero => b0
  | one => b1
  end.

Definition of_bool (a : bool) : binary -> binary :=
  match a with
  | false => b0
  | true => b1
  end.

Fixpoint succ (z : binary) : binary :=
  match z with
  | b1 z => b0 (succ z)
  | _ => z
  end.

Definition succ_length :
  forall z, length_binary (succ z) = length_binary z.
Proof.
  induction z; simpl; auto.
Qed.

(* Add two numbers with carry. The result is truncated to the
   length of the first operand. *)
Fixpoint plus' (c : bit) (z1 z2 : binary) :=
  match z1, z2 with
  | b0 z1, b0 z2 => of_bit c (plus' zero z1 z2)
  | b1 z1, b0 z2 | b0 z1, b1 z2 =>
    match c with
    | zero => b1 (plus' zero z1 z2)
    | one => b0 (plus' one z1 z2)
    end
  | b1 z1, b1 z2 =>
    of_bit c (plus' one z1 z2)
  | _, _ => succ z1
  end.

Lemma plus'_length :
  forall z1 z2 c, length_binary (plus' c z1 z2) = length_binary z1.
Proof.
  induction z1; destruct z2; destruct c; simpl; auto using succ_length.
Qed.

Definition plus : binary -> binary -> binary := plus' zero.

Example plus_test :
  plus (N_to_binary 10 3) (N_to_binary 5 5) = N_to_binary 10 8.
Proof. reflexivity. Qed.

Lemma plus_length :
  forall z1 z2, length_binary (plus z1 z2) = length_binary z1.
Proof.
  intros; apply plus'_length.
Qed.

Fixpoint mul (z1 z2 : binary) :=
  match z1 with
  | b0 z1 => b0 (mul z1 z2)
  | b1 z1 => plus (b0 (mul z1 z2)) z2
  | b_ => b_
  end.

Example mul_test :
  mul (N_to_binary 10 3) (N_to_binary 5 5) = N_to_binary 10 15.
Proof. reflexivity. Qed.

Lemma mul_length :
  forall z1 z2, length_binary (mul z1 z2) = length_binary z1.
Proof.
  induction z1; intro z2; simpl; auto.
  rewrite plus_length; simpl; auto.
Qed.

Fixpoint popcount_under (n : nat) (z : binary) : bool :=
  match z, n with
  | b1 _, O => false
  | b1 z, S n => popcount_under n z
  | b0 z, _ => popcount_under n z
  | b_, _ => true
  end.

Fixpoint hex' (acc : binary) (s : string) : binary :=
  match s with
  | EmptyString => acc
  | String x s =>
    let acc :=
        match x with
        (* Digit *)
        | Ascii a0 a1 a2 a3 _ _ false _ =>
          of_bool a0 (of_bool a1 (of_bool a2 (of_bool a3 acc)))
        | "a" => b0 (b1 (b0 (b1 acc)))
        | "b" => b1 (b1 (b0 (b1 acc)))
        | "c" => b0 (b0 (b1 (b1 acc)))
        | "d" => b1 (b0 (b1 (b1 acc)))
        | "e" => b0 (b1 (b1 (b1 acc)))
        | "f" => b1 (b1 (b1 (b1 acc)))
        | _ => b0 (b0 (b0 (b0 acc)))
        end%char in
    hex' acc s
  end.

Definition hex : string -> binary := hex' b_.

(* Compute hex "123". *)

Definition golden_gamma : binary :=
  Eval compute in hex "9e3779b97f4a7c15".

Definition c1 : binary :=
  Eval compute in hex "ff51afd7ed558ccd".
Definition c2 : binary :=
  Eval compute in hex "c4ceb9fe1a85ec53".

Definition mix64 z :=
  let z := mul c1 (shift_xor z 33) in
  let z := mul c2 (shift_xor z 33) in
  shift_xor z 33.

Definition c3 : binary :=
  Eval compute in hex "bf58476d1ce4e5b9".
Definition c4 : binary :=
  Eval compute in hex "94d049bb133111eb".

Definition mix64variant13 z :=
  let z := mul c3 (shift_xor z 30) in
  let z := mul c4 (shift_xor z 27) in
  shift_xor z 31.

Definition set_lsb z :=
  match z with
  | b0 z => b1 z
  | _ => z
  end.

Definition c5 : binary :=
  Eval compute in hex "aaaaaaaaaaaaaaaa".

Definition mix_gamma z :=
  let z := set_lsb (mix64 z) in
  if popcount_under 24 (shift_xor z 1) then
    xor z c5
  else
    z.

Definition N64 := binary.

Record State := MkState {
  seed : N64;
  gamma : N64;
  counter : N64; (* big-endian *)
  remaining : nat;
}.

Definition split '(MkState s0 g c r) : State * State :=
  match r with
  | S r =>
    let new bx := MkState s0 g (bx c) r in
    (new b0, new b1)
  | O =>
    (* [b0 c = 2 * c], SplitMix's splitting increments the
       counter by 2. *)
    let s1 := plus s0 (mul g (b0 (rev c))) in
    let s2 := plus s1 g in
    let s' := mix64variant13 s1 in
    let g' := mix_gamma s2 in
    let new bx := MkState s' g' (bx b_) 63 in
    (new b0, new b1)
  end.

(* Probably overkill if you just need a few bits. *)
Definition to_binary '(MkState s0 g c r) : binary :=
  let s1 := plus s0 (mul g (b0 (rev c))) in
  mix64variant13 s1.

Definition of_seed n : State :=
  {| seed := N_to_binary 64 n;
     gamma := golden_gamma;
     counter := b_;
     remaining := 64 |}.

Section Ex.

Import NArith.

Fixpoint split_many2 (n : nat) g :=
  match n with
  | O => g
  | S n' => let (_, g) := split g in split_many2 n' g
  end.

End Ex.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Basic_Cons.Equalizer.
Require Import Coq_Cats.Type_Cat.Type_Cat.

Local Obligation Tactic := idtac.

(** Just like in category of sets, in category of types, the equalizer is the type
that reperesents the subset of the cartesian profuct of the domain of the two functions
that is mapped to equal values by both functions. *)
Section Equalizer.
  Context {A B : Type} (f g : A → B).

  Program Definition Type_Cat_Eq : Equalizer Type_Cat f g :=
    {|
      equalizer := {x : A | f x = g x};
      equalizer_morph := @proj1_sig _ _;
      equalizer_morph_ex :=
        fun T eqm H x =>
          exist _ (eqm x) _
    |}.

  Next Obligation.
  Proof.
    extensionality x; destruct x as [x Px]; trivial.
  Qed.

  Next Obligation.
  Proof.
    intros T eqm H x.
    apply (fun w => equal_f w x) in H; trivial.
  Qed.

  Next Obligation.
  Proof.
    trivial.
  Qed.

  Next Obligation.
  Proof.
    intros T eqm H1 u u' H2 H3.
    extensionality x.
    apply (fun w => equal_f w x) in H2; cbn in H2.
    apply (fun w => equal_f w x) in H3; cbn in H3.
    destruct (u x) as [ux e]; destruct (u' x) as [ux' e']; cbn in *.
    destruct H2; destruct H3.
    PIR.
    trivial.
  Qed.

End Equalizer.

(** Similar to the category set, in category of types, the coequalizer of two functions
f,g : A -> B is quotient of B with respect to the equivalence relation ~. Here, ~
is the equivalence closure of the relation for which we have

x ~ y if and only if ∃z. (f(z) = x) ∧ (g(z) = y)

*)

Program Instance Type_Cat_Has_Equalizers : Has_Equalizers Type_Cat := fun _ _ => Type_Cat_Eq.

Require Import Coq.Relations.Relations Coq.Relations.Relation_Definitions.
Require Import Coq.Logic.ClassicalChoice Coq.Logic.ChoiceFacts.
Require Coq.Logic.ClassicalFacts.

Section CoEqualizer.
  Context {A B : Type} (f g : A → B).

  Local Obligation Tactic := idtac.

  Definition CoEq_rel_base : relation B := fun x y => exists z, f z = x ∧ g z = y.

  Definition CoEq_rel : relation B := clos_refl_sym_trans _ CoEq_rel_base.

  Definition CoEq_rel_refl := equiv_refl _ _ (clos_rst_is_equiv _ CoEq_rel_base).
  Definition CoEq_rel_sym := equiv_sym _ _ (clos_rst_is_equiv _ CoEq_rel_base).
  Definition CoEq_rel_trans := equiv_trans _ _ (clos_rst_is_equiv _ CoEq_rel_base).

  Definition CoEq_Type := {P : B → Prop | exists z : B, P z ∧ (∀ (y : B), (P y ↔ CoEq_rel z y))}.

  Local Axiom ConstructiveIndefiniteDescription_B : ConstructiveIndefiniteDescription_on B.

  Definition CoEq_Choice (ct : CoEq_Type) : {x : B | (proj1_sig ct) x}.
  Proof.
    apply ConstructiveIndefiniteDescription_B.
    destruct ct as [P [z [H1 H2]]].
    exists z; trivial.
  Defined.

  Local Axiom PropExt : ClassicalFacts.prop_extensionality.

  Theorem CoEq_rel_Ext : ∀ (x : A) (y : B), CoEq_rel (f x) y = CoEq_rel (g x) y.
  Proof.
    intros x y.
    assert (Hx : CoEq_rel (f x) (g x)).
    {
      constructor 1.
      exists x; split; trivial.
    }
    apply PropExt; split; intros H.
    {
      apply CoEq_rel_sym in Hx.
      apply (CoEq_rel_trans _ _ _ Hx H).
    }
    {
      apply (CoEq_rel_trans _ _ _ Hx H).
    }
  Qed.

  Program Definition Type_Cat_CoEq  : CoEqualizer Type_Cat f g :=
    {|
      equalizer := CoEq_Type
    |}.

  Next Obligation.
  Proof.
    cbn in *.
    intros x.
    exists (fun y => CoEq_rel x y).
    exists x; split.
    apply CoEq_rel_refl.
    intros z; split; intros; trivial.
  Defined.

  Next Obligation.
  Proof.
    extensionality x.
    apply sig_proof_irrelevance.
    extensionality y.
    apply CoEq_rel_Ext.
  Qed.

  Next Obligation.
  Proof.
    intros T F H x.
    exact (F (proj1_sig (CoEq_Choice x))).
  Defined.

  Next Obligation.
  Proof.
    intros T eqm H.
    unfold Type_Cat_CoEq_obligation_1, Type_Cat_CoEq_obligation_3.
    extensionality x.
    cbn in *.
    match goal with
      [|- eqm (proj1_sig ?A) = _] =>
      destruct A as [z Hz]
    end.
    cbn in *.
    induction Hz as [? ? [w [[] []]]| | |]; auto.
    {
      eapply equal_f in H; eauto.
    }
  Qed.

  Next Obligation.
  Proof.
    intros T eqm H1 u u' H2 H3.
    destruct H3.
    extensionality x.
    destruct x as [P [z [Hz1 Hz2]]].
    unfold Type_Cat_CoEq_obligation_1 in H2; cbn in *.
    apply equal_f with (x := z) in H2.
    match goal with
      [|- ?A = ?B] =>
      match type of H2 with
        ?C = ?D => cutrewrite (A = C); [cutrewrite (B = D)|]; trivial
      end
    end.
    {
      apply f_equal.
      apply sig_proof_irrelevance; cbn.
      extensionality y; apply PropExt; trivial.
    }
    {
      apply f_equal.
      apply sig_proof_irrelevance; cbn.
      extensionality y; apply PropExt; trivial.
    }
  Qed.

End CoEqualizer.

Program Instance Type_Cat_Has_CoEqualizers : Has_CoEqualizers Type_Cat := fun _ _ => Type_Cat_CoEq.


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

Require Import Arith Lia Wellfounded Extraction.

Set Implicit Arguments.

(** Notations utilisées dans le projet

    ⌊l⌋    :  longueur de la liste l
    l ~p m :  les listes l et m sont permutables
    x ∊ l  :  x appartient à la liste l
    x ≤ y  :  x est plus petit que y (pour l'ordre R)
    l ≲ r  :  tous les elements de la liste l sont plus petits que
              tous les elements de la liste r (pour l'ordre R)

    Les quatres lignes ci-dessous ne font que déclarer
    la forme et les priorités des notations, leur sens
    est déclaré plus loin, la première fois qu'on les
    utilise. *)

Reserved Notation "⌊ l ⌋" (at level 1, format "⌊ l ⌋").
Reserved Notation "l ~p m" (at level 70, no associativity, format "l  ~p  m").
Reserved Notation "x ∊ l" (at level 70, no associativity, format "x  ∊  l").
Reserved Notation "x ≤ y" (at level 70, no associativity, format "x  ≤  y").
Reserved Notation "l ≲ m" (at level 70, no associativity, format "l  ≲  m").

(** Une librairie pour réaliser des inductions basées sur une mesure entière,
    par exemple la longueur d'une liste, ou encore la longueur combinée de
    deux listes. *)

Section measure_rect.

  Variables (X : Type) (m : X -> nat)
            (P : X -> Type) (HP: forall x, (forall x', m x' < m x -> P x') -> P x).

  Definition measure_rect x : P x.
  Proof.
    refine ((fix loop x (a : Acc (fun u v => m u < m v) x) : P x := _) x _).
    + apply HP.
      intros; now apply loop, Acc_inv with (1 := a).
    + apply wf_inverse_image, lt_wf.
  Defined.

End measure_rect.

Section measure_rect2.

  Variables (X Y : Type) (m : X -> Y -> nat)
            (P : X -> Y -> Type) (HP: forall x y, (forall x' y', m x' y' < m x y -> P x' y') -> P x y).

  Definition measure2_rect x y : P x y.
  Proof.
    refine ((fix loop x y (a : Acc (fun u v => m (fst u) (snd u) < m (fst v) (snd v)) (x,y)) : P x y := _) x y _).
    + apply HP.
      intros; now apply loop, Acc_inv with (1 := a).
    + apply wf_inverse_image, lt_wf.
  Defined.

End measure_rect2.

Tactic Notation "induction" "on" hyp(x) "as" ident(IH) "with" "measure" uconstr(f) :=
  pattern x; revert x; apply measure_rect with (m := fun x => f); intros x IH.

Tactic Notation "induction" "on" hyp(x) hyp(y) "as" ident(IH) "with" "measure" uconstr(f) :=
  pattern x, y; revert x y; apply measure2_rect with (m := fun x y => f); intros x y IH.

Extraction Inline measure_rect measure2_rect.

(** Toute petite extension de la libraire standard sur les listes (List) *)

Require Import List.

Import ListNotations.

(* On note "In x l" de manière infixe avec "x ∊ l" *)
Infix "∊" := In.
Notation "⌊ l ⌋" := (length l).

Print Notation  "_ ∊ _".
About "_ ∊ _".
Print In.

Print Notation "⌊ _ ⌋".
About "⌊ _ ⌋".
Print length.

Print Notation "_ ++ _".
About "_ ++ _".
Print app.

Fact list_cons_inj X (x y : X) l m : x::l = y::m -> x = y /\ l = m.
Proof. intros H; inversion H; split; trivial. Qed.

#[local] Hint Resolve in_eq in_cons : core.

Check in_eq.
Check in_cons.

(** On importe une partie de la librairie sur les permutations.
    Seuls sont listés les résultats utiles aux algorithmes de tri. *)

Require Permutation.
Infix "~p" := Permutation.Permutation.

Section perm.

  Variable (X : Type).

  Implicit Types (l : list X).

  Fact perm_refl l : l ~p l.
  Proof. apply Permutation.Permutation_refl. Qed.

  Fact perm_cons x y l m : x = y -> l ~p m -> x::l ~p y::m.
  Proof. intros ->; apply Permutation.Permutation_cons; trivial. Qed.

  Fact perm_swap x y l : x::y::l ~p y::x::l.
  Proof. apply Permutation.perm_swap. Qed.

  Fact perm_trans l m k : l ~p m -> m ~p k -> l ~p k.
  Proof. apply Permutation.perm_trans. Qed.

  Fact perm_sym l m : l ~p m -> m ~p l.
  Proof. apply Permutation.Permutation_sym. Qed.

  Fact perm_middle x l m : x::l++m ~p l++x::m.
  Proof. apply Permutation.Permutation_middle. Qed.

  Fact perm_app l l' m m' : l ~p l' -> m ~p m' -> l++m ~p l'++m'.
  Proof. apply Permutation.Permutation_app. Qed.

  Fact perm_app_comm l m : l++m ~p m++l.
  Proof. apply Permutation.Permutation_app_comm. Qed.

  Fact perm_nil l : [] ~p l -> l = [].
  Proof. apply Permutation.Permutation_nil. Qed.

  Fact perm_length l m : l ~p m -> ⌊l⌋ = ⌊m⌋.
  Proof. apply Permutation.Permutation_length. Qed.

  Fact perm_in l m x : l ~p m -> x ∊ l -> x ∊ m.
  Proof. apply Permutation.Permutation_in. Qed.

  Fact perm_cons_inv x l m : x::l ~p x::m -> l ~p m.
  Proof. apply Permutation.Permutation_cons_inv. Qed.

End perm.

(** On va trier les listes en utilisant un ordre total
    et calculable, c'est à dire, une relation binaire

         R : X -> X -> Prop

    notée "x ≤ y" à la place de "R x y" pour plus de lisibilité.
    On suppose que R/≤ est
     - réflexive, antisymétrique et transitive
     - calculable, càd dotée du'une fonction R_cmp
       qui calcule un Booléen b de sorte que
       * si b est true alors on a une preuve de x ≤ y
       * si b est false alors on a une preuve de y ≤ x.
     - voir ci-dessous pour quelques détails supplémentaire
       sur R_cmp. *)

Parameter (X : Type) (R : X -> X -> Prop).
Infix "≤" := R.

Parameter (R_refl  : forall x, x ≤ x)
          (R_anti  : forall x y, x ≤ y -> y ≤ x -> x = y)
          (R_trans : forall x y z, x ≤ y -> y ≤ z -> x ≤ z)
          (R_cmp   : forall x y, { b : bool | if b then x ≤ y else y ≤ x }).

(* R_cmp x y est de type { b : bool | if b then x ≤ y else y ≤ x }, càd
   une paire dépendante (b,Hb) où
      - b est de type bool;
      - Hb est de type (if b then x ≤ y else y ≤ x).
   Donc le type de Hb dépend de la valeur de b. Plus précisément, b est true
   alors Hb : x ≤ y, et si b est false alors Hb : y ≤ x. *)

#[local] Hint Resolve R_refl : core.

(** Une librairie pour la comparaison de deux listes
    en utilisant R/≤. On défini une relation binaire

        list_le : list X -> list X -> Prop

    notée "l ≲ r" à la place de "list_le l r" pour
    plus de lisibilité. "l ≲ r" signifie que tous les
    éléments de l sont plus petits que tous les éléments
    de r. *)

Definition list_le l r := forall x y, x ∊ l -> y ∊ r -> x ≤ y.
Infix "≲" := list_le.

(* Astuce: "Print In" vous dit que x ∊ [] est False *)
Fact list_le_nil_l r : [] ≲ r.  Proof. admit. Admitted.
Fact list_le_nil_r l : l ≲ [].  Proof. admit. Admitted.

#[local] Hint Resolve list_le_nil_l list_le_nil_r : core.

(* Astuce: utiliser R_trans *)
Fact list_le_trans l x r : l ≲ [x] -> [x] ≲ r -> l ≲ r.
Proof.
  intros H1 H2 u v Hu Hv.
  admit.
Admitted.

(* Astuce: perm_in dit que si l ~p m alors l et m
   ont les mêmes éléments *)
Fact list_le_perm_l l m r : l ~p m -> m ≲ r -> l ≲ r.
Proof.
  intros H1 H2 u v Hu Hv.
  admit.
Admitted.

Fact list_le_perm_r l m r : r ~p m -> l ≲ m -> l ≲ r.
Proof.
  admit.
Admitted.

(* Astuce: Check in_app_iff. *)
Fact list_le_app_l l r m : l++r ≲ m <-> l ≲ m /\ r ≲ m.
Proof.
  admit.
Admitted.

Fact list_le_app_r m l r : m ≲ l++r <-> m ≲ l /\ m ≲ r.
Proof.
  admit.
Admitted.

(* Astuce:
    - utiliser list_le_app_l
    - et l'identité x::l = [x]++l *)
Fact list_le_cons_l x l r : [x] ≲ r -> l ≲ r -> x::l ≲ r.
Proof.
  admit.
Admitted.

Fact list_le_cons_r x l r : l ≲ [x] -> l ≲ r -> l ≲ x::r.
Proof.
  admit.
Admitted.

Fact list_le_singleton x y : x ≤ y -> [x] ≲ [y].
Proof.
  admit.
Admitted.

#[local] Hint Resolve list_le_singleton : core.

Fact list_le_singleton_iff x y : [x] ≲ [y] <-> x ≤ y.
Proof. split; auto. Qed.

(** Notion de liste triée par rapport à R/≤ *)

(* Si on découpe une liste triée m en deux "m = l++r", alors
   la partie gauche "l" contient des éléments tous inférieurs
   à eux de la partie droite "r".

   C'est ainsi qu'on choisit de définir ce qu'est une liste
   triée. D'autres choix de définitions équivalentes sont
   possibles. *)

Definition sorted m := forall l r, m = l++r -> l ≲ r.

(** Astuce:
    - seul [] = []++[] est possible
    - puis utiliser list_le_nil_* *)
Fact sorted_nil : sorted [].
Proof.
  admit.
Admitted.

(* Astuce:
   - analyse par cas sur l, première variable
     quantifiée dans la déf. de sorted.
   - utiliser list_consj_inj ensuite. *)
Fact sorted_cons x m : [x] ≲ m -> sorted m -> sorted (x::m).
Proof.
  intros H1 H2 [ | y k ] r E; simpl in *.
  + admit.
  + admit.
Admitted.

#[local] Hint Resolve sorted_nil sorted_cons : core.

Fact sorted_singleton x : sorted [x].
Proof. auto. Qed.

(* Astuce:
   - si m = l++r alors x::m = (x::l)++r
   - aussi, x::m = [x]++m *)
Fact sorted_cons_inv x m : sorted (x::m) -> sorted m /\ [x] ≲ m.
Proof.
  admit.
Admitted.

(* Astuce:
   - par induction sur l
   - utiliser sorted_cons & sorted_cons_inv *)
Fact sorted_app l r : l ≲ r -> sorted l -> sorted r -> sorted (l++r).
Proof.
  induction l as [ | x l IHl ] in r |- *; simpl; trivial.
  admit.
Admitted.

(** Il y a une seul résultat possible au tri d'une liste
    même s'il y a plusieurs manières de procéder à ce tri *)

(* Une fonction de tri est une fonction qui renvoie
   une liste permutable et triée *)
Definition sorting_function (s : list X -> list X) :=
  forall l, sorted (s l) /\ s l ~p l.

(* Astuce:
   - par induction sur l puis analyse par cas sur r
   - utiliser perm_*
   - utiliser sorted_cons_inv
   - aussi, R est antisymétrique *)
Lemma perm_sorted_eq l r : l ~p r -> sorted l -> sorted r -> l = r.
Proof.
  induction l as [ | x l IHl ] in r |- *.
  + intros E _ _.
    apply perm_nil in E.
    subst.
    trivial.
  + destruct r as [ | y r ].
    * admit.
    * admit.
Admitted.

(* Toutes les fonctions de tri renvoient la même valeur *)
Corollary sorting_deterministic s1 s2 :
           sorting_function s1
        -> sorting_function s2
        -> forall l, s1 l = s2 l.
Proof.
  intros H1 H2 l.
  destruct (H1 l) as (G1 & G2).
  destruct (H2 l) as (G3 & G4).
  revert G1 G3; apply perm_sorted_eq.
  now apply perm_trans with (1 := G2), perm_sym.
Qed.

Section insertion_sort.

  (** Le tri par insertion *)

  (* On insère x dans l à sa place *)
  Fixpoint insert x l :=
    match l with
    | []   => [x]
    | y::m => if proj1_sig (R_cmp x y) then x::l else y::insert x m
    end.

  (* A permutation près, on ne fait que rajouter un élément à l *)
  (* Astuce: perm_[refl,trans,cons,swap] *)
  Fact insert_perm x l : insert x l ~p x::l.
  Proof.
    induction l as [ | y m IH ]; simpl.
    + admit.
    + admit.
  Admitted.

  (* Si l est déjà triée, l'insertion maintien cette propriété *)
  (* Astuce: sorted_cons_inv, list_le_cons, list_le_trans *)
  Fact insert_sorted x l : sorted l -> sorted (insert x l).
  Proof.
    induction l as [ | y m IH ]; simpl.
    + intros _; apply sorted_singleton.
    + intros H.
      destruct (R_cmp x y) as ([] & Hb); simpl.
      * admit.
      * admit.
  Admitted.

  (* Le tri par insertion *)
  Fixpoint insertion_sort l :=
    match l with
    | []   => []
    | x::l => insert x (insertion_sort l)
    end.

  (* Astuce:
     - insert_perm & perm_*
     - insert_sorted *)
  Theorem insert_sort_sorting : sorting_function insertion_sort.
  Proof.
    intros l.
    induction l as [ | x l IH ]; simpl.
  Admitted.

End insertion_sort.

Section quick_sort.

  (** Le tri rapide *)

  Implicit Type m : list X.

  (* On sépare la liste m avec le pivot x:
     - l qui contient les éléments plus petits que x
     - r qui contient ceux plus grands que x *)
  Fixpoint pivot_split x m :=
    match m with
    | []   => ([],[])
    | y::m => let (l,r) := pivot_split x m in
              if proj1_sig (R_cmp x y) then (l,y::r) else (y::l,r)
    end.

  (* Propriétés du pivot_split *)
  (* Astuce:
     - induction sur m = [] ou m = y::m'
     - analyse du pivot_split x m' dans
       le cas récursif
     - comparaison de x et y *)
  Lemma pivot_split_spec x m :
    let (l,r) := pivot_split x m
    in  l++r ~p m /\ l ≲ [x] /\ [x] ≲ r.
  Proof.
    induction m as [ | y m' IH ]; simpl.
    + repeat split; auto; tauto.
    + destruct (pivot_split x m') as (l,r).
      destruct IH as (H1 & H2 & H3).
      destruct (R_cmp x y) as ([] & Hxy); simpl.
      * admit.
      * admit.
  Admitted.

  (* pivot_split et sa spécification dans un seul type enrichi *)
  Definition pivot_split_full x m : { '(l,r) | l++r ~p m /\ l ≲ [x] /\ [x] ≲ r }.
  Proof. exists (pivot_split x m); apply pivot_split_spec. Defined.

  (* Argument de terminaison pour le quick_sort *)
  Lemma perm_length_cons l r x m : l++r ~p m -> ⌊l⌋ < ⌊x::m⌋ /\ ⌊r⌋ < ⌊x::m⌋.
  Proof.
    intros H%perm_length.
    rewrite app_length in H.
    simpl; lia.
  Qed.

  (* Astuce:
     - sorted_app, list_le_cons, list_le_trans *)
  Lemma sorted_quick_sort l x r :
        l ≲ [x]
     -> [x] ≲ r
     -> sorted l
     -> sorted r
     -> sorted (l++x::r).
  Proof.
    admit.
  Admitted.

  (* Argument de correction du quick_sort *)
  (* Astuce: perm_[trans,cons,sym_middle] *)
  Lemma perm_quick_sort l r x m : l++r ~p m -> l++x::r ~p x::m.
  Proof.
    admit.
  Admitted.

  (* quick_sort construit avec sa spécification:
     la sortie s est une liste triée permutable
      avec l'entré m. *)
  (* Astuce:
     - induction sur la longueur de m
     - analyse par cas sur m = [] ou m = x::m'
     - on utilise x comme pivot:
        ((l,r),H) := pivot_split_full x m'
     - on applique l'hypothèse d'induction à l et r *)
  Lemma quick_sort_full m : { s | sorted s /\ s ~p m }.
  Proof.
    induction on m as IH with measure ⌊m⌋.
    destruct m as [ | x m' ].
    + exists [].
      admit.
    + destruct (pivot_split_full x m') as ((l,r) & H1 & H2 & H3).
      destruct (IH l) as (l' & G1 & G2); [ apply perm_length_cons with (1 := H1) | ].
      destruct (IH r) as (r' & G3 & G4); [ apply perm_length_cons with (1 := H1) | ].
      exists (l'++x::r'); split.
      * admit.
      * admit.
  Admitted.

  (* Puis on obtient le quick_sort en séparant
     le résultat et sa spécification *)

  Definition quick_sort m := proj1_sig (quick_sort_full m).

  Theorem quick_sort_sorting : sorting_function quick_sort.
  Proof. intros m; apply (proj2_sig (quick_sort_full m)). Qed.

End quick_sort.

Section merge_sort.

  (** Le tri fusion *)

  Implicit Type m : list X.

  (* merge_split [x1,x2,x3,..] = ([x1,x3,x5,...],[x2,x4,...] *)
  Fixpoint merge_split m :=
    match m with
    | []   => ([],[])
    | x::m => let (l,r) := merge_split m in (x::r,l)
    end.

  (* Spécification de "(l,r) := merge_split m" :
     - l&r contiennent les mêmes éléments que m à
       permutation près
     - les listes l et r ont presque la même longueur *)
  (* Astuce:
     - induction sur m = [] ou m = x::m'
     - analyse de merge_split m'
     - perm_[cons,trans,app_comm] *)
  Lemma merge_split_spec m :
    let (l,r) := merge_split m
    in  l++r ~p m /\ ⌊r⌋ <= ⌊l⌋ <= 1+⌊r⌋.
  Proof.
    induction m as [ | y m' IH ]; simpl.
    + repeat split; auto; lia.
    + revert IH.
      destruct (merge_split m') as (l,r); simpl.
      intros (H1 & H2 & H3).
      split; [ | lia ].
      admit.
  Admitted.

  Definition merge_split_full m : { '(l,r) | l++r ~p m /\ ⌊r⌋ <= ⌊l⌋ <= 1+⌊r⌋ }.
  Proof. exists (merge_split m); apply merge_split_spec. Defined.

  (* fusion de deux listes triées l et r avec la spécification *)
  (* Astuce:
     - induction sur la longueur combinée ⌊l⌋+⌊r⌋
     - analyse par cas sur l puis sur r
     - dans le cas où l = x::l' et r = y::r'
       comparaison de x et y avec R_dec *)
  Lemma merge l r : sorted l -> sorted r -> { m | m ~p l++r /\ sorted m }.
  Proof.
    induction on l r as IH with measure (⌊l⌋+⌊r⌋).
    intros Hl Hr.
    destruct l as [ | x l' ].
    + exists r; auto.
    + destruct r as [ | y r' ].
      * exists (x::l'); split; auto.
        now rewrite <- app_nil_end.
      * apply sorted_cons_inv in Hl as (H1 & H2).
        apply sorted_cons_inv in Hr as (H3 & H4).
        destruct (R_cmp x y) as ([] & Hxy); simpl.
        - destruct (IH l' (y::r')) as (m & G1 & G2); auto.
          exists (x::m); simpl.
          admit.
        - admit.
  Admitted.

  (* tri fusion de m avec sa spécification *)
  (* Astuce:
     - par induction sur la longueur ⌊m⌋
     - analyse par cas sur m
       * m = []
       * m = [x]
       * m = _::_::_ (longueur > 1)
         dans ce cas, on divise m en
         deux parts de longueur presque identique,
         que l'on trie récursivement, puis qu'on
         fusionne. *)
  Lemma merge_sort_full m : { s | sorted s /\ s ~p m }.
  Proof.
    induction on m as IH with measure ⌊m⌋.
    revert IH.
    case_eq m.
    + intros Hm IH.
      exists []; auto.
    + intros x [ | y m' ] Hm IH.
      * exists [x]; auto.
      * destruct (merge_split_full m) as ((l,r) & H1 & H2 & H3).
        subst m.
        generalize (perm_length H1); rewrite app_length; simpl; intros H4.
        destruct (IH l) as (l' & G1 & G2); [ simpl; lia | ].
        destruct (IH r) as (r' & G3 & G4); [ simpl; lia | ].
        admit.
  Admitted.

  Definition merge_sort m := proj1_sig (merge_sort_full m).

  Theorem meger_sort_sorting : sorting_function merge_sort.
  Proof. intros m; apply (proj2_sig (merge_sort_full m)). Qed.

End merge_sort.

(** Pour information, on peut extraire les algorithmes
    certifiés corrects vers le langage OCaml par exemple *)

Extraction Inline pivot_split_full quick_sort_full.
Extraction Inline merge_split_full merge_sort_full.

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

Recursive Extraction insertion_sort quick_sort merge_sort.