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

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

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

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

Hint Constructors permutation.
Hint Resolve permutation_refl.
Hint Resolve permutation_app_comp.
Hint Resolve permutation_app_swap.

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

Implicit Arguments permutation [A].
Implicit Arguments split_one [A].
Implicit Arguments all_permutations [A].
Implicit 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.
Hint Resolve permutation_map.

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

Let 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.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export poly.

Theorem silly1 : forall (n m o p : nat),
     n = m ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1. apply eq2. Qed.

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     oddb 3 = true ->
     evenb 4 = true.
Proof.
  intros Hn H3. rewrite <- H3. rewrite Hn. reflexivity. reflexivity.
Qed.

(*symmetry : =項の 左辺と右辺の入れ替え。*)
Theorem silly3_firsttry : forall (n : nat),
     true = (n == 5) ->
     (S (S n)) == 7 = true.
Proof.
  intros n H1.   symmetry. simpl. apply H1.
Qed.

Theorem rev_doble : forall (l : list nat),
  rev (rev l) = l.
Proof.
  intros l. induction l.
  - reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHl. reflexivity.
Qed.

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  intros l1 l2 H. rewrite H. rewrite rev_doble. reflexivity.
Qed.

Example trans_eq_example : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity. Qed.

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Proof.
  intros a b c d e f eq1 eq2.
  apply trans_eq with [c;d].
  apply eq1. apply eq2. Qed.

Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros n m o p H1 H2. rewrite H2. apply H1.
Qed.

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H1.
  assert (H2: n = pred (S n)). { reflexivity. }
  rewrite H2. rewrite H1. reflexivity.
Qed.

Theorem S_injective' : forall (n m : nat),
  S n = S m ->
  n = m.
Proof.
  intros n m H.  injection H. intros Hnm. apply Hnm.
Qed.

Theorem injection_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H.
  injection H. intros H1 H2.
  rewrite H1. rewrite H2. reflexivity.
Qed.

Example injection_ex3 : forall (X : Type) (x y z : X) (l j : list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros X x y z l j H1 H2. injection H2. intros Hin. symmetry. apply H.
Qed.

Theorem eqb_0_l : forall n,
   0 == n = true -> n = 0.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  -
    intros H. reflexivity.
  -
    simpl.  intros H. discriminate H.
Qed.

Theorem discriminate_ex1 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  intros n contra. discriminate contra. Qed.

Theorem discriminate_ex2 : forall (n m : nat),
  false = true ->
  [n] = [m].
Proof.
  intros n m contra. discriminate contra. Qed.

Example discriminate_ex3 :
  forall (X : Type) (x y z : X) (l j : list X),
    x :: y :: l = [] ->
    x = z.
Proof.
  intros X x y z l j H. discriminate H. Qed.

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq. reflexivity. Qed.

Theorem S_inj : forall (n m : nat) (b : bool),
     (S n) == (S m) = b ->
     n == m = b.
Proof.
  intros n m b H. simpl in H. apply H. Qed.

Theorem silly3' : forall (n : nat),
  (n == 5 = true -> (S (S n)) == 7 = true) ->
  true = (n == 5) ->
  true = ((S (S n)) == 7).
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H. Qed.

Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  - simpl. intros m eq. destruct m as [| m'] eqn:E.
    + reflexivity.
    + discriminate eq.

  - simpl. intros m eq. destruct m as [| m'] eqn:E.
    + simpl. discriminate eq.
    + apply f_equal.
      apply IHn'. injection eq as goal. apply goal. Qed.

Theorem succ_eq : forall n m,
  S n = S m -> n = m.
Proof.
  intros [] []. reflexivity. discriminate. discriminate.
  intros H. injection H as goal. rewrite goal. reflexivity.
Qed.

Theorem eqb_true : forall n m,
    n == m = true -> n = m.
Proof.
  intros n . induction n.
  - simpl. intros [].   reflexivity. discriminate.
  - intros m . destruct m.
    + discriminate.
    + simpl. intros H. apply IHn in H. rewrite H.
      reflexivity.
Qed.

Theorem eqb_id_true : forall x y,
  eqb_id x y = true -> x = y.
Proof.
  intros [m] [n]. simpl. intros H.
  assert (H' : m = n). { apply eqb_true. apply H. }
  rewrite H'. reflexivity.
Qed.

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
  intros.
  generalize dependent n.
  induction l as [| h t IH].
  - intros.
    rewrite <- H.
    reflexivity.
  - intros.
    rewrite <- H.
    simpl.
    apply IH.
    reflexivity.
Qed.

Definition square n := n * n.

Definition foo (x: nat) := 5.

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Proof.
  intros m.
  simpl.
  reflexivity.
Qed.

Definition sillyfun (n : nat) : bool :=
  if n == 3 then false
  else if n == 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (n == 3) eqn:E1.
    - reflexivity.
    - destruct (n == 5) eqn:E2.
      + reflexivity.
      + reflexivity. Qed.

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t =>
      match split t with
      | (lx, ly) => (x :: lx, y :: ly)
      end
  end.

Theorem tail_eq: forall (X: Type) (h: X) (l1 l2: list X),
    l1 = l2 -> h :: l1 = h :: l2.
Proof.
  intros. apply f_equal. apply H.
Qed.

Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| h t IH].
   - intros. simpl in H. inversion H. reflexivity.
   - intros l1 l2 H. inversion H. destruct h.
     destruct (split t). inversion H1.     simpl.
     apply tail_eq. apply IH. reflexivity.
Qed.

Definition sillyfun1 (n : nat) : bool :=
  if n == 3 then true
  else if n == 5 then true
  else false.

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (n == 3) eqn:Heqe3.
    - apply eqb_true in Heqe3.
      rewrite -> Heqe3. reflexivity.
    - destruct (n == 5) eqn:Heqe5.
        +
          apply eqb_true in Heqe5.
          rewrite -> Heqe5. reflexivity.
        + discriminate eq. Qed.

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f [].
   destruct (f true) eqn:fT.
     - rewrite fT. rewrite fT. reflexivity.
     -  destruct (f false) eqn: fF.
        + rewrite fT. reflexivity.
        + rewrite fF. reflexivity.
     - destruct (f false) eqn:fF.
       + destruct (f true ) eqn:fT. rewrite fT. reflexivity.
        rewrite fF. reflexivity.
       + rewrite fF. rewrite fF. reflexivity.
Qed.

Theorem eqb_sym : forall (n m : nat),
  (n == m) = (m == n).
Proof.
  intros n. induction n.
    - intros. induction m. + reflexivity. + reflexivity.
    - induction m. + reflexivity. + simpl. rewrite IHn. reflexivity.
Qed.

Theorem eqb_trans : forall n m p,
  n == m = true ->
  m == p = true ->
  n == p = true.
Proof.
   intros.  apply eqb_true in H. apply eqb_true in H0. induction H0. induction H. apply true_eq.
Qed.

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | nil => true
  | h :: t => if (test h) then forallb test t else false
  end.

Example test_forallb_1 : forallb oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.

Example test_forallb_2 : forallb negb [false;false] = true.
Proof. reflexivity. Qed.

Example test_forallb_3 : forallb evenb [0;2;4;5] = false.
Proof. reflexivity. Qed.

Example test_forallb_4 : forallb (eqb 5) [] = true.
Proof. reflexivity. Qed.

Fixpoint existsb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | nil => false
  | h :: t => if (test h) then true else existsb test t
  end.

Example test_existsb_1 : existsb (eqb 5) [0;2;3;6] = false.
Proof. reflexivity. Qed.

Example test_existsb_2 : existsb (andb true) [true;true;false] = true.
Proof. reflexivity. Qed.

Example test_existsb_3 : existsb oddb [1;0;0;0;0;3] = true.
Proof. reflexivity. Qed.

Example test_existsb_4 : existsb evenb [] = false.
Proof. reflexivity. Qed.

Definition existsb' {X : Type} (test : X -> bool) (l : list X) : bool :=
   negb (forallb (fun x => negb (test x)) l) .

Theorem existsb_existsb' : forall (X : Type) (test : X -> bool) (l : list X),
  existsb test l = existsb' test l.
Proof.
  intros. unfold existsb'. unfold existsb. induction l. - simpl. reflexivity.
  - simpl. destruct (test x).
     + simpl. reflexivity.
     + simpl. rewrite IHl. reflexivity.
Qed.

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n m. rewrite <- double_plus. rewrite <- double_plus. Search double. apply double_injective.
Qed.

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

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros.
  generalize dependent lf.
  induction l as [| h t IH].
  - intros.
    simpl in H.
    inversion H.
  - intros.
    generalize dependent H.
    destruct lf as [| hf tf].
    + simpl.
      intros.
      destruct (test h) eqn:testH.
      * inversion H.
        rewrite -> H1 in testH.
        apply testH.
      * apply IH in H.
        apply H.
    + simpl.
      intros.
      destruct (test h) eqn:testH.
      * inversion H.
        rewrite -> H1 in testH.
        apply testH.
      * apply IH in H.
        apply H.
Qed.


From mathcomp Require Export ssreflect.
Require Export Classical.

Definition set T := T -> Prop.

Definition In {T : Type} (x : T)(X : set T) := X x.
Notation "x ∈ X" := (@In _ x X )(at level 60).

Definition setU {T : Type} (A B : set T) : set T :=
    fun x => x ∈ A \/ x ∈ B .
Definition setI {T : Type} (A B : set T) : set T :=
    fun x => x ∈ A /\ x ∈ B.
Definition subset {T : Type} (A B : set T) : Prop :=
    forall x, x ∈ A -> x ∈ B.
Definition setD {T : Type} (A B : set T) : set T
    := fun x => x ∈ A /\ ~ x ∈ B.
Definition setC {T : Type} (A : set T) : set T
    := fun x => ~ x ∈ A.
Definition set0 {T : Type} : set T :=
    fun _ : T => False.

Notation "A ∩ B" := (@setI _ A B)(at level 40).
Notation "A ∪ B" := (@setU _ A B)(at level 40).
Notation "A ⊂ B" := (@subset _ A B)(at level 30).
Notation "A // B" := (@setD _ A B)(at level 40).
Notation "¬ A" := (@setC _ A)(at level 40).
Notation "∅" := set0.

Axiom extension : forall {T : Type} (A B : set T),
    A ⊂ B /\ B ⊂ A -> A = B.

Section SetsFacts.

Context  {T : Type}.

Theorem setCU (A B : set T):
    ¬ (A ∪ B) = ¬ A ∩ ¬ B.
Proof.
    apply extension; split => x Hx.
    +   split => F; apply Hx; [left|right] => //.
    +   move : Hx => [Ha_ Hb_].
        move => [Ha|Hb]; [apply Ha_ | apply Hb_] => //.
Qed.

Theorem setCI (A B : set T):
    ¬ (A ∩ B) = ¬ A ∪ ¬ B.
Proof.
    apply extension; split => x Hx.
    +   apply NNPP => F.
        rewrite /setC /setU /In /= in F.
        move /not_or_and : F => [/NNPP HA /NNPP NB ].
        apply Hx; split => //.
    +   move => [HA HB].
        move : Hx => [H|H]; apply H => //.
Qed.


Add LoadPath "bezier-functions".

Require Import polynomial.
Require Import auxiliary.
Require Import QArith.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.

Lemma bezier_curve_polynomial_symm_fstdegree :
  forall (P0 P1 : point) (q : Q),
      calc_bezier_polynomial (P0 :: [P1]) q == calc_bezier_polynomial (rev (P0 :: [P1])) (1 - q).
Proof.
  intros P0 P1 q.
  unfold calc_bezier_polynomial. unfold rev. simpl.
  unfold calc_fact_div. unfold minus_1_sgn. unfold inject_Z. simpl.
  destruct P0 as [x0 y0]. destruct P1 as [x1 y1].
  unfold "==". simpl. split.
  { ring. }
  { ring. }
Qed.


Add LoadPath "MyAlgebraicStructure" as MyAlgebraicStructure.
Add LoadPath "BasicProperty" as BasicProperty.
Add LoadPath "Tools" as Tools.

From mathcomp Require Import ssreflect.
Require Import Classical.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import MyAlgebraicStructure.MyField.
Require Import BasicProperty.MappingProperty.

Section VectorSpace.

Record VectorSpace (F : Field) : Type := mkVectorSpace
{
VT   : Type;
VO : VT;
Vadd : VT -> VT -> VT;
Vmul : (FT F) -> VT -> VT;
Vopp : VT -> VT;
Vadd_comm : forall (x y : VT), (Vadd x y) = (Vadd y x);
Vadd_assoc : forall (x y z : VT), (Vadd (Vadd x y) z) = (Vadd x (Vadd y z));
Vadd_O_l : forall x : VT, (Vadd VO x) = x;
Vadd_opp_r : forall x : VT, (Vadd x (Vopp x)) = VO;
Vmul_add_distr_l : forall (x : FT F) (y z : VT), (Vmul x (Vadd y z)) = (Vadd (Vmul x y) (Vmul x z));
Vmul_add_distr_r : forall (x y : FT F) (z : VT), (Vmul (Fadd F x y) z) = (Vadd (Vmul x z) (Vmul y z));
Vmul_assoc : forall (x y : FT F) (z : VT), (Vmul x (Vmul y z)) = (Vmul (Fmul F x y) z);
Vmul_I_l : forall x : VT, (Vmul (FI F) x) = x;
}.

Lemma Vadd_O_r : forall (F : Field) (v : VectorSpace F) (x : VT F v), (Vadd F v x (VO F v)) = x.
Proof.
move=> F v x.
rewrite (Vadd_comm F v x (VO F v)).
apply (Vadd_O_l F v x).
Qed.

Lemma Vadd_ne : forall (F : Field) (v : VectorSpace F) (x : VT F v), (Vadd F v x (VO F v)) = x /\ (Vadd F v (VO F v) x) = x.
Proof.
move=> F v x.
apply conj.
apply (Vadd_O_r F v x).
apply (Vadd_O_l F v x).
Qed.

Lemma Vadd_opp_l : forall (F : Field) (v : VectorSpace F) (x : VT F v), (Vadd F v (Vopp F v x) x) = (VO F v).
Proof.
move=> F v x.
rewrite (Vadd_comm F v (Vopp F v x) x).
apply (Vadd_opp_r F v x).
Qed.

Lemma Vadd_opp_r_uniq : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vadd F v x y) = (VO F v) -> y = (Vopp F v x).
Proof.
move=> F v x y H1.
suff: (Vadd F v (Vopp F v x) (Vadd F v x y)) = (Vadd F v (Vopp F v x) (VO F v)).
move=> H2.
rewrite - (Vadd_O_r F v (Vopp F v x)).
rewrite - H2.
rewrite - (Vadd_assoc F v (Vopp F v x) x y).
rewrite (Vadd_opp_l F v x).
rewrite (Vadd_O_l F v y).
by [].
rewrite H1.
by [].
Qed.

Lemma Vadd_eq_compat_l : forall (F : Field) (v : VectorSpace F) (x y z : VT F v), y = z -> (Vadd F v x y) = (Vadd F v x z).
Proof.
move=> F v x y z H1.
rewrite H1.
by [].
Qed.

Lemma Vadd_eq_compat_r : forall (F : Field) (v : VectorSpace F) (x y z : VT F v), y = z -> (Vadd F v y x) = (Vadd F v z x).
Proof.
move=> F v x y z H1.
rewrite H1.
by [].
Qed.

Lemma Vadd_eq_reg_l : forall (F : Field) (v : VectorSpace F) (x y z : VT F v), (Vadd F v x y) = (Vadd F v x z) -> y = z.
Proof.
move=> F v x y z H1.
rewrite - (Vadd_O_l F v y).
rewrite - (Vadd_O_l F v z).
rewrite - (Vadd_opp_l F v x).
rewrite (Vadd_assoc F v (Vopp F v x) x y).
rewrite (Vadd_assoc F v (Vopp F v x) x z).
apply (Vadd_eq_compat_l F v (Vopp F v x) (Vadd F v x y) (Vadd F v x z)).
by [].
Qed.

Lemma Vadd_eq_reg_r : forall (F : Field) (v : VectorSpace F) (x y z : VT F v), (Vadd F v y x) = (Vadd F v z x) -> y = z.
Proof.
move=> F v x y z H1.
rewrite - (Vadd_O_r F v y).
rewrite - (Vadd_O_r F v z).
rewrite - (Vadd_opp_r F v x).
rewrite - (Vadd_assoc F v y x (Vopp F v x)).
rewrite - (Vadd_assoc F v z x (Vopp F v x)).
apply (Vadd_eq_compat_r F v (Vopp F v x) (Vadd F v y x) (Vadd F v z x)).
by [].
Qed.

Lemma Vadd_O_r_uniq : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vadd F v x y) = x -> y = (VO F v).
Proof.
move=> F v x y H1.
rewrite - (Vadd_O_l F v y).
rewrite - (Vadd_opp_l F v x).
rewrite (Vadd_assoc F v (Vopp F v x) x y).
rewrite H1.
by [].
Qed.

Lemma Vmul_O_r : forall (F : Field) (v : VectorSpace F) (x : FT F), (Vmul F v x (VO F v)) = (VO F v).
Proof.
move=> F v x.
apply (Vadd_O_r_uniq F v (Vmul F v x (VO F v)) (Vmul F v x (VO F v))).
rewrite - (Vmul_add_distr_l F v x (VO F v) (VO F v)).
rewrite (Vadd_O_l F v (VO F v)).
by [].
Qed.

Lemma Vmul_O_l : forall (F : Field) (v : VectorSpace F) (x : VT F v), (Vmul F v (FO F) x) = (VO F v).
Proof.
move=> F v x.
apply (Vadd_O_r_uniq F v (Vmul F v (FO F) x) (Vmul F v (FO F) x)).
rewrite - (Vmul_add_distr_r F v (FO F) (FO F) x).
rewrite (Fadd_O_l F (FO F)).
by [].
Qed.

Lemma Vmul_eq_compat_l : forall (F : Field) (v : VectorSpace F) (x : FT F) (y z : VT F v), y = z -> (Vmul F v x y) = (Vmul F v x z).
Proof.
move=> F v x y z H1.
rewrite H1.
by [].
Qed.

Lemma Vmul_eq_compat_r : forall (F : Field) (v : VectorSpace F) (x : VT F v) (y z : FT F), y = z -> (Vmul F v y x) = (Vmul F v z x).
Proof.
move=> F v x y z H1.
rewrite H1.
by [].
Qed.

Lemma Vmul_eq_reg_l : forall (F : Field) (v : VectorSpace F) (x : FT F) (y z : VT F v), (Vmul F v x y) = (Vmul F v x z) -> x <> (FO F) -> y = z.
Proof.
move=> F v x y z H1 H2.
rewrite - (Vmul_I_l F v y).
rewrite - (Vmul_I_l F v z).
rewrite - (Finv_l F x H2).
rewrite - (Vmul_assoc F v (Finv F x) x y).
rewrite - (Vmul_assoc F v (Finv F x) x z).
rewrite H1.
by [].
Qed.

Lemma Vmul_eq_reg_r : forall (F : Field) (v : VectorSpace F) (x : VT F v) (y z : FT F), (Vmul F v y x) = (Vmul F v z x) -> x <> (VO F v) -> y = z.
Proof.
move=> F v x y z H1 H2.
apply NNPP.
move=> H3.
apply H2.
rewrite - (Vmul_I_l F v x).
rewrite - (Finv_l F (Fadd F y (Fopp F z))).
rewrite - (Vmul_assoc F v (Finv F (Fadd F y (Fopp F z))) (Fadd F y (Fopp F z)) x).
suff: ((Vmul F v (Fadd F y (Fopp F z)) x) = VO F v).
move=> H4.
rewrite H4.
apply (Vmul_O_r F v (Finv F (Fadd F y (Fopp F z)))).
apply (Vadd_eq_reg_r F v (Vmul F v z x) (Vmul F v (Fadd F y (Fopp F z)) x) (VO F v)).
rewrite (Vadd_O_l F v (Vmul F v z x)).
rewrite (Vmul_add_distr_r F v y (Fopp F z) x).
rewrite (Vadd_assoc F v (Vmul F v y x) (Vmul F v (Fopp F z) x) (Vmul F v z x)).
rewrite - (Vmul_add_distr_r F v (Fopp F z) z x).
rewrite (Fadd_opp_l F z).
rewrite (Vmul_O_l F v x).
rewrite H1.
apply (Vadd_O_r F v (Vmul F v z x)).
move=> H4.
apply H3.
apply (Fminus_diag_uniq F y z H4).
Qed.

Lemma Vmul_integral : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (Vmul F v x y) = (VO F v) -> x = (FO F) \/ y = (VO F v).
Proof.
move=> F v x y H1.
apply (NNPP (x = FO F \/ y = VO F v)).
move=> H2.
apply H2.
right.
apply (Vmul_eq_reg_l F v x y (VO F v)).
rewrite H1.
rewrite (Vmul_O_r F v x).
by [].
move=> H3.
apply H2.
left.
apply H3.
Qed.

Lemma Vmul_eq_O_compat : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (x = (FO F) \/ y = (VO F v)) -> (Vmul F v x y) = (VO F v).
Proof.
move=> F v x y H1.
case H1.
move=> H2.
rewrite H2.
apply (Vmul_O_l F v y).
move=> H2.
rewrite H2.
apply (Vmul_O_r F v x).
Qed.

Lemma Vmul_eq_O_compat_r : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), x = (FO F) -> (Vmul F v x y) = (VO F v).
Proof.
move=> F v x y H1.
rewrite H1.
apply (Vmul_O_l F v y).
Qed.

