(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * QMake : a generic efficient implementation of rational numbers *)

(** Initial authors : Benjamin Gregoire, Laurent Thery, INRIA, 2007 *)

Require Import BigNumPrelude ROmega.
Require Import QArith Qcanon Qpower Qminmax.
Require Import NSig ZSig QSig.

(** We will build rationals out of an implementation of integers [ZType]
    for numerators and an implementation of natural numbers [NType] for
    denominators. But first we will need some glue between [NType] and
    [ZType]. *)

Module Type NType_ZType (N:NType)(Z:ZType).
 Parameter Z_of_N : N.t -> Z.t.
 Parameter spec_Z_of_N : forall n, Z.to_Z (Z_of_N n) = N.to_Z n.
 Parameter Zabs_N : Z.t -> N.t.
 Parameter spec_Zabs_N : forall z, N.to_Z (Zabs_N z) = Zabs (Z.to_Z z).
End NType_ZType.

Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType.

 (** The notation of a rational number is either an integer x,
     interpreted as itself or a pair (x,y) of an integer x and a natural
     number y interpreted as x/y. The pairs (x,0) and (0,y) are all
     interpreted as 0. *)

 Inductive t_ :=
  | Qz : Z.t -> t_
  | Qq : Z.t -> N.t -> t_.

 Definition t := t_.

 Bind Scope abstract_scope with t t_.

 (** Specification with respect to [QArith] *)

 Local Open Scope Q_scope.

 Definition of_Z x: t := Qz (Z.of_Z x).

 Definition of_Q (q:Q) : t :=
  let (x,y) := q in
  match y with
    | 1%positive => Qz (Z.of_Z x)
    | _ => Qq (Z.of_Z x) (N.of_N (Npos y))
  end.

 Definition to_Q (q: t) :=
 match q with
   | Qz x => Z.to_Z x # 1
   | Qq x y => if N.eq_bool y N.zero then 0
               else Z.to_Z x # Z2P (N.to_Z y)
 end.

 Notation "[ x ]" := (to_Q x).

 Lemma N_to_Z_pos :
  forall x, (N.to_Z x <> N.to_Z N.zero)%Z -> (0 < N.to_Z x)%Z.
 Proof.
 intros x; rewrite N.spec_0; generalize (N.spec_pos x). romega.
 Qed.
