Require Import FinTypes Base.

(* Require Import Vector. *)

(* Definition vector X Y := Vector.t Y (|elem X|). *)

Definition finfunc_table (A : finType) (B: Type) (f: A -> B) :=
  List.map (fun x => (x, f x)) (elem A).

(* Now we prove that the tranformation of a function of finite domain to a table is correct *)

Lemma finfunc_comp (A : finType) (B: Type) (f: A -> B) a : (a,f a) el finfunc_table f.
Proof.
  unfold finfunc_table. now eapply (in_map (fun x => (x, f x))).
Qed.

Lemma finfunc_sound (A : finType) (B : Type) (f: A -> B) a b: (a,b) el finfunc_table f -> b = f a.
Proof.
  unfold finfunc_table. rewrite in_map_iff. firstorder congruence.
Qed.

Lemma finfunc_sound_cor (A : finType) (B:Type) (f: A -> B) a b b' : (a,b) el finfunc_table f -> (a,b') el finfunc_table f -> b = b'.
Proof.
  intros H1 H2. specialize (finfunc_sound H1). specialize (finfunc_sound H2). congruence.
Qed.

Definition lookup (A : eqType) (B : Type) (l : list (A * B)) (a : A) (def : B) : B :=
  match (filter (fun p => Dec (fst p = a)) l) with
    List.nil => def
  | p :: _ => snd p
  end.

Lemma lookup_sound (A: eqType) (B: Type) (L : list (prod A B)) a b def :
  (forall a' b1 b2, (a',b1) el L -> (a',b2) el L -> b1=b2) -> (a,b) el L -> lookup L a def = b.
Proof.
  intros H1 H2. unfold lookup.
  destruct filter eqn:E.
  - assert ((a,b) el filter (fun p : A * B => Dec (fst p = a)) L) by ( rewrite in_filter_iff ; eauto).
    now rewrite E in H.
  - destruct p. assert ((e,b0) el (filter (fun p : A * B => Dec (fst p = a)) L)) by now rewrite E.
    rewrite in_filter_iff in H.
    dec; cbn in *; subst; firstorder.
Qed.

Lemma finfunc_correct (A: finType) B (f: A -> B) a  def: lookup (finfunc_table f) a def = f a.
Proof.
  eapply lookup_sound; [ apply finfunc_sound_cor | apply finfunc_comp ].
Qed.

(* Now we can prove that the transformation of the function table into another type is correct as long
as the conversion is injective *)

Lemma finfunc_conv (A: finType) (cA : eqType) (B cB : Type) (f: A -> B) (mA : A -> cA) (mB : B -> cB) a def:
  injective mA -> lookup (List.map (fun x => (mA (fst x), mB (snd x))) (finfunc_table f))  (mA a) def = mB (f a).
Proof.
  intros INJ.
  erewrite lookup_sound; eauto.
  - intros a' b1 b2 H1 H2. rewrite in_map_iff in *. destruct H1 as [[] [L1 R1]]. destruct H2 as [[] [L2 R2]].
    cbn in *.
    inv L1; inv L2. rewrite (finfunc_sound R1), (finfunc_sound R2), (INJ e e0); congruence.
  - rewrite in_map_iff. exists (a, f a). subst. split; auto. apply finfunc_comp.
Qed.

(* (** Definition of vectors (extensional/ set theoretic functions)  *)
 (*   structure containing a list representing the image and a proof that the list has exactly as many elements as the source type *) *)
(* Definition Card_X_eq X Y (A: list Y) := |A| = Cardinality X. *)
(* Definition vector (X: finType) (Y: Type) := subtype (@Card_X_eq X Y). *)
(* Notation "X --> Y" := (vector X Y) (at level 55, right associativity). *)
(* Hint Unfold pure. *)
(* Hint Unfold Card_X_eq. *)
(* (** Projects the list from a STF *) *)
(* Definition image (X: finType) (Y: Type) (f: X --> Y) := proj1_sig  f. *)

(* (** Instance Declaration for Type Dec Type class for vectors. *) *)
(* Instance vector_eq_dec (X: finType) (Y: eqType) : eq_dec (X --> Y). *)
(* Proof. *)
(*   auto. *)
(* Qed. *)

(* Canonical Structure EqVect (X: finType) (Y: eqType) := EqType (X --> Y). *)

(* (** Function which produces a list of all list containing elements from A with length n *) *)
(* Fixpoint images (Y: Type) (A: list Y) (n: nat): list (list Y) := *)
(*   match n with *)
(*   | 0 => [[]] *)
(*   | S n' => concat (map (fun x => map (cons x) (images A n')) A) *)
(*   end. *)

(* Lemma imagesNonempty (Y: Type) y (A: list Y) : forall n, images (y::A) n <> nil. *)
(* Proof. *)
(*   intro n. induction n. *)
(*   - cbn. congruence. *)
(*   - cbn. intro H. pose proof (app_eq_nil _ _ H) as [E1 E2]. clear H. pose proof (map_eq_nil _ _ E1).  auto. *)
(* Qed. *)

(* (** If x is unequal to y then a list starting with y cannot be found in a list of list all starting with x *) *)
(* Lemma notInMapCons (X: Type) (x y: X) (A: list X) (B: list (list X)): *)
(*   x <> y -> y::A el (map (cons x) B) -> False. *)
(* Proof. *)
(*   intros neq E. rewrite in_map_iff in E. destruct E as [C [E _]]. congruence. *)
(* Qed. *)

(* Definition mC X B := (fun x:X => map (cons x) B). *)
(* Definition mmC  X B (A: list X) := map (mC B) A. *)

(* Lemma disjoint_map_cons X (A: list (list X)) (x y: X): x <> y -> disjoint (map (cons x) A) (map (cons y) A). *)
(* Proof. *)
(*   intro N; induction A. *)
(*   - cbn. auto. *)
(*   - cbn. unfold disjoint. intros [B [H1 H2]]. destruct H1, H2. *)
(*     + congruence. *)
(*     + subst B. eapply notInMapCons. Focus 2. *)
(*       * apply H0. *)
(*       * congruence. *)
(*     + subst B. eapply notInMapCons; eauto. *)
(*     + apply IHA. now exists B. *)
(* Qed.   *)

