(*|
#####################################################
How to replace a term with some property of the term?
#####################################################

:Link: https://stackoverflow.com/q/69949496
|*)

(*|
Question
********

I apologize if this example is contrived, I am attempting to prove a
similar Lemma with a more complex function than ``list_even``. I wish
to prove some property about a translation of a list.
|*)

Require Import Coq.Lists.List.
Import ListNotations.

Definition list_even (c : list nat) := map Nat.even c.

Lemma list_even_split : forall (c : list nat),
    c = nil \/
      exists c1 c2 b,
        c = c1 ++ c2
        /\ list_even c1 = b :: nil
        /\ list_even c = b :: list_even c2.

(*| The proof I came up with is as follows. |*)

Proof.
  induction c.
  - left. reflexivity.
  - right. exists [a], c.
    (* I am stuck here. *)
    assert (e := Nat.even a).

(*|
If I were to prove this by hand, my argument goes as follows.

Let ``c = [a] :: c2``, so ``c1 = [a]``. By ``Nat.Even_or_Odd``, ``a``
is even or it is odd. If ``a`` is even, then ``b = true`` and so

.. code-block:: coq

    c = [a] ++ c2 /\
        list_even [a] = [true] /\
        list_even c = true :: list_even c2

If ``a`` is odd, then ``b = false`` and so

.. code-block:: coq

    c = [a] ++ c2 /\
        list_even [a] = [false] /\
        list_even c = false :: list_even c2

which hold by simplification and reflexivity.

However, I do not know how to translate the proof state of
|*)

    Show. (* .unfold .messages *)
Abort. (* .none *)

(*|
into one which proceeds with the evenness of ``a``.

I also do not believe I need induction for this.
|*)

(*|
Answer
******

Even-ness isn't actually important to this goal, as it is just a fact
about mapping. Either ``c`` is the empty list, or ``c`` is of the form
``c = x :: xs = [x] ++ xs`` so ``map Nat.even c = Nat.even x ++ map
Nat.even xs``. As such, you could have a proof like
|*)

Lemma list_even_split : forall (c : list nat),
    c = nil \/
      exists c1 c2 b,
        c = c1 ++ c2
        /\ list_even c1 = b :: nil
        /\ list_even c = b :: list_even c2.
Proof.
  intros c.
  destruct c as [|x xs];
    [ left; auto
    | right; exists (x :: nil); do 2 eexists; repeat split; eauto ].
Qed.

(*|
However, in other cases where one needs evenness of a variable you can
record it via

.. code-block:: coq

    destruct (Nat.even x) eqn : NAT_IS_EVEN
|*)


Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthancongruence.
Require Export GeoCoq.Elements.OriginalProofs.lemma_3_6b.
Require Export GeoCoq.Elements.OriginalProofs.lemma_partnotequalwhole.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_trichotomy2 :
   forall A B C D,
   Lt A B C D ->
   ~ Lt C D A B.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists E, (BetS C E D /\ Cong C E A B)) by (conclude_def Lt );destruct Tf as [E];spliter.
assert (Cong A B C E) by (conclude lemma_congruencesymmetric).
assert (~ Lt C D A B).
 {
 intro.
 assert (Lt C D C E) by (conclude lemma_lessthancongruence).
 let Tf:=fresh in
 assert (Tf:exists F, (BetS C F E /\ Cong C F C D)) by (conclude_def Lt );destruct Tf as [F];spliter.
 assert (BetS C F D) by (conclude lemma_3_6b).
 assert (~ Cong C F C D) by (conclude lemma_partnotequalwhole).
 contradict.
 }
close.
Qed.

End Euclid.


Require Import Bool.