Lemma Vmul_eq_O_compat_l : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), y = (VO F v) -> (Vmul F v x y) = (VO F v).
Proof.
move=> F v x y H1.
rewrite H1.
apply (Vmul_O_r F v x).
Qed.

Lemma Vmul_neq_O_reg : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (Vmul F v x y) <> (VO F v) -> x <> (FO F) /\ y <> (VO F v).
Proof.
move=> F v x y H1.
apply conj.
move=> H2.
apply H1.
rewrite H2.
apply (Vmul_O_l F v y).
move=> H2.
apply H1.
rewrite H2.
apply (Vmul_O_r F v x).
Qed.

Lemma Vmul_integral_contrapositive : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), x <> (FO F) /\ y <> (VO F v) -> (Vmul F v x y) <> (VO F v).
Proof.
move=> F v x y H1 H2.
apply (proj1 H1).
apply (Vmul_eq_reg_r F v y x (FO F)).
rewrite (Vmul_O_l F v y).
apply H2.
apply (proj2 H1).
Qed.

Lemma Vmul_integral_contrapositive_currified : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), x <> (FO F) -> y <> (VO F v) -> (Vmul F v x y) <> (VO F v).
Proof.
move=> F v x y H1 H2 H3.
apply H1.
apply (Vmul_eq_reg_r F v y x (FO F)).
rewrite (Vmul_O_l F v y).
apply H3.
apply H2.
Qed.

Lemma Vopp_eq_compat : forall (F : Field) (v : VectorSpace F) (x y : VT F v), x = y -> (Vopp F v x) = (Vopp F v y).
Proof.
move=> F v x y H1.
rewrite H1.
by [].
Qed.

Lemma Vopp_O : forall (F : Field) (v : VectorSpace F), (Vopp F v (VO F v)) = (VO F v).
Proof.
move=> F v.
apply (Vadd_O_r_uniq F v (VO F v) (Vopp F v (VO F v))).
apply (Vadd_opp_r F v (VO F v)).
Qed.

Lemma Vopp_eq_O_compat : forall (F : Field) (v : VectorSpace F) (x : VT F v), x = (VO F v) -> (Vopp F v x) = (VO F v).
Proof.
move=> F v x H1.
rewrite H1.
apply (Vopp_O F v).
Qed.

Lemma Vopp_involutive : forall (F : Field) (v : VectorSpace F) (x : VT F v), (Vopp F v (Vopp F v x)) = x.
Proof.
move=> F v x.
suff: x = Vopp F v (Vopp F v x).
move=> H1.
rewrite{2} H1.
by [].
apply (Vadd_opp_r_uniq F v (Vopp F v x)).
apply (Vadd_opp_l F v x).
Qed.

Lemma Vopp_neq_O_compat : forall (F : Field) (v : VectorSpace F) (x : VT F v), x <> (VO F v) -> (Vopp F v x) <> (VO F v).
Proof.
move=> F v x H1 H2.
apply H1.
rewrite - (Vopp_involutive F v x).
apply (Vopp_eq_O_compat F v (Vopp F v x) H2).
Qed.

Lemma Vopp_add_distr : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vopp F v (Vadd F v x y)) = (Vadd F v (Vopp F v x) (Vopp F v y)).
Proof.
move=> F v x y.
suff: Vadd F v (Vopp F v x) (Vopp F v y) = Vopp F v (Vadd F v x y).
move=> H1.
rewrite H1.
by [].
apply (Vadd_opp_r_uniq F v (Vadd F v x y)).
rewrite (Vadd_comm F v x y).
rewrite - (Vadd_assoc F v (Vadd F v y x) (Vopp F v x) (Vopp F v y)).
rewrite (Vadd_assoc F v y x (Vopp F v x)).
rewrite (Vadd_opp_r F v x).
rewrite (Vadd_O_r F v y).
apply (Vadd_opp_r F v y).
Qed.