(*
 Lemma if_fun_commut : forall A B (f:A->B)(b:bool) a a',
 f (if b then a else a') = if b then f a else f a'.
 Proof. now destruct b. Qed.

 Lemma if_fun_commut' : forall A B C D (f:A->B)(b:{C}+{D}) a a',
 f (if b then a else a') = if b then f a else f a'.
 Proof. now destruct b. Qed.
*)
 Ltac destr_eqb :=
  match goal with
   | |- context [Z.eq_bool ?x ?y] =>
     rewrite (Z.spec_eq_bool x y);
     generalize (Zeq_bool_if (Z.to_Z x) (Z.to_Z y));
     case (Zeq_bool (Z.to_Z x) (Z.to_Z y));
     destr_eqb
   | |- context [N.eq_bool ?x ?y] =>
     rewrite (N.spec_eq_bool x y);
     generalize (Zeq_bool_if (N.to_Z x) (N.to_Z y));
     case (Zeq_bool (N.to_Z x) (N.to_Z y));
     [ | let H:=fresh "H" in
         try (intro H;generalize (N_to_Z_pos _ H); clear H)];
     destr_eqb
   | _ => idtac
  end.

 Hint Rewrite
  Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l
  Z.spec_0 N.spec_0 Z.spec_1 N.spec_1 Z.spec_m1 Z.spec_opp
  Z.spec_compare N.spec_compare
  Z.spec_add N.spec_add Z.spec_mul N.spec_mul Z.spec_div N.spec_div
  Z.spec_gcd N.spec_gcd Zgcd_Zabs Zgcd_1
  spec_Z_of_N spec_Zabs_N
 : nz.
 Ltac nzsimpl := autorewrite with nz in *.

 Ltac qsimpl := try red; unfold to_Q; simpl; intros;
  destr_eqb; simpl; nzsimpl; intros;
  rewrite ?Z2P_correct by auto;
  auto.

 Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q.
 Proof.
 intros(x,y); destruct y; simpl; rewrite ?Z.spec_of_Z; auto;
  destr_eqb; now rewrite ?N.spec_0, ?N.spec_of_N.
 Qed.

 Theorem spec_of_Q: forall q: Q, [of_Q q] == q.
 Proof.
 intros; rewrite strong_spec_of_Q; red; auto.
 Qed.

 Definition eq x y := [x] == [y].

 Definition zero: t := Qz Z.zero.
 Definition one: t := Qz Z.one.
 Definition minus_one: t := Qz Z.minus_one.

 Lemma spec_0: [zero] == 0.
 Proof.
 simpl. nzsimpl. reflexivity.
 Qed.

 Lemma spec_1: [one] == 1.
 Proof.
 simpl. nzsimpl. reflexivity.
 Qed.

 Lemma spec_m1: [minus_one] == -(1).
 Proof.
 simpl. nzsimpl. reflexivity.
 Qed.

 Definition compare (x y: t) :=
  match x, y with
  | Qz zx, Qz zy => Z.compare zx zy
  | Qz zx, Qq ny dy =>
    if N.eq_bool dy N.zero then Z.compare zx Z.zero
    else Z.compare (Z.mul zx (Z_of_N dy)) ny
  | Qq nx dx, Qz zy =>
    if N.eq_bool dx N.zero then Z.compare Z.zero zy
    else Z.compare nx (Z.mul zy (Z_of_N dx))
  | Qq nx dx, Qq ny dy =>
    match N.eq_bool dx N.zero, N.eq_bool dy N.zero with
    | true, true => Eq
    | true, false => Z.compare Z.zero ny
    | false, true => Z.compare nx Z.zero
    | false, false => Z.compare (Z.mul nx (Z_of_N dy))
                                (Z.mul ny (Z_of_N dx))
    end
  end.

 Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]).
 Proof.
 intros [z1 | x1 y1] [z2 | x2 y2];
   unfold Qcompare, compare; qsimpl.
 Qed.

 Definition lt n m := [n] < [m].
 Definition le n m := [n] <= [m].

 Definition min n m := match compare n m with Gt => m | _ => n end.
 Definition max n m := match compare n m with Lt => m | _ => n end.

 Lemma spec_min : forall n m, [min n m] == Qmin [n] [m].
 Proof.
 unfold min, Qmin, GenericMinMax.gmin. intros.
 rewrite spec_compare; destruct Qcompare; auto with qarith.
 Qed.

 Lemma spec_max : forall n m, [max n m] == Qmax [n] [m].
 Proof.
 unfold max, Qmax, GenericMinMax.gmax. intros.
 rewrite spec_compare; destruct Qcompare; auto with qarith.
 Qed.

 Definition eq_bool n m :=
  match compare n m with Eq => true | _ => false end.

 Theorem spec_eq_bool: forall x y, eq_bool x y = Qeq_bool [x] [y].
 Proof.
 intros. unfold eq_bool. rewrite spec_compare. reflexivity.
 Qed.

 (** [check_int] : is a reduced fraction [n/d] in fact a integer ? *)

 Definition check_int n d :=
  match N.compare N.one d with
  | Lt => Qq n d
  | Eq => Qz n
  | Gt => zero  (* n/0 encodes 0 *)
  end.

 Theorem strong_spec_check_int : forall n d, [check_int n d] = [Qq n d].
 Proof.
 intros; unfold check_int.
 nzsimpl.
 destr_zcompare.
 simpl. rewrite <- H; qsimpl. congruence.
 reflexivity.
 qsimpl. exfalso; romega.
 Qed.

 (** Normalisation function *)

 Definition norm n d : t :=
  let gcd := N.gcd (Zabs_N n) d in
  match N.compare N.one gcd with
  | Lt => check_int (Z.div n (Z_of_N gcd)) (N.div d gcd)
  | Eq => check_int n d
  | Gt => zero (* gcd = 0 => both numbers are 0 *)
  end.

 Theorem spec_norm: forall n q, [norm n q] == [Qq n q].
 Proof.
 intros p q; unfold norm.
 assert (Hp := N.spec_pos (Zabs_N p)).
 assert (Hq := N.spec_pos q).
 nzsimpl.
 destr_zcompare.
 (* Eq *)
 rewrite strong_spec_check_int; reflexivity.
 (* Lt *)
 rewrite strong_spec_check_int.
 qsimpl.
 generalize (Zgcd_div_pos (Z.to_Z p) (N.to_Z q)). romega.
 replace (N.to_Z q) with 0%Z in * by assumption.
 rewrite Zdiv_0_l in *; auto with zarith.
 apply Zgcd_div_swap0; romega.
 (* Gt *)
 qsimpl.
 assert (H' : Zgcd (Z.to_Z p) (N.to_Z q) = 0%Z).
  generalize (Zgcd_is_pos (Z.to_Z p) (N.to_Z q)); romega.
 symmetry; apply (Zgcd_inv_0_l _ _ H'); auto.
 Qed.

 Theorem strong_spec_norm : forall p q, [norm p q] = Qred [Qq p q].
 Proof.
 intros.
 replace (Qred [Qq p q]) with (Qred [norm p q]) by
  (apply Qred_complete; apply spec_norm).
 symmetry; apply Qred_identity.
 unfold norm.
 assert (Hp := N.spec_pos (Zabs_N p)).
 assert (Hq := N.spec_pos q).
 nzsimpl.
 destr_zcompare; rewrite ?strong_spec_check_int.
 (* Eq *)
 qsimpl.
 (* Lt *)
 qsimpl.
 rewrite Zgcd_1_rel_prime.
 destruct (Z_lt_le_dec 0 (N.to_Z q)).
 apply Zis_gcd_rel_prime; auto with zarith.
 apply Zgcd_is_gcd.
 replace (N.to_Z q) with 0%Z in * by romega.
 rewrite Zdiv_0_l in *; romega.
 (* Gt *)
 simpl; auto with zarith.
 Qed.

 (** Reduction function : producing irreducible fractions *)

 Definition red (x : t) : t :=
  match x with
   | Qz z => x
   | Qq n d => norm n d
  end.

 Class Reduced x := is_reduced : [red x] = [x].

 Theorem spec_red : forall x, [red x] == [x].
 Proof.
 intros [ z | n d ].
 auto with qarith.
 unfold red.
 apply spec_norm.
 Qed.

 Theorem strong_spec_red : forall x, [red x] = Qred [x].
 Proof.
 intros [ z | n d ].
 unfold red.
 symmetry; apply Qred_identity; simpl; auto with zarith.
 unfold red; apply strong_spec_norm.
 Qed.

 Definition add (x y: t): t :=
  match x with
  | Qz zx =>
    match y with
    | Qz zy => Qz (Z.add zx zy)
    | Qq ny dy =>
      if N.eq_bool dy N.zero then x
      else Qq (Z.add (Z.mul zx (Z_of_N dy)) ny) dy
    end
  | Qq nx dx =>
    if N.eq_bool dx N.zero then y
    else match y with
    | Qz zy => Qq (Z.add nx (Z.mul zy (Z_of_N dx))) dx
    | Qq ny dy =>
      if N.eq_bool dy N.zero then x
      else
       let n := Z.add (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) in
       let d := N.mul dx dy in
       Qq n d
    end
  end.

 Theorem spec_add : forall x y, [add x y] == [x] + [y].
 Proof.
 intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl;
  auto with zarith.
 rewrite Pmult_1_r, Z2P_correct; auto.
 rewrite Pmult_1_r, Z2P_correct; auto.
 destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition.
 rewrite Zpos_mult_morphism, 2 Z2P_correct; auto.
 Qed.

 Definition add_norm (x y: t): t :=
  match x with
  | Qz zx =>
    match y with
    | Qz zy => Qz (Z.add zx zy)
    | Qq ny dy =>
      if N.eq_bool dy N.zero then x
      else norm (Z.add (Z.mul zx (Z_of_N dy)) ny) dy
    end
  | Qq nx dx =>
    if N.eq_bool dx N.zero then y
    else match y with
    | Qz zy => norm (Z.add nx (Z.mul zy (Z_of_N dx))) dx
    | Qq ny dy =>
      if N.eq_bool dy N.zero then x
      else
       let n := Z.add (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) in
       let d := N.mul dx dy in
       norm n d
    end
  end.

 Theorem spec_add_norm : forall x y, [add_norm x y] == [x] + [y].
 Proof.
 intros x y; rewrite <- spec_add.
 destruct x; destruct y; unfold add_norm, add;
 destr_eqb; auto using Qeq_refl, spec_norm.
 Qed.

 Instance strong_spec_add_norm x y
   `(Reduced x, Reduced y) : Reduced (add_norm x y).
 Proof.
 unfold Reduced; intros.
 rewrite strong_spec_red.
 rewrite <- (Qred_complete [add x y]);
  [ | rewrite spec_add, spec_add_norm; apply Qeq_refl ].
 rewrite <- strong_spec_red.
 destruct x as [zx|nx dx]; destruct y as [zy|ny dy];
  simpl; destr_eqb; nzsimpl; simpl; auto.
 Qed.

 Definition opp (x: t): t :=
  match x with
  | Qz zx => Qz (Z.opp zx)
  | Qq nx dx => Qq (Z.opp nx) dx
  end.

 Theorem strong_spec_opp: forall q, [opp q] = -[q].
 Proof.
 intros [z | x y]; simpl.
 rewrite Z.spec_opp; auto.
 match goal with  |- context[N.eq_bool ?X ?Y] =>
  generalize (N.spec_eq_bool X Y); case N.eq_bool
 end; auto; rewrite N.spec_0.
 rewrite Z.spec_opp; auto.
 Qed.

 Theorem spec_opp : forall q, [opp q] == -[q].
 Proof.
 intros; rewrite strong_spec_opp; red; auto.
 Qed.

 Instance strong_spec_opp_norm q `(Reduced q) : Reduced (opp q).
 Proof.
 unfold Reduced; intros.
 rewrite strong_spec_opp, <- H, !strong_spec_red, <- Qred_opp.
 apply Qred_complete; apply spec_opp.
 Qed.

 Definition sub x y := add x (opp y).

 Theorem spec_sub : forall x y, [sub x y] == [x] - [y].
 Proof.
 intros x y; unfold sub; rewrite spec_add; auto.
 rewrite spec_opp; ring.
 Qed.

 Definition sub_norm x y := add_norm x (opp y).

 Theorem spec_sub_norm : forall x y, [sub_norm x y] == [x] - [y].
 Proof.
 intros x y; unfold sub_norm; rewrite spec_add_norm; auto.
 rewrite spec_opp; ring.
 Qed.

 Instance strong_spec_sub_norm x y
  `(Reduced x, Reduced y) : Reduced (sub_norm x y).
 Proof.
 intros.
 unfold sub_norm.
 apply strong_spec_add_norm; auto.
 apply strong_spec_opp_norm; auto.
 Qed.

 Definition mul (x y: t): t :=
  match x, y with
  | Qz zx, Qz zy => Qz (Z.mul zx zy)
  | Qz zx, Qq ny dy => Qq (Z.mul zx ny) dy
  | Qq nx dx, Qz zy => Qq (Z.mul nx zy) dx
  | Qq nx dx, Qq ny dy => Qq (Z.mul nx ny) (N.mul dx dy)
  end.

 Theorem spec_mul : forall x y, [mul x y] == [x] * [y].
 Proof.
 intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl; qsimpl.
 rewrite Pmult_1_r, Z2P_correct; auto.
 destruct (Zmult_integral (N.to_Z dx) (N.to_Z dy)); intuition.
 rewrite H0 in H1; auto with zarith.
 rewrite H0 in H1; auto with zarith.
 rewrite H in H1; nzsimpl; auto with zarith.
 rewrite Zpos_mult_morphism, 2 Z2P_correct; auto.
 Qed.

 Definition norm_denum n d :=
  if N.eq_bool d N.one then Qz n else Qq n d.

 Lemma spec_norm_denum : forall n d,
  [norm_denum n d] == [Qq n d].
 Proof.
 unfold norm_denum; intros; simpl; qsimpl.
 congruence.
 rewrite H0 in *; auto with zarith.
 Qed.

 Definition irred n d :=
   let gcd := N.gcd (Zabs_N n) d in
   match N.compare gcd N.one with
     | Gt => (Z.div n (Z_of_N gcd), N.div d gcd)
     | _ => (n, d)
   end.

 Lemma spec_irred : forall n d, exists g,
  let (n',d') := irred n d in
  (Z.to_Z n' * g = Z.to_Z n)%Z /\ (N.to_Z d' * g = N.to_Z d)%Z.
 Proof.
 intros.
 unfold irred; nzsimpl; simpl.
 destr_zcompare.
 exists 1%Z; nzsimpl; auto.
 exists 0%Z; nzsimpl.
 assert (Zgcd (Z.to_Z n) (N.to_Z d) = 0%Z).
  generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega.
 clear H.
 split.
 symmetry; apply (Zgcd_inv_0_l _ _ H0).
 symmetry; apply (Zgcd_inv_0_r _ _ H0).
 exists (Zgcd (Z.to_Z n) (N.to_Z d)).
 simpl.
 split.
 nzsimpl.
 destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)).
 rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
 nzsimpl.
 destruct (Zgcd_is_gcd (Z.to_Z n) (N.to_Z d)).
 rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith.
 Qed.

 Lemma spec_irred_zero : forall n d,
   (N.to_Z d = 0)%Z <-> (N.to_Z (snd (irred n d)) = 0)%Z.
 Proof.
 intros.
 unfold irred.
 split.
 nzsimpl; intros.
 destr_zcompare; auto.
 simpl.
 nzsimpl.
 rewrite H, Zdiv_0_l; auto.
 nzsimpl; destr_zcompare; simpl; auto.
 nzsimpl.
 intros.
 generalize (N.spec_pos d); intros.
 destruct (N.to_Z d); auto.
 assert (0 < 0)%Z.
  rewrite <- H0 at 2.
  apply Zgcd_div_pos; auto with zarith.
  compute; auto.
 discriminate.
 compute in H1; elim H1; auto.
 Qed.

 Lemma strong_spec_irred : forall n d,
  (N.to_Z d <> 0%Z) ->
  let (n',d') := irred n d in Zgcd (Z.to_Z n') (N.to_Z d') = 1%Z.
 Proof.
 unfold irred; intros.
 nzsimpl.
 destr_zcompare; simpl; auto.
 elim H.
 apply (Zgcd_inv_0_r (Z.to_Z n)).
 generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega.

 nzsimpl.
 rewrite Zgcd_1_rel_prime.
 apply Zis_gcd_rel_prime.
 generalize (N.spec_pos d); romega.
 generalize (Zgcd_is_pos (Z.to_Z n) (N.to_Z d)); romega.
 apply Zgcd_is_gcd; auto.
 Qed.

 Definition mul_norm_Qz_Qq z n d :=
   if Z.eq_bool z Z.zero then zero
   else
    let gcd := N.gcd (Zabs_N z) d in
    match N.compare gcd N.one with
      | Gt =>
        let z := Z.div z (Z_of_N gcd) in
        let d := N.div d gcd in
        norm_denum (Z.mul z n) d
      | _  => Qq (Z.mul z n) d
    end.

 Definition mul_norm (x y: t): t :=
 match x, y with
 | Qz zx, Qz zy => Qz (Z.mul zx zy)
 | Qz zx, Qq ny dy => mul_norm_Qz_Qq zx ny dy
 | Qq nx dx, Qz zy => mul_norm_Qz_Qq zy nx dx
 | Qq nx dx, Qq ny dy =>
    let (nx, dy) := irred nx dy in
    let (ny, dx) := irred ny dx in
    norm_denum (Z.mul ny nx) (N.mul dx dy)
 end.

 Lemma spec_mul_norm_Qz_Qq : forall z n d,
   [mul_norm_Qz_Qq z n d] == [Qq (Z.mul z n) d].
 Proof.
 intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
 destr_eqb; nzsimpl; intros Hz.
 qsimpl; rewrite Hz; auto.
 destruct Z_le_gt_dec; intros.
 qsimpl.
 rewrite spec_norm_denum.
 qsimpl.
 rewrite Zdiv_gcd_zero in z0; auto with zarith.
 rewrite H in *. rewrite Zdiv_0_l in *; discriminate.
 rewrite <- Zmult_assoc, (Zmult_comm (Z.to_Z n)), Zmult_assoc.
 rewrite Zgcd_div_swap0; try romega.
 ring.
 Qed.

 Instance strong_spec_mul_norm_Qz_Qq z n d :
   forall `(Reduced (Qq n d)), Reduced (mul_norm_Qz_Qq z n d).
 Proof.
 unfold Reduced.
 rewrite 2 strong_spec_red, 2 Qred_iff.
 simpl; nzsimpl.
 destr_eqb; intros Hd H; simpl in *; nzsimpl.

 unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
 destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto.
 destruct Z_le_gt_dec.
 simpl; nzsimpl.
 destr_eqb; simpl; nzsimpl; auto with zarith.
 unfold norm_denum. destr_eqb; simpl; nzsimpl.
 rewrite Hd, Zdiv_0_l; discriminate.
 intros _.
 destr_eqb; simpl; nzsimpl; auto.
 nzsimpl; rewrite Hd, Zdiv_0_l; auto with zarith.

 rewrite Z2P_correct in H; auto.
 unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt.
 destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto.
 destruct Z_le_gt_dec as [H'|H'].
 simpl; nzsimpl.
 destr_eqb; simpl; nzsimpl; auto.
 intros.
 rewrite Z2P_correct; auto.
 apply Zgcd_mult_rel_prime; auto.
  generalize (Zgcd_inv_0_l (Z.to_Z z) (N.to_Z d))
    (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega.
 destr_eqb; simpl; nzsimpl; auto.
 unfold norm_denum.
 destr_eqb; nzsimpl; simpl; destr_eqb; simpl; auto.
 intros; nzsimpl.
 rewrite Z2P_correct; auto.
 apply Zgcd_mult_rel_prime.
 rewrite Zgcd_1_rel_prime.
 apply Zis_gcd_rel_prime.
 generalize (N.spec_pos d); romega.
 generalize (Zgcd_is_pos (Z.to_Z z) (N.to_Z d)); romega.
 apply Zgcd_is_gcd.
 destruct (Zgcd_is_gcd (Z.to_Z z) (N.to_Z d)) as [ (z0,Hz0) (d0,Hd0) Hzd].
 replace (N.to_Z d / Zgcd (Z.to_Z z) (N.to_Z d))%Z with d0.
 rewrite Zgcd_1_rel_prime in *.
 apply bezout_rel_prime.
 destruct (rel_prime_bezout _ _ H) as [u v Huv].
 apply Bezout_intro with u (v*(Zgcd (Z.to_Z z) (N.to_Z d)))%Z.
 rewrite <- Huv; rewrite Hd0 at 2; ring.
 rewrite Hd0 at 1.
 symmetry; apply Z_div_mult_full; auto with zarith.
 Qed.

 Theorem spec_mul_norm : forall x y, [mul_norm x y] == [x] * [y].
 Proof.
 intros x y; rewrite <- spec_mul; auto.
 unfold mul_norm, mul; destruct x; destruct y.
 apply Qeq_refl.
 apply spec_mul_norm_Qz_Qq.
 rewrite spec_mul_norm_Qz_Qq; qsimpl; ring.

 rename t0 into nx, t3 into dy, t2 into ny, t1 into dx.
 destruct (spec_irred nx dy) as (g & Hg).
 destruct (spec_irred ny dx) as (g' & Hg').
 assert (Hz := spec_irred_zero nx dy).
 assert (Hz':= spec_irred_zero ny dx).
 destruct irred as (n1,d1); destruct irred as (n2,d2).
 simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].
 rewrite spec_norm_denum.
 qsimpl.

 destruct (Zmult_integral _ _ H0) as [Eq|Eq].
 rewrite Eq in *; simpl in *.
 rewrite <- Hg2' in *; auto with zarith.
 rewrite Eq in *; simpl in *.
 rewrite <- Hg2 in *; auto with zarith.

 destruct (Zmult_integral _ _ H) as [Eq|Eq].
 rewrite Hz' in Eq; rewrite Eq in *; auto with zarith.
 rewrite Hz in Eq; rewrite Eq in *; auto with zarith.

 rewrite <- Hg1, <- Hg2, <- Hg1', <- Hg2'; ring.
 Qed.

 Instance strong_spec_mul_norm x y :
  forall `(Reduced x, Reduced y), Reduced (mul_norm x y).
 Proof.
 unfold Reduced; intros.
 rewrite strong_spec_red, Qred_iff.
 destruct x as [zx|nx dx]; destruct y as [zy|ny dy].
 simpl in *; auto with zarith.
 simpl.
 rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto.
 simpl.
 rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto.
 simpl.
 destruct (spec_irred nx dy) as [g Hg].
 destruct (spec_irred ny dx) as [g' Hg'].
 assert (Hz := spec_irred_zero nx dy).
 assert (Hz':= spec_irred_zero ny dx).
 assert (Hgc := strong_spec_irred nx dy).
 assert (Hgc' := strong_spec_irred ny dx).
 destruct irred as (n1,d1); destruct irred as (n2,d2).
 simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2'].

 unfold norm_denum; qsimpl.

 assert (NEQ : N.to_Z dy <> 0%Z) by
  (rewrite Hz; intros EQ; rewrite EQ in *; romega).
 specialize (Hgc NEQ).

 assert (NEQ' : N.to_Z dx <> 0%Z) by
  (rewrite Hz'; intro EQ; rewrite EQ in *; romega).
 specialize (Hgc' NEQ').

 revert H H0.
 rewrite 2 strong_spec_red, 2 Qred_iff; simpl.
 destr_eqb; simpl; nzsimpl; try romega; intros.
 rewrite Z2P_correct in *; auto.

 apply Zgcd_mult_rel_prime; rewrite Zgcd_comm;
  apply Zgcd_mult_rel_prime; rewrite Zgcd_comm; auto.

 rewrite Zgcd_1_rel_prime in *.
 apply bezout_rel_prime.
 destruct (rel_prime_bezout _ _ H4) as [u v Huv].
 apply Bezout_intro with (u*g')%Z (v*g)%Z.
 rewrite <- Huv, <- Hg1', <- Hg2. ring.

 rewrite Zgcd_1_rel_prime in *.
 apply bezout_rel_prime.
 destruct (rel_prime_bezout _ _ H3) as [u v Huv].
 apply Bezout_intro with (u*g)%Z (v*g')%Z.
 rewrite <- Huv, <- Hg2', <- Hg1. ring.
 Qed.

 Definition inv (x: t): t :=
 match x with
 | Qz z =>
   match Z.compare Z.zero z with
     | Eq => zero
     | Lt => Qq Z.one (Zabs_N z)
     | Gt => Qq Z.minus_one (Zabs_N z)
   end
 | Qq n d =>
   match Z.compare Z.zero n with
     | Eq => zero
     | Lt => Qq (Z_of_N d) (Zabs_N n)
     | Gt => Qq (Z.opp (Z_of_N d)) (Zabs_N n)
   end
 end.

 Theorem spec_inv : forall x, [inv x] == /[x].
 Proof.
 destruct x as [ z | n d ].
 (* Qz z *)
 simpl.
 rewrite Z.spec_compare; destr_zcompare.
 (* 0 = z *)
 rewrite <- H.
 simpl; nzsimpl; compute; auto.
 (* 0 < z *)
 simpl.
 destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
 set (z':=Z.to_Z z) in *; clearbody z'.
 red; simpl.
 rewrite Zabs_eq by romega.
 rewrite Z2P_correct by auto.
 unfold Qinv; simpl; destruct z'; simpl; auto; discriminate.
 (* 0 > z *)
 simpl.
 destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
 set (z':=Z.to_Z z) in *; clearbody z'.
 red; simpl.
 rewrite Zabs_non_eq by romega.
 rewrite Z2P_correct by romega.
 unfold Qinv; simpl; destruct z'; simpl; auto; discriminate.
 (* Qq n d *)
 simpl.
 rewrite Z.spec_compare; destr_zcompare.
 (* 0 = n *)
 rewrite <- H.
 simpl; nzsimpl.
 destr_eqb; intros; compute; auto.
 (* 0 < n *)
 simpl.
 destr_eqb; nzsimpl; intros.
 intros; rewrite Zabs_eq in *; romega.
 intros; rewrite Zabs_eq in *; romega.
 clear H1.
 rewrite H0.
 compute; auto.
 clear H1.
 set (n':=Z.to_Z n) in *; clearbody n'.
 rewrite Zabs_eq by romega.
 red; simpl.
 rewrite Z2P_correct by auto.
 unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate.
 rewrite Zpos_mult_morphism, Z2P_correct; auto.
 (* 0 > n *)
 simpl.
 destr_eqb; nzsimpl; intros.
 intros; rewrite Zabs_non_eq in *; romega.
 intros; rewrite Zabs_non_eq in *; romega.
 clear H1.
 red; nzsimpl; rewrite H0; compute; auto.
 clear H1.
 set (n':=Z.to_Z n) in *; clearbody n'.
 red; simpl; nzsimpl.
 rewrite Zabs_non_eq by romega.
 rewrite Z2P_correct by romega.
 unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate.
 assert (T : forall x, Zneg x = Zopp (Zpos x)) by auto.
 rewrite T, Zpos_mult_morphism, Z2P_correct; auto; ring.
 Qed.

 Definition inv_norm (x: t): t :=
   match x with
     | Qz z =>
       match Z.compare Z.zero z with
         | Eq => zero
         | Lt => Qq Z.one (Zabs_N z)
         | Gt => Qq Z.minus_one (Zabs_N z)
       end
     | Qq n d =>
       if N.eq_bool d N.zero then zero else
       match Z.compare Z.zero n with
         | Eq => zero
         | Lt =>
           match Z.compare n Z.one with
             | Gt => Qq (Z_of_N d) (Zabs_N n)
             | _ => Qz (Z_of_N d)
           end
         | Gt =>
           match Z.compare n Z.minus_one with
             | Lt => Qq (Z.opp (Z_of_N d)) (Zabs_N n)
             | _ => Qz (Z.opp (Z_of_N d))
           end
       end
   end.

 Theorem spec_inv_norm : forall x, [inv_norm x] == /[x].
 Proof.
 intros.
 rewrite <- spec_inv.
 destruct x as [ z | n d ].
 (* Qz z *)
 simpl.
 rewrite Z.spec_compare; destr_zcompare; auto with qarith.
 (* Qq n d *)
 simpl; nzsimpl; destr_eqb.
 destr_zcompare; simpl; auto with qarith.
 destr_eqb; nzsimpl; auto with qarith.
 intros _ Hd; rewrite Hd; auto with qarith.
 destr_eqb; nzsimpl; auto with qarith.
 intros _ Hd; rewrite Hd; auto with qarith.
 (* 0 < n *)
 destr_zcompare; auto with qarith.
 destr_zcompare; nzsimpl; simpl; auto with qarith; intros.
 destr_eqb; nzsimpl; [ intros; rewrite Zabs_eq in *; romega | intros _ ].
 rewrite H0; auto with qarith.
 romega.
 (* 0 > n *)
 destr_zcompare; nzsimpl; simpl; auto with qarith.
 destr_eqb; nzsimpl; [ intros; rewrite Zabs_non_eq in *; romega | intros _ ].
 rewrite H0; auto with qarith.
 romega.
 Qed.

 Instance strong_spec_inv_norm x : Reduced x -> Reduced (inv_norm x).
 Proof.
 unfold Reduced.
 intros.
 destruct x as [ z | n d ].
 (* Qz *)
 simpl; nzsimpl.
 rewrite strong_spec_red, Qred_iff.
 destr_zcompare; simpl; nzsimpl; auto.
 destr_eqb; nzsimpl; simpl; auto.
 destr_eqb; nzsimpl; simpl; auto.
 (* Qq n d *)
 rewrite strong_spec_red, Qred_iff in H; revert H.
 simpl; nzsimpl.
 destr_eqb; nzsimpl; auto with qarith.
 destr_zcompare; simpl; nzsimpl; auto; intros.
 (* 0 < n *)
 destr_zcompare; simpl; nzsimpl; auto.
 destr_eqb; nzsimpl; simpl; auto.
 rewrite Zabs_eq; romega.
 intros _.
 rewrite strong_spec_norm; simpl; nzsimpl.
 destr_eqb; nzsimpl.
 rewrite Zabs_eq; romega.
 intros _.
 rewrite Qred_iff.
 simpl.
 rewrite Zabs_eq; auto with zarith.
 rewrite Z2P_correct in *; auto.
 rewrite Zgcd_comm; auto.
 (* 0 > n *)
 destr_eqb; nzsimpl; simpl; auto; intros.
 destr_zcompare; simpl; nzsimpl; auto.
 destr_eqb; nzsimpl.
 rewrite Zabs_non_eq; romega.
 intros _.
 rewrite strong_spec_norm; simpl; nzsimpl.
 destr_eqb; nzsimpl.
 rewrite Zabs_non_eq; romega.
 intros _.
 rewrite Qred_iff.
 simpl.
 rewrite Z2P_correct in *; auto.
 intros.
 rewrite Zgcd_comm, Zgcd_Zabs, Zgcd_comm.
 apply Zis_gcd_gcd; auto with zarith.
 apply Zis_gcd_minus.
 rewrite Zopp_involutive, <- H1; apply Zgcd_is_gcd.
 rewrite Zabs_non_eq; romega.
 Qed.

 Definition div x y := mul x (inv y).

 Theorem spec_div x y: [div x y] == [x] / [y].
 Proof.
 unfold div; rewrite spec_mul; auto.
 unfold Qdiv; apply Qmult_comp.
 apply Qeq_refl.
 apply spec_inv; auto.
 Qed.

 Definition div_norm x y := mul_norm x (inv_norm y).

 Theorem spec_div_norm x y: [div_norm x y] == [x] / [y].
 Proof.
 unfold div_norm; rewrite spec_mul_norm; auto.
 unfold Qdiv; apply Qmult_comp.
 apply Qeq_refl.
 apply spec_inv_norm; auto.
 Qed.

 Instance strong_spec_div_norm x y
   `(Reduced x, Reduced y) : Reduced (div_norm x y).
 Proof.
 intros; unfold div_norm.
 apply strong_spec_mul_norm; auto.
 apply strong_spec_inv_norm; auto.
 Qed.

 Definition square (x: t): t :=
  match x with
  | Qz zx => Qz (Z.square zx)
  | Qq nx dx => Qq (Z.square nx) (N.square dx)
  end.

 Theorem spec_square : forall x, [square x] == [x] ^ 2.
 Proof.
 destruct x as [ z | n d ].
 simpl; rewrite Z.spec_square; red; auto.
 simpl.
 destr_eqb; nzsimpl; intros.
 apply Qeq_refl.
 rewrite N.spec_square in *; nzsimpl.
 elim (Zmult_integral _ _ H0); romega.
 rewrite N.spec_square in *; nzsimpl.
 rewrite H in H0; romega.
 rewrite Z.spec_square, N.spec_square.
 red; simpl.
 rewrite Zpos_mult_morphism; rewrite !Z2P_correct; auto.
 apply Zmult_lt_0_compat; auto.
 Qed.

 Definition power_pos (x : t) p : t :=
  match x with
  | Qz zx => Qz (Z.pow_pos zx p)
  | Qq nx dx => Qq (Z.pow_pos nx p) (N.pow_pos dx p)
  end.

 Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p.
 Proof.
 intros [ z | n d ] p; unfold power_pos.
 (* Qz *)
 simpl.
 rewrite Z.spec_pow_pos.
 rewrite Qpower_decomp.
 red; simpl; f_equal.
 rewrite Zpower_pos_1_l; auto.
 (* Qq *)
 simpl.
 rewrite Z.spec_pow_pos.
 destr_eqb; nzsimpl; intros.
 apply Qeq_sym; apply Qpower_positive_0.
 rewrite N.spec_pow_pos in *.
 assert (0 < N.to_Z d ^ ' p)%Z by
  (apply Zpower_gt_0; auto with zarith).
 romega.
 rewrite N.spec_pow_pos, H in *.
 rewrite Zpower_0_l in H0; [romega|discriminate].
 rewrite Qpower_decomp.
 red; simpl; do 3 f_equal.
 rewrite Z2P_correct by (generalize (N.spec_pos d); romega).
 rewrite N.spec_pow_pos. auto.
 Qed.

 Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p).
 Proof.
 destruct x as [z | n d]; simpl; intros.
 red; simpl; auto.
 red; simpl; intros.
 rewrite strong_spec_norm; simpl.
 destr_eqb; nzsimpl; intros.
 simpl; auto.
 rewrite Qred_iff.
 revert H.
 unfold Reduced; rewrite strong_spec_red, Qred_iff; simpl.
 destr_eqb; nzsimpl; simpl; intros.
 rewrite N.spec_pow_pos in H0.
 rewrite H, Zpower_0_l in *; [romega|discriminate].
 rewrite Z2P_correct in *; auto.
 rewrite N.spec_pow_pos, Z.spec_pow_pos; auto.
 rewrite Zgcd_1_rel_prime in *.
 apply rel_prime_Zpower; auto with zarith.
 Qed.

 Definition power (x : t) (z : Z) : t :=
   match z with
     | Z0 => one
     | Zpos p => power_pos x p
     | Zneg p => inv (power_pos x p)
   end.

 Theorem spec_power : forall x z, [power x z] == [x]^z.
 Proof.
 destruct z.
 simpl; nzsimpl; red; auto.
 apply spec_power_pos.
 simpl.
 rewrite spec_inv, spec_power_pos; apply Qeq_refl.
 Qed.

 Definition power_norm (x : t) (z : Z) : t :=
   match z with
     | Z0 => one
     | Zpos p => power_pos x p
     | Zneg p => inv_norm (power_pos x p)
   end.

 Theorem spec_power_norm : forall x z, [power_norm x z] == [x]^z.
 Proof.
 destruct z.
 simpl; nzsimpl; red; auto.
 apply spec_power_pos.
 simpl.
 rewrite spec_inv_norm, spec_power_pos; apply Qeq_refl.
 Qed.

 Instance strong_spec_power_norm x z :
   Reduced x -> Reduced (power_norm x z).
 Proof.
 destruct z; simpl.
 intros _; unfold Reduced; rewrite strong_spec_red.
 unfold one.
 simpl to_Q; nzsimpl; auto.
 intros; apply strong_spec_power_pos; auto.
 intros; apply strong_spec_inv_norm; apply strong_spec_power_pos; auto.
 Qed.

 (** Interaction with [Qcanon.Qc] *)

 Open Scope Qc_scope.

 Definition of_Qc q := of_Q (this q).

 Definition to_Qc q := !! [q].

 Notation "[[ x ]]" := (to_Qc x).

 Theorem strong_spec_of_Qc : forall q, [of_Qc q] = q.
 Proof.
 intros (q,Hq); intros.
 unfold of_Qc; rewrite strong_spec_of_Q; auto.
 Qed.

 Instance strong_spec_of_Qc_bis q : Reduced (of_Qc q).
 Proof.
 intros; red; rewrite strong_spec_red, strong_spec_of_Qc.
 destruct q; simpl; auto.
 Qed.

 Theorem spec_of_Qc: forall q, [[of_Qc q]] = q.
 Proof.
 intros; apply Qc_decomp; simpl; intros.
 rewrite strong_spec_of_Qc; auto.
 Qed.

 Theorem spec_oppc: forall q, [[opp q]] = -[[q]].
 Proof.
 intros q; unfold Qcopp, to_Qc, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 rewrite spec_opp, <- Qred_opp, Qred_correct.
 apply Qeq_refl.
 Qed.

 Theorem spec_oppc_bis : forall q : Qc, [opp (of_Qc q)] = - q.
 Proof.
 intros.
 rewrite <- strong_spec_opp_norm by apply strong_spec_of_Qc_bis.
 rewrite strong_spec_red.
 symmetry; apply (Qred_complete (-q)%Q).
 rewrite spec_opp, strong_spec_of_Qc; auto with qarith.
 Qed.

 Theorem spec_comparec: forall q1 q2,
  compare q1 q2 = ([[q1]] ?= [[q2]]).
 Proof.
 unfold Qccompare, to_Qc.
 intros q1 q2; rewrite spec_compare; simpl; auto.
 apply Qcompare_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_addc x y:
  [[add x y]] = [[x]] + [[y]].
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! ([x] + [y])).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_add; auto.
 unfold Qcplus, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 apply Qplus_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_add_normc x y:
  [[add_norm x y]] = [[x]] + [[y]].
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! ([x] + [y])).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_add_norm; auto.
 unfold Qcplus, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 apply Qplus_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_add_normc_bis : forall x y : Qc,
   [add_norm (of_Qc x) (of_Qc y)] = x+y.
 Proof.
 intros.
 rewrite <- strong_spec_add_norm by apply strong_spec_of_Qc_bis.
 rewrite strong_spec_red.
 symmetry; apply (Qred_complete (x+y)%Q).
 rewrite spec_add_norm, ! strong_spec_of_Qc; auto with qarith.
 Qed.

 Theorem spec_subc x y:  [[sub x y]] = [[x]] - [[y]].
 Proof.
 unfold sub; rewrite spec_addc; auto.
 rewrite spec_oppc; ring.
 Qed.

 Theorem spec_sub_normc x y:
   [[sub_norm x y]] = [[x]] - [[y]].
 Proof.
 unfold sub_norm; rewrite spec_add_normc; auto.
 rewrite spec_oppc; ring.
 Qed.

 Theorem spec_sub_normc_bis : forall x y : Qc,
   [sub_norm (of_Qc x) (of_Qc y)] = x-y.
 Proof.
 intros.
 rewrite <- strong_spec_sub_norm by apply strong_spec_of_Qc_bis.
 rewrite strong_spec_red.
 symmetry; apply (Qred_complete (x+(-y)%Qc)%Q).
 rewrite spec_sub_norm, ! strong_spec_of_Qc.
 unfold Qcopp, Q2Qc, this. rewrite Qred_correct ; auto with qarith.
 Qed.

 Theorem spec_mulc x y:
  [[mul x y]] = [[x]] * [[y]].
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! ([x] * [y])).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_mul; auto.
 unfold Qcmult, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_mul_normc x y:
   [[mul_norm x y]] = [[x]] * [[y]].
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! ([x] * [y])).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_mul_norm; auto.
 unfold Qcmult, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_mul_normc_bis : forall x y : Qc,
   [mul_norm (of_Qc x) (of_Qc y)] = x*y.
 Proof.
 intros.
 rewrite <- strong_spec_mul_norm by apply strong_spec_of_Qc_bis.
 rewrite strong_spec_red.
 symmetry; apply (Qred_complete (x*y)%Q).
 rewrite spec_mul_norm, ! strong_spec_of_Qc; auto with qarith.
 Qed.

 Theorem spec_invc x:
   [[inv x]] =  /[[x]].
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! (/[x])).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_inv; auto.
 unfold Qcinv, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 apply Qinv_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_inv_normc x:
   [[inv_norm x]] =  /[[x]].
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! (/[x])).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_inv_norm; auto.
 unfold Qcinv, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 apply Qinv_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_inv_normc_bis : forall x : Qc,
   [inv_norm (of_Qc x)] = /x.
 Proof.
 intros.
 rewrite <- strong_spec_inv_norm by apply strong_spec_of_Qc_bis.
 rewrite strong_spec_red.
 symmetry; apply (Qred_complete (/x)%Q).
 rewrite spec_inv_norm, ! strong_spec_of_Qc; auto with qarith.
 Qed.

 Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]].
 Proof.
 unfold div; rewrite spec_mulc; auto.
 unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto.
 apply spec_invc; auto.
 Qed.

 Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]].
 Proof.
 unfold div_norm; rewrite spec_mul_normc; auto.
 unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto.
 apply spec_inv_normc; auto.
 Qed.

 Theorem spec_div_normc_bis : forall x y : Qc,
   [div_norm (of_Qc x) (of_Qc y)] = x/y.
 Proof.
 intros.
 rewrite <- strong_spec_div_norm by apply strong_spec_of_Qc_bis.
 rewrite strong_spec_red.
 symmetry; apply (Qred_complete (x*(/y)%Qc)%Q).
 rewrite spec_div_norm, ! strong_spec_of_Qc.
 unfold Qcinv, Q2Qc, this; rewrite Qred_correct; auto with qarith.
 Qed.

 Theorem spec_squarec x: [[square x]] = [[x]]^2.
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! ([x]^2)).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_square; auto.
 simpl Qcpower.
 replace (!! [x] * 1) with (!![x]); try ring.
 simpl.
 unfold Qcmult, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
 Qed.

 Theorem spec_power_posc x p:
   [[power_pos x p]] = [[x]] ^ nat_of_P p.
 Proof.
 unfold to_Qc.
 apply trans_equal with (!! ([x]^Zpos p)).
 unfold Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete; apply spec_power_pos; auto.
 induction p using Pind.
 simpl; ring.
 rewrite Psucc_S; simpl Qcpower.
 rewrite <- IHp; clear IHp.
 unfold Qcmult, Q2Qc.
 apply Qc_decomp; intros _ _; unfold this.
 apply Qred_complete.
 setoid_replace ([x] ^ ' Psucc p)%Q with ([x] * [x] ^ ' p)%Q.
 apply Qmult_comp; apply Qeq_sym; apply Qred_correct.
 simpl.
 rewrite Pplus_one_succ_l.
 rewrite Qpower_plus_positive; simpl; apply Qeq_refl.
 Qed.