(* Lemma disjoint_in (X: Type) x A (B: list (list X)) (E: B <> nil) B' (H: ~ x el A): B' el map (mC B) A -> disjoint (map (cons x) B) B'.  *)
(* Proof. *)
(*   destruct B; try congruence. *)
(*   intro H'. induction A. *)
(*   - contradiction H'. *)
(*   - pose proof (negOr H) as [G G']. destruct H' as [H' | H']. *)
(*     + subst B'. apply disjoint_map_cons; congruence. *)
(*     + apply IHA; auto. *)
(* Qed. *)

(* Lemma disjoint_in_map_map_cons X  (A: list X) (B C C': list (list X)) (H: C <> C') (E: C el (mmC B A)) (E': C' el (mmC B A)) (N: B <> nil) (D: dupfree A): *)
(*   disjoint C C'. *)
(* Proof.  *)
(*   induction D. *)
(*   - contradiction E. *)
(*   - destruct B; try congruence; clear N. destruct E, E'; try congruence. *)
(*     + subst C. eapply disjoint_in; now eauto. *)
(*     + subst C'. apply disjoint_symm. eapply disjoint_in; now  eauto. *)
(*     + now apply IHD. *)
(* Qed.       *)

(* Lemma dupfree_concat_map_cons (X: Type) (A: list X) (B: list (list X)): *)
(*   dupfree A -> dupfree B -> B <> nil ->  dupfree (concat (map (fun x => map (cons x) B) A)). *)
(* Proof. *)
(*   intros D D' N. apply dupfree_concat; try split. *)
(*   - intros C E. induction D. *)
(*     +  contradiction E. *)
(*     + destruct E; auto. subst C. apply dupfree_map; auto. congruence. *)
(*   -  intros B' B'' E E' H. eapply disjoint_in_map_map_cons; eauto. *)
(*   - apply dupfree_map; auto. intros x y _ _ E. destruct B. *)
(*     + congruence. *)
(*     +  cbn in E. now inv E. *)
(* Qed. *)

(* Lemma imagesDupfree (Y: Type) (A: list Y) (n:nat) : dupfree A -> dupfree (images A n). *)
(* Proof. *)
(*   induction n. *)
(*   - now repeat constructor. *)
(*   - cbn. intro D. destruct A. *)
(*     +constructor. *)
(*     + apply dupfree_concat_map_cons; auto. apply imagesNonempty. *)
(* Qed. *)

(* Lemma inConcatCons (Y: Type) (A C: list Y) (B: list (list Y)) y: y el A /\ C el B -> (y::C) el (concat (map (fun x => map (cons x) B) A)). *)
(* Proof. *)
(*   intros [E E']. induction A. *)
(*   - contradiction E. *)
(*   - cbn. destruct E as [E | E]. *)
(*     + subst a. apply in_app_iff. left. apply in_map_iff. now exists C. *)
(*                                                                     + auto.  *)
(* Qed.                                                                *)

(* Lemma inImages (Y: Type) (A B: list Y): (forall x, x el B -> x el A) -> B el images A (|B|). *)
(* Proof. *)
(*   intros E. induction B. *)
(*   - cbn. now left. *)
(*   - cbn. apply inConcatCons. auto. *)
(* Qed.       *)

(* (** images produces a list of containing all lists of correct length *) *)
(* Lemma vector_enum_ok (X: finType) (Y: finType) f: *)
(* |f| = Cardinality X -> count (images  (elem Y) (Cardinality X)) f= 1. *)
(* Proof. *)
(*   intros H. apply dupfreeCount. *)
(*   - apply imagesDupfree. apply dupfree_elements. *)
(*   - rewrite <- H. now apply inImages. *)
(* Qed. *)

(* (** FunctionLists A n only produces lists of length n *) *)
(* Lemma imagesInnerLength (Y: Type) (n: nat) : *)
(*   forall (A: list Y) B, B el (images A n) -> | B | = n. *)
(* Proof. *)
(*   induction n; intros A B; cbn. *)
(*   - intros H. destruct H; try tauto. now subst B. *)
(*   - pattern A at 1. generalize A at 2. induction A; cbn. *)
(*     +  tauto. *)
(*     + intros C E. destruct (in_app_or  _ _ B E) as [H|H]. *)
(*       * pose proof (in_map_iff (cons a)  (images C n) B) as [G _]. specialize (G H); clear H. *)
(*         destruct G as [D [H G]]. specialize (IHn  _ _ G). subst B. cbn. omega. *)
(*       * now apply (IHA C). *)
(* Qed. *)

(* (** Function converting a list (list Y) containing lists of length Cardinality X into a lists of vectors (X --> Y) *) *)
(* Definition extensionalPower (X Y: finType) (L: list (list Y))  (P: L <<= images (elem Y) (Cardinality X)): list (X --> Y). *)
(* Proof. *)
(*   revert L P. *)
(*   refine (fix extPow L P :=  _). destruct L. *)
(*   -  exact nil. *)
(*   - apply cons. *)
(*     + exists l. specialize (P l (or_introl eq_refl)). unfold pure. dec; auto. contradiction ( n (imagesInnerLength P)). *)
(*     + eapply extPow. intros A E. apply P. exact (or_intror E). *)
(* Defined. *)

(* (** To vectors  are equal if there images are equal *) *)
(* Lemma vector_extensionality (X: finType) (Y: Type) (F G: X --> Y) : (image F = image G) -> F = G. *)
(* Proof. *)
(*   apply subtype_extensionality.  *)
(* Qed. *)

(* (** The number if occurences of a function in extensionalpower is equal to the number of occurences of its image in the original list given to extensionalpower as an argument *) *)
(*  Lemma counttFL X Y L P f : *)
(*   count (@extensionalPower X Y L P) f = count L (image f). *)
(* Proof. *)
(*   induction L. *)
(*   -   reflexivity. *)
(*   - simpl. dec; rename a into A; decide (image f = A). *)
(*     +  now rewrite IHL. *)
(*     +contradict n. now subst f.       *)
(*     +  contradict n. now apply vector_extensionality. *)
(*     + apply IHL.         *)
(* Qed. *)

(* Instance finTypeC_vector (X Y: finType) : *)
(*   finTypeC (EqVect X Y). *)
(* Proof. *)
(*  apply (FinTypeC (enum := @extensionalPower _ _ (images (elem Y) (Cardinality X)) (fun x => fun y => y))). *)
(*  intro f. rewrite counttFL. apply vector_enum_ok. destruct f as [A p]. cbn. now impurify p. *)
(* Defined. *)

(* Canonical Structure finType_vector (X Y: finType) := FinType (EqVect X Y). *)

(* Notation "Y ^ X" := (finType_vector X Y). *)

(* Lemma finType_vector_correct (X Y: finType): *)
(*   X --> Y =  Y^ X. *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

(* Lemma finType_vector_enum (X Y: finType): *)
(*   elem (Y^ X) = @extensionalPower _ _ (images (elem Y) (Cardinality X)) (fun x => fun y => y). *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

(* Set Printing Coercions. *)

(* Lemma tofinType_vector_correct (X Y: finType): *)
(*   tofinType (X --> Y) = Y ^ X. *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)
(* Unset Printing Coercions. *)
(* (*** Conversion between vectors and functions *) *)

(* (** Function that applies a vector to an argument *)                 *)
(* Definition applyVect (X: finType) (Y: Type) (f: X --> Y): X -> Y. *)
(* Proof. *)
(*   refine (fun x: X => _). *)
(*   destruct (elem X) eqn: E. *)
(*   - exfalso. pose proof (elem_spec x). now rewrite E in H.     *)
(*   - destruct f as [image p]. destruct image. *)
(*     + exfalso. unfold Card_X_eq, Cardinality in p. rewrite E in p. now impurify p. *)
(*     + exact (getAt (y::image0) (index x) y). *)
(* Defined. *)

(* Coercion applyVect: vector >-> Funclass. *)

(* (** A function converting A function f into the list representing its image on elements of A*) *)
(* Definition getImage {X: finType} {Y: Type} (f: X -> Y) :=map f (elem X). *)

(* (** getImage contains the right elements *) *)
(* Lemma getImage_in (X: finType) (Y: Type) (f: X -> Y) (x:X) : (f x) el (getImage f). *)
(* Proof. *)
(*   unfold getImage. now apply in_map. *)
(*  Qed. *)
(* (** getImage only produces lists of the correct length *) *)
(* Lemma getImage_length (X: finType) (Y: Type) (f: X -> Y) :  |getImage f| = Cardinality X. *)
(* Proof. *)
(*   apply map_length. *)
(* Qed. *)

(* (** Function converting a function into a vector *) *)
(* Definition vectorise {X: finType} {Y: Type} (f: X -> Y) : X --> Y := *)
(*   exist (pure (@Card_X_eq X Y)) (getImage f) (purify (getImage_length f)). *)

(* Lemma getImage_correct (X:finType) (Y:Type) (f: X -> Y): *)
(*   getImage f = image (vectorise f). *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

(* (** A generalisation of a late case of apply_toVector_inverse *) *)
(* Lemma HelpApply (X: eqType) (Y: Type) (A: list X) (f: X -> Y) x y (C: count A x > 0): *)
(*   getAt (map f A) (getPosition A x) y = f x. *)
(* Proof. *)
(*   induction A. *)
(*   - cbn in *. omega. *)
(*   - cbn in *. dec. *)
(*     + congruence. *)
(*     + now apply IHA. *)
(* Qed. *)

(* (** If a function is converted into a vector and then applied to an argument the result is the same as if one had just applied the function to the argument *) *)
(* Lemma apply_vectorise_inverse (X: finType) (Y: Type) (f: X -> Y) (x: X) : *)
(*     (vectorise f) x = f x.   *)
(* Proof. *)
(*  destruct X as [X [A ok]]. destruct A. *)
(*   - discriminate (ok x). *)
(*   - cbn  in  *. specialize (ok x). dec. *)
(*     + congruence. *)
(*     + apply HelpApply. omega. *)
(* Qed. *)

(* (** The position of x in a list containg x exactly once is one greater than the size of the sublist befor x *) *)
(* Lemma countNumberApp (X: eqType) (x:X) (A B: list X)  (ok : count (A ++ x::B) x = 1) : *)
(*   getPosition (A ++ x::B) x = |A|. *)
(* Proof. *)
(*   induction A. *)
(*   - cbn. now deq x. *)
(*   - cbn in *. dec. *)
(*     + inv ok. pose proof (countApp a A B). omega. *)
(*     + auto. *)
(* Qed. *)

(* Lemma getAt_correct (Y:Type) (A A': list Y) y y': *)
(* getAt (A' ++ y::A) (|A'|) y' = y. *)
(* Proof. *)
(*   induction A'; cbn. *)
(*   - reflexivity. *)
(*   - cbn in *. apply IHA'. *)
(* Qed.     *)

(* Lemma rightResult (X: finType) (x:X) (B B': list X) (Y: Type)  (y:Y) (A A': list Y) (H:  pure (@Card_X_eq X Y) (A' ++ y::A))  (H': |A'| = | B'|)  (G: elem X = B' ++ x::B): *)
(*  ((exist _ _ H): X --> Y) x = y. *)
(* Proof. *)
(* destruct X as [X [C ok]]. unfold applyVect. cbn in *. subst C. destruct B'; destruct A' ; cbn in *; impurify H; unfold Card_X_eq in H;  cbn in H. *)
(*   -  now deq x.  *)
(*   -  rewrite app_length in H.  inv H. omega. *)
(*   - rewrite app_length in H. cbn in H. omega. *)
(*   - specialize (ok x). dec. *)
(*     + subst e. inv ok.  pose proof countApp x B' B. omega. *)
(*     + rewrite countNumberApp; auto. *)
(*    inv H'. eapply getAt_correct. *)
(* Qed.       *)

(* Lemma vectorise_apply_inverse' (X: finType) (B B': list X) (Y: Type) (A A' A'': list Y) (H: pure (@Card_X_eq X Y) A'') (H': |A'| = | B' |) (H'': |A| = | B|) (E: A' ++ A = A'') (G: elem X = B' ++ B) : *)
(*   map ((exist _ _ H): X --> Y) B= A. *)
(*   Proof. *)
(*     revert A A' B' H' H'' E G. induction B; intros A A' B' H' H'' E G. *)
(*     - cbn. symmetry. now rewrite <- length_zero_iff_nil. *)
(*     - cbn. destruct A; try (discriminate H''). f_equal. *)
(*       +  subst A''. eapply rightResult. *)
(*         * inv H'. exact H1. *)
(*         * exact G. *)
(*       + apply (IHB A (A' ++ [y]) (B' ++ [a])). *)
(*         * repeat rewrite app_length. cbn. omega. *)
(*         * now inv H''. *)
(*         *  now rewrite app_assoc_reverse. *)
(*         * rewrite G.  replace (a::B) with ([a]++B) by auto. now rewrite app_assoc. *)
(*   Qed. *)

(* Lemma vectorise_apply_inverse (X: finType) (Y: Type) (f: X --> Y): vectorise f = f. *)
(* Proof. *)
(*   apply vector_extensionality. cbn. destruct f as [A p]. *)
(*   eapply vectorise_apply_inverse'; eauto using app_nil_l; now impurify p. *)
(* Qed. *)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2014-12-11
- Adam Koprowski, 2009-04-24
- Leo Ducas, 2007-08-06

Type of natural numbers strictly smaller that some bound.
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil NatUtil ListUtil ListNodup FunUtil VecUtil.

Definition N n := sig (gt n).

Definition N_ n := @exist nat (gt n).

Definition N_val {n} (x : N n) : nat := proj1_sig x.

Coercion N_val : N >-> nat.

Definition N_prf {n} (x : N n) : x < n := proj2_sig x.

Coercion N_prf : N >-> lt.

Definition zero {n} : N (S n). Proof. apply (@N_ _ 0). lia. Defined.

(* One can define anything from [N 0] since [N 0] is empty. *)
Definition any_of_N0 {B : Type} : N 0 -> B.

Proof. intros [k_val k]. lia. Qed.

Lemma inj_N_val n : injective (@N_val n).

Proof.
  intros [x xn] [y yn]; simpl. intro e. subst y. f_equal. apply lt_unique.
Qed.

Lemma N_eq {n} : forall x y : N n, N_val x = N_val y <-> x = y.

Proof.
  intros [x xn] [y yn]; simpl. split; intro e.
  subst y. rewrite (lt_unique xn yn). refl.
  gen (f_equal N_val e). tauto.
Qed.

Lemma N_eq_dec {n} : forall x y : N n, {x=y}+{~x=y}.

Proof.
  intros [x xn] [y yn]. destruct (eq_nat_dec x y).
  left. apply N_eq. hyp.
  right. intro e. apply n0. apply N_eq in e. hyp.
Defined.

(****************************************************************************)
(** List [n-1; ..; 0] of the n first natural numbers starting from 0
in reverse order. *)

Fixpoint nats_decr_lt n :=
  match n with
    | 0 => nil
    | S n' => n' :: nats_decr_lt n'
  end.

Definition nats_incr_lt n := rev' (nats_decr_lt n).

Lemma In_nats_decr_lt : forall n x, x < n <-> In x (nats_decr_lt n).

Proof. induction n; simpl; intros. lia. rewrite <- IHn. lia. Qed.

Lemma length_nats_decr_lt n : length (nats_decr_lt n) = n.

Proof. induction n; simpl. refl. rewrite IHn. refl. Qed.

(****************************************************************************)
(** List [@N_ n (n-1) _; ..; @N_ n 0 _] of all the elements of [N n] in
reverse order. *)

Section list_N.

  Variable n : nat.

  Lemma L_ k : S k < n -> k < n. Proof. lia. Qed.

  (* Given k<n, returns the list [@N_ n k _; ..; @N_ n 0 _]. *)
  Fixpoint L_aux k :=
    match k as k return k<n -> list (N n) with
      | 0 => fun h => N_ h :: nil
      | S k' => fun h => N_ h :: L_aux k' (L_ h)
    end.

  Lemma length_L_aux : forall k (hk : k<n), length (L_aux hk) = S k.

  Proof. induction k; intro hk; simpl. lia. rewrite IHk. lia. Qed.

  Lemma nth_L_aux x :
    forall k (h : k<n) i, i <= k -> N_val (nth i (L_aux h) x) = k - i.

  Proof.
    induction k; simpl; intros; destruct i; simpl. refl. lia. refl.
    rewrite IHk. refl. lia.
  Qed.

  Lemma In_L_aux_elim x k (h : k<n) :
    In x (L_aux h) -> exists i, N_val x = k - i.

  Proof.
    intro xL. destruct (In_nth x xL) as [i [i1 i2]].
    apply N_eq in i2. rewrite nth_L_aux in i2. ex i. hyp.
    rewrite length_L_aux in i1. lia.
  Qed.

  Arguments In_L_aux_elim [x k h] _.

  Lemma In_L_aux :
    forall k (h : k<n) i (p : i<n), i <= k -> In (N_ p) (L_aux h).

  Proof.
    induction k; simpl; intros.
    left. apply N_eq; simpl. lia.
    destruct (eq_nat_dec (S k) i).
    left. apply N_eq; simpl. hyp.
    right. apply IHk. lia.
  Qed.

End list_N.

Arguments In_L_aux_elim [n x k h] _.

(* Returns the list [@N_ n (n-1) _; ..; @N_ n 0 _]. *)
Definition L n :=
  match n return list (N n) with
    | 0 => nil
    | S n' => L_aux (le_n (S n'))
  end.

Arguments L : clear implicits.

Lemma nth_L n x i : i < n -> N_val (nth i (L n) x) = pred n - i.

Proof. intros. unfold L. destruct n. lia. apply nth_L_aux. lia. Qed.

Lemma In_L n i (p : i<n) : In (N_ p) (L n).

Proof. unfold L. destruct n. lia. apply In_L_aux. lia. Qed.

Lemma In_L_elim n x : In x (L n) -> exists i, N_val x = n - i.

Proof.
  destruct n; simpl. fo.
  intro xl. destruct (In_L_aux_elim xl) as [i e]. ex (S i). hyp.
Qed.

Arguments In_L_elim [n x] _.

Lemma length_L n : length (L n) = n.

Proof. destruct n; simpl. refl. unfold N. rewrite length_L_aux. refl. Qed.

Lemma nodup_L_aux {n} : forall k (hk : k < n), nodup (L_aux hk).

Proof.
  induction k; intro hk; simpl. tauto. split. 2: apply IHk.
  intro h. destruct (In_L_aux_elim h) as [i e]. simpl in e. lia.
Qed.

Lemma nodup_L n : nodup (L n).

Proof. destruct n; simpl. auto. apply nodup_L_aux. Qed.

(****************************************************************************)
(** Functions between [N m] and [N n]. *)

Lemma N_inj_le m n (f : N m -> N n) : injective f -> m <= n.

Proof.
  intro f_inj.
  assert (e : length (map f (L m)) = m). rewrite map_length, length_L. refl.
  rewrite <- e, <- (@length_L n). apply nodup_incl_length_le.
  apply nodup_map_inj. hyp. apply nodup_L.
  intros y hy. destruct y as [y_val y]. apply In_L.
Qed.

Lemma N_bij_eq m n (f : N m -> N n) : bijective f -> m = n.

Proof.
  intros [f_inj f_surj]. apply le_antisym.
  apply N_inj_le with (f := f). hyp.
  apply N_inj_le with (f := inverse f_surj). inj.
Qed.

(****************************************************************************)
(** Vector [@N_ n (n-1) _; ..; @N_ n 0 _] of all the elements of [N n] in
reverse order. *)

Section vec_N.

  Variable n : nat.

  (* Given k<n, returns the list [@N_ n k _; ..; @N_ n 0 _]. *)
  Fixpoint V_aux k :=
    match k as k return k<n -> vector (N n) (S k) with
      | 0 => fun h => Vcons (N_ h) Vnil
      | S k' => fun h => Vcons (N_ h) (V_aux k' (L_ h))
    end.

  Lemma Vnth_V_aux :
    forall k (h : k<n) i (hi : i < S k), N_val (Vnth (V_aux h) hi) = k - i.

  Proof.
    induction k; simpl; intros; destruct i; simpl. refl. lia. refl.
    rewrite IHk. refl.
  Qed.

  Lemma Vin_V_aux_elim x k (h : k<n) :
    Vin x (V_aux h) -> exists i, N_val x = k - i.

  Proof.
    intro xL. destruct (Vin_nth xL) as [i [i1 i2]].
    apply N_eq in i2. rewrite Vnth_V_aux in i2. ex i. hyp.
  Qed.

  Arguments Vin_V_aux_elim [x k h] _.

  Lemma Vin_V_aux :
    forall k (h : k<n) i (p : i<n), i <= k -> Vin (N_ p) (V_aux h).

  Proof.
    induction k; simpl; intros.
    left. apply N_eq; simpl. lia.
    destruct (eq_nat_dec (S k) i).
    left. apply N_eq; simpl. hyp.
    right. apply IHk. lia.
  Qed.

End vec_N.

Arguments Vin_V_aux_elim [n x k h] _.

(* Returns the list [@N_ n (n-1) _; ..; @N_ n 0 _]. *)
Definition V n :=
  match n return vector (N n) n with
    | 0 => Vnil
    | S n' => V_aux (le_n (S n'))
  end.

Arguments V : clear implicits.

Lemma Vnth_V n i (hi : i < n) : N_val (Vnth (V n) hi) = pred n - i.

Proof. intros. unfold L. destruct n. lia. apply Vnth_V_aux. Qed.

Lemma Vin_V n i (p : i<n) : Vin (N_ p) (V n).

Proof. unfold L. destruct n. lia. apply Vin_V_aux. lia. Qed.

Lemma Vin_V_elim n x : Vin x (V n) -> exists i, N_val x = n - i.

Proof.
  destruct n; simpl. fo.
  intro xl. destruct (Vin_V_aux_elim xl) as [i e]. ex (S i). hyp.
Qed.

Arguments Vin_V_elim [n x] _.

(****************************************************************************)
(** Multiplicity and sorting properties. *)

Lemma map_N_val_L_aux n :
  forall k (hk : k<n), map N_val (L_aux hk) = nats_decr_lt (S k).

Proof. induction k; intro hk; simpl. refl. rewrite IHk. refl. Qed.

Lemma map_N_val_L n : map N_val (L n) = nats_decr_lt n.

Proof. destruct n; simpl. refl. apply map_N_val_L_aux. Qed.

From CoLoR Require Import SortUtil RelUtil.

Lemma lelistA_map_N_val n R (a : N n) :
  forall l, lelistA (Rof R N_val) a l -> lelistA R a (map N_val l).

Proof.
  induction l; intro h; simpl.
  apply nil_leA.
  inversion h; subst. apply cons_leA; auto.
Qed.

Lemma sort_map_N_val n R :
  forall l : list (N n), sort (Rof R N_val) l -> sort R (map N_val l).

Proof.
  induction l; intro h; simpl.
  apply nil_sort.
  inversion h; subst. apply cons_sort. tauto. apply lelistA_map_N_val. hyp.
Qed.

From CoLoR Require Import ListPermutation.

Lemma multiplicity_nats_decr_lt i :
  forall n, multiplicity (list_contents eq_nat_dec (nats_decr_lt n)) i
            = if lt_ge_dec i n then 1 else 0.

Proof.
  induction n; simpl.
  destruct (lt_ge_dec i 0); lia.
  rewrite IHn. destruct (lt_ge_dec i n); destruct (eq_nat_dec n i);
    destruct (lt_ge_dec i (S n)); lia.
Qed.

Lemma multiplicity_L_aux n (i : N n) : forall k (kn : k < n),
    multiplicity (list_contents N_eq_dec (L_aux kn)) i
    = if le_dec i k then 1 else 0.

Proof.
  destruct i as [i hi]; simpl.
  induction k; intro hk.
  simpl. destruct i.
  destruct (le_dec 0 0); lia.
  destruct (le_dec (S i) 0); lia.
  simpl. destruct i; rewrite IHk.
  destruct (le_dec 0 k); destruct (le_dec 0 (S k)); lia.
  destruct (eq_nat_dec k i); simpl;
    destruct (le_dec (S i) k); destruct (le_dec (S i) (S k)); lia.
Qed.

Lemma multiplicity_L n (i : N n) :
  multiplicity (list_contents N_eq_dec (L n)) i = 1.

Proof.
  destruct n as [|n]. apply any_of_N0. hyp.
  unfold L. rewrite multiplicity_L_aux. destruct (le_dec i n). refl.
  destruct i as [i hi]. simpl in n0. lia.
Qed.

Lemma multiplicity_map_N_val n i (hi : i<n) :
  forall l, multiplicity (list_contents eq_nat_dec (map N_val l)) i
            = multiplicity (list_contents N_eq_dec l) (N_ hi).

Proof.
  induction l; simpl. refl. rewrite IHl. destruct a as [j hj]; simpl.
  destruct (eq_nat_dec j i); refl.
Qed.

Lemma multiplicity_map_N_val_notin n i (hi : i>=n) : forall l : list (N n),
    multiplicity (list_contents eq_nat_dec (map N_val l)) i = 0.

Proof.
  induction l; simpl. refl. rewrite IHl. destruct (eq_nat_dec a i).
  subst. destruct a as [a ha]. simpl in hi. lia. refl.
Qed.

(****************************************************************************)
(** Given [n:nat], a predicate [Pr : N n -> Prop] and a function
[P] that can check whether [Pr i] is true, [check_seq Pr P] checks
whether [Pr i] is true for all [i] strictly smaller than [n]. *)

Section Check_seq_aux.

  Variables (n : nat) (Pr : N n -> Prop) (P : forall i : N n, option (Pr i)).

  Program Fixpoint check_seq_aux p (H : forall i : N n, N_val i < p -> Pr i)
    {measure (n - p)} : option (forall i : N n, Pr i) :=
    match le_lt_dec n p with
      | left _ => Some _
      | right cmp =>
        match P (N_ cmp) with
          | None => None
          | Some _ => @check_seq_aux (S p) _ _
        end
    end.

  Next Obligation. apply H. destruct i. simpl. lia. Qed.
  Next Obligation.
    destruct i as [x l]. simpl in *.
    destruct (eq_nat_dec x p).
    subst. rewrite (lt_unique l cmp). hyp.
    apply H. simpl. lia.
  Qed.
  Next Obligation. lia. Qed.

End Check_seq_aux.

Program Definition check_seq (n : nat) (Pr : N n -> Prop)
  (P : forall (i : N n), option (Pr i)) : option (forall (i : N n), Pr i)
  := check_seq_aux _ P (p:=0) _.

Next Obligation. lia. Qed.

Arguments check_seq [n Pr] _.


Require Export OrderedType SetoidList.
Require Export Morphisms.

Generalizable All Variables.

(** This file defines the interface of typeclass-based
   finite sets *)

(** * Pointwise-equality

   We define pointwise equality for any structure with a membership
   predicate [In : elt -> container -> Prop], and prove it is an
   equivalence relation. This is required for the sets' interface.
   *)
Section Equal.
  Variable container : Type.
  Variable elt : Type.
  Variable In : elt -> container -> Prop.
  Definition Equal_pw (s s' : container) : Prop :=
    forall a : elt, In a s <-> In a s'.
  Program Definition Equal_pw_Equivalence : Equivalence Equal_pw :=
    Build_Equivalence _ _ _ _.
  Next Obligation.
    constructor; auto.
  Qed.
  Next Obligation.
    constructor; firstorder.
  Qed.
  Next Obligation.
    constructor; firstorder eauto.
  Qed.
End Equal.
Hint Unfold Equal_pw.

(** * [FSet] : the interface of sets

   We define the class [FSet] of structures that implement finite
   sets. An instance of [FSet] for an ordered type [A] contains the
   type [set A] of sets of elements of type [A]. It also contains all
   the operations that these sets support : insertion, membership,
   etc. The specifications of these operations are in a different
   class (see below).

   The operations provided are the same as in the standard [FSets]
   library.

   The last member of the class states that for any ordered type [A],
   [set A] is itself an ordered type for pointwise equality. This makes
   building sets of sets possible.
   *)
Class FSet `{OrderedType A} := {
  (** The container type *)
  set : Type;

  (** The specification of all set operations is done
     with respect to the sole membership predicate. *)
  In : A -> set -> Prop;

  (** Set Operations  *)
  empty : set;
  is_empty : set -> bool;
  mem : A -> set -> bool;

  add : A -> set -> set;
  singleton : A -> set;
  remove : A -> set -> set;
  union : set -> set -> set;
  inter : set -> set -> set;
  diff : set -> set -> set;

  equal : set -> set -> bool;
  subset : set -> set -> bool;

  fold : forall {B : Type}, (A -> B -> B) -> set -> B -> B;
  for_all : (A -> bool) -> set -> bool;
  exists_ : (A -> bool) -> set -> bool;
  filter : (A -> bool) -> set -> set;
  partition : (A -> bool) -> set -> set * set;

  cardinal : set -> nat;
  elements : set -> list A;
  choose :  set -> option A;
  min_elt :  set -> option A;
  max_elt :  set -> option A;

  (** Sets should be ordered types as well, in order to be able
     to use sets in containers. *)
  FSet_OrderedType :>
    SpecificOrderedType _ (Equal_pw set A In)
}.

Arguments set _ {H FSet}.

(** Set notations (see below) are interpreted in scope [set_scope],
   delimited with key [set]. We bind it to the type [set]. *)
Delimit Scope set_scope with set.
Bind Scope set_scope with set.

(** All projections should be made opaque for tactics using [delta]-conversion,
   otherwise the underlying instances may appear during proofs, which then
   causes several problems (notations not being used, unification failures...).
   This doesnt stop computation with [compute] or [vm_compute] though, which is
   exactly what we want.
*)
Global Opaque
  set In empty is_empty mem add singleton remove
  union inter diff equal subset fold
  for_all exists_ filter partition cardinal elements choose
  FSet_OrderedType.

(** There follow definitions of predicates about sets expressable
   in terms of [In], and which are not provided by the [FSet] class. *)
Definition Equal `{FSet elt} s s' :=
  forall a : elt, In a s <-> In a s'.
Definition Subset `{FSet elt} s s' :=
  forall a : elt, In a s -> In a s'.
Definition Empty `{FSet elt} s :=
  forall a : elt, ~ In a s.
Definition For_all `{FSet elt} (P : elt -> Prop) s :=
  forall x, In x s -> P x.
Definition Exists `{FSet elt} (P : elt -> Prop) s :=
  exists x, In x s /\ P x.

(** We also define a couple of notations for set-related operations.
   These notations can be used to avoid ambiguity when dealing
   simultaneously with operations on lists and sets that have
   similar names ([mem], [In], ...). *)
Notation "s [=] t" := (Equal s t) (at level 70, no associativity) : set_scope.
Notation "s [<=] t" := (Subset s t) (at level 70, no associativity) : set_scope.
Notation "v '\In' S" := (In v S)(at level 70, no associativity) : set_scope.

Notation "'{}'" := (empty)(at level 0, no associativity) : set_scope.
Notation "'{' v '}'" := (singleton v) : set_scope.
Notation "'{' v ';' S '}'" := (add v S)(v at level 99) : set_scope.
Notation "'{' S '~' v '}'" := (remove v S)(S at level 99) : set_scope.
Notation "v '\in' S" := (mem v S)(at level 70, no associativity) : set_scope.
Notation "S '++' T" := (union S T) : set_scope.
Notation "S '\' T" := (diff S T) (at level 60, no associativity) : set_scope.

Set Implicit Arguments.
Unset Strict Implicit.

(** * [FSetSpecs] : finite sets' specification

   We provide the specifications of set operations in a separate class
   [FSetSpecs] parameterized by an [FSet] instance. The specifications
   are the same as in the standard [FSets.FSetInterface.S] module type,
   with the exception that compatibility hypotheses for functions used
   in [filter], [exists_], etc are replaced by morphism hypotheses,
   which can be handled by the typeclass mechanism.
   *)
Class FSetSpecs_In `(FSet A) := {
  In_1 : forall s (x y : A), x === y -> In x s -> In y s
}.
Class FSetSpecs_mem `(FSet A) := {
  mem_1 : forall s x, In x s -> mem x s = true;
  mem_2 : forall s x, mem x s = true -> In x s
}.
Class FSetSpecs_equal `(FSet A) := {
  equal_1 : forall s s', Equal s s' -> equal s s' = true;
  equal_2 : forall s s',  equal s s' = true -> Equal s s'
}.
Class FSetSpecs_subset `(FSet A) := {
  subset_1 : forall s s', Subset s s' -> subset s s' = true;
  subset_2 : forall s s', subset s s' = true -> Subset s s'
}.
Class FSetSpecs_empty `(FSet A) := {
  empty_1 : Empty empty
}.
Class FSetSpecs_is_empty `(FSet A) := {
  is_empty_1 : forall s, Empty s -> is_empty s = true;
  is_empty_2 : forall s, is_empty s = true -> Empty s
}.
Class FSetSpecs_add `(FSet A) := {
  add_1 : forall s (x y : A), x === y -> In y (add x s);
  add_2 : forall s x y, In y s -> In y (add x s);
  add_3 : forall s (x y : A), x =/= y -> In y (add x s) -> In y s
}.
Class FSetSpecs_remove `(FSet A) := {
  remove_1 : forall s (x y : A), x === y -> ~ In y (remove x s);
  remove_2 : forall s (x y : A),
    x =/= y -> In y s -> In y (remove x s);
  remove_3 : forall s x y, In y (remove x s) -> In y s
}.
Class FSetSpecs_singleton `(FSet A) := {
  singleton_1 : forall (x y : A), In y (singleton x) -> x === y;
  singleton_2 : forall (x y : A), x === y -> In y (singleton x)
}.
Class FSetSpecs_union `(FSet A) := {
  union_1 : forall s s' x,
    In x (union s s') -> In x s \/ In x s';
  union_2 : forall s s' x, In x s -> In x (union s s');
  union_3 : forall s s' x, In x s' -> In x (union s s')
}.
Class FSetSpecs_inter `(FSet A) := {
  inter_1 : forall s s' x, In x (inter s s') -> In x s;
  inter_2 : forall s s' x, In x (inter s s') -> In x s';
  inter_3 : forall s s' x,
    In x s -> In x s' -> In x (inter s s')
}.
Class FSetSpecs_diff `(FSet A) := {
  diff_1 : forall s s' x, In x (diff s s') -> In x s;
  diff_2 : forall s s' x, In x (diff s s') -> ~ In x s';
  diff_3 : forall s s' x,
    In x s -> ~ In x s' -> In x (diff s s')
}.
Class FSetSpecs_fold `(FSet A) := {
  fold_1 : forall s (B : Type) (i : B) (f : A -> B -> B),
      fold f s i = fold_left (fun a e => f e a) (elements s) i
}.
Class FSetSpecs_cardinal `(FSet A) := {
  cardinal_1 : forall s, cardinal s = length (elements s)
}.
Class FSetSpecs_filter `(FSet A) := {
  filter_1 : forall s x f `{Proper _ (_eq ==> @eq bool) f},
    In x (filter f s) -> In x s;
  filter_2 : forall s x f `{Proper _ (_eq ==> @eq bool) f},
    In x (filter f s) -> f x = true;
  filter_3 : forall s x f `{Proper _ (_eq ==> @eq bool) f},
    In x s -> f x = true -> In x (filter f s)
}.
Class FSetSpecs_for_all `(FSet A) := {
  for_all_1 : forall s f `{Proper _ (_eq ==> @eq bool) f},
    For_all (fun x => f x = true) s -> for_all f s = true;
  for_all_2 : forall s f `{Proper _ (_eq ==> @eq bool) f},
    for_all f s = true -> For_all (fun x => f x = true) s
}.
Class FSetSpecs_exists `(FSet A) := {
  exists_1 : forall s f `{Proper _ (_eq ==> @eq bool) f},
    Exists (fun x => f x = true) s -> exists_ f s = true;
  exists_2 : forall s f `{Proper _ (_eq ==> @eq bool) f},
    exists_ f s = true -> Exists (fun x => f x = true) s
}.
Class FSetSpecs_partition `(FSet A) := {
  partition_1 : forall s f `{Proper _ (_eq ==> @eq bool) f},
    Equal (fst (partition f s)) (filter f s);
  partition_2 : forall s f `{Proper _ (_eq ==> @eq bool) f},
    Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
}.
Class FSetSpecs_elements `(FSet A) := {
  elements_1 : forall s x, In x s -> InA _eq x (elements s);
  elements_2 : forall s x, InA _eq x (elements s) -> In x s;
  elements_3 : forall s, sort _lt (elements s);
  elements_3w : forall s, NoDupA _eq (elements s)
}.
Class FSetSpecs_choose `(FSet A) := {
  choose_1 : forall s x, choose s = Some x -> In x s;
  choose_2 : forall s, choose s = None -> Empty s;
  choose_3 : forall s s' x y,
    choose s = Some x -> choose s' = Some y -> Equal s s' -> x === y
}.
Class FSetSpecs_min_elt `(FSet A) := {
  min_elt_1 : forall s x, min_elt s = Some x -> In x s;
  min_elt_2 : forall s x y,
    min_elt s = Some x -> In y s -> ~ y <<< x;
  min_elt_3 : forall s, min_elt s = None -> Empty s
}.
Class FSetSpecs_max_elt `(FSet A) := {
  max_elt_1 : forall s x, max_elt s = Some x -> In x s;
  max_elt_2 : forall s x y,
    max_elt s = Some x -> In y s -> ~ x <<< y;
  max_elt_3 : forall s, max_elt s = None -> Empty s
}.

Class FSetSpecs `(F : FSet A) := {
  FFSetSpecs_In :> FSetSpecs_In F;
  FFSetSpecs_mem :> FSetSpecs_mem F;
  FFSetSpecs_equal :> FSetSpecs_equal F;
  FFSetSpecs_subset :> FSetSpecs_subset F;
  FFSetSpecs_empty :> FSetSpecs_empty F;
  FFSetSpecs_is_empty :> FSetSpecs_is_empty F;
  FFSetSpecs_add :> FSetSpecs_add F;
  FFSetSpecs_remove :> FSetSpecs_remove F;
  FFSetSpecs_singleton :> FSetSpecs_singleton F;
  FFSetSpecs_union :> FSetSpecs_union F;
  FFSetSpecs_inter :> FSetSpecs_inter F;
  FFSetSpecs_diff :> FSetSpecs_diff F;
  FFSetSpecs_fold :> FSetSpecs_fold F;
  FFSetSpecs_cardinal :> FSetSpecs_cardinal F;
  FFSetSpecs_filter :> FSetSpecs_filter F;
  FFSetSpecs_for_all :> FSetSpecs_for_all F;
  FFSetSpecs_exists :> FSetSpecs_exists F;
  FFSetSpecs_partition :> FSetSpecs_partition F;
  FFSetSpecs_elements :> FSetSpecs_elements F;
  FFSetSpecs_choose :> FSetSpecs_choose F;
  FFSetSpecs_min_elt :> FSetSpecs_min_elt F;
  FFSetSpecs_max_elt :> FSetSpecs_max_elt F
}.
(* About FSetSpecs. *)

(* Because of a bug (or limitation, depending on your leniency)
   of interaction between hints and implicit typeclasses parameters
   we define aliases to add as hints. *)
Definition zmem_1 `{H : @FSetSpecs A HA F} :=
  @mem_1 _ _ _ (@FFSetSpecs_mem _ _ _ H).
Definition zequal_1 `{H : @FSetSpecs A HA F} :=
  @equal_1 _ _ _ (@FFSetSpecs_equal _ _ _ H).
Definition zsubset_1 `{H : @FSetSpecs A HA F} :=
  @subset_1 _ _ _ (@FFSetSpecs_subset _ _ _ H).
Definition zempty_1 `{H : @FSetSpecs A HA F} :=
  @empty_1 _ _ _ (@FFSetSpecs_empty _ _ _ H).
Definition zis_empty_1 `{H : @FSetSpecs A HA F} :=
  @is_empty_1 _ _ _ (@FFSetSpecs_is_empty _ _ _ H).
Definition zchoose_1 `{H : @FSetSpecs A HA F} :=
  @choose_1 _ _ _ (@FFSetSpecs_choose _ _ _ H).
Definition zchoose_2 `{H : @FSetSpecs A HA F} :=
  @choose_2 _ _ _ (@FFSetSpecs_choose _ _ _ H).
Definition zadd_1 `{H : @FSetSpecs A HA F} :=
  @add_1 _ _ _ (@FFSetSpecs_add _ _ _ H).
Definition zadd_2 `{H : @FSetSpecs A HA F} :=
  @add_2 _ _ _ (@FFSetSpecs_add _ _ _ H).
Definition zremove_1 `{H : @FSetSpecs A HA F} :=
  @remove_1 _ _ _ (@FFSetSpecs_remove _ _ _ H).
Definition zremove_2 `{H : @FSetSpecs A HA F} :=
  @remove_2 _ _ _ (@FFSetSpecs_remove _ _ _ H).
Definition zsingleton_2 `{H : @FSetSpecs A HA F} :=
  @singleton_2 _ _ _ (@FFSetSpecs_singleton _ _ _ H).
Definition zunion_1 `{H : @FSetSpecs A HA F} :=
  @union_1 _ _ _ (@FFSetSpecs_union _ _ _ H).
Definition zunion_2 `{H : @FSetSpecs A HA F} :=
  @union_2 _ _ _ (@FFSetSpecs_union _ _ _ H).
Definition zunion_3 `{H : @FSetSpecs A HA F} :=
  @union_3 _ _ _ (@FFSetSpecs_union _ _ _ H).
Definition zinter_3 `{H : @FSetSpecs A HA F} :=
  @inter_3 _ _ _ (@FFSetSpecs_inter _ _ _ H).
Definition zdiff_3 `{H : @FSetSpecs A HA F} :=
  @diff_3 _ _ _ (@FFSetSpecs_diff _ _ _ H).
Definition zfold_1 `{H : @FSetSpecs A HA F} :=
  @fold_1 _ _ _ (@FFSetSpecs_fold _ _ _ H).
Definition zfilter_3 `{H : @FSetSpecs A HA F} :=
  @filter_3 _ _ _ (@FFSetSpecs_filter _ _ _ H).
Definition zfor_all_1 `{H : @FSetSpecs A HA F} :=
  @for_all_1 _ _ _ (@FFSetSpecs_for_all _ _ _ H).
Definition zexists_1 `{H : @FSetSpecs A HA F} :=
  @exists_1 _ _ _ (@FFSetSpecs_exists _ _ _ H).
Definition zpartition_1 `{H : @FSetSpecs A HA F} :=
  @partition_1 _ _ _ (@FFSetSpecs_partition _ _ _ H).
Definition zpartition_2 `{H : @FSetSpecs A HA F} :=
  @partition_2 _ _ _ (@FFSetSpecs_partition _ _ _ H).
Definition zelements_1 `{H : @FSetSpecs A HA F} :=
  @elements_1 _ _ _ (@FFSetSpecs_elements _ _ _ H).
Definition zelements_3w `{H : @FSetSpecs A HA F} :=
  @elements_3w _ _ _ (@FFSetSpecs_elements _ _ _ H).
Definition zelements_3 `{H : @FSetSpecs A HA F} :=
  @elements_3 _ _ _ (@FFSetSpecs_elements _ _ _ H).

Definition zIn_1 `{H : @FSetSpecs A HA F} :=
  @In_1 _ _ _ (@FFSetSpecs_In _ _ _ H).
Definition zmem_2 `{H : @FSetSpecs A HA F} :=
  @mem_2 _ _ _ (@FFSetSpecs_mem _ _ _ H).
Definition zequal_2 `{H : @FSetSpecs A HA F} :=
  @equal_2 _ _ _ (@FFSetSpecs_equal _ _ _ H).
Definition zsubset_2 `{H : @FSetSpecs A HA F} :=
  @subset_2 _ _ _ (@FFSetSpecs_subset _ _ _ H).
Definition zis_empty_2 `{H : @FSetSpecs A HA F} :=
  @is_empty_2 _ _ _ (@FFSetSpecs_is_empty _ _ _ H).
Definition zadd_3 `{H : @FSetSpecs A HA F} :=
  @add_3 _ _ _ (@FFSetSpecs_add _ _ _ H).
Definition zremove_3 `{H : @FSetSpecs A HA F} :=
  @remove_3 _ _ _ (@FFSetSpecs_remove _ _ _ H).
Definition zsingleton_1 `{H : @FSetSpecs A HA F} :=
  @singleton_1 _ _ _ (@FFSetSpecs_singleton _ _ _ H).
Definition zinter_1 `{H : @FSetSpecs A HA F} :=
  @inter_1 _ _ _ (@FFSetSpecs_inter _ _ _ H).
Definition zinter_2 `{H : @FSetSpecs A HA F} :=
  @inter_2 _ _ _ (@FFSetSpecs_inter _ _ _ H).
Definition zdiff_1 `{H : @FSetSpecs A HA F} :=
  @diff_1 _ _ _ (@FFSetSpecs_diff _ _ _ H).
Definition zdiff_2 `{H : @FSetSpecs A HA F} :=
  @diff_2 _ _ _ (@FFSetSpecs_diff _ _ _ H).
Definition zfilter_1 `{H : @FSetSpecs A HA F} :=
  @filter_1 _ _ _ (@FFSetSpecs_filter _ _ _ H).
Definition zfilter_2 `{H : @FSetSpecs A HA F} :=
  @filter_2 _ _ _ (@FFSetSpecs_filter _ _ _ H).
Definition zfor_all_2 `{H : @FSetSpecs A HA F} :=
  @for_all_2 _ _ _ (@FFSetSpecs_for_all _ _ _ H).
Definition zexists_2 `{H : @FSetSpecs A HA F} :=
  @exists_2 _ _ _ (@FFSetSpecs_exists _ _ _ H).
Definition zelements_2 `{H : @FSetSpecs A HA F} :=
  @elements_2 _ _ _ (@FFSetSpecs_elements _ _ _ H).
Definition zmin_elt_1 `{H : @FSetSpecs A HA F} :=
  @min_elt_1 _ _ _ (@FFSetSpecs_min_elt _ _ _ H).
Definition zmin_elt_2 `{H : @FSetSpecs A HA F} :=
  @min_elt_2 _ _ _ (@FFSetSpecs_min_elt _ _ _ H).
Definition zmin_elt_3 `{H : @FSetSpecs A HA F} :=
  @min_elt_3 _ _ _ (@FFSetSpecs_min_elt _ _ _ H).
Definition zmax_elt_1 `{H : @FSetSpecs A HA F} :=
  @max_elt_1 _ _ _ (@FFSetSpecs_max_elt _ _ _ H).
Definition zmax_elt_2 `{H : @FSetSpecs A HA F} :=
  @max_elt_2 _ _ _ (@FFSetSpecs_max_elt _ _ _ H).
Definition zmax_elt_3 `{H : @FSetSpecs A HA F} :=
  @max_elt_3 _ _ _ (@FFSetSpecs_max_elt _ _ _ H).

Hint Resolve @zmem_1 @zequal_1 @zsubset_1 @zempty_1
  @zis_empty_1 @zchoose_1 @zchoose_2 @zadd_1 @zadd_2 @zremove_1
  @zremove_2 @zsingleton_2 @zunion_1 @zunion_2 @zunion_3
  @zinter_3 @zdiff_3 @zfold_1 @zfilter_3 @zfor_all_1 @zexists_1
    @zpartition_1 @zpartition_2 @zelements_1 @zelements_3w @zelements_3
    : set.
Hint Immediate @zIn_1 @zmem_2 @zequal_2 @zsubset_2 @zis_empty_2 @zadd_3
  @zremove_3 @zsingleton_1 @zinter_1 @zinter_2 @zdiff_1 @zdiff_2
  @zfilter_1 @zfilter_2 @zfor_all_2 @zexists_2 @zelements_2
    @zmin_elt_1 @zmin_elt_2 @zmin_elt_3 @zmax_elt_1 @zmax_elt_2 @zmax_elt_3
    : set.
(* Typeclasses Opaque set. *)


(** This module defines two bijections: [bijNN : nat * nat -> nat] and
      [bijNpN : nat + nat -> nat]. *)

Section Bijection_Naturals.

  Require Import Coq.Arith.Wf_nat.
  Require Import ArithLemmas.
  Require Import Lt.
  Require Import Le.
  Require Import Plus.
  Require Import Compare_dec.
  Require Import Coq.Program.Wf.

  Definition NN := (nat*nat)%type.
  Definition NpN := (nat + nat)%type.

  (** * Bijection [nat * nat -> nat]

   Every positive integer [n] can be written uniquely
   as [(2p + 1). 2^q], so we define our bijection as
   follows.
   *)

  Fixpoint bijNNp (a b : nat) : nat :=
    match a, b with
      | 0, b => S (b + b)
      | S n, b => 2 * bijNNp n b
    end.

  Definition bijNN (p : NN) : nat := pred (bijNNp (fst p) (snd p)).

  (** ** Forward map *)

  (** bijNNp is positive. *)
  Lemma bijNNp_pos : forall a b, 0 < bijNNp a b.
  Proof.
    intros.
    induction a.
    simpl. apply lt_0_Sn.
    simpl.
    apply (lt_plus_trans 0 (bijNNp a b) _ IHa).
  Qed.

  (** We characterize the graph of [bijNNp].
    *)
  Lemma bijNNp_carac : forall a b, (bijNNp a b = S (b + b) /\ a = 0) \/ (even (bijNNp a b) /\ bijNNp a b = 2 * bijNNp (pred a) b).
  Proof.
    intros.
    destruct a.

    - (* a = 0 *)
      apply or_introl. split.
      reflexivity. reflexivity.

    - (* S a *)
      apply or_intror.
      simpl. split. rewrite <- plus_n_O. apply double_is_even.
      reflexivity.
  Qed.

  (** ** Lemmas for the termination of the reverse map *)

  Lemma n_le_S_m : forall n m, n < S m -> (n = m) \/ (n < m).
  Proof.
    intros.
    apply lt_le_S in H.
    apply le_S_n in H.
    apply or_comm.
    apply (le_lt_or_eq _ _ H).
  Defined.

  Lemma div2_n_le_n_bi : forall n, div2 (S n) < (S n) /\ div2 (S (S n)) < (S (S n)).
  Proof.
    induction n.
    - (* n = 0 *)
      auto.
    - (* S n *)
      destruct IHn.
      split. assumption.
      simpl. apply lt_n_S.
      destruct n. auto.
      simpl in H. apply (lt_trans _ (S (S n)) _ H).
      auto.
  Defined.

  Lemma div2_n_le : forall n, div2 (S (S n)) < (S (S n)).
  Proof.
    intro.
    apply div2_n_le_n_bi.
  Defined.

  (** ** Definition of the reverse map *)

  Program Fixpoint bijNN_rev (n : nat) { measure n } : { q : NN | (n = 0) \/ (n = S (bijNN q))} :=
    match n with
      | 0 => (0,0)
      | 1 => (0,0)
      | S (S p) =>
        match even_odd_dec n with
         | left e => let (a,pr) := bijNN_rev (S (div2 p)) in (S (fst a),(snd a))
         | right o => (0, S (div2 p))
        end
    end.
  Obligation 3.
  apply div2_n_le.
  Qed.

  Obligation 4.
  apply or_intror.
  destruct pr as [pr1|pr2].
  - inversion pr1.
  - apply eq_S.
    inversion pr2.
    specialize (bijNN_rev (S p)).
    destruct bijNN_rev.
    auto.
    destruct o.
    + inversion H.
    + unfold bijNN. simpl.
      unfold bijNN in H0.
      rewrite <- plus_n_O.
      assert (pred (S p) = pred (pred (bijNNp (fst a) (snd a) + (bijNNp (fst a) (snd a))))).
      simpl.
      rewrite pred_sum.
      * rewrite <- H0.
        inversion e. inversion H2.
        rewrite <- double_plus.
        apply (even_double p H4).
      * apply bijNNp_pos.
      * apply bijNNp_pos.
      * simpl in H1.
        rewrite H1.
        rewrite <- (S_pred _ 0).
        reflexivity.
        apply lt_pred.
        apply (plus_le_lt_compat 1 _ 0).
        apply lt_le_S.
        apply bijNNp_pos.
        apply bijNNp_pos.
  Qed.

  Obligation 5.
  apply or_intror.
  apply eq_S.
  specialize (bijNN_rev (S p)).
  destruct bijNN_rev.
  - auto.
  - destruct o0. inversion H.
    inversion o.
    inversion H1.
    unfold bijNN. simpl.
    apply eq_S.
    rewrite <- plus_n_Sm.
    rewrite <- double_plus.
    apply (odd_double _ H3).
  Qed.

  Definition bijNNinv (n : nat) : NN :=
    match bijNN_rev (S n) with
      | exist _ a P => a
    end.

  (** ** The two map are mutual inverses *)

  Lemma bijNNp_inj : forall x y z w, bijNNp x y = bijNNp z w -> (x,y) = (z,w).
  Proof.
    intro x.
    induction x.

    - (* x = 0 *)
      induction y.

      + (* x, y = 0 *)
        intros. simpl in H.
        (* case analysis on z *)
        destruct z.
        * (* z = 0 *)
          (* case analysis on w *)
          destruct w.
          reflexivity.
          (* w > 0 *)
          simpl in H. inversion H.
        * (* z > 0 *)
          simpl in H.
          assert (bijNNp z w > 0).
          apply bijNNp_pos.
          destruct (bijNNp z w).
          inversion H.
          rewrite plus_Sn_m in H.
          rewrite plus_Sn_m in H.
          rewrite <- plus_n_Sm in H.
          inversion H.

      + (* x = 0, y > 0 *)
        intros.
        simpl in H.
        assert ((bijNNp z w = S (w + w) /\ z = 0) \/ (even (bijNNp z w) /\ bijNNp z w = 2 * bijNNp (pred z) w)).
        apply bijNNp_carac.
        (* case analysis on the carac *)
        destruct H0. destruct H0.
        * rewrite H1.
          rewrite H0 in H.
          inversion H.
          rewrite <- plus_Sn_m in H3.
          apply double_injective in H3.
          rewrite <- H3.
          reflexivity.
        * (* absurd case of the carac *)
          destruct H0.
          rewrite <- H in H0.
          inversion H0.
          rewrite <- plus_Sn_m in H3.
          apply (not_even_and_odd _ (double_is_even (S y))) in H3.
          inversion H3.

    - (* x > 0 *)
      intros.
      simpl in H.
      rewrite <- plus_n_O in H.
      (* let's show that bijNNp z w is even and give that to carac *)
      assert ((bijNNp z w = S (w + w) /\ z = 0) \/ (even (bijNNp z w) /\ bijNNp z w = 2 * bijNNp (pred z) w)).
      apply bijNNp_carac.
      destruct H0.
      + (* absurd case of the carac *)
        destruct H0.
        assert (odd (bijNNp z w)).
        rewrite H0.
        apply odd_S.
        apply double_is_even.
        assert (even (bijNNp z w)).
        rewrite <- H.
        apply double_is_even.
        apply (not_even_and_odd _ H3) in H2.
        inversion H2.
      + (* good case *)
        destruct H0.
        simpl in H1.
        rewrite <- plus_n_O in H1.
        rewrite <- H in H1.
        apply double_injective in H1.
        apply IHx in H1.
        inversion H1.
        (* final case analysis *)
        destruct z.
        * (* absurd case *)
          simpl in H0.
          assert (even (w + w)).
          apply double_is_even.
          inversion H0.
          apply (not_even_and_odd _ H2) in H6.
          inversion H6.
        * (* good case *)
          reflexivity.
  Qed.

  Lemma bijNN_inj : forall p q, bijNN p = bijNN q -> p = q.
  Proof.
    unfold bijNN.
    intros.
    destruct p, q.
    simpl in H.
    apply pred_inj in H.
    apply bijNNp_inj. apply H.
    apply bijNNp_pos.
    apply bijNNp_pos.
  Qed.

  Theorem bijNN_bijNNinv : forall n, bijNN (bijNNinv n) = n.
  Proof.
    intros.
    unfold bijNNinv.
    destruct (bijNN_rev).
    destruct o. inversion H.
    inversion H.
    reflexivity.
  Qed.

  Theorem bijNNinv_bijNN : forall p, bijNNinv (bijNN p) = p.
  Proof.
    intro.
    apply bijNN_inj.
    rewrite bijNN_bijNNinv.
    reflexivity.
  Qed.

  Proposition bijNN_surj : forall n : nat, exists p : NN, n = bijNN p.
  Proof.
    intro.
    exists (bijNNinv n).
    symmetry.
    apply bijNN_bijNNinv.
  Qed.

  Proposition bijNNinv_surj : forall p : NN, exists n : nat, p = bijNNinv n.
  Proof.
    intro.
    exists (bijNN p).
    symmetry.
    apply bijNNinv_bijNN.
  Qed.

  Proposition bijNNinv_inj : forall x y, bijNNinv x = bijNNinv y -> x = y.
  Proof.
    intros.
    rewrite <- bijNN_bijNNinv.
    rewrite <- H.
    rewrite bijNN_bijNNinv.
    reflexivity.
  Qed.

  Definition bijNN1 n := fst (bijNNinv n).
  Definition bijNN2 n := snd (bijNNinv n).

  Proposition bijNN1_eq : forall p, bijNN1 (bijNN p) = fst p.
  Proof.
    intro. unfold bijNN1. rewrite bijNNinv_bijNN.
    reflexivity.
  Qed.

  Proposition bijNN2_eq : forall p, bijNN2 (bijNN p) = snd p.
  Proof.
    intro. unfold bijNN2. rewrite bijNNinv_bijNN.
    reflexivity.
  Qed.

  (** * Bijection [nat + nat -> nat] *)

  (** ** Definition of the functions
      This time the definition of both maps is much simpler. *)

  Definition bijNpN (p : NpN) : nat :=
    match p with
      | inl a => double a
      | inr a => S (double a)
    end.

  Definition bijNpNinv (x : nat) : NpN :=
    match even_odd_dec x with
      | left e => inl (div2 x)
      | right o => inr (div2 x)
    end.

  (** ** They are mutual inverses *)

  Theorem bijNpN_bij1 : forall n, bijNpN (bijNpNinv n) = n.
  Proof.
    intro.
    unfold bijNpNinv.
    destruct (even_odd_dec n).

    - (* n is even *)
      simpl. symmetry.
      apply (even_double _ e).

    - (* n is odd *)
      simpl. symmetry.
      apply (odd_double _ o).
  Qed.

  Theorem bijNpN_bij2 : forall p, bijNpNinv (bijNpN p) = p.
  Proof.
    intro.
    unfold bijNpN, bijNpNinv.
    destruct p.

    - (* double n *)
      destruct (even_odd_dec (double n)).
      + (* good case *)
        rewrite double_2times.
        rewrite div2_double. reflexivity.
      + (* absurd case *)
        apply (not_even_and_odd _ (double_is_even n)) in o.
        inversion o.

    - (* S (double n) *)
      destruct (even_odd_dec (S (double n))).
      + (* absurd case *)
        assert (odd (S (double n))).
        apply odd_S. apply double_is_even.
        contradiction (not_even_and_odd _ e H).
      + (* good case *)
        rewrite double_2times.
        rewrite div2_double_plus_one.
        reflexivity.
  Qed.

End Bijection_Naturals.


Require Import Coq.Arith.Arith.
Require Import Coq.omega.Omega.
Require Lists.List.

Inductive t (A: Type) :=
| stream: list A -> t A.

Definition empty {A} := stream A nil.

Definition length {A} (s: t A): nat :=
  match s with
  | stream  _ l => List.length l
  end.

Definition is_finished {A} (s: t A): bool :=
  match s with
  | stream _ nil => true
  | _ => false
  end.

Definition take {A} (s: t A): option (A * t A) :=
  match s with
  | stream _ l =>
    match l with
    | nil => None
    | cons a l => Some (a, stream _ l)
    end
  end.

Lemma take_none_length: forall (A: Type)(s: t A),
    take s = None -> length s = 0.
Proof.
  unfold take, length. intros.
  destruct s. destruct l.
  - trivial.
  - discriminate.
Qed.

Lemma take_some_length: forall (A: Type)(s s': t A)(r: A),
    take s = Some (r, s') -> length s = S (length s').
Proof.
  unfold take, length. intros.
  destruct s. destruct s'. destruct l.
  - discriminate.
  - injection H. intros. subst. reflexivity.
Qed.

Lemma take_eq: forall (A: Type) (s s': t A),
    take s = take s' -> s = s'.
Proof.
  unfold take. intros.
  destruct s, s', l, l0; try discriminate.
  - reflexivity.
  - injection H; intros. subst. reflexivity.
Qed.

Definition put {A} (v: A) (s: t A): t A :=
  match s with
  | stream _ l => stream _ (cons v l)
  end.

Lemma put_length: forall (A: Type)(v: A)(s: t A),
    length (put v s) = S (length s).
Proof.
  unfold put, length. intros.
  destruct s. reflexivity.
Qed.

Fixpoint put_list {A} (l: list A) (s: t A): t A :=
  match l with
  | nil => s
  | cons a l => put_list l (put a s)
  end.

Definition puts {A}
           (f: t A -> t A)
           (l: list A): Prop :=
  eq (f empty) (put_list l empty).

Definition bit := t bool.

Module BitNotations.
  Notation "0" := (false): bit_scope.
  Notation "1" := (true): bit_scope.
  Delimit Scope bit_scope with bit.
End BitNotations.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Greatest Common Divisor *)

Require Import NZAxioms NZMulOrder.

(** Interface of a gcd function, then its specification on naturals *)

Module Type Gcd (Import A : Typ).
 Parameter Inline gcd : t -> t -> t.
End Gcd.

Module Type NZGcdSpec (A : NZOrdAxiomsSig')(B : Gcd A).
 Import A B.
 Definition divide n m := exists p, m == p*n.
 Local Notation "( n | m )" := (divide n m) (at level 0).
 Axiom gcd_divide_l : forall n m, (gcd n m | n).
 Axiom gcd_divide_r : forall n m, (gcd n m | m).
 Axiom gcd_greatest : forall n m p, (p | n) -> (p | m) -> (p | gcd n m).
 Axiom gcd_nonneg : forall n m, 0 <= gcd n m.
End NZGcdSpec.

Module Type DivideNotation (A:NZOrdAxiomsSig')(B:Gcd A)(C:NZGcdSpec A B).
 Import A B C.
 Notation "( n | m )" := (divide n m) (at level 0).
End DivideNotation.

Module Type NZGcd (A : NZOrdAxiomsSig) := Gcd A <+ NZGcdSpec A.
Module Type NZGcd' (A : NZOrdAxiomsSig) :=
 Gcd A <+ NZGcdSpec A <+ DivideNotation A.

(** Derived properties of gcd *)

Module NZGcdProp
 (Import A : NZOrdAxiomsSig')
 (Import B : NZGcd' A)
 (Import C : NZMulOrderProp A).

(** Results concerning divisibility*)

Instance divide_wd : Proper (eq==>eq==>iff) divide.
Proof.
 unfold divide. intros x x' Hx y y' Hy.
 setoid_rewrite Hx. setoid_rewrite Hy. easy.
Qed.

Lemma divide_1_l : forall n, (1 | n).
Proof.
 intros n. exists n. now nzsimpl.
Qed.

Lemma divide_0_r : forall n, (n | 0).
Proof.
 intros n. exists 0. now nzsimpl.
Qed.

Lemma divide_0_l : forall n, (0 | n) -> n==0.
Proof.
 intros n (m,Hm). revert Hm. now nzsimpl.
Qed.

Lemma eq_mul_1_nonneg : forall n m,
 0<=n -> n*m == 1 -> n==1 /\ m==1.
Proof.
 intros n m Hn H.
 le_elim Hn.
 destruct (lt_ge_cases m 0) as [Hm|Hm].
 generalize (mul_pos_neg n m Hn Hm). order'.
 le_elim Hm.
 apply le_succ_l in Hn. rewrite <- one_succ in Hn.
 le_elim Hn.
 generalize (lt_1_mul_pos n m Hn Hm). order.
 rewrite <- Hn, mul_1_l in H. now split.
 rewrite <- Hm, mul_0_r in H. order'.
 rewrite <- Hn, mul_0_l in H. order'.
Qed.

Lemma eq_mul_1_nonneg' : forall n m,
 0<=m -> n*m == 1 -> n==1 /\ m==1.
Proof.
 intros n m Hm H. rewrite mul_comm in H.
 now apply and_comm, eq_mul_1_nonneg.
Qed.

Lemma divide_1_r_nonneg : forall n, 0<=n -> (n | 1) -> n==1.
Proof.
 intros n Hn (m,Hm). symmetry in Hm.
 now apply (eq_mul_1_nonneg' m n).
Qed.

Lemma divide_refl : forall n, (n | n).
Proof.
 intros n. exists 1. now nzsimpl.
Qed.

Lemma divide_trans : forall n m p, (n | m) -> (m | p) -> (n | p).
Proof.
 intros n m p (q,Hq) (r,Hr). exists (r*q).
 now rewrite Hr, Hq, mul_assoc.
Qed.

Instance divide_reflexive : Reflexive divide | 5 := divide_refl.
Instance divide_transitive : Transitive divide | 5 := divide_trans.

(** Due to sign, no general antisymmetry result *)

Lemma divide_antisym_nonneg : forall n m,
 0<=n -> 0<=m -> (n | m) -> (m | n) -> n == m.
Proof.
 intros n m Hn Hm (q,Hq) (r,Hr).
 le_elim Hn.
 destruct (lt_ge_cases q 0) as [Hq'|Hq'].
 generalize (mul_neg_pos q n Hq' Hn). order.
 rewrite Hq, mul_assoc in Hr. symmetry in Hr.
 apply mul_id_l in Hr; [|order].
 destruct (eq_mul_1_nonneg' r q) as [_ H]; trivial.
 now rewrite H, mul_1_l in Hq.
 rewrite <- Hn, mul_0_r in Hq. now rewrite <- Hn.
Qed.

Lemma mul_divide_mono_l : forall n m p, (n | m) -> (p * n | p * m).
Proof.
 intros n m p (q,Hq). exists q. now rewrite mul_shuffle3, Hq.
Qed.

Lemma mul_divide_mono_r : forall n m p, (n | m) -> (n * p | m * p).
Proof.
 intros n m p (q,Hq). exists q. now rewrite mul_assoc, Hq.
Qed.

Lemma mul_divide_cancel_l : forall n m p, p ~= 0 ->
 ((p * n | p * m) <-> (n | m)).
Proof.
 intros n m p Hp. split.
 intros (q,Hq). exists q. now rewrite mul_shuffle3, mul_cancel_l in Hq.
 apply mul_divide_mono_l.
Qed.

Lemma mul_divide_cancel_r : forall n m p, p ~= 0 ->
 ((n * p | m * p) <-> (n | m)).
Proof.
 intros. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l.
Qed.

Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p).
Proof.
 intros n m p (q,Hq) (r,Hr). exists (q+r).
 now rewrite mul_add_distr_r, Hq, Hr.
Qed.

Lemma divide_mul_l : forall n m p, (n | m) -> (n | m * p).
Proof.
 intros n m p (q,Hq). exists (q*p). now rewrite mul_shuffle0, Hq.
Qed.

Lemma divide_mul_r : forall n m p, (n | p) -> (n | m * p).
Proof.
 intros n m p. rewrite mul_comm. apply divide_mul_l.
Qed.

Lemma divide_factor_l : forall n m, (n | n * m).
Proof.
 intros. apply divide_mul_l, divide_refl.
Qed.

Lemma divide_factor_r : forall n m, (n | m * n).
Proof.
 intros. apply divide_mul_r, divide_refl.
Qed.

Lemma divide_pos_le : forall n m, 0 < m -> (n | m) -> n <= m.
Proof.
 intros n m Hm (q,Hq).
 destruct (le_gt_cases n 0) as [Hn|Hn]. order.
 rewrite Hq.
 destruct (lt_ge_cases q 0) as [Hq'|Hq'].
 generalize (mul_neg_pos q n Hq' Hn). order.
 le_elim Hq'.
 rewrite <- (mul_1_l n) at 1. apply mul_le_mono_pos_r; trivial.
 now rewrite one_succ, le_succ_l.
 rewrite <- Hq', mul_0_l in Hq. order.
Qed.

(** Basic properties of gcd *)

Lemma gcd_unique : forall n m p,
 0<=p -> (p|n) -> (p|m) ->
 (forall q, (q|n) -> (q|m) -> (q|p)) ->
 gcd n m == p.
Proof.
 intros n m p Hp Hn Hm H.
 apply divide_antisym_nonneg; trivial. apply gcd_nonneg.
 apply H. apply gcd_divide_l. apply gcd_divide_r.
 now apply gcd_greatest.
Qed.

Instance gcd_wd : Proper (eq==>eq==>eq) gcd.
Proof.
 intros x x' Hx y y' Hy.
 apply gcd_unique.
 apply gcd_nonneg.
 rewrite Hx. apply gcd_divide_l.
 rewrite Hy. apply gcd_divide_r.
 intro. rewrite Hx, Hy. apply gcd_greatest.
Qed.

Lemma gcd_divide_iff : forall n m p,
  (p | gcd n m) <-> (p | n) /\ (p | m).
Proof.
 intros. split. split.
 transitivity (gcd n m); trivial using gcd_divide_l.
 transitivity (gcd n m); trivial using gcd_divide_r.
 intros (H,H'). now apply gcd_greatest.
Qed.

Lemma gcd_unique_alt : forall n m p, 0<=p ->
 (forall q, (q|p) <-> (q|n) /\ (q|m)) ->
 gcd n m == p.
Proof.
 intros n m p Hp H.
 apply gcd_unique; trivial.
 apply H. apply divide_refl.
 apply H. apply divide_refl.
 intros. apply H. now split.
Qed.

Lemma gcd_comm : forall n m, gcd n m == gcd m n.
Proof.
 intros. apply gcd_unique_alt; try apply gcd_nonneg.
 intros. rewrite and_comm. apply gcd_divide_iff.
Qed.

Lemma gcd_assoc : forall n m p, gcd n (gcd m p) == gcd (gcd n m) p.
Proof.
 intros. apply gcd_unique_alt; try apply gcd_nonneg.
 intros. now rewrite !gcd_divide_iff, and_assoc.
Qed.

Lemma gcd_0_l_nonneg : forall n, 0<=n -> gcd 0 n == n.
Proof.
 intros. apply gcd_unique; trivial.
 apply divide_0_r.
 apply divide_refl.
Qed.

Lemma gcd_0_r_nonneg : forall n, 0<=n -> gcd n 0 == n.
Proof.
 intros. now rewrite gcd_comm, gcd_0_l_nonneg.
Qed.

Lemma gcd_1_l : forall n, gcd 1 n == 1.
Proof.
 intros. apply gcd_unique; trivial using divide_1_l, le_0_1.
Qed.

Lemma gcd_1_r : forall n, gcd n 1 == 1.
Proof.
 intros. now rewrite gcd_comm, gcd_1_l.
Qed.

Lemma gcd_diag_nonneg : forall n, 0<=n -> gcd n n == n.
Proof.
 intros. apply gcd_unique; trivial using divide_refl.
Qed.

Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0.
Proof.
 intros.
 generalize (gcd_divide_l n m). rewrite H. apply divide_0_l.
Qed.

Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0.
Proof.
 intros. apply gcd_eq_0_l with n. now rewrite gcd_comm.
Qed.

Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0.
Proof.
 intros. split. split.
 now apply gcd_eq_0_l with m.
 now apply gcd_eq_0_r with n.
 intros (EQ,EQ'). rewrite EQ, EQ'. now apply gcd_0_r_nonneg.
Qed.

Lemma gcd_mul_diag_l : forall n m, 0<=n -> gcd n (n*m) == n.
Proof.
 intros n m Hn. apply gcd_unique_alt; trivial.
 intros q. split. split; trivial. now apply divide_mul_l.
 now destruct 1.
Qed.

Lemma divide_gcd_iff : forall n m, 0<=n -> ((n|m) <-> gcd n m == n).
Proof.
 intros n m Hn. split. intros (q,Hq). rewrite Hq.
 rewrite mul_comm. now apply gcd_mul_diag_l.
 intros EQ. rewrite <- EQ. apply gcd_divide_r.
Qed.

End NZGcdProp.


(** * Generation of Hoare proof obligations in total correctness

 This file is part of the "Tutorial on Hoare Logic".
 For an introduction to this Coq library,
 see README #or index.html#.

 This file gives a syntactic definition of the weakest precondition [wp]
 introduced in ##[hoarelogicsemantics]##.
 We refine here the approach of  ##[partialhoarelogic]##.
*)

Global Set Asymmetric Patterns.
Set Implicit Arguments.
Require Export hoarelogicsemantics.
Require Wf.

Module TotalHoareLogic (HD: HoareLogicDefs).

Export HD.
Module HLD:=HD.

Definition sem_wp := wp.

Export Wf.

(** * Syntactic definition of the weakest precondition.

 In the following, we show that this definition is logically
 equivalent to [wp].
 *)
Fixpoint synt_wp (prog: ImpProg) : Pred -> Pred
 := fun post e =>
  match prog with
  | Iskip => post e
  | (Iset A x expr) => post (E.upd x (E.eval expr e) e)
  | (Iif cond p1 p2) =>
          ((E.eval cond e)=true -> (synt_wp p1 post e))
       /\ ((E.eval cond e)=false -> (synt_wp p2 post e))
  | (Iseq p1 p2) => synt_wp p1 (synt_wp p2 post) e
  | (Iwhile cond p) =>
        exists inv:Pred,
        exists R:E.Env -> E.Env -> Prop,
             (well_founded R)
          /\ (inv e)
          /\ (forall e', (inv e')
                  -> (E.eval cond e')=false -> post e')
          /\ (forall e', (inv e')
                  -> (E.eval cond e')=true -> synt_wp p inv e')
          /\ (forall e0, (inv e0)
                  -> (E.eval cond e0)=true -> synt_wp p (fun e1 => R e1 e0) e0)
  end.

(** * Soundness *)

(** Monotonicity is also trivially satisfied by [wp].
    We need it here to prove the soundness.
*)
Lemma synt_wp_monotonic:
  forall (p: ImpProg) (post1 post2: Pred),
   (forall e, post1 e -> post2 e)
    -> forall e, (synt_wp p post1 e) -> (synt_wp p post2 e).
Proof.
  induction p; simpl; firstorder eauto.
Qed.

Hint Resolve synt_wp_monotonic: hoare.

(** Below, a little tactic to decompose a pair in hypothesis [H]
    by giving the name [n] to the first component.
 *)
Ltac dec2 n H := case H; clear H; intros n H.

(** The property below is also satisfied by [wp] (using the fact that
    the language is deterministic).
    We need it here to prove the soundness.
*)
Lemma synt_wp_conj:
 forall (p: ImpProg) (post1 post2: Pred) e,
   (synt_wp p post1 e) -> (synt_wp p post2 e)
     -> (synt_wp p (fun e => post1 e /\ post2 e) e).
Proof.
  induction p; simpl; try ((intuition auto); fail).
  (* Iseq *)
  intros post1 post2 e H1 H2.
  intros; eapply synt_wp_monotonic.
  2: apply (IHp1 _ _ _ H1 H2).
  simpl; intuition auto.
  (* Iwhile *)
  intros post1 post2 e H1 H2.
  dec2 inv1 H1.
  dec2 R1 H1.
  dec2 inv2 H2.
  intros;
  constructor 1 with (x:=fun e => inv1 e /\ inv2 e).
  constructor 1 with (x:=R1).
  firstorder auto.
Qed.

(** The proof of soundness proceeds by induction over [prog].
*)
Lemma wp_sound: forall prog post, synt_wp prog post |= prog [=post=].
Proof.
 unfold wp.
 induction prog; simpl; try ((intuition eauto with hoare); fail).
 (* - case [Iif] *)
 intros post e.
 set (b:=E.eval cond e).
 cut (E.eval cond e=b); auto.
 case b; firstorder eauto with hoare.
 (* - case [Iseq] *)
 intros post e H; case (IHprog1 _ _ H).
 intros e0 H0; case (IHprog2 post e0); firstorder eauto with hoare.
 (* - case [Iwhile] *)
 intros post e H.
 dec2 inv H.
 dec2 R H.
 dec2 Rwf H.
 dec2 Hinv H.
 dec2 H1 H.
 dec2 H2 H.
 generalize Hinv.
 pattern e.
 (* -- here the proof proceeds by induction on the well-founded relation *)
 eapply well_founded_ind; eauto.
 clear Hinv e.
 intros e' X H'.
 set (b:=E.eval cond e').
 cut (E.eval cond e'=b); auto.
 case b; [ idtac | firstorder eauto with hoare ].
 intros H5.
 case (IHprog (wp (Iwhile cond prog) post) e');
 [ idtac | (unfold wp; firstorder eauto with hoare) ].
 eapply synt_wp_monotonic.
 2:apply (synt_wp_conj _ _ _ _ (H2 _ H' H5) (H _ H' H5)).
 simpl; unfold wp; intuition auto.
Qed.

(** * Auxiliary lemmas for completeness

   The proof of completeness requires to exhibit a variant.
   The purpose of the following lemmas is to build this variant.
*)

(** ** A technical issue: the inversion of [exec]

   If your are not interested in Coq details, you may skip this part
   which only explains how to avoid the assumption of a (consistent
   and standard) axiom to prove the completeness.

   Because the use of dependent types in constructor [exec_Iset], the
   standard inversion of Coq may fail on [exec] (see
   [exec_test_inversion] below).

   This comes from the fact the following property is not provable in
   the core theory of Coq (although it is consistent with it) :

   [forall A (x1 x2:E.Var A) e1 e2, (Iset x1 e1)=(Iset x2 e2) -> x1=x2 /\ e1=e2.]

   To deal with this problem, we may assume a (consistent) axiom given
   in ##
      [EqdepFacts]##.
   But here, we can avoid this axiom.

   Indeed, I define an ad-hoc inversion lemma for [exec] called
   [exec_inversion] below. This lemma is directly derived from the
   notion of weakest liberal precondition: [aux_wlp] is an other
   alternative definition of [wlp].

*)
Definition aux_wlp (prog: ImpProg) : Pred -> Pred
 := fun post e =>
  match prog with
  | Iskip => post e
  | (Iset A x expr) => post (E.upd x (E.eval expr e) e)
  | (Iif cond p1 p2) =>
       forall e', exec e (if E.eval cond e then p1 else p2) e'
          -> post e'
  | (Iseq p1 p2) => forall e1 e2, exec e p1 e1 -> exec e1 p2 e2 -> post e2
  | (Iwhile cond p) => forall e', exec e (Iif cond (Iseq p (Iwhile cond p)) Iskip) e' -> post e'
  end.

(** This lemma is my inversion lemma of [exec]. It expresses the "soundness" of [aux_wlp]. *)
Lemma exec_inversion:
  forall prog e e', (exec e prog e') -> forall post, (aux_wlp prog post e) -> post e'.
Proof.
  induction 1; simpl;
  try ((firstorder eauto with hoare); fail).
Qed.

(** Here is the case, where the previous lemma is better than the standard inversion of Coq. *)
Lemma exec_test_inversion:
  forall A (x:E.Var A) expr e e',
     (exec e (Iset x expr) e') -> e'=(E.upd x (E.eval expr e) e).
Proof.
  intros A x expr e e' H.
  (** Here, try "[inversion H]" instead the tactic below.
      The generated goal is not directly provable. *)
  pattern e'; apply (exec_inversion H); simpl; auto.
Qed.

(** Below, a little tactic to helps in applying [exec_inversion]. *)
Ltac exec_inversion H :=
  match type of H with
  | (exec ?e ?p ?e') => pattern e'; apply (exec_inversion H); simpl; clear H
  end.

(** ** The programming language is deterministic

This property is probably not necessary to prove the correctness of my
variant, but it simplifies the proof a lot.

This lemma is a trivial induction over the first [exec] derivation,
provided the ad-hoc inversion tactic on the second [exec] derivation.
*)
Lemma exec_deterministic: forall ei p ef,
  (exec ei p ef) -> forall ef', (exec ei p ef') -> ef=ef'.
Proof.
  induction 1; intros ef' X; exec_inversion X; eauto.
  (* - case [Iseq] *)
  intros e1 e2 X1 X2; assert (X3: e'=e1); auto.
  subst; auto.
Qed.

(** ** Definition of the variant
  Given a program [p] and a boolean expression [cond], the relation on environment
  "[reduces cond p]" is the variant required by "[synt_wp (Iwhile cond p)]".

  I prove below that this relation is well-founded.
*)
Definition reduces cond p e1 e0 :=
  (E.eval cond e0)=true /\ (exec e0 p e1) /\ exists ef, (exec e1 (Iwhile cond p) ef).

(** To prove that "[reduces cond p]" is well-founded, I want to count
    the number of execution of [p] in the computation of "[Iwhile cond p]".
    Indeed, as the language is deterministic, this number is unique.

    Hence, "[execn n e (Iwhile cond p) e']" means that "[exec e (Iwhile cond p) e']"
    in a sequence of [n] execution of [p].
 *)
Inductive execn: nat -> E.Env -> ImpProg -> E.Env -> Prop :=
 | execn_Iskip:
    forall e, (execn 0 e Iskip e)
 | execn_Iset:
    forall (A:Type) e x (expr: E.Expr A),
     (execn 0 e (Iset x expr) (E.upd x (E.eval expr e) e))
 | execn_Iif:
    forall n e (cond: E.Expr bool) p1 p2 e',
       (execn n e (if (E.eval cond e) then p1 else p2) e')
         -> (execn n e (Iif cond p1 p2) e')
 | execn_Iseq:
    forall n e p1 p2 e' e'',
      (exec e p1 e')
       -> (execn n e' p2 e'')
         -> (execn n e (Iseq p1 p2) e'')
 | execn_Iwhile:
    forall n e cond p e',
     (execn n e (Iif cond (Iseq p (Iwhile cond p)) Iskip) e')
        -> (execn (S n) e (Iwhile cond p) e').

Hint Resolve execn_Iskip execn_Iset execn_Iif execn_Iseq execn_Iwhile: hoare.

Lemma exec_execn: forall ei p ef,
  (exec ei p ef) -> (exists n, execn n ei p ef).
Proof.
  induction 1; firstorder (eauto with hoare).
Qed.

(** In the proof below, I mainly use that "[reduces cond p e1 e0]"
    implies that there exists [n] and [ef] such that "[execn (S n) e0 (Iwhile cond p) ef]"
    and "[execn n e1 (Iwhile cond p) ef]".
*)
Lemma reduces_wf: forall cond p, well_founded (reduces cond p).
Proof.
  unfold well_founded.
  intros cond p e0; apply Acc_intro.
  intros e1 H; unfold reduces in H.
  decompose [ex and] H; clear H.
  clear H2 H0 e0.
  case (exec_execn H1).
  intros n.
  generalize cond p e1 x; clear cond p e1 x H1.
  elim n.
  (* case 0 *)
  intros cond p e0 e1 H; inversion_clear H.
  (* recursive case *)
  clear n; intros n HR cond p e0 e1 H.
  inversion_clear H.
  inversion_clear H0.
  set (b:=E.eval cond e0) in * |-.
  cut (E.eval cond e0=b); auto.
  generalize H; clear H; case b; simpl.
  (* case cond=true *)
    intros H;
    inversion_clear H.
    intros;
    apply Acc_intro.
    intros e2 H3; unfold reduces in H3.
    intuition.
    rewrite (exec_deterministic H3 H0); eauto.
    (* case cond=false *)
    intros H H0; apply Acc_intro.
    unfold reduces; rewrite H0.
    intuition.
    discriminate.
Qed.
Hint Resolve reduces_wf: hoare.

(** * Completeness

    The proof of completeness proceeds by induction over [prog] syntax.

*)
Lemma wp_complete: forall prog post, prog [= post =] |= (synt_wp prog post).
Proof.
 unfold wp.
  intros prog post e H; case H; clear H.
  intros e' H; case H; clear H.
  generalize post e e'; clear post e e'; elim prog; clear prog; simpl.
  (* - case [Iskip] *)
  intros post e e' H; exec_inversion H; auto.
  (* - case [Iset] *)
  intros A v expr post e e' H; exec_inversion H; auto.
  (* - case [Iif] *)
  intros cond p1 Hp1 p2 Hp2 post e e' H; exec_inversion H.
  case (E.eval cond e); simpl; firstorder auto || discriminate.
  (* - case [Iseq] *)
  intros p1 Hp1 p2 Hp2 post e e' H.
  exec_inversion H.
  eauto.
  (* - case [Iwhile] *)
  intros cond p Hp post e e' H H0.
  constructor 1 with (x:=wp (Iwhile cond p) post).
  constructor 1 with (x:=reduces cond p).
  unfold wp; (intuition eauto with hoare);
    dec2 e1 H1;
    case H1; clear H1; intros H1;
    exec_inversion H1;
    intros e2 H1; exec_inversion H1;
    rewrite H2; intros e3 H1; exec_inversion H1;
    unfold reduces; eauto with hoare.
Qed.

(** * Combining the previous results with transitivity of [ |= ] *)

Hint Resolve wp_complete wp_sound: hoare.

Theorem soundness: forall pre p post, pre |= (synt_wp p post) -> pre |= p [=post=].
Proof.
 auto with hoare.
Qed.

Theorem completeness: forall pre p post, pre |= p [=post=] -> pre |= (synt_wp p post).
Proof.
  intuition auto with hoare.
Qed.

End TotalHoareLogic.

(** "Tutorial on Hoare Logic" Library. Copyright 2007 Sylvain Boulme.

This file is distributed under the terms of the
 "GNU LESSER GENERAL PUBLIC LICENSE" version 3.
*)


Global Set Asymmetric Patterns.
Set Implicit Arguments.

(** * Preliminaries *)
(** ** Definition of iterator [comp]
   [comp f u n x] is defined as $(f~(u~(n-1)).. (f (u~ 0)~x))$ *)

Fixpoint comp (A:Type) (f : A -> A -> A) (x : A) (u : nat -> A) (n:nat) {struct n}: A :=
   match n with O => x| (S p) => f (u p) (comp f x u p) end.

Lemma comp0 : forall (A:Type) (f : A -> A -> A) (x : A) (u : nat -> A), comp f x u 0 = x.
trivial.
Qed.

Lemma compS : forall (A:Type) (f : A -> A -> A) (x : A) (u : nat -> A) (n:nat),
              comp f x u (S n) = f (u n) (comp f x u n).
trivial.
Qed.

(** ** Monotonicity of sequences for an arbitrary relation *)
Definition mon_seq (A:Type) (le : A -> A -> Prop) (f:nat ->A)
  :=  forall n m, (n <= m) -> (le (f n) (f m)).

Definition decr_seq (A:Type) (le : A -> A -> Prop) (f:nat ->A)
  :=  forall n m, (n <= m) -> (le (f m) (f n)).

(** ** Reducing if constructs *)

Lemma if_then : forall (P:Prop) (b:{P}+{ ~P})(A:Type)(p q:A), P -> (if b then p else q) =p.
destruct b; simpl; intuition.
Qed.

Lemma if_else : forall (P:Prop) (b:{P}+{ ~P})(A:Type)(p q:A), ~P -> (if b then p else q) =q.
destruct b; simpl; intuition.
Qed.

(** ** Classical reasoning *)

Definition class (A:Prop) := ~ ~A -> A.

Lemma class_neg : forall A:Prop, class ( ~ A).
unfold class; intuition.
Qed.

Lemma class_false : class False.
unfold class; intuition.
Qed.
Hint Resolve class_neg class_false.

Definition orc (A B:Prop) := forall C:Prop, class C -> (A ->C) -> (B->C) -> C.

Lemma orc_left : forall A B:Prop, A -> orc A B.
red;intuition.
Qed.

Lemma orc_right : forall A B:Prop, B -> orc A B.
red;intuition.
Qed.

Hint Resolve orc_left orc_right.

Lemma class_orc : forall A B, class (orc A B).
repeat red; intros.
apply H0; red; intro.
apply H; red; intro.
apply H3; apply H4; auto.
Qed.

Implicit Arguments class_orc [].

Lemma orc_intro : forall A B, ( ~A -> ~B -> False) -> orc A B.
intros; apply class_orc; red; intros.
apply H; red; auto.
Qed.

Lemma class_and : forall A B, class A -> class B -> class (A /\ B).
unfold class; intuition.
Qed.

Lemma excluded_middle : forall A, orc A ( ~A).
red; intros.
apply H; red; intro.
intuition.
Qed.

Definition exc (A :Type)(P:A->Prop) :=
   forall C:Prop, class C -> (forall x:A, P x ->C) -> C.

Lemma exc_intro : forall (A :Type)(P:A->Prop) (x:A), P x -> exc P.
red;firstorder.
Qed.

Lemma class_exc : forall (A :Type)(P:A->Prop), class (exc P).
repeat red; intros.
apply H0; clear H0; red; intro.
apply H; clear H; red; intro H2.
apply H2; intros; auto.
apply H0; apply (H1 x); auto.
Qed.

Lemma exc_intro_class : forall (A:Type) (P:A->Prop), ((forall x, ~P x) -> False) -> exc P.
intros; apply class_exc; red; intros.
apply H; red; intros; auto.
apply H0; apply exc_intro with (x:=x);auto.
Qed.

Lemma not_and_elim_left : forall A B, ~ (A /\ B) -> A -> ~B.
intuition.
Qed.

Lemma not_and_elim_right : forall A B, ~ (A /\ B) -> B -> ~A.
intuition.
Qed.

Hint Resolve class_orc class_and class_exc excluded_middle.