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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Properties of arbitrary binary relations (not necessarily decidable) *)
(** A functional or deterministic relation *)
Definition functional {X : Type} (R : X -> X -> Prop) : Prop :=
  forall (s s1 s2 : X), R s s1 -> R s s2 -> s1 = s2.

Lemma func1 :
  functional (fun x y => x.*2 == y).
Admitted.

Lemma func2 :
  ~ functional (fun x y => (x.*2 == y) || ((x, y) == (0,1))).
Admitted.

(** Define a notation such that {In C, functional R} restricts the domain of the relation like so:

  forall (s s1 s2 : X), C s -> R s s1 -> R s s2 -> s1 = s2

And prove the following lemma:
*)
(* Notation "{ 'In' C , P }" := *)
(*   (...) (at level 0). *)

Lemma func3 :
  {In (fun n => 0 < n), functional (fun x y => (x.*2 == y) || ((x, y) == (0,1)))}.
Admitted.

(* prove without using [case] or [elim] tactics *)
Lemma Peirce p q : ((p ==> q) ==> p) ==> p.
Admitted.

(* prove without using [case] or [elim] tactics *)
Lemma addb_neq12 p q :  ~~ p = q -> p (+) q.
Admitted.

Lemma div_fact_plus1 m p : 1 < p -> p %| m `! + 1 -> m < p.
Admitted.

(* Prove [8x = 6y + 1] has no solutions in [nat] *)
Lemma no_solution x y :
  8*x != 6*y + 1.
Admitted.

Lemma iota_add m n1 n2 :
  iota m (n1 + n2) = iota m n1 ++ iota (m + n1) n2.
Admitted.

Definition mysum m n F := (foldr (fun i a => F i + a) 0 (iota m (n - m))).

(* "big" operator *)
Notation "\mysum_ ( m <= i < n ) F" := (mysum m n (fun i => F))
  (at level 41, F at level 41, i, m, n at level 50,
           format "'[' \mysum_ ( m  <=  i  <  n ) '/  '  F ']'").

Lemma mysum_recl m n F :
  m <= n ->
  \mysum_(m <= i < n.+1) F i = \mysum_(m <= i < n) F i + F n.
Admitted.

Lemma sum_odds n :
  \mysum_(0 <= i < n) (2 * i + 1) = n ^ 2.
Admitted.


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

Inductive source_expr : Type :=
	| n : source_expr
	| expr : source_expr -> source_expr -> source_expr.

Inductive instr : Type :=
	| pop : instr
	| push : nat -> instr.

Inductive instrlist : Type :=
	| empty : instrlist
	| build : instr -> instrlist -> instrlist.

Definition pop_stack (s : natlist) : natlist :=
	match s with
		| nil => nil
		| cons h (cons h' t) => cons (h + h') t
		| _ => s
end.

Fixpoint execute (lst : instrlist) (stack : natlist) : natlist :=
	match lst with
		| empty => stack
		| build h t => match h with
			| (push n') => execute t (cons n' stack)
			| pop => execute t (pop_stack stack)
		end
end.

Example test_execute1 : execute (build (push 5) empty) nil = cons 5 nil.
Proof. reflexivity. Qed.

Example test_execute2 : execute (build (push 5) (build (push 3) (build pop empty))) nil = cons 8 nil.
Proof. reflexivity. Qed.

Example test_execute3 : execute (build pop empty) (cons 1 (cons 2 nil)) = cons 3 nil.
Proof. reflexivity. Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Theorem identity_fn_applied_twice :
    forall (f : bool -> bool),
    (forall (x : bool), f x = x) ->
    forall (b : bool), f (f b) = b.
Proof.
    intros f.
    intros H.
    intros b.
    rewrite <- H.
    rewrite <- H.
    reflexivity.
Qed.


Require Import FormalSystem Translation Classical
        EqualityArithmetic.

(* -------------------------- *)
(*Consistency of PA via that of HA*)

(*Question 5.1.1*)
(*Interpretation of formulae as types of Coq (in the universe Prop)*)
Fixpoint intf f : Prop :=
  match f with
  | Tr => True
  | Fa => False
  | And g h => intf g /\ intf h
  | Or g h => intf g \/ intf h
  | Impl g h => intf g -> intf h
  | @All A P => forall x:A, intf (P x)
  | @Ex A P => exists x:A, intf (P x)
  | Atom p => p
  end.

(*Question 5.2.1*)
(*The soundness of the interpretation --- all derivable judgments L ⊢ f are valid, i.e., the type corresponding to the conclusion is inhabited when those corresponding to the premisses are inhabited.*)
Lemma intf_soundness (L:_->Prop) f:
  (forall g, L g -> intf g) ->
  L ⊢ f -> intf f.
Proof.
  intros H' H. induction H; simpl in *; try auto.
  - exfalso. apply IHderiv, H'.
  - intro. apply IHderiv. intros g0 H1. case H1.
    + apply H'.
    + intro H2. rewrite H2. assumption.
  - apply IHderiv, H'.
  - apply IHderiv, H'.
  - case IHderiv1. apply H'.
    + intro. apply IHderiv2. intros g0 H1'. case H1'.
      * apply H'.
      * intro H1''. rewrite H1''. assumption.
    + intro. apply IHderiv3. intros g0 H1'. case H1'.
      * apply H'.
      * intro H1''. rewrite H1''. assumption.
  - exists t. auto.
  - destruct IHderiv.
    + assumption.
    + apply (H0 x). intros g H''. case H''.
      * apply H'.
      * intro H3. rewrite H3. exact H2.
Qed.

(*Question 5.3.1*)
(*The interpretation of the theory E A holds for any type A*)
Lemma intf_E A f:
  E A f ->
  intf f.
Proof.
  intro H; case H; simpl in *.
  + reflexivity.
  + symmetry. assumption.
  + intros. transitivity y; assumption.
Qed.

(*The same for the theory A*)
Lemma intf_A f:
  A f ->
  intf f.
Proof.
  intro H; case H; simpl in *.
  + apply O_S.
  + apply eq_add_S.
  + intros P. apply (nat_ind (fun x => intf (P x))).
Qed.

(*Question 5.4.1*)
(*Consistency of HA*)
Lemma HA_consistency :
  ~ (Ø ⊢ₕ Fa).
Proof.
  intro.
  apply (intf_soundness (Ø ⋃ HA) Fa).
  - destruct 1.
    + exfalso. apply H0.
    + destruct H0. apply intf_A. assumption.
      apply (intf_E nat). assumption.
  - assumption.
Qed.

(*Consistency of PA via that of HA*)
Lemma PA_consistency :
  ~ (Ø ⊢ₚ Fa).
Proof.
  intro.
  assert (Ø ⊢ₕ Fa).
  - apply (deriv_substitution (nnt_ctx Ø ⋃ HA)).
    + apply (nnt_ha Ø Fa). assumption.
    + intros. destruct H0.
      * destruct H0 as [g [H' H'']]. exfalso. apply H'.
      * apply ax; right; assumption.
  - apply HA_consistency. assumption.
Qed.

(*Fin*)


Require Import init.

Require Export plus_group.
Require Export mult_ring.

Require Import set.
Require Import unordered_list.

#[universes(template)]
Record Ideal U `{Plus U, Mult U} := make_ideal {
    ideal_set : U → Prop;
    ideal_nempty : ∃ a, ideal_set a;
    ideal_plus : ∀ a b, ideal_set a → ideal_set b → ideal_set (a + b);
    ideal_lmult : ∀ a b, ideal_set b → ideal_set (a * b);
    ideal_rmult : ∀ a b, ideal_set a → ideal_set (a * b);
}.
Arguments make_ideal {U H H0}.
Arguments ideal_set {U H H0}.
Arguments ideal_nempty {U H H0}.
Arguments ideal_plus {U H H0}.
Arguments ideal_lmult {U H H0}.
Arguments ideal_rmult {U H H0}.

Theorem ideal_eq_set {U} `{Plus U, Mult U} : ∀ I J : Ideal U,
    ideal_set I = ideal_set J → I = J.
Proof.
    intros [I_set I_nempty I_plus I_lmult I_rmult]
           [J_set J_nempty J_plus J_lmult J_rmult] eq.
    cbn in eq.
    subst J_set.
    rewrite (proof_irrelevance J_nempty I_nempty).
    rewrite (proof_irrelevance J_plus I_plus).
    rewrite (proof_irrelevance J_lmult I_lmult).
    rewrite (proof_irrelevance J_rmult I_rmult).
    reflexivity.
Qed.

Theorem ideal_eq {U} `{Plus U, Mult U} : ∀ I J : Ideal U,
    (∀ x, ideal_set I x ↔ ideal_set J x) → I = J.
Proof.
    intros I J eq.
    apply ideal_eq_set.
    apply predicate_ext.
    exact eq.
Qed.

(* begin hide *)
Section RingIdeal.

Context {U} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UM : Mult U,
    UO : One U,
    @PlusAssoc U UP,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,
    @Ldist U UP UM,
    @Rdist U UP UM,
    @MultAssoc U UM,
    @MultComm U UM,
    @MultLid U UM UO,
    @MultRid U UM UO
}.

(* end hide *)
Variable I : Ideal U.

Theorem ideal_neg : ∀ a, ideal_set I a → ideal_set I (-a).
Proof.
    intros a a_in.
    rewrite <- mult_neg_one.
    apply ideal_lmult.
    exact a_in.
Qed.

Theorem ideal_zero : ideal_set I 0.
Proof.
    pose proof (ideal_nempty I) as [a a_in].
    rewrite <- (plus_linv a).
    apply ideal_plus.
    1: apply ideal_neg.
    all: exact a_in.
Qed.

Let ideal_eq a b := ideal_set I (a - b).
Local Infix "~" := ideal_eq : algebra_scope.

Lemma ideal_eq_reflexive : ∀ a, a ~ a.
Proof.
    intros a.
    unfold ideal_eq.
    rewrite plus_rinv.
    apply ideal_zero.
Qed.
Instance ideal_eq_reflexive_class : Reflexive _ := {
    refl := ideal_eq_reflexive
}.

Lemma ideal_eq_symmetric : ∀ a b, a ~ b → b ~ a.
Proof.
    unfold ideal_eq.
    intros a b ab.
    apply ideal_neg in ab.
    rewrite neg_plus in ab.
    rewrite neg_neg in ab.
    rewrite plus_comm in ab.
    exact ab.
Qed.
Instance ideal_eq_symmetric_class : Symmetric _ := {
    sym := ideal_eq_symmetric
}.

Lemma ideal_eq_transitive : ∀ a b c, a ~ b → b ~ c → a ~ c.
Proof.
    unfold ideal_eq.
    intros a b c ab bc.
    pose proof (ideal_plus I _ _ ab bc) as eq.
    rewrite plus_assoc in eq.
    rewrite plus_rlinv in eq.
    exact eq.
Qed.
Instance ideal_eq_transitive_class : Transitive _ := {
    trans := ideal_eq_transitive
}.

Definition ideal_equiv := make_equiv _ ideal_eq_reflexive_class
    ideal_eq_symmetric_class ideal_eq_transitive_class.

Definition quotient_ring := equiv_type ideal_equiv.
Definition to_qring a := to_equiv ideal_equiv a.

(* begin show *)
Local Infix "~" := (eq_equal ideal_equiv).
(* end show *)