End Make.


Require Coq.Init.Byte Coq.Strings.Byte.
Require Import Coq.ZArith.ZArith.

Local Open Scope Z_scope.

Notation byte := (Coq.Init.Byte.byte: Type). (* to avoid that some universes are forced to "Set" *)

Module byte.
  Definition unsigned(b: byte): Z := Z.of_N (Byte.to_N b).

  Definition wrap(z: Z): Z := z mod 2 ^ 8.

  Lemma wrap_range z:
    0 <= byte.wrap z < 2 ^ 8.
  Proof. apply Z.mod_pos_bound. reflexivity. Qed.

  Lemma Byte_of_N_of_mod_not_None: forall z, Byte.of_N (Z.to_N (wrap z)) <> None.
  Proof.
    intros z C.
    apply Byte.of_N_None_iff in C.
    pose proof (Z.mod_pos_bound z 256 eq_refl) as P.
    destruct P as [P1 P2].
    apply Z2N.inj_lt in P2. 3: cbv; discriminate. 2: assumption.
    apply N.lt_le_pred in P2.
    simpl in P2.
    pose proof (N.lt_le_trans _ _ _ C P2) as P3.
    cbv in P3.
    discriminate.
  Qed.

  Definition of_Z(z: Z): byte :=
    let r := Byte.of_N (Z.to_N (wrap z)) in
    match r as o return (r = o -> byte) with
    | Some b => fun _ => b
    | None => fun E => False_rect byte (Byte_of_N_of_mod_not_None z E)
    end eq_refl.

  Lemma unsigned_of_Z: forall z, unsigned (of_Z z) = wrap z.
  Proof.
    intros. unfold unsigned.
    pose proof (Z.mod_pos_bound z (2^8) eq_refl) as P.
    rewrite <- (Z2N.id (wrap z)) by (destruct P; assumption).
    f_equal.
    destruct (Byte.of_N (Z.to_N (wrap z))) eqn: E. 2: {
      apply Byte_of_N_of_mod_not_None in E. contradiction.
    }
    erewrite <- (Byte.to_of_N (Z.to_N (wrap z))). 2: exact E.
    f_equal.
    unfold of_Z.
    remember (fun E0 : Byte.of_N (Z.to_N (wrap z)) = None => False_rect byte (Byte_of_N_of_mod_not_None z E0))
      as F; clear HeqF.
    revert E F.
    generalize (Byte.of_N (Z.to_N (wrap z))).
    clear z P.
    intros o E.
    rewrite E.
    intros.
    reflexivity.
  Qed.

  Lemma of_bits_inj: forall bs1 bs2, Byte.of_bits bs1 = Byte.of_bits bs2 -> bs1 = bs2.
  Proof.
    intros.
    rewrite <- (Byte.to_bits_of_bits bs1) in *.
    rewrite <- (Byte.to_bits_of_bits bs2) in *.
    do 2 rewrite Byte.of_bits_to_bits in H.
    f_equal.
    assumption.
  Qed.

  Lemma to_bits_inj: forall b1 b2, Byte.to_bits b1 = Byte.to_bits b2 -> b1 = b2.
  Proof.
    intros.
    rewrite <- (Byte.of_bits_to_bits b1) in *.
    rewrite <- (Byte.of_bits_to_bits b2) in *.
    do 2 rewrite Byte.to_bits_of_bits in H.
    f_equal.
    assumption.
  Qed.

  Lemma to_N_inj: forall b1 b2, Byte.to_N b1 = Byte.to_N b2 -> b1 = b2.
  Proof.
    intros.
    enough (Some b1 = Some b2). 1: congruence.
    rewrite <- (Byte.of_to_N b1).
    rewrite <- (Byte.of_to_N b2).
    f_equal.
    assumption.
  Qed.

  Lemma unsigned_inj: forall b1 b2, unsigned b1 = unsigned b2 -> b1 = b2.
  Proof.
    unfold unsigned. intros.
    apply N2Z.inj in H.
    apply to_N_inj in H.
    assumption.
  Qed.

  Lemma unsigned_range: forall b, 0 <= unsigned b < 2 ^ 8.
  Proof.
    intros. unfold unsigned. split.
    - apply N2Z.is_nonneg.
    - change (2 ^ 8) with (Z.of_N (N.succ 255)).
      apply N2Z.inj_lt.
      apply N.lt_succ_r.
      apply (Byte.to_N_bounded b).
  Qed.

  Lemma wrap_unsigned: forall x, byte.wrap (byte.unsigned x) = byte.unsigned x.
  Proof.
    intros. unfold byte.wrap, byte.unsigned.
    apply Z.mod_small.
    apply unsigned_range.
  Qed.

  Lemma of_Z_unsigned b:
    byte.of_Z (byte.unsigned b) = b.
  Proof. eapply unsigned_inj. rewrite unsigned_of_Z. rewrite wrap_unsigned. trivial. Qed.

  (* FIXME isn't this defined somewhere already? *)
  Definition and (b1 b2: byte) := byte.of_Z (Z.land (byte.unsigned b1) (byte.unsigned b2)).
  Definition xor a b := byte.of_Z (Z.lxor (byte.unsigned a) (byte.unsigned b)).
End byte.


Require Import ZArith Arith List syntax little Lia.

Import ListNotations.

Module compiler (S : little_syntax).

Import S.

Inductive assembly :=
  push (n : Z) |
  pop |
  add |
  cmp |
  load (n : nat) |
   store (n : nat) | goto (n : nat) | branch (n : nat).

Definition asm_step_new_stack (stack mem : list Z) (i : assembly) :
  list Z :=
  match i with
  | push v => v :: stack
  | pop => tl stack
  | add => match stack with a :: b :: s => (a + b)%Z :: s | _ => nil end
  | cmp =>
    match stack with a :: b :: s => Z.b2z(a <=? b)%Z :: s | _ => nil end
  | load n => nth n mem 0%Z :: stack
  | store n => tl stack
  | goto n => stack
  | branch n => tl stack
  end.

Definition asm_step_new_pc (stack mem : list Z) (i : assembly) (pc : nat) :
  nat :=
  match i with
  | push n => pc + 1
  | pop => pc + 1
  | add => pc + 1
  | cmp => pc + 1
  | load n => pc + 1
  | store n => pc + 1
  | goto n => n
  | branch n =>
    if (hd 0 stack =? Z.b2z true)%Z then n else pc + 1
  end.

Fixpoint set_nth (l : list Z)(i : nat)(v : Z) :=
  match l, i with
  | x :: m, 0%nat => v :: m
  | x :: m, S i' => x :: set_nth m i' v
  | _, _ => nil
  end.

Definition asm_step_new_mem (stack mem : list Z) (i : assembly) :
  list Z :=
  match i with
  | push n => mem
  | pop => mem
  | add => mem
  | cmp => mem
  | load n => mem
  | store n =>
    match stack with
    | v :: s => set_nth mem n v
    | _ => nil
    end
  | goto n => mem
  | branch n => mem
  end.

Fixpoint exec_asm
   (exec_count : nat)(pg : list assembly)(stack mem : list Z) (pc : nat)
   :=
  match exec_count with
  | 0%nat => (stack, mem, pc)
  | S ec =>
    match nth_error pg pc with
    | None => (stack, mem, pc)
    | Some i =>
      exec_asm ec pg (asm_step_new_stack stack mem i)
             (asm_step_new_mem stack mem i)
             (asm_step_new_pc stack mem i pc)
    end
  end.

Fixpoint env_to_mem (l : list (string * Z)) : list Z :=
  match l with (s, v) :: l' => v :: env_to_mem l' | nil => nil end.

Fixpoint symbol_index (l : list string)(s : string) : nat :=
  match l with
  | nil => 0
  | s' :: l' =>
    if string_dec s s' then 0 else S (symbol_index l' s)
  end.

Fixpoint compile_aexp (symbols : list string)
  (e : aexpr0 string) : list assembly :=
  match e with
  | avar s => [load (symbol_index symbols s)]
  | anum n => [push n]
  | aplus e1 e2 =>
    compile_aexp symbols e1 ++ compile_aexp symbols e2 ++ [add]
  end.

Definition compile_bexp (symbols : list string)
  (b : bexpr0 string) : list assembly :=
  match b with
  | blt e1 e2 =>
    compile_aexp symbols e1 ++ compile_aexp symbols e2 ++ [cmp]
  end.

Fixpoint compile_instr (symbols : list string)(loc : nat)
  (i : instr0 string) {struct i} : list assembly :=
match i with
| assign s e =>
  let cp_exp := compile_aexp symbols e in
  compile_aexp symbols e ++ [store (symbol_index symbols s)]
| sequence i1 i2 =>
  let pg1 := compile_instr symbols loc i1 in
  let pg2 := compile_instr symbols (loc + length pg1) i2 in
  pg1 ++ pg2
| while b i1 =>
  let pge := compile_bexp symbols b in
  let pgi := compile_instr symbols (loc + length pge + 1) i1 in
  pge ++ branch (loc + length pge + length pgi + 2) ::
  pgi ++ [goto loc]
| skip => []
end.

End compiler.

Module compiler_proofs (S : little_syntax).

Module comp := compiler S.
Module dyn := little S.

Import comp.
Import dyn.

Lemma exec_avar : forall n env e v pg1 pg2 stk,
  aeval env e v -> e = avar n ->
   exec_asm 1 (pg1 ++ compile_aexp
                        (map fst env) e ++ pg2) stk (env_to_mem env)
   (length pg1) =
   (v :: stk, env_to_mem env, (length pg1 + 1)%nat).
Proof.
intros n env e v pg1 pg2 stk dyn.
induction dyn as [r v | r x v | r x y v v' xny dyn Ih |
   r e1 e2 v1 v2 dyn1 Ih1 dyn2 Ih2].
      discriminate.
    intros [= xn]; simpl.
    destruct (S.string_dec x x) as [ _ | abs];[simpl | now case abs].
    now rewrite nth_error_app2, Nat.sub_diag; simpl.
  intros [= xn]; simpl.
  destruct (S.string_dec x y) as [ abs | _];[now case xny | simpl].
  rewrite nth_error_app2, Nat.sub_diag; simpl; auto with arith.
  revert Ih; rewrite xn; simpl.
  rewrite nth_error_app2, Nat.sub_diag; simpl; auto with arith.
  intros Ih; assert (Ih' := Ih eq_refl); injection Ih'.
  now intros v'q; rewrite v'q.
discriminate.
Qed.

Lemma exec_asm_seq :
  forall pg stk stk1 mem mem1 ec1 ec2 pc pc1,
  exec_asm ec1 pg stk mem pc = (stk1, mem1, pc1) ->
  exec_asm (ec1 + ec2) pg stk mem pc =
  exec_asm ec2 pg stk1 mem1 pc1.
Proof.
intros pg stk stk1 mem mem1 ec1; revert stk stk1 mem mem1.
induction ec1.
  simpl; intros stk stk1 mem mem1 ec2 pc pc1 [= stst mm pp].
  now subst.
intros stk stk1 mem mem1 ec2 pc pc1.
  simpl.
destruct (nth_error pg pc) as [i | ] eqn:nthq; cycle 1.
  intros [= -> -> ->].
  case ec2 as [ | ec].
    auto.
  now simpl; rewrite nthq.
intros cnd1.
now apply IHec1.
Qed.

Lemma exec_aexp :
  forall env e v pg1 pg2 stk,
  aeval env e v ->
  exists ec,
  exec_asm ec (pg1 ++ compile_aexp (map fst env) e ++ pg2)
       stk (env_to_mem env) (length pg1) =
  (v :: stk, env_to_mem env,
   (length pg1 + length (compile_aexp (map fst env) e))%nat).
Proof.
intros env e v pg1 pg2 stk dyn; revert pg1 pg2 stk.
induction dyn as [r n | r x v | r x y v v' xny dyn Ih|
                  r e1 e2 v1 v2 dyn1 Ih1 dyn2 Ih2].
      intros pg1 pg2 stk; exists 1%nat; simpl.
      now rewrite nth_error_app2, Nat.sub_diag; simpl.
    intros pg1 pg2 stk; exists 1%nat.
    apply (exec_avar x).
      constructor.
    easy.
  intros pg1 pg2 stk; exists 1%nat.
  apply (exec_avar x).
    now constructor.
  easy.
intros pg1 pg2 stk.
destruct (Ih1 pg1 (compile_aexp (map fst r) e2 ++ [add] ++ pg2) stk)
   as [ec1 Pec1].
destruct (Ih2 (pg1 ++ (compile_aexp (map fst r) e1)) (add :: pg2) (v1 :: stk))
  as [ec2 Pec2].
exists (ec1 + ec2 + 1)%nat.
simpl.
revert Pec1 Pec2; rewrite <-!app_assoc; simpl.
rewrite app_length.
set (pg := pg1 ++ _); intros Pec1 Pec2.
assert
  (both_exp : exec_asm (ec1 + ec2) pg stk (env_to_mem r) (length pg1) =
    (v2 :: v1 :: stk, env_to_mem r,
    (length pg1 + length (compile_aexp (map fst r) e1) +
     length (compile_aexp (map fst r) e2)))%nat).
  rewrite (exec_asm_seq pg _ (v1 :: stk) _ (env_to_mem r)
    _ _ _ (length pg1 + length (compile_aexp (map fst r) e1))%nat Pec1).
  easy.
rewrite app_length.
rewrite (exec_asm_seq _ _ (v2 :: v1 :: stk) _ (env_to_mem r)
            _ _ _ _ both_exp).
unfold pg; simpl.
rewrite 2!app_assoc.
rewrite nth_error_app2;[ | now rewrite !app_length; auto with arith].
rewrite !app_length, Nat.sub_diag; simpl.
now rewrite (Z.add_comm v2 v1), !Nat.add_assoc.
Qed.

Lemma exec_bexp :
  forall env e1 e2 v pg1 pg2 stk,
  beval env (blt e1 e2) v ->
  exists ec,
  exec_asm ec (pg1 ++ compile_bexp (map fst env) (blt e1 e2) ++ pg2)
       stk (env_to_mem env) (length pg1) =
  (Z.b2z (negb v) :: stk, env_to_mem env,
   (length pg1 + length (compile_bexp (map fst env) (blt e1 e2)))%nat).
Proof.
intros env e1 e2 v pg1 pg2 stk dyn.
inversion dyn as [r e1' e2' v1 v2 ev1 ev2 cmp1|
                  r e1' e2' v1 v2 ev1 ev2 cmp2].
  destruct (exec_aexp env e1 v1 pg1 (compile_aexp
                                            (map fst env) e2 ++ [cmp] ++ pg2)
                    stk ev1) as [ec1 Pec1].
  destruct (exec_aexp env e2 v2 (pg1 ++ compile_aexp
                                       (map fst env) e1) ([cmp] ++ pg2)
              (v1 :: stk) ev2) as [ec2 Pec2].
  revert Pec1 Pec2; simpl; rewrite <-!app_assoc; simpl; set (pg := pg1 ++ _).
  rewrite app_length.
  intros Pec1 Pec2; exists (ec1 + ec2 + 1)%nat.
  assert
    (both_exp : exec_asm (ec1 + ec2) pg stk (env_to_mem env) (length pg1) =
    (v2 :: v1 :: stk, env_to_mem env,
    (length pg1 + length (compile_aexp (map fst env) e1) +
     length (compile_aexp (map fst env) e2)))%nat).
    rewrite (exec_asm_seq pg _ (v1 :: stk) _ (env_to_mem env)
      _ _ _ (length pg1 +
              length (compile_aexp (map fst env) e1))%nat Pec1).
    easy.
  rewrite (exec_asm_seq _ _ (v2 :: v1 :: stk) _ (env_to_mem env)
            _ _ _ _ both_exp).
  unfold pg; simpl.
  rewrite 2!app_assoc.
  rewrite nth_error_app2;[ | now rewrite !app_length; auto with arith].
  rewrite !app_length, Nat.sub_diag; simpl.
  assert (cmpv : v2 <=? v1 = false) by now rewrite Z.leb_gt.
  now rewrite cmpv, !Nat.add_assoc.

destruct (exec_aexp env e1 v1 pg1
             (compile_aexp (map fst env) e2 ++ [cmp] ++ pg2)
                    stk ev1) as [ec1 Pec1].
destruct (exec_aexp env e2 v2 (pg1 ++
             compile_aexp (map fst env) e1) ([cmp] ++ pg2)
              (v1 :: stk) ev2) as [ec2 Pec2].
revert Pec1 Pec2; simpl; rewrite <-!app_assoc; simpl; set (pg := pg1 ++ _).
rewrite app_length.
intros Pec1 Pec2; exists (ec1 + ec2 + 1)%nat.
assert
    (both_exp : exec_asm (ec1 + ec2) pg stk (env_to_mem env) (length pg1) =
    (v2 :: v1 :: stk, env_to_mem env,
    (length pg1 + length (compile_aexp (map fst env) e1) +
     length (compile_aexp (map fst env) e2)))%nat).
  rewrite (exec_asm_seq pg _ (v1 :: stk) _ (env_to_mem env)
      _ _ _ (length pg1 +
             length (compile_aexp (map fst env) e1))%nat Pec1).
  easy.
rewrite (exec_asm_seq _ _ (v2 :: v1 :: stk) _ (env_to_mem env)
            _ _ _ _ both_exp).
unfold pg; simpl.
rewrite 2!app_assoc.
rewrite nth_error_app2;[ | now rewrite !app_length; auto with arith].
rewrite !app_length, Nat.sub_diag; simpl.
assert (cmpv : v2 <=? v1 = true) by now rewrite Z.leb_le.
now rewrite cmpv, !Nat.add_assoc.
Qed.

Lemma update_set_nth : forall r x v r',
  s_update r x v r' ->
  set_nth (env_to_mem r)
             (symbol_index (map fst r) x) v = (env_to_mem r').
Proof.
induction 1 as [env x v v' | env env' x y v v' upd Ih xny].
  simpl.
  now destruct (S.string_dec x x) as [_ | abs];[ | now case abs].
simpl.
destruct (S.string_dec x y) as [abs | _];[ now case xny |].
now rewrite Ih.
Qed.

Lemma update_index r x v r' :
  s_update r x v r' -> map fst r = map fst r'.
Proof.
induction 1 as [r x v v' | r r' x y v v' up Ih xny].
  easy.
now simpl; rewrite Ih.
Qed.

Lemma exec_fst_inv r i1 r' :
  exec r i1 r' -> map fst r = map fst r'.
Proof.
induction 1 as [ | r r' x a v ev up |
   r r' r'' i1 i2 ex1 Ih1 ex2 Ih2 | r r' r'' b i ev ex1 Ih1 ex2 Ih2 | ]; auto.
- now apply (update_index _ _ _ _ up).
- now rewrite <- Ih2.
- now rewrite <- Ih2.
Qed.

Lemma compile_instr_complete :
  forall env env' i pg1 pg2 stk,
  exec env i env' ->
  exists ec,
  exec_asm ec
     (pg1 ++ compile_instr (map fst env) (length pg1) i ++ pg2)
       stk (env_to_mem env) (length pg1) =
  (stk, env_to_mem env',
   (length pg1 + length (compile_instr (map fst env) (length pg1) i))%nat).
Proof.
intros env env' i pg1 pg2 stk dyn; revert pg1 pg2 stk.
induction dyn as [ | env env' x e v ev up |
   env env' env'' i1 i2 dyn1 Ih1 dyn2 Ih2|
   env env' env''  [e1 e2] i ev dyn1 Ih1 dyn2 Ih2 | env [e1 e2] i ev ].
        intros pg1 pg2 stk.
        now exists 0%nat; simpl; rewrite Nat.add_0_r.
      intros pg1 pg2 stk.
      destruct
         (exec_aexp env e v pg1
              (store (symbol_index (map fst env) x) :: pg2) stk) as
        [ec Pec]; auto.
      exists (ec + 1)%nat.
      simpl; rewrite <-!app_assoc; simpl; set (pg := pg1 ++ _).
      fold pg in Pec.
      assert (t1 := exec_asm_seq pg _ _ _ _ _ 1 _ _ Pec).
      rewrite t1; unfold pg; simpl; rewrite nth_error_app2; [ | lia].
      rewrite minus_plus, <- (Nat.add_0_r (length _)).
      rewrite nth_error_app2;[ | lia].
      rewrite minus_plus; simpl.
      assert (t2 := update_set_nth _ _ _ _ up).
      now rewrite t2, app_length, Nat.add_0_r, Nat.add_assoc.
    intros pg1 pg2 stk.
    destruct (Ih1 pg1
               (compile_instr (map fst env)
                  (length pg1 +
                   length (compile_instr (map fst env) (length pg1) i1))
                   i2 ++ pg2) stk) as [ec1 Pec1].
    revert Pec1; set (pg := (pg1 ++ _)); intros Pec1.
    destruct (Ih2 (pg1 ++ compile_instr (map fst env) (length pg1) i1) pg2 stk)
        as [ec2 Pec2].
    revert Pec2; rewrite <-!app_assoc, app_length.
    rewrite <- (exec_fst_inv  _ _ _ dyn1); fold pg; intros Pec2.
    simpl; rewrite <-!app_assoc, !app_length; fold pg.
    exists (ec1 + ec2)%nat.
    assert (t1 := exec_asm_seq pg _ _ _ _ _ ec2 _ _ Pec1).
    now rewrite t1, Pec2; rewrite !Nat.add_assoc.
  intros pg1 pg2 stk.
  cbn [compile_instr compile_bexp].
  rewrite !app_length, !Nat.add_assoc, <-! app_assoc.
  repeat simpl (length [_]).
  set (middle_pc := (_ + 1 + 1)%nat).
  set (last_pc := (_ + 2)%nat).
  change (branch last_pc :: compile_instr (map fst env) middle_pc i
              ++ [goto (length pg1)])
     with
   ([branch last_pc] ++ compile_instr (map fst env) middle_pc i
              ++ [goto (length pg1)]).
  rewrite <-!app_assoc.
  set (pg := pg1 ++ _).
  destruct (exec_bexp _ _ _ _ pg1
              ([branch last_pc] ++
               compile_instr (map fst env) (length pg1 +
                 length (compile_bexp (map fst env) (blt e1 e2)) + 1) i
                ++ [goto (length pg1)] ++ pg2) stk ev) as [ec1 Pec1].
  revert Pec1; cbn [compile_instr compile_bexp].
  rewrite !app_length, !Nat.add_assoc, <- !app_assoc.
  simpl (length [ _ ]); fold middle_pc; fold pg; intros Pec1.
  destruct (Ih1 (pg1 ++ compile_bexp (map fst env) (blt e1 e2)
               ++ [branch last_pc])
              ([goto (length pg1)] ++ pg2) stk) as [ec2 Pec2].
  revert Pec2; cbn [compile_instr compile_bexp].
  rewrite !app_length, !Nat.add_assoc, <- !app_assoc.
  simpl (length [cmp]); simpl (length [branch _]).
  fold middle_pc; fold pg; intros Pec2.
  destruct (Ih2 pg1 pg2 stk) as [ec3 Pec3].
  revert Pec3; cbn [compile_instr compile_bexp].
  rewrite !app_length, !Nat.add_assoc, <- !app_assoc.
  simpl (length [cmp]); simpl (length [branch _]).
  rewrite <- ! (exec_fst_inv _ _ _ dyn1).
  fold middle_pc; fold last_pc.
  change (branch last_pc :: compile_instr (map fst env) middle_pc i ++
          [goto (length pg1)]) with
     ([branch last_pc] ++ compile_instr (map fst env) middle_pc i ++
          [goto (length pg1)]).
  rewrite <- !app_assoc; fold pg; intros Pec3.
  exists (ec1 + (1 + (ec2 + (1 + ec3))))%nat.
  rewrite (exec_asm_seq pg _ (Z.b2z (negb true) :: stk) _ _ _ _ _ _ Pec1).
  rewrite (exec_asm_seq pg (Z.b2z (negb true) :: stk) stk (env_to_mem env)
             (env_to_mem env) 1 (ec2 + (1 + ec3))
             (length pg1 + length (compile_aexp (map fst env) e1) +
                  length (compile_aexp (map fst env) e2) + 1) middle_pc);
         cycle 1.
    simpl; unfold pg; rewrite <-!Nat.add_assoc.
    repeat (rewrite nth_error_app2, minus_plus; [ | lia]).
    now simpl; rewrite !Nat.add_assoc.
  rewrite (exec_asm_seq pg _ stk _ _ _ _ _ _ Pec2).
  rewrite (exec_asm_seq pg stk stk (env_to_mem env')
             (env_to_mem env') 1 ec3 _ (length pg1)); cycle 1.
    simpl; unfold pg, middle_pc; rewrite <-!Nat.add_assoc.
    repeat (rewrite nth_error_app2, minus_plus; [ | lia]).
    simpl.
    repeat (rewrite nth_error_app2, minus_plus; [ | lia]).
    simpl.
    set (L := length (compile_instr _ _ _)); rewrite <- (Nat.add_0_r L).
    unfold L.
    repeat (rewrite nth_error_app2, minus_plus; [ | lia]).
    easy.
  rewrite Pec3; unfold middle_pc; rewrite !app_length; simpl (length [_]).
  now rewrite !Nat.add_assoc.
intros pg1 pg2 stk.
cbn [compile_instr compile_bexp].
rewrite !app_length, !Nat.add_assoc, <-! app_assoc.
repeat simpl (length [_]).
set (middle_pc := (_ + 1 + 1)%nat).
set (last_pc := (_ + 2)%nat).
change (branch last_pc :: compile_instr (map fst env) middle_pc i
    ++ [goto (length pg1)])
    with
 ([branch last_pc] ++ compile_instr (map fst env) middle_pc i
    ++ [goto (length pg1)]).
rewrite <-!app_assoc.
set (pg := pg1 ++ _).
destruct (exec_bexp _ _ _ _ pg1
            ([branch last_pc] ++
             compile_instr (map fst env) (length pg1 +
               length (compile_bexp (map fst env) (blt e1 e2)) + 1) i
              ++ [goto (length pg1)] ++ pg2) stk ev) as [ec1 Pec1].
revert Pec1; cbn [compile_instr compile_bexp].
rewrite !app_length, !Nat.add_assoc, <- !app_assoc.
simpl (length [ _ ]); fold middle_pc; fold pg; intros Pec1.
exists (ec1 + 1)%nat.
rewrite (exec_asm_seq _ _ (Z.b2z (negb false) :: stk) _ _ _ 1 _ _ Pec1).
simpl.
unfold pg; rewrite <-!Nat.add_assoc.
repeat (rewrite nth_error_app2, minus_plus; [ | lia]).
simpl.
unfold last_pc, middle_pc.
apply f_equal; lia.
Qed.

End compiler_proofs.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Normalisation functions for rational numbers. *)

Require Export QArith_base.
Require Import Zgcd_def Znumtheory.

(** First, a function that (tries to) build a positive back from a Z. *)

Definition Z2P (z : Z) :=
  match z with
  | Z0 => 1%positive
  | Zpos p => p
  | Zneg p => p
  end.

Lemma Z2P_correct : forall z : Z, (0 < z)%Z -> Zpos (Z2P z) = z.
Proof.
 simple destruct z; simpl in |- *; auto; intros; discriminate.
Qed.

Lemma Z2P_correct2 : forall z : Z, 0%Z <> z -> Zpos (Z2P z) = Zabs z.
Proof.
 simple destruct z; simpl in |- *; auto; intros; elim H; auto.
Qed.

(** Simplification of fractions using [Zgcd].
  This version can compute within Coq. *)

Definition Qred (q:Q) :=
  let (q1,q2) := q in
  let (r1,r2) := snd (Zggcd q1 ('q2))
  in r1#(Z2P r2).

Lemma Qred_correct : forall q, (Qred q) == q.
Proof.
  unfold Qred, Qeq; intros (n,d); simpl.
  generalize (Zggcd_gcd n ('d)) (Zgcd_nonneg n ('d))
    (Zggcd_correct_divisors n ('d)).
  destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl.
  Open Scope Z_scope.
  intros Hg LE (Hn,Hd). rewrite Hd, Hn.
  rewrite <- Hg in LE; clear Hg.
  assert (0 <> g) by (intro; subst; discriminate).
  rewrite Z2P_correct. ring.
  apply Zmult_gt_0_lt_0_reg_r with g; auto with zarith.
  now rewrite Zmult_comm, <- Hd.
  Close Scope Z_scope.
Qed.

Lemma Qred_complete : forall p q,  p==q -> Qred p = Qred q.
Proof.
  intros (a,b) (c,d).
  unfold Qred, Qeq in *; simpl in *.
  Open Scope Z_scope.
  generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
    (Zgcd_nonneg a ('b)) (Zggcd_correct_divisors a ('b)).
  destruct (Zggcd a (Zpos b)) as (g,(aa,bb)).
  generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d))
    (Zgcd_nonneg c ('d)) (Zggcd_correct_divisors c ('d)).
  destruct (Zggcd c (Zpos d)) as (g',(cc,dd)).
  simpl.
  intro H; rewrite <- H; clear H.
  intros Hg'1 Hg'2 (Hg'3,Hg'4).
  intro H; rewrite <- H; clear H.
  intros Hg1 Hg2 (Hg3,Hg4).
  intros.
  assert (g <> 0) by (intro; subst g; discriminate).
  assert (g' <> 0) by (intro; subst g'; discriminate).

  elim (rel_prime_cross_prod aa bb cc dd).
  congruence.
  unfold rel_prime in |- *.
  (*rel_prime*)
  constructor.
  exists aa; auto with zarith.
  exists bb; auto with zarith.
  intros.
  inversion Hg1.
  destruct (H6 (g*x)).
  rewrite Hg3.
  destruct H2 as (xa,Hxa); exists xa; rewrite Hxa; ring.
  rewrite Hg4.
  destruct H3 as (xb,Hxb); exists xb; rewrite Hxb; ring.
  exists q.
  apply Zmult_reg_l with g; auto.
  pattern g at 1; rewrite H7; ring.
  (* /rel_prime *)
  unfold rel_prime in |- *.
  (* rel_prime *)
  constructor.
  exists cc; auto with zarith.
  exists dd; auto with zarith.
  intros.
  inversion Hg'1.
  destruct (H6 (g'*x)).
  rewrite Hg'3.
  destruct H2 as (xc,Hxc); exists xc; rewrite Hxc; ring.
  rewrite Hg'4.
  destruct H3 as (xd,Hxd); exists xd; rewrite Hxd; ring.
  exists q.
  apply Zmult_reg_l with g'; auto.
  pattern g' at 1; rewrite H7; ring.
    (* /rel_prime *)
  assert (0<bb); [|auto with zarith].
  apply Zmult_gt_0_lt_0_reg_r with g.
  omega.
  rewrite Zmult_comm.
  rewrite <- Hg4; compute; auto.
  assert (0<dd); [|auto with zarith].
  apply Zmult_gt_0_lt_0_reg_r with g'.
  omega.
  rewrite Zmult_comm.
  rewrite <- Hg'4; compute; auto.
  apply Zmult_reg_l with (g'*g).
  intro H2; elim (Zmult_integral _ _ H2); auto.
  replace (g'*g*(aa*dd)) with ((g*aa)*(g'*dd)); [|ring].
  replace (g'*g*(bb*cc)) with ((g'*cc)*(g*bb)); [|ring].
  rewrite <- Hg3; rewrite <- Hg4; rewrite <- Hg'3; rewrite <- Hg'4; auto.
  Close Scope Z_scope.
Qed.

Add Morphism Qred : Qred_comp.
Proof.
  intros q q' H.
  rewrite (Qred_correct q); auto.
  rewrite (Qred_correct q'); auto.
Qed.

Definition Qplus' (p q : Q) := Qred (Qplus p q).
Definition Qmult' (p q : Q) := Qred (Qmult p q).
Definition Qminus' x y := Qred (Qminus x y).

Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q).
Proof.
  intros; unfold Qplus' in |- *; apply Qred_correct; auto.
Qed.

Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q).
Proof.
  intros; unfold Qmult' in |- *; apply Qred_correct; auto.
Qed.

Lemma Qminus'_correct : forall p q : Q, (Qminus' p q)==(Qminus p q).
Proof.
  intros; unfold Qminus' in |- *; apply Qred_correct; auto.
Qed.

Add Morphism Qplus' : Qplus'_comp.
Proof.
  intros; unfold Qplus' in |- *.
  rewrite H; rewrite H0; auto with qarith.
Qed.

Add Morphism Qmult' : Qmult'_comp.
  intros; unfold Qmult' in |- *.
  rewrite H; rewrite H0; auto with qarith.
Qed.

Add Morphism Qminus' : Qminus'_comp.
  intros; unfold Qminus' in |- *.
  rewrite H; rewrite H0; auto with qarith.
Qed.

Lemma Qred_opp: forall q, Qred (-q) = - (Qred q).
Proof.
  intros (x, y); unfold Qred; simpl.
  rewrite Zggcd_opp; case Zggcd; intros p1 (p2, p3); simpl.
  unfold Qopp; auto.
Qed.

Theorem Qred_compare: forall x y,
  Qcompare x y = Qcompare (Qred x) (Qred y).
Proof.
  intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct.
Qed.


Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

Section str_def.

Variable A : Set.

CoInductive str (A: Set) : Set :=
  SCons: A -> str A ->  str A.

Definition hd (s : str A) : A :=
   match s with SCons _ x s' => x end.

Definition tl (s : str A) : str A :=
   match s with SCons _ x s' => s' end.

Definition str_decompose (s : str A) : str A:=
   match s with SCons _ x s' => SCons A x s' end.

Theorem st_dec_eq: forall (s : str A),  s = str_decompose s.
intros s; case s; auto.
Qed.

Ltac str_unfold term :=
apply trans_equal with (1 := st_dec_eq term).

Fixpoint str_decomp_n (n: nat) (s: str A){struct n}: str A :=
match n, s with
O, s' => s'|
S n', SCons _ x s' => SCons A x (str_decomp_n n' s')
end.

Print str_decomp_n.

Theorem str_decompose_n_lemma :
forall (n:nat)(s: str A), s = str_decomp_n n s.
induction n; intros.
simpl; trivial.
case s.
simpl; trivial.
intros.
rewrite <- IHn.
trivial.
Qed.

Section def_filter.
Variables (P : A ->  Prop) (P_dec : forall x,  ({ P x }) + ({ ~ P x })).

Inductive eventually_s : str A ->  Prop :=
  ev_b: forall x s, P x ->  eventually_s (SCons A x s)
 | ev_r: forall x s, ~ P x -> eventually_s s ->  eventually_s (SCons A x s) .

Definition eventually_s_inv:
 forall (s : str A),
 eventually_s s -> forall x s', s = SCons A x s' -> ~ P x ->  eventually_s s'.
intros s h. case h.
intros x s0 H x0 s' H0 H1. elim H1. injection H0. intros; subst x0; auto.
intros x s0 H3 H x0 s' H0 H1; injection H0; intros; subst s'; assumption.
Defined.

(*the following is slightly changed comapring with Bert05:*)

Fixpoint pre_filter_s (s : str A) (h : eventually_s s) {struct h} : A * str A
 :=
 match s as b return s = b ->  A*str A with
    SCons _ x s' =>
      fun heq =>
         match P_dec x with
           left _ => (x, s')
          | right hn => pre_filter_s s' (eventually_s_inv s h x s' heq hn)
         end
 end (refl_equal s).

Check pre_filter_s.

(*the following is generalised:*)

CoInductive infinite_s : str A ->  Prop :=
  al_cons:
    forall (s: str A) (h: eventually_s s),
     infinite_s (snd(pre_filter_s s h)) ->  infinite_s s.

(*the following is new:*)

Lemma infinite_eventually_s : forall s, infinite_s s -> eventually_s s.
intros s H; case H; auto.
Qed.

Scheme eventually_s_ind2 := Induction for eventually_s Sort Prop.

Lemma pre_filter_s_prf_irrelevant :
  forall s (h h':eventually_s s), pre_filter_s s h = pre_filter_s s h'.
induction h using eventually_s_ind2.
intros h0.
apply (eventually_s_ind2 (fun s' t =>
    match s' with SCons _ a b => b end = s ->
    match s' with SCons _ a b => a end = x ->
    pre_filter_s (SCons A x s) (ev_b x s p) = pre_filter_s s' t)); auto.
intros x0 s0 p0 Hs0 Hx0; subst s0 x0; simpl.
case (P_dec x); auto.
intros; contradiction.
intros; subst x0; contradiction.
intros h0.
apply (eventually_s_ind2 (fun s' t =>
    match s' with SCons _ a b => b end = s ->
    match s' with SCons _ a b => a end = x ->
    pre_filter_s (SCons A x s) (ev_r x s n h) = pre_filter_s s' t)); auto.
intros; subst x; contradiction.
intros x0 s0 Hn He Hr Hs0 Hx0; subst s0 x0; simpl.
case (P_dec x); auto.
Qed.

Lemma F_inf_reverse:
forall (s: str A)(h:eventually_s s),
infinite_s s -> infinite_s (snd (pre_filter_s s h)).
intros s h H'; inversion H'.
rewrite (pre_filter_s_prf_irrelevant s h h0); auto.

Qed.

Theorem infinite_always_s:
forall (s:str A) (h:infinite_s s), infinite_s (snd (pre_filter_s s (infinite_eventually_s s h))).
intros s h; case h.
intros s0 h0; case h0.
intros.
rewrite (pre_filter_s_prf_irrelevant (SCons A x s1) (infinite_eventually_s (SCons A x s1)
              (al_cons (SCons A x s1) (ev_b x s1 p) i)) (ev_b x s1 p)); auto.
intros.
rewrite (pre_filter_s_prf_irrelevant (SCons A x s1)(infinite_eventually_s (SCons A x s1)
              (al_cons (SCons A x s1) (ev_r x s1 n e) i))(ev_r x s1 n e)); auto.
Qed.

CoFixpoint filter (s : str A) : forall (h: infinite_s s), str A :=
  match s return infinite_s s -> str A with
  | SCons _ x s' =>
      fun h' : infinite_s (SCons A x s') =>
      SCons A
        (fst (pre_filter_s (SCons A x s')
              (infinite_eventually_s (SCons A x s') h')))
        (filter
           (snd (pre_filter_s (SCons A x s')
                 (infinite_eventually_s (SCons A x s') h')))
           (infinite_always_s (SCons A x s') h'))
  end.

(*CoFixpoint filter (s : str A): forall (h:infinite_s s), str A :=
  match s return infinite_s s -> str A with
  | SCons A x s' => fun h' : infinite_s (SCons A x s') =>
        SCons A (fst (pre_filter_s (SCons A x s') (infinite_eventually_s  (SCons A x s')  h'))) (filter (SCons A x s') (infinite_always_s (SCons A x s') h'))
   end.
*)

Lemma s_step1 : forall s x, infinite_s (SCons A x s) -> infinite_s s.
intros s x hf; inversion hf.
generalize H; clear H; dependent inversion h.
simpl.
case P_dec.
intros; auto.
intros; elim n; auto.
simpl.
case P_dec.
intros; auto.
intros; auto.
apply al_cons with e; assumption.
Qed.

CoInductive bisimilar:  str A -> str A -> Prop :=
|bisim: forall (a : A) (s s' : str A), bisimilar s s' -> bisimilar (SCons A a s)(SCons A a s').

Require Import Relation_Definitions.
Require Import Relation_Operators.
Require Import Operators_Properties.

Theorem Bisim_refl: forall (s : str A), bisimilar s s.
cofix H.
intros.
case s.
intros.
apply bisim.
apply H.
Qed.

Theorem Bisim_trans: forall (l u v: str A),
 bisimilar  l u -> bisimilar u v -> bisimilar l v.
cofix H.
intros l u v.
case l; case u; case v.
intros.
assert (a1 = a0).
inversion H0; auto.
assert (a = a0).
inversion H1; auto.
assert (a1 = a).
apply trans_equal with a0; auto.
rewrite H4.
apply bisim.
apply H with s0.
Guarded.
inversion H0; assumption.
inversion H1; assumption.
Qed.

Lemma misc3: forall (x: A) (s: str A) (H: eventually_s (SCons A x s)),   P x -> (x, s) = (pre_filter_s (SCons A x s) H).
intros x s h h0.
dependent inversion h.
apply trans_equal with (pre_filter_s (SCons A x s) h).
apply sym_equal.
unfold pre_filter_s.
dependent inversion h; case P_dec; auto;
intro; contradiction.
rewrite (pre_filter_s_prf_irrelevant (SCons A x s) (h)(ev_b x s p)); auto.
contradiction.
Qed.

Lemma misc3': forall (x:A) (s: str A) (H: eventually_s (SCons A x s)),  P x -> x = fst (pre_filter_s (SCons A x s) H).
intros.
assert ((x,s) = pre_filter_s (SCons A x s) H).
apply misc3; assumption.
rewrite <- H1; auto.
Qed.

Lemma misc3'': forall (x: A) (s: str A) (H: eventually_s (SCons A x s)),   P x ->  snd (pre_filter_s (SCons A x s) H) = s.
intros x s h h0.
assert ((x,s) = pre_filter_s (SCons A x s) h).
apply misc3; assumption.
rewrite <- H; auto.
Qed.
(*Lemma F_inf_step1_always: forall (x: A) (s: str A)(h: infinite_s (SCons A x s)), P x ->
 infinite_always_s h = s_step1 h.
*)

Lemma filter_prf_irrelevant :
  forall s s' (h : infinite_s s) (h':infinite_s s'), s = s' -> bisimilar (filter s h) (filter s' h').
cofix H.
intros [a s][a' s'] h h' Hss'; injection Hss'; clear Hss'; intros Hss' Haa'.
rewrite (st_dec_eq (filter (SCons A a s) h)); simpl.
rewrite (st_dec_eq (filter (SCons A a' s') h')); simpl.
assert (pre_filter_s (SCons A a s) (infinite_eventually_s (SCons A a s) h) = pre_filter_s (SCons A a' s') (infinite_eventually_s (SCons A a' s') h')).
generalize h'; clear h'; rewrite <- Haa'; rewrite <- Hss'; intros h'.
rewrite (pre_filter_s_prf_irrelevant (SCons A a s) (infinite_eventually_s (SCons A a s) h)
              (infinite_eventually_s (SCons A a s) h')); auto.
pattern (pre_filter_s (SCons A a s) (infinite_eventually_s (SCons A a s) h)) at 1; rewrite H0.
apply bisim.
apply H.
rewrite H0; auto.
Qed.

Lemma pre_filter_prf_irrelevant_neg: forall x s (h: eventually_s (SCons A x s)) (h': eventually_s s), ~ P x ->
pre_filter_s (SCons A x s)  h = pre_filter_s s h'.
intros x [a s] h h' n.
generalize (refl_equal (SCons A a s)).
intro q.
dependent inversion h.
contradiction.
simpl.
case P_dec.
intro; contradiction.
intro; apply pre_filter_s_prf_irrelevant.
Qed.

Lemma filter_prf_irrelevant_neg :
  forall (x:A) (s: str A) (h : infinite_s (SCons A x s)),  ~ P x ->
bisimilar (filter (SCons A x s) h) (filter s (s_step1 s x h)).
intros x [a s] h n.
rewrite (st_dec_eq (filter (SCons A x (SCons A a s)) h)); simpl str_decompose.
rewrite (st_dec_eq (filter (SCons A a s) (s_step1 (SCons A a s) x h))); simpl str_decompose.
assert (infinite_s (SCons A a s)).
apply s_step1 with x; assumption.
assert (eventually_s (SCons A a s)).
apply infinite_eventually_s; assumption.
assert (eventually_s (SCons A x (SCons A a s))).
apply infinite_eventually_s; assumption.
pattern (pre_filter_s (SCons A a s) (infinite_eventually_s (SCons A a s) (s_step1 (SCons A a s) x h))) at 1.
rewrite (pre_filter_s_prf_irrelevant (SCons A a s) (infinite_eventually_s (SCons A a s) (s_step1 (SCons A a s) x h)) H0).
assert (pre_filter_s (SCons A x (SCons A a s)) H1 = pre_filter_s (SCons A a s) H0).
apply pre_filter_prf_irrelevant_neg; assumption.
rewrite <- H2.
assert (pre_filter_s (SCons A x (SCons A a s)) (infinite_eventually_s (SCons A x (SCons A a s)) h) = pre_filter_s (SCons A x (SCons A a s)) H1).
apply pre_filter_s_prf_irrelevant.
rewrite <- H3.
apply bisim.
apply Bisim_trans with (filter
        (snd(pre_filter_s (SCons A a s) (infinite_eventually_s (SCons A a s) H)))
        (infinite_always_s (SCons A a s) H)).
apply filter_prf_irrelevant.
assert ((pre_filter_s (SCons A x (SCons A a s))
        (infinite_eventually_s (SCons A x (SCons A a s)) h)) =
     (pre_filter_s (SCons A a s) (infinite_eventually_s (SCons A a s) H))).
apply pre_filter_prf_irrelevant_neg; assumption.
rewrite H4; auto.
apply filter_prf_irrelevant.
assert ((pre_filter_s (SCons A a s) (infinite_eventually_s (SCons A a s) H))
     = (pre_filter_s (SCons A a s)
        (infinite_eventually_s (SCons A a s) (s_step1 (SCons A a s) x h)))).
apply pre_filter_s_prf_irrelevant.
rewrite H4; auto.
Qed.

Theorem filter_equation:
   forall (s : str A) (h : infinite_s s),
   bisimilar (filter s h)
     (match s return (infinite_s s -> str A) with
      | SCons _ x s' =>
          fun h0 : infinite_s (SCons A x s') =>
          match P_dec x return str A with
          | left _ => SCons A x (filter s' (s_step1 s' x h0))
          | right _ => filter s' (s_step1 s' x h0)
          end
      end h).
intros s h.
case h; intros.
induction h0 using eventually_s_ind2; case P_dec.
intro.
rewrite (st_dec_eq (filter (SCons A x s0) (al_cons (SCons A x s0) (ev_b x s0 p) i))); simpl.
assert ( x =
     (fst (pre_filter_s (SCons A x s0)
           (infinite_eventually_s (SCons A x s0)
              (al_cons (SCons A x s0) (ev_b x s0 p) i))))).
assert (eventually_s (SCons A x s0)).
apply ev_b; assumption.
assert (infinite_s (SCons A x s0)).
apply al_cons with H.
assert (pre_filter_s (SCons A x s0) H = pre_filter_s (SCons A x s0) (ev_b x s0 p)).
rewrite (pre_filter_s_prf_irrelevant (SCons A x s0)(H)
              (ev_b x s0 p)); auto.
rewrite H0; assumption.
apply trans_equal with (fst (pre_filter_s (SCons A x s0) H)).
generalize p0.
apply misc3'; auto.
rewrite (pre_filter_s_prf_irrelevant (SCons A x s0) (H)
              (infinite_eventually_s (SCons A x s0) (al_cons (SCons A x s0) (ev_b x s0 p) i))); auto.
rewrite <- H.
apply bisim.
apply filter_prf_irrelevant.
inversion i.
assert (eventually_s (SCons A x s0)).
apply ev_b; assumption.
apply trans_equal with (snd (pre_filter_s (SCons A x s0) H2)).
rewrite (pre_filter_s_prf_irrelevant (SCons A x s0) (infinite_eventually_s (SCons A x s0) (al_cons (SCons A x s0) (ev_b x s0 p) i)) (H2)); auto.
apply misc3''; auto.
intro; contradiction.
intro; contradiction.
intro.
apply filter_prf_irrelevant_neg; auto.
Qed.

End def_filter.

End str_def.