Lemma Vopp_mul_distr_l : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (Vopp F v (Vmul F v x y)) = (Vmul F v (Fopp F x) y).
Proof.
move=> F v x y.
suff: Vmul F v (Fopp F x) y = Vopp F v (Vmul F v x y).
move=> H1.
rewrite H1.
by [].
apply (Vadd_opp_r_uniq F v (Vmul F v x y)).
rewrite - (Vmul_add_distr_r F v x (Fopp F x) y).
rewrite (Fadd_opp_r F x).
apply (Vmul_O_l F v y).
Qed.

Lemma Vopp_mul_distr_l_reverse : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (Vmul F v (Fopp F x) y) = (Vopp F v (Vmul F v x y)).
Proof.
move=> F v x y.
rewrite (Vopp_mul_distr_l F v x y).
reflexivity.
Qed.

Lemma Vopp_mul_distr_r : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (Vopp F v (Vmul F v x y)) = (Vmul F v x (Vopp F v y)).
Proof.
move=> F v x y.
suff: Vmul F v x (Vopp F v y) = Vopp F v (Vmul F v x y).
move=> H1.
rewrite H1.
by [].
apply (Vadd_opp_r_uniq F v (Vmul F v x y)).
rewrite - (Vmul_add_distr_l F v x y (Vopp F v y)).
rewrite (Vadd_opp_r F v y).
apply (Vmul_O_r F v x).
Qed.

Lemma Vopp_mul_distr_r_reverse : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (Vmul F v x (Vopp F v y)) = (Vopp F v (Vmul F v x y)).
Proof.
move=> F v x y.
rewrite (Vopp_mul_distr_r F v x y).
reflexivity.
Qed.

Lemma Vmul_opp_opp : forall (F : Field) (v : VectorSpace F) (x : FT F) (y : VT F v), (Vmul F v (Fopp F x) (Vopp F v y)) = (Vmul F v x y).
Proof.
move=> F v x y.
rewrite (Vopp_mul_distr_l_reverse F v x (Vopp F v y)).
rewrite (Vopp_mul_distr_r_reverse F v x y).
apply (Vopp_involutive F v (Vmul F v x y)).
Qed.

Lemma Vminus_O_r : forall (F : Field) (v : VectorSpace F) (x : VT F v), (Vadd F v x (Vopp F v (VO F v))) = x.
Proof.
move=> F v x.
rewrite (Vopp_O F v).
apply (Vadd_O_r F v x).
Qed.

Lemma Vminus_O_l : forall (F : Field) (v : VectorSpace F) (x : VT F v), (Vadd F v (VO F v) (Vopp F v x)) = (Vopp F v x).
Proof.
move=> F v x.
apply (Vadd_O_l F v (Vopp F v x)).
Qed.

Lemma Vopp_minus_distr : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vopp F v (Vadd F v x (Vopp F v y))) = (Vadd F v y (Vopp F v x)).
Proof.
move=> F v x y.
rewrite (Vopp_add_distr F v x (Vopp F v y)).
rewrite (Vopp_involutive F v y).
apply (Vadd_comm F v (Vopp F v x) y).
Qed.

Lemma Vopp_minus_distr' : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vopp F v (Vadd F v y (Vopp F v x))) = (Vadd F v x (Vopp F v y)).
Proof.
move=> F v x y.
rewrite (Vopp_add_distr F v y (Vopp F v x)).
rewrite (Vopp_involutive F v x).
apply (Vadd_comm F v (Vopp F v y) x).
Qed.

Lemma Vminus_diag_eq : forall (F : Field) (v : VectorSpace F) (x y : VT F v), x = y -> (Vadd F v x (Vopp F v y)) = (VO F v).
Proof.
move=> F v x y H1.
rewrite H1.
apply (Vadd_opp_r F v y).
Qed.

Lemma Vminus_diag_uniq : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vadd F v x (Vopp F v y)) = (VO F v) -> x = y.
Proof.
move=> F v x y H1.
rewrite<- (Vadd_O_r F v x).
rewrite<- (Vadd_opp_l F v y).
rewrite<- (Vadd_O_l F v y) at 3.
rewrite<- (Vadd_assoc F v x (Vopp F v y) y).
rewrite H1.
reflexivity.
Qed.

Lemma Vminus_diag_uniq_sym : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vadd F v y (Vopp F v x)) = (VO F v) -> x = y.
Proof.
move=> F v x y H1.
rewrite (Vminus_diag_uniq F v y x H1).
reflexivity.
Qed.

Lemma Vadd_minus : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vadd F v x (Vadd F v y (Vopp F v x))) = y.
Proof.
move=> F v x y.
rewrite (Vadd_comm F v y (Vopp F v x)).
rewrite<- (Vadd_assoc F v x (Vopp F v x) y).
rewrite (Vadd_opp_r F v x).
apply (Vadd_O_l F v y).
Qed.

Lemma Vminus_eq_contra : forall (F : Field) (v : VectorSpace F) (x y : VT F v), x <> y -> (Vadd F v x (Vopp F v y)) <> (VO F v).
Proof.
move=> F v x y H1 H2.
apply H1.
apply (Vminus_diag_uniq F v x y H2).
Qed.

Lemma Vminus_not_eq : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vadd F v x (Vopp F v y)) <> (VO F v) -> x <> y.
Proof.
move=> F v x y H1 H2.
apply H1.
apply (Vminus_diag_eq F v x y H2).
Qed.

Lemma Vminus_not_eq_right : forall (F : Field) (v : VectorSpace F) (x y : VT F v), (Vadd F v y (Vopp F v x)) <> (VO F v) -> x <> y.
Proof.
move=> F v x y H1 H2.
apply H1.
apply (Vminus_diag_eq F v y x).
rewrite H2.
reflexivity.
Qed.

Lemma Vmul_minus_distr_l : forall (F : Field) (v : VectorSpace F) (x : FT F) (y z : VT F v), (Vmul F v x (Vadd F v y (Vopp F v z))) = (Vadd F v (Vmul F v x y) (Vopp F v (Vmul F v x z))).
Proof.
move=> F v x y z.
rewrite (Vmul_add_distr_l F v x y (Vopp F v z)).
rewrite (Vopp_mul_distr_r F v x z).
reflexivity.
Qed.

Definition IsomorphicVS (F : Field) (v1 v2 : VectorSpace F) (f : VT F v1 -> VT F v2) := Bijective f /\ (forall (x y : VT F v1), f (Vadd F v1 x y) = Vadd F v2 (f x) (f y)) /\ (forall (c : FT F) (x : VT F v1), f (Vmul F v1 c x) = Vmul F v2 c (f x)).

Lemma IsomorphicChainVS : forall (F : Field) (v1 v2 v3 : VectorSpace F) (f : VT F v1 -> VT F v2) (g : VT F v2 -> VT F v3), IsomorphicVS F v1 v2 f -> IsomorphicVS F v2 v3 g -> IsomorphicVS F v1 v3 (fun (x : VT F v1) => g (f x)).
Proof.
move=> F v1 v2 v3 f g H1 H2.
apply conj.
apply (BijChain (VT F v1) (VT F v2) (VT F v3) f g (proj1 H1) (proj1 H2)).
apply conj.
move=> x y.
rewrite ((proj1 (proj2 H1)) x y).
apply ((proj1 (proj2 H2)) (f x) (f y)).
move=> c x.
rewrite (proj2 (proj2 H1) c x).
apply (proj2 (proj2 H2) c (f x)).
Qed.

Lemma IsomorphicInvVS : forall (F : Field) (v1 v2 : VectorSpace F) (f : VT F v1 -> VT F v2) (g : VT F v2 -> VT F v1), IsomorphicVS F v1 v2 f -> (forall (x : VT F v1), g (f x) = x) /\ (forall (y : VT F v2), f (g y) = y) -> IsomorphicVS F v2 v1 g.
Proof.
move=> F v1 v2 f g H1 H2.
apply conj.
exists f.
apply conj.
apply (proj2 H2).
apply (proj1 H2).
apply conj.
move=> x y.
apply (BijInj (VT F v1) (VT F v2) f (proj1 H1) (g (Vadd F v2 x y)) (Vadd F v1 (g x) (g y))).
rewrite (proj1 (proj2 H1) (g x) (g y)).
rewrite (proj2 H2 x).
rewrite (proj2 H2 y).
apply (proj2 H2 (Vadd F v2 x y)).
move=> c x.
apply (BijInj (VT F v1) (VT F v2) f (proj1 H1) (g (Vmul F v2 c x)) (Vmul F v1 c (g x))).
rewrite (proj2 (proj2 H1) c (g x)).
rewrite (proj2 H2 x).
apply (proj2 H2 (Vmul F v2 c x)).
Qed.

Definition Fn (F : Field) (N : nat) := ({m : nat | m < N} -> FT F).

Definition Fnadd (F : Field) (N : nat) := fun (f1 f2 : Fn F N) => (fun (n : {m : nat | m < N}) => Fadd F (f1 n) (f2 n)).

Definition Fnmul (F : Field) (N : nat) := fun (c : FT F) (f : Fn F N) => (fun (n : {m : nat | m < N}) => Fmul F c (f n)).

Definition Fnopp (F : Field) (N : nat) := fun (f : (Fn F N)) => (fun (n : {m : nat | m < N}) => Fopp F (f n)).

Definition Fnminus (F : Field) (N : nat) := fun (f1 f2 : (Fn F N)) => (Fnadd F N f1 (Fnopp F N f2)).

Definition FnO (F : Field) (N : nat) := (fun (n : {m : nat | m < N}) => FO F).

Lemma Fnadd_comm : forall (F : Field) (N : nat) (f1 f2 : Fn F N), (Fnadd F N f1 f2) = (Fnadd F N f2 f1).
Proof.
move=> F N f1 f2.
apply functional_extensionality.
move=> n.
apply (Fadd_comm F (f1 n) (f2 n)).
Qed.

Lemma Fnadd_assoc : forall (F : Field) (N : nat) (f1 f2 f3 : Fn F N), (Fnadd F N (Fnadd F N f1 f2) f3) = (Fnadd F N f1 (Fnadd F N f2 f3)).
Proof.
move=> F N f1 f2 f3.
apply functional_extensionality.
move=> n.
apply (Fadd_assoc F (f1 n) (f2 n) (f3 n)).
Qed.

Lemma Fnadd_O_l : forall (F : Field) (N : nat) (f : Fn F N), (Fnadd F N (FnO F N) f) = f.
Proof.
move=> F N f.
apply functional_extensionality.
move=> n.
apply (Fadd_O_l F (f n)).
Qed.

Lemma Fnadd_opp_r : forall (F : Field) (N : nat) (f : Fn F N), (Fnadd F N f (Fnopp F N f)) = (FnO F N).
Proof.
move=> F N f.
apply functional_extensionality.
move=> n.
apply (Fadd_opp_r F (f n)).
Qed.

Lemma Fnadd_distr_l : forall (F : Field) (N : nat) (c : FT F) (f1 f2 : Fn F N), (Fnmul F N c (Fnadd F N f1 f2)) = (Fnadd F N (Fnmul F N c f1) (Fnmul F N c f2)).
Proof.
move=> F N c f1 f2.
apply functional_extensionality.
move=> n.
apply (Fmul_add_distr_l F c (f1 n) (f2 n)).
Qed.

Lemma Fnadd_distr_r : forall (F : Field) (N : nat) (c1 c2 : FT F) (f : Fn F N), (Fnmul F N (Fadd F c1 c2) f) = (Fnadd F N (Fnmul F N c1 f) (Fnmul F N c2 f)).
Proof.
move=> F N c1 c2 f.
apply functional_extensionality.
move=> n.
apply (Fmul_add_distr_r F c1 c2 (f n)).
Qed.

Lemma Fnmul_assoc : forall (F : Field) (N : nat) (c1 c2 : FT F) (f : Fn F N), (Fnmul F N c1 (Fnmul F N c2 f)) = (Fnmul F N (Fmul F c1 c2) f).
Proof.
move=> F N c1 c2 f.
apply functional_extensionality.
move=> n.
unfold Fnmul.
rewrite (Fmul_assoc F c1 c2 (f n)).
reflexivity.
Qed.

Lemma Fnmul_I_l : forall (F : Field) (N : nat) (f : Fn F N), (Fnmul F N (FI F) f) = f.
Proof.
move=> F N f.
apply functional_extensionality.
move=> n.
apply (Fmul_I_l F (f n)).
Qed.

Definition FnVS (F : Field) (N : nat) := mkVectorSpace F (Fn F N) (FnO F N) (Fnadd F N) (Fnmul F N) (Fnopp F N) (Fnadd_comm F N) (Fnadd_assoc F N) (Fnadd_O_l F N) (Fnadd_opp_r F N) (Fnadd_distr_l F N) (Fnadd_distr_r F N) (Fnmul_assoc F N) (Fnmul_I_l F N).