Theorem orb_is_or : (forall a b, Is_true (orb a b) <-> Is_true a \/ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros H.
    case a, b.
      (* suppose a=true, b=true *)
      exact (or_introl I).
      (* suppose a=true, b=false *)
      exact (or_introl I).
      (* suppose a=false, b=true *)
      exact (or_intror I).
      (* suppose a=false, b=false *)
      case H.
  intros H.
  case a, b.
    (* suppose a=true, b=true *)
    exact I.
    (* suppose a=true, b=true *)
    exact I.
    (* suppose a=true, b=true *)
    exact I.
    case H.
      (* false -> false \/ false *)
      intros A.
      case A.
      (* false -> false \/ false *)
      intros B.
      case B.
Qed.

Theorem andb_is_and : (forall a b, Is_true (andb a b) <-> Is_true a /\ Is_true b).
Proof.
  intros a b.
  unfold iff.
  refine (conj _ _).
    intros H.
    case a, b.
      (* a=true, b=true *)
      exact (conj I I).
      (* a=true, b=false *)
      case H.
      (* a=false, b=true *)
      case H.
      (* a=false, b=false *)
      case H.
    intros H.
    case a, b.
      (* a=true, b=true *)
      exact I.
      (* a=true, b=false *)
      destruct H as [ A B ].
      case B.
      (* a=false, b=true *)
      destruct H as [ A B ].
      case A.
      (* a=false, b=false *)
      destruct H as [ A B ].
      case A.
Qed.

Theorem negb_is_not : (forall a, Is_true (negb a) <-> (~(Is_true a)) ).
Proof.
  intros a.
  unfold iff.
  refine (conj _ _).
    case a.
      (* a=true *)
      simpl.
      intros H.
      case H.
      (* a=false *)
      simpl.
      intros H.
      intros A.
      case A.
    case a.
      (* a=true *)
      simpl.
      intros H.
      case H.
      exact I.
      (* a=false *)
      simpl.
      intros H.
      exact I.
Qed.


Require Export FiniteTypes Relation_Definitions ZArith QArith IndexedFamilies.
Require Import InfiniteTypes CSB DecidableDec
               FunctionalExtensionality ProofIrrelevance
               DependentTypeChoice ClassicalChoice
               Arith ArithRing.

Local Close Scope Q_scope.

Set Asymmetric Patterns.

Inductive CountableT (X : Type) : Prop :=
  | intro_nat_injection (f : X -> nat) : injective f -> CountableT X.

Lemma CountableT_is_FiniteT_or_countably_infinite (X : Type) :
  CountableT X -> {FiniteT X} + {exists f : X -> nat, bijective f}.
Proof.
intros.
apply exclusive_dec.
- intro.
  destruct H0 as [? [f ?]].
  contradiction nat_infinite.
  apply bij_finite with _ f; trivial.
  apply bijective_impl_invertible; trivial.
- destruct (classic (FiniteT X)).
  + left; trivial.
  + right.
    apply infinite_nat_inj in H0.
    destruct H, H0 as [g].
    now apply CSB with f g.
Qed.

Lemma nat_countable : CountableT nat.
Proof.
apply intro_nat_injection with (fun n => n).
now intros [|m] [|n].
Qed.

Lemma countable_nat_product: CountableT (nat * nat).
Proof.
pose (sum_1_to_n := fix sum_1_to_n n:nat := match n with
  | O => O
  | S m => (sum_1_to_n m) + n
end).
exists (fun p:nat*nat => let (m,n):=p in
  (sum_1_to_n (m+n)) + n).
assert (forall m n:nat, m<n ->
  sum_1_to_n m + m < sum_1_to_n n).
- intros.
  induction H.
  + simpl.
    auto with arith.
  + apply lt_trans with (sum_1_to_n m0); trivial.
    assert (sum_1_to_n m0 + 0 < sum_1_to_n m0 + S m0) by auto with arith.
    assert (sum_1_to_n m0 + 0 = sum_1_to_n m0) by auto with arith.
    now rewrite H1 in H0.
- intros [x1 y1] [x2 y2] H0.
  case (lt_eq_lt_dec (x1+y1) (x2+y2)); intro.
  + case s; intro.
    * assert (sum_1_to_n (x1+y1) + y1 < sum_1_to_n (x2+y2) + y2).
      ** apply le_lt_trans with (sum_1_to_n (x1+y1) + (x1+y1)).
         *** assert (sum_1_to_n (x1+y1) + (x1+y1) =
               (sum_1_to_n (x1+y1) + y1) + x1);
             [ ring | auto with arith ].
         *** apply lt_le_trans with (sum_1_to_n (x2+y2));
             [ apply H |];
             auto with arith.
      ** rewrite H0 in H1.
         contradict H1.
         auto with arith.
    * assert (y1=y2).
      ** rewrite e in H0.
         now apply plus_reg_l in H0.
      ** f_equal; trivial.
         rewrite H1, plus_comm, (plus_comm x2 y2) in e.
         now apply plus_reg_l in e.
  + assert (sum_1_to_n (x2+y2) + y2 < sum_1_to_n (x1+y1) + y1).
    * apply le_lt_trans with (sum_1_to_n (x2+y2) + (x2+y2)),
            lt_le_trans with (sum_1_to_n (x1+y1));
        auto with arith.
    * rewrite H0 in H1.
      contradict H1.
      auto with arith.
Qed.

Lemma countable_sum (X Y : Type) :
  CountableT X -> CountableT Y -> CountableT (X + Y).
Proof.
intros [f] [g].
destruct countable_nat_product as [h].
exists (fun s:X+Y => match s with
  | inl x => h (0, f x)
  | inr y => h (1, g y)
end).
intros [x1|y1] [x2|y2] ?;
  apply H1 in H2; try discriminate H2;
  intros; f_equal;
  apply H + apply H0;
  now injection H2.
Qed.

Lemma countable_product (X Y:Type) :
  CountableT X -> CountableT Y -> CountableT (X * Y).
Proof.
intros [f] [g].
pose (fg := fun (p:X*Y) => let (x,y):=p in (f x, g y)).
destruct countable_nat_product as [h].
exists (fun p:X*Y => h (fg p)).
intros [x1 y1] [x2 y2] H2.
apply H1 in H2.
injection H2 as H3 H4.
apply H in H3.
apply H0 in H4.
now subst.
Qed.

Lemma countable_exp (X Y : Type) :
  FiniteT X -> CountableT Y -> CountableT (X -> Y).
Proof.
intros.
induction H.
- exists (fun _ => 0).
  red; intros.
  extensionality f.
  destruct f.
- destruct (countable_product (T -> Y) Y); trivial.
  exists (fun g =>
    f (fun x => g (Some x), g None)).
  intros g1 g2 ?.
  apply H1 in H2.
  extensionality o.
  destruct o;
    injection H2;
    trivial.
  intros.
  pose proof (equal_f H4).
  apply H5.
- destruct H1, IHFiniteT.
  exists (fun h => f0 (fun x => h (f x))).
  intros h1 h2 ?.
  apply H3 in H4.
  pose proof (equal_f H4).
  simpl in H5.
  extensionality y.
  rewrite <- (H2 y).
  apply H5.
Qed.

Definition Countable {X : Type} (S : Ensemble X) : Prop :=
  CountableT {x:X | In S x}.

Lemma inj_countable {X Y : Type} (f : X -> Y) :
  CountableT Y -> injective f -> CountableT X.
Proof.
intros [g] ?.
exists (fun x:X => g (f x)).
intros x1 x2 ?.
auto.
Qed.

Lemma surj_countable {X Y : Type} (f : X -> Y) :
  CountableT X -> surjective f -> CountableT Y.
Proof.
intros.
destruct (choice (fun (y:Y) (x:X) => f x = y)) as [finv]; trivial.
apply inj_countable with finv; trivial.
intros x1 x2 ?.
congruence.
Qed.

Lemma countable_downward_closed {X : Type} (S T : Ensemble X) :
  Countable T -> Included S T -> Countable S.
Proof.
intros [f H] H0.
exists (fun x => match x with
  | exist x0 i => f (exist _ x0 (H0 _ i))
  end).
intros [x1] [x2] H1.
apply H in H1.
injection H1 as H1.
now destruct H1, (proof_irrelevance _ i i0).
Qed.

Lemma countable_img {X Y : Type} (f : X -> Y) (S : Ensemble X) :
  Countable S -> Countable (Im S f).
Proof.
intros.
assert (forall x, In S x -> In (Im S f) (f x)) by auto with sets.
pose (fS := fun x =>
  match x with
  | exist x0 i => exist _ (f x0) (H0 x0 i)
  end).
apply surj_countable with fS; trivial.
intros [? [x i y e]].
exists (exist _ x i).
simpl.
generalize (H0 x i); intro.
generalize (Im_intro X Y S f x i y e); intro.
now destruct e, (proof_irrelevance _ i0 i1).
Qed.

Lemma countable_type_ensemble  {X : Type} (S : Ensemble X) :
  CountableT X -> Countable S.
Proof.
intros.
apply (inj_countable (@proj1_sig _ (In S)) H).
intros [? ?] [? ?].
now apply subset_eq_compat.
Qed.

Lemma FiniteT_impl_CountableT (X : Type) :
  FiniteT X -> CountableT X.
Proof.
intros.
induction H.
- exists (False_rect nat).
  now intro.
- destruct IHFiniteT.
  exists (fun x => match x with
    | Some x0 => S (f x0)
    | None => 0
  end).
  intros [x1|] [x2|] H1;
    injection H1 as H1 + discriminate H1 + trivial.
  now destruct (H0 _ _ H1).
- destruct IHFiniteT as [g],
           H0 as [finv].
  exists (fun y:Y => g (finv y)).
  intros y1 y2 ?.
  apply H1 in H3.
  congruence.
Qed.

Lemma Finite_impl_Countable: forall {X : Type} (S : Ensemble X),
  Finite _ S -> Countable S.
Proof.
intros.
now apply FiniteT_impl_CountableT, Finite_ens_type.
Qed.

Lemma positive_countable: CountableT positive.
Proof.
exists nat_of_P.
intros n1 n2 ?.
now apply nat_of_P_inj.
Qed.

Lemma Z_countable: CountableT Z.
Proof.
destruct countable_nat_product as [f],
         positive_countable as [g].
exists (fun n:Z => match n with
  | Z0 => f (0, 0)
  | Zpos p => f (1, g p)
  | Zneg p => f (2, g p)
end).
intros [|p1|p1] [|p2|p2] H1;
  apply H in H1;
  discriminate H1 + trivial;
  injection H1 as H1; f_equal; auto.
Qed.

Lemma Q_countable: CountableT Q.
Proof.
destruct countable_nat_product as [f],
         positive_countable as [g],
         Z_countable as [h].
exists (fun q:Q => match q with
  n # d => f (h n, g d)
end)%Q.
intros [n1 d1] [n2 d2] ?.
apply H in H2.
injection H2 as H2.
f_equal; auto.
Qed.

Lemma countable_union: forall {X A:Type}
  (F:IndexedFamily A X), CountableT A ->
    (forall a:A, Countable (F a)) ->
    Countable (IndexedUnion F).
Proof.
intros.
destruct (choice_on_dependent_type (fun (a:A)
                               (f:{x:X | In (F a) x} -> nat) =>
  injective f)) as [choice_fun_inj].
- intro.
  destruct (H0 a).
  now exists f.
- destruct (choice (fun (x:{x:X | In (IndexedUnion F) x}) (a:A) =>
    In (F a) (proj1_sig x))) as [choice_fun_a].
  + destruct x as [x [a]].
    now exists a.
  + destruct countable_nat_product as [g],
             H as [h].
    exists (fun x:{x:X | In (IndexedUnion F) x} =>
      g (h (choice_fun_a x), choice_fun_inj _ (exist _ _ (H2 x)))).
    intros x1 x2 H4.
    apply H3 in H4.
    injection H4 as H5 H6.
    apply H in H5.
    revert H6.
    generalize (H2 x1), (H2 x2).
    rewrite H5.
    intros.
    apply H1 in H6.
    injection H6.
    destruct x1, x2.
    apply subset_eq_compat.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Nil : lst | Cons : natural -> lst -> lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rotate_len_append : forall (x y : lst), rotate (len x) (append x y) = append y x.
Proof.
   intro.
   induction x.
   - intros.  simpl. lfind.  reflexivity.
Admitted.

Theorem rotate_len : forall (x : lst), eq (rotate (len x) x) x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rotate_len_append. reflexivity.
Qed.


(*Autor: David Felipe Hernandez Chiapa
Proyecto Final de Semantica y Verificacion
*)

Require Import Nat.

Require Import List.
Require Import Utf8.

Export ListNotations.

Definition key := nat.

Inductive color := Red | Black.

Section RBTree.
Variable V : Type.
Variable default: V.

 Inductive Tree : Type :=
 | E : Tree
 | T: color → Tree → key → V → Tree → Tree.

Fixpoint lookup (x: key) (t : Tree) : V :=
  match t with
  | E => default
  | T _ tl k v tr => if x <? k then lookup x tl
                         else if k <? x then lookup x tr
                         else v
  end.

Definition balance rb t1 k vk t2 :=
 match rb with
 | Black => match t1 with
        | T Red (T Red a x vx b) y vy c => T Red (T Black a x vx b) y vy (T Black c k vk t2)
        | T Red a x vx (T Red b y vy c) => T Red (T Black a x vx b) y vy (T Black c k vk t2)
        | _ => match t2 with
            | T Red (T Red b y vy c) z vz d => T Red (T Black t1 k vk b) y vy (T Black c z vz d)
            | T Red b y vy (T Red c z vz d) => T Red (T Black t1 k vk b) y vy (T Black c z vz d)
            | _ => T Black t1 k vk t2
            end
        end
 | Red => T Red t1 k vk t2
 end.

Definition makeBlack t :=
  match t with
  | E => E
  | T _ a x vx b => T Black a x vx b
  end.

Fixpoint ins x vx t :=
 match t with
 | E => T Red E x vx E
 | T c a y vy b => if ltb x y then balance c (ins x vx a) y vy b
                        else if ltb y x then balance c a y vy (ins x vx b)
                        else T c a x vx b
 end.

Definition insert x vx t := makeBlack (ins x vx t).

Inductive SearchTreeAux : nat → Tree → nat → Prop :=
| ST_E : ∀ min max, min ≤ max → SearchTreeAux min E max
| ST_T: ∀ min c l k v r max,
    SearchTreeAux min l k →
    SearchTreeAux (S k)  r max →
    SearchTreeAux min (T c l k v r) max.

Inductive isSearchTree: Tree → Prop :=
| ST_intro: ∀ t min max, SearchTreeAux min t max → isSearchTree t.

Theorem SearchTreeCorrectness: ∀ col lt rt k v min max,
                                SearchTreeAux min lt k ->
                                SearchTreeAux (S k) rt max ->
                                SearchTreeAux min (balance col lt k v rt) max.
Proof.
intros.
unfold balance.
destruct col.
*
constructor;trivial.
*
destruct lt;destruct rt.
constructor;trivial.
destruct c.
destruct rt1;destruct rt2.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
destruct c.
destruct lt1;destruct lt2.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c0.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
destruct c;destruct lt1;destruct lt2;destruct c0;destruct rt1;destruct rt2.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c2.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
destruct c0.
constructor;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c1.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
constructor;trivial.
destruct c0.
constructor;constructor;inversion H0;inversion H8;trivial.
destruct c2.
constructor;constructor;inversion H0;inversion H9;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
constructor;trivial.
Qed.

Inductive isRB : Tree → color → nat → Prop :=
 | IsRB_leaf: ∀ c, isRB E c 0
 | IsRB_r: ∀ tl k kv tr n,
          isRB tl Red n →
          isRB tr Red n →
          isRB (T Red tl k kv tr) Black n
 | IsRB_b: ∀ c tl k kv tr n,
          isRB tl Black n →
          isRB tr Black n →
          isRB (T Black tl k kv tr) c (S n).

Lemma red_to_black : ∀ t n, isRB t Red n -> isRB t Black n.
Proof.
intros.
destruct H;constructor;trivial.
Qed.
Hint Resolve red_to_black.

Inductive nearRB : Tree → nat → Prop :=
| nrRB_r: ∀ tl k kv tr n,
         isRB tl Black n →
         isRB tr Black n →
         nearRB (T Red tl k kv tr) n
| nrRB_b: ∀ tl k kv tr n,
         isRB tl Black n →
         isRB tr Black n →
         nearRB (T Black tl k kv tr) (S n).

Lemma insAux : ∀ k x t1 n,isRB (ins k x t1) Black n -> isRB (ins k x t1) Red n.
Admitted.

Theorem ins_isRB:
  ∀ k x t n,
    (isRB t Red n → nearRB (ins k x t) n) ∧
    (isRB t Black n → isRB (ins k x t) Black n).
Proof.
induction t; intro n; simpl; split; intros; inversion H; repeat constructor; auto.
*
destruct (IHt1 n0); clear IHt1.
destruct (IHt2 n0); clear IHt2.
specialize (H10 H7).
specialize (H12 H8).
unfold balance.
destruct (k <? k0).
destruct (ins k x t1).
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18;auto.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
constructor;trivial.
destruct c1.
destruct t3.
destruct t4.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18;auto.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H10;inversion H19;auto.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18;auto.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H10;inversion H18;auto.
destruct t4.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18;auto.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H10;inversion H19;auto.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18;auto.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
constructor;trivial.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18;auto.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19;auto.
constructor;trivial.
constructor;trivial.
destruct (k0 <? k).
destruct t1.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
destruct t1_1.
destruct t1_2.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H7;inversion H19;trivial.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H7;inversion H18;trivial.
destruct t1_2.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H7;inversion H19;trivial.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
constructor;trivial.
*
destruct (IHt1 n); clear IHt1.
destruct (IHt2 n); clear IHt2.
assert (A := H6).
assert (B := H7).
apply red_to_black in H6.
apply red_to_black in H7.
specialize (H11 H7).
specialize (H9 H6).
unfold balance.
destruct (k0 <? k);destruct (k <? k0);constructor;trivial.
apply insAux;trivial.
apply insAux;trivial.
apply insAux;trivial.
*
destruct (IHt1 n0); clear IHt1.
destruct (IHt2 n0); clear IHt2.
specialize (H10 H7).
specialize (H12 H8).
unfold balance.
destruct (k <? k0).
destruct (ins k x t1).
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
destruct t3.
destruct t4.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H10;inversion H19.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H10;inversion H18.
destruct t4.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H10;inversion H19.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
constructor;trivial.
destruct t2.
constructor;trivial.
destruct c1.
destruct t2_1.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H18.
destruct t2_2.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H8;inversion H19.
constructor;trivial.
constructor;trivial.
destruct (k0 <? k).
destruct t1.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
destruct t1_1.
destruct t1_2.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H7;inversion H19.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H7;inversion H18.
destruct t1_2.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H7;inversion H19.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
destruct (ins k x t2).
constructor;trivial.
destruct c1.
destruct t1.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H18.
destruct t3.
constructor;trivial.
destruct c1.
constructor;constructor;inversion H12;inversion H19.
constructor;trivial.
constructor;trivial.
constructor;trivial.
Qed.

End RBTree.


Require Import Arith Euclid Omega.

Definition is_mod (a b r : nat) :=
  exists q, r < b /\ q * b + r = a.

Theorem a2mod3_cases : forall a, is_mod (a*a) 3 0 \/ is_mod (a*a) 3 1.
Proof.
  intros.
  assert (3 > 0) by auto with arith.
  destruct (modulo _ H a) as [r [q [Hq Hr]]].
  destruct r.
    left.
    exists (q * 3 * q).
    rewrite Hq.
    repeat rewrite <- plus_n_O.
    rewrite mult_assoc.
    now auto.
  destruct r.
    right.
    rewrite Hq.
    exists (2 * q + 3 * q * q).
    repeat rewrite <- (mult_comm 3).
    simpl.
    repeat rewrite <- plus_n_O.
    repeat rewrite mult_plus_distr_l.
    repeat rewrite mult_plus_distr_r.
    omega.
  destruct r.
    right.
    exists (1 + 4 * q + 3 * q * q).
    rewrite Hq.
    repeat rewrite <- (mult_comm 3).
    simpl.
    repeat rewrite <- plus_n_O.
    repeat rewrite mult_plus_distr_l.
    repeat rewrite mult_plus_distr_r.
    omega.
  repeat apply lt_S_n in Hr.
  elim (lt_n_O _ Hr).
Qed.

Definition div3 n := exists q, 3 * q = n.

Lemma div3_square : forall a, div3 (a * a) -> div3 a.
Proof.
  intros.
  assert (3 > 0) by auto with arith.
  destruct (modulo _ H0 a) as [r [q [Hq Hr]]].
  destruct r.
    exists q.
    omega.
  destruct r.
    destruct H as [q' Hq'].
    rewrite Hq in Hq'.
    repeat rewrite mult_plus_distr_l in *.
    repeat rewrite mult_plus_distr_r in *.
    rewrite <- (mult_comm 1) in Hq'.
    rewrite (mult_comm 3) in Hq'.
    simpl in Hq'.
    repeat rewrite <- plus_n_O in Hq'.
    rewrite plus_assoc in Hq'.
    repeat rewrite mult_assoc in Hq'.
    repeat rewrite <- mult_plus_distr_r in Hq'.
    apply plus_minus in Hq'.
    rewrite <- mult_minus_distr_r in Hq'.
    destruct (q' - (q * 3 * q + q + q)).
      discriminate.
    simpl in Hq'.
    inversion Hq'.
  destruct r.
    destruct H as [q' Hq'].
    rewrite Hq in Hq'.
    repeat rewrite mult_plus_distr_l in *.
    repeat rewrite mult_plus_distr_r in *.
    rewrite (mult_assoc 2), (mult_comm 2) in Hq'.
    rewrite <- (mult_assoc q 3 2) in Hq'.
    repeat rewrite (mult_comm 3) in Hq'.
    repeat rewrite mult_assoc in Hq'.
    simpl in Hq'.
    change 4 with (1*3 + 1) in Hq'.
    repeat rewrite plus_assoc in Hq'.
    repeat rewrite <- mult_plus_distr_r in Hq'.
    apply plus_minus in Hq'.
    rewrite <- mult_minus_distr_r in Hq'.
    destruct (q' - (q * 3 * q + q * 2 + q * 2 + 1)).
      discriminate.
    simpl in Hq'.
    inversion Hq'.
  repeat apply lt_S_n in Hr.
  elim (lt_n_O _ Hr).
Qed.

Theorem a_b_c_div3 : forall a b c,
  a * a + b * b = 3 * c * c -> div3 a /\ div3 b /\ div3 c.
Proof.
  intros.
  destruct (a2mod3_cases a), (a2mod3_cases b).
  + assert (div3 a).
      destruct H0 as [q [Hr Hq]].
      rewrite <- plus_n_O in Hq.
      apply div3_square.
      exists q.
      now rewrite mult_comm.
    assert (div3 b).
      destruct H1 as [q [Hr Hq]].
      rewrite <- plus_n_O in Hq.
      apply div3_square.
      exists q.
      now rewrite mult_comm.
    assert (div3 c).
      apply div3_square.
      destruct H2 as [qa Ha].
      destruct H3 as [qb Hb].
      rewrite <-Ha, <-Hb in H.
      repeat rewrite mult_assoc in H.
      repeat rewrite <- (mult_comm 3) in H.
      repeat rewrite <- mult_assoc in H.
      rewrite <- mult_plus_distr_l in H.
      assert (3 * (qa * qa) + 3 * (qb * qb) = c * c) by omega.
      rewrite <- mult_plus_distr_l in H2.
      esplit; eauto.
    now auto.
  + destruct H0 as [qa [Hra Hqa]].
    destruct H1 as [qb [Hrb Hqb]].
    rewrite <- Hqa, <- Hqb in H.
    rewrite <- mult_assoc, (mult_comm 3) in H.
    rewrite <- (plus_comm 0) in H.
    simpl in H.
    rewrite plus_assoc in H.
    apply eq_sym in H.
    apply plus_minus in H.
    rewrite <- mult_plus_distr_r, <- mult_minus_distr_r in H.
    destruct (c * c - (qa + qb)).
      discriminate.
    simpl in H.
    inversion H.
  + destruct H0 as [qa [Hra Hqa]].
    destruct H1 as [qb [Hrb Hqb]].
    rewrite <- Hqa, <- Hqb in H.
    rewrite <- mult_assoc, (mult_comm 3) in H.
    rewrite <- (plus_comm 0) in H.
    simpl in H.
    rewrite <- plus_assoc, (plus_comm 1 (qb * 3)), plus_assoc in H.
    apply eq_sym, plus_minus in H.
    rewrite <- mult_plus_distr_r, <- mult_minus_distr_r in H.
    destruct (c * c - (qa + qb)).
      discriminate.
    simpl in H.
    inversion H.
  + destruct H0 as [qa [Hra Hqa]].
    destruct H1 as [qb [Hrb Hqb]].
    rewrite <- Hqa, <- Hqb in H.
    rewrite <- mult_assoc, (mult_comm 3) in H.
    rewrite <- plus_assoc, (plus_comm 1 (qb * 3 + 1)) in H.
    repeat rewrite plus_assoc in H.
    rewrite <- plus_assoc in H.
    apply eq_sym, plus_minus in H.
    rewrite <- mult_plus_distr_r, <- mult_minus_distr_r in H.
    destruct (c * c - (qa + qb)).
      discriminate.
    simpl in H.
    inversion H.
Qed.

Require Import Wf_nat.

Theorem a_b_c_0 : forall a b c,
  a * a + b * b = 3 * c * c -> a = 0 /\ b = 0 /\ c = 0.
Proof.
  intros a b c; revert a b.
  induction c using lt_wf_ind.
  intros a b Habc.
  destruct c.
    destruct a; try discriminate.
    destruct b; try discriminate.
    now auto.
  destruct (a_b_c_div3 _ _ _ Habc) as [[qa Ha] [[qb Hb] [qc Hc]]].
  rewrite <- Ha, <- Hb, <- Hc in Habc |- *.
  assert (qc < S c) by omega.
  destruct (H qc H0 qa qb) as [Hqa [Hqb Hqc]].
    repeat rewrite <- mult_assoc in Habc.
    rewrite (mult_comm qa), (mult_comm qb), (mult_comm qc) in Habc.
    repeat rewrite mult_assoc in Habc.
    simpl (3*3) in Habc.
    repeat rewrite <- mult_assoc in Habc.
    rewrite (mult_assoc 3 qc qc) in Habc.
    omega.
  subst.
  now auto.
Qed.


Require Import List Min Arith Div2.

Notation "n .+1" := (S n)(at level 2, left associativity, format "n .+1"): nat_scope.

(* Minus *)

Lemma minus_match k1 k2: match k2 - k1 with O => k2 <= k1 | S _ => k1 < k2 end.
Proof.
generalize k2; clear k2.
induction k1 as [| k1 IH]; intros [| k2]; simpl; auto with arith.
generalize (IH k2); case minus; auto with arith.
Qed.

(* The exponential function *)

Section Exp.

Fixpoint exp (n m: nat) {struct m} : nat :=
  match m with O => 1 | 1 => n | (S m1) => n * exp n m1 end.

Lemma exp0 n: exp n 0 = 1.
Proof. auto. Qed.

Lemma expS n m: exp n (S m) = n * exp n m.
Proof.
destruct m; simpl; auto; rewrite <- mult_n_Sm; rewrite <- mult_n_O; auto.
Qed.

End Exp.

(* Some iterators on list *)

Section Fold2.

Variable A B C: Type.
Variable f: A -> B -> C -> C.

Definition dhead a (l : list A) :=
  match l with nil => a | b :: _ => b end.

Fixpoint fold2 (l1: list A) (l2: list B) (c: C) {struct l1}: C :=
  match l1, l2 with
    a::l3, b::l4 => fold2 l3 l4 (f a b c)
  | _, _ => c
  end.

Variable g: A -> B -> C.

Fixpoint map2 (l1: list A) (l2: list B) {struct l1}: list C :=
  match l1, l2 with
    a::l3, b::l4 => (g a b)::map2 l3 l4
  | _, _ => nil
  end.

Lemma map2_length l1 l2:
  length (map2 l1 l2) = min (length l1) (length l2).
Proof.
generalize l2; clear l2.
induction l1 as [| a1 l1 IH]; intros [| a2 l2]; simpl; auto.
Qed.

Fixpoint dmap2 (a : A) (l1: list A) (l2: list B) {struct l2}: list C :=
  match l1, l2 with
    a1::l3, b1 :: l4 => g a1 b1 :: dmap2 a l3 l4
  |    nil, b1 :: l4 =>  g a b1 :: dmap2 a nil l4
  | _, _ => nil
  end.

End Fold2.
Arguments dhead[A].
Arguments fold2[A B C].
Arguments map2[A B C].
Arguments dmap2[A B C].

Section Perm.

Variable A: Type.

Inductive perm: list A -> list A -> Prop :=
  perm_id: forall l, perm l l
| perm_swap: forall a b l,  perm (a::b::l) (b::a::l)
| perm_skip: forall a l1 l2,  perm l1 l2 -> perm (a::l1) (a::l2)
| perm_trans: forall l1 l2 l3, perm l1 l2 -> perm l2 l3 -> perm l1 l3.

Lemma perm_sym l1 l2: perm l1 l2 -> perm l2 l1.
Proof.
intros HH; elim HH; simpl; auto.
intros; apply perm_id; auto.
intros; apply perm_swap.
intros; apply perm_skip; auto.
intros l3 l4 l5 H1 H2 H3 H4;
  apply perm_trans with (1 := H4); auto.
Qed.

Lemma perm_cons_app a l1 l2: perm ((a:: l1) ++ l2) (l1 ++ (a:: l2)).
Proof.
generalize l2; clear l2; induction l1 as [| b l1 IH]; auto.
intros l2; apply perm_id.
intros l2; apply perm_trans with (1 := perm_swap a b (l1 ++ l2)).
simpl; apply perm_skip; auto.
apply (IH l2).
Qed.

Lemma perm_length l1 l2: perm l1 l2 -> length l1 = length l2.
Proof.
intros HH; elim HH; simpl; auto.
intros l3 l4 l5 H1 H2 H3 H4; rewrite H2; auto.
Qed.

Lemma perm_in a l1 l2: perm l1 l2 -> In a l1 -> In a l2.
Proof.
intros H; generalize a; elim H; clear a l1 l2 H; auto with datatypes.
simpl; intros a b l c [H1 | [H1 | H1]]; subst; auto.
simpl; intros a l1 l2 H IH c [H1 | H1]; subst; auto.
Qed.

Lemma perm_in_inv a l1: In a l1 -> exists l2, perm l1 (a:: l2).
Proof.
induction l1 as [| b l1 IH]; simpl; intros HH; case HH; auto.
intros HH1; subst; exists l1; apply perm_id.
intros HH1; case IH; auto.
intros l2 Hl2; exists (b::l2).
apply perm_trans with (b::a::l2).
apply perm_skip; auto.
apply perm_swap; auto.
Qed.

Lemma perm_incl_r l1 l2 l3: perm l1 l2 -> incl l1 l3 -> incl l2 l3.
Proof.
intros H; generalize l3; elim H; clear l3 l1 l2 H; auto with datatypes.
intros a b l1 l2 H x; simpl; intros [H1 | [H1 | H1]]; subst; apply H;
   auto with datatypes.
intros a l1 l2 Hp IH l3 Hi x; simpl; intros [H1 | H1]; subst.
apply Hi; auto with datatypes.
apply IH; auto with datatypes.
intros y Hy; apply Hi; auto with datatypes.
Qed.

Lemma perm_incl_l l1 l2 l3: perm l1 l2 -> incl l3 l1 -> incl l3 l2.
Proof.
intros H; generalize l3; elim H; clear l3 l1 l2 H; auto with datatypes.
intros a b l1 l2 H x Hx.
generalize (H _ Hx); simpl; intros [H1 | [H1 | H1]]; subst; auto.
intros a l1 l2 Hp IH l3 Hi x Hx.
generalize (Hi _ Hx); simpl; intros [H1 | H1]; subst; auto.
right; apply perm_in with (1 := Hp); auto.
Qed.

End Perm.

Arguments perm[A].

Section Uniq.

Variable A: Type.

Inductive uniq: list A -> Prop :=
  uniq_nil: uniq nil
| uniq_cons: forall a l, ~ In a l -> uniq l -> uniq (a::l).

Lemma uniq_perm l1 l2: perm l1 l2 -> uniq l1 -> uniq l2.
Proof.
intros H; elim H; auto.
intros a b l HH; inversion_clear HH as [| aa bb Hi HH1].
inversion_clear HH1 as [| aa bb Hi1 HH2].
repeat apply uniq_cons; auto with datatypes.
simpl; intros [H1 | H1]; subst; auto.
case Hi; auto with datatypes.
intros a l3 l4 H1 IH HH.
inversion_clear HH as [| aa bb Hi HH1].
apply uniq_cons; auto.
intros HH2; case Hi; apply perm_in with (1 := perm_sym _ _ _ H1); auto.
Qed.

Lemma uniq_cons_inv a l: uniq (a::l) -> uniq l.
Proof.
intros HH; inversion HH; auto.
Qed.

Lemma uniq_app_inv_l l1 l2: uniq (l1 ++ l2) -> uniq l1.
Proof.
generalize l1; induction l2 as [| a l2 IH]; clear l1; intros l1.
rewrite <-app_nil_end; auto.
intros HH; apply uniq_cons_inv with a.
apply IH.
apply uniq_perm with (2 := HH).
apply perm_sym; apply perm_cons_app.
Qed.

Lemma uniq_app_inv_r l1 l2: uniq (l1 ++ l2) -> uniq l2.
Proof.
generalize l2; clear l2; induction l1 as [| a l1 IH]; auto.
intros l2 Hl2.
apply uniq_cons_inv with a.
apply IH.
apply uniq_perm with (2 := Hl2).
apply perm_cons_app.
Qed.

Lemma perm_incl_inv l1 l2:
  uniq l1 -> uniq l2 -> incl l1 l2 -> exists l3, perm l2 (l1 ++ l3).
Proof.
generalize l2; clear l2; induction l1 as [| a l1 IH]; intros l2.
intros; exists l2; apply perm_id.
intros Hu1 Hu2 Hi.
assert (H1: In a l2).
apply Hi; auto with datatypes.
case perm_in_inv with (1 := H1).
intros l3 Hl3.
case (IH l3); auto.
apply uniq_cons_inv with a; auto.
apply uniq_cons_inv with a; auto.
apply uniq_perm with (1 := Hl3); auto.
intros x Hx.
assert (H2: In x (a::l3)).
apply perm_in with (1 := Hl3).
apply Hi; auto with datatypes.
simpl in H2; case H2; intros HH; subst; auto.
inversion_clear Hu1 as [| aa bb HH1 HH2].
case HH1; auto.
intros l4 Hl4.
exists l4.
apply perm_trans with (1 := Hl3).
simpl; apply perm_skip; auto.
Qed.

End Uniq.

Lemma list_split (A: Type) n1 n2 (l: list A):
 length l = n1 + n2 ->
   exists l1, exists l2, l = l1 ++ l2 /\ length l1 = n1 /\ length l2 = n2.
Proof.
generalize n2 l; clear n2 l; induction n1 as [| n1 IH].
intros n2 l Hl; exists nil; exists l; auto.
intros n2 [| a l] H; try discriminate.
case (IH n2 l); auto.
intros l1 (l2, (H1, (H2, H3))).
exists (a::l1); exists l2; repeat split; subst; simpl; auto.
Qed.

Lemma length_split (A B: Type) (a b: A) (lk: list B) l1 l2:
 length lk = length ((a:: l1) ++ b :: l2)%list ->
 exists k1, exists k2, exists lk1, exists lk2,
 lk = ((k1::lk1) ++ k2::lk2)%list /\ length lk1 = length l1 /\ length lk2 = length l2.
Proof.
destruct lk as [| a1 lk].
intros; discriminate.
simpl; intros HH; injection HH; clear HH; intros HH.
assert (H1:  exists k2, exists lk1, exists lk2,
 lk = (lk1 ++ k2::lk2)%list /\ length lk1 = length l1 /\ length lk2 = length l2).
generalize l1 HH; clear HH; induction lk as [| a2 lk IH]; clear l1;
  intros [| b1 l1]; try (intros; discriminate).
simpl; intros HH; injection HH; clear HH; intros HH.
exists a2; exists (@nil _); exists lk; repeat split; auto.
simpl; intros HH; injection HH; clear HH; intros HH.
case (IH _ HH); auto.
intros k1 (lk1, (lk2, (H1lk1, (H2lk1, H3lk1)))).
exists k1; exists (a2::lk1); exists lk2; simpl; repeat split; auto.
rewrite H1lk1; auto.
case H1; intros k2 (lk1, (lk2, (H1lk, (H2lk, H3lk)))).
exists a1; exists k2; exists lk1; exists lk2; repeat split; auto.
rewrite H1lk; auto.
Qed.

Lemma list_app_inj (A: Type) (l1 l2 l3 l4: list A):
 length l1 = length l3 -> l1 ++ l2 = l3 ++ l4 -> l1 = l3 /\ l2 = l4.
Proof.
generalize l2 l3 l4; clear l2 l3 l4; induction l1 as [| x1 l1 IH].
intros  l2 [| x3 l3] l4 H1 H2; try discriminate; auto.
intros l2 [| x3 l3] l4 H1 H2; try discriminate.
injection H2; intros; subst; auto.
case (IH l2 l3 l4); auto; intros; subst; auto.
Qed.

Lemma list_case (A:Type) (l: list A): l = nil \/ l <> nil.
destruct l as [|a l]; simpl; auto.
right; intros HH; discriminate.
Qed.

Lemma list_dec (A: Type) (P: A -> Prop) l:
 (forall x, P x \/ ~ P x) -> (forall x, In x l -> P x) \/ (exists x, In x l /\ ~ P x).
Proof.
intros Pdec.
induction l as [| a l IH].
left; intros x [].
case (Pdec a); intros H.
2: right; exists a; auto with datatypes.
case IH.
simpl; intros H1; left; intros x [Hx|Hx]; subst; auto.
intros (x,(H1x,H2x)); right; exists x; auto with datatypes.
Qed.

Arguments uniq[A].

(* Georges' trick for easy case analysis *)

Inductive eq_Spec (A: Type) (x y: A): bool -> Prop :=
 |eq_Spect:  x = y -> eq_Spec A x y true
 |eq_Specf: x <> y -> eq_Spec A x y false.

Arguments eq_Spec[A].

(** Binomial Coefficient defined using Pascal's triangle *)
Fixpoint bin (a b : nat) {struct a} : nat :=
 match a, b with
   _, O => 1
  | O, S b' => 0
  | S a', S b' => bin a' (S b') + bin a' b'
 end.

(** Basic properties of binomial coefficients *)
Lemma bin_0: forall (n : nat),  bin n 0 = 1.
intros n; induction n; auto.
Qed.

Lemma bin_1: forall (n : nat),  bin n 1 = n.
intros; induction n as [|n IH]; simpl; auto.
rewrite bin_0, IH, Plus.plus_comm; auto.
Qed.

Lemma bin_more: forall (n m : nat), n < m ->  bin n m = 0.
intros n; induction n as [| n IH]; simpl; auto.
intros m; case m; simpl; auto.
intros H'; inversion H'; auto.
intros m; case m; simpl; auto.
intros H'0; contradict H'0; auto with arith.
intros n1 H'0; rewrite !IH; auto with arith.
Qed.

Lemma bin_nn: forall (n : nat),  bin n n = 1.
intros n; induction n as [| n IH]; intros; simpl; auto.
rewrite (bin_more n (S n)); auto.
Qed.

Lemma bin_def:
 forall (n k : nat),  bin (S n) (S k) = bin n (S k) + bin n k.
simpl; auto.
Qed.

Fixpoint iter {A: Type} (f: A -> A) (n: nat) (x: A) :=
  match n with
  | O => x
  | S n1 => f (iter f n1 x)
  end.

(* A bit of ssreflect *)

Coercion b2Prop (x : bool) := x = true.

Lemma b2PropT: b2Prop true.
Proof. exact (refl_equal true). Qed.

Global Hint Resolve b2PropT : core.

Require Import Bool.

Lemma andbP b1 b2: b1 && b2 <-> b1 /\ b2.
Proof.
case b1; case b2; intuition.
Qed.

(* Some facts about div2 *)

Lemma div2_double_p n m : div2 (2 * n + m) = n + div2 m.
Proof.
induction n as [| n IH]; simpl; auto.
rewrite <-plus_n_Sm; simpl in IH |- *.
rewrite IH; auto.
Qed.

Lemma div2_prop n: n + div2 (n * (n - 1)) = div2 (n.+1 * n).
Proof.
assert (F1: forall n, (n + n * n = 2 * n + n * (n - 1))%nat).
intros [|n1]; simpl; auto.
rewrite <-!Minus.minus_n_O; ring.
induction n; simpl; auto.
rewrite <-plus_n_Sm.
rewrite <-Minus.minus_n_O.
rewrite F1, div2_double_p.
rewrite !Plus.plus_assoc; replace (n + n) with (2 * n); try ring.
rewrite div2_double_p, <-(Mult.mult_comm (n.+1)), <-IHn.
ring.
Qed.

Lemma minus_minus_le m n: n <= m -> m - (m - n) = n.
Proof.
assert (F1: (forall n m, n <= m -> exists k, m = k + n)%nat).
intros n1 m1 H; elim H; auto.
exists 0%nat; auto.
intros m2 _ (k, Hk); rewrite Hk; exists k.+1; auto.
intros H; case (F1 _ _ H).
intros k Hk; subst.
rewrite (Plus.plus_comm k), Minus.minus_plus.
rewrite (Plus.plus_comm n), Minus.minus_plus; auto.
Qed.

Lemma minus0_le m n: m <= n -> m - n = 0.
Proof.
generalize n; clear n; induction m as [| m IH]; auto.
intros [|n]; simpl; auto with arith.
Qed.

Fixpoint eq_nat (m n: nat) :=
  match m, n with (S m), (S n) => eq_nat m n | 0, 0 => true | _, _ => false end.

Notation "m ?= n" := (eq_nat m n) (at level 70): nat_scope.

Inductive eq_nat_spec: nat -> nat -> bool -> Type :=
  eq_nat_spect: forall m, eq_nat_spec m m true
| eq_nat_specb: forall m n, m <> n -> eq_nat_spec m n false.

Lemma eq_natP m n: eq_nat_spec m n (m ?= n).
Proof.
generalize n; clear n; induction m as [| m IH]; intros [| n]; simpl;
  try constructor; try (intros; discriminate).
(case (IH n); clear m n IH); [intros m | intros m n H];
  constructor; intros H1; case H; injection H1; auto.
Qed.

Notation "x .+2" := (S (S x))  (at level 9): nat_scope.


(* Coq演習 ex1 *)
Theorem Modus_ponens : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
  intros.
  apply H0.
  exact H.
Qed.

Theorem Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P.
Proof.
  unfold not.
  intros.
  inversion H.
  apply H1.
  apply H2.
  exact H0.
Qed.

Theorem Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q.
Proof.
  unfold not.
  intros.
  inversion H.
  contradiction.

  exact H1.
Qed.

Theorem DeMorgan1 : forall P Q : Prop, ~P \/ ~Q -> ~(P /\ Q).
Proof.
  unfold not.
  intros.
  inversion H0.
  inversion H.
  apply H3.
  exact H1.

  apply H3.
  apply H2.
Qed.

Theorem DeMorgan2 : forall P Q : Prop, ~P /\ ~Q -> ~(P \/ Q).
Proof.
  unfold not.
  intros.
  inversion H.
  inversion H0.
  apply H1.
  apply H3.

  apply H2.
  apply H3.
Qed.

Theorem DeMorgan3 : forall P Q : Prop, ~(P \/ Q) -> ~P /\ ~Q.
Proof.
  unfold not.
  intros.
  split.
  intros.
  apply H.
  left.
  exact H0.

  intros.
  apply H.
  right.
  exact H0.
Qed.

Theorem NotNot_LEM : forall P : Prop, ~ ~(P \/ ~P).
Proof.
  unfold not.
  intros.
  apply H.
  right.
  intros.
  apply H.
  left.
  exact H0.
Qed.


(** Semántica y Verificación
    Ejemplo 5
    Manuel Soto Romero
    Luis F. Benítez Lluis

    Contenido:
    1 Definiciones de listas polimórficas
    2 Pares Polimórficos
      2.1 La función split
    3 Opcioes polimórficos
      3.1 Función head para listas polimóficas
    4 La táctica discriminate
    5 Manejo de la hipótesis inductiva
    6 Desdoblando definiciones
    7 Resumen de téctias (extracto citado del libro)

    Para acceder rápidamente a la sección deseada
    buscar la cadena ">n" donde "n" es el número de
    sección.

    Material basado en los scripts
    correspondientes al libro Logical Foundations en
    Software Foundations- Benjamin C. Pierce, et al.
    *)

Require Import Coq.Arith.PeanoNat.
Require Import Bool.Bool.

(** >1 Definiciones de listas polimórficas*)

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).
Arguments nil {X}.
Arguments cons {X} _ _.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.
Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** >2 Pares Polimórficos *)

(* Generalizemos la noción de par *)

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

(* Definimos lor argumentos implicitos *)
Arguments pair {X} {Y} _ _.

(* Definomos la notación usual de par *)

Notation "( x , y )" := (pair x y).

(* Podemos usar también notación para el producto de tipos*)

Notation "X * Y" := (prod X Y) : type_scope.

(* La anotación [: type_scope] le dice a Coq que la anotación de
    tipos sólo aplica en el parsing de tipos, más no para expresiones.
    Gracias a esta restricción evitamos conflicto con la notación
    de multiplicación. *)

(* Es importante hacer hincapié en que (x,y) representa la notación
  de expresiones que representan parejas ordenadas y que
  X*Y representan el producto de tipos. Si x:X y y:Y entonces
  (x,y):X*Y*)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(*Función que combina dos listas en parejas de entradas
  de cada lista respectivamente *)
(* [1,2,3], [4,5,6]=> [(1,4),(2,5),(3,6)]*)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y):=
  match lx,ly with
    | [], _ => []
    | _, [] => []
    | x::tx, y ::ty => (x,y):: (combine tx ty)
    end.

Example test_combine: combine [1;2;3] [4;5;6]=[(1,4);(2,5);(3,6)].
Proof.
simpl.
reflexivity.
Qed.

(** >2.1 La función split*)
(*  La función [split] es la inversa derecha de [combine], desdoblando
    listas de parejas en una pareja de listas con los elementos
    respectivos.*)
(*    [(1,4);(2,5);(3,6)]

   (1,4)
   ([2;3],[5;6]) *)
Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y):=
match l with
  | [] => ([],[])
  | h::t => ((fst h)::fst (split t), (snd h)::snd(split t))
end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
reflexivity.
Qed.

(** >3 Opcioes polimórficos *)

(* Hagamos la definición en un módulo pues coq ya posee
    el tipo opción que buscamos*)
Module OptionPlayground.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

(* Recordemos que nth-error es una función que devuelve el
    n-ésimo elemento de una lista. Dado que se puede elegir
    n ue supere la longitud de la lista, es conveniente que
    devolvamos un tipo opción para ajustar para este error.  *)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | nil => None
  | a :: l' => match n with
               | O => Some a
               | S n' => nth_error l' n'
               end
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** >3.1 Función head para listas polimóficas *)

Definition hd_error {X : Type} (l : list X) : option X:=
  match l with
    | [] => None
    | h::t=> Some h
  end.

Check @hd_error : forall X : Type, list X -> option X.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof.
reflexivity.
Qed.

Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof.
reflexivity.
Qed.

(** >4 La táctica discriminate*)

(*  La táctica [discriminate] sirve para detectar hipótesis inválidas
    sobre igualdadades. Para que la táctica funcione, es inminente
    que los términos sean sintácticamente distintos. Por ejemplo
    cuando se tiene iguadad entre un sucesor y cero [S n = O]. *)

Theorem eqb_0_l : forall n,
   0 =? n = true -> n = 0.
Proof.
  intros.
  destruct n.
  -  simpl in H. reflexivity.
  - simpl in H.
    discriminate H.
Qed.

(*  El razonamiento lógico a esta solución sigue el principio de
    explosión que afirma que de cosas falsas se sigue
    lo que sea. En este caso la falsedad se encarna como
    igualdades insatisfacibles. *)

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

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

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

Example inversion_ex :
  forall (n:nat), S n <=0-> 2+2=5.
Proof.
  intros.
  inversion H.
Qed.

(** >5 Manejo de la hipótesis inductiva *)
Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

Theorem double_injective_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n' IHn'].
  - (* n = O *) simpl. intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) intros eq. destruct m as [| m'] eqn:E.
    + (* m = O *) discriminate eq.
    + (* m = S m' *) apply f_equal.

Abort.

Theorem double_injective : forall  n m,
     double n = double m ->
     n = m.
Proof.
intro.

induction n.
- intros. destruct m.
  -- reflexivity.
  -- discriminate H.
- intros. destruct m.
  -- discriminate H.
  -- apply f_equal.
      apply IHn.
      inversion H.
      reflexivity.
Qed.

(* intros  n. induction n as [| n' IHn'].
  - (* n = O *) simpl. intros m eq. destruct m as [| m'] eqn:E.
    + (* m = O *) reflexivity.
    + (* m = S m' *) discriminate eq.
  - (* n = S n' *) simpl.
    intros m eq.
    destruct m as [| m'] eqn:E.
    + (* m = O *)
    discriminate eq.
    + (* m = S m' *)
      apply f_equal.
      apply IHn'. simpl in eq. injection eq as goal. apply goal.
Qed.
 *)

(* intro.
induction n.
- intros. destruct m.
-- reflexivity.
-- simpl in H. discriminate H.
- intros. simpl in H.
destruct m.
-- simpl in H. discriminate H.
-- simpl in H. apply f_equal.
  apply IHn.
  injection H.
  intro.
  assumption.

  (*  inversion H.
   reflexivity. *)
Qed. *)

Theorem eqb_true : forall n m,
    n =? m = true -> n = m.
Proof.
intro.
induction n.
- destruct m.
-- intros. reflexivity.
--  intros. discriminate H.
- destruct m.
-- intros. discriminate H.
-- intros. apply f_equal.
  apply IHn.
  simpl in H.
  assumption.
  Qed.

(* Hint: usar [plus_n_Sm] *)
Check plus_n_Sm.
Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
intro.
induction n.
- intros. simpl in H. destruct m.
-- reflexivity.
-- simpl in H.
discriminate H.
- intros.
destruct m.
-- discriminate H.
-- apply f_equal.
   apply IHn.
   simpl in H.
   inversion H.
   rewrite <-plus_n_Sm in H1.
   rewrite <-plus_n_Sm in H1.
   inversion H1.
   reflexivity.
Qed.

(* A veces hay que reorganizar las variables para que al generalizar
las pruebas salgas adecuadamente*)

Theorem double_injective_take2_FAILED : forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction m as [| m' IHm'].
  - (* m = O *) simpl. intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.

Abort.

Theorem double_injective_take2 : forall m n,
     double n = double m ->
     n = m.
Proof.
intros.
generalize dependent m.
induction n.
- intros. destruct m.
  -- reflexivity.
  -- discriminate H.
- intros. destruct m.
  -- discriminate H.
  -- apply f_equal.
      apply IHn.
      inversion H.
      reflexivity.
Qed.

(*   intros n m.
  generalize dependent n.
  induction m as [| m' IHm'].
  - (* m = O *) simpl. intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) reflexivity.
    + (* n = S n' *) discriminate eq.
  - (* m = S m' *) intros n eq. destruct n as [| n'] eqn:E.
    + (* n = O *) discriminate eq.
    + (* n = S n' *) apply f_equal.
      apply IHm'. injection eq as goal. apply goal. Qed. *)

(* Probemos por inducción sobre l*)

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
Admitted.

(** >6 Desdoblando definiciones *)
Require Import Coq.Arith.PeanoNat.

Definition square n := n * n.

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Proof.
intros.
unfold square.
rewrite Nat.mul_assoc.
assert (H : n * m * n = n * n * m).
    { rewrite Nat.mul_comm. apply Nat.mul_assoc. }
  rewrite H. rewrite Nat.mul_assoc. reflexivity.
Qed.

(*  Algunas tácticas como [apply][simpl] y [reflexivity]
    simplifican términos cuando se usan, y particularmente
    desdoblan definiciones de algunas funciones.
    Por lo que en algunos casos no hace falta desdoblar
    las deficniciones pues se hace automáticamente *)

Definition foo (x: nat) := 5.

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

(*  No obstante, este desdoblamiento no siempre se ejecuta
    sobretodo si la expresión es algo compleja. *)

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2_FAILED : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  simpl.
Abort.
(* [simpl] no siempre logra progreso pues la cláusula match
   impide que se simplifique a su última expresión, ya que
   la entrada no se puede catalogar en la búsqueda de patrones.
   Es hasta que se desestructura la entrad que se puede resolver
   el match y simplificar la expresión*)

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m.
  destruct m eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(* Esto funciona pero si alguna parte de la expresión no se puede
  detectar para caza de patrones puede que requiramos más
  desestructuración. Otra forma es literalmente desdoblando la
  definición.*)

Fact silly_fact_2' : forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
Admitted.

(*   intros m.
  unfold bar.
  destruct m eqn:E.
  - reflexivity.
  - reflexivity.
Qed. *)

(** >7 Resumen de téctias (extracto citado del libro) *)
(*

      - [intros]: move hypotheses/variables from goal to context

      - [reflexivity]: finish the proof (when the goal looks like [e =
        e])

      - [apply]: prove goal using a hypothesis, lemma, or constructor

      - [apply... in H]: apply a hypothesis, lemma, or constructor to
        a hypothesis in the context (forward reasoning)

      - [apply... with...]: explicitly specify values for variables
        that cannot be determined by pattern matching

      - [simpl]: simplify computations in the goal

      - [simpl in H]: ... or a hypothesis

      - [rewrite]: use an equality hypothesis (or lemma) to rewrite
        the goal

      - [rewrite ... in H]: ... or a hypothesis

      - [symmetry]: changes a goal of the form [t=u] into [u=t]

      - [symmetry in H]: changes a hypothesis of the form [t=u] into
        [u=t]

      - [transitivity y]: prove a goal [x=z] by proving two new subgoals,
        [x=y] and [y=z]

      - [unfold]: replace a defined constant by its right-hand side in
        the goal

      - [unfold... in H]: ... or a hypothesis

      - [destruct... as...]: case analysis on values of inductively
        defined types

      - [destruct... eqn:...]: specify the name of an equation to be
        added to the context, recording the result of the case
        analysis

      - [induction... as...]: induction on values of inductively
        defined types

      - [injection]: reason by injectivity on equalities
        between values of inductively defined types

      - [discriminate]: reason by disjointness of constructors on
        equalities between values of inductively defined types

      - [assert (H: e)] (or [assert (e) as H]): introduce a "local
        lemma" [e] and call it [H]

      - [generalize dependent x]: move the variable [x] (and anything
        else that depends on it) from the context back to an explicit
        hypothesis in the goal formula

      - [f_equal]: change a goal of the form [f x = f y] into [x = y] *)


(* ListCalculus.v *)
(* author: Peter Urbak *)
(* version: 2014-06-02 *)

(** * List calculus

  This module defines a small calculus over the [list nat] type with the
  following selectors:

  - [hd]
  - [tl]
  - [nth]
  - [last]
  - [removelast]
  - [app]
  - [length]
  - [rev]

  constructors:

  - [make_list]
  - [list_constant]
  - [list_successor]

  and operators:

  - [list_map]
  - [list_scalar_mult]
  - [list_exponentiation]
  - [list_zip]
  - [list_sum]
  - [list_product]
  - [list_partial_sums_acc]
  - [list_partial_sums]
*)

(** * Preliminaries *)

(** ** Requirements *)

(* Standard library *)
Require Import Arith.
Require Export List.
Export ListNotations. (* enable [ ] and [ a ; b ; c] notation *)

(* Own modules *)
Require Import Cases.
Require Export Power.

(** * List basics *)

(** ** List type *)

(** ** List

  *** Definition *)

(*
(* {LIST} *)
Inductive list (A : Type) : Type :=
 | nil : list A
 | cons : A -> list A -> list A.
(* {END} *)

(* {NOTATION} *)
Notation " [ ] " := nil : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
Infix "::" := cons (at level 60, right associativity) : list_scope.
(* {END} *)
*)

(** ** List selectors *)

(** ** Hd

  *** Definition *)

(*
(* {HD} *)
Definition hd {A : Type} (d : A) (xs : list A) :=
  match xs with
    | [] => d
    | x :: _ => x
  end.
(* {END} *)
*)

(** *** Unfolding lemmas *)

Lemma unfold_list_head :
  forall (d : nat) (xs : list nat),
    hd d xs = match xs with
               | [] => d
               | x :: _ => x
              end.
Proof.
  intros d xs.
  unfold hd.
  reflexivity.
Qed.
Hint Rewrite unfold_list_head : listcalc.

(** ** Tl

  *** Definition *)

(*
(* {TL} *)
Definition tl {A : Type} (xs : list A) :=
  match xs with
    | [] => []
    | _ :: xs' => xs'
  end.
(* {END} *)
*)

(** *** Unfolding lemmas *)

Lemma unfold_list_tail :
  forall (xs : list nat),
    tl xs = match xs with
              | [] => []
              | _ :: xs' => xs'
            end.
Proof.
  intro xs.
  unfold tl.
  reflexivity.
Qed.
Hint Rewrite unfold_list_tail : listcalc.

(** ** Nth

 *** Definition *)

(*
(* {NTH} *)
Fixpoint nth {A : Type} (n : nat) (xs: list A) (d : A) : A :=
  match n, xs with
    | O, x :: xs' => x
    | O, [] => d
    | S n', [] => d
    | S n', x :: xs => nth n' xs' d
  end.
(* {END} *)
*)

(** *** Unfolding lemmas *)

Lemma unfold_nth_base_case_nil :
  forall (A : Type) (d : A),
    nth 0 [] d = d.
Proof.
  intros A d.
  unfold nth.
  reflexivity.
Qed.
Hint Rewrite unfold_nth_base_case_nil : listcalc.

Lemma unfold_nth_base_case_cons :
  forall (A : Type) (d x : A) (xs' : list A),
    nth 0 (x :: xs') d = x.
Proof.
  intros A d x xs'.
  unfold nth.
  reflexivity.
Qed.
Hint Rewrite unfold_nth_base_case_cons : listcalc.

Lemma unfold_nth_induction_case_nil :
  forall (A : Type) (n' : nat) (d : A),
    nth (S n') [] d = d.
Proof.
  intros A n' d.
  unfold nth.
  reflexivity.
Qed.
Hint Rewrite unfold_nth_induction_case_nil : listcalc.

Lemma unfold_nth_induction_case_cons :
  forall (A : Type) (n' : nat) (d x : A) (xs' : list A),
    nth (S n') (x :: xs') d = nth n' xs' d.
Proof.
  intros A n' d x xs'.
  unfold nth.
  reflexivity.
Qed.
Hint Rewrite unfold_nth_induction_case_cons : listcalc.

(** *** Properties *)

Lemma nth_n_nil :
  forall (A : Type) (n : nat) (d : A),
    nth n [] d = d.
Proof.
  intros A n d.
  case n as [ | n' ].

  Case "n = 0".
  rewrite -> unfold_nth_base_case_nil.
  reflexivity.

  Case "n = S n'".
  rewrite -> unfold_nth_induction_case_nil.
  reflexivity.
Qed.
Hint Rewrite nth_n_nil : listcalc.

(** ** Last

  *** Definition *)

(*
(* {LAST} *)
Fixpoint last {A : Type} (xs: list A) (d : A) : A :=
  match xs with
    | [] => d
    | [x] => x
    | x :: xs => last xs d
  end.
(* {END} *)
*)

(** *** Unfolding lemmas *)

Lemma unfold_last_base_case_nil :
  forall (A : Type) (d : A),
    last [] d = d.
Proof.
  intros A d.
  unfold last.
  reflexivity.
Qed.
Hint Rewrite unfold_last_base_case_nil : listcalc.

Lemma unfold_last_base_case_cons :
  forall (A : Type) (x d : A),
    last [x] d = x.
Proof.
  intros A x d.
  unfold last.
  reflexivity.
Qed.
Hint Rewrite unfold_last_base_case_cons : listcalc.

Lemma unfold_last_induction_case :
  forall (A : Type) (x x' d : A) (xs'' : list A),
    last (x :: x' :: xs'') d = last (x' :: xs'') d.
Proof.
  intros A x x' d xs''.
  unfold last; fold last.
  reflexivity.
Qed.
Hint Rewrite unfold_last_induction_case : listcalc.

(** *** Properties *)

Lemma last_cons :
  forall (x d : nat) (xs' : list nat),
    length xs' > 0 ->
    last (x :: xs') d = last xs' d.
Proof.
  intros x d.
  case xs' as [ | x' xs'' ].

  Case "xs' = []".
  intro H_absurd; inversion H_absurd.

  Case "xs' = x' :: xs''".
  intros _.
  rewrite -> unfold_last_induction_case.
  reflexivity.
Qed.
Hint Resolve last_cons : listcalc.

(** ** Remove last

  *** Definition *)

(*
(* {REMOVELAST} *)
Fixpoint removelast {A : Type} (xs : list A) : list A :=
  match xs with
    | [] => []
    | [x] => []
    | x :: xs => x :: removelast xs
  end.
(* {END} *)
*)

(** *** Unfolding lemmas *)

Lemma unfold_removelast_base_case_nil :
  forall (A : Type),
    removelast ([] : list A) = ([] : list A).
Proof.
  intro A.
  unfold removelast.
  reflexivity.
Qed.
Hint Rewrite unfold_removelast_base_case_nil : listcalc.

Lemma unfold_removelast_base_case_cons :
  forall (A : Type) (x : A),
    removelast [x] = [].
Proof.
  intros A x.
  unfold removelast.
  reflexivity.
Qed.
Hint Rewrite unfold_removelast_base_case_cons : listcalc.

Lemma unfold_removelast_induction_case :
  forall (A : Type) (x x' : A) (xs'' : list A),
    removelast (x :: x' :: xs'') = x :: removelast (x' :: xs'').
Proof.
  intros A x x' xs''.
  unfold removelast.
  reflexivity.
Qed.
Hint Rewrite unfold_removelast_induction_case : listcalc.

(** ** App

  *** Definition *)

(*
(* {APP} *)
Fixpoint app {A : Type} (xs ys : list A) : list A :=
  match xs with
    | [] => ys
    | x :: xs' => x :: app xs' ys
  end.
Infix "++" := app (right associativity, at level 60) : list_scope.
(* {END} *)
*)

(** ** Length

  *** Definition *)

(*
(* {LENGTH} *)
Fixpoint length {A : Type} (xs : list A) : nat :=
  match xs with
   | [] => O
   | _ :: xs' => S (length xs')
  end.
(* {END} *)
*)

(** *** Unfolding lemmas *)

Lemma unfold_length_base_case :
  length ([] : list nat) = 0.
Proof.
  unfold length.
  reflexivity.
Qed.
Hint Rewrite unfold_length_base_case : listcalc.

Lemma unfold_length_induction_case :
  forall (x : nat) (xs' : list nat),
    length (x :: xs') = S (length xs').
Proof.
  intros x xs'.
  unfold length.
  reflexivity.
Qed.
Hint Rewrite unfold_length_induction_case : listcalc.

(** *** Properties *)

Lemma length_nil_0 :
  forall (xs : list nat),
    length xs = 0 ->
    xs = [].
Proof.
  case xs as [ | x xs' ].

  Case "xs = []".
  intro H_length_nil_eq_0.
  reflexivity.

  Case "xs = x :: xs'".
  intro H_absurd; inversion H_absurd.
Qed.
Hint Rewrite length_nil_0 : listcalc.

Lemma length_implies_last_index :
  forall (n d : nat) (xs : list nat),
    length xs = (S n) ->
    last xs d = nth n xs d.
Proof.
  induction n as [ | n' IH_n' ].

  Case "n = 0".
  intro d.
  case xs as [ | x xs' ].

  SCase "xs = []".
  intro H_absurd; inversion H_absurd.

  SCase "xs = x :: xs'".
  intro H_length_x_xs'_eq_1.
  rewrite -> unfold_nth_base_case_cons.
  inversion H_length_x_xs'_eq_1;
    rename H0 into H_length_xs'_eq_0.
  rewrite -> (length_nil_0 xs' H_length_xs'_eq_0).
  rewrite -> unfold_last_base_case_cons.
  reflexivity.

  Case "n = S n'".
  intro d.
  case xs as [ | x xs' ].

  SCase "xs = []".
  intro H_absurd; inversion H_absurd.

  SCase "xs = x :: xs'".
  intro H_length_x_xs'_eq_S_S_n'.
  rewrite -> unfold_nth_induction_case_cons.
  inversion H_length_x_xs'_eq_S_S_n';
   rename H0 into H_length_xs'_eq_S_n'.
  rewrite <- (IH_n' d xs' H_length_xs'_eq_S_n').
  rewrite -> last_cons;
    [ reflexivity | rewrite -> H_length_xs'_eq_S_n'; apply gt_Sn_O ].
Qed.
Hint Resolve length_implies_last_index : listcalc.

(** ** Rev

  ** Definition *)

(*
(* {REV} *)
Fixpoint rev {A : Type} (xs : list A) : list A :=
  match xs with
    | [] => []
    | x :: xs' => rev xs' ++ [x]
  end.
(* {END} *)
*)

(** *** Unfolding lemmas *)

Lemma unfold_rev_base_case :
  forall (A : Type),
    rev ([] : list A) = [].
Proof.
  intro A.
  unfold rev.
  reflexivity.
Qed.
Hint Rewrite unfold_rev_base_case : listcalc.

Lemma unfold_rev_induction_case :
  forall (A : Type) (x : A) (xs' : list A),
    rev (x :: xs') = rev xs' ++ [x].
Proof.
  intros A x xs'.
  unfold rev; fold rev.
  reflexivity.
Qed.
Hint Rewrite unfold_rev_induction_case : listcalc.

(** *** Properties *)

(* {NTH_REV_EQ_LAST} *)
Lemma nth_rev_eq_last :
  forall (xs : list nat) (d : nat),
    nth 0 (rev xs) d =
    last xs d.
(* {END} *)
Proof.
  induction xs as [ | x xs' IH_xs' ].

  Case "xs = []".
  intro d.
  rewrite -> unfold_last_base_case_nil.
  rewrite -> unfold_rev_base_case.
  rewrite -> unfold_nth_base_case_nil.
  reflexivity.

  Case "xs = x :: xs'".
  intro d.
  case xs' as [ | x' xs'' ].

  SCase "xs' = []".
  rewrite -> unfold_last_base_case_cons.
  rewrite -> unfold_rev_induction_case.
  rewrite -> unfold_rev_base_case.
  rewrite -> app_nil_l.
  rewrite -> unfold_nth_base_case_cons.
  reflexivity.

  SCase "xs' = x' :: xs''".
  rewrite -> unfold_rev_induction_case.
  rewrite -> unfold_last_induction_case.
  rewrite <- (IH_xs' d).
  rewrite -> unfold_rev_induction_case.
  rewrite -> app_nth1;
    [ idtac |
      rewrite -> app_length;
        rewrite -> unfold_length_induction_case;
        rewrite -> unfold_length_base_case;
        rewrite -> plus_comm;
        apply lt_0_Sn ].
  reflexivity.
Qed.
Hint Rewrite nth_rev_eq_last : listcalc.

(** ** List constructors *)

(** ** Make list

  *** Definition *)

(* {MAKE_LIST} *)
Fixpoint make_list (n i : nat) (f : nat -> nat) : list nat :=
  match n with
    | 0 => []
    | S n' => i :: (make_list n' (f i) f)
  end.
(* {END} *)
Hint Unfold make_list : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_make_list_base_case :
  forall (i : nat) (f : nat -> nat),
    make_list 0 i f = [].
Proof.
  intros i f.
  unfold make_list.
  reflexivity.
Qed.
Hint Rewrite unfold_make_list_base_case : listcalc.

Lemma unfold_make_list_induction_case :
  forall (n' i : nat) (f : nat -> nat),
    make_list (S n') i f = i :: (make_list n' (f i) f).
Proof.
  intros n' i f.
  unfold make_list; fold make_list.
  reflexivity.
Qed.
Hint Rewrite unfold_make_list_induction_case : listcalc.

(** *** List constant

  *** Definition *)

(* {LIST_CONSTANT} *)
Definition list_constant (n c : nat) : list nat :=
  make_list n c (fun x : nat => x).
(* {END} *)
Hint Unfold list_constant : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_constant_base_case :
  forall (c : nat),
    list_constant 0 c = [].
Proof.
  intro c.
  unfold list_constant.
  rewrite -> unfold_make_list_base_case.
  reflexivity.
Qed.
Hint Rewrite unfold_list_constant_base_case : listcalc.

Lemma unfold_list_constant_induction_case :
  forall (c n' : nat),
    list_constant (S n') c = c :: (list_constant n' c).
Proof.
  intros c n'.
  unfold list_constant.
  rewrite -> unfold_make_list_induction_case.
  reflexivity.
Qed.
Hint Rewrite unfold_list_constant_induction_case : listcalc.

(** List successor *)

(* {LIST_SUCCESSOR} *)
Definition list_successor (n i : nat) : list nat :=
  make_list n i S.
(* {END} *)
Hint Unfold list_successor : listcalc.

Lemma unfold_list_successor_base_case :
  forall (i : nat),
    list_successor 0 i = [].
Proof.
  intro i.
  unfold list_successor.
  rewrite -> unfold_make_list_base_case.
  reflexivity.
Qed.
Hint Rewrite unfold_list_successor_base_case : listcalc.

Lemma unfold_list_successor_induction_case :
  forall (n' i : nat),
    list_successor (S n') i = i :: (list_successor n' (S i)).
Proof.
  intros n' i.
  unfold list_successor.
  rewrite -> unfold_make_list_induction_case.
  reflexivity.
Qed.
Hint Rewrite unfold_list_successor_induction_case : listcalc.

(** * List operators *)

(** ** List map

  *** Definition *)

(* {LIST_MAP} *)
Fixpoint list_map (f : nat -> nat) (xs : list nat) : list nat :=
  match xs with
    | [] => xs
    | x :: xs' => (f x) :: (list_map f xs')
  end.
(* {END} *)
Hint Unfold list_map : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_map_base_case :
  forall (f : nat -> nat),
    list_map f [] = [].
Proof.
  intro f.
  unfold list_map.
  reflexivity.
Qed.
Hint Rewrite unfold_list_map_base_case : listcalc.

Lemma unfold_list_map_induction_case :
  forall (x : nat) (xs' : list nat) (f : nat -> nat),
    list_map f (x :: xs') = (f x) :: (list_map f xs').
Proof.
  intros x xs' f.
  unfold list_map; fold list_map.
  reflexivity.
Qed.
Hint Rewrite unfold_list_map_induction_case : listcalc.

(** ** List scalar multiplication

  *** Definition *)

(* {LIST_SCALAR_MULTIPLICATION} *)
Definition list_scalar_multiplication (k : nat)
           (xs : list nat) : list nat :=
  list_map (mult k) xs.
Notation "k ls* xs" := (list_scalar_multiplication k xs)
                         (at level 40, left associativity).
(* {END} *)
Hint Unfold list_scalar_multiplication : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_scalar_multiplication :
  forall (k : nat) (xs : list nat),
    list_scalar_multiplication k xs = list_map (mult k) xs.
Proof.
  intros k xs.
  unfold list_scalar_multiplication.
  reflexivity.
Qed.
Hint Rewrite unfold_list_scalar_multiplication : listcalc.

Lemma unfold_list_scalar_multiplication_base_case :
  forall (k : nat),
    k ls* [] = [].
Proof.
  intro k.
  unfold list_scalar_multiplication.
  exact (unfold_list_map_base_case (mult k)).
Qed.
Hint Rewrite unfold_list_scalar_multiplication_base_case : listcalc.

Lemma unfold_list_scalar_multiplication_induction_case :
  forall (k x : nat) (xs' : list nat),
    k ls* (x :: xs') = (k * x) :: (k ls* xs').
Proof.
  intros k x xs'.
  unfold list_scalar_multiplication.
  exact (unfold_list_map_induction_case x xs' (mult k)).
Qed.
Hint Rewrite unfold_list_scalar_multiplication_induction_case : listcalc.

(** ** List exponentiation

  *** Definition *)

(* {LIST_EXPONENTIATION} *)
Definition list_exponentiation (n : nat) (xs : list nat) : list nat :=
  list_map (power n) xs.
Notation "xs l^ n" := (list_exponentiation n xs)
                        (at level 31, left associativity).
(* {END} *)
Hint Unfold list_exponentiation : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_exponentiation :
  forall (n : nat) (xs : list nat),
    list_exponentiation n xs = list_map (power n) xs.
Proof.
  intros n xs.
  unfold list_exponentiation.
  reflexivity.
Qed.
Hint Rewrite unfold_list_exponentiation : listcalc.

Lemma unfold_list_exponentiation_base_case :
  forall (n : nat),
    [] l^ n = [].
Proof.
  intro n.
  unfold list_exponentiation.
  rewrite -> unfold_list_map_base_case.
  reflexivity.
Qed.
Hint Rewrite unfold_list_exponentiation_base_case : listcalc.

Lemma unfold_list_exponentiation_induction_case :
  forall (n x : nat) (xs' : list nat),
    (x :: xs') l^ n = (x ^ n) :: (xs' l^ n).
Proof.
  intros n x xs'.
  unfold list_exponentiation.
  rewrite -> unfold_list_map_induction_case.
  reflexivity.
Qed.
Hint Rewrite unfold_list_exponentiation_induction_case : listcalc.

(** ** List zip

  *** Definition *)

(* {LIST_ZIP} *)
Fixpoint list_zip (f : nat -> nat -> nat)
         (xs ys : list nat) : list nat :=
  match xs, ys with
    | xs, [] => xs
    | [], ys => ys
    | x :: xs', y :: ys' => (f x y) :: (list_zip f xs' ys')
  end.
(* {END} *)
Hint Unfold list_zip : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_zip_base_case_nil :
  forall (f : nat -> nat -> nat),
    list_zip f [] [] = [].
Proof.
  intro f.
  unfold list_zip.
  reflexivity.
Qed.
Hint Rewrite unfold_list_zip_base_case_nil : listcalc.

Lemma unfold_list_zip_base_case_cons :
  forall (y : nat) (ys' : list nat) (f : nat -> nat -> nat),
    list_zip f [] (y :: ys') = (y :: ys').
Proof.
  intros y ys' f.
  unfold list_zip.
  reflexivity.
Qed.
Hint Rewrite unfold_list_zip_base_case_cons : listcalc.

Lemma unfold_list_zip_induction_case_nil :
  forall (x : nat) (xs' : list nat) (f : nat -> nat -> nat),
    list_zip f (x :: xs') [] = (x :: xs').
Proof.
  intros x xs' f.
  unfold list_zip.
  reflexivity.
Qed.
Hint Rewrite unfold_list_zip_induction_case_nil : listcalc.

Lemma unfold_list_zip_induction_case_cons :
  forall (x y : nat) (xs' ys' : list nat) (f : nat -> nat -> nat),
    list_zip f (x :: xs') (y :: ys') = (f x y) :: (list_zip f xs' ys').
Proof.
  intros x y xs' ys' f.
  unfold list_zip; fold list_zip.
  reflexivity.
Qed.
Hint Rewrite unfold_list_zip_induction_case_cons : listcalc.

(** ** List sum

  *** Definition *)

(* {LIST_SUM} *)
Definition list_sum (xs ys : list nat) : list nat :=
  list_zip plus xs ys.
Infix "l+" := list_sum (at level 50, left associativity).
(* {END} *)
Hint Unfold list_sum : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_sum :
  forall (xs ys : list nat),
    xs l+ ys = list_zip plus xs ys.
Proof.
  intros xs ys.
  unfold list_sum.
  reflexivity.
Qed.
Hint Rewrite unfold_list_sum : listcalc.

Lemma unfold_list_sum_base_case_nil :
  [] l+ [] = [].
Proof.
  unfold list_sum.
  exact (unfold_list_zip_base_case_nil plus).
Qed.
Hint Rewrite unfold_list_sum_base_case_nil : listcalc.

Lemma unfold_list_sum_base_case_cons :
  forall (y : nat) (ys' : list nat),
    [] l+ (y :: ys') = (y :: ys').
Proof.
  intros y ys'.
  unfold list_sum.
  exact (unfold_list_zip_base_case_cons y ys' plus).
Qed.
Hint Rewrite unfold_list_sum_base_case_cons : listcalc.

Lemma unfold_list_sum_induction_case_nil :
  forall (x : nat) (xs' : list nat),
    (x :: xs') l+ [] = (x :: xs').
Proof.
  intros x xs'.
  unfold list_sum.
  exact (unfold_list_zip_induction_case_nil x xs' plus).
Qed.
Hint Rewrite unfold_list_sum_induction_case_nil : listcalc.

Lemma unfold_list_sum_induction_case_cons :
  forall (x y : nat) (xs' ys' : list nat),
    (x :: xs') l+ (y :: ys') = (x + y) :: (xs' l+ ys').
Proof.
  intros x y xs' ys'.
  unfold list_sum.
  exact (unfold_list_zip_induction_case_cons x y xs' ys' plus).
Qed.
Hint Rewrite unfold_list_sum_induction_case_cons : listcalc.

(** ** List product

  *** Definition *)

(* {LIST_PRODUCT} *)
Definition list_product (xs ys : list nat) : list nat :=
  list_zip mult xs ys.
Infix "l*" := list_product (at level 40, left associativity).
(* {END} *)
Hint Unfold list_product : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_product :
  forall (xs ys : list nat),
    xs l* ys = list_zip mult xs ys.
Proof.
  intros xs ys.
  unfold list_product.
  reflexivity.
Qed.
Hint Rewrite unfold_list_product : listcalc.

Lemma unfold_list_product_base_case_nil :
  [] l* [] = [].
Proof.
  unfold list_product.
  exact (unfold_list_zip_base_case_nil mult).
Qed.
Hint Rewrite unfold_list_product_base_case_nil : listcalc.

Lemma unfold_list_product_base_case_cons :
  forall (y : nat) (ys' : list nat),
    [] l* (y :: ys') = (y :: ys').
Proof.
  intros y ys'.
  unfold list_product.
  exact (unfold_list_zip_base_case_cons y ys' mult).
Qed.
Hint Rewrite unfold_list_product_base_case_cons : listcalc.

Lemma unfold_list_product_induction_case_nil :
  forall (x : nat) (xs' : list nat),
    (x :: xs') l* [] = (x :: xs').
Proof.
  intros x xs'.
  unfold list_product.
  exact (unfold_list_zip_induction_case_nil x xs' mult).
Qed.
Hint Rewrite unfold_list_product_induction_case_nil : listcalc.

Lemma unfold_list_product_induction_case_cons :
  forall (x y : nat) (xs' ys' : list nat),
    (x :: xs') l* (y :: ys') = (x * y) :: (xs' l* ys').
Proof.
  intros x y xs' ys'.
  unfold list_product.
  exact (unfold_list_zip_induction_case_cons x y xs' ys' mult).
Qed.
Hint Rewrite unfold_list_product_induction_case_cons : listcalc.

(** ** List partial sums acc

  *** Definition *)

(* {LIST_PARTIAL_SUMS_ACC} *)
Fixpoint list_partial_sums_acc (a : nat) (xs : list nat) : list nat :=
  match xs with
    | [] => []
    | x :: xs' => (x + a) :: (list_partial_sums_acc (x + a) xs')
  end.
(* {END} *)
Hint Unfold list_partial_sums_acc : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_partial_sums_acc_base_case :
  forall (a : nat),
    list_partial_sums_acc a [] = [].
Proof.
  intro a.
  unfold list_partial_sums_acc.
  reflexivity.
Qed.
Hint Rewrite unfold_list_partial_sums_acc_base_case : listcalc.

Lemma unfold_list_partial_sums_acc_induction_case :
  forall (a x : nat) (xs' : list nat),
    list_partial_sums_acc a (x :: xs') =
    (x + a) :: (list_partial_sums_acc (x + a) xs').
Proof.
  intros a x xs'.
  unfold list_partial_sums_acc; fold list_partial_sums_acc.
  reflexivity.
Qed.
Hint Rewrite unfold_list_partial_sums_acc_induction_case : listcalc.

(** *** Properties *)

Lemma nth_list_partial_sums_acc :
  forall (xs : list nat) (a d : nat),
    length xs > 0 ->
    nth 0 (list_partial_sums_acc a xs) d =
    (nth 0 xs d) + a.
Proof.
  induction xs as [ | x xs' IH_xs' ].

  Case "xs = []".
  intros a d H_absurd.
  inversion H_absurd.

  Case "xs = x :: xs'".
  intros a d H_length_x_xs'_gt_0.
  rewrite -> unfold_list_partial_sums_acc_induction_case.
  rewrite -> unfold_nth_base_case_cons.
  rewrite -> unfold_nth_base_case_cons.
  reflexivity.
Qed.
Hint Rewrite nth_list_partial_sums_acc : listcalc.

(** *** List partial sums

  *** Definition *)

(* {LIST_PARTIAL_SUMS} *)
Definition list_partial_sums (xs : list nat) : list nat :=
  list_partial_sums_acc 0 xs.
(* {END} *)
Hint Unfold list_partial_sums : listcalc.

(** *** Unfolding lemmas *)

Lemma unfold_list_partial_sums :
  forall (xs : list nat),
    list_partial_sums xs = list_partial_sums_acc 0 xs.
Proof.
  intro xs.
  unfold list_partial_sums.
  reflexivity.
Qed.
Hint Rewrite unfold_list_partial_sums : listcalc.

(** *** Properties *)

Lemma nth_list_partial_sums :
  forall (xs : list nat) (d : nat),
    length xs > 0 ->
    nth 0 (list_partial_sums xs) d =
    (nth 0 xs d).
Proof.
  intros xs d H_length_xs_gt_0.
  rewrite -> unfold_list_partial_sums.
  rewrite <- plus_0_r.
  exact (nth_list_partial_sums_acc xs 0 d H_length_xs_gt_0).
Qed.
Hint Rewrite nth_list_partial_sums : listcalc.


(** * Step 1 and 2. Defining syntax and isomorphism *)

(** Grammar of pseudo-type

   Add this annotation to guide the isomorphism generation tool
   to produce the isomorphism modules for type automatically
<<
(*@Iso Iso_typ*)
>> *)

(*@Iso Iso_typ*)
Inductive typ :=
| typ_var : nat -> typ
| typ_arrow  : typ -> typ -> typ.

(** Grammar of pseudo-term

Add this annotation to guide the isomorphism generation tool to produce the isomorphism modules for term automatically
<<
(*@Iso Iso_trm {
  Parameter trm_fvar,
  Variable  trm_bvar,
  Binder trm_abs
}*)
>> *)

(*@Iso Iso_trm {
  Parameter trm_fvar,
  Variable  trm_bvar,
  Binder trm_abs
}*)
Inductive trm :=
| trm_fvar : nat -> trm
| trm_bvar : nat -> trm
| trm_abs  : trm -> trm
| trm_app  : trm -> trm -> trm.

(***********************************************************)
(** ** Isomorphism modules for type and term *)
(***********************************************************)
(** Isomorphism generation tool will produce isomorphism modules for type and term automatically.

> genIsos Tutorial_STLC_Syntax.v

This command will generate [Iso_typ.v] and [Iso_trm.v]
which contain isomorphism for type and isomorphism for term respectively.

<<
Module Iso_typ <: Iso_partial.
  ...
End Iso_typ

Module Iso_trm <: Iso_full.
  ...
End Iso_trm
>> *)


Require Import LC.Util.Fin.

Fixpoint Vec X n : Type :=
  match n with
  | 0 => unit
  | S m => X * Vec X m
  end.

Fixpoint vmap {X Y} {n} (f : X -> Y) : Vec X n -> Vec Y n :=
  match n with
  | 0 => fun _ => tt
  | S m => fun '(x, xs) => (f x, vmap f xs)
  end.

Fixpoint vlookup {X} {n} : Fin n -> Vec X n -> X :=
  match n with
  | 0 => fun e =>
    match e with
    end
  | S m => fun i v =>
    match i with
    | inl _ => fst v
    | inr j => vlookup j (snd v)
    end
  end.

Lemma vlookup_vmap {X Y} {n} (f : X -> Y) (v : Vec X n) (i : Fin n) :
  vlookup i (vmap f v) = f (vlookup i v).
Proof.
  induction n.
  - destruct i.
  - destruct i; destruct v; simpl.
    + reflexivity.
    + now rewrite IHn.
Qed.

Fixpoint Fins n : Vec (Fin n) n :=
  match n with
  | 0 => tt
  | S m => (inl tt, vmap inr (Fins m))
  end.

Lemma vlookup_Fins {n} : forall i : Fin n,
  vlookup i (Fins n) = i.
Proof.
  induction n; intro i.
  - destruct i.
  - destruct i as [[]|j].
    + reflexivity.
    + simpl.
      rewrite vlookup_vmap.
      now rewrite IHn.
Qed.


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

Require Import Arith Omega.

Set Implicit Arguments.

Section nat_rev_ind.

  (** A reverse recursion principle *)

  Variables (P : nat -> Prop)
            (HP : forall n, P (S n) -> P n).

  Theorem nat_rev_ind x y : x <= y -> P y -> P x.
  Proof. induction 1; auto. Qed.

End nat_rev_ind.

Section nat_rev_ind'.

  (** A reverse recursion principle *)

  Variables (P : nat -> Prop) (k : nat)
            (HP : forall n, n < k -> P (S n) -> P n).

  Theorem nat_rev_ind' x y : x <= y <= k -> P y -> P x.
  Proof.
    intros H1 H2.
    set (Q n := n <= k /\ P n).
    assert (forall x y, x <= y -> Q y -> Q x) as H.
      apply nat_rev_ind.
      intros n (H3 & H4); split.
      omega.
      revert H4; apply HP, H3.
    apply (H x y).
    omega.
    split; auto; omega.
  Qed.

End nat_rev_ind'.

Section minimizer_bool.

  Variable (T F : nat -> Prop)
           (HFun  : forall n, T n -> F n -> False)
           (HComp : forall n, T n \/ F n -> { T n } + { F n }).

  Definition minimizer n := T n /\ forall i, i < n -> F i.

  Fact minimizer_fun n m : minimizer n -> minimizer m -> n = m.
  Proof.
    intros (H1 & H2) (H3 & H4).
    destruct (lt_eq_lt_dec n m) as [ [ H | ] | H ]; auto.
    * apply H4 in H; destruct (@HFun n); auto.
    * apply H2 in H; destruct (@HFun m); auto.
  Qed.

  Inductive bar n : Prop :=
    | in_bar_0 : T n -> bar n
    | in_bar_1 : F n -> bar (S n) -> bar n.

  Let bar_ex n : bar n -> T n \/ F n.
  Proof. induction 1; auto. Qed.

  Let loop : forall n, bar n -> { k | T k /\ forall i, n <= i < k -> F i }.
  Proof.
    refine (fix loop n Hn { struct Hn } := match HComp (bar_ex Hn) with
        | left  H => exist _ n _
        | right H => match loop (S n) _ with
          | exist _ k Hk => exist _ k _
        end
      end).
    * split; trivial.
      intros; omega.
    * destruct Hn; trivial.
      destruct (@HFun n); trivial.
    * destruct Hk as (H1 & H2); split; trivial.
      intros i Hi; destruct (eq_nat_dec i n).
      - subst; trivial.
      - apply H2; omega.
  Qed.

  Hypothesis Hmin : ex minimizer.

  Let bar_0 : bar 0.
  Proof.
    destruct Hmin as (k & H1 & H2).
    apply in_bar_0 in H1.
    revert H1.
    apply nat_rev_ind' with (k := k).
    intros i H3.
    apply in_bar_1, H2; trivial.
    omega.
  Qed.

  Definition minimizer_bool_coq : sig minimizer.
  Proof.
    destruct (loop bar_0) as (k & H1 & H2).
    exists k; split; auto.
    intros; apply H2; omega.
  Defined.

End minimizer_bool.

Section minimizer.

  Variable (R : nat -> nat -> Prop)
           (Rfun : forall n u v, R n u -> R n v -> u = v)
           (HR : forall n, ex (R n) -> sig (R n)).

  Let T n := R n 0.
  Let F n := exists u, R n (S u).

  Definition minimizer_coq : ex (@minimizer T F) -> sig (@minimizer T F).
  Proof.
    apply minimizer_bool_coq.
    intros n H1 (u & H2).
    generalize (Rfun H1 H2); discriminate.
    intros n Hn.
    refine (match @HR n _ with
      | exist _ u Hu => match u as m return R _ m -> _ with
        | 0   => fun H => left H
        | S v => fun H => right (ex_intro _ v H)
        end Hu
      end).
    destruct Hn as [ Hn | (u & Hu) ].
    - exists 0; auto.
    - exists (S u); auto.
  Defined.

End minimizer.

Check minimizer_coq.
Print Assumptions minimizer_coq.

Extraction "minimizer.ml" minimizer_bool_coq minimizer_coq.


Require Import Arith.
Require Import List.
Import ListNotations.

(** On définit ici des fonctions d'indexage et d'insertion dans la mémoire
qui tiennent compte de sa taille.
Ainsi, on empêche les accès en dehors du domaine autorisé. *)

Lemma zltz: 0 < 0 -> False.
Proof.
  intros. contradict H. apply Lt.lt_irrefl.
Qed.

Lemma nltz: forall n: nat, n < 0 -> False.
Proof.
  intros. contradict H. apply Lt.lt_n_0.
Qed.

Lemma predecessor_proof: forall {X: Type} (n: nat) (x: X) (xs: list X),
  S n < length (x::xs) -> n < length xs.
Proof.
  intros. simpl in H. apply Lt.lt_S_n. assumption.
Qed.

Fixpoint safe_nth {X: Type} (xs: list X) (n: nat): n < length xs -> X :=
  match xs, n with
  | [], _ => fun pf => match nltz n pf with end
  | x::_, 0 => fun _ => x
  | x::xs', S n' => fun pf => safe_nth xs' n' (predecessor_proof n' x xs' pf)
  end.

Fixpoint safe_insert {X: Type} (xs: list X) (n: nat) (elt: X): n < length xs -> list X :=
  match xs, n with
    | nil, _ => fun pf => elt::nil
    | h::t, 0 => fun _ => elt::t
    | h :: t, S n' => fun pf => h :: safe_insert t n' elt (predecessor_proof n' h t pf)
    end.

Definition insert' {A:Type} (l: list A) (n : nat) (elt : A)  :=
match lt_dec n (length l) with
  | left pf => Some (safe_insert l n elt pf)
  | right _ => None
  end.

Definition nth' {A:Type} (l: list A) (n : nat) :=
match lt_dec n (length l) with
  | left pf => Some (safe_nth l n pf)
  | right _ => None
  end.

Eval compute in insert' [1;2;3] 2 4.
Eval compute in nth' [1;2;3] 0.