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

Require Import List Arith Omega.

Require Import decidable_t.

Set Implicit Arguments.

(** Thanks to a remark of Yannick Forster at ITP 2017,
    it seems that I rediscovered a result of Coq's
    standard library (Constructive Epsilon), with
    similar proofs (although a bit different in
    presentation).

    I have to add that the ad-hoc inductive predicate
    "before_witness" which is defined in Section

      ConstructiveIndefiniteGroundDescription_Direct

    is in fact a restricted form of Bar inductive predicate
 *)

Section nat_reify.

  (** This is UNBOUNDED minimization when a certificate of termination
     is provided

     But in this simpler case, we do not show that the minimum
     is computed

  *)

  Variable P : nat -> Prop.
  Hypothesis HP : forall n, { P n } + { ~ P n }.

  Let R x y := x = S y /\ ~ P y.

  Let P_Acc_R x : P x -> Acc R x.
  Proof.
    constructor; intros ? (_ & []); auto.
  Qed.

  Let Acc_R_dec x : Acc R (S x) -> Acc R x.
  Proof.
    constructor; intros ? (? & _); subst; auto.
  Qed.

  Let Acc_R_zero x : Acc R x -> Acc R 0.
  Proof.
    induction x; auto.
  Qed.

  Let Acc_exists_eq x : Acc R x <-> exists i, x <= i /\ P i.
  Proof.
    split.

    induction 1 as [ x Hx IHx ].
    destruct (HP x).
    exists x; auto.
    destruct IHx with (S x) as (i & ? & ?);
      [ | exists i ]; split; auto; omega.

    intros (i & H1 & H2).
    apply P_Acc_R in H2.
    revert H2.
    replace i with ((i-x)+x) by omega.
    generalize (i-x); clear i H1.
    intros i; induction i; auto.
  Qed.

  (* @Acc_inv x Hx F is a proof of Acc R (S x) which is
     *structurally simpler* than Hx, the given proof of Acc R x
   *)

  Let Acc_inv x (Hx : Acc R x) (F : ~ P x) : Acc R (S x).
  Proof.
    refine (match Hx with
      | Acc_intro _ H => H _ _  (* H : forall y, R y x -> Acc R y *)
    end).
    split; trivial.
  Qed.

  Let Acc_inv' x (Hx : Acc R x) (F : ~ P x) : Acc R (S x) :=
    let F' := conj eq_refl F     (* F'  : R (S x) x   *)
    in match Hx with
      | Acc_intro _ H => H _ F'  (* H : forall y, R y x -> Acc R y *)
    end.

  (* Hence the following fixpoint type-checks
     with Hx as structurally decreasing argument
   *)

  Fixpoint Acc_P x (Hx : Acc R x) : { m | P m } :=
    match HP x with
      | left  T => exist _ x T
      | right F => @Acc_P (S x) (@Acc_inv x Hx F)
    end.

  Print Acc_P.

  Let Acc_P' := fix Acc_P' x (Hx : Acc R x) : { m | P m } :=
    match HP x with
      | left  T => exist _ x T
      | right F =>
        let Hx' := match Hx with
              Acc_intro _ H => H (S x) (conj eq_refl F)
        end in Acc_P' (S x) Hx'
    end.

  Print Acc_P'.

  Let Acc_P'' : forall x (Hx : Acc R x), { m | P m }.
  Proof.
    refine (fix loop x Hx { struct Hx } := _).
    destruct (@HP x) as [ H | H ].
    exists x; trivial.
    destruct (loop (S x)) as (m & H2).
    destruct Hx as [ Hx ].
    apply Hx; split; trivial.
    exists m; trivial.
  Qed.

  Print Acc_P''.

  Theorem nat_reify : (exists x, P x) -> { x | P x }.
  Proof.
    intros H.
    apply Acc_P with 0.
    destruct H as (x & Hx).
    apply Acc_R_zero with x, P_Acc_R, Hx.
  Qed.

  (* Same as nat_reif but we show that the computed value
     is the minimum *)

  Let Acc_P_min : forall x (Hx : Acc R x), { m | P m /\ forall y, P y -> y < x \/ m <= y }.
  Proof.
    refine (fix Acc_P_min x Hx { struct Hx } :=
      match HP x with
        | left T  => exist _ x _
        | right F => match Acc_P_min (S x) _ with exist _ m H => exist _ m _ end
      end).

    split; trivial.
    intros y _; destruct (le_lt_dec x y); auto.

    destruct Hx as [ Hx ].
    apply Hx; red; auto.

    clear Acc_P_min.  (* we do not want the automatic tactics to use that one *)
    destruct H as [ H1 H2 ].
    split; trivial.
    intros y Hy.
    destruct (eq_nat_dec x y) as [ | ].
    subst; contradict F; trivial.
    specialize (H2 _ Hy); omega.
  Qed.

  Print Acc_P_min.

  Theorem nat_minimizer : (exists x, P x) -> { x | P x /\ forall y, P y -> x <= y }.
  Proof.
    intros H.
    destruct Acc_P_min with 0 as (m & H1 & H2).

    destruct H as (x & Hx).
    apply Acc_R_zero with x, P_Acc_R, Hx.

    exists m; split; auto.
    intros ? Hy; specialize (H2 _ Hy); omega.
  Qed.

End nat_reify.

Section nat_reify_t.

  (* The same but with nat -> Type predicates instead of nat -> Prop *)

  Variable P : nat -> Type.
  Hypothesis HP : forall n, decidable_t (P n).

  Let R x y := x = S y /\ ~ inhabited (P y).

  Let P_Acc_R x : P x -> Acc R x.
  Proof.
    intros H.
    constructor.
    intros ? (_ & []).
    exists; auto.
  Qed.

  Let Acc_R_dec x : Acc R (S x) -> Acc R x.
  Proof.
    constructor; intros ? (? & _); subst; auto.
  Qed.

  Let Acc_R_zero x : Acc R x -> Acc R 0.
  Proof.
    induction x; auto.
  Qed.

  Let Acc_inv x : Acc R x -> (P x -> False) -> Acc R (S x).
  Proof.
    intros [ Hx ] F; apply Hx; split.
    * reflexivity.
    * intros [ t ]; exact (F t).
  Defined.

  Print Acc_inv.

  Let Acc_P := fix Acc_P x (Hx : Acc R x) : sigT P :=
    match HP x with
      | inl T => existT _ x T
      | inr F => @Acc_P (S x) (@Acc_inv x Hx F)
    end.

  Theorem nat_reify_t : (exists x, inhabited (P x)) -> { x : nat & P x }.
  Proof.
    intros H; apply Acc_P with 0.
    destruct H as (x & [ Hx ]).
    apply Acc_R_zero with x, P_Acc_R, Hx.
  Qed.

End nat_reify_t.

Section functional_countable_decidable_choice.

  Variable (X : Type) (R : X -> nat -> Prop) (HR : forall x n, { R x n } + { ~ R x n }).

  Theorem FunctionalCountableDecidableChoice : (forall x, exists n, R x n) -> { f | forall x, R x (f x) }.
  Proof.
    intros H.
    set (f x := @nat_reify (R x) (HR x) (H x)).
    exists (fun x => proj1_sig (f x)).
    intros x.
    apply (proj2_sig (f x)).
  Qed.

End functional_countable_decidable_choice.

Check FunctionalCountableDecidableChoice.

Extraction "minimize.ml" nat_reify nat_minimizer nat_reify_t.


(** 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 (lf3 : natural) (x : natural) : natural := mult x lf3.


(** Numbers represented as lists of digits. *)

Require Import Coq.NArith.NArith.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.

Local Open Scope N.

Inductive digits : Set :=
| Zero
| Digit : digits -> N -> digits
.

Arguments digits : clear implicits.

Section Digits.

Context (base : N).

(** Add two digits and a carry *)
Definition adder (d d0 c : N) : N * N :=
  let s := c + d + d0 in
  if s <? base then (0, s) else (1, s - base).

(* [2 * n + d0] *)
Fixpoint double_plus (c : N) (n : digits) :=
  match n with
  | Zero =>
    if c =? 0 then Zero else Digit Zero c
  | Digit n d =>
    let (c, d) := adder d d c in
    Digit (double_plus c n) d
  end.

Fixpoint digits_of_pos (p : positive) :=
  match p with
  | xH => Digit Zero 1
  | xI p => double_plus 1 (digits_of_pos p)
  | xO p => double_plus 0 (digits_of_pos p)
  end.

Definition digits_of_N (n : N) :=
  match n with
  | N0 => Digit Zero 0
  | Npos p => digits_of_pos p
  end.

End Digits.

Definition binary_ascii (n : N) : ascii :=
  match n with
  | 0 =>  "0"%char
  | _ =>  "1"%char
  end.

Definition octal_ascii (n : N) : ascii :=
  match n with
  | 2 =>  "2"%char
  | 3 =>  "3"%char
  | 4 =>  "4"%char
  | 5 =>  "5"%char
  | 6 =>  "6"%char
  | 7 =>  "7"%char
  | _ => binary_ascii n
  end.

Definition decimal_ascii (n : N) : ascii :=
  match n with
  | 8 =>  "8"%char
  | 9 =>  "9"%char
  | _ => octal_ascii n
  end.

Definition hex_ascii (n : N) : ascii :=
  match n with
  | 10 => "a"%char
  | 11 => "b"%char
  | 12 => "c"%char
  | 13 => "d"%char
  | 14 => "e"%char
  | 15 => "f"%char
  | _  => decimal_ascii n
  end.

Definition hex_ascii_upper (n : N) : ascii :=
  match n with
  | 10 => "A"%char
  | 11 => "B"%char
  | 12 => "C"%char
  | 13 => "D"%char
  | 14 => "E"%char
  | 15 => "F"%char
  | _  => decimal_ascii n
  end.

Local Fixpoint string_of_digits_
    (digit : N -> ascii)
    (s : string)
    (n : digits)
  : string :=
  match n with
  | Zero => s
  | Digit n d => string_of_digits_ digit (String (digit d) s) n
  end.

Definition string_of_digits (digit : N -> ascii) : digits -> string :=
  string_of_digits_ digit "".

Definition string_of_N (base : N) (digit : N -> ascii) (n : N) : string :=
  string_of_digits digit (digits_of_N base n).

Definition binary_string (n : N) :=
  string_of_N 2 binary_ascii n.

Definition hex_string (n : N) :=
  string_of_N 16 hex_ascii n.

Definition hex_string_upper (n : N) :=
  string_of_N 16 hex_ascii_upper n.

Definition octal_string (n : N) :=
  string_of_N 8 octal_ascii n.

Definition decimal_string (n : N) :=
  string_of_N 10 decimal_ascii n.


(*
We present a characterization of the equality in an Indexed W type
as an Indexed W type of the same shape.
(assuming function extensionality)

That is, a path between (sup x children1) and (sup y children2) is
a path p between x and y,
and a path between each pair of children, lying over p.

I am not aware of this result in any of the literature,
but I believe it is an interesting result.
In particular, I was surprised not to find it in the HoTT book.
*)

From IWTypes Require Import IWType.
From IWTypes Require Import FunctionExtensionality.

(* We aren't working with nat, and we want to use the * notation for pairs. *)
Close Scope nat_scope.

Section IWEquality.
Context {FunExt : FunExt}.
Context {S : spec}.

(* Postulate an implementation I of S *)
Context (I : impl S).

(* Define the type of children of a node labeled by x *)
Definition children_for (x : Data S) := forall c, carrier I (child_index x c).

(* We claim that equality in T satisfies the following spec: *)
Definition Seq : spec := {|
  Data := {x : Data S & children_for x * children_for x};
  Children := fun '(existT _ x _) => Children x;
  Index := {i : Index S & carrier I i * carrier I i};
  index := fun '(existT _ x (children1, children2)) =>
    existT _ (index x) (sup I x children1, sup I x children2);
  child_index := fun '(existT _ x (children1, children2)) c =>
    existT _ _ (children1 c, children2 c);
|}.

(* This is the type family we claim satisfies the above spec *)
Definition eq_type : Index Seq -> Type
  := fun '(existT _ i (a, b)) => a = b.
(* Introduction rule, easy by funext *)
Definition eq_sup
  : forall dat : Data Seq, (forall c, eq_type (child_index dat c)) ->
    eq_type (index dat)
  := fun '(existT _ x (children1, children2)) children_eq =>
     f_equal (sup I x) (funext children_eq).

(* Now we prove that we have the induction rule, and that it computes. *)
Section induct.
Context
  (P : forall iab, eq_type iab -> Type)
  (IS : forall dat children_eq, (forall c, P _ (children_eq c)) ->
        P (index dat) (eq_sup dat children_eq)).

(* First we show that P holds for reflexivity *)
Definition eq_induct_refl : forall i a, P (existT _ i (a, a)) eq_refl
  := induct I (fun i a => P (existT _ i (a, a)) eq_refl)
     (fun x children refl_children_P => eq_rect
      (funext (happly eq_refl))
      (fun p' =>
       P (existT _ (index x) (sup I x children, sup I x children))
       (f_equal (sup I x) p'))
      (IS (existT _ x (children, children)) (happly eq_refl)
       refl_children_P)
      eq_refl
      (funext_comp eq_refl)).

(* Then we use path induction to generalize. *)
Definition eq_induct
  : forall iab p, P iab p
  := fun '(existT _ i (a, b)) (p : a = b) => match p in (_ = b)
     return P (existT _ i (a, b)) p with eq_refl => eq_induct_refl i a end.

(* Finally, we show that the induction above computes as expected. *)

(* First eq_induct_refl: *)
Definition eq_induct_refl_computes
  x children1
  : eq_induct_refl (index x) (sup I x children1) =
    eq_rect (funext (fun c => eq_refl)) _
      (IS (existT _ x (children1, children1)) (happly eq_refl)
       (fun c => eq_induct_refl _ (children1 c)))
      eq_refl (funext_comp eq_refl)
  := induct_computes I _ _ _ _.

(* Then in general *)
Definition eq_induct_computes
  : forall dat children_eq,
    eq_induct (index dat) (eq_sup dat children_eq) =
    IS dat children_eq (fun c => eq_induct _ (children_eq c))
  := fun '(existT _ x (children1, children2)) =>
     fun children_eq : forall c, children1 c = children2 c =>
     eq_trans (eq_trans
     (match funext children_eq
      as p' in (_ = children2)
      return
        match f_equal (sup I x) p' as p'' in (_ = b)
        return P (existT _ (index x) (sup I x children1, b)) p''
        with eq_refl => eq_induct_refl (index x) (sup I x children1) end
        =
        eq_rect (funext (happly p'))
        (fun p'' => P (existT _ _ (_, _)) (f_equal (sup I x) p''))
        (IS (existT _ x (children1, children2)) (happly p')
         (fun c => eq_induct (existT _ _ (_, _)) (happly p' c)))
        p' (funext_comp p')
      with eq_refl => eq_induct_refl_computes x children1
      end)
     (f_equal (eq_rect _ _ _ _) (funext_adjoint children_eq)))
     (match funext_app children_eq as children_p in (_ = children_eq')
      return
        eq_rect _ _ _ _ (f_equal funext children_p) =
        IS (existT _ x (children1, children2)) children_eq'
        (fun c => eq_induct (existT _ _ (_, _)) (children_eq' c))
      with eq_refl => eq_refl end).
End induct.

(* Thus the equality is an inductive family: *)
Definition Ieq : impl Seq
  := Build_impl Seq eq_type eq_sup eq_induct eq_induct_computes.

End IWEquality.
Arguments eq_sup {FunExt S I} dat children.


(** 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 (lf2 : natural) (z : natural) (x : natural) (lf1 : natural)
  : natural := mult lf1 (Succ Zero).


(** 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) (z : natural) (x : natural)
  : natural := mult z (Succ x).


Require Import ZArith Znumtheory Lia Zpow_facts MyZ.
Require Import Hurwitz_def.

Section basic_lemmas.

Variable h1 h2 h3 : Hurwitz.

(* eq *)

Lemma Hurwitz_dec : { h1 = h2 } + { h1 <> h2 }.
Proof.
repeat decide equality.
Qed.

(* hopp *)

Lemma hopp_invol : h- (h- h1) = h1.
Proof.
destruct h1 ; simpl ; f_equal ; ring.
Qed.

Lemma hopp_hadd_distrib : h- (h1 h+ h2) = h- h1 h+ h- h2.
Proof.
destruct h1, h2, h3 ; simpl ; f_equal ; ring.
Qed.

Lemma hopp_hadd_hminus : h- h1 h+ h2 = h2 h- h1.
Proof.
destruct h1, h2 ; simpl ; f_equal ; ring.
Qed.

(* hadd *)

Lemma hadd_comm : h1 h+ h2 = h2 h+ h1.
Proof.
destruct h1, h2 ; simpl ; f_equal ; ring.
Qed.

Lemma hadd_assoc : h1 h+ h2 h+ h3 = h1 h+ (h2 h+ h3).
Proof.
destruct h1, h2, h3 ; simpl ; f_equal ; ring.
Qed.

(* hmul *)

Lemma hmul_assoc : forall a b c, hmul a (hmul b c) = hmul (hmul a b) c.
Proof.
intros [] [] []; intros.
 unfold hmul ; f_equal ; ring.
Qed.

Lemma hmul_1_l : hmul (IZH 1) h1 = h1.
Proof.
destruct h1 ; intros.
unfold hmul, IZH.
f_equal; ring.
Qed.

Lemma hmul_1_r : hmul h1 (IZH 1) = h1.
Proof.
destruct h1 ; intros.
unfold hmul, IZH.
f_equal; ring.
Qed.

(* conjugate *)

Lemma hconj_invol : hconj (hconj h1) = h1.
Proof.
destruct h1 ; intros ; unfold hconj ; f_equal ; ring.
Qed.

Lemma hconj_hopp : hconj (h- h1) = h- (hconj h1).
unfold hconj, hopp ; destruct h1 ; intros ; f_equal ; ring.
Qed.

Lemma hconj_hadd : hconj (h1 h+ h2) = hconj h1 h+ hconj h2.
Proof.
unfold hconj, hadd ; destruct h1, h2 ; intros ; f_equal ; ring.
Qed.

Lemma hconj_hminus : hconj (h1 h- h2) = (hconj h1) h- (hconj h2).
Proof.
unfold hminus, hadd, hopp, hconj ; destruct h1, h2 ; intros ; f_equal ; ring.
Qed.

Lemma hconj_hmul : hconj (h1 h* h2) = (hconj h2) h* (hconj h1).
Proof.
unfold hmul, hconj ; destruct h1, h2 ; f_equal ; ring.
Qed.

(* norm *)

Lemma hnorm2_IZH : forall z, hnorm2 (IZH z) = z ^ 2.
Proof.
intro z ; unfold hnorm2, hconj, IZH, hmul, i ; ring.
Qed.

Lemma hnorm2_hconj : hnorm2 (hconj h1) = hnorm2 h1.
Proof.
destruct h1 ; intros ; unfold hnorm2 , hconj , hmul, Hurwitz_def.i ;
 ring.
Qed.

Lemma hnorm2_hmul : hnorm2 (h1 h* h2) = hnorm2 h1 * hnorm2 h2.
Proof.
destruct h1, h2 ; unfold hnorm2, hconj, hmul, Hurwitz_def.i ;
 ring.
Qed.

Lemma real_hnorm2 : is_real (hmul h1 (hconj h1)).
Proof.
destruct h1 ; intros; unfold hmul, hconj.
repeat split;
  cbv delta [Hurwitz_def.h Hurwitz_def.i Hurwitz_def.j Hurwitz_def.k];
  cbv iota beta;
  ring.
Qed.

Lemma Zmult_le_reg_l : forall m n p, 0 < p -> p * m <= p * n -> m <= n.
Proof.
intros m n p p_pos ; do 2 rewrite (Zmult_comm p) ;
 apply Zmult_le_reg_r, Z.lt_gt ; assumption.
Qed.

Lemma hnorm2_pos : 0 <= hnorm2 h1.
Proof.
destruct h1 ; intros ; unfold hnorm2, hmul, hconj.
 cbv delta [Hurwitz_def.i] ; cbv beta iota.
 ring_simplify.
 apply Zmult_le_reg_l with 4 ; [lia |].
 transitivity ((h + 2 * i) ^ 2 + (h + 2 * j) ^ 2 + (h + 2 * k) ^ 2 + h ^ 2).
 do 4 rewrite Zpower_2 ; repeat apply Zplus_le_0_compat ; apply Z.ge_le, sqr_pos.
 apply eq_Zle ; ring.
Qed.

Lemma h_Zle_hnorm2 : (h h1) ^ 2 <= 4 * hnorm2 h1.
Proof.
destruct h1 ; intros ; unfold hnorm2, hmul, hconj.
 cbv delta [Hurwitz_def.h Hurwitz_def.i] ; cbv beta iota.
 apply Zle_0_minus_le ; ring_simplify.
 transitivity ((h + 2 * i) ^ 2 + (h + 2 * j) ^ 2 + (h + 2 * k) ^ 2).
 do 3 rewrite Zpower_2 ; repeat apply Zplus_le_0_compat ; apply Z.ge_le, sqr_pos.
 apply eq_Zle ; ring.
Qed.

End basic_lemmas.

(* units *)

Lemma H_unit_is_unit : forall x, H_unit x -> is_H_unit x.
Proof.
  intros x Ux.
  exists (hconj x).
  destruct Ux as [[]|[]|[]|[]|[] [] [] []]; auto.
Qed.

Lemma is_H_unit_hnorm2_1 : forall x, is_H_unit x -> hnorm2 x = 1.
Proof.
intros x (y, Ixy).
 assert (H : hnorm2 x  * hnorm2 y = 1).
  etransitivity ; [symmetry ; eapply hnorm2_hmul |].
  rewrite Ixy ; apply hnorm2_IZH.
 eapply Zmult_one ; [apply Z.le_ge, hnorm2_pos | eassumption].
Qed.

Lemma H_unit_dec : forall x, H_unit x + (H_unit x -> False).
Proof.
intro h ; pose (np := Z_of_Z_unit Z_one) ; pose (nn := Z_of_Z_unit Z_mone).
 destruct (Hurwitz_dec h (mkHurwitz (2 * np) (- np) (- np) (- np))) as [e | Hnp_1].
  left ; subst ; apply H_unit_1.
 destruct (Hurwitz_dec h (mkHurwitz (2 * nn) (- nn) (- nn) (- nn))) as [e | Hnn_1].
  left ; subst ; apply H_unit_1.
 destruct (Hurwitz_dec h (mkHurwitz 0 np 0 0)) as [e | Hnp_i].
  left ; subst ; apply H_unit_i.
 destruct (Hurwitz_dec h (mkHurwitz 0 nn 0 0)) as [e | Hnn_i].
  left ; subst ; apply H_unit_i.
 destruct (Hurwitz_dec h (mkHurwitz 0 0 np 0)) as [e | Hnp_j].
  left ; subst ; apply H_unit_j.
 destruct (Hurwitz_dec h (mkHurwitz 0 0 nn 0)) as [e | Hnn_j].
  left ; subst ; apply H_unit_j.
 destruct (Hurwitz_dec h (mkHurwitz 0 0 0 np)) as [e | Hnp_k].
  left ; subst ; apply H_unit_k.
 destruct (Hurwitz_dec h (mkHurwitz 0 0 0 nn)) as [e | Hnn_k].
  left ; subst ; apply H_unit_k.
 pose (hpp := halfsub Z_one Z_one) ; pose (hpn := halfsub Z_one Z_mone) ;
 pose (hnp := halfsub Z_mone Z_one) ; pose (hnn := halfsub Z_mone Z_mone).
 destruct (Hurwitz_dec h (mkHurwitz np hpp hpp hpp)) as [e | Hh_0].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz np hpp hpp hnp)) as [e | Hh_1].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz np hpp hnp hpp)) as [e | Hh_2].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz np hpp hnp hnp)) as [e | Hh_3].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz np hnp hpp hpp)) as [e | Hh_4].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz np hnp hpp hnp)) as [e | Hh_5].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz np hnp hnp hpp)) as [e | Hh_6].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz np hnp hnp hnp)) as [e | Hh_7].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hpn hpn hpn)) as [e | Hh_8].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hpn hpn hnn)) as [e | Hh_9].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hpn hnn hpn)) as [e | Hh_A].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hpn hnn hnn)) as [e | Hh_B].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hnn hpn hpn)) as [e | Hh_C].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hnn hpn hnn)) as [e | Hh_D].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hnn hnn hpn)) as [e | Hh_E].
  left ; subst ; apply H_unit_h.
 destruct (Hurwitz_dec h (mkHurwitz nn hnn hnn hnn)) as [e | Hh_F].
  left ; subst ; apply H_unit_h.
 right ; intros Hf ; inversion Hf.
  destruct u ; [apply Hnp_1 | apply Hnn_1] ; auto.
  destruct u ; [apply Hnp_i | apply Hnn_i] ; auto.
  destruct u ; [apply Hnp_j | apply Hnn_j] ; auto.
  destruct u ; [apply Hnp_k | apply Hnn_k] ; auto.
  destruct u ; destruct v ; destruct w ; destruct z ;
  [ apply Hh_0 | apply Hh_1 | apply Hh_2 | apply Hh_3 | apply Hh_4 |
    apply Hh_5 | apply Hh_6 | apply Hh_7 | apply Hh_8 | apply Hh_9 |
    apply Hh_A | apply Hh_B | apply Hh_C | apply Hh_D | apply Hh_E |
    apply Hh_F ] ; auto.
Qed.

Lemma H_unit_characterization : forall x, is_H_unit x -> H_unit x.
Proof.
intros x Hx ; assert (Nx := is_H_unit_hnorm2_1 _ Hx) ; destruct Hx as [y Ixy].
 assert (Ny : hnorm2 y = 1).
  apply Zmult_reg_l with 1 ; [lia |] ; rewrite <- Zpower_2,
   <- hnorm2_IZH, <- Ixy, <- Nx ; symmetry ; apply hnorm2_hmul.

  (* Une fois qu'on a ça, c'est pas si facile. Chez les quaternions
  on peut borner |a+bi+cj+dk|>=|a|+|b|+|c|+|d| mais comme le changement
  est dans une base pas trop orthonormée, c'est moins facile, mais c'est
  possible quand même. *)
  (*intros [[|p|p] [|q|q] [|r|r] [|s|s]] (y, Uxy).*)

  (* idée : on peut énumérer les x, y de norme bornée (par 1), et après
  on peut vérifier que si xy=1 c'est que H_unit x. Peut-être avoir la
  décidabilité de H_unit aidera. *)
Abort.


(* Exercise 68 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.

Theorem exercise_068 : ~ (exists x : D, P x) -> forall x : D, ~ P x.
Proof.
imp_i a1.
all_i a.
neg_e' (exists x:D, P x) a2.
hyp a1.
exi_i a.
neg_e' (~P a) a3.
hyp a2.
hyp a3.
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 (lf1 : natural) (y : natural) (x : natural) (lf2 : natural)
  : natural := Succ (plus Zero y).


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Export ZArith.
Require Export ZCmisc.

Open Local Scope positive_scope.

Open Local Scope P_scope.

(* [div_eucl a b] return [(q,r)] such that a = q*b + r *)
Fixpoint div_eucl (a b : positive) {struct a} : N * N :=
  match a with
  | xH => if 1 ?< b then (0%N, 1%N) else (1%N, 0%N)
  | xO a' =>
    let (q, r) := div_eucl a' b in
    match q, r with
    | N0, N0 => (0%N, 0%N) (* n'arrive jamais *)
    | N0, Npos r =>
      if (xO r) ?< b then (0%N, Npos (xO r))
      else (1%N,PminusN (xO r) b)
    | Npos q, N0 => (Npos (xO q), 0%N)
    | Npos q, Npos r =>
      if (xO r) ?< b then (Npos (xO q), Npos (xO r))
      else (Npos (xI q),PminusN (xO r) b)
    end
  | xI a' =>
    let (q, r) := div_eucl a' b in
    match q, r with
    | N0, N0 => (0%N, 0%N)                 (* Impossible *)
    | N0, Npos r =>
      if (xI r) ?< b then (0%N, Npos (xI r))
      else (1%N,PminusN (xI r) b)
    | Npos q, N0 => if 1 ?< b then (Npos (xO q), 1%N) else (Npos (xI q), 0%N)
    | Npos q, Npos r =>
      if (xI r) ?< b then (Npos (xO q), Npos (xI r))
      else (Npos (xI q),PminusN (xI r) b)
    end
  end.
Infix "/" := div_eucl : P_scope.

Open Scope Z_scope.
Opaque Zmult.
Lemma div_eucl_spec : forall a b,
          Zpos a = fst (a/b)%P * b + snd (a/b)%P
       /\ snd (a/b)%P < b.
Proof with zsimpl;try apply Zlt_0_pos;try ((ring;fail) || omega).
 intros a b;generalize a;clear a;induction a;simpl;zsimpl.
 case IHa; destruct (a/b)%P as [q r].
   case q; case r; simpl fst; simpl snd.
     rewrite Zmult_0_l; rewrite Zplus_0_r; intros HH; discriminate HH.
  intros p H; rewrite H;
  match goal with
  | [|- context [ ?xx ?< b ]] =>
    generalize (is_lt_spec xx b);destruct (xx ?< b)
  | _ => idtac
  end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
  intros p H; rewrite H;
  match goal with
  | [|- context [ ?xx ?< b ]] =>
    generalize (is_lt_spec xx b);destruct (xx ?< b)
  | _ => idtac
  end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto; try ring.
  ring_simplify.
  case (Zle_lt_or_eq _ _ H1); auto with zarith.
  intros p p1 H; rewrite H.
  match goal with
  | [|- context [ ?xx ?< b ]] =>
    generalize (is_lt_spec xx b);destruct (xx ?< b)
  | _ => idtac
  end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto; try ring.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
 case IHa; destruct (a/b)%P as [q r].
   case q; case r; simpl fst; simpl snd.
     rewrite Zmult_0_l; rewrite Zplus_0_r; intros HH; discriminate HH.
  intros p H; rewrite H;
  match goal with
  | [|- context [ ?xx ?< b ]] =>
    generalize (is_lt_spec xx b);destruct (xx ?< b)
  | _ => idtac
  end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
  intros p H; rewrite H; simpl; intros H1; split; auto.
  zsimpl; ring.
  intros p p1 H; rewrite H.
  match goal with
  | [|- context [ ?xx ?< b ]] =>
    generalize (is_lt_spec xx b);destruct (xx ?< b)
  | _ => idtac
  end; zsimpl; simpl; intros H1 H2; split; zsimpl; auto; try ring.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
  rewrite PminusN_le...
  generalize H1; zsimpl; auto.
  match goal with
  | [|- context [ ?xx ?< b ]] =>
    generalize (is_lt_spec xx b);destruct (xx ?< b)
  | _ => idtac
  end; zsimpl; simpl.
  split; auto.
  case (Zle_lt_or_eq 1 b); auto with zarith.
  generalize (Zlt_0_pos b); auto with zarith.
Qed.
Transparent Zmult.

(******** Definition du modulo ************)

(* [mod a b] return [a] modulo [b] *)
Fixpoint Pmod (a b : positive) {struct a} : N :=
  match a with
  | xH => if 1 ?< b then 1%N else 0%N
  | xO a' =>
    let r := Pmod a' b in
    match r with
    | N0 => 0%N
    | Npos r' =>
      if (xO r') ?< b then Npos (xO r')
      else PminusN (xO r') b
    end
  | xI a' =>
    let r := Pmod a' b in
    match r with
    | N0 => if 1 ?< b then 1%N else 0%N
    | Npos r' =>
      if (xI r') ?< b then Npos (xI r')
      else PminusN (xI r') b
    end
  end.

Infix "mod" := Pmod (at level 40, no associativity) : P_scope.
Open Local Scope P_scope.

Lemma Pmod_div_eucl : forall a b, a mod b = snd (a/b).
Proof with auto.
 intros a b;generalize a;clear a;induction a;simpl;
 try (rewrite IHa;
  assert (H1 := div_eucl_spec a b); destruct (a/b) as [q r];
  destruct q as [|q];destruct r as [|r];simpl in *;
  match goal with
   | [|- context [ ?xx ?< b ]] =>
      assert (H2 := is_lt_spec xx b);destruct (xx ?< b)
  | _ => idtac
  end;simpl) ...
 destruct H1 as [H3 H4];discriminate H3.
 destruct (1 ?< b);simpl ...
Qed.

Lemma mod1: forall a, a mod 1 = 0%N.
Proof. induction a;simpl;try rewrite IHa;trivial. Qed.

Lemma mod_a_a_0 : forall a, a mod a = N0.
Proof.
 intros a;generalize (div_eucl_spec a a);rewrite <- Pmod_div_eucl.
 destruct (fst (a / a));unfold Z_of_N at 1.
 rewrite Zmult_0_l;intros (H1,H2);elimtype False;omega.
 assert (a<=p*a).
  pattern (Zpos a) at 1;rewrite <- (Zmult_1_l a).
  assert (H1:= Zlt_0_pos p);assert (H2:= Zle_0_pos a);
   apply Zmult_le_compat;trivial;try omega.
 destruct (a mod a)%P;auto with zarith.
 unfold Z_of_N;assert (H1:= Zlt_0_pos p0);intros (H2,H3);elimtype False;omega.
Qed.

Lemma mod_le_2r : forall (a b r: positive) (q:N),
                    Zpos a = b*q + r -> b <= a -> r < b -> 2*r <= a.
Proof.
 intros a b r q H0 H1 H2.
 assert (H3:=Zlt_0_pos a). assert (H4:=Zlt_0_pos b). assert (H5:=Zlt_0_pos r).
 destruct q as [|q].  rewrite Zmult_0_r in H0. elimtype False;omega.
 assert (H6:=Zlt_0_pos q).  unfold Z_of_N in H0.
 assert (Zpos r = a - b*q). omega.
 simpl;zsimpl. pattern r at 2;rewrite H.
 assert (b <= b * q).
  pattern (Zpos b) at 1;rewrite <- (Zmult_1_r b).
  apply Zmult_le_compat;try omega.
 apply Zle_trans with (a - b * q + b). omega.
 apply Zle_trans with (a - b + b);omega.
Qed.

Lemma mod_lt : forall a b r, a mod b = Npos r -> r < b.
Proof.
 intros a b r H;generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl;
  rewrite H;simpl;intros (H1,H2);omega.
Qed.

Lemma mod_le : forall a b r, a mod b = Npos r -> r <= b.
Proof. intros a b r H;assert (H1:= mod_lt _ _ _ H);omega. Qed.

Lemma mod_le_a : forall a b r, a mod b = r -> r <= a.
Proof.
 intros a b r H;generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl;
  rewrite H;simpl;intros (H1,H2).
 assert (0 <= fst (a / b) * b).
  destruct (fst (a / b));simpl;auto with zarith.
 auto with zarith.
Qed.

Lemma lt_mod : forall a b, Zpos a < Zpos b -> (a mod b)%P = Npos a.
Proof.
  intros a b H; rewrite Pmod_div_eucl. case (div_eucl_spec a b).
  assert (0 <= snd(a/b)). destruct (snd(a/b));simpl;auto with zarith.
  destruct (fst (a/b)).
  unfold Z_of_N at 1;rewrite Zmult_0_l;rewrite Zplus_0_l.
  destruct (snd (a/b));simpl; intros H1 H2;inversion H1;trivial.
  unfold Z_of_N at 1;assert (b <= p*b).
  pattern (Zpos b) at 1; rewrite <- (Zmult_1_l (Zpos b)).
   assert (H1 := Zlt_0_pos p);apply Zmult_le_compat;try omega.
  apply Zle_0_pos.
  intros;elimtype False;omega.
Qed.

Fixpoint gcd_log2 (a b c:positive) {struct c}: option positive :=
 match a mod b with
 | N0  => Some b
 | Npos r =>
   match b mod r, c with
   | N0, _ => Some r
   | Npos r', xH    => None
   | Npos r', xO c' => gcd_log2 r r' c'
   | Npos r', xI c' => gcd_log2 r r' c'
   end
 end.

Fixpoint egcd_log2 (a b c:positive) {struct c}:
    option (Z * Z * positive) :=
 match a/b with
 |    (_, N0)  => Some (0, 1, b)
 | (q, Npos r) =>
   match b/r, c with
   | (_, N0), _ => Some (1, -q, r)
   | (q', Npos r'), xH    => None
   | (q', Npos r'), xO c' =>
        match egcd_log2 r r' c' with
          None => None
        | Some (u', v', w') =>
               let u := u' - v' * q' in
               Some (u, v' - q * u, w')
        end
   | (q', Npos r'), xI c' =>
        match egcd_log2 r r' c' with
          None => None
        | Some (u', v', w') =>
               let u := u' - v' * q' in
               Some (u, v' - q * u, w')
        end
   end
 end.

Lemma egcd_gcd_log2: forall c a b,
  match egcd_log2 a b c, gcd_log2 a b c with
    None, None => True
  | Some (u,v,r), Some r' => r = r'
  | _, _ => False
  end.
induction c; simpl; auto; try
 (intros a b; generalize (Pmod_div_eucl a b); case (a/b); simpl;
  intros q r1 H; subst; case (a mod b); auto;
  intros r; generalize (Pmod_div_eucl b r); case (b/r); simpl;
  intros q' r1 H; subst; case (b mod r); auto;
  intros r'; generalize (IHc r r'); case egcd_log2; auto;
  intros ((p1,p2),p3); case gcd_log2; auto).
Qed.

Ltac rw l :=
  match l with
   | (?r, ?r1) =>
       match type of r with
         True => rewrite <- r1
      |  _ => rw r; rw r1
      end
  | ?r => rewrite r
  end.

Lemma egcd_log2_ok: forall c a b,
  match egcd_log2 a b c with
    None => True
  | Some (u,v,r) => u * a + v * b = r
  end.
induction c; simpl; auto;
 intros a b; generalize (div_eucl_spec a b); case (a/b);
  simpl fst; simpl snd; intros q r1; case r1; try (intros; ring);
  simpl; intros r (Hr1, Hr2); clear r1;
  generalize (div_eucl_spec b r); case (b/r);
  simpl fst; simpl snd; intros q' r1; case r1;
    try (intros; rewrite Hr1; ring);
  simpl; intros r' (Hr'1, Hr'2); clear r1; auto;
  generalize (IHc r r'); case egcd_log2; auto;
  intros ((u',v'),w'); case gcd_log2; auto; intros;
  rw ((I, H), Hr1, Hr'1); ring.
Qed.

Fixpoint log2 (a:positive) : positive :=
 match a with
 | xH => xH
 | xO a => Psucc (log2 a)
 | xI a => Psucc (log2 a)
 end.

Lemma gcd_log2_1: forall a c, gcd_log2  a xH c = Some xH.
Proof. destruct c;simpl;try rewrite mod1;trivial. Qed.

Lemma log2_Zle :forall a b, Zpos a <= Zpos b -> log2 a <= log2 b.
Proof with zsimpl;try omega.
 induction a;destruct b;zsimpl;intros;simpl ...
 assert (log2 a <= log2 b) ...  apply IHa ...
 assert (log2 a <= log2 b) ...  apply IHa ...
 assert (H1 := Zlt_0_pos a);elimtype False;omega.
 assert (log2 a <= log2 b) ...  apply IHa ...
 assert (log2 a <= log2 b) ...  apply IHa ...
 assert (H1 := Zlt_0_pos a);elimtype False;omega.
 assert (H1 := Zlt_0_pos (log2 b)) ...
 assert (H1 := Zlt_0_pos (log2 b)) ...
Qed.

Lemma log2_1_inv : forall a, Zpos (log2 a) = 1 -> a = xH.
Proof.
 destruct a;simpl;zsimpl;intros;trivial.
 assert (H1:= Zlt_0_pos (log2 a));elimtype False;omega.
 assert (H1:= Zlt_0_pos (log2 a));elimtype False;omega.
Qed.

Lemma mod_log2 :
  forall a b r:positive, a mod b = Npos r -> b <= a -> log2 r + 1 <= log2 a.
Proof.
 intros; cut (log2 (xO r) <= log2 a). simpl;zsimpl;trivial.
 apply log2_Zle.
 replace (Zpos (xO r)) with (2 * r)%Z;trivial.
 generalize (div_eucl_spec a b);rewrite <- Pmod_div_eucl;rewrite H.
 rewrite Zmult_comm;intros [H1 H2];apply mod_le_2r with b (fst (a/b));trivial.
Qed.

Lemma gcd_log2_None_aux :
  forall c a b, Zpos b <= Zpos a -> log2 b <= log2 c ->
   gcd_log2 a b c <> None.
Proof.
 induction c;simpl;intros;
 (CaseEq (a mod b);[intros Heq|intros r Heq];try (intro;discriminate));
 (CaseEq (b mod r);[intros Heq'|intros r' Heq'];try (intro;discriminate)).
 apply IHc. apply mod_le with b;trivial.
 generalize H0 (mod_log2 _ _ _ Heq' (mod_le _ _ _ Heq));zsimpl;intros;omega.
 apply IHc. apply mod_le with b;trivial.
 generalize H0 (mod_log2 _ _ _ Heq' (mod_le _ _ _ Heq));zsimpl;intros;omega.
 assert (Zpos (log2 b) = 1).
  assert (H1 := Zlt_0_pos (log2 b));omega.
 rewrite (log2_1_inv _ H1) in Heq;rewrite mod1 in Heq;discriminate Heq.
Qed.

Lemma gcd_log2_None : forall a b, Zpos b <= Zpos a -> gcd_log2 a b b <> None.
Proof. intros;apply gcd_log2_None_aux;auto with zarith. Qed.

Lemma gcd_log2_Zle :
   forall c1 c2 a b, log2 c1 <= log2 c2 ->
      gcd_log2 a b c1 <> None -> gcd_log2 a b c2 = gcd_log2 a b c1.
Proof with zsimpl;trivial;try omega.
 induction c1;destruct c2;simpl;intros;
   (destruct (a mod b) as [|r];[idtac | destruct (b mod r)]) ...
 apply IHc1;trivial. generalize H;zsimpl;intros;omega.
 apply IHc1;trivial. generalize H;zsimpl;intros;omega.
 elim H;destruct (log2 c1);trivial.
 apply IHc1;trivial. generalize H;zsimpl;intros;omega.
 apply IHc1;trivial. generalize H;zsimpl;intros;omega.
 elim H;destruct (log2 c1);trivial.
 elim H0;trivial. elim H0;trivial.
Qed.

Lemma gcd_log2_Zle_log :
   forall a b c, log2 b <= log2 c -> Zpos b <= Zpos a ->
      gcd_log2 a b c = gcd_log2 a b b.
Proof.
 intros a b c H1 H2; apply gcd_log2_Zle; trivial.
 apply gcd_log2_None; trivial.
Qed.

Lemma gcd_log2_mod0 :
  forall a b c, a mod b = N0 -> gcd_log2 a b c = Some b.
Proof. intros a b c H;destruct c;simpl;rewrite H;trivial. Qed.

Require Import Zwf.

Lemma Zwf_pos : well_founded (fun x y => Zpos x < Zpos y).
Proof.
 unfold well_founded.
 assert (forall x a ,x = Zpos a -> Acc (fun x y : positive => x < y) a).
 intros x;assert (Hacc := Zwf_well_founded 0 x);induction Hacc;intros;subst x.
 constructor;intros. apply H0 with (Zpos y);trivial.
 split;auto with zarith.
 intros a;apply H with (Zpos a);trivial.
Qed.

Opaque Pmod.
Lemma gcd_log2_mod : forall a b, Zpos b <= Zpos a ->
  forall r, a mod b = Npos r -> gcd_log2 a b b = gcd_log2 b r r.
Proof.
 intros a b;generalize a;clear a; assert (Hacc := Zwf_pos b).
 induction Hacc; intros a Hle r Hmod.
 rename x into b. destruct b;simpl;rewrite Hmod.
 CaseEq (xI b mod r)%P;intros. rewrite gcd_log2_mod0;trivial.
 assert (H2 := mod_le _ _ _ H1);assert (H3 := mod_lt _ _ _ Hmod);
  assert (H4 := mod_le _ _ _ Hmod).
 rewrite (gcd_log2_Zle_log r p b);trivial.
 symmetry;apply H0;trivial.
 generalize (mod_log2 _ _ _ H1 H4);simpl;zsimpl;intros;omega.
 CaseEq (xO b mod r)%P;intros. rewrite gcd_log2_mod0;trivial.
 assert (H2 := mod_le _ _ _ H1);assert (H3 := mod_lt _ _ _ Hmod);
  assert (H4 := mod_le _ _ _ Hmod).
 rewrite (gcd_log2_Zle_log r p b);trivial.
 symmetry;apply H0;trivial.
 generalize (mod_log2 _ _ _ H1 H4);simpl;zsimpl;intros;omega.
 rewrite mod1 in Hmod;discriminate Hmod.
Qed.

Lemma gcd_log2_xO_Zle :
 forall a b, Zpos b <= Zpos a -> gcd_log2 a b (xO b) = gcd_log2 a b b.
Proof.
 intros a b Hle;apply gcd_log2_Zle.
 simpl;zsimpl;auto with zarith.
 apply gcd_log2_None_aux;auto with zarith.
Qed.

Lemma gcd_log2_xO_Zlt :
 forall a b, Zpos a < Zpos b -> gcd_log2 a b (xO b) = gcd_log2 b a a.
Proof.
 intros a b H;simpl. assert (Hlt := Zlt_0_pos a).
 assert (H0 := lt_mod _ _ H).
 rewrite H0;simpl.
 CaseEq (b mod a)%P;intros;simpl.
 symmetry;apply gcd_log2_mod0;trivial.
 assert (H2 := mod_lt _ _ _ H1).
 rewrite (gcd_log2_Zle_log a p b);auto with zarith.
 symmetry;apply gcd_log2_mod;auto with zarith.
 apply log2_Zle.
 replace (Zpos p) with (Z_of_N (Npos p));trivial.
 apply mod_le_a with a;trivial.
Qed.

Lemma gcd_log2_x0 : forall a b, gcd_log2 a b (xO b) <> None.
Proof.
 intros;simpl;CaseEq (a mod b)%P;intros. intro;discriminate.
 CaseEq (b mod p)%P;intros. intro;discriminate.
 assert (H1 := mod_le_a _ _ _ H0). unfold Z_of_N in H1.
 assert (H2 := mod_le _ _ _ H0).
 apply gcd_log2_None_aux. trivial.
 apply log2_Zle. trivial.
Qed.

Lemma egcd_log2_x0 : forall a b, egcd_log2 a b (xO b) <> None.
Proof.
intros a b H; generalize (egcd_gcd_log2 (xO b) a b) (gcd_log2_x0 a b);
  rw H; case gcd_log2; auto.
Qed.

Definition gcd a b :=
  match gcd_log2 a b (xO b) with
  | Some p => p
  | None => (* can not appear *) 1%positive
  end.

Definition egcd a b :=
  match egcd_log2 a b (xO b) with
  | Some p => p
  | None => (* can not appear *) (1,1,1%positive)
  end.

Lemma gcd_mod0 : forall a b, (a mod b)%P = N0 -> gcd a b = b.
Proof.
 intros a b H;unfold gcd.
 pattern (gcd_log2 a b (xO b)) at 1;
  rewrite (gcd_log2_mod0 _ _ (xO b) H);trivial.
Qed.

Lemma gcd1 : forall a, gcd a xH = xH.
Proof. intros a;rewrite gcd_mod0;[trivial|apply mod1]. Qed.

Lemma gcd_mod : forall a b r, (a mod b)%P = Npos r ->
                     gcd a b = gcd b r.
Proof.
 intros a b r H;unfold gcd.
 assert (log2 r <= log2 (xO r)). simpl;zsimpl;omega.
 assert (H1 := mod_lt _ _ _ H).
 pattern (gcd_log2 b r (xO r)) at 1; rewrite gcd_log2_Zle_log;auto with zarith.
 destruct (Z_lt_le_dec a b) as [z|z].
 pattern (gcd_log2 a b (xO b)) at 1; rewrite gcd_log2_xO_Zlt;trivial.
 rewrite (lt_mod _ _ z) in H;inversion H.
 assert  (r <= b). omega.
 generalize (gcd_log2_None _ _ H2).
 destruct (gcd_log2 b r r);intros;trivial.
 assert (log2 b <= log2 (xO b)). simpl;zsimpl;omega.
 pattern (gcd_log2 a b (xO b)) at 1; rewrite gcd_log2_Zle_log;auto with zarith.
 pattern (gcd_log2 a b b) at 1;rewrite (gcd_log2_mod _ _ z _ H).
 assert  (r <= b). omega.
 generalize (gcd_log2_None _ _ H3).
 destruct (gcd_log2 b r r);intros;trivial.
Qed.

Require Import ZArith.
Require Import Znumtheory.

Hint Rewrite  Zpos_mult times_Zmult square_Zmult Psucc_Zplus: zmisc.

Ltac mauto :=
  trivial;autorewrite with zmisc;trivial;auto with zarith.

Lemma gcd_Zis_gcd : forall a b:positive, (Zis_gcd b a (gcd b a)%P).
Proof with mauto.
 intros a;assert (Hacc := Zwf_pos a);induction Hacc;rename x into a;intros.
 generalize (div_eucl_spec b a)...
 rewrite <- (Pmod_div_eucl b a).
 CaseEq (b mod a)%P;[intros Heq|intros r Heq]; intros (H1,H2).
 simpl in H1;rewrite Zplus_0_r in H1.
 rewrite (gcd_mod0 _ _ Heq).
 constructor;mauto.
 apply Zdivide_intro with (fst (b/a)%P);trivial.
 rewrite (gcd_mod _ _ _ Heq).
 rewrite H1;apply Zis_gcd_sym.
 rewrite Zmult_comm;apply Zis_gcd_for_euclid2;simpl in *.
 apply Zis_gcd_sym;auto.
Qed.

Lemma egcd_Zis_gcd : forall a b:positive,
   let (uv,w) := egcd a b in
   let  (u,v) := uv in
     u * a + v * b = w /\ (Zis_gcd b a w).
Proof with mauto.
 intros a b; unfold egcd.
 generalize (egcd_log2_ok (xO b) a b) (egcd_gcd_log2 (xO b) a b)
            (egcd_log2_x0 a b) (gcd_Zis_gcd b a); unfold egcd, gcd.
 case egcd_log2; try (intros ((u,v),w)); case gcd_log2;
 try (intros; match goal with H: False |- _ => case H end);
 try (intros _ _ H1; case H1; auto; fail).
 intros; subst; split; try apply Zis_gcd_sym; auto.
Qed.

Definition Zgcd a b :=
  match a, b with
  | Z0, _ => b
  | _, Z0 => a
  | Zpos a, Zneg b => Zpos (gcd a b)
  | Zneg a, Zpos b => Zpos (gcd a b)
  | Zpos a, Zpos b => Zpos (gcd a b)
  | Zneg a, Zneg b => Zpos (gcd a b)
  end.

Lemma Zgcd_is_gcd : forall x y, Zis_gcd x y (Zgcd x y).
Proof.
 destruct x;destruct y;simpl.
 apply Zis_gcd_0.
 apply Zis_gcd_sym;apply Zis_gcd_0.
 apply Zis_gcd_sym;apply Zis_gcd_0.
 apply Zis_gcd_0.
 apply gcd_Zis_gcd.
 apply Zis_gcd_sym;apply Zis_gcd_minus;simpl;apply gcd_Zis_gcd.
 apply Zis_gcd_0.
 apply Zis_gcd_minus;simpl;apply Zis_gcd_sym;apply gcd_Zis_gcd.
 apply Zis_gcd_minus;apply Zis_gcd_minus;simpl;apply gcd_Zis_gcd.
Qed.

Definition Zegcd a b :=
  match a, b with
  | Z0, Z0 => (0,0,0)
  | Zpos _, Z0 => (1,0,a)
  | Zneg _, Z0 => (-1,0,-a)
  | Z0, Zpos _ => (0,1,b)
  | Z0, Zneg _ => (0,-1,-b)
  | Zpos a, Zneg b =>
     match egcd a b with (u,v,w) => (u,-v, Zpos w) end
  | Zneg a, Zpos b =>
     match egcd a b with (u,v,w) => (-u,v, Zpos w) end
  | Zpos a, Zpos b =>
     match egcd a b with (u,v,w) => (u,v, Zpos w) end
  | Zneg a, Zneg b =>
     match egcd a b with (u,v,w) => (-u,-v, Zpos w) end
  end.

Lemma Zegcd_is_egcd : forall x y,
  match Zegcd x y with
   (u,v,w) => u * x + v * y = w /\ Zis_gcd x y w /\ 0 <= w
  end.
Proof.
 assert (zx0: forall x, Zneg x = -x).
    simpl; auto.
 assert (zx1: forall x, -(-x) = x).
   intro x; case x; simpl; auto.
 destruct x;destruct y;simpl; try (split; [idtac|split]);
  auto; try (red; simpl; intros; discriminate);
 try (rewrite zx0; apply Zis_gcd_minus; try rewrite zx1; auto;
       apply Zis_gcd_minus; try rewrite zx1; simpl; auto);
 try apply Zis_gcd_0; try (apply Zis_gcd_sym;apply Zis_gcd_0);
 generalize (egcd_Zis_gcd p p0); case egcd; intros (u,v) w (H1, H2);
 split; repeat rewrite zx0; try (rewrite <- H1; ring); auto;
 (split; [idtac | red; intros; discriminate]).
 apply Zis_gcd_sym; auto.
 apply Zis_gcd_sym; apply Zis_gcd_minus; rw zx1;
    apply Zis_gcd_sym; auto.
 apply Zis_gcd_minus; rw zx1; auto.
 apply Zis_gcd_minus; rw zx1; auto.
 apply Zis_gcd_minus; rw zx1; auto.
 apply Zis_gcd_sym; auto.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 2: Basic Program Syntax
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.
(* This [Import] command is for including a library of code, theorems, tactics, etc.
 * Here we just include the standard library of the book.
 * We won't distinguish carefully between built-in Coq features and those provided by that library. *)

(* As a first example, let's look at the syntax of simple arithmetic expressions.
 * We use the Coq feature of modules, which let us group related definitions together.
 * A key benefit is that names can be reused across modules,
 * which is helpful to define several variants of a suite of functionality,
 * within a single source file. *)
Module ArithWithConstants.

  (* The following definition closely mirrors a standard BNF grammar for expressions.
   * It defines abstract syntax trees of arithmetic expressions. *)
  Inductive arith : Set :=
  | Const (n : nat)
  | Plus (e1 e2 : arith)
  | Times (e1 e2 : arith).

  (* Here are a few examples of specific expressions. *)
  Example ex1 := Const 42.
  Example ex2 := Plus (Const 1) (Times (Const 2) (Const 3)).

  (* How many nodes appear in the tree for an expression?
   * Unlike in many programming languages, in Coq,
   * recursive functions must be marked as recursive explicitly.
   * That marking comes with the [Fixpoint] command, as opposed to [Definition].
   * Note also that Coq checks termination of each recursive definition.
   * Intuitively, recursive calls must be on subterms of the original argument. *)
  Fixpoint size (e : arith) : nat :=
    match e with
    | Const _ => 1
    | Plus e1 e2 => 1 + size e1 + size e2
    | Times e1 e2 => 1 + size e1 + size e2
    end.

  (* Here's how to run a program (evaluate a term) in Coq. *)
  Compute size ex1.
  Compute size ex2.

  (* What's the longest path from the root of a syntax tree to a leaf? *)
  Fixpoint depth (e : arith) : nat :=
    match e with
    | Const _ => 1
    | Plus e1 e2 => 1 + max (depth e1) (depth e2)
    | Times e1 e2 => 1 + max (depth e1) (depth e2)
    end.

  Compute depth ex1.
  Compute depth ex2.

  (* Our first proof!
   * Size is an upper bound on depth. *)
  Theorem depth_le_size : forall e, depth e <= size e.
  Proof.
    (* Within a proof, we apply commands called *tactics*.
     * Here's our first one.
     * Throughout the book's Coq code, we give a brief note documenting each tactic,
     * after its first use.
     * Keep in mind that the best way to understand what's going on
     * is to run the proof script for yourself, inspecting intermediate states! *)
    induct e.
    (* [induct x]: where [x] is a variable in the theorem statement,
     *   structure the proof by induction on the structure of [x].
     *   You will get one generated subgoal per constructor in the
     *   inductive definition of [x].  (Indeed, it is required that
     *   [x]'s type was introduced with [Inductive].) *)

    simplify.
    (* [simplify]: simplify throughout the goal, applying the definitions of
     *   recursive functions directly.  That is, when a subterm
     *   matches one of the [match] cases in a defining [Fixpoint],
     *   replace with the body of that case, then repeat. *)
    linear_arithmetic.
    (* [linear_arithmetic]: a complete decision procedure for linear arithmetic.
     *   Relevant formulas are essentially those built up from
     *   variables and constant natural numbers and integers
     *   using only addition, with equality and inequality
     *   comparisons on top.  (Multiplication by constants
     *   is supported, as a shorthand for repeated addition.) *)

    simplify.
    linear_arithmetic.

    simplify.
    linear_arithmetic.
  Qed.

  Theorem depth_le_size_snazzy : forall e, depth e <= size e.
  Proof.
    induct e; simplify; linear_arithmetic.
    (* Oo, look at that!  Chaining tactics with semicolon, as in [t1; t2],
     * asks to run [t1] on the goal, then run [t2] on *every*
     * generated subgoal.  This is an essential ingredient for automation. *)
  Qed.

  (* A silly recursive function: swap the operand orders of all binary operators. *)
  Fixpoint commuter (e : arith) : arith :=
    match e with
    | Const _ => e
    | Plus e1 e2 => Plus (commuter e2) (commuter e1)
    | Times e1 e2 => Times (commuter e2) (commuter e1)
    end.

  Compute commuter ex1.
  Compute commuter ex2.

  (* [commuter] has all the appropriate interactions with other functions (and itself). *)

  Theorem size_commuter : forall e, size (commuter e) = size e.
  Proof.
    induct e; simplify; linear_arithmetic.
  Qed.

  Theorem depth_commuter : forall e, depth (commuter e) = depth e.
  Proof.
    induct e; simplify; linear_arithmetic.
  Qed.

  Theorem commuter_inverse : forall e, commuter (commuter e) = e.
  Proof.
    induct e; simplify; equality.
    (* [equality]: a complete decision procedure for the theory of equality
     *   and uninterpreted functions.  That is, the goal must follow
     *   from only reflexivity, symmetry, transitivity, and congruence
     *   of equality, including that functions really do behave as functions. *)
  Qed.

End ArithWithConstants.

(* Let's shake things up a bit by adding variables to expressions.
 * Note that all of the automated proof scripts from before will keep working
 * with no changes!  That sort of "free" proof evolution is invaluable for
 * theorems about real-world compilers, say. *)
Module ArithWithVariables.

  Inductive arith : Set :=
  | Const (n : nat)
  | Var (x : var) (* <-- this is the new constructor! *)
  | Plus (e1 e2 : arith)
  | Times (e1 e2 : arith).

  Example ex1 := Const 42.
  Example ex2 := Plus (Const 1) (Times (Var "x") (Const 3)).

  Fixpoint size (e : arith) : nat :=
    match e with
    | Const _ => 1
    | Var _ => 1
    | Plus e1 e2 => 1 + size e1 + size e2
    | Times e1 e2 => 1 + size e1 + size e2
    end.

  Compute size ex1.
  Compute size ex2.

  Fixpoint depth (e : arith) : nat :=
    match e with
    | Const _ => 1
    | Var _ => 1
    | Plus e1 e2 => 1 + max (depth e1) (depth e2)
    | Times e1 e2 => 1 + max (depth e1) (depth e2)
    end.

  Compute depth ex1.
  Compute depth ex2.

  Theorem depth_le_size : forall e, depth e <= size e.
  Proof.
    induct e; simplify; linear_arithmetic.
  Qed.

  Fixpoint commuter (e : arith) : arith :=
    match e with
    | Const _ => e
    | Var _ => e
    | Plus e1 e2 => Plus (commuter e2) (commuter e1)
    | Times e1 e2 => Times (commuter e2) (commuter e1)
    end.

  Compute commuter ex1.
  Compute commuter ex2.

  Theorem size_commuter : forall e, size (commuter e) = size e.
  Proof.
    induct e; simplify; linear_arithmetic.
  Qed.

  Theorem depth_commuter : forall e, depth (commuter e) = depth e.
  Proof.
    induct e; simplify; linear_arithmetic.
  Qed.

  Theorem commuter_inverse : forall e, commuter (commuter e) = e.
  Proof.
    induct e; simplify; equality.
  Qed.

  (* Now that we have variables, we can consider new operations,
   * like substituting an expression for a variable.
   * We use an infix operator [==v] for equality tests on strings.
   * It has a somewhat funny and very expressive type,
   * whose details we will try to gloss over.
   * (We later return to them in SubsetTypes.v.) *)
  Fixpoint substitute (inThis : arith) (replaceThis : var) (withThis : arith) : arith :=
    match inThis with
    | Const _ => inThis
    | Var x => if x ==v replaceThis then withThis else inThis
    | Plus e1 e2 => Plus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
    | Times e1 e2 => Times (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
    end.

  (* An intuitive property about how much [substitute] might increase depth. *)
  Theorem substitute_depth : forall replaceThis withThis inThis,
    depth (substitute inThis replaceThis withThis) <= depth inThis + depth withThis.
  Proof.
    induct inThis.

    simplify.
    linear_arithmetic.

    simplify.
    cases (x ==v replaceThis).
    (* [cases e]: break the proof into one case for each constructor that might have
     *   been used to build the value of expression [e].  In the special case where
     *   [e] essentially has a Boolean type, we consider whether [e] is true or false. *)
    linear_arithmetic.
    simplify.
    linear_arithmetic.

    simplify.
    linear_arithmetic.

    simplify.
    linear_arithmetic.
  Qed.

  (* Let's get fancier about automation, using [match goal] to pattern-match the goal
   * and decide what to do next!
   * The [|-] syntax separates hypotheses and conclusion in a goal.
   * The [context] syntax is for matching against *any subterm* of a term.
   * The construct [try] is also useful, for attempting a tactic and rolling back
   * the effect if any error is encountered. *)
  Theorem substitute_depth_snazzy : forall replaceThis withThis inThis,
    depth (substitute inThis replaceThis withThis) <= depth inThis + depth withThis.
  Proof.
    induct inThis; simplify;
    try match goal with
        | [ |- context[if ?a ==v ?b then _ else _] ] => cases (a ==v b); simplify
        end; linear_arithmetic.
  Qed.

  (* A silly self-substitution has no effect. *)
  Theorem substitute_self : forall replaceThis inThis,
    substitute inThis replaceThis (Var replaceThis) = inThis.
  Proof.
    induct inThis; simplify;
    try match goal with
        | [ |- context[if ?a ==v ?b then _ else _] ] => cases (a ==v b); simplify
        end; equality.
  Qed.

  (* We can do substitution and commuting in either order. *)
  Theorem substitute_commuter : forall replaceThis withThis inThis,
    commuter (substitute inThis replaceThis withThis)
    = substitute (commuter inThis) replaceThis (commuter withThis).
  Proof.
    induct inThis; simplify;
    try match goal with
        | [ |- context[if ?a ==v ?b then _ else _] ] => cases (a ==v b); simplify
        end; equality.
  Qed.

  (* *Constant folding* is one of the classic compiler optimizations.
   * We repeatedly find opportunities to replace fancier expressions
   * with known constant values. *)
  Fixpoint constantFold (e : arith) : arith :=
    match e with
    | Const _ => e
    | Var _ => e
    | Plus e1 e2 =>
      let e1' := constantFold e1 in
      let e2' := constantFold e2 in
      match e1', e2' with
      | Const n1, Const n2 => Const (n1 + n2)
      | Const 0, _ => e2'
      | _, Const 0 => e1'
      | _, _ => Plus e1' e2'
      end
    | Times e1 e2 =>
      let e1' := constantFold e1 in
      let e2' := constantFold e2 in
      match e1', e2' with
      | Const n1, Const n2 => Const (n1 * n2)
      | Const 1, _ => e2'
      | _, Const 1 => e1'
      | Const 0, _ => Const 0
      | _, Const 0 => Const 0
      | _, _ => Times e1' e2'
      end
    end.

  (* This is supposed to be an *optimization*, so it had better not *increase*
   * the size of an expression!
   * There are enough cases to consider here that we skip straight to
   * the automation.
   * A new scripting construct is [match] patterns with dummy bodies.
   * Such a pattern matches *any* [match] in a goal, over any type! *)
  Theorem size_constantFold : forall e, size (constantFold e) <= size e.
  Proof.
    induct e; simplify;
    repeat match goal with
           | [ |- context[match ?E with _ => _ end] ] => cases E; simplify
           end; linear_arithmetic.
  Qed.

  (* Business as usual, with another commuting law *)
  Theorem commuter_constantFold : forall e, commuter (constantFold e) = constantFold (commuter e).
  Proof.
    induct e; simplify;
    repeat match goal with
           | [ |- context[match ?E with _ => _ end] ] => cases E; simplify
           | [ H : ?f _ = ?f _ |- _ ] => invert H
           | [ |- ?f _ = ?f _ ] => f_equal
           end; equality || linear_arithmetic || ring.
    (* [f_equal]: when the goal is an equality between two applications of
     *   the same function, switch to proving that the function arguments are
     *   pairwise equal.
     * [invert H]: replace hypothesis [H] with other facts that can be deduced
     *   from the structure of [H]'s statement.  This is admittedly a fuzzy
     *   description for now; we'll learn much more about the logic shortly!
     *   Here, what matters is that, when the hypothesis is an equality between
     *   two applications of a constructor of an inductive type, we learn that
     *   the arguments to the constructor must be pairwise equal.
     * [ring]: prove goals that are equalities over some registered ring or
     *   semiring, in the sense of algebra, where the goal follows solely from
     *   the axioms of that algebraic structure. *)
  Qed.

  (* To define a further transformation, we first write a roundabout way of
   * testing whether an expression is a constant.
   * This detour happens to be useful to avoid overhead in concert with
   * pattern matching, since Coq internally elaborates wildcard [_] patterns
   * into separate cases for all constructors not considered beforehand.
   * That expansion can create serious code blow-ups, leading to serious
   * proof blow-ups! *)
  Definition isConst (e : arith) : option nat :=
    match e with
    | Const n => Some n
    | _ => None
    end.

  (* Our next target is a function that finds multiplications by constants
   * and pushes the multiplications to the leaves of syntax trees,
   * ideally finding constants, which can be replaced by larger constants,
   * not affecting the meanings of expressions.
   * This helper function takes a coefficient [multiplyBy] that should be
   * applied to an expression. *)
  Fixpoint pushMultiplicationInside' (multiplyBy : nat) (e : arith) : arith :=
    match e with
    | Const n => Const (multiplyBy * n)
    | Var _ => Times (Const multiplyBy) e
    | Plus e1 e2 => Plus (pushMultiplicationInside' multiplyBy e1)
                         (pushMultiplicationInside' multiplyBy e2)
    | Times e1 e2 =>
      match isConst e1 with
      | Some k => pushMultiplicationInside' (k * multiplyBy) e2
      | None => Times (pushMultiplicationInside' multiplyBy e1) e2
      end
    end.

  (* The overall transformation just fixes the initial coefficient as [1]. *)
  Definition pushMultiplicationInside (e : arith) : arith :=
    pushMultiplicationInside' 1 e.

  (* Let's prove this boring arithmetic property, so that we may use it below. *)
  Lemma n_times_0 : forall n, n * 0 = 0.
  Proof.
    linear_arithmetic.
  Qed.

  (* A fun fact about pushing multiplication inside:
   * the coefficient has no effect on depth!
   * Let's start by showing any coefficient is equivalent to coefficient 0. *)
  Lemma depth_pushMultiplicationInside'_irrelevance0 : forall e multiplyBy,
    depth (pushMultiplicationInside' multiplyBy e)
    = depth (pushMultiplicationInside' 0 e).
  Proof.
    induct e; simplify.

    linear_arithmetic.

    linear_arithmetic.

    rewrite IHe1.
    (* [rewrite H]: where [H] is a hypothesis or previously proved theorem,
     *  establishing [forall x1 .. xN, e1 = e2], find a subterm of the goal
     *  that equals [e1], given the right choices of [xi] values, and replace
     *  that subterm with [e2]. *)
    rewrite IHe2.
    linear_arithmetic.

    cases (isConst e1); simplify.

    rewrite IHe2.
    rewrite n_times_0.
    linear_arithmetic.

    rewrite IHe1.
    linear_arithmetic.
  Qed.

  (* It can be remarkably hard to get Coq's automation to be dumb enough to
   * help us demonstrate all of the primitive tactics. ;-)
   * In particular, we can redo the proof in an automated way, without the
   * explicit rewrites. *)
  Lemma depth_pushMultiplicationInside'_irrelevance0_snazzy : forall e multiplyBy,
    depth (pushMultiplicationInside' multiplyBy e)
    = depth (pushMultiplicationInside' 0 e).
  Proof.
    induct e; simplify;
    try match goal with
        | [ |- context[match ?E with _ => _ end] ] => cases E; simplify
        end; equality.
  Qed.

  (* Now the general corollary about irrelevance of coefficients for depth. *)
  Lemma depth_pushMultiplicationInside'_irrelevance : forall e multiplyBy1 multiplyBy2,
    depth (pushMultiplicationInside' multiplyBy1 e)
    = depth (pushMultiplicationInside' multiplyBy2 e).
  Proof.
    simplify.
    transitivity (depth (pushMultiplicationInside' 0 e)).
    (* [transitivity X]: when proving [Y = Z], switch to proving [Y = X]
     * and [X = Z]. *)
    apply depth_pushMultiplicationInside'_irrelevance0.
    (* [apply H]: for [H] a hypothesis or previously proved theorem,
     *   establishing some fact that matches the structure of the current
     *   conclusion, switch to proving [H]'s own hypotheses.
     *   This is *backwards reasoning* via a known fact. *)
    symmetry.
    (* [symmetry]: when proving [X = Y], switch to proving [Y = X]. *)
    apply depth_pushMultiplicationInside'_irrelevance0.
  Qed.

  (* Let's prove that pushing-inside has only a small effect on depth,
   * considering for now only coefficient 0. *)
  Lemma depth_pushMultiplicationInside' : forall e,
    depth (pushMultiplicationInside' 0 e) <= S (depth e).
  Proof.
    induct e; simplify.

    linear_arithmetic.

    linear_arithmetic.

    linear_arithmetic.

    cases (isConst e1); simplify.

    rewrite n_times_0.
    linear_arithmetic.

    linear_arithmetic.
  Qed.

  Local Hint Rewrite n_times_0.
  (* Registering rewrite hints will get [simplify] to apply them for us
   * automatically! *)

  Lemma depth_pushMultiplicationInside'_snazzy : forall e,
    depth (pushMultiplicationInside' 0 e) <= S (depth e).
  Proof.
    induct e; simplify;
    try match goal with
        | [ |- context[match ?E with _ => _ end] ] => cases E; simplify
        end; linear_arithmetic.
  Qed.

  Theorem depth_pushMultiplicationInside : forall e,
    depth (pushMultiplicationInside e) <= S (depth e).
  Proof.
    simplify.
    unfold pushMultiplicationInside.
    (* [unfold X]: replace [X] by its definition. *)
    rewrite depth_pushMultiplicationInside'_irrelevance0.
    apply depth_pushMultiplicationInside'.
  Qed.

End ArithWithVariables.


(** * A correção do algoritmo de ordenação por inserção *)

(** O objetivo deste arquivo é servir de apoio ao desenvolvimento do projeto deste semestre. Aqui apresentaremos todo o processo de formalização do algoritmo de ordenação por inserção, e este processo deve servir como modelo para o desenvolvimento do seu projeto. *)

(* begin hide *)
Require Import Arith List.
(* end hide *)

(** Inicialmente apresentamos a definição do predicado [sorted] que é o mesmo apresentado no projeto, e por isto não nos preocuparemos em explicar aqui esta definição. *)

Inductive sorted :list nat -> Prop :=
  | nil_sorted : sorted nil
  | one_sorted: forall n:nat, sorted (n :: nil)
  | all_sorted : forall (x y: nat) (l:list nat), sorted (y :: l) -> x <= y -> sorted (x :: y :: l).

(** O algoritmo de ordenação por inserção é baseado em na função auxiliar [insert] que definimos a seguir. A função [insert] recebe um natural [x] e uma lista [l] como argumentos, e é definida recursivamente na estrutura de [l]: *)

Fixpoint insert (x:nat) (l: list nat) := match l with
                      | nil => x :: nil
                      | h :: tl => if x <=? h then (x :: l)
                                                  else (h :: (insert x tl))
                      end.

(** Como podemos observar, quando a lista [l] é a lista vazia, a função retorna a lista unitária contendo o elemento que foi inserido. Quando [l] não é a lista vazia, então ela tem a forma [h::tl], isto é, [l] tem [h] como primeiro elemento, e [tl] como cauda. Para saber onde inserir um elemento [x], comparamos [x] com [h], e quando [x] é menor ou igual a [h] simplesmente inserimos [x] na primeira posição da lista. Caso contrário, a função vai recursivamente encontrar a posição correta para inserir [x]. Assim, temos que a função [insert] é construída de forma a preservar a ordenação da lista recebida como segundo argumento. Este é exatamente o conteúdo do lema a seguir: *)

Lemma insert_preserves_sorting: forall l x, sorted l -> sorted (insert x l).
Proof.
  induction l.
  - intros x H.
    simpl.
    apply one_sorted.
  - intros x H.
    simpl.
    destruct (x <=? a) eqn:Hleq.
    + apply leb_complete in Hleq.
      apply all_sorted; assumption.
    + generalize dependent l.
      intro l. case l.
      * intros H1 H2.
        simpl.
        apply all_sorted.
        ** apply one_sorted.
        ** apply Nat.leb_gt in Hleq.
           apply Nat.lt_le_incl; assumption.
      * intros n l' H1 H2.
        simpl.
        destruct (x <=? n) eqn:Hleq'.
        ** apply all_sorted.
           *** apply all_sorted.
               **** inversion H2; subst.
                    assumption.
               **** apply leb_complete in Hleq'.
                    assumption.
           *** apply Nat.leb_gt in Hleq.
           apply Nat.lt_le_incl; assumption.
        ** apply all_sorted.
           *** inversion H2; subst.
               apply (H1 x) in H3.
               simpl in H3.
               rewrite Hleq' in H3.
               assumption.
           *** inversion H2; subst.
               assumption.
Qed.

(** A seguir apresentaremos uma prova alternativa para o lema acima: *)

Definition le_all x l := forall y, In y l -> x <= y.
Infix "<=*" := le_all (at level 70, no associativity).

Lemma le_all_nil: forall a, a <=* nil.
Proof.
  intro a; unfold le_all.
  intros y H.
  inversion H.
Qed.

Lemma sublist_sorted: forall l a, sorted (a :: l) -> sorted l.
Proof.
  intro l.
  case l.
  - intros a H.
    apply nil_sorted.
  - intros n l' a H.
    inversion H; subst.
    assumption.
Qed.

Lemma le_all_sorted: forall l a, a <=* l -> sorted l -> sorted (a :: l).
Proof.
(* Replace this line by your proof. *) Admitted.

Lemma sorted_le_all: forall l a, sorted(a :: l) -> a <=* l.
Proof.
(* Replace this line by your proof. *) Admitted.

Lemma le_all_cons_part1: forall l a x, a <= x -> a <=* l -> a <=* x :: l.
Proof.
  induction l.
  - admit.
  - Admitted.

Lemma le_all_cons_part2: forall l a x, a <=* x :: l -> a <= x /\ a <=* l.
Proof.
  induction l.
  - admit.
  - Admitted.

Lemma le_all_insert: forall l a x, a <= x -> a <=* l -> a <=* insert x l.
Proof.
  induction l.
  - intros a x Hleq Hle_all.
    simpl.
    apply le_all_cons_part1; assumption.
  - intros a' x Hleq Hle_all.
    simpl.
    destruct (x <=? a) eqn: H.
    + apply le_all_cons_part1; assumption.
    + apply le_all_cons_part2  in Hle_all.
      destruct Hle_all as [H1 H2].
      apply le_all_cons_part1.
      * assumption.
      * apply IHl; assumption.
Qed.

Lemma insert_preserves_sorting': forall l x, sorted l -> sorted (insert x l).
Proof.
  induction l.
  - intros x H.
    simpl.
    apply one_sorted.
  - intros x H.
    simpl.
    destruct (x <=? a) eqn:Hleq.
    + apply leb_complete in Hleq.
      apply all_sorted; assumption.
    + apply le_all_sorted.
      * apply le_all_insert.
        ** apply leb_complete_conv in Hleq.
           apply Nat.lt_le_incl; assumption.
        ** apply sorted_le_all; assumption.
      * apply IHl.
        apply sublist_sorted with a; assumption.
Qed.

(** A função principal do algoritmo é dada a seguir: *)

Fixpoint insertion_sort l := match l with
                             | nil =>l
                             | h :: tl => insert h (insertion_sort tl)
                             end.

(** A função [insertion_sort] é  definida recursivamente na estrutura da lista [l] que é dada como argumento. Quando a lista é vazia não há nada a fazer, e caso contrário, a função [insert] é chamada para inserir a cabeça [h] da lista na cauda [tl] onde a função é aplicada recursivamente. O lema a seguir pede para você provar que a função [insertion_sort] retorna uma lista ordenada. *)

Lemma insertion_sort_sorts: forall l, sorted (insertion_sort l).
Proof.
  induction l.
  - simpl.
    apply nil_sorted.
  - simpl insertion_sort.
    apply insert_preserves_sorting.
    apply IHl.
Qed.

(** A seguir apresentamos a definição de permutação a partir da contagem do número de ocorrências dos elementos nas listas, assim como apresentada no projeto mergesort deste semestre, e os lemas a seguir nos permitem concluir que o algoritmo [insertion_sort] é correto. *)

Fixpoint num_oc n l  :=
  match l with
    | nil => 0
    | h :: tl =>
      if n =? h then S(num_oc n tl) else  num_oc n tl
  end.

Definition perm l l' := forall n:nat, num_oc n l = num_oc n l'.

Lemma perm_refl: forall l, perm l l.
Proof.
intro l. unfold perm. intro. reflexivity.
Qed.

Lemma num_oc_insert_neq: forall l n a, n =? a = false -> num_oc n (insert a l) = num_oc n l.
Proof.
Admitted.

Lemma num_oc_insert: forall l n, num_oc n (insert n l) = S (num_oc n l).
Proof.
Admitted.

Lemma ord_insercao_perm: forall l, perm l (insertion_sort l).
Proof.
Admitted.

Theorem correcao_ord_insercao: forall l, sorted (insertion_sort l) /\ perm l (insertion_sort l).
Proof.
Admitted.

(** Extração de código certificado *)

Require Extraction.

Recursive Extraction insertion_sort.
Extraction "insertion_sort.ml" insertion_sort.