Definition FVS (F : Field) := mkVectorSpace F (FT F) (FO F) (Fadd F) (Fmul F) (Fopp F) (Fadd_comm F) (Fadd_assoc F) (Fadd_O_l F) (Fadd_opp_r F) (Fmul_add_distr_l F) (Fmul_add_distr_r F) (Fmul_assoc_reverse F) (Fmul_I_l F).

End VectorSpace.


Add LoadPath "/Users/danielle/projects/software-foundations/chapter03".
Require Import case.
Require Import exercise02.

Require Import Utf8.

Theorem plus_swap: ∀ n m p: nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  assert (H: m + (n + p) = (m + n) + p).
    Case "Associative property".
    rewrite -> plus_assoc.
    reflexivity.
  rewrite -> H.
  assert (H': m + n = n + m).
    Case "Commutative property".
    rewrite -> plus_comm.
    reflexivity.
  rewrite -> H'.
  assert (H'': n + (m + p) = (n + m) + p).
    Case "Associative property".
    rewrite -> plus_assoc.
    reflexivity.
  rewrite -> H''.
  reflexivity.
  Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  plus x (plus y (Succ lf1)).


From mathcomp Require Import ssreflect.

Require Import collect_operator.
Require Import direct_product.
Require Import mapping.
Require Import mapping_morphism.
Require Import family_collection.

Inductive EquivalenceClass {U:Type} (R:Relation U) (a:U) : Collection U :=
  definition_of_equivalence_class: forall x:U, EquivalenceRelation U R /\ R a x -> x ∈ EquivalenceClass R a.
(*
Inductive QuotientSet {U:Type} (R:Relation U) (X:Collection U) : Collection (Collection U) :=
  definition_of_quotinet_set: forall (A:Collection U), (forall x:U, x ∈ X -> A ⊂ EquivalenceClass R x) -> A ∈ QuotientSet R X.
 *)
Definition QuotientSet (U:Type) (R:Relation U) (a:U) := PowerCollection (EquivalenceClass R a).

Definition EquivalenceClassByFunction {U V:Type} (f:U->V) (a:U) :=
  EquivalenceClass (fun x y:U => f x = f y) a.

Section EquivalenceClass.
  Variable U V:Type.
  Variable R:Relation U.

  Theorem a_element_in_equivalence_class_of_it_element:
    EquivalenceRelation U R ->
    forall a:U, a ∈ EquivalenceClass R a.
  Proof.
    move => H a.
    split.
    split.
    split.
    apply H.
    apply H.
    apply H.
    inversion H.
    apply H0.
  Qed.

  Theorem equivalence_relation_element_in_equivalence_class_of_it_element:
    EquivalenceRelation U R ->
    forall a x:U, R a x -> x ∈ EquivalenceClass R a.
  Proof.
    move => H a x HR.
    split.
    split; assumption.
  Qed.

  Theorem element_in_equivalence_class_of_it_element_to_relation:
    EquivalenceRelation U R ->
    forall a x:U, x ∈ EquivalenceClass R a -> R a x.
  Proof.
    move => HR a x H.
    inversion H.
    inversion H0.
    apply H3.
  Qed.

  Theorem equivalence_relation_to_equivalence_class_eq:
    EquivalenceRelation U R ->
    forall a b:U, R a b -> EquivalenceClass R a = EquivalenceClass R b.
  Proof.
    move => H a b HR.
    inversion H.
    apply mutally_included_to_eq.
    split => x H';[inversion H' as [x0 [HR' HRax]]|
                   inversion H' as [x0 [HR' HRbx]]];
             split;split.
    apply H.
    apply H1.
    apply (H2 x a b).
    apply H1.
    trivial.
    assumption.
    apply H.
    apply (H2 a b x).
    apply HR.
    assumption.
  Qed.

  Theorem equivalence_class_eq_to_equivalence_relation:
    EquivalenceRelation U R ->
    forall a b:U, EquivalenceClass R a = EquivalenceClass R b -> R a b.
  Proof.
    move => HR a b H.
    apply mutally_included_iff_eq in H.
    inversion H.
    move: (H1 b) => H1b.
    apply element_in_equivalence_class_of_it_element_to_relation.
    apply HR.
    apply H1b.
    apply a_element_in_equivalence_class_of_it_element.
    apply HR.
  Qed.

  Theorem equivalence_relation_iff_equivalence_class_eq:
    EquivalenceRelation U R ->
    forall a b:U,  R a b <-> EquivalenceClass R a = EquivalenceClass R b.
  Proof.
    move => HR a b.
    rewrite /iff.
    split;[apply equivalence_relation_to_equivalence_class_eq|
           apply equivalence_class_eq_to_equivalence_relation];trivial.
  Qed.

  Theorem same_relation_to_intersection_of_equivalence_class_not_empty:
    EquivalenceRelation U R ->
    forall a b:U, R a b -> EquivalenceClass R a ∩ EquivalenceClass R b <> `Ø`.
  Proof.
    move => HR a b H.
    apply exists_element_in_collection_to_not_empty_collection.
    exists a.
    split;[apply a_element_in_equivalence_class_of_it_element|
           apply equivalence_relation_element_in_equivalence_class_of_it_element];trivial.
    inversion HR.
    apply H1.
    assumption.
  Qed.

  Theorem intersection_of_equivalence_class_not_empty_to_same_relation:
    EquivalenceRelation U R ->
    forall a b:U, EquivalenceClass R a ∩ EquivalenceClass R b <> `Ø` -> R a b.
  Proof.
    move => HR a b H.
    apply not_empty_collection_to_exists_element_in_collection in H.
    inversion H as [x].
    inversion H0.
    apply element_in_equivalence_class_of_it_element_to_relation.
    trivial.
    suff: R a b.
    apply equivalence_relation_element_in_equivalence_class_of_it_element.
    trivial.
    inversion HR.
    apply: (H6 a x b).
    apply element_in_equivalence_class_of_it_element_to_relation;trivial.
    apply H5.
    apply element_in_equivalence_class_of_it_element_to_relation;trivial.
  Qed.

  Theorem same_relation_iff_intersection_of_equivalence_class_not_empty:
    EquivalenceRelation U R ->
    forall a b:U, R a b <-> EquivalenceClass R a ∩ EquivalenceClass R b <> `Ø`.
  Proof.
    move => HR a b.
    rewrite /iff.
    split;[apply same_relation_to_intersection_of_equivalence_class_not_empty|
           apply intersection_of_equivalence_class_not_empty_to_same_relation];trivial.
  Qed.

  Theorem result_value_same_to_equivalence_class_eq:
    forall (f:U->V), forall a b:U,
        f a = f b -> EquivalenceClassByFunction f a = EquivalenceClassByFunction f b.
  Proof.
    move => f a b H.
    apply mutally_included_to_eq.
    split => x H'.
    inversion H'.
    inversion H0.
    split.
    split.
    apply H2.
    rewrite -H3.
    apply eq_sym.
    trivial.
    inversion H'.
    inversion H0.
    split.
    split.
    apply H2.
    rewrite -H3.
    assumption.
  Qed.

End EquivalenceClass.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Theorem plus_id_example : forall n m:nat, n = m -> n + n = m + m.
1 subgoal

  ============================
  forall n m : nat, n = m -> n + n = m + m

plus_id_example < Proof.
1 subgoal

  ============================
  forall n m : nat, n = m -> n + n = m + m

plus_id_example < intros n m.
1 subgoal

  n, m : nat
  ============================
  n = m -> n + n = m + m

plus_id_example < intros H.
1 subgoal

  n, m : nat
  H : n = m
  ============================
  n + n = m + m

plus_id_example < rewrite -> H.
1 subgoal

  n, m : nat
  H : n = m
  ============================
  m + m = m + m

plus_id_example < reflexivity.
No more subgoals.

plus_id_example < Qed.
Proof.
intros n m.
intros H.
rewrite H.
reflexivity.

Qed.
plus_id_example is defined


Require Import List.
Section Last.

Variable A : Type.
Set Implicit Arguments.

Inductive last (a:A) : list A -> Prop :=
   | last_hd : last a (a :: nil)
   | last_tl : forall (b:A) (l:list A), last a l -> last a (b :: l).

Hint Constructors last.

Fixpoint last_fun (l:list A) : option A :=
  match l with
  | nil => None (A:=A)
  | a :: nil => Some a
  | a :: l' => last_fun l'
  end.

Theorem last_fun_correct :
 forall (a:A) (l:list A), last a l -> last_fun l = Some a.
Proof.
 intros a l H; induction H as [| b l H IH].
 - reflexivity.
 -   destruct l; simpl in *.
    +  discriminate IH.
    +  assumption.
Qed.

Theorem last_fun_correct_R :
 forall (a:A) (l:list A), last_fun l = Some a -> last a l.
Proof.
 intros a l ; induction l as [ |a0 l0 IHl0]; simpl.
 - discriminate.
 -  destruct l0.
   + injection 1;intros;subst a0;auto.
   +  intro e; simpl; auto.
Qed.

Lemma last_fun_of_cons : forall (l:list A) (a:A), last_fun (a :: l) <> None.
Proof.
 intros l ; induction l as [| a l0].
 -  discriminate.
 - destruct l0;simpl;auto.
   + discriminate.
Qed.

Theorem last_fun_correct3 :
 forall l:list A, last_fun l = None -> forall b:A, ~ last b l.
Proof.
 intro l; case l.
 - simpl; red; inversion 2.
 -  intros a l0 H;  case (last_fun_of_cons l0 a H).
Qed.

End Last.


Require Import List. Import ListNotations.
Set Implicit Arguments.

(** * Preuve assistée en Coq *)

(** Premier exemple de théorème *)
Parameters (p q : Prop).
Theorem th0 : p -> ((p -> q) -> q).
Proof.
  exact (fun (x : p) (f : p -> q) => f x).
Qed.

Theorem th : p -> (p -> q) -> q.
Proof. auto. Qed.

Print th.
(* th = fun (H : p) (H0 : p -> q) => H0 H
 : p -> (p -> q) -> q *)

(** Exemple d'utilisation de "reflexivity" *)
Lemma facile : 1 + 1 = 2.
reflexivity.
Qed.

(** Exemple d'utilisation de "rewrite" *)
Lemma exemple (pred : nat -> nat) (E : forall n : nat, 0 < n -> S (pred n) = n) (n : nat) :
  S (pred (2 * (n + 1))) = 2 * n + 2.
rewrite E.
Show 1.
Show 2.
Abort.

(** Exemple d'utilisation de "apply" *)
Lemma exemple (le_S : forall n m, n <= m -> n <= S m) (n : nat) :
  n <= S (S n).
apply le_S.
Show 1.
Abort.

(** Exemple d'utilisation de "induction" *)
Theorem add_comm : forall n m : nat, n + m = m + n.
induction n.
Show 1.
Show 2.
Abort.

(** Exemple d'utilisation de "destruct" *)
Theorem addn1_neq0 : forall n : nat, n + 1 <> 0.
destruct n.
Show 1.
Show 2.
Abort.

(** Exemple d'utilisation de "simpl" *)
Lemma example (n : nat) : 1 + n = n + 1.
simpl.
Abort.

(** ** Exemples et exercices autour des listes *)
Print rev.
Print "++".

Lemma app_nil :
  forall T (l : list T), l = l ++ [].
Proof.
induction l.
  { simpl.
    reflexivity. }
simpl.
rewrite <- IHl. (* utilise l'hypothèse d'induction *)
reflexivity.
Qed.

Lemma app_assoc :
  forall T (l1 l2 l3 : list T),
  l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
induction l1; simpl; intros; auto.
rewrite IHl1.
reflexivity.
Qed.

Lemma rev_app_distr :
  forall T (l1 l2 : list T),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
induction l1; simpl; intros.
{ apply app_nil. }
rewrite IHl1.
rewrite app_assoc.
reflexivity.
Qed.

Theorem rev_involutive :
  forall T (l : list T),
  rev (rev l) = l.
Proof.
Admitted.


(** * Types.v : Standard types and user-defined types *)

Set Implicit Arguments.

Require Export BaseDef.
Require Export Dlist.
Require Export CCMisc.

Open Scope nat_scope.

(** Polynomials *)
Module Type POLYNOMIALS.

 Parameter polynomial : Type.

 Parameter pcst :> nat -> polynomial.
 Parameter pvar : polynomial.
 Parameter pplus : polynomial -> polynomial -> polynomial.
 Parameter pmult : polynomial -> polynomial -> polynomial.
 Parameter pcomp : polynomial -> polynomial -> polynomial.

 Parameter peval : polynomial -> nat -> nat.

 Coercion peval : polynomial >-> Funclass.

 Parameter pcst_spec : forall k n, peval (pcst k) n = k.

 Parameter pvar_spec : forall n, peval pvar n = n.

 Parameter pplus_spec : forall p1 p2 n,
  peval (pplus p1 p2) n = peval p1 n + peval p2 n.

 Parameter pmult_spec : forall p1 p2 n,
    peval (pmult p1 p2) n = peval p1 n * peval p2 n.

 Parameter pcomp_spec : forall (p q : polynomial) n,
   peval (pcomp p q) n = peval p (peval q n).

 Parameter polynomial_bounded :
  forall p, exists k, forall n, 2 <= n -> peval p n <= n ^ k.

 Parameter peval_monotonic : forall (p : polynomial) n1 n2,
   n1 <= n2 -> p n1 <= p n2.

End POLYNOMIALS.

Module Poly : POLYNOMIALS.

 Definition polynomial : Type := list (nat * nat).

 Definition pcst (c:nat) : polynomial := (c,0) :: nil.

 Definition pvar : polynomial := (1,1) :: nil.

 Fixpoint mplus (c:nat) (k:nat) (p:polynomial) {struct p} : polynomial :=
  match p with
  | nil => (c,k) :: nil
  | (c',k') :: p' =>
   match nat_eqb k k' with
   | true => (c + c', k) :: p'
   | false => (c', k') :: mplus c k p'
   end
  end.

 Fixpoint pplus (p1 p2:polynomial) {struct p1} : polynomial :=
  match p1 with
  | nil => p2
  | (c,k) :: p' => mplus c k (pplus p' p2)
  end.

 Fixpoint mmult (c:nat) (k:nat) (p:polynomial) {struct p} : polynomial :=
  match p with
  | nil => nil
  | (c', k') :: p' => (c*c', k + k') :: mmult c k p'
  end.

 Fixpoint pmult (p1 p2:polynomial) {struct p1} : polynomial :=
  match p1 with
  | nil => nil
  | (c,k)::p => pplus (mmult c k p2) (pmult p p2)
  end.

 Fixpoint ppow (p : polynomial) (n : nat) {struct n} : polynomial :=
   match n with
     | 0 => pcst 1
     | S n' => pmult p (ppow p n')
   end.

 Fixpoint pcomp (p q : polynomial) : polynomial :=
   match p with
     | nil => nil
     | (c,k)::p' => pplus (pmult (pcst c) (ppow q k)) (pcomp p' q)
   end.

 Fixpoint peval (p:polynomial) (n:nat) {struct p} : nat :=
  match p with
  | nil => 0
  | (c,k) :: p' => c * n ^ k + peval p' n
  end.

 Lemma pcst_spec : forall k n, peval (pcst k) n = k.
 Proof.
  intros; simpl; ring.
 Qed.

 Lemma pvar_spec : forall n, peval pvar n = n.
 Proof.
  intros; simpl; ring.
 Qed.

 Lemma peval_mplus : forall c k p n,
  peval (mplus c k p) n = c * n ^ k + peval p n.
 Proof.
  induction p; simpl.
  intros; ring.
  intros; destruct a.
  case_eq (nat_eqb k n1); intro Heq.
  rewrite (nat_eqb_true Heq); simpl; ring.
  simpl; rewrite IHp; ring.
 Qed.

 Lemma pplus_spec : forall p1 p2 n,
  peval (pplus p1 p2) n = peval p1 n + peval p2 n.
 Proof.
  induction p1; simpl.
  trivial.
  intros; destruct a; rewrite peval_mplus, IHp1; simpl; ring.
 Qed.

 Lemma peval_mmult : forall c k p n,
   peval (mmult c k p) n = (c*n^k)*peval p n.
 Proof.
  induction p; simpl; intros.
  ring.
  destruct a; simpl.
  rewrite IHp, <- pow_mult_plus; ring.
 Qed.

 Lemma pmult_spec : forall p1 p2 n,
   peval (pmult p1 p2) n = peval p1 n * peval p2 n.
 Proof.
  induction p1; simpl; intros.
  trivial.
  destruct a.
  rewrite pplus_spec, peval_mmult, IHp1; ring.
 Qed.

 Lemma ppow_spec : forall p k n,
   peval (ppow p k) n = (peval p n) ^ k.
 Proof.
  induction k; simpl; intros; trivial.
  rewrite pmult_spec, IHk; trivial.
 Qed.

 Lemma pcomp_spec : forall (p q : polynomial) n,
   peval (pcomp p q) n = peval p (peval q n).
 Proof.
   induction p; simpl; intros; trivial.
   destruct a as (c, k).
   rewrite pplus_spec, pplus_spec, peval_mmult, ppow_spec, IHp; simpl; ring.
 Qed.

 Lemma polynomial_bounded :
  forall p, exists k, forall n, 2 <= n -> peval p n <= n ^ k.
 Proof.
  induction p; intros; simpl.
  exists 0; intros; simpl; auto.

  destruct a as (c, k0).
  destruct IHp as [k Hle].
  destruct (pow_2_le c) as [kc Hc].
  exists (S (Max.max (kc + k0) k)); intros n Hn.
  apply le_trans with (2 ^ kc * n ^ k0 + n ^ k).
  apply plus_le_compat; [ | auto].
  apply mult_le_compat; trivial.

  apply le_trans with (n ^ kc * n ^ k0 + n ^ k).
  apply plus_le_compat; [ | trivial].
  apply mult_le_compat; [ | trivial].
  apply pow_monotone_1; trivial.

  apply le_trans with (2 * n ^ (Max.max (kc + k0) k)).
  apply le_trans with (n ^ Max.max (kc + k0) k + n ^ Max.max (kc + k0) k).
  rewrite pow_mult_plus.
  apply plus_le_compat.
  apply pow_monotone_2; auto with arith.
  apply pow_monotone_2; auto with arith.
  omega.
  apply mult_le_compat; trivial.
 Qed.

 Lemma peval_monotonic : forall (p : polynomial) n1 n2,
   n1 <= n2 -> peval p n1 <= peval p n2.
 Proof.
  induction p; simpl; intros; auto.
  destruct a.
  apply plus_le_compat; auto.
  apply mult_le_compat; auto.
  apply pow_monotone_1; trivial.
 Qed.

End Poly.

Export Poly.

Lemma pplus_assoc : forall p q r k,
 peval (pplus (pplus p q) r) k = peval (pplus p (pplus q r)) k.
Proof.
 intros p q r k.
 rewrite (pplus_spec (pplus p q) r).
 rewrite (pplus_spec p q).
 rewrite <- plus_assoc.
 repeat rewrite <- pplus_spec; trivial.
Qed.

Lemma pplus_comm : forall p q k,
 peval (pplus p q) k = peval (pplus q p) k.
Proof.
 intros p q k.
 rewrite pplus_spec.
 rewrite plus_comm.
 rewrite <- pplus_spec; trivial.
Qed.

Lemma pplus_le_l : forall p1 p2 n, peval p1 n <= peval (pplus p1 p2) n.
Proof.
 intros; rewrite pplus_spec; auto with arith.
Qed.

Lemma pplus_le_r : forall p1 p2 n, peval p2 n <= peval (pplus p1 p2) n.
Proof.
 intros; rewrite pplus_spec; auto with arith.
Qed.

(** [size_nat] definition *)

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

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

Lemma log_inf_monotonic : forall (p q:positive), (p <= q)%positive ->
 log_inf p <= log_inf q.
Proof.
 unfold Ple; induction p; destruct q; simpl; intros; auto using le_n_S with arith.
 apply le_n_S; apply IHp; intro; apply H.
 case_eq ((p ?= q)%positive Gt); intros; trivial.
 destruct (Pcompare_not_Eq p q).
 elim (H2 H1).
 apply Pcompare_Gt_Lt in H1; rewrite H1 in H0; trivial.
 elim H; trivial.
 apply le_n_S; apply IHp; intro; apply H.
 rewrite <- Pcompare_eq_Gt; trivial.
 elim H; trivial.
Qed.

Lemma log_sup_inf_monotonic :forall p q,
 (p ?= q)%positive Eq = Lt ->
 S (log_inf p) <= log_sup q.
Proof.
 induction p; destruct q; simpl; intros H; try discriminate H; auto with arith.
 apply le_n_S; apply le_n_S; apply log_inf_monotonic; unfold Ple; rewrite H; intro; discriminate.
 apply le_n_S; apply IHp.
 rewrite Pcompare_eq_Lt; trivial.
 apply le_n_S; apply le_n_S; apply log_inf_monotonic; unfold Ple.
 apply Pcompare_Lt_Lt in H; destruct H.
 rewrite H; intro; discriminate.
 rewrite H, Pcompare_refl; intro; discriminate.
Qed.

Lemma log_inf_le_log_sup : forall p, log_inf p <= log_sup p.
Proof.
 induction p; intros; simpl; auto with arith.
Qed.

Lemma log_sup_le_Slog_inf : forall p, log_sup p <= S (log_inf p).
Proof.
 induction p; intros; simpl; auto with arith.
Qed.

Lemma log_sup_monotonic : forall (p q:positive), (p <= q)%positive ->
 log_sup p <= log_sup q.
Proof.
 unfold Ple; induction p; destruct q; simpl; intros;
  auto using le_n_S, log_inf_monotonic with arith.
 apply le_n_S.
 case_eq ((p ?= q)%positive Gt); intros Heq; rewrite Heq in H.
 destruct (Pcompare_not_Eq p q).
 elim (H0 Heq).
 rewrite <- Pcompare_eq_Lt in Heq.
 apply log_sup_inf_monotonic; trivial.
 elim H; trivial.
 elim H; trivial.
 apply le_n_S.
 apply le_trans with (2:= log_sup_le_Slog_inf q); auto with arith.
 apply IHp; intro; apply H; rewrite <- Pcompare_eq_Gt; trivial.
 elim H; trivial.
Qed.

Definition size_nat (n:nat) : nat :=
 match n with
 | O => S O
 | _ => log_sup (P_of_succ_nat n)
 end.

Lemma size_nat_double : forall n,
 0 < n -> size_nat (2 * n) = S (size_nat n).
Proof.
 intros n Hn.
 destruct n; simpl; auto with arith.
 clear; rewrite plus_0_r, <- plus_n_Sm; simpl.
 rewrite ZL3.
 induction (P_of_succ_nat n); simpl.
 apply eq_S; rewrite <- IHp; trivial.
 trivial.
 trivial.
Qed.

Lemma size_nat_monotonic : forall n p,
 n <= p ->
 size_nat n <= size_nat p.
Proof.
 intros n p; case n; case p; intros.
 trivial.
 simpl.
 apply le_trans with (log_sup (P_of_succ_nat (S O))).
 trivial.
 apply log_sup_monotonic.
 simpl; intro.
 apply nat_of_P_gt_Gt_compare_morphism in H0.
 rewrite nat_of_P_succ_morphism, nat_of_P_o_P_of_succ_nat_eq_succ in H0.
 unfold nat_of_P in H0; simpl in H0; omega.
 omega.
 simpl; apply log_sup_monotonic; intro.
 apply nat_of_P_gt_Gt_compare_morphism in H0.
 repeat rewrite nat_of_P_succ_morphism, nat_of_P_o_P_of_succ_nat_eq_succ in H0; omega.
Qed.

Lemma size_nat_positive : forall n, 0 < size_nat n.
Proof.
 induction n.
 auto.
 apply lt_le_trans with (size_nat n).
 trivial.
 apply size_nat_monotonic; apply le_S; trivial.
Qed.

Lemma size_nat_plus_max : forall n m, n <= m -> size_nat (n + m) <= S (size_nat m).
Proof.
 intros; apply le_trans with (size_nat (2 * m)).
 apply size_nat_monotonic; omega.
 destruct m.
 simpl; auto with arith.
 rewrite size_nat_double; auto with arith.
Qed.

Lemma size_nat_plus : forall n m, size_nat (n + m) <= size_nat n + size_nat m.
Proof.
 intros n m.
 destruct (le_lt_dec n m).
 apply le_trans with (1 := size_nat_plus_max l).
 assert (W:= size_nat_positive n); omega.
 assert (m <= n) by omega; clear l.
 rewrite plus_comm, (plus_comm (size_nat n)).
 apply le_trans with (1 := size_nat_plus_max H).
 assert (W:= size_nat_positive m); omega.
Qed.

Fixpoint Ppow2 (n:nat) := match n with O => xH | S n => xO (Ppow2 n) end.

Lemma Ppow2_lt_compat : forall n m, n < m -> (Ppow2 n < Ppow2 m)%positive.
Proof.
 induction n; destruct m; simpl; intros.
 elimtype False; omega.
 red; trivial.
 elimtype False; omega.
 refine (IHn _ _); omega.
Qed.

Lemma Ppow2_monotonic : forall n m, n <= m -> (Ppow2 n <= Ppow2 m)%positive.
Proof.
 induction n; destruct m; simpl; intros.
 discriminate.
 discriminate.
 elimtype False; omega.
 refine (IHn _ _); omega.
Qed.

Lemma log_inf_pow : forall n, (Ppow2 (log_inf n) <= n < Ppow2 (S (log_inf n)))%positive.
Proof.
 induction n.
 destruct IHn; split.
 unfold Ple in *; simpl; intro; apply H.
 apply Pcompare_Lt_Gt; trivial.
 change ((n ?= (Ppow2 (log_inf n~1)))%positive Gt = Lt).
 rewrite <- Pcompare_eq_Lt; exact H0.
 exact IHn.
 unfold Ple, Plt; simpl; split;[discriminate | trivial].
Qed.

Lemma log_sup_inf : forall p, log_sup p = log_inf p \/ log_sup p = S (log_inf p).
Proof.
 intros p; assert (W:= log_inf_le_log_sup p); assert (W':= log_sup_le_Slog_inf p).
 omega.
Qed.

Lemma log_pow_eq : forall n, log_sup n = log_inf n -> n = Ppow2 (log_sup n).
Proof.
 induction n; simpl; intros.
 elimtype False; omega.
 rewrite <- IHn; trivial.
 injection H; trivial.
 trivial.
Qed.

Lemma log_sup_pow : forall n, log_sup (Ppow2 n) = n.
Proof.
 induction n; simpl; trivial.
 rewrite IHn; trivial.
Qed.

Lemma log_pow : forall n, (n <= Ppow2 (log_sup n))%positive.
Proof.
 intros.
 assert (W:=log_inf_pow n).
 destruct (log_sup_inf n).
 rewrite <- (log_pow_eq _ H); intro H0; rewrite Pcompare_refl in H0; discriminate H0.
 destruct W.
 unfold Ple, Plt in *; rewrite H, H1; discriminate.
Qed.

Lemma nat_of_P_le_morphism : forall p q, Ple p q -> nat_of_P p <= nat_of_P q.
Proof.
 intros.
 assert (~ nat_of_P p > nat_of_P q);[ | omega].
 intro.
 apply nat_of_P_gt_Gt_compare_complement_morphism in H0.
 apply (H H0).
Qed.

Lemma nat_of_P_le_complement_morphism : forall p q, nat_of_P p <= nat_of_P q -> Ple p q.
Proof.
 intros.
 intro.
 apply nat_of_P_gt_Gt_compare_morphism in H0; omega.
Qed.

Lemma Ppow2_mult_add : forall n m, (Ppow2 n * Ppow2 m = Ppow2 (n + m))%positive.
Proof.
 induction n; simpl; intros; trivial.
 rewrite IHn; trivial.
Qed.

Lemma log_sup_mult : forall n m, log_sup (n * m) <= log_sup n + log_sup m.
Proof.
 intros.
 apply le_trans with (log_sup (Ppow2 (log_sup n) * Ppow2 (log_sup m))).
 apply log_sup_monotonic.
 apply nat_of_P_le_complement_morphism.
 repeat rewrite nat_of_P_mult_morphism.
 apply mult_le_compat; apply nat_of_P_le_morphism; apply log_pow.
 rewrite Ppow2_mult_add, log_sup_pow; trivial.
Qed.

Lemma size_nat_mult : forall n m, size_nat (n * m) <= size_nat n + size_nat m.
Proof.
 intros n m.
 destruct n.
 simpl; auto with arith.
 destruct m.
 rewrite mult_0_r, plus_comm; simpl; auto with arith.
 unfold size_nat.
 change (log_sup (P_of_succ_nat (S n * S m)) <=
   log_sup (P_of_succ_nat (S n)) + log_sup (P_of_succ_nat (S m))).
 apply le_trans with (log_sup (P_of_succ_nat (S n) * P_of_succ_nat (S m))).
 apply log_sup_monotonic; intro.
 apply nat_of_P_gt_Gt_compare_morphism in H.
 rewrite nat_of_P_mult_morphism in H.
 repeat rewrite nat_of_P_o_P_of_succ_nat_eq_succ in H.
 ring_simplify in H; omega.
 apply log_sup_mult.
Qed.

Lemma log_sup_le : forall p, log_sup (Psucc p) <= S (log_sup p).
Proof.
 induction p; simpl.
 apply le_trans with (S (S (log_sup p))).
 apply le_n_S; trivial.
 apply le_n_S; apply le_n_S; apply log_sup_le_Slog_inf.
 apply le_n_S; apply le_n_S; apply log_inf_le_log_sup.
 trivial.
Qed.

Lemma log_sup_le_S : forall p,
 log_sup p <= log_sup (Psucc p).
Proof.
 destruct p; simpl.
 apply le_n_S.
 induction p; simpl.
 apply le_n_S; trivial.
 trivial.
 trivial.
 apply le_n_S; apply log_sup_le_Slog_inf.
 apply le_S; trivial.
Qed.

Lemma log_sup_monotonic_P_of : forall p n,
 n <= p ->
 log_sup (P_of_succ_nat n) <= log_sup (P_of_succ_nat p).
Proof.
 induction p; intros n Hn; inversion_clear Hn.
 trivial.
 trivial.
 apply le_trans with (log_sup (P_of_succ_nat p)).
 apply IHp; trivial.
 simpl; apply log_sup_le_S.
Qed.

Lemma size_nat_le : forall n,
 0 < n -> size_nat n <= n.
Proof.
 intro n; case n.
 intro Hn; trivial.
 intros n0 _.
 unfold size_nat.
 induction (S n0).
 trivial.
 simpl.
 apply le_trans with (S (log_sup (P_of_succ_nat n1))).
 apply log_sup_le.
 apply le_n_S; trivial.
Qed.

Lemma size_nat_pow_2 : forall n, size_nat (2^n) = S n.
Proof.
 induction n.
 trivial.
 change (2 ^ (S n)) with (2 * 2 ^ n).
 rewrite size_nat_double.
 rewrite IHn; trivial.
 apply pow_lt_0; auto.
Qed.

(* REMARK: should add 1 to account for the sign *)
Definition size_Z (n:Z) : nat := size_nat (Zabs_nat n).

Lemma size_Z_positive : forall n, 0 < size_Z n.
Proof.
 unfold size_Z.
 intros.
 apply size_nat_positive.
Qed.

Section EQLIST.

 Variables (A:Type) (eqb : A -> A -> bool).

 Hypothesis eqb_spec : forall x y, if eqb x y then x = y else x <> y.

 Lemma eqb_list_spec : forall x y, if eqb_list eqb x y then x = y else x <> y.
 Proof.
  induction x; destruct y; simpl; trivial; try (intro; discriminate).
  generalize (eqb_spec a a0); destruct (eqb a a0); intros; subst.
  generalize (IHx y); destruct (eqb_list eqb x y); intros; subst; trivial.
  intros H1; apply H; inversion H1; trivial.
  intros H1; apply H; inversion H1; trivial.
 Qed.

 Hypothesis Aeq_dec : forall x y:A, {x = y} + {True}.
 Hypothesis Aeq_dec_r : forall x y i, Aeq_dec x y = right _ i -> x <> y.

 Fixpoint eq_dec_list (l1 l2 : list A) {struct l1} : {l1 = l2} + {True} :=
  match l1 as l1_0 return {l1_0 = l2} + {True} with
   | nil =>
    match l2 as l2_0 return {nil = l2_0} + {True} with
     | nil => left _ (refl_equal nil)
     | _ => right _ I
    end
   | a1::l1 =>
    match l2 as l2_0 return {a1::l1 = l2_0} + {True} with
     | nil => right _ I
     | a2::l2 =>
      match Aeq_dec a1 a2 with
       | left H =>
        match H in (_ = y0) return {a1::l1 = y0::l2} + {True} with
         | refl_equal =>
          match eq_dec_list l1 l2 with
           | left H =>
            match H in (_ = y0) return {a1::l1 = a1::y0} + {True} with
             | refl_equal => left _ (refl_equal (a1::l1))
            end
           | _ => right _ I
          end
        end
       | _ => right _ I
      end
    end
  end.

 Lemma eq_dec_list_r : forall x y i, eq_dec_list x y = right _ i -> x <> y.
 Proof.
  induction x; destruct y; simpl; intro i; try (intros; intro; discriminate).
  generalize (@Aeq_dec_r a a0); destruct (Aeq_dec a a0).
  case e.
  generalize (IHx y); destruct (eq_dec_list x y).
  case e0.
  intros; discriminate.
  case t; case i; intros; intro.
  apply (H I); trivial; inversion H2; trivial.
  case t; case i; intros; intro.
  apply (H I); trivial; inversion H1; trivial.
 Qed.

End EQLIST.

(** * User-defined types *)
Module Type UTYPE.

 Parameter t : Type.
 Parameter eqb : t -> t -> bool.
 Parameter eqb_spec : forall x y, if eqb x y then x = y else x <> y.

 Parameter eq_dec : forall (x y:t), {x = y} + {True}.

 Parameter eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.

 Parameter interp : nat -> t -> Type.

 Parameter size : forall k t, interp k t -> nat.

 Parameter default : forall k t, interp k t.

 Parameter default_poly : t -> polynomial.

 Parameter size_positive : forall k t (x:interp k t), 0 < size x.

 Parameter default_poly_spec : forall k t,
  size (default k t) <= peval (default_poly t) k.

 Parameter i_eqb : forall k t, interp k t -> interp k t -> bool.
 Parameter i_eqb_spec : forall k t (x y:interp k t),
  if i_eqb x y then x = y else x <> y.

End UTYPE.

Module EmptyType <: UTYPE.

 Inductive t_ := .

 Definition t := t_.

 Definition eqb : t -> t -> bool := fun _ _ => true.

 Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
 Proof.
  destruct x.
 Qed.

 Lemma eq_dec : forall (x y:t), {x = y} + {True}.
 Proof.
  destruct x.
 Qed.

 Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
 Proof.
  destruct x.
 Qed.

 Definition interp : nat -> t -> Type := fun _ _ => Datatypes.unit.

 Definition size : forall k t, interp k t -> nat := fun _ _ _ => O.

 Definition default : forall k t, interp k t := fun _ _ => tt.

 Definition i_eqb : forall k t, interp k t -> interp k t -> bool :=
  fun _ _ _ _  => true.

 Definition default_poly : t -> polynomial := fun _ => pcst O.

 Lemma size_positive :  forall k t (x:interp k t), 0 < size x.
 Proof.
  intros k t0; elim t0.
 Qed.

 Lemma default_poly_spec : forall k t,
  size (default k t) <= peval (default_poly t) k.
 Proof.
  intros k t0; elim t0.
 Qed.

 Lemma i_eqb_spec : forall k t (x y:interp k t),
  if i_eqb x y then x = y else x <> y.
 Proof.
  intros k t0 x y; case x; case y.
  simpl; trivial.
 Qed.

End EmptyType.

(** * Types *)
Module Type TYPE (UT:UTYPE).

 Inductive type : Type :=
 | User (ut:UT.t)
 | Unit
 | Nat
 | Zt
 | Bool
 | List (t:type)
 | Pair (t1 t2:type)
 | Sum (t1 t2:type)
 | Option (t:type).

 Parameter eqb : type -> type -> bool.
 Parameter eqb_spec : forall x y, if eqb x y then x = y else x <> y.

 Parameter eq_dec : forall (x y:type), {x = y} + {True}.
 Parameter eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.

 Section INTERP.

  Variable k:nat.

  Fixpoint interp (t : type) : Type :=
   match t with
    | User ut => UT.interp k ut
    | Unit => Datatypes.unit
    | Nat => nat
    | Zt => Z
    | Bool => bool
    | List t => list (interp t)
    | Pair t1 t2 => (interp t1 * interp t2)%type
    | Sum t1 t2 => (interp t1 + interp t2)%type
    | Option t => option (interp t)
   end.

  Fixpoint type_op (dom:list type) (codom:type) {struct dom} : Type :=
   match dom with
    | nil => interp codom
    | t1 :: dom => interp t1 -> type_op dom codom
   end.

  Fixpoint ctype_op (dom:list type) (codom:type) {struct dom} : Type :=
   match dom with
    | nil => (interp codom * nat)%type
    | t1 :: dom => interp t1 -> ctype_op dom codom
   end.

  Fixpoint app_op (dom:list type) (codom:type) (op:type_op dom codom)
   (args:dlist interp dom) {struct args} : interp codom :=
   match args in (dlist _ dom0) return type_op dom0 codom -> interp codom with
   | dnil => fun (op:interp codom) => op
   | dcons t1 dom v args =>
     fun (op:type_op (t1::dom) codom) => app_op codom (op v) args
   end op.

  Fixpoint capp_op (dom:list type) (codom:type) (op:ctype_op dom codom)
   (args:dlist interp dom) {struct args} : interp codom * nat :=
   match args in (dlist _ dom0) return ctype_op dom0 codom -> interp codom * nat with
   | dnil => fun (op:interp codom * nat) => op
   | dcons t1 dom v args =>
     fun (op:ctype_op (t1::dom) codom) => capp_op codom (op v) args
   end op.

  Fixpoint default (t:type) {struct t} : interp t :=
   match t as t0 return interp t0 with
    | User ut => UT.default k ut
    | Unit => tt
    | Nat => 0%nat
    | Zt => 0%Z
    | Bool => false
    | List t1 => @nil (interp t1)
    | Pair t1 t2 => (default t1, default t2)
    | Sum t1 t2 => inl _ (default t1)
    | Option t => None
   end.

  Fixpoint default_poly (t:type) : polynomial :=
   match t with
    | User ut => UT.default_poly ut
    | Unit => 1
    | Nat => 1
    | Zt => 1
    | Bool => 1
    | List _ => 1
    | Pair t1 t2 => pplus 1 (pplus (default_poly t1) (default_poly t2))
    | Sum t1 t2 => pplus 1 (default_poly t1)
    | Option t => 1
   end.

  Fixpoint size (t:type) {struct t} : interp t -> nat :=
   match t as t0 return interp t0 -> nat with
    | User ut => fun v => UT.size v
    | Unit => fun _ => 1
    | Nat => size_nat
    | Zt => size_Z
    | Bool => fun _ => S O
    | List t1 => fun l => List.fold_right (fun v n => S (size t1 v + n)) 1 l
    | Pair t1 t2 => fun p => S (size t1 (fst p) + size t2 (snd p))%nat
    | Sum t1 t2 => fun s =>
       S (match s with inl x => size t1 x | inr y => size t2 y end)
    | Option t => fun o =>
       match o with None => 1 | Some x => S (size t x) end
   end.

 End INTERP.

 Parameter size_positive : forall k t (x:interp k t), 0 < size k t x.

 Parameter default_poly_spec : forall k t,
  size k t (default k t) <= peval (default_poly t) k.

 Parameter i_eqb : forall k t, interp k t -> interp k t -> bool.
 Parameter i_eqb_spec : forall k t (x y:interp k t),
  if i_eqb k t x y then x = y else x <> y.

 (* Dependant equality *)
 Parameter eq_dep_eq : forall (P:type->Type) (p:type) (x y:P p),
  eq_dep type P p x p y -> x = y.

 Parameter UIP_refl : forall (x:type) (p:x = x), p = refl_equal x.

 Parameter inj_pair2 : forall (P:type -> Type) (p:type) (x y:P p),
  existT P p x = existT P p y -> x = y.

 Parameter l_eq_dep_eq : forall (P : list type -> Type)
  (p : list type) (x y : P p),
  eq_dep (list type) P p x p y -> x = y.

 Parameter l_inj_pair2 : forall (P : list type -> Type)
  (p : list type) (x y : P p),
  existT P p x = existT P p y -> x = y.

 Parameter l_UIP_refl : forall (x : list type) (p : x = x), p = refl_equal x.

 Ltac dlist_inversion_aux l Heq :=
  let H := fresh "H" in
  let l1 := fresh "l" in
   match type of l with
   | dlist _ nil =>
     rewrite (l_eq_dep_eq (dlist_nil l)) in Heq
   | dlist _ (_::_) =>
     destruct (dlist_cons l) as [? [l1 H] ];
     rewrite (l_eq_dep_eq H) in Heq;
     clear H; dlist_inversion_aux l1 Heq; clear l1
   | _ => fail 1 "dlist_inversion : Unexpected type"
   end.

 Ltac dlist_inversion l :=
  let l' := fresh "l" in
  let Heq := fresh "Heq" in
   pose (l' := l);
   assert (Heq : l' = l) by (vm_cast_no_check (refl_equal l'));
   vm_compute in l;
   dlist_inversion_aux l Heq;
   unfold l' in Heq; clear l'.

End TYPE.

Module MakeType (UT:UTYPE) <: TYPE UT.

 Inductive type : Type :=
 | User (ut:UT.t)
 | Unit
 | Nat
 | Zt
 | Bool
 | List (t:type)
 | Pair (t1 t2:type)
 | Sum (t1 t2:type)
 | Option (t:type).

 Fixpoint eqb (x y : type) {struct x} : bool :=
  match x, y with
   | User ut1, User ut2 => UT.eqb ut1 ut2
   | Unit, Unit => true
   | Nat, Nat => true
   | Zt, Zt => true
   | Bool, Bool => true
   | List t1, List t2 => eqb t1 t2
   | Pair x1 x2, Pair y1 y2 => if eqb x1 y1 then eqb x2 y2 else false
   | Sum x1 x2, Sum y1 y2 => if eqb x1 y1 then eqb x2 y2 else false
   | Option x, Option y => eqb x y
   | _, _ => false
  end.

 Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
 Proof.
  induction x; destruct y; simpl; intros; trivial; try (intro; discriminate).
  generalize (UT.eqb_spec ut ut0); destruct (UT.eqb ut ut0);
   intros; subst; trivial.
  intro H1; apply H; inversion H1; trivial.
  generalize (IHx y); destruct (eqb x y); intros; subst; trivial.
  intro H1; apply H; inversion H1; trivial.
  generalize (IHx1 y1); destruct (eqb x1 y1); intros; subst.
  generalize (IHx2 y2); destruct (eqb x2 y2); intros; subst; trivial.
  intro H1; apply H; inversion H1; trivial.
  intro H1; apply H; inversion H1; trivial.
  generalize (IHx1 y1); destruct (eqb x1 y1); intros; subst.
  generalize (IHx2 y2); destruct (eqb x2 y2); intros; subst; trivial.
  intro H1; apply H; inversion H1; trivial.
  intro H1; apply H; inversion H1; trivial.
  generalize (IHx y); destruct (eqb x y); intros; subst; trivial.
  intro H1; apply H; inversion H1; trivial.
 Qed.

 Definition eq_dec (x y:type) : {x = y} + {True}.
  induction x; destruct y;
  match goal with
  | |- {?X _ _ = ?X _ _} + {True} => idtac
  | |- {?X _ = ?X _} + {True} => idtac
  | |- {?X = ?X} + {True} => left; apply refl_equal
  | _ => right; trivial
  end.
  case (UT.eq_dec ut ut0).
  intro Heq; rewrite Heq; left; trivial.
  right; trivial.

  case (IHx y).
  intro Heq; rewrite Heq; left; trivial.
  right; trivial.

  case (IHx1 y1).
  intro Heq1; rewrite Heq1.
  case (IHx2 y2).
  intro Heq2; rewrite Heq2; left; trivial.
  right; trivial.
  right; trivial.

  case (IHx1 y1).
  intro Heq1; rewrite Heq1.
  case (IHx2 y2).
  intro Heq2; rewrite Heq2; left; trivial.
  right; trivial.
  right; trivial.

  case (IHx y).
  intro Heq; rewrite Heq; left; trivial.
  right; trivial.
 Defined.

 Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
 Proof.
  induction x; destruct y; intros i; simpl; try (intros; intro; discriminate).
  case_eq (UT.eq_dec ut ut0); intros.
  clear H; generalize H0; case e; intros; discriminate.
  clear H0; assert (H0 := UT.eq_dec_r H).
  intros Heq; apply H0; inversion Heq; trivial.
  generalize (IHx y); destruct (eq_dec x y); intros; try discriminate.
  clear H; generalize H0; case e; intros; discriminate.
  generalize H; clear H; case t; intros.
  intros Heq; apply (H i); trivial; inversion Heq; trivial.
  case i; trivial.
  generalize (IHx1 y1); destruct (eq_dec x1 y1).
  case e.
  generalize (IHx2 y2); destruct (eq_dec x2 y2).
  case e0.
  intros; discriminate.
  case t; intros; intro.
  apply (H i); trivial; inversion H2; trivial.
  case i; trivial.
  case t; intros; intro.
  apply (H i); trivial; inversion H1; trivial.
  case i; trivial.
  generalize (IHx1 y1); destruct (eq_dec x1 y1).
  case e.
  generalize (IHx2 y2); destruct (eq_dec x2 y2).
  case e0.
  intros; discriminate.
  case t; intros; intro.
  apply (H i); trivial; inversion H2; trivial.
  case i; trivial.
  case t; intros; intro.
  apply (H i); trivial; inversion H1; trivial.
  case i; trivial.
  generalize (IHx y); destruct (eq_dec x y); intros; try discriminate.
  clear H; generalize H0; case e; intros; discriminate.
  generalize H; clear H; case t; intros.
  intros Heq; apply (H i); trivial; inversion Heq; trivial.
  case i; trivial.
 Qed.

 Section INTERP.

  Variable k:nat.

  Fixpoint interp (t : type) : Type :=
   match t with
    | User ut => UT.interp k ut
    | Unit => Datatypes.unit
    | Nat => nat
    | Zt => Z
    | Bool => bool
    | List t => list (interp t)
    | Pair t1 t2 => (interp t1 * interp t2)%type
    | Sum t1 t2 => (interp t1 + interp t2)%type
    | Option t => option (interp t)
   end.

  Fixpoint type_op (dom:list type) (codom:type) {struct dom} : Type :=
   match dom with
    | nil => interp codom
    | t1 :: dom => interp t1 -> type_op dom codom
   end.

  Fixpoint ctype_op (dom:list type) (codom:type) {struct dom} : Type :=
   match dom with
    | nil => (interp codom * nat)%type
    | t1 :: dom => interp t1 -> ctype_op dom codom
   end.

  Fixpoint app_op (dom:list type) (codom:type) (op:type_op dom codom)
   (args:dlist interp dom) {struct args} : interp codom :=
   match args in (dlist _ dom0) return type_op dom0 codom -> interp codom with
   | dnil => fun (op:interp codom) => op
   | dcons t1 dom v args =>
     fun (op:type_op (t1::dom) codom) => app_op codom (op v) args
   end op.

  Fixpoint capp_op (dom:list type) (codom:type) (op:ctype_op dom codom)
   (args:dlist interp dom) {struct args} : interp codom * nat :=
   match args in (dlist _ dom0) return ctype_op dom0 codom -> interp codom * nat with
   | dnil => fun (op:interp codom * nat) => op
   | dcons t1 dom v args =>
     fun (op:ctype_op (t1::dom) codom) => capp_op codom (op v) args
   end op.

  Fixpoint default (t:type) {struct t} : interp t :=
   match t as t0 return interp t0 with
    | User ut => UT.default k ut
    | Unit => tt
    | Nat => 0%nat
    | Zt => 0%Z
    | Bool => false
    | List t1 => @nil (interp t1)
    | Pair t1 t2 => (default t1, default t2)
    | Sum t1 t2 => inl _ (default t1)
    | Option t => None
   end.

  Fixpoint default_poly (t:type) : polynomial :=
   match t with
    | User ut => UT.default_poly ut
    | Unit => 1
    | Nat => 1
    | Zt => 1
    | Bool => 1
    | List _ => 1
    | Pair t1 t2 => pplus 1 (pplus (default_poly t1) (default_poly t2))
    | Sum t1 t2 => pplus 1 (default_poly t1)
    | Option t => 1
   end.

  Fixpoint size (t:type) {struct t} : interp t -> nat :=
   match t as t0 return interp t0 -> nat with
    | User ut => fun v => UT.size v
    | Unit  => fun _ => 1
    | Nat => size_nat
    | Zt => size_Z
    | Bool => fun _ => S O
    | List t1 => fun l => List.fold_right (fun v n => S (size t1 v + n)) 1 l
    | Pair t1 t2 => fun p => S (size t1 (fst p) + size t2 (snd p))%nat
    | Sum t1 t2 => fun s =>
       S (match s with inl x => size t1 x | inr y => size t2 y end)
    | Option t => fun o =>
       match o with None => 1 | Some x => S (size t x) end
   end.

  Fixpoint i_eqb (t:type) {struct t} : interp t -> interp t -> bool :=
   match t as t0 return interp t0 -> interp t0 -> bool with
    | User ut => @UT.i_eqb k ut
    | Unit => fun _ _ => true
    | Nat => nat_eqb
    | Zt => Zeq_bool
    | Bool => Bool.eqb
    | List t1 => eqb_list (i_eqb t1)
    | Pair t1 t2 =>
      fun (v1 v2:interp t1 * interp t2) =>
       if i_eqb t1 (fst v1) (fst v2) then i_eqb t2 (snd v1) (snd v2) else false
    | Sum t1 t2 =>
      fun (v1 v2:interp t1 + interp t2) =>
       match v1, v2 with
       | inl x1, inl x2 => i_eqb t1 x1 x2
       | inr y1, inr y2 => i_eqb t2 y1 y2
       | _, _ => false
       end
    | Option t =>
       fun v1 v2 =>
        match v1, v2 with
        | None, None => true
        | Some x1, Some x2 => i_eqb t x1 x2
        | _, _ => false
        end
   end.

  Lemma i_eqb_spec : forall t (x y:interp t),
   if i_eqb t x y then x = y else x <> y.
  Proof.
   induction t; simpl; intros.
   apply UT.i_eqb_spec.
   destruct x; destruct y; trivial.
   apply nat_eqb_spec.
   case_eq (Zeq_bool x y); intros.
   apply Zeq_bool_eq; exact H.
   apply Zeq_bool_neq; exact H.
   case_eq (Bool.eqb x y); intros.
   apply eqb_prop; trivial.
   intro; subst; rewrite eqb_reflx in H; discriminate.
   apply eqb_list_spec; auto.
   generalize (IHt1 (fst x) (fst y)); destruct (i_eqb t1 (fst x) (fst y));
    intros; subst.
   generalize (IHt2 (snd x) (snd y)); destruct (i_eqb t2 (snd x) (snd y));
    intros; subst; trivial.
   destruct x; destruct y; simpl in H, H0; subst; trivial.
   intro H1; apply H0; inversion H1; trivial.
   intro H1; apply H; inversion H1; trivial.

   destruct x as [x1 | y1]; destruct y as [x2 | y2].
   generalize (IHt1 x1 x2); destruct (i_eqb t1 x1 x2).
   intro; subst; trivial.
   intros H0 H1; apply H0; injection H1; trivial.
   discriminate.
   discriminate.
   generalize (IHt2 y1 y2); destruct (i_eqb t2 y1 y2).
   intro; subst; trivial.
   intros H0 H1; apply H0; injection H1; trivial.

   destruct x; destruct y.
   generalize (IHt i i0); case (i_eqb t i i0).
   intro; subst; trivial.
   intros H0 H1; apply H0; injection H1; trivial.
   discriminate.
   discriminate.
   trivial.
  Qed.

 End INTERP.

 Lemma size_positive :  forall k t (x:interp k t), 0 < size k t x.
 Proof.
  intros k t x.
  destruct t; simpl.
  apply UT.size_positive.
  auto.
  apply size_nat_positive.
  apply size_Z_positive.
  auto.
  induction x; simpl; auto with arith.
  auto with arith.
  auto with arith.
  case x; auto with arith.
 Qed.

 Lemma default_poly_spec : forall k t,
  size k t (default k t) <= peval (default_poly t) k.
 Proof.
  intros k t.
  induction t.
  simpl; apply UT.default_poly_spec.
  simpl; rewrite pcst_spec; trivial.
  simpl; rewrite pcst_spec; trivial.
  simpl; rewrite pcst_spec; trivial.
  simpl; rewrite pcst_spec; trivial.
  simpl; rewrite pcst_spec; trivial.
  simpl; rewrite pplus_spec, pcst_spec, pplus_spec; simpl.
  apply le_n_S; apply plus_le_compat; trivial.
  simpl; rewrite pplus_spec, pcst_spec.
  apply le_n_S; trivial.
  simpl; rewrite pcst_spec; trivial.
 Qed.

 (** Dependant equality *)
 Module Tdec <: DecidableType.

  Definition U := type.

  Lemma eq_dec : forall (t1 t2:type), {t1 = t2} + {t1 <> t2}.
  Proof.
   intros t1 t2; generalize (eqb_spec t1 t2); destruct (eqb t1 t2); auto.
  Qed.

 End Tdec.

 Include DecidableEqDepSet Tdec.

 Module LTdec <: DecidableType.

  Definition U := list type.

  Lemma eq_dec : forall (l1 l2:list type), {l1 = l2} + {l1 <> l2}.
  Proof.
   intros l1 l2; generalize (eqb_list_spec eqb eqb_spec l1 l2).
   destruct (eqb_list eqb l1 l2); auto.
  Qed.

 End LTdec.

 Module LTeqdep := DecidableEqDepSet LTdec.

 Lemma l_eq_dep_eq : forall (P : list type -> Type) (p : list type) (x y : P p),
  eq_dep (list type) P p x p y -> x = y.
 Proof LTeqdep.eq_dep_eq.

 Lemma l_inj_pair2 : forall (P : list type -> Type) (p : list type) (x y : P p),
  existT P p x = existT P p y -> x = y.
 Proof LTeqdep.inj_pair2.

 Lemma l_UIP_refl : forall (x : list type) (p : x = x), p = refl_equal x.
 Proof LTeqdep.UIP_refl.

 Ltac dlist_inversion_aux l Heq :=
  let H := fresh "H" in
  let l1 := fresh "l" in
   match type of l with
   | dlist _ nil =>
     rewrite (l_eq_dep_eq (dlist_nil l)) in Heq
   | dlist _ (_::_) =>
     destruct (dlist_cons l) as [? [l1 H] ];
     rewrite (l_eq_dep_eq H) in Heq;
     clear H; dlist_inversion_aux l1 Heq; clear l1
   | _ => fail 1 "dlist_inversion : Unexpected type"
   end.

 Ltac dlist_inversion l :=
  let l' := fresh "l" in
  let Heq := fresh "Heq" in
   pose (l' := l);
   assert (Heq : l' = l) by (vm_cast_no_check (refl_equal l'));
   vm_compute in l;
   dlist_inversion_aux l Heq;
   unfold l' in Heq; clear l'.

End MakeType.

Close Scope nat_scope.


(* -*- coq-prog-name: "~/research/coq/trunk/bin/coqtop.byte"; coq-prog-args: ("-emacs-U" "-R" "." "FingerTree" "-R" "../../safe" "Safe" "-R" "../../monads" "Monad") -*- *)
(* begin hide *)
Require Import FingerTree.Monoid.
Require Import FingerTree.Notations.
Require Import Coq.Program.Program.
Set Implicit Arguments.
(* end hide *)
(** ** Digits *)
Section Digit.
  Variable A : Type.

  (** A digit is simply a buffer of one to four values. *)

  Inductive digit : Type :=
  | One : A -> digit
  | Two : A -> A -> digit
  | Three : A -> A -> A -> digit
  | Four : A -> A -> A -> A -> digit.

  (** We build simple functional predicates on digits for use in specifications. *)

  Definition full (x : digit) :=
    match x with Four _ _ _ _ => True | _ => False  end.

  (* begin hide *)
  Definition single (x : digit) :=
    match x with One _ => True | _ => False end.
  (* end hide *)
  (** We now define addition of an element to the left of a digit. *)

  Program Definition add_digit_left (a : A)
    (d : digit | ~ full d) : digit :=
    match d with
      | One x => Two a x
      | Two x y => Three a x y
      | Three x y z => Four a x y z
      | Four _ _ _ _ => !
    end.

  (** It has become a little more interesting here, as we define our first %\emph{partial}%
     function. We can add to a digit if and only if it is not already full.
     So, we require the argument digit to be accompanied by a proof that it is not full.
     We will use it to prove that the last branch is inaccessible ;
     we use the notation ! ('bang') to denote inaccessible program points, which are
     points where [False] can be proved.
     Note that we can pattern-match on
     [d] as if it was just a digit: properties have no influence on code, only on proofs.

     The generated obligation (figure \ref{fig:}) is easily solved, as we have a contradiction in the context:
     both [~ full d] and [d = Four _ _ _ _] are present.
     We can define in a similar fashion addition on the right and the various
     accessors on digits ([head], [tail], [last] and [liat]).
     From now on we will omit the proof scripts used to solve obligations.
     *)

  Next Obligation.
    intros ; simpl in H ; auto.
  Qed.

  (* begin hide *)
  Program Definition add_digit_right (d : digit | ~ full d ) (a : A) : digit :=
    match d with
      | One x => Two x a
      | Two x y => Three x y a
      | Three x y z => Four x y z a
      | Four _ _ _ _ => !
    end.

  Next Obligation.
  Proof.
    intros ; simpl in H ; elim H ; auto.
  Qed.

  Definition digit_head (d : digit) : A :=
    match d with
      | One x => x
      | Two x _ => x
      | Three x _ _ => x
      | Four x _ _ _ => x
    end.

  Program Definition digit_tail (d : digit | ~ single d) : digit :=
    match d with
      | One _ => !
      | Two x y => One y
      | Three x y z => Two y z
      | Four x y z w => Three y z w
    end.

  Next Obligation.
  Proof.
    intros ; simpl in H ; auto.
  Qed.

  Definition digit_last (d : digit) : A :=
    match d with
      | One x => x
      | Two _ x => x
      | Three _ _ x => x
      | Four _ _ _ x => x
    end.

  Program Definition digit_liat (d : digit | ~ single d) : digit :=
    match d with
      | One _ => !
      | Two x y => One x
      | Three x y z => Two x y
      | Four x y z w => Three x y z
    end.

  Next Obligation.
  Proof.
    intros ; elim H ; simpl ; auto.
  Qed.

End Digit.

Require Import Modules.

(* begin hide *)
Module DigitMeasure(M : Monoid).
  Import M.
  Definition v := M.m.

  Section Measure.
    Variable A : Type.
    Variable measure : A -> v.
    Notation " 'lparr' x 'rparr' " := (measure x) (x ident, no associativity).

    Definition digit_measure (d : digit A) : v :=
      match d with
        | One x => measure x
        | Two x y => measure x cdot measure y
        | Three x y z => measure x cdot measure y cdot measure z
        | Four x y z w => measure x cdot measure y cdot measure z cdot measure w
      end.

    Definition option_measure (A:Type) (measure : A -> v) (x : option A) :=
      match x with Some x => measure x | None => epsilon end.
  End Measure.

  Definition option_digit_measure (A : Type) (measure : A -> v) :=
     option_measure (digit_measure measure).

  Ltac splitTac :=
    program_simpl ; auto with * ; intuition ; try right ; unfold option_measure ; unfold digit_measure ; simpl ;
      monoid_tac ; auto ; repeat rewrite <- monoid_assoc ; auto.

  Obligation Tactic := splitTac.

  Section Digits.
    Variable A : Type.
    Variable measure : A -> v.
    Notation " 'lparr' x 'rparr' " := (measure x) (x ident, no associativity).

    Program Definition get_digit (p : v -> bool) (d : digit A)
      (i : v | p i = false /\ p (i cdot digit_measure measure d) = true) :
      { (s, x) : v * A | p s = false /\ p (s cdot lparr x rparr) = true } :=
      match d with
        | One x => (i, x)
        | Two x y =>
          let i' := i cdot lparr x rparr in
            if dec (p i') then (i, x) else (i', y)
        | Three x y z =>
          let i' := i cdot lparr x rparr in
            if dec (p i') then (i, x)
            else
              let i'' := i' cdot lparr y rparr in
              if dec (p i'') then (i', y) else (i'', z)
        | Four x y z w =>
          let i' := i cdot lparr x rparr in
            if dec (p i') then (i, x)
            else
              let i'' := i' cdot lparr y rparr in
              if dec (p i'') then (i', y)
              else
                let i''' := i'' cdot lparr z rparr in
                if dec (p i''') then (i'', z) else  (i''', w)
      end.

    Program Definition split_digit (p : v -> bool) (i : v) (d : digit A) :
      { (l, x, r) : option (digit A) * A * option (digit A) |
        digit_measure measure d = option_digit_measure measure l cdot measure x cdot option_digit_measure measure r /\
        (l = None \/ p (i cdot (option_measure (digit_measure measure) l)) = false) /\
        (r = None \/ p (i cdot (option_measure (digit_measure measure) l) cdot (measure x)) = true) } :=
      match d with
        | One x => (None, x, None)
        | Two x y =>
          let i' := i cdot lparr x rparr in
            if dec (p i') then (None, x, Some (One y))
            else (Some (One x), y, None)
        | Three x y z =>
          let i' := i cdot lparr x rparr in
          let i'' := i' cdot lparr y rparr in
            if dec (p i') then
              (None, x, Some (Two y z))
            else if dec (p i'') then
              (Some (One x), y, Some (One z))
            else
              (Some (Two x y), z, None)
        | Four x y z w =>
          let i' := i cdot lparr x rparr in
            if dec (p i') then
              (None, x, Some (Three y z w))
            else let i'' := i' cdot lparr y rparr in
              if dec (p i'') then
                (Some (One x), y, Some (Two z w))
              else let i''' := i'' cdot lparr z rparr in
                if dec (p i''') then
                  (Some (Two x y), z, Some (One w))
                else
                  (Some (Three x y z), w, None)
      end.

  End Digits.
End DigitMeasure.

(* end hide *)