Lemma qring_plus_wd : ∀ a b c d, a ~ b → c ~ d → a + c ~ b + d.
Proof.
    cbn; unfold ideal_eq.
    intros a b c d ab cd.
    rewrite neg_plus.
    rewrite <- plus_assoc.
    rewrite (plus_assoc c).
    rewrite (plus_comm c).
    do 2 rewrite plus_assoc.
    rewrite <- plus_assoc.
    apply ideal_plus; assumption.
Qed.

Instance quotient_ring_plus : Plus quotient_ring := {
    plus := binary_op (binary_self_wd qring_plus_wd)
}.

Program Instance quotient_ring_plus_assoc : PlusAssoc quotient_ring.
Next Obligation.
    equiv_get_value a b c.
    unfold plus; equiv_simpl.
    rewrite plus_assoc.
    reflexivity.
Qed.

Program Instance quotient_ring_plus_comm : PlusComm quotient_ring.
Next Obligation.
    equiv_get_value a b.
    unfold plus; equiv_simpl.
    rewrite plus_comm.
    reflexivity.
Qed.

Instance quotient_ring_zero : Zero quotient_ring := {
    zero := to_equiv ideal_equiv 0
}.

Program Instance quotient_ring_plus_lid : PlusLid quotient_ring.
Next Obligation.
    equiv_get_value a.
    unfold zero, plus; equiv_simpl.
    rewrite plus_lid.
    reflexivity.
Qed.

Lemma qring_neg_wd : ∀ a b, a ~ b → -a ~ -b.
Proof.
    cbn; unfold ideal_eq.
    intros a b eq.
    rewrite <- neg_plus.
    apply ideal_neg.
    exact eq.
Qed.
Instance quotient_ring_neg : Neg quotient_ring := {
    neg := unary_op (unary_self_wd qring_neg_wd)
}.

Program Instance quotient_ring_plus_linv : PlusLinv quotient_ring.
Next Obligation.
    equiv_get_value a.
    unfold plus, neg, zero; equiv_simpl.
    rewrite plus_linv.
    reflexivity.
Qed.

Lemma qring_mult_wd : ∀ a b c d, a ~ b → c ~ d → a * c ~ b * d.
Proof.
    cbn; unfold ideal_eq.
    intros a b c d ab cd.
    rewrite <- (plus_llinv (-(b * d)) (b * c)).
    rewrite plus_assoc.
    apply ideal_plus.
    -   rewrite <- mult_lneg.
        rewrite <- rdist.
        apply ideal_rmult.
        exact ab.
    -   rewrite <- mult_rneg.
        rewrite <- ldist.
        apply ideal_lmult.
        exact cd.
Qed.

Instance quotient_ring_mult : Mult quotient_ring := {
    mult := binary_op (binary_self_wd qring_mult_wd)
}.

Program Instance quotient_ring_ldist : Ldist quotient_ring.
Next Obligation.
    equiv_get_value a b c.
    unfold plus, mult; equiv_simpl.
    rewrite ldist.
    reflexivity.
Qed.

Program Instance quotient_ring_rdist : Rdist quotient_ring.
Next Obligation.
    equiv_get_value a b c.
    unfold plus, mult; equiv_simpl.
    rewrite rdist.
    reflexivity.
Qed.

Program Instance quotient_ring_mult_assoc : MultAssoc quotient_ring.
Next Obligation.
    equiv_get_value a b c.
    unfold mult; equiv_simpl.
    rewrite mult_assoc.
    reflexivity.
Qed.

Program Instance quotient_ring_mult_comm : MultComm quotient_ring.
Next Obligation.
    equiv_get_value a b.
    unfold mult; equiv_simpl.
    rewrite mult_comm.
    reflexivity.
Qed.

Instance quotient_ring_one : One quotient_ring := {
    one := to_equiv ideal_equiv 1
}.

Program Instance quotient_ring_mult_lid : MultLid quotient_ring.
Next Obligation.
    equiv_get_value a.
    unfold one, mult; equiv_simpl.
    rewrite mult_lid.
    reflexivity.
Qed.

Program Instance quotient_ring_mult_rid : MultRid quotient_ring.
Next Obligation.
    equiv_get_value a.
    unfold one, mult; equiv_simpl.
    rewrite mult_rid.
    reflexivity.
Qed.

Theorem to_qring_plus : ∀ a b, to_qring (a + b) = to_qring a + to_qring b.
Proof.
    intros a b.
    unfold plus at 2, to_qring; equiv_simpl.
    apply ideal_eq_reflexive.
Qed.

Theorem to_qring_zero : to_qring 0 = 0.
Proof.
    reflexivity.
Qed.

Theorem to_qring_neg : ∀ a, to_qring (-a) = -to_qring a.
Proof.
    intros a.
    unfold neg at 2, to_qring; equiv_simpl.
    apply ideal_eq_reflexive.
Qed.

Theorem to_qring_mult : ∀ a b, to_qring (a * b) = to_qring a * to_qring b.
Proof.
    intros a b.
    unfold mult at 2, to_qring; equiv_simpl.
    apply ideal_eq_reflexive.
Qed.

Theorem to_qring_one : to_qring 1 = 1.
Proof.
    reflexivity.
Qed.

(* begin hide *)
End RingIdeal.

Section IdealGenerated.

Context {U} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UM : Mult U,
    UO : One U,
    @PlusAssoc U UP,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,
    @Ldist U UP UM,
    @Rdist U UP UM,
    @MultAssoc U UM,
    @MultLid U UM UO,
    @MultRid U UM UO
}.

(* end hide *)
Variable S : U → Prop.

Definition ideal_generated_by_set x := ∃ l : ulist ((U * U) * set_type S),
    x = ulist_sum (ulist_image (λ p, fst (fst p) * [snd p|] * snd (fst p)) l).

Lemma ideal_generated_by_nempty : ∃ x, ideal_generated_by_set x.
Proof.
    exists 0.
    exists ulist_end.
    rewrite ulist_image_end, ulist_sum_end.
    reflexivity.
Qed.

Lemma ideal_generated_by_plus : ∀ a b,
    ideal_generated_by_set a → ideal_generated_by_set b →
    ideal_generated_by_set (a + b).
Proof.
    intros a b [al al_eq] [bl bl_eq]; subst a b.
    exists (al + bl).
    rewrite ulist_image_conc, ulist_sum_plus.
    reflexivity.
Qed.

Lemma ideal_generated_by_lmult : ∀ a b,
    ideal_generated_by_set b → ideal_generated_by_set (a * b).
Proof.
    intros a b [l l_eq]; subst b.
    exists (ulist_image (λ p, ((a * fst (fst p), snd (fst p)), snd p)) l).
    rewrite ulist_image_comp.
    cbn.
    induction l as [|b l] using ulist_induction.
    -   do 2 rewrite ulist_image_end, ulist_sum_end.
        apply mult_ranni.
    -   do 2 rewrite ulist_image_add, ulist_sum_add.
        rewrite ldist.
        rewrite IHl.
        apply rplus.
        do 2 rewrite mult_assoc.
        reflexivity.
Qed.

Lemma ideal_generated_by_rmult : ∀ a b,
    ideal_generated_by_set a → ideal_generated_by_set (a * b).
Proof.
    intros a b [l l_eq]; subst a.
    exists (ulist_image (λ p, ((fst (fst p), snd (fst p) * b), snd p)) l).
    rewrite ulist_image_comp.
    cbn.
    induction l as [|a l] using ulist_induction.
    -   do 2 rewrite ulist_image_end, ulist_sum_end.
        apply mult_lanni.
    -   do 2 rewrite ulist_image_add, ulist_sum_add.
        rewrite rdist.
        rewrite IHl.
        apply rplus.
        rewrite mult_assoc.
        reflexivity.
Qed.

Definition ideal_generated_by := make_ideal
    ideal_generated_by_set
    ideal_generated_by_nempty
    ideal_generated_by_plus
    ideal_generated_by_lmult
    ideal_generated_by_rmult.
(* begin hide *)

End IdealGenerated.
(* end hide *)


Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.

Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Testbit.

Require Import Crypto.Util.ZUtil.Tactics.SolveTestbit.

Local Open Scope Z_scope.

Module Z.
  Lemma ones_from_spec m k i
        (Hk : 0 <= k) :
    Z.testbit (Z.ones_from m k) i = if (i <? 0) then false else ((m - k) <=? i) && (i <? m).
  Proof. unfold Z.ones_from; Z.solve_testbit. Qed.

  Lemma ones_from_spec_full m k i :
    Z.testbit (Z.ones_from m k) i = if (i <? 0) then false else ((m - k) <=? i) && ((i <? m) || (k <? 0)).
  Proof. unfold Z.ones_from; Z.solve_testbit. Qed.

#[global]
  Hint Rewrite ones_from_spec : testbit_rewrite.

  Lemma ones_from_0 m : Z.ones_from m 0 = 0.
  Proof. Z.solve_using_testbit. Qed.
End Z.


(* Close Scope nat_scope. *)

Require Import ZArith.

(* SearchAbout "int". *)
(* Import Z_as_Int. *)
(* Import Int. *)

Open Scope Z_scope.

Definition int := Z.

Check (fun x y => x + y).

Inductive Value : Set :=
| V_Int  : int  -> Value
| V_Bool : bool -> Value
.

Inductive Prim : Set :=
| P_Plus
| P_Minus
| P_Times
| P_LT
.

Inductive Exp : Set :=
| EX_Int  : int  -> Exp
| EX_Bool : bool -> Exp
| EX_Prim : Prim -> Exp -> Exp -> Exp
| EX_If   : Exp -> Exp -> Exp -> Exp
.

Print Exp_ind.

Inductive Plus : Value -> Value -> Value -> Prop :=
| B_Plus  : forall i1 i2 i3 : int,
              i1 + i2 = i3 -> Plus (V_Int i1) (V_Int i2) (V_Int i3).

Notation "i1 'plus' i2 'is' i3" :=
  (Plus i1 i2 i3) (at level 31, left associativity).

Inductive Minus : Value -> Value -> Value -> Prop :=
| B_Minus : forall i1 i2 i3 : int,
              i1 - i2 = i3 -> Minus (V_Int i1) (V_Int i2) (V_Int i3).

Notation "i1 'minus' i2 'is' i3" :=
  (Minus i1 i2 i3) (at level 31, left associativity).

Inductive Times : Value -> Value -> Value -> Prop :=
| B_Times : forall i1 i2 i3 : int,
              i1 * i2 = i3 -> Times (V_Int i1) (V_Int i2) (V_Int i3).

Notation "i1 'times' i2 'is' i3" :=
  (Times i1 i2 i3) (at level 31, left associativity).

Check Z.compare.
Print comparison.

Definition Zlt x y :=
  match Z.compare x y with
    | Lt => true
    | Eq => false
    | Gt => false
  end.

Inductive LT : Value -> Value -> Value -> Prop :=
| B_LT : forall (i1 i2 : int) (b : bool),
           (Zlt i1 i2) = b -> LT (V_Int i1) (V_Int i2) (V_Bool b).

Notation "i1 'less' 'than' i2 'is' b3" :=
  (LT i1 i2 b3) (at level 31, left associativity).

(* Inductive LT : Value -> *)

Infix "+!" := (EX_Prim P_Plus) (at level 51, left associativity).

Infix "-!" := (EX_Prim P_Minus) (at level 51, left associativity).

Infix "*!" := (EX_Prim P_Times) (at level 41, left associativity).

Infix "<!" := (EX_Prim P_LT) (at level 61, left associativity).

Reserved Notation "e '||!' v" (at level 71, left associativity).

Inductive Eval1 : Exp -> Value -> Prop :=
| E_Int   : forall i, EX_Int i ||! V_Int i
| E_Bool  : forall b, EX_Bool b ||! V_Bool b
| E_IfT   : forall e1 e2 e3 v,
              e1 ||! V_Bool true ->
              e2 ||! v ->
              EX_If e1 e2 e3 ||! v
| E_IfF   : forall e1 e2 e3 v,
              e1 ||! V_Bool false ->
              e3 ||! v ->
              EX_If e1 e2 e3 ||! v
| E_Plus  : forall e1 e2 i1 i2 i3,
              e1 ||! i1 ->
              e2 ||! i2 ->
              i1 plus i2 is i3 ->
              e1 +! e2 ||! i3
| E_Minus : forall e1 e2 i1 i2 i3,
              e1 ||! i1 ->
              e2 ||! i2 ->
              i1 minus i2 is i3 ->
              e1 -! e2 ||! i3
| E_Times : forall e1 e2 i1 i2 i3,
              e1 ||! i1 ->
              e2 ||! i2 ->
              i1 times i2 is i3 ->
              e1 *! e2 ||! i3
| E_LT    : forall e1 e2 i1 i2 b3,
              e1 ||! i1 ->
              e2 ||! i2 ->
              i1 less than i2 is b3 ->
              e1 <! e2 ||! b3
where "e '||!' v" := (Eval1 e v)
.

(* 3.2 *)
Lemma eval1Unique :
  forall e v1 v2, e ||! v1 -> e ||! v2 -> v1 = v2.
Proof.
  induction e as [ i | b | p e1 IHe1 e2 IHe2 | eP IHeP eT IHeT eE IHeE ]
  ; intros v1 v2 E1 E2.

    (* EX_Int *)
    inversion E1; subst.
    inversion E2; subst.
    reflexivity.

    (* EX_Bool *)
    inversion E1; subst.
    inversion E2; subst.
    reflexivity.

    (* EX_Prim *)
    destruct p

    ; inversion E1 as [ | | |
                        | e1e1 e1e2 e1i1 e1i2 e1v e1E1H e1E2H e1BH
                        | e1e1 e1e2 e1i1 e1i2 e1v e1E1H e1E2H e1BH
                        | e1e1 e1e2 e1i1 e1i2 e1v e1E1H e1E2H e1BH
                        | e1e1 e1e2 e1i1 e1i2 e1v e1E1H e1E2H e1BH
                      ]
    ; subst
    ; inversion E2 as [ | | |
                        | e2e1 e2e2 e2i1 e2i2 e2v1 e2E1H e2E2H e2BH (* EX_Plus *)
                        | e2e1 e2e2 e2i1 e2i2 e2v1 e2E1H e2E2H e2BH (* EX_Minus *)
                        | e2e1 e2e2 e2i1 e2i2 e2v1 e2E1H e2E2H e2BH (* EX_Times *)
                        | e2e1 e2e2 e2i1 e2i2 e2v1 e2E1H e2E2H e2BH (* EX_LT *)
                      ]
    ; subst

    ; rewrite <- (IHe1 e1i1 e2i1 e1E1H e2E1H) in e2BH
    ; rewrite <- (IHe2 e1i2 e2i2 e1E2H e2E2H) in e2BH
    ; inversion e1BH; subst
    ; inversion e2BH; subst
    ; reflexivity.

    (* EX_If *)
    inversion E1 as [ |
                      | e1e1 e1e2 e1e3 e1v e1PH e1H
                      | e1e1 e1e2 e1e3 e1v e1PH e1H
                      | | | | ]
    ; subst
    ; inversion E2 as [ |
                        | e2e1 e2e2 e2e3 e2v e2PH e2H
                        | e2e1 e2e2 e2e3 e2v e2PH e2H
                        | | | | ]; subst.

    exact (IHeT v1 v2 e1H e2H).

    assert (V_Bool true = V_Bool false) as N by
          exact (IHeP (V_Bool true) (V_Bool false) e1PH e2PH)
    ; inversion N.

    assert (V_Bool false = V_Bool true) as N by
          exact (IHeP (V_Bool false) (V_Bool true) e1PH e2PH)
    ; inversion N.

    exact (IHeE v1 v2 e1H e2H).
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (z : natural) (lf2 : natural) : natural :=
  plus lf2 (mult z (Succ y)).


Require Import List Arith Lia.

Section mirror.

 Variable A : Type.

 Inductive remove_last (a:A) : list A -> list A -> Prop :=
   | remove_last_hd : remove_last a (a :: nil) nil
   | remove_last_tl :
       forall (b:A) (l m:list A),
         remove_last a l m -> remove_last a (b :: l) (b :: m).

 Inductive palindrome : list A -> Prop :=
   | empty_pal : palindrome nil
   | single_pal : forall a:A, palindrome (a :: nil)
   | cons_pal :
       forall (a:A) (l m:list A),
         palindrome l -> remove_last a m l -> palindrome (a :: m).

 #[local] Hint Constructors remove_last palindrome : core.

 Lemma ababa : forall a b:A, palindrome (a :: b :: a :: b :: a :: nil).
 Proof.
  eauto 7.
 Qed.

(* more about palindromes *)

Lemma remove_last_inv :
 forall (a:A) (l m:list A), remove_last a m l -> m = l ++ a :: nil.
Proof.
 intros a l m H; elim H; simpl; auto with datatypes.
 intros b l0 m0 H0 e; rewrite e; trivial.
Qed.

Lemma rev_app : forall l m:list A, rev (l ++ m) = rev m ++ rev l.
Proof.
 intros l m; elim l; simpl; auto with datatypes.
 intros a l0 H0; rewrite ass_app; rewrite H0; auto.
Qed.

Lemma palindrome_rev : forall l:list A, palindrome l -> rev l = l.
Proof.
 intros l H; elim H; simpl; auto with datatypes.
 intros a l0 m H0 H1 H2; generalize H1; inversion_clear H2.
 -  simpl; auto.
 -  rewrite (remove_last_inv _ _  _ H3); simpl; repeat (rewrite rev_app; simpl).
    intro eg; rewrite eg;  simpl; auto.
Qed.

(* A new induction principle for lists *)

(* preliminaries *)

Lemma length_app :
 forall l l':list A, length (l ++ l') = length l + length l'.
Proof.
  intro l; elim l; simpl; auto.
Qed.

Lemma fib_ind :
 forall P:nat -> Prop,
   P 0 ->
   P 1 ->
  (forall n:nat, P n -> P (S n) -> P (S (S n))) ->
  forall n:nat, P n.
Proof.
 intros P H0 H1 HSSn n.
 assert (H2 : P n /\ P (S n)).
 - induction n ;[tauto | ].
   destruct IHn;split;auto.
 -  destruct H2; auto.
Qed.

Section Proof_of_list_new_ind.
Variables (P : list A -> Prop).

Hypotheses (H0 : P nil)
           (H1 : forall a: A, P (a::nil))
           (H2 : forall (a b:A) (l:list A), P l -> P (a :: l ++ b :: nil)).

Lemma list_cut :
forall (l:list A) (x:A),
            exists b : A, exists l' : list A, x :: l = l' ++ b :: nil.
Proof.
intro l; elim l; simpl.
 intro x; exists x; exists (nil (A:=A)); auto.
 intros a1 l3 H x.
 case (H a1).
 intros x0 H7.
 case H7; intros b Hb.
 rewrite Hb.
 exists x0.
 exists (x :: b); auto.
Qed.

Lemma list_new_ind_length :
forall (n:nat) (l:list A), length l = n -> P l.
Proof.
intro n; pattern n; apply fib_ind.
  -  intro l; case l; [simpl; auto with datatypes |  discriminate].
  -  intro l; case l; simpl; [ discriminate | ].
     +  intros a l0; case l0; simpl; [auto | discriminate].
  -  intros n0 H3 H4 l; case l; simpl;[discriminate |].
     +  intros a l0 H5; generalize H5; case l0.
       *   simpl; discriminate 1.
       *   intros a0 l1 H6; destruct (list_cut l1 a0) as [x [l' Hx]];
           rewrite Hx; apply H2.
           apply H3.
           rewrite Hx in H6.
           rewrite length_app in H6.
           simpl in H6; lia.
Qed.

Lemma list_new_ind :
   forall l:list A, P l.
Proof.
 intro l; now apply list_new_ind_length with (length l).
Qed.

End Proof_of_list_new_ind.

Lemma app_left_reg : forall l l1 l2:list A, l ++ l1 = l ++ l2 -> l1 = l2.
Proof.
 intro l; elim l; simpl; auto.
 intros a l0 H0 l1 l2 H; injection H; auto.
Qed.

Lemma app_right_reg : forall l l1 l2:list A, l1 ++ l = l2 ++ l -> l1 = l2.
Proof.
 intros l l1 l2 e.
 assert (H: rev (l1 ++ l) = rev (l2 ++ l)).
 - now rewrite e.
 -  repeat rewrite rev_app in H.
    generalize (app_left_reg _ _ _ H).
    intro H1;  rewrite <- (rev_involutive  l1) ;
    rewrite <- (rev_involutive l2);
    rewrite H1; auto.
    Qed.

Theorem rev_pal : forall l:list A, rev l = l -> palindrome  l.
Proof.
 intro l; elim l using list_new_ind; auto.
 -  intros a b l0 H H0.
    apply cons_pal with l0.
   +  apply H;  simpl in H0;  rewrite rev_app in H0.
      simpl in H0; injection H0.
      intros H1 e; generalize H1; rewrite e.
      intro H2; generalize (app_right_reg _ _ _ H2); auto.
   +  simpl in H0; rewrite rev_app in H0; simpl in H0.
      injection H0; intros H1 H2; rewrite <- H2.
      generalize l0; intro l1; induction l1; simpl; auto.
Qed.

End mirror.


(* ###################################################################### *)
(** * Case study: Red-Black Trees *)

Open Scope bool_scope.
Require Import Coq.Arith.Arith_base.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Psatz.

(** We will now see how we can use Coq's language to implement an
    interesting functional program: a red-black tree module. Red-black
    trees are binary search trees that use an intricate invariant to
    guarantee that they are well-balanced.

    We use Coq's [Section] mechanism to state our definitions within
    the scope of common parameters. This makes our notation lighter by
    avoiding having to redeclare these arguments in all
    definitions. The [Variable] and [Hypothesis] keywords introduce
    assumptions in our context that are in scope in the entire
    [Section] declaration.

    Our definitions are parameterized by a type [A] and a comparison
    function [comp] between elements of [A]. The [comparison] type is
    defined in the standard library, and includes the values [Lt],
    [Gt], and [Eq]. Notice that we state a few hypotheses that are
    needed for our results to hold. *)

Section RedBlack.

Variable A : Type.
Variable comp : A -> A -> comparison.

Hypothesis comp_opp :
  forall x y, comp x y = CompOpp (comp y x).
Hypothesis comp_trans :
  forall x y z, comp x y = Lt ->
                comp y z = Lt ->
                comp x z = Lt.
Hypothesis comp_refl_iff :
(* <-> ==== if and only if *)
  forall x y, comp x y = Eq <-> x = y.

(* Exercise: (Hint: [apply] works with [<->]) *)
Lemma comp_refl : forall x, comp x x = Eq.
Proof.
  intros x.
  rewrite comp_refl_iff.
  reflexivity.
Qed.

(** Red-black trees are binary search trees that contain elements of
    [A] on their internal nodes, and such that every internal node is
    colored with either [Red] or [Black]. *)

Inductive color := Red | Black.

Inductive tree :=
| Leaf : tree
| Node : color -> tree -> A -> tree -> tree.

(** Before getting into details about the red-black invariants, we can
    already define a search algorithm that looks up an element [x] of
    [A] on a tree. Its definition is standard: *)

Fixpoint member x t : bool :=
  match t with
  | Leaf => false
  | Node _ t1 x' t2 =>
    match comp x x' with
    | Lt => member x t1
    | Eq => true
    | Gt => member x t2
    end
  end.

(** We want to formulate a specification for our algorithm and prove
    that this implementation indeed satisfies it. We begin by
    formalizing what it means for a tree to be a binary search
    tree. This will require the following higher-order function, which
    tests whether all elements of a tree [t] satisfy a property [f]: *)

Fixpoint all (f : A -> bool) (t : tree) : bool :=
  match t with
  | Leaf => true
  | Node _ t1 x t2 => all f t1 && f x && all f t2
  end.

(** We can now state the familiar binary-tree search invariant: Each
    element [x] on an internal node is strictly greater than those to
    its left, and strictly smaller than those to its right. We use an
    auxiliary function [ltb] that tests whether an element [x : A] is
    smaller than some [y : A] with the [comp] function. *)

Definition ltb x y :=
  match comp x y with
  | Lt => true
  | _ => false
  end.

(** The invariant is then expressed with a simple recursive function
    that combines [all] and [ltb] above. *)

Fixpoint search_tree (t : tree) : bool :=
  match t with
  | Leaf => true
  | Node _ t1 x t2 =>
    all (fun y => ltb y x) t1
    && all (ltb x) t2
    && search_tree t1
    && search_tree t2
  end.

(** The specification of [member] is given in terms of a function
    [occurs] that looks for an element [x] on all nodes of a tree
    [t]. The [eqb] function, as its name suggests, tests two elements
    for equality. *)

Definition eqb x y :=
  match comp x y with
  | Eq => true
  | _ => false
  end.

Fixpoint occurs (x : A) (t : tree) : bool :=
  match t with
  | Leaf => false
  | Node _ t1 y t2 => occurs x t1 || eqb x y || occurs x t2
  end.

(** New tactic
    ----------

    - [trivial]: solves simple goals through [reflexivity] and by
      looking for assumptions in the context that apply directly. If
      it cannot solve the goal, it does nothing.

    - [try]: Calling [try foo] tries to execute [foo], doing nothing
      if [foo] raises any errors. In particular, if [foo] is a
      _terminating tactic_ such as [discriminate], [try foo] attempts
      to solve the goal, and does nothing if it fails.

    - [destruct ... eqn: ...]: Do case analysis on an expression while
      generating an equation. *)

Lemma all_weaken :
  forall f g,
    (forall x, f x = true -> g x = true) ->
    forall t, all f t = true -> all g t = true.
Proof. Admitted.

(* Exercise: *)
Lemma none_occurs :
  forall (x : A) (f : A -> bool) (t : tree),
    f x = false ->
    all f t = true ->
    occurs x t = false.
Proof. (* fill in here *) Admitted.

(** With these results, we are ready to prove the correctness of the
    membership testing algorithm.

    New Tactics
    -----------

    - [assert]: Introduce a new hypothesis in the context, requiring
      us to prove that it holds. *)

Lemma member_correct :
  forall x t,
    search_tree t = true ->
    member x t = occurs x t.
Proof. Admitted.

(** We now turn our attention to the red-black invariant. A red-black
    tree is _valid_ if (1) all paths from the root of the tree to its
    leaves go through the same number of black nodes, and (2) if red
    nodes only have black children (we stipulate that the leaves of
    the tree are black). We begin by formalizing (2). *)

Definition tree_color (t : tree) : color :=
  match t with
  | Leaf => Black
  | Node c _ _ _ => c
  end.

Fixpoint well_colored (t : tree) : bool :=
  match t with
  | Leaf => true
  | Node c t1 _ t2 =>

    let colors_ok :=
      match c, tree_color t1, tree_color t2 with
      | Red, Black, Black => true
      | Red, _, _ => false
      | Black, _, _ => true
      end in
    colors_ok && well_colored t1 && well_colored t2
  end.

(** The [black_height] function computes the number of black nodes on
    the path to the left-most leaf of the tree. It is used in the
    [height_ok] function, which ensures that _all_ paths have the same
    number of black nodes. *)

Fixpoint black_height (t : tree) : nat :=
  match t with
  | Leaf => 0
  | Node Red t _ _ => black_height t
  | Node Black t _ _ => S (black_height t)
  end.

Fixpoint height_ok (t : tree) : bool :=
  match t with
  | Leaf => true
  | Node _ t1 _ t2 =>
    beq_nat (black_height t1) (black_height t2)
    && height_ok t1
    && height_ok t2
  end.

Definition is_red_black (t : tree) : bool :=
  well_colored t && height_ok t.

(** The red-black invariant is important because it implies that the
    height of the tree is logarithmic on the number of nodes. We will
    now see how to formally show that this is the case. We begin by
    defining a function [size] for computing various metrics about our
    trees: *)

Fixpoint size (f : nat -> nat -> nat) (t : tree) : nat :=
  match t with
  | Leaf => 0
  | Node _ t1 _ t2 => S (f (size f t1) (size f t2))
  end.

(** Note that [size plus] computes the number of elements stored in
    the tree. [size max] computes the height of the tree, whereas
    [size min] computes the length of the shortest path from the root
    of the tree to a leaf.

    As a warm-up exercise, let's show that the black height of a tree
    is a lower bound on the length of its minimal path.

    To facilitate low-level arithmetic reasoning, we can use the [lia]
    tactic.

    New Tactics
    -----------

    - [lia]: Short for "Linear Integer Arithmetic"; tries to solve
      goals that involve linear systems of inequalites on integers. *)

Lemma size_min_black_height :
  forall t,
    if height_ok t then black_height t <= size min t
    else True.
Proof. Admitted.

(** We now need to relate the black height of a tree to its total
    height, by proving the following fact: *)

Lemma size_max_black_height :
  forall t,
    if is_red_black t then size max t <= 2 * black_height t + 1
    else True.
Proof. (* stuck ... *) Abort.

(** Unfortunately, this won't work. We need to reason about the
    coloring properties of red-black trees, and show the following
    slightly stronger statement, which gives an improved bound for
    black trees. *)

Lemma size_max_black_height :
  forall t,
    if is_red_black t then
      match tree_color t with
      | Red => size max t <= 2 * black_height t + 1
      | Black => size max t <= 2 * black_height t
      end
    else True.
Proof. Admitted.

(** Exercise: Prove the following result using the previous two lemmas
    relating the height of the tree to the length of its mininal
    path. *)

Lemma size_max_size_min :
  forall t,
    if is_red_black t then size max t <= 2 * size min t + 1
    else True.
Proof. (* fill in here *) Admitted.

(** The previous lemma implies that the tree is well-balanced thanks
    to the following fact, which shows that the number of elements
    stored in a tree is exponential in the length of the minimal path:
    *)

Lemma size_min_size_plus :
  forall t,
    2 ^ size min t <= size plus t + 1.
Proof. Admitted.

(** Take-home exercise: The extended version of this file contains an
    implementation of red-black-tree insertion. Read through the basic
    definitions and try to complete the missing proofs. *)

End RedBlack.


(* T2: Demostraciones por inducción sobre los números naturales en Coq *)

Require Export T1_PF_en_Coq.

(* El contenido de la teoría es
   1. Demostraciones por inducción.
   2. Demostraciones anidadas.
   3. Demostraciones formales vs demostraciones informales.
   4. Ejercicios complementarios *)

(* =====================================================================
   § 1. Demostraciones por inducción
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 1.1. Demostrar que
      forall n:nat, n = n + 0.
   ------------------------------------------------------------------ *)

(* 1º intento: con métodos elementales *)
Theorem suma_n_0_a: forall n:nat, n = n + 0.
Proof.
  intros n. (* n : nat
               ============================
                n = n + 0 *)
  simpl.    (* n : nat
               ============================
                n = n + 0 *)
Abort.

(* 2º intento: con casos *)
Theorem suma_n_0_b : forall n:nat,
  n = n + 0.
Proof.
  intros n.             (* n : nat
                           ============================
                            n = n + 0 *)
  destruct n as [| n'].
  -                     (*
                           ============================
                            0 = 0 + 0 *)
    reflexivity.
  -                     (* n' : nat
                           ============================
                            S n' = S n' + 0  *)
    simpl.              (* n' : nat
                           ============================
                            S n' = S (n' + 0) *)
Abort.

(* 3ª intento: con inducción *)
Theorem suma_n_0 : forall n:nat,
    n = n + 0.
Proof.
  intros n.                   (* n : nat
                                 ============================
                                 n = n + 0 *)
  induction n as [| n' IHn'].
  +                           (*
                                 ============================
                                 0 = 0 + 0 *)
    reflexivity.
  +                           (* n' : nat
                                 IHn' : n' = n' + 0
                                 ============================
                                 S n' = S n' + 0 *)
    simpl.                    (* S n' = S (n' + 0) *)
    rewrite <- IHn'.          (* S n' = S n' *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 1.2. Demostrar que
      forall n, n - n = 0.
   ------------------------------------------------------------------ *)

Theorem resta_n_n: forall n, n - n = 0.
Proof.
  intros n.                   (* n : nat
                                 ============================
                                 n - n = 0 *)
  induction n as [| n' IHn'].
  +                           (*
                                 ============================
                                 0 - 0 = 0 *)
    reflexivity.
  +                           (* n' : nat
                                 IHn' : n' - n' = 0
                                 ============================
                                 S n' - S n' = 0 *)
    simpl.                    (* n' - n' = 0 *)
    rewrite -> IHn'.          (* 0 = 0 *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.1. Demostrar que
      forall n:nat, n * 0 = 0.
   ------------------------------------------------------------------ *)

Theorem multiplica_n_0: forall n:nat, n * 0 = 0.
Proof.
  intros n.                   (* n : nat
                                 ============================
                                 n * 0 = 0 *)
  induction n as [| n' IHn'].
  +                           (*
                                 ============================
                                 0 * 0 = 0 *)
    reflexivity.
  +                           (* n' : nat
                                 IHn' : n' * 0 = 0
                                 ============================
                                 S n' * 0 = 0 *)
    simpl.                    (* n' * 0 = 0 *)
    rewrite IHn'.             (* 0 = 0 *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.2. Demostrar que,
      forall n m : nat, S (n + m) = n + (S m).
   ------------------------------------------------------------------ *)

Theorem suma_n_Sm: forall n m : nat, S (n + m) = n + (S m).
Proof.
  intros n m.                (*  n, m : nat
                                 ============================
                                 S (n + m) = n + S m *)
  induction n as [|n' IHn'].
  +                          (* m : nat
                                ============================
                                S (0 + m) = 0 + S m *)
    simpl.                   (* m : nat
                                ============================
                                S m = S m *)
    reflexivity.
  +                          (* S (S n' + m) = S n' + S m *)
    simpl.                   (* S (S (n' + m)) = S (n' + S m) *)
    rewrite IHn'.            (* S (n' + S m) = S (n' + S m) *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.3. Demostrar que
      forall n m : nat, n + m = m + n.
   ------------------------------------------------------------------ *)

Theorem suma_conmutativa: forall n m : nat,
  n + m = m + n.
Proof.
  intros  n m.               (* n, m : nat
                                ============================
                                n + m = m + n *)
  induction n as [|n' IHn'].
  +                          (* m : nat
                                ============================
                                0 + m = m + 0 *)
    simpl.                   (* m = m + 0 *)
    rewrite <- suma_n_0.     (* m = m *)
    reflexivity.
  +                          (* n', m : nat
                                IHn' : n' + m = m + n'
                                ============================
                                S n' + m = m + S n' *)
    simpl.                   (* S (n' + m) = m + S n' *)
    rewrite IHn'.            (* S (m + n') = m + S n' *)
    rewrite <- suma_n_Sm.    (* S (m + n') = S (m + n') *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.4. Demostrar que
      forall n m p : nat, n + (m + p) = (n + m) + p.
   ------------------------------------------------------------------ *)

Theorem suma_asociativa: forall n m p : nat, n + (m + p) = (n + m) + p.
Proof.
  intros n m p.              (* n, m, p : nat
                                ============================
                                n + (m + p) = (n + m) + p *)
  induction n as [|n' IHn'].
  +                          (* m, p : nat
                                ============================
                                0 + (m + p) = (0 + m) + p *)
    reflexivity.
  +                          (* n', m, p : nat
                                IHn' : n' + (m + p) = n' + m + p
                                ============================
                                S n' + (m + p) = (S n' + m) + p *)
    simpl.                   (* S (n' + (m + p)) = S ((n' + m) + p) *)
    rewrite IHn'.            (* S ((n' + m) + p) = S ((n' + m) + p) *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.5. Se considera la siguiente función que dobla su argumento.
      Fixpoint doble (n:nat) :=
        match n with
        | O    => O
        | S n' => S (S (doble n'))
        end.

   Demostrar que
      forall n, doble n = n + n.
   ------------------------------------------------------------------ *)

Fixpoint doble (n:nat) :=
  match n with
  | O    => O
  | S n' => S (S (doble n'))
  end.

Lemma doble_suma : forall n, doble n = n + n .
Proof.
  intros n.                  (* n : nat
                                ============================
                                doble n = n + n *)
  induction n as [|n' IHn'].
  +                          (*
                                ============================
                                doble 0 = 0 + 0 *)
    reflexivity.
  +                          (* n' : nat
                                IHn' : doble n' = n' + n'
                                ============================
                                doble (S n') = S n' + S n' *)
    simpl.                   (* S (S (doble n')) = S (n' + S n') *)
    rewrite IHn'.            (* S (S (n' + n')) = S (n' + S n') *)
    rewrite suma_n_Sm.       (* S (n' + S n') = S (n' + S n') *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 1.6. Demostrar que
      forall n : nat, esPar (S n) = negacion (esPar n).
   ------------------------------------------------------------------ *)

Theorem esPar_S : forall n : nat,
  esPar (S n) = negacion (esPar n).
Proof.
  intros n.                      (* n : nat
                                    ============================
                                    esPar (S n) = negacion (esPar n) *)
  induction n as [|n' IHn'].
  +                              (*
                                    ============================
                                    esPar 1 = negacion (esPar 0) *)
    simpl.                       (*
                                    ============================
                                    false = false *)
    reflexivity.
  +                              (* n' : nat
                                    IHn' : esPar (S n') = negacion (esPar n')
                                    ============================
                                    esPar (S (S n')) =
                                     negacion (esPar (S n')) *)
    rewrite IHn'.                (* esPar (S (S n')) =
                                     negacion (negacion (esPar n')) *)
    rewrite negacion_involutiva. (* esPar (S (S n')) = esPar n' *)
    simpl.                       (* esPar n' = esPar n' *)
    reflexivity.
Qed.

(* =====================================================================
   § 2. Demostraciones anidadas
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejemplo 2.1. Demostrar que
      forall n m : nat, (0 + n) * m = n * m.
   ------------------------------------------------------------------ *)

Theorem producto_0_suma': forall n m : nat, (0 + n) * m = n * m.
Proof.
  intros n m.            (* n, m : nat
                            ============================
                            (0 + n) * m = n * m *)
  assert (H: 0 + n = n).
  -                      (* n, m : nat
                            ============================
                            0 + n = n *)
    reflexivity.
  -                      (* n, m : nat
                            H : 0 + n = n
                            ============================
                            (0 + n) * m = n * m *)
    rewrite -> H.        (* n * m = n * m *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejemplo 2.2. Demostrar que
      forall n m p q : nat, (n + m) + (p + q) = (m + n) + (p + q)
   ------------------------------------------------------------------ *)

(* 1º intento sin assert*)
Theorem suma_reordenada_1: forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.              (* n, m, p, q : nat
                                  ============================
                                  (n + m) + (p + q) = (m + n) + (p + q) *)
  rewrite -> suma_conmutativa. (* n, m, p, q : nat
                                  ============================
                                  p + q + (n + m) = m + n + (p + q) *)
Abort.

(* 2º intento con assert *)
Theorem suma_reordenada: forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.                (* n, m, p, q : nat
                                    ============================
                                    (n + m) + (p + q) = (m + n) + (p + q) *)
  assert (H: n + m = m + n).
  -                              (* n, m, p, q : nat
                                    ============================
                                    n + m = m + n *)
    rewrite -> suma_conmutativa. (* m + n = m + n *)
    reflexivity.
  -                              (* n, m, p, q : nat
                                    H : n + m = m + n
                                    ============================
                                    (n + m) + (p + q) = (m + n) + (p + q) *)
    rewrite -> H.                (* m + n + (p + q) = m + n + (p + q) *)
    reflexivity.
Qed.

(* =====================================================================
   § 3. Demostraciones formales vs demostraciones informales
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio 3.1. Escribir la demostración informal (en lenguaje natural)
   correspondiente a la demostración formal de la asociatividad de la
   suma del ejercicio 1.4.
   ------------------------------------------------------------------ *)

(* Demostración por inducción en n.

   - Caso base: Se supone que n es 0 y hay que demostrar que
        0 + (m + p) = (0 + m) + p.
     Esto es consecuencia inmediata de la definición de suma.

   - Paso de indución: Suponemos la hipótesis de inducción
        n' + (m + p) = (n' + m) + p.
     Hay que demostrar que
        (S n') + (m + p) = ((S n') + m) + p.
     que, por la definición de suma, se reduce a
        S (n' + (m + p)) = S ((n' + m) + p)
     que por la hipótesis de inducción se reduce a
        S ((n' + m) + p) = S ((n' + m) + p)
     que es una identidad. *)

(* ---------------------------------------------------------------------
   Ejercicio 3.2. Escribir la demostración informal (en lenguaje natural)
   correspondiente a la demostración formal de la asociatividad de la
   suma del ejercicio 1.3.
   ------------------------------------------------------------------ *)

(* Demostración por inducción en n.

   - Caso base: Se supone que n es 0 y hay que demostrar que
        0 + m = m + 0
     que, por la definición de la suma, se reduce a
        m = m + 0
     que se verifica por el lema suma_n_0.

   - Paso de indución: Suponemos la hipótesis de inducción
        n' + m = m + n'
     Hay que demostrar que
        S n' + m = m + S n'
     que, por la definición de suma, se reduce a
        S (n' + m) = m + S n'
     que, por la hipótesis de inducción, se reduce a
        S (m + n') = m + S n'
     que, por el lema suma_n_Sm, se reduce a
        S (m + n') = S (m + n')
     que es una identidad. *)

(* ---------------------------------------------------------------------
   Ejercicio 3.3. Demostrar que
      forall n:nat, iguales_nat n n = true.
   ------------------------------------------------------------------ *)

Theorem iguales_nat_refl: forall n : nat,
    iguales_nat n n = true.
Proof.
  intros n.                  (* n : nat
                                ============================
                                iguales_nat n n = true *)
  induction n as [|n' IHn'].
  -                          (*
                                ============================
                                iguales_nat 0 0 = true *)
    reflexivity.
  -                          (* n' : nat
                                IHn' : iguales_nat n' n' = true
                                ============================
                                iguales_nat (S n') (S n') = true *)
    simpl.                   (* iguales_nat n' n' = true *)
    rewrite <- IHn'.          (* true = true *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 3.4. Escribir la demostración informal (en lenguaje natural)
   correspondiente la demostración del ejercicio anterior.
   ------------------------------------------------------------------ *)

(* Demostración por inducción en n.

   - Caso base: Se supone que n es 0 y hay que demostrar que
        true = iguales_nat 0 0
     que se verifica por la definición de iguales_nat.

   - Paso de indución: Suponemos la hipótesis de inducción
        true = iguales_nat n' n'
     Hay que demostrar que
        true = iguales_nat (S n') (S n')
     que, por la definición de iguales_nat, se reduce a
        true = iguales_nat n' n
     que, por la hipótesis de inducción, se reduce a
        true = true
     que es una identidad. *)

(* =====================================================================
   § 4. Ejercicios complementarios
   ================================================================== *)

(* ---------------------------------------------------------------------
   Ejercicio 4.1. Demostrar, usando assert pero no induct,
      forall n m p : nat, n + (m + p) = m + (n + p).
   ------------------------------------------------------------------ *)

Theorem suma_permutada: forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.               (* n, m, p : nat
                                 ============================
                                 n + (m + p) = m + (n + p) *)
  rewrite suma_asociativa.    (* n, m, p : nat
                                 ============================
                                 (n + m) + p = m + (n + p) *)
  rewrite suma_asociativa.    (* n, m, p : nat
                                 ============================
                                 n + m + p = m + n + p *)
  assert (H : n + m = m + n).
  -                           (* n, m, p : nat
                                 ============================
                                 n + m = m + n *)
    rewrite suma_conmutativa. (* m + n = m + n *)
    reflexivity.
  -                           (* n, m, p : nat
                                 H : n + m = m + n
                                 ============================
                                 (n + m) + p = (m + n) + p *)
    rewrite H.                (* (m + n) + p = (m + n) + p *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.2. Demostrar que la multiplicación es conmutativa.
   ------------------------------------------------------------------ *)

Lemma producto_n_1 : forall n: nat,
    n * 1 = n.
Proof.
  intro n.                   (* n : nat
                                ============================
                                n * 1 = n *)
  induction n as [|n' IHn'].
  -                          (*
                                ============================
                                0 * 1 = 0 *)
    reflexivity.
  -                          (* n' : nat
                                IHn' : n' * 1 = n'
                                ============================
                                S n' * 1 = S n' *)
    simpl.                   (* S (n' * 1) = S n' *)
    rewrite IHn'.            (* S n' = S n' *)
    reflexivity.
Qed.

Theorem suma_n_1 : forall n : nat,
    n + 1 = S n.
Proof.
  intro n.                   (* n : nat
                                ============================
                                n + 1 = S n *)
  induction n as [|n' HIn'].
  -                          (*
                                ============================
                                0 + 1 = 1 *)
    reflexivity.
  -                          (* n' : nat
                                HIn' : n' + 1 = S n'
                                ============================
                                S n' + 1 = S (S n') *)
    simpl.                   (* S (n' + 1) = S (S n') *)
    rewrite HIn'.            (* S (S n') = S (S n') *)
    reflexivity.
Qed.

Theorem producto_n_Sm: forall n m : nat,
    n * (m + 1) = n * m + n.
Proof.
  intros n m.                   (* n, m : nat
                                   ============================
                                   n * (m + 1) = n * m + n *)
  induction n as [|n' IHn'].
  -                             (* m : nat
                                   ============================
                                   0 * (m + 1) = 0 * m + 0 *)
    reflexivity.
  -                             (* n', m : nat
                                   IHn' : n' * (m + 1) = n' * m + n'
                                   ============================
                                   S n' * (m + 1) = S n' * m + S n' *)
    simpl.                      (* (m + 1) + n' * (m + 1) =
                                    (m + n' * m) + S n' *)
    rewrite IHn'.               (* (m + 1) + (n' * m + n') =
                                    (m + n' * m) + S n' *)
    rewrite suma_permutada.     (* n' * m + ((m + 1) + n') =
                                    (m + n' * m) + S n' *)
    rewrite <- suma_asociativa. (* n' * m + (m + (1 + n')) =
                                    (m + n' * m) + S n' *)
    rewrite <- suma_n_1.        (* n' * m + (m + (n' + 1)) =
                                   (m + n' * m) + S n' *)
    rewrite suma_n_1.           (* n' * m + (m + S n') = (m + n' * m) + S n' *)
    rewrite suma_permutada.     (* m + (n' * m + S n') = (m + n' * m) + S n' *)
    rewrite suma_asociativa.    (* m + (n' * m + S n') = (m + n' * m) + S n' *)
    reflexivity.
Qed.

Theorem producto_conmutativa: forall m n : nat,
  m * n = n * m.
Proof.
  intros n m.                 (* n, m : nat
                                 ============================
                                 n * m = m * n *)
  induction n as [|n' HIn'].
  -                           (* m : nat
                                 ============================
                                 0 * m = m * 0 *)
    rewrite multiplica_n_0.   (* 0 * m = 0 *)
    reflexivity.
  -                           (* n', m : nat
                                 HIn' : n' * m = m * n'
                                 ============================
                                 S n' * m = m * S n' *)
    simpl.                    (* m + n' * m = m * S n' *)
    rewrite HIn'.             (* m + m * n' = m * S n' *)
    rewrite <- suma_n_1.      (* m + m * n' = m * (n' + 1) *)
    rewrite producto_n_Sm.    (* m + m * n' = m * n' + m *)
    rewrite suma_conmutativa. (* m * n' + m = m * n' + m *)
   reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.3. Demostrar que
      forall n : nat, true = menor_o_igual n n.
   ------------------------------------------------------------------ *)

Theorem menor_o_igual_refl: forall n : nat,
    true = menor_o_igual n n.
Proof.
  intro n.                    (* n : nat
                                 ============================
                                 true = menor_o_igual n n *)
  induction n as [| n' HIn'].
  -                           (*
                                 ============================
                                 true = menor_o_igual 0 0 *)
    reflexivity.
  -                           (* n' : nat
                                 HIn' : true = menor_o_igual n' n'
                                 ============================
                                 true = menor_o_igual (S n') (S n') *)
    simpl.                    (* true = menor_o_igual n' n' *)
    rewrite HIn'.             (* menor_o_igual n' n' = menor_o_igual n' n' *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.4. Demostrar que
      forall n : nat, iguales_nat 0 (S n) = false.
   ------------------------------------------------------------------ *)

Theorem cero_distinto_S: forall n : nat,
  iguales_nat 0 (S n) = false.
Proof.
  intros n.    (* n : nat
                  ============================
                  iguales_nat 0 (S n) = false *)
  simpl.       (* false = false *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.5. Demostrar que
      forall b : bool, conjuncion b false = false.
   ------------------------------------------------------------------ *)

Theorem conjuncion_false_r : forall b : bool,
  conjuncion b false = false.
Proof.
  intros b.      (* b : bool
                    ============================
                    b && false = false *)
  destruct b.
  -              (*
                    ============================
                    true && false = false *)
    simpl.       (* false = false *)
    reflexivity.
  -              (*
                    ============================
                    false && false = false *)
    simpl.       (* false = false *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.6. Demostrar que
      forall n m p : nat, menor_o_igual n m = true ->
                          menor_o_igual (p + n) (p + m) = true.
   ------------------------------------------------------------------ *)

Theorem menor_o_igual_suma: forall n m p : nat,
  menor_o_igual n m = true -> menor_o_igual (p + n) (p + m) = true.
Proof.
  intros n m p H.            (* n, m, p : nat
                                H : menor_o_igual n m = true
                                ============================
                                menor_o_igual (p + n) (p + m) = true *)
  induction p as [|p' HIp'].
  -                          (* n, m : nat
                                H : menor_o_igual n m = true
                                ============================
                                menor_o_igual (0 + n) (0 + m) = true *)
    simpl.                   (* menor_o_igual n m = true *)
    rewrite H.               (* true = true *)
    reflexivity.
  -                          (* n, m, p' : nat
                                H : menor_o_igual n m = true
                                HIp' : menor_o_igual (p' + n) (p' + m) = true
                                ============================
                                menor_o_igual (S p' + n) (S p' + m) = true *)
    simpl.                   (* menor_o_igual (p' + n) (p' + m) = true *)
    rewrite HIp'.            (* true = true *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.7. Demostrar que
      forall n : nat, iguales_nat (S n) 0 = false.
   ------------------------------------------------------------------ *)

Theorem S_distinto_0 : forall n:nat,
  iguales_nat (S n) 0 = false.
Proof.
  intro n.     (* n : nat
                  ============================
                  iguales_nat (S n) 0 = false *)
  simpl.       (* false = false *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.8. Demostrar que
      forall n:nat, 1 * n = n.
   ------------------------------------------------------------------ *)

Theorem producto_1_n: forall n:nat, 1 * n = n.
Proof.
  intro n.          (* n : nat
                       ============================
                       1 * n = n *)
  simpl.            (* n + 0 = n *)
  rewrite suma_n_0. (* n + 0 = n + 0 *)
  reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.9. Demostrar que
       forall b c : bool, disyuncion (conjuncion b c)
                              (disyuncion (negacion b)
                                          (negacion c))
                          = true.
   ------------------------------------------------------------------ *)

Theorem alternativas: forall b c : bool,
    disyuncion
      (conjuncion b c)
      (disyuncion (negacion b)
                  (negacion c))
    = true.
Proof.
  intros [] [].
  - reflexivity. (* (true && true) || (negacion true || negacion true) = true *)
  - reflexivity. (* (true && false) || (negacion true || negacion false) = true *)
  - reflexivity. (* (false && true) || (negacion false || negacion true) = true *)
  - reflexivity. (* (false && false) || (negacion false || negacion false)=true *)
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.10. Demostrar que
      forall n m p : nat, (n + m) * p = (n * p) + (m * p).
   ------------------------------------------------------------------ *)

Theorem producto_suma_distributiva_d: forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p.              (* n, m, p : nat
                                ============================
                                (n + m) * p = n * p + m * p *)
  induction n as [|n' HIn'].
  -                          (* m, p : nat
                                ============================
                                (0 + m) * p = 0 * p + m * p *)
    reflexivity.
  -                          (* n', m, p : nat
                                HIn' : (n' + m) * p = n' * p + m * p
                                ============================
                                (S n' + m) * p = S n' * p + m * p *)
    simpl.                   (* p + (n' + m) * p = (p + n' * p) + m * p *)
    rewrite HIn'.            (* p + (n' * p + m * p) = (p + n') * p + m * p *)
    rewrite suma_asociativa. (* (p + n' * p) + m * p = (p + n' * p) + m * p *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 4.11. Demostrar que
      forall n m p : nat, n * (m * p) = (n * m) * p.
   ------------------------------------------------------------------ *)

Theorem producto_asociativa: forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros n m p.     (* n, m, p : nat
                       ============================
                       n * (m * p) = (n * m) * p *)
  induction n as [|n' HIn'].
  -                 (* m, p : nat
                       ============================
                       0 * (m * p) = (0 * m) * p *)
    simpl.          (* 0 = 0 *)
    reflexivity.
  -                 (* n', m, p : nat
                       HIn' : n' * (m * p) = (n' * m) * p
                       ============================
                       S n' * (m * p) = (S n' * m) * p *)
    simpl.          (* m * p + n' * (m * p) = (m + n' * m) * p *)
    rewrite HIn'.   (* m * p + (n' * m) * p = (m + n' * m) * p *)
    rewrite producto_suma_distributiva_d.
                    (* m * p + (n' * m) * p = m * p + (n' * m) * p *)
    reflexivity.
Qed.

(* ---------------------------------------------------------------------
   Ejercicio 11. La táctica replace permite especificar el subtérmino
   que se desea reescribir y su sustituto:
      replace t with u
   sustituye todas las copias de la expresión t en el objetivo por la
   expresión u y añade la ecuación (t = u) como un nuevo subojetivo.

   El uso de la táctica replace es especialmente útil cuando la táctica
   rewrite actúa sobre una parte del objetivo que no es la que se desea.

   Demostrar, usando la táctica replace y sin usar
   [assert (n + m = m + n)], que
      forall n m p : nat, n + (m + p) = m + (n + p).
   ------------------------------------------------------------------ *)

Theorem suma_permutada' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.                 (* n, m, p : nat
                                   ============================
                                   n + (m + p) = m + (n + p) *)
  rewrite suma_asociativa.      (* (n + m) + p = m + (n + p) *)
  rewrite suma_asociativa.      (* (n + m) + p = (m + n) + p *)
  replace (n + m) with (m + n).
  -                             (* n, m, p : nat
                                   ============================
                                   (m + n) + p = (m + n) + p *)
    reflexivity.
  -                             (* n, m, p : nat
                                   ============================
                                   m + n = n + m *)
    rewrite suma_conmutativa.   (* n + m = n + m *)
    reflexivity.
Qed.

(* =====================================================================
   § Bibliografía
   ================================================================== *)

(*
 + "Demostraciones por inducción" de Peirce et als. http://bit.ly/2NRSWTF
 *)


Require Import Lib Deci Arith Omega NArith PArith ZArith.

Open Scope list_scope.

(** Correctness proofs for the nat conversions *)

Module NatProofs.

Import DecNat.

Lemma nat2digit2nat n : n < 10 -> digit2nat (nat2digit n) = n.
Proof.
 destruct n as [|[|[|[|[|[|[|[|[|[|]]]]]]]]]]; auto; omega.
Qed.

Lemma digit2nat2digit d : nat2digit (digit2nat d) = d.
Proof.
 now destruct d.
Qed.

(** A naive version of dec2nat, for the proofs *)
Fixpoint of_dec (d:dec) :=
  match d with
  | nil => 0
  | d :: l => of_dec l + digit2nat d * 10^length l
  end.

Lemma d2n_eqn dg d acc :
  d2n (dg::d) acc =
  d2n d (digit2nat dg + 10 * acc).
Proof.
 rewrite <- TailNat.addmul_spec.
 reflexivity.
Qed.

Lemma d2n_add d n p :
 d2n d (n+p) = d2n d n + p * 10^length d.
Proof.
 revert n p.
 induction d.
 - simpl; auto with arith.
 - intros. rewrite !d2n_eqn.
   rewrite Nat.mul_add_distr_l, Nat.add_assoc, IHd.
   f_equal. simpl length.
   rewrite Nat.pow_succ_r', Nat.mul_assoc. f_equal.
   apply Nat.mul_comm.
Qed.

Lemma d2n_alt d acc : d2n d acc = dec2nat d + acc * 10^length d.
Proof.
 apply (d2n_add d 0 acc).
Qed.

Lemma dec2nat_alt d : dec2nat d = of_dec d.
Proof.
 induction d; simpl; auto.
 unfold dec2nat. simpl.
 rewrite <- IHd. unfold dec2nat. now rewrite <- d2n_add.
Qed.

Lemma n2d_eqn n acc count :
  n2d (S n) acc (S count) =
  n2d (S n / 10) (nat2digit (S n mod 10) :: acc) count.
Proof.
 change (n2d (S n) acc (S count)) with
 (let (q,r) := diveucl (S n) 10 in n2d q (nat2digit r :: acc) count).
 now rewrite diveucl_spec.
Qed.

Lemma n2d_eqn' n acc count :
  n2d n acc (S count) =
  if n =? 0 then acc
  else
   n2d (n/10) (nat2digit (n mod 10) :: acc) count.
Proof.
 destruct n. trivial. apply n2d_eqn.
Qed.

Lemma n2d_anycount count count' n acc :
 n <= count -> n <= count' ->
 n2d n acc count = n2d n acc count'.
Proof.
 revert count' n acc.
 induction count; destruct count'; auto.
 - now inversion 1.
 - now inversion 2.
 - intros.
   destruct n; auto.
   rewrite !n2d_eqn.
   destruct (Nat.le_gt_cases 10 (S n)).
   * apply IHcount; apply Nat.div_le_upper_bound; omega.
   * rewrite Nat.div_small; auto. now destruct count, count'.
Qed.

Lemma n2d_mincount count n acc :
 n <= count -> n2d n acc count = n2d n acc n.
Proof.
 intros. now apply n2d_anycount.
Qed.

Lemma n2d_app n d d' count :
 n <= count ->
 n2d n (d++d') count = n2d n d count ++ d'.
Proof.
 revert n d d'.
 induction count.
 - now inversion 1.
 - intros. destruct n.
   + auto.
   + rewrite !n2d_eqn.
     generalize (nat2digit (S n mod 10)); intros dg.
     change (dg :: d ++ d') with ((dg::d)++d').
     destruct (Nat.le_gt_cases 10 (S n)).
     * apply IHcount.
       apply Nat.div_le_upper_bound; omega.
     * rewrite Nat.div_small; simpl; auto.
       destruct count; auto.
Qed.

Lemma n2d_alt n acc count :
 n <= count ->
 n2d n acc count = nat2dec n ++ acc.
Proof.
 intros.
 unfold nat2dec. rewrite (n2d_anycount n count); auto.
 now apply (n2d_app n nil).
Qed.

Lemma of_dec_app d d' :
  of_dec (d ++ d') =
  of_dec d * 10^length d' + of_dec d'.
Proof.
 induction d; simpl; auto.
 rewrite IHd. rewrite List.app_length, Nat.pow_add_r.
 ring.
Qed.

Lemma nat2dec2nat n :
 dec2nat (nat2dec n) = n.
Proof.
 rewrite dec2nat_alt.
 induction n using lt_wf_ind.
 unfold nat2dec.
 destruct n.
 - simpl; auto.
 - rewrite n2d_eqn.
   rewrite n2d_alt by (apply Nat.lt_succ_r, Nat.div_lt; omega).
   rewrite of_dec_app.
   simpl length.
   rewrite H by (apply Nat.div_lt; omega).
   unfold of_dec.
   rewrite nat2digit2nat by (apply Nat.mod_upper_bound; auto).
   simpl length.
   rewrite Nat.pow_1_r, Nat.pow_0_r, Nat.add_0_l, Nat.mul_1_r.
   rewrite Nat.mul_comm. symmetry. now apply Nat.div_mod.
Qed.

Lemma nat2dec_inj n n' : nat2dec n = nat2dec n' -> n = n'.
Proof.
 intro EQ.
 now rewrite <- (nat2dec2nat n), <- (nat2dec2nat n'), EQ.
Qed.

Lemma n2d_spec dg p d count :
 norm (n2d (digit2nat dg + 10*p) d (S count)) =
 norm (n2d p (dg::d) count).
Proof.
 rewrite n2d_eqn'.
 case Nat.eqb_spec; intros.
 - destruct dg; try discriminate. simpl digit2nat in e.
   replace p with 0 by omega.
   now destruct count.
 - f_equal. f_equal.
   + rewrite Nat.mul_comm, Nat.div_add, Nat.div_small; auto.
     destruct dg; simpl; omega.
   + f_equal.
     rewrite Nat.mul_comm, Nat.mod_add, Nat.mod_small; auto.
     apply digit2nat2digit.
     destruct dg; simpl; omega.
Qed.

(*
<n0>|      d      |d0|
<...        n ...>|d0|
*)

Lemma d2n2d count n n0 (d0 d : dec) :
 n <= count ->
 n = d2n d n0 ->
 norm (n2d n d0 count) =
 norm (n2d n0 (d ++ d0) count).
Proof.
 revert count n n0 d0.
 induction d.
 - intros. simpl in *. now subst.
 - intros count n n0 d0 LT EQ.
   assert (LE' : n <= S count) by omega.
   rewrite (n2d_anycount count (S count)) by auto.
   rewrite d2n_eqn in EQ.
   rewrite (IHd _ _ _ d0 LE' EQ).
   now rewrite n2d_spec.
Qed.

Definition Normal d := norm d = d.

Lemma n2d_norm n count acc :
 0<n<=count -> Normal (n2d n acc count).
Proof.
 revert n acc.
 induction count.
 - intros. omega.
 - intros. destruct n. omega.
   rewrite n2d_eqn.
   destruct (Nat.le_gt_cases 10 (S n)).
   + apply IHcount.
     split. apply Nat.div_str_pos. omega.
     apply Nat.div_le_upper_bound; omega.
   + rewrite Nat.div_small by auto.
     rewrite Nat.mod_small by auto.
     rewrite n2d_mincount by omega.
     remember (nat2digit (S n)) as dg.
     simpl. destruct dg; red; auto.
     generalize (nat2digit2nat (S n) H0).
     rewrite <- Heqdg; simpl. discriminate.
Qed.

Lemma nat2dec_norm n : Normal (nat2dec n).
Proof.
 destruct n.
 - red; auto.
 - apply n2d_norm; omega.
Qed.

Lemma dec2nat2dec (d:dec) :
  nat2dec (dec2nat d) = norm d.
Proof.
 rewrite <- (nat2dec_norm (dec2nat d)).
 unfold nat2dec.
 rewrite d2n2d with (n0:=0)(d:=d); auto.
 rewrite List.app_nil_r.
 rewrite n2d_mincount; auto with arith.
Qed.

Lemma dec2nat_norm d d' : norm d = norm d' ->
 dec2nat d = dec2nat d'.
Proof.
 intros EQ. apply nat2dec_inj. now rewrite !dec2nat2dec.
Qed.

Lemma dec2nat_inj d d' :
 dec2nat d = dec2nat d' -> norm d = norm d'.
Proof.
 intros. rewrite <- !dec2nat2dec. now f_equal.
Qed.

Lemma dec2nat_iff d d' : dec2nat d = dec2nat d' <-> norm d = norm d'.
Proof.
 split. apply dec2nat_inj. apply dec2nat_norm.
Qed.

End NatProofs.

(** Correctness proofs for the N conversions *)

Module NProofs.

Import DecN.
Open Scope N.

(** We first state that these N conversions behave like
    the nat conversions *)

Lemma d2n_nat d acc :
 d2n d acc = N.of_nat (DecNat.d2n d (N.to_nat acc)).
Proof.
 revert acc.
 induction d.
 - intros; simpl; now rewrite N2Nat.id.
 - intros. rewrite NatProofs.d2n_eqn.
   replace (DecNat.digit2nat a + 10 * N.to_nat acc)%nat
   with (N.to_nat (digit2n a + 10*acc)).
   rewrite <- IHd; auto.
   rewrite N2Nat.inj_add, N2Nat.inj_mul. f_equal.
   now destruct a.
Qed.

Lemma dec2n_nat d : dec2n d = N.of_nat (DecNat.dec2nat d).
Proof.
 unfold dec2n. now rewrite d2n_nat.
Qed.

(** Complements for N2Nat ... *)

Lemma N2Nat_div n m :
 (N.to_nat (n / m) = N.to_nat n / N.to_nat m)%nat.
Proof.
 case (N.eqb_spec m 0); [ intros -> | intros H ].
 - simpl. destruct n; simpl; auto.
 - apply Nat.div_unique with (N.to_nat (n mod m)).
   + generalize (N.mod_upper_bound n m H).
     unfold N.lt. rewrite N2Nat.inj_compare.
     apply Nat.compare_lt_iff.
   + rewrite <- N2Nat.inj_mul, <- N2Nat.inj_add.
     f_equal. now apply N.div_mod.
Qed.

Lemma N2Nat_mod n m : m<>0 ->
 (N.to_nat (n mod m) = (N.to_nat n) mod (N.to_nat m))%nat.
Proof.
 intros.
 apply Nat.mod_unique with (N.to_nat (n / m)).
 - generalize (N.mod_upper_bound n m H).
   unfold N.lt. rewrite N2Nat.inj_compare.
   apply Nat.compare_lt_iff.
 - rewrite <- N2Nat.inj_mul, <- N2Nat.inj_add.
   f_equal. now apply N.div_mod.
Qed.

Lemma N2Nat_le n m : (N.to_nat n <= N.to_nat m)%nat <-> n<=m.
Proof.
 now rewrite <- Nat.compare_le_iff, <- N2Nat.inj_compare.
Qed.

Lemma N2Nat_lt n m : (N.to_nat n < N.to_nat m)%nat <-> n<m.
Proof.
 now rewrite <- Nat.compare_lt_iff, <- N2Nat.inj_compare.
Qed.

Lemma n2digit_nat n : n < 10 ->
 n2digit n = DecNat.nat2digit (N.to_nat n).
Proof.
 destruct n as [|p]; trivial.
 destruct p as [p|p|]; trivial;
  destruct p as [p|p|]; trivial;
   destruct p as [p|p|]; trivial;
    now destruct p.
Qed.

Lemma n2d_nat n acc count :
 n < Npos count ->
 n2d n acc count = DecNat.n2d (N.to_nat n) acc (Pos.to_nat count).
Proof.
 revert n acc.
 induction count.
 - intros.
   destruct n. auto.
   case_eq (Pos.to_nat (count~1)).
   + generalize (Pos2Nat.is_pos (count~1)); omega.
   + intros c Hc.
     rewrite NatProofs.n2d_eqn'.
     simpl Nat.eqb.
     case Nat.eqb_spec.
     * intros. generalize (Pos2Nat.is_pos p); omega.
     * intros.
       change 10%nat with (N.to_nat 10).
       rewrite <- N2Nat_div, <- N2Nat_mod by discriminate.
       simpl n2d.
       case_eq (N.pos_div_eucl p 10); intros q r Hqr.
       assert (Hq : q = Npos p / 10)
         by (unfold N.div; simpl; now rewrite Hqr).
       assert (Hr : r = Npos p mod 10)
         by (unfold N.modulo; simpl; now rewrite Hqr).
       rewrite <- Hq, <-Hr.
       rewrite IHcount.
       replace (DecNat.nat2digit (N.to_nat r)) with (n2digit r).
       apply NatProofs.n2d_anycount.
       { apply (N2Nat_le q (Npos count)).
         rewrite Hq. apply N.div_le_upper_bound. discriminate.
         zify; omega. }
       { apply Nat.succ_le_mono. rewrite <- Hc.
         rewrite <- N2Nat.inj_succ.
         apply (N2Nat_le (N.succ q) (N.pos (count~1))).
         apply N.le_succ_l.
         rewrite Hq. apply N.div_lt_upper_bound. discriminate.
         zify; omega. }
       { apply n2digit_nat. rewrite Hr. now apply N.mod_lt. }
       { rewrite Hq. apply N.div_lt_upper_bound. discriminate.
         zify; omega. }
 - intros.
   destruct n.
   + simpl. now destruct (Pos.to_nat count~0).
   + case_eq (Pos.to_nat (count~0)).
     * generalize (Pos2Nat.is_pos (count~0)); omega.
     * intros c Hc.
       rewrite NatProofs.n2d_eqn'.
       simpl Nat.eqb.
       case Nat.eqb_spec.
       { intros. generalize (Pos2Nat.is_pos p); omega. }
       { intros.
         change 10%nat with (N.to_nat 10).
         rewrite <- N2Nat_div, <- N2Nat_mod by discriminate.
         simpl n2d.
         case_eq (N.pos_div_eucl p 10); intros q r Hqr.
         assert (Hq : q = Npos p / 10)
           by (unfold N.div; simpl; now rewrite Hqr).
         assert (Hr : r = Npos p mod 10)
           by (unfold N.modulo; simpl; now rewrite Hqr).
         rewrite <- Hq, <-Hr.
         rewrite IHcount.
         replace (DecNat.nat2digit (N.to_nat r)) with (n2digit r).
         apply NatProofs.n2d_anycount.
         { apply (N2Nat_le q (Npos count)).
           rewrite Hq. apply N.div_le_upper_bound. discriminate.
           zify; omega. }
         { apply Nat.succ_le_mono. rewrite <- Hc.
           rewrite <- N2Nat.inj_succ.
           apply (N2Nat_le (N.succ q) (N.pos (count~0))).
           apply N.le_succ_l.
           rewrite Hq. apply N.div_lt_upper_bound. discriminate.
           zify; omega. }
         { apply n2digit_nat. rewrite Hr. now apply N.mod_lt. }
         { rewrite Hq. apply N.div_lt_upper_bound. discriminate.
           zify; omega. }}
 - intros. now replace n with 0 by (zify;omega).
Qed.

Lemma n2dec_nat n : n2dec n = DecNat.nat2dec (N.to_nat n).
Proof.
 unfold n2dec.
 rewrite n2d_nat.
 - apply NatProofs.n2d_anycount; auto.
   destruct n; zify; omega.
 - destruct n; zify; omega.
Qed.

(** We now state direct correctness results over the N conversions *)

Lemma n2dec2n (n:N) : dec2n (n2dec n) = n.
Proof.
 now rewrite n2dec_nat, dec2n_nat, NatProofs.nat2dec2nat, N2Nat.id.
Qed.

Lemma n2dec_inj n n' : n2dec n = n2dec n' -> n = n'.
Proof.
 intro EQ.
 now rewrite <- (n2dec2n n), <- (n2dec2n n'), EQ.
Qed.

Definition Normal d := norm d = d.

Lemma n2dec_norm n : Normal (n2dec n).
Proof.
 rewrite n2dec_nat. apply NatProofs.nat2dec_norm.
Qed.

Lemma dec2n2dec (d:dec) :
  n2dec (dec2n d) = norm d.
Proof.
 now rewrite n2dec_nat, dec2n_nat, Nat2N.id, NatProofs.dec2nat2dec.
Qed.

Lemma dec2n_norm d d' : norm d = norm d' ->
 dec2n d = dec2n d'.
Proof.
 intros EQ. apply n2dec_inj. now rewrite !dec2n2dec.
Qed.

Lemma dec2n_inj d d' :
 dec2n d = dec2n d' -> norm d = norm d'.
Proof.
 intros. rewrite <- !dec2n2dec. now f_equal.
Qed.

Lemma dec2n_iff d d' : dec2n d = dec2n d' <-> norm d = norm d'.
Proof.
 split. apply dec2n_inj. apply dec2n_norm.
Qed.

End NProofs.

(** Correctness proofs for the Positive conversions *)

Module PosProofs.

Import DecPos.

Lemma pos2dec2pos p : dec2pos (pos2dec p) = Some p.
Proof.
 unfold dec2pos, pos2dec.
 now rewrite NProofs.n2dec2n.
Qed.

Lemma dec2pos2dec d p : dec2pos d = Some p -> pos2dec p = norm d.
Proof.
 unfold dec2pos, pos2dec.
 case_eq (DecN.dec2n d); try discriminate.
 intros p' E. injection 1 as ->. rewrite <- E.
 apply NProofs.dec2n2dec.
Qed.

Lemma dec2pos_none d : dec2pos d = None <-> norm d = nil.
Proof.
 rewrite <- NProofs.dec2n2dec. unfold dec2pos.
 split.
 - now case_eq (DecN.dec2n d).
 - change nil with (DecN.n2dec 0).
   intros E. apply NProofs.n2dec_inj in E. now rewrite E.
Qed.

End PosProofs.

Module ZProofs.

Import DecZ.
Open Scope Z.

Lemma z2dec2z z : 0<=z -> dec2z (z2dec z) = z.
Proof.
 unfold dec2z, z2dec.
 destruct z; simpl.
 - trivial.
 - now rewrite NProofs.n2dec2n.
 - now destruct 1.
Qed.

Lemma dec2z2dec d : z2dec (dec2z d) = norm d.
Proof.
 unfold z2dec, dec2z.
 case_eq (DecN.dec2n d).
 - rewrite <- NProofs.dec2n2dec. now intros ->.
 - intros p <-. apply NProofs.dec2n2dec.
Qed.

End ZProofs.

(** Proofs concerning [Deci.succ] *)

Import DecNat NatProofs.

Lemma bounded_succ_length d :
  length (carry_proj (bounded_succ d)) = length d.
Proof.
 induction d; simpl; auto.
 destruct (bounded_succ d); simpl in *; auto.
 destruct a; simpl; congruence.
Qed.

Lemma bounded_succ_spec d :
 match bounded_succ d with
 | Carry d' => S (dec2nat d) = 10^length d /\ dec2nat d' = 0
 | NoCarry d' => S (dec2nat d) < 10^length d /\ dec2nat d' = S (dec2nat d)
 end.
Proof.
 induction d.
 - simpl; auto.
 - simpl bounded_succ.
   assert (L:=bounded_succ_length d).
   destruct bounded_succ; simpl in L.
   + destruct a;
     rewrite !dec2nat_alt in *; simpl of_dec; simpl length;
     rewrite Nat.pow_succ_r', !Nat.add_0_r, <- ?Nat.add_succ_l, ?L;
     destruct IHd as (->,->); split; auto;
     generalize (Nat.pow_nonzero 10 (length d)); omega.
   + rewrite !dec2nat_alt in *; simpl of_dec; simpl length.
     rewrite L.
     destruct IHd as (IH,->). split; auto.
     rewrite Nat.pow_succ_r'.
     rewrite <- Nat.add_succ_l.
     assert (digit2nat a * 10 ^ length d <= 9 * 10 ^ length d).
     { apply Nat.mul_le_mono_nonneg_r; auto with arith.
       destruct a; simpl; auto with arith. }
     omega.
Qed.

Lemma norm_length d : length (norm d) <= length d.
Proof.
 induction d; simpl; auto.
 destruct a; auto.
Qed.

Lemma bounded_succ_norm d :
 match bounded_succ d with
 | Carry d' => Normal d
 | NoCarry d' => Normal d -> Normal d'
 end.
Proof.
 destruct d as [|a d']; simpl; auto. reflexivity.
 destruct (bounded_succ d'); destruct a; unfold Normal; simpl; auto.
 intros.
 generalize (norm_length d'). rewrite H. simpl. omega.
Qed.

Lemma succ_norm d : norm (succ d) = succ (norm d).
Proof.
 induction d as [|a d IH].
 - simpl; auto.
 - unfold succ.
   assert (L := bounded_succ_length (a::d)).
   assert (H := bounded_succ_spec (a::d)).
   assert (N := bounded_succ_norm (a::d)).
   destruct (bounded_succ (a::d)) eqn:E.
   + now rewrite N, E.
   + simpl in E, L.
     unfold succ in IH.
     destruct (bounded_succ d) eqn:E'.
     * destruct a; simpl; try discriminate;
       rewrite ?E'; now injection E as <-.
     * injection E as <-.
       destruct a; simpl; auto; now rewrite E'.
Qed.

Lemma succ_to n : succ (nat2dec n) = nat2dec (S n).
Proof.
 unfold succ.
 assert (L := bounded_succ_length (nat2dec n)).
 assert (H := bounded_succ_spec (nat2dec n)).
 assert (N := bounded_succ_norm (nat2dec n)).
 destruct (bounded_succ (nat2dec n)); simpl in *.
 - destruct H as (H,H').
   rewrite nat2dec2nat in H.
   change (D1 :: l) with (norm (D1 :: l)).
   rewrite <- nat2dec_norm.
   apply dec2nat_inj.
   rewrite nat2dec2nat. rewrite H.
   rewrite dec2nat_alt in *. simpl. rewrite H', L. omega.
 - rewrite nat2dec2nat in H.
   rewrite <- (N (nat2dec_norm n)), <- (nat2dec_norm (S n)).
   apply dec2nat_inj.
   now rewrite nat2dec2nat.
Qed.

Lemma of_succ d : dec2nat (succ d) = S (dec2nat d).
Proof.
 apply nat2dec_inj.
 rewrite <- succ_to.
 rewrite !dec2nat2dec.
 apply succ_norm.
Qed.

Lemma succ_inj d d' :
 succ d = succ d' -> norm d = norm d'.
Proof.
 intros. apply dec2nat_inj.
 assert (E : S (dec2nat d) = S (dec2nat d')).
 { rewrite <- !of_succ. now f_equal. }
 now injection E.
Qed.

(** Proofs concerning [Deci.succ] *)

Lemma to_lt n n' : n < n' -> lt (nat2dec n) (nat2dec n').
Proof.
 induction 1.
 + rewrite <- succ_to. apply Succ.
 + apply Trans with (nat2dec m); trivial.
   rewrite <- succ_to. apply Succ.
Qed.

Lemma of_lt d d' : lt d d' -> dec2nat d < dec2nat d'.
Proof.
 induction 1.
 + rewrite of_succ. auto.
 + omega.
Qed.

Lemma to_lt_iff n n' :  n < n' <-> lt (nat2dec n) (nat2dec n').
Proof.
 split; [apply to_lt|].
 intros H. apply of_lt in H. now rewrite !nat2dec2nat in H.
Qed.

Lemma of_lt_iff d d' :
  dec2nat d < dec2nat d' <-> lt (norm d) (norm d').
Proof.
 rewrite to_lt_iff. now rewrite !dec2nat2dec.
Qed.

Lemma lt_norm d d' : lt d d' -> lt (norm d) (norm d').
Proof.
 rewrite <- of_lt_iff. apply of_lt.
Qed.

Lemma lt_irrefl d d' : lt d d' -> norm d <> norm d'.
Proof.
 intros L E.
 apply of_lt in L.
 apply dec2nat_norm in E.
 omega.
Qed.

Lemma lt_antisym d d' : lt d d' -> ~lt d' d.
Proof.
 intros L L'. apply of_lt in L. apply of_lt in L'. omega.
Qed.

Lemma lt_trans d1 d2 d3 : lt d1 d2 -> lt d2 d3 -> lt d1 d3.
Proof.
 apply Trans.
Qed.

Lemma lt_norm_total d d' :
 { lt (norm d) (norm d') } + { norm d = norm d' } + { lt (norm d') (norm d) }.
Proof.
 destruct (CompareSpec2Type (Nat.compare_spec (dec2nat d) (dec2nat d'))).
 - left; right. now apply dec2nat_inj.
 - left; left. now apply of_lt_iff.
 - right; now apply of_lt_iff.
Qed.