Require Import List ZArith Znumtheory Int31 Cyclic31.

(* We are going to implement modular arithmetic with
   montgomery reduction
*)

Definition number := list int31.

Definition nhead (n : number) :=
  match n with cons i _ => i | _ => 0%int31 end.

Definition ntail (n : number) : number :=
  match n with cons _ t => t | _ => @nil _ end.

Open Scope int31_scope.

Fixpoint positive_aux_to_num (p : positive) (i j : int31) : number :=
  match p with
  | xH    => (i + j) :: nil
  | xO p1 =>
    let i1 := 2 * i in
    match i1 ?= 0 with
    | Gt => positive_aux_to_num  p1 i1 j
    | _  =>  j :: positive_aux_to_num  p1 1 0
    end
  | xI p1 =>
    let i1 := 2 * i in
    let j1 := i + j in
    match i1 ?= 0 with
    | Gt => positive_aux_to_num  p1 i1 j1
    | _  =>  j1 :: positive_aux_to_num  p1 1 0
    end
  end.

Definition positive_to_num (p : positive) : number :=
  positive_aux_to_num p 1 0.

Definition Z_to_num z :=
  match z with
  | Zpos p => positive_to_num p
  | _      => nil
  end.

Eval vm_compute in
  positive_to_num 31415926535897932384626433.

Eval vm_compute in
  positive_to_num 2147483648.

Let wB := (2^ Z_of_nat size)%Z.
Definition mphi (n : number) :=
  fold_right (fun i r => phi i + wB * r )%Z 0%Z n.

Notation "[ a ]" := (mphi a).

Eval vm_compute in
  [positive_to_num 31415926535897932384626433].

Lemma phi_nil : [nil] = 0%Z.
Proof. auto. Qed.

Lemma phi_cons a l : ([a::l] = phi a + wB * [l])%Z.
Proof. auto. Qed.

Lemma phi_head_tail n : [n] = [nhead n :: ntail n].
Proof. unfold nhead, ntail; case n; auto. Qed.

Ltac nrom :=
 repeat rewrite phi_nil;
 repeat rewrite phi_cons;
 try change (phi 0) with 0%Z;
 try change (phi 1) with 1%Z;
 try change (phi 2) with 2%Z;
 try change (phi Tn) with (wB - 1)%Z;
 try change (2^ Z_of_nat size)%Z with wB.

Lemma Zpower_nat_0 x : Zpower_nat x 0 = 1%Z.
Proof. auto. Qed.

Lemma Zpower_nat_S x n : Zpower_nat x (S n) =  (x * Zpower_nat x n)%Z.
Proof. auto. Qed.

Lemma Zpower_nat_pos u n : (0 < u -> 0  < Zpower_nat u n)%Z.
Proof.
intros Hu.
induction n; simpl; try rewrite Zpower_nat_S;
   try rewrite Zpower_nat_0; auto with zarith.
apply Zmult_lt_0_compat; auto.
Qed.

Lemma Zpower_base_pos n : (0  < Zpower_nat wB n)%Z.
Proof. apply Zpower_nat_pos; auto with zarith; red; auto. Qed.

Lemma Zpower_nat_le_compat u n m :
  (0 < u)%Z -> (n <= m)%nat -> (Zpower_nat u n  <= Zpower_nat u m)%Z.
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros _; change 1%Z with (1 * 1)%Z; apply Zmult_le_compat; auto with zarith.
generalize (Zpower_nat_pos _ m Hu); auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
Qed.

Lemma Zpower_nat_lt_compat u n m :
  (1 < u)%Z -> (n < m)%nat -> (Zpower_nat u n  < Zpower_nat u m)%Z.
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros _; apply Zlt_le_trans with (u * 1)%Z; auto with zarith.
assert (Hv: (0 < u)%Z); auto with zarith.
generalize (Zpower_nat_pos _ m Hv); auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros HH.
apply Zmult_lt_compat_l; auto with zarith.
Qed.

Lemma Zpower_nat_le_reg u n m :
  (1 < u)%Z -> (Zpower_nat u n  <= Zpower_nat u m)%Z -> (n <= m)%nat .
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0.
intros Hv; contradict Hv; apply Zlt_not_le.
apply Zlt_le_trans with (u * 1)%Z; auto with zarith.
assert (HH: (0 < u)%Z); auto with zarith.
assert (HH1:= Zpower_nat_pos u n HH); auto with zarith.
intros Hv; assert (n <= m)%nat; auto with arith.
apply Hrec; apply Zmult_le_reg_r with u; auto with zarith;
  repeat rewrite <- (Zmult_comm u); auto.
Qed.

Lemma Zpower_nat_lt_reg u n m :
  (1 < u)%Z -> (Zpower_nat u n  < Zpower_nat u m)%Z -> (n < m)%nat .
Proof.
intros Hu; generalize m; clear m; induction n as [ | n Hrec]; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros [ | m]; repeat rewrite Zpower_nat_S; try rewrite Zpower_nat_0; auto with zarith.
intros Hv; contradict Hv; apply Zle_not_lt.
apply Zle_trans with (u * 1)%Z; auto with zarith.
assert (HH: (0 < u)%Z); auto with zarith.
assert (HH1:= Zpower_nat_pos u n HH); auto with zarith.
intros Hv; assert (n < m)%nat; auto with arith.
apply Hrec; apply Zmult_lt_reg_r with u; auto with zarith;
  repeat rewrite <- (Zmult_comm u); auto.
Qed.

Lemma positive_phi p : [positive_to_num p] = Zpos p.
Proof.
assert (Hi0: (forall i n, phi i = Zpower_nat 2 n ->
              match 2 * i ?= 0 with
              | Eq => n = 30%nat
              | Lt => False
              | Gt => phi (2 * i) = Zpower_nat 2 (S n)
              end)).
intros i n Hi.
  assert (n < 31)%nat.
  case (phi_bounded i); nrom; rewrite Hi; intros Hi1 Hi2.
  apply Zpower_nat_lt_reg with 2%Z; auto with zarith.
assert (HH1: (0 < 2)%Z); auto with zarith.
assert (HH2 := Zpower_nat_pos _ (S n) HH1).
rewrite spec_compare; case Z.compare_spec.
rewrite spec_mul; nrom.
rewrite Hi, <- Zpower_nat_S; auto with zarith.
case (le_lt_or_eq n 30); auto with zarith; intros HH3.
rewrite Zmod_small; auto with zarith.
split; auto with zarith.
change wB with (Zpower_nat 2 31); apply Zpower_nat_lt_compat; auto with zarith.
intros HH; contradict HH.
case (phi_bounded (2 * i)); nrom; auto with zarith.
rewrite spec_mul; nrom; rewrite Hi, <- Zpower_nat_S; auto with zarith.
case (le_lt_or_eq n 30); auto with zarith; intros HH3.
rewrite Zmod_small; nrom; auto with zarith.
split; auto with zarith.
change wB with (Zpower_nat 2 31); apply Zpower_nat_lt_compat; auto with zarith.
rewrite HH3, Z_mod_same; auto with zarith.
apply Zlt_gt; auto with zarith.
assert (Hij: (forall i j n, phi i = Zpower_nat 2 n -> phi j < phi i ->
             phi (i + j) = phi i + phi j)%Z).
intros i j n Hi Hj.
  rewrite spec_add, Zmod_small; auto; nrom.
  case (phi_bounded i); case (phi_bounded j); nrom; intros H1j H2j H1i H2i;
   split; auto with zarith.
  assert (n < 31)%nat.
  apply Zpower_nat_lt_reg with 2%Z; auto with zarith.
  rewrite <- Hi; auto with zarith.
  apply Zlt_le_trans with (Zpower_nat 2 (S n)).
  rewrite Zpower_nat_S, <-Hi; auto with zarith.
  change wB with (Zpower_nat 2 31).
  apply Zpower_nat_le_compat; auto with zarith.
assert (H: forall p1 i j n, phi i = Zpower_nat 2 n -> (phi j < phi i ->
   mphi (positive_aux_to_num p1 i j) = Zpos p1 * phi i + phi j)%Z).
induction p1 as [p1 Hrec| p1 Hrec| ]; simpl positive_aux_to_num; intros i j n Hi Hj.
generalize (Hi0 i n Hi); rewrite spec_compare; case Z.compare_spec; nrom.
intros Hphi Hn; rewrite (Hij i j n), Hi, Hn; auto with zarith.
rewrite (Hrec 1 0 0%nat); nrom; auto with zarith.
rewrite Zpos_xI; change wB with (2 * Zpower_nat 2 30)%Z; ring.
generalize (phi_bounded (2 * i)); auto with zarith.
intros HH H2i; rewrite (Hrec _ _ (S n)); auto with zarith.
rewrite Zpos_xI, H2i, (Hij i j n), Hi, Zpower_nat_S; auto with zarith.
ring.
rewrite (Hij i j n), H2i, Zpower_nat_S, <- Hi; auto with zarith.
generalize (Hi0 i n Hi); rewrite spec_compare; case Z.compare_spec; nrom.
intros HH Hn; rewrite Hi, Hn; auto with zarith.
rewrite (Hrec 1 0 0%nat); nrom; auto with zarith.
rewrite Zpos_xO; change wB with (2 * Zpower_nat 2 30)%Z; ring.
generalize (phi_bounded (2 * i)); auto with zarith.
intros HH H2i; rewrite (Hrec _ _ (S n)); auto with zarith.
rewrite Zpos_xO, H2i, Hi, Zpower_nat_S; auto with zarith.
ring.
case (phi_bounded i); intros Hi1 H2.
rewrite H2i, Zpower_nat_S, <- Hi; auto with zarith.
rewrite phi_cons, (Hij i j n); nrom; auto with zarith.
unfold positive_to_num.
rewrite (H _ _ _ 0%nat); auto with zarith.
nrom; ring.
nrom; auto with zarith.
Qed.

Lemma phi_pos n : (0 <= [n])%Z.
Proof.
induction n as [ | a n Hrec]; nrom; auto with zarith.
case (phi_bounded a); intros Ha1 Ha2; auto with zarith.
apply Z.add_nonneg_nonneg; auto with zarith.
apply Z.mul_nonneg_nonneg; auto with zarith.
apply Z.pow_nonneg; auto with zarith.
Qed.

Lemma num_phi z :  (0 <= z)%Z -> [Z_to_num z] = z.
Proof.
destruct z as [|p|p]; intros Hp; auto with zarith.
apply positive_phi.
contradict Hp; auto with zarith.
Qed.

Lemma add_cp a b :
  match (a + b) ?= a with
  | Lt => (phi (a + b) = phi a + phi b - wB)%Z
  | _  => (phi (a + b) = phi a + phi b)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (a + b)); nrom; intros Hab1 Hab2.
assert (H2ab: (phi a + phi b < 2 * wB)%Z); auto with zarith.
case (Zle_or_lt wB (phi a + phi b)); intros H1ab.
assert (He: (phi(a + b) = phi a + phi b - wB)%Z).
rewrite <- (fun x y => Zmod_small (x - y) wB); auto with zarith.
rewrite Zminus_mod, Z_mod_same_full, Zminus_0_r, Zmod_mod, <- spec_add; auto.
rewrite spec_compare; case Z.compare_spec; nrom; intros Hc; auto with zarith.
assert (He: (phi(a + b) = phi a + phi b)%Z).
rewrite spec_add, Zmod_small; auto with zarith.
rewrite spec_compare; case Z.compare_spec; nrom; intros Hc; auto with zarith.
Qed.

Lemma add1_cp a :
  match (1 + a) ?= 0 with
  | Eq => (phi a = wB - 1)%Z
  | _ => (phi (1 + a) = 1 + phi a)%Z
  end.
Proof.
case (phi_bounded a);
case (phi_bounded (1 + a));
  generalize (add_cp 1 a); rewrite spec_compare; case Z.compare_spec;
  rewrite spec_compare; case Z.compare_spec; nrom; auto with zarith.
Qed.

Lemma add2_cp a b :
  match (1 + (a + b)) ?= a with
  | Gt  => (phi (1 + (a + b)) = phi a + phi b + 1)%Z
  | _ => (phi (1 + (a + b)) = phi a + phi b + 1 - wB)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (a + b)); nrom; intros Hab1 Hab2.
case (phi_bounded (1 + (a + b))); nrom; intros H1ab1 H1ab2.
generalize (add_cp 1 (a + b)) (add_cp a b);
 do 2 (rewrite spec_compare; case Z.compare_spec); nrom; intros H1 H2;
  lazy zeta; rewrite spec_compare; case Z.compare_spec; nrom; auto with zarith.
Qed.

Fixpoint incr_num (n: number): number :=
  match n with
  | nil => 1 :: nil
  | a::n1 => let c :=  1 + a in
             match c ?= 0 with
             | Eq => 0 :: incr_num n1
             | _  => c :: n1
             end
  end.

Notation "a .+1" := (incr_num a) (at level 0).

Lemma incr_correct n : ([n.+1] = [n] + 1)%Z.
Proof.
induction n as [ | a n Hrec]; nrom; auto.
unfold incr_num; fold incr_num.
generalize (add1_cp a); rewrite spec_compare; case Z.compare_spec; nrom;
  intros HH H; rewrite H; try rewrite Hrec; try ring.
Qed.

Fixpoint add_num (n1 n2 : number) :=
  match n1 with
  | nil => n2
  | a :: n3 => match n2 with
             | nil => n1
             | b :: n4 => let c := a + b in
                          match c ?= a with
                          | Lt => c :: add1_num n3 n4
                          | _  => c :: add_num n3 n4
                          end
             end
  end
with add1_num (n1 n2 : number) :=
  match n1 with
  | nil => incr_num n2
  | a :: n3 => match n2 with
               | nil => incr_num n1
               | b :: n4 => let c := (1 + (a + b)) in
                            match c ?= a with
                            | Gt  => c :: add_num n3 n4
                            | _   => c :: add1_num n3 n4
                            end
               end
  end.

Notation "a + b" := (add_num a b).
Notation "a +1 b" := (add1_num a b) (at level 40).

Lemma add_add1_correct m n :
  [m + n] = ([m] + [n])%Z /\ [m +1 n] = ([m] + [n] + 1)%Z.
Proof.
generalize n; clear n.
induction m as [ | a m Hrec]; nrom; auto.
intros n; simpl; rewrite incr_correct; auto.
intros n; destruct n as [ | b n].
  unfold add_num; fold add_num;
  unfold add1_num; fold add1_num;
  rewrite incr_correct; auto with zarith.
split.
change ((a :: m) + (b :: n)) with
                      (let c :=  (a + b)%int31 in
                        match c ?= a with
                        | Lt => c::add1_num m n
                        | _  => c::add_num m n
                        end).
lazy zeta; generalize (add_cp a b); rewrite spec_compare; case Z.compare_spec;
  nrom; intros HH H; case (Hrec n); intros H1 H2;
  try rewrite H; try rewrite H1; try rewrite H2; ring.
change ((a :: m) +1 (b :: n)) with
                      (let c :=  (1 + (a + b))%int31 in
                        match c ?= a with
                        | Gt => c::add_num m n
                        | _  => c::add1_num m n
                        end).
lazy zeta;  generalize (add2_cp a b); rewrite spec_compare; case Z.compare_spec;
 nrom; intros HH H1; case (Hrec n); intros Hr1 Hr2;
 rewrite H1; (rewrite Hr1 || rewrite Hr2); ring.
Qed.

Lemma add_correct m n : [m + n] = ([m] + [n])%Z.
Proof. case (add_add1_correct m n); auto. Qed.

Lemma add1_correct m n : [m +1 n] = ([m] + [n] + 1)%Z.
Proof. case (add_add1_correct m n); auto. Qed.

Fixpoint zerop_num (n: number) :=
  match n with
  | nil => true
  | a::n1 => match a ?= 0 with
             | Eq => zerop_num n1
             | _  => false
             end
  end.

Lemma zerop_correct n :
  if zerop_num n then [n] = 0%Z else [n] <> 0%Z.
Proof.
induction n as [ | a n Hrec].
simpl; auto.
case (phi_bounded a); nrom; intros Ha1 Ha2.
unfold zerop_num; fold zerop_num.
rewrite spec_compare; case Z.compare_spec; nrom; auto with zarith.
generalize Hrec; case zerop_num; auto with zarith.
intros H1 H2; rewrite H1, H2; ring.
intros H1 H2; rewrite H2.
rewrite Zplus_0_l; intros HH; case (Zmult_integral _ _ HH);
  auto with zarith.
generalize (phi_pos n); intros H1 H2 H3.
assert (0 < phi a + wB * [n])%Z; auto with zarith.
apply Zlt_le_trans with (phi a); auto with zarith.
assert (0 <= wB * [n])%Z; auto with zarith.
Qed.

Fixpoint cpr_num (n1 n2: number) res :=
  match n1 with
  | nil => if zerop_num n2 then res else Lt
  | a :: n3 => match n2 with
             | nil => if zerop_num n1 then res else Gt
             | b :: n4 => let res1 :=
                          match a ?= b with
                          | Eq => res
                          | v  => v
                          end in cpr_num n3 n4 res1
             end
  end.

Lemma base_lexi_order a b n1 n2 wB :
  (0 <= a < wB -> 0 <= b < wB ->
   match a + wB * n1 ?= b + wB * n2 with
   | Eq => a = b /\ n1 = n2
   | Lt => n1 < n2 \/ (n1 = n2 /\ a < b)
   | Gt => n2 < n1 \/ (n1 = n2 /\ b < a)
   end)%Z.
Proof.
intros (Ha1, Ha2) (Hb1, Hb2).
case Zcompare_spec; intros HH.
case (Zle_or_lt n1 n2); intros H1.
case (Zle_lt_or_eq _ _ H1); clear H1; intros H1; auto.
assert (HH1: (wB + wB * (n2 - n1 -1) = (a - b))%Z).
replace a with ((a + wB * n1) - wB * n1)%Z; try ring.
rewrite HH; ring.
assert (Hu: (0 <= wB * (n2 - n1 - 1))%Z); auto with zarith.
split; auto.
replace a with ((a + wB * n1) - wB * n1)%Z; try ring.
rewrite HH, H1; ring.
assert (wB + wB * (n1 - n2 -1) = (b - a))%Z.
replace b with ((b + wB * n2) - wB * n2)%Z; try ring.
rewrite <-HH; ring.
assert (Hu: (0 <= wB * (n1 - n2 - 1))%Z); auto with zarith.
case (Zle_or_lt n2 n1); intros H1; auto.
case (Zle_lt_or_eq _ _ H1); clear H1; intros H1; auto.
assert (0 <= wB * (n1 - n2 - 1))%Z; auto with zarith.
assert (wB + wB * (n1 - n2 -1) < (b - a))%Z; auto with zarith.
repeat rewrite Zmult_minus_distr_l; rewrite Zmult_1_r; auto with zarith.
rewrite H1 in HH; auto with zarith.
case (Zle_or_lt n1 n2); intros H1; auto.
case (Zle_lt_or_eq _ _ H1); clear H1; intros H1; auto.
assert (0 <= wB * (n2 - n1 - 1))%Z; auto with zarith.
assert (wB + wB * (n2 - n1 -1) < (a - b))%Z; auto with zarith.
repeat rewrite Zmult_minus_distr_l; rewrite Zmult_1_r; auto with zarith.
rewrite H1 in HH; auto with zarith.
Qed.

Lemma cpr_correct n1 n2 res :
  match ([n1] ?= [n2])%Z with
  | Lt => cpr_num n1 n2 res = Lt
  | Gt => cpr_num n1 n2 res = Gt
  | Eq => cpr_num n1 n2 res = res
  end.
Proof.
generalize n2 res; clear n2 res.
induction n1 as [ | a n1 Hrec].
intros n2 res; simpl cpr_num; nrom.
generalize (phi_pos n2); case Zcompare_spec; auto with zarith;
  generalize (zerop_correct n2); case zerop_num; auto with zarith;
  intros H1 H2 H3; contradict H1; auto with zarith.
intros [ | b n2].
intros res; unfold cpr_num.
generalize (phi_pos (a::n1)); case Zcompare_spec; auto with zarith;
  generalize (zerop_correct (a::n1)); case zerop_num; auto with zarith;
  nrom; intros H1 H2 H3; contradict H1; auto with zarith.
intros res; unfold cpr_num; fold cpr_num.
set (v := (match a ?= b with Eq => res | _ => a ?= b end)).
generalize (base_lexi_order _ _ [n1] [n2] _
                    (phi_bounded a) (phi_bounded b)); nrom;
  case Zcompare.
intros (HH, HH0).
unfold v; rewrite spec_compare; case Z.compare_spec; nrom; intros HH2;
  try (contradict HH2; auto with zarith; fail).
generalize (Hrec n2 res); case Zcompare_spec; auto;
 intros HH3; contradict HH3; auto with zarith.
intros [HH2 | (HH2, HH3)].
generalize (Hrec n2 v); rewrite HH2; unfold v;
  rewrite spec_compare; case Z.compare_spec; auto.
generalize (Hrec n2 v); rewrite HH2; unfold v.
rewrite Zcompare_refl.
rewrite spec_compare; case Z.compare_spec; auto with zarith
 ; intros HH; contradict HH; auto with zarith.
intros [HH2 | (HH2, HH3)].
generalize (Hrec n2 v); case Z.compare_spec; auto with zarith.
intros HH; contradict HH2; auto with zarith.
intros HH; contradict HH2; auto with zarith.
unfold v; rewrite spec_compare; case Z.compare_spec; auto.
generalize (Hrec n2 v); rewrite HH2, Zcompare_refl.
unfold v; rewrite spec_compare; case Z.compare_spec; auto.
intros HH4; contradict HH3; auto with zarith.
intros HH4; contradict HH3; auto with zarith.
Qed.

Definition cp_num n1 n2 := cpr_num n1 n2 Eq.

Inductive CpSpec (i j : number) : comparison -> Prop :=
    CpSpecEq : [i] = [j] -> CpSpec i j Eq
  | CpSpecLt : ([i] < [j])%Z -> CpSpec i j Lt
  | CpSpecGt : ([j] < [i])%Z -> CpSpec i j Gt.

Lemma cp_spec i j : CpSpec i j (cp_num i j).
Proof.
generalize (cpr_correct i j Eq).
unfold cp_num; case Zcompare_spec; intros H1 H2; rewrite H2;
  constructor; auto.
Qed.

Fixpoint eq_num (n1 n2: number) :=
  match n1 with
  | nil     => zerop_num n2
  | a :: n3 => match n2 with
             | nil     => zerop_num n1
             | b :: n4 => match a ?= b with
                          | Eq => eq_num n3 n4
                          | _  => false
                        end
             end
  end.

Lemma eq_correct n1 n2 :
  if eq_num n1 n2 then [n1] = [n2]%Z else [n1] <> [n2]%Z.
Proof.
generalize n2; clear n2.
induction n1 as [ | a n1 Hrec].
intros n2; generalize (zerop_correct n2); simpl; case zerop_num; auto.
case (phi_bounded a); nrom; intros Ha1 Ha2.
intros [ |b n2]; unfold eq_num; fold eq_num; nrom.
generalize (zerop_correct (a::n1)); simpl; case zerop_num; auto.
rewrite spec_compare; case Z.compare_spec; nrom; intros H1;
  try (
    intros HH;
     generalize (base_lexi_order _ _ [n1] [n2] _
                      (phi_bounded a) (phi_bounded b)); nrom;
    rewrite HH, Zcompare_refl; intros (H3,H4); contradict H1; auto with zarith).
generalize (Hrec n2); case eq_num; intros H2.
apply Zcompare_Eq_eq;
  generalize (base_lexi_order _ _ [n1] [n2] _
                    (phi_bounded a) (phi_bounded b)); nrom;
  case Zcompare; auto.
intros [H3 | (H3, H4)]; contradict H3; auto with zarith.
intros [H3 | (H3, H4)]; contradict H3; auto with zarith.
intros HH;
  generalize (base_lexi_order _ _ [n1] [n2] _
                    (phi_bounded a) (phi_bounded b)); nrom;
  rewrite HH, Zcompare_refl; intros (H3,H4); case H2; auto.
Qed.

Fixpoint decr_num (n: number): number :=
  match n with
  | nil     => 1 :: nil
  | a :: n1 => match a ?= 0 with
             | Eq => Tn :: decr_num n1
             | _  => (a - 1) :: n1
             end
  end.

Notation "a .-1" := (decr_num a) (at level 0).

Lemma decr_correct n : (0 < [n])%Z -> ([n.-1] = [n] - 1)%Z.
Proof.
induction n as [ | a n Hrec]; nrom; auto with zarith.
unfold decr_num; fold decr_num.
case (phi_bounded a); nrom; intros Ha1 Ha2.
rewrite spec_compare; case Z.compare_spec;
  nrom; try rewrite spec_Bm1; nrom; auto with zarith.
intros H1 H2; rewrite H1 in H2 |- *; rewrite Hrec;
 auto with zarith; try ring.
apply Zmult_lt_0_reg_r with wB; auto with zarith.
rewrite Zmult_comm; auto with zarith.
intros H1 H2.
rewrite spec_sub; nrom.
rewrite Zmod_small; auto with zarith.
Qed.

Fixpoint sub_num (n1 n2 : number) :=
  match n1 with
  | nil     => nil
  | a :: n3 => match n2 with
             | nil     => n1
             | b :: n4 => let c := a - b in
                          match c ?= a with
                          | Gt => c :: sub1_num n3 n4
                          | _  => c :: sub_num n3 n4
                          end
             end
  end
with sub1_num (n1 n2 : number) :=
  match n1 with
  | nil     => nil
  | a :: n3 => match n2 with
               | nil     => decr_num n1
               | b :: n4 => let c := (a - (1 + b)) in
                            match c ?= a with
                            | Lt  => c :: sub_num n3 n4
                            | _   => c :: sub1_num n3 n4
                            end
               end
  end.

Notation "a - b" := (sub_num a b).
Notation "a -1 b" := (sub1_num a b) (at level 40).

Lemma sub_cp a b :
  match (a - b) ?= a with
  | Gt => (phi (a - b) = phi a - phi b + wB)%Z
  | _  => (phi (a - b) = phi a - phi b)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (a - b)); nrom; intros Hab1 Hab2.
assert (H1ab: (phi a - phi b < wB)%Z); auto with zarith.
case (Zle_or_lt 0 (phi a - phi b)); intros Hab.
assert (He: (phi(a - b) = phi a - phi b)%Z).
rewrite spec_sub, Zmod_small; auto with zarith.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
assert (He: (phi(a - b) = phi a - phi b + wB)%Z).
rewrite <- (fun x y => Zmod_small (x + y) wB); auto with zarith.
rewrite Zplus_mod, Z_mod_same_full, Zplus_0_r, Zmod_mod, <- spec_sub; auto.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
Qed.

Lemma sub1_cp a b :
  match (a - (1 + b)) ?= a with
  | Lt => (phi (a - (1 + b)) = phi a - (1 + phi b))%Z
  | _  => (phi (a - (1 + b)) = phi a - (1 + phi b) + wB)%Z
  end.
Proof.
case (phi_bounded a); nrom; intros Ha1 Ha2.
case (phi_bounded b); nrom; intros Hb1 Hb2.
case (phi_bounded (1 + b)); nrom; intros H1b1 H1b2.
case (phi_bounded (a - (1 + b))); nrom; intros Hab1 Hab2.
case (Zle_lt_or_eq (1 + phi b) wB); auto with zarith; intros Hb3;
  try(
  rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith;
  generalize Hc; rewrite spec_sub, spec_add; nrom;
  rewrite Hb3, Z_mod_same_full, Zminus_0_r, Zmod_small; auto with zarith).
assert (H1b: phi (1 + b) = (phi b + 1)%Z).
  rewrite spec_add, Zmod_small; nrom; auto with zarith.
assert (H1ab: (phi a - phi (1 + b) < wB)%Z); auto with zarith.
case (Zle_or_lt 0 (phi a - phi (1 + b))); intros Hab.
assert (He: (phi(a - (1 + b)) = phi a - phi b - 1)%Z).
rewrite spec_sub, Zmod_small; nrom; auto with zarith.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
assert (He: (phi(a - (1 + b)) = phi a - phi b - 1 + wB)%Z).
rewrite <- (fun x y => Zmod_small (x + y) wB); auto with zarith.
rewrite Zplus_mod, Z_mod_same_full, Zplus_0_r, Zmod_mod; auto with zarith.
rewrite spec_sub, H1b; nrom; apply f_equal2 with (f := Zmod); auto with zarith.
rewrite spec_compare; case Z.compare_spec; intros Hc;
  auto with zarith.
Qed.

Lemma sub_sub1_correct m n :
   (([n] <= [m])%Z -> [m - n] = ([m] - [n])%Z)
/\ ([n] <  [m] -> [m -1 n] = [m] - (1 + [n]))%Z.
Proof.
generalize n; clear n.
induction m as [ | a m Hrec]; nrom; auto.
intros n; induction n as [ | b n Hrec];
  unfold sub_num, sub1_num; fold sub_num;
  fold sub1_num; nrom; auto with zarith.
generalize (phi_pos (b::n)); nrom; auto with zarith.
intros n; destruct n as [ | b n];
  unfold sub_num, sub1_num; fold sub_num;
  fold sub1_num; nrom; auto with zarith.
split; intros H1; auto with zarith.
rewrite decr_correct; auto with zarith.
split; intros H1.
case (Hrec n); intros H2 H3.
assert (H4: ([n] <= [m])%Z).
  generalize (base_lexi_order _ _ [n] [m] _ (phi_bounded b) (phi_bounded a));
  nrom;
  case (Zle_lt_or_eq _ _ H1); intros H4.
    red in H4; rewrite H4; auto with zarith.
  rewrite H4, Zcompare_refl; auto with zarith.
generalize (sub_cp a b); rewrite spec_compare; case Z.compare_spec; nrom; intros HH0 HH1;
  rewrite HH1; try rewrite H2; auto; try ring.
rewrite H3; try ring.
case (Zle_lt_or_eq _ _ H4); intros H5; auto.
rewrite H5 in H1 |- *.
generalize (base_lexi_order _ _ [m] [m] _ (phi_bounded b) (phi_bounded a));
nrom.
assert (H6: (phi a < phi b)%Z).
case (Zle_or_lt (phi b) (phi a)); intros H6; auto.
generalize HH1; rewrite spec_sub; nrom.
  case (phi_bounded a); nrom; intros Ha1 Ha2;
  case (phi_bounded b); nrom; intros Hb1 Hb2;
    rewrite Zmod_small; auto with zarith.
case (Zle_lt_or_eq _ _ H1); intros H7.
red in H7; rewrite H7; auto with zarith.
rewrite H7, Zcompare_refl; auto with zarith.
generalize (base_lexi_order _ _ [n] [m] _ (phi_bounded b) (phi_bounded a)); nrom.
red in H1; rewrite H1.
intros [H2 | (H2, H3)].
case (Hrec n); intros H3 H4.
generalize (sub1_cp a b); rewrite spec_compare; case Z.compare_spec; nrom; intros HH0 HH1;
  rewrite HH1; try rewrite H3; try rewrite H4;
  auto with zarith; try ring.
assert (Ha: (phi (a - (1 + b)) < phi a)%Z).
  case (phi_bounded a); nrom; intros H1a H2a.
  case (phi_bounded b); nrom; intros H1b _.
  rewrite spec_sub, Zmod_small; nrom; auto with zarith;
  rewrite spec_add, Zmod_small; nrom; auto with zarith.
rewrite spec_compare; case Z.compare_spec; auto with zarith.
intros _; case (Hrec n); intros H4 _; nrom.
rewrite H4; auto with zarith.
case (phi_bounded a); nrom; intros H1a H2a;
  case (phi_bounded b); nrom; intros H1b _;
  rewrite spec_sub, Zmod_small; nrom; auto with zarith;
  rewrite spec_add, Zmod_small; nrom; auto with zarith;
  try ring.
Qed.

Lemma sub_correct m n :
  ([n] <= [m])%Z -> [m - n] = ([m] - [n])%Z.
Proof. intros H; case (sub_sub1_correct m n); auto with zarith. Qed.

Lemma sub1_correct m n :
  ([n] < [m])%Z -> [m -1 n] = ([m] - [n] - 1)%Z.
Proof. intros H; case (sub_sub1_correct m n); auto with zarith. Qed.

Definition add_mod p m n :=
  let res := m + n in
  match cp_num res p with
  | Lt => res
  | _  => res - p
  end.

Lemma add_mod_correct p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       [add_mod p m n] = ([m] + [n]) mod [p])%Z.
Proof.
intros H1 H2; unfold add_mod.
case cp_spec; rewrite add_correct; intros H3;
  try rewrite sub_correct; try rewrite add_correct; auto with zarith.
rewrite H3, Z_mod_same_full; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite <-(fun x y => (Zmod_small (x - y) [p])); auto with zarith.
rewrite Zminus_mod, Z_mod_same_full, Zminus_0_r, Zmod_mod; auto.
Qed.

Lemma add_mod_bound p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       0 <= [add_mod p m n] < [p])%Z.
Proof.
intros H1 H2; rewrite add_mod_correct; auto.
apply Z_mod_lt; auto with zarith.
Qed.

Definition sub_mod p m n :=
  match cp_num m n with
  | Lt => (p + m) - n
  | _  => m - n
  end.

Lemma sub_mod_correct p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       [sub_mod p m n] = ([m] - [n]) mod [p])%Z.
Proof.
intros H1 H2; unfold sub_mod.
case cp_spec; intros H3.
rewrite H3, Zminus_diag, Zmod_0_l, sub_correct, H3; auto with zarith.
rewrite sub_correct; rewrite add_correct; auto with zarith.
rewrite <-(fun x y => (Zmod_small (x - y) [p])); auto with zarith.
rewrite Zminus_mod, Zplus_mod, Z_mod_same_full, Zplus_0_l,
        Zmod_mod, <- Zminus_mod; auto.
rewrite Zmod_small, sub_correct; auto with zarith.
Qed.

Lemma sub_mod_bound p m n :
  (0 <= [m] < [p] -> 0 <= [n] < [p] ->
       0 <= [sub_mod p m n] < [p])%Z.
Proof.
intros H1 H2; rewrite sub_mod_correct; auto.
apply Z_mod_lt; auto with zarith.
Qed.

Definition amd (A: Type) (a b c: int31) (f: int31 -> int31 -> A): A :=
match a *c b with
| W0 => f c 0
| WW resh resl =>
    let u := (resl + c)%int31 in
    match u ?= resl with
    | Lt => f u (incr resh)
    | _ => f u resh
    end
end.

Fixpoint amd_num (a b: int31) (n: number): number :=
match n with
| nil => b :: nil
| c::n1 => amd _ a c b
    (fun xl xh =>
       xl :: amd_num a xh n1)
end.

Lemma amd_correct a b n :
  [amd_num a b n] = (phi a * [n] + phi b)%Z.
Proof.
generalize a b; clear a b;
  induction n as [ | c n1 Hrec]; intros a b;
  unfold amd_num; fold amd_num; nrom; nrom.
ring.
unfold amd; generalize (spec_mul_c a c); nrom;
  case (_ *c _); simpl zn2z_to_Z.
intros H1; nrom; rewrite Hrec; nrom.
repeat rewrite Zmult_plus_distr_r; rewrite <- H1.
ring.
intros xh xl Hx; generalize (add_cp xl b); case (_ ?= _);
  intros H1; nrom; rewrite H1, Hrec;
  repeat rewrite Zmult_plus_distr_r; rewrite <- Hx; try ring.
replace (phi (incr xh)) with (phi xh + 1)%Z; try ring.
case (phi_bounded a); nrom; intros H1a H2a.
case (phi_bounded c); nrom; intros H1c H2c.
case (phi_bounded xl); nrom; intros H1xl H2xl.
rewrite phi_incr, Zmod_small; nrom; auto with zarith.
case (phi_bounded xh); nrom; intros H1xh H2xh; split; auto with zarith.
assert (HH: (phi a * phi c <= (wB - 1) * (wB - 1))%Z).
apply Zmult_le_compat; auto with zarith.
replace ((wB - 1) * (wB - 1))%Z with
    (1 + wB * (wB - 2) )%Z in HH;try ring.
rewrite <-Hx, Zmult_comm, Zplus_comm in HH.
assert (HH1: (0 <= 1 < wB)%Z);
  case (phi_bounded 1); nrom; auto with zarith.
generalize (base_lexi_order (phi xl) 1 (phi xh) (wB - 2) wB
             (phi_bounded xl) HH1).
case (Zle_lt_or_eq _ _ HH); intros HH2.
red in HH2; rewrite HH2; auto with zarith.
rewrite HH2, Zcompare_refl; auto with zarith.
Qed.

Definition scal_num (a : int31) (n : number) : number :=
  amd_num a 0 n.

Lemma scal_correct a n :
  [scal_num a n] = (phi a * [n])%Z.
Proof. unfold scal_num; rewrite amd_correct; nrom; ring. Qed.

Fixpoint prod_num (m n : number) : number :=
  match n with
  | nil     => nil
  | a :: n1 => match scal_num a m with
               | nil     => 0 :: prod_num m n1
               | b :: n2 => b :: add_num n2 (prod_num m n1)
               end
  end.

Lemma prod_correct m n : [prod_num m n] = ([m] * [n])%Z.
Proof.
induction n as [ | a n Hrec]; unfold prod_num;
  fold prod_num.
nrom; ring.
generalize (scal_correct a m); case scal_num; nrom.
rewrite Hrec; intros HH.
rewrite Zmult_plus_distr_r, (Zmult_comm [m]), (Zmult_comm [m]),
        <-HH; ring.
intros i l; nrom; intros HH.
rewrite add_correct, Hrec, Zmult_plus_distr_r, Zplus_assoc, HH;
  ring.
Qed.

Fixpoint exp_num (m : number) (n : nat) : number :=
  match n with
  | O    => 1 :: nil
  | S n1 => prod_num m (exp_num m n1)
  end.

Lemma exp_correct m n: [exp_num m n] = Zpower_nat [m] n.
Proof.
induction n as [ | n Hrec]; unfold exp_num; fold exp_num.
nrom; nrom; unfold Zpower_nat; simpl; auto.
change (S n) with (1 + n)%nat; rewrite Zpower_nat_is_exp.
rewrite prod_correct, Hrec; change (Zpower_nat [m] 1) with ([m] * 1)%Z.
ring.
Qed.

Definition shift_num (t : number) : number :=
  match t with nil => nil | a :: t1 => t1 end.

Lemma shift_correct t : [shift_num t] = ([t] / wB)%Z.
Proof.
destruct t as [ | a t]; unfold shift_num; nrom.
rewrite Zdiv_0_l; auto.
case (phi_bounded a); nrom; intros H1a H2a.
rewrite Zmult_comm, Z_div_plus_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.
Qed.

Section Reduce.

Variable M : number.
Variable m' : int31.
Hypothesis Hmm' : (phi (nhead M * m') = wB - 1)%Z.

Lemma M_pos : (0 < [M])%Z.
Proof.
rewrite phi_head_tail.
nrom; case (phi_bounded (nhead M)); nrom; intros H1a H2a.
case (Zle_lt_or_eq _ _ H1a); intros H3a.
assert (Hms := phi_pos (ntail M)).
apply Zlt_le_trans with (phi (nhead M) + wB * 0)%Z; auto with zarith.
generalize Hmm'; rewrite spec_mul; nrom.
rewrite <-H3a, Zmult_0_l, Zmod_0_l; auto with zarith.
simpl; auto with zarith.
Qed.

Fixpoint reduce_aux_num (n : nat) (t : number)  :=
  match n with
  |    O => t
  | S n1 =>
     match t with
     | nil    => t
     | a :: _ =>
         reduce_aux_num n1
            (shift_num (add_num t (scal_num (a * m') M)))
     end
  end.

Lemma reduce_aux_step a t :
  ((phi a + wB * [t] + phi (a * m') * [M]) / wB * wB =
   phi a + wB * [t] + phi (a * m') * [M])%Z.
Proof.
case (phi_bounded a); nrom; intros H1a H2a.
rewrite (phi_head_tail M); nrom.
set (m := nhead M); set (ms := ntail M).
replace (phi a + wB * [t] + phi (a * m') * (phi m + wB * [ms]))%Z
  with ((phi a + phi (a * m') * phi m) + ([t] +  phi (a * m') * [ms]) * wB)%Z;
  try ring.
rewrite Z_div_plus_full; auto with zarith.
set (v := (phi a + phi (a * m') * phi m)%Z).
assert (HH: (v / wB * wB = v)%Z).
rewrite (Z_div_mod_eq_full v wB); auto with zarith.
rewrite (Zmult_comm wB), Z_div_plus_full_l; auto with zarith.
assert (HH: (v mod wB = 0)%Z); auto with zarith.
unfold v; rewrite spec_mul; nrom.
rewrite Zplus_mod, Zmult_mod, Zmod_mod, <- Zmult_mod, <- Zmult_assoc,
        Zmult_mod.
unfold m.
generalize Hmm'; rewrite spec_mul; nrom; intros HH1; rewrite (Zmult_comm (phi m')), HH1.
rewrite (Zmult_mod (phi a mod wB)), Zmod_mod, <- Zmult_mod, <- Zplus_mod.
replace (phi a + phi a * (wB - 1))%Z with (phi a * wB)%Z; try ring.
rewrite Z_mod_mult; auto.
rewrite Zmult_plus_distr_l, HH, Zdiv_0_l, Zmult_0_l, <-HH,
        Zmult_comm, <- Z_div_mod_eq_full; auto with zarith.
rewrite Zmult_plus_distr_l, HH; unfold v.
nrom; ring.
Qed.

Lemma reduce_aux_correct n t :
  ([reduce_aux_num n t] * (Zpower_nat wB n) mod [M] = [t]  mod [M])%Z.
Proof.
generalize t; clear t.
induction n as [ | n Hrec]; intros t.
assert (HH := phi_pos t).
simpl reduce_aux_num; repeat rewrite Zpower_nat_0;
  repeat rewrite Zmult_1_r; auto.
repeat rewrite Zpower_nat_S.
simpl reduce_aux_num; case t.
nrom; rewrite Zmod_small, Zmult_0_l; auto with zarith.
rewrite Zmult_0_l; auto with zarith.
generalize M_pos; auto with zarith.
intros a t1.
rewrite (Zmult_comm wB), Zmult_assoc, Zmult_mod, Hrec,
        <- Zmult_mod, shift_correct, add_correct, scal_correct.
nrom.
rewrite reduce_aux_step, Zplus_mod, Z_mod_mult, Zplus_0_r, Zmod_mod; auto.
Qed.

Lemma reduce_aux_le n t :
  ([t] < [M] * (Zpower_nat wB n) -> [reduce_aux_num n t] < 2 * [M])%Z .
Proof.
intros Ht.
assert (HH: (exists U, [reduce_aux_num n t] * Zpower_nat wB n = [t] + U * [M]
                    /\ 0 <= U < Zpower_nat wB n)%Z).
generalize t; clear t Ht; induction n as [ | n Hrec]; intros t.
assert (HM := phi_pos M).
simpl reduce_aux_num; repeat rewrite Zpower_nat_0;
  repeat rewrite Zmult_1_r; auto with zarith.
exists 0%Z; auto with zarith.
repeat rewrite Zpower_nat_S.
assert (HH2 := Zpower_base_pos n).
simpl reduce_aux_num; case t; nrom.
exists 0%Z; split; auto with zarith.
split; try apply Zmult_lt_0_compat; auto with zarith.
red; auto.
intros a t1; nrom.
case (Hrec (shift_num (add_num (a :: t1) (scal_num (a * m') M)))).
intros U (H1U, H2U); exists (phi(a * m') + wB * U)%Z; split.
rewrite (Zmult_comm wB), Zmult_assoc, H1U,
         shift_correct, add_correct, scal_correct; nrom.
rewrite Zmult_plus_distr_l, reduce_aux_step; ring.
case (phi_bounded (a * m')); nrom; intros H1am H2am; auto with zarith.
split; auto with zarith.
apply Zlt_le_trans with (wB + wB * U)%Z; auto with zarith.
replace (wB * Zpower_nat wB n)%Z with
        (wB + wB * (Zpower_nat wB n - 1))%Z; auto with zarith; ring.
apply Zmult_gt_0_lt_reg_r with (1 := Zlt_gt _ _ (Zpower_base_pos n)).
case HH; intros U (H1U, H2U).
rewrite H1U.
assert (U * [M] < [M] * Zpower_nat wB n)%Z; auto with zarith.
rewrite Zmult_comm; apply Zmult_gt_0_lt_compat_l; auto with zarith.
apply Zlt_gt; apply M_pos.
replace (2 * [M] * Zpower_nat wB n)%Z with
       ([M] * Zpower_nat wB n + [M] * Zpower_nat wB n)%Z; auto with zarith;
  ring.
Qed.

Definition reduce_num (n : nat) (t : number) : number :=
  let res := reduce_aux_num n t in
  match cp_num res M with
  | Lt => res
  | _ => sub_num res M
  end.

Lemma reduce_correct n t :
  ([reduce_num n t] * (Zpower_nat wB n) mod [M] = [t]  mod [M])%Z.
Proof.
assert (H:= M_pos).
assert (HH:= reduce_aux_correct n t).
unfold reduce_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct, Zmult_minus_distr_r; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
Qed.

Lemma reduce_bound n t :
  ([t] < [M] * (Zpower_nat wB n) ->
  0 <= [reduce_num n t] < [M])%Z.
Proof.
intros Ht; split.
apply phi_pos.
assert (HH := reduce_aux_le _ _ Ht).
unfold reduce_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct; auto with zarith.
Qed.

Definition T n := reduce_num n (1%int31::nil).

Lemma Tn_correct n :
  ([T n] * (Zpower_nat wB n) mod [M] = 1 mod[M])%Z.
Proof.
unfold T; rewrite reduce_correct; nrom; nrom.
rewrite Zmult_0_r, Zplus_0_r; auto with zarith.
Qed.

Lemma eq_Tn_correct a b n :
  ((a * Zpower_nat wB n) mod [M] = (b * Zpower_nat wB n) mod [M] ->
    a mod [M] = b mod [M])%Z.
Proof.
intros H.
assert (HH: ((a - b) mod [M] = 0)%Z).
rewrite <- (Zmult_1_r (a - b)), Zmult_mod, <- (Tn_correct n),
        <- Zmult_mod, (Zmult_comm [T n]), Zmult_assoc,
        Zmult_minus_distr_r, Zmult_mod, Zminus_mod, H,
        <- Zminus_mod, <- Zmult_mod, Zminus_diag, Zmult_0_l,
        Zmod_0_l; auto.
replace a with (b + (a - b))%Z; try ring.
rewrite Zplus_mod, HH, Zplus_0_r, Zmod_mod; auto.
Qed.

Fixpoint reduce_amd_aux_num (n : nat) (t1 t2 res : number) {struct n} :=
  match n with
  | O    => add_num res (prod_num t1 t2)
  | S n1 =>
    match t1 with
    |     nil => reduce_aux_num n res
    | a :: t3 =>
      let res1 := add_num res (scal_num a t2) in
      match res1 with
      | nil    => reduce_amd_aux_num n1 t3 t2 nil
      | b :: _ =>
        reduce_amd_aux_num n1 t3 t2
            (shift_num (add_num res1 (scal_num (b * m') M)))
      end
    end
  end.

Lemma reduce_amd_aux_correct n t1 t2 res :
 (([reduce_amd_aux_num n t1 t2 res] * Zpower_nat wB n) mod [M] =
  ([t1] * [t2] + [res]) mod [M])%Z.
Proof.
generalize t1 t2 res; clear t1 t2 res.
induction n as [ |n1 Hrec]; intros t1 t2 res;
   unfold reduce_amd_aux_num; fold reduce_amd_aux_num.
rewrite Zpower_nat_0, Zmult_1_r, add_correct, prod_correct, Zplus_comm; auto.
destruct t1 as [ | a t3]; nrom.
rewrite Zmult_0_l, Zplus_0_l, reduce_aux_correct; auto.
set (v :=  add_num res (scal_num a t2)).
assert (Hv: [v] = ([res] + phi a * [t2])%Z).
unfold v; rewrite add_correct, scal_correct; auto.
generalize Hv; destruct v as [ | b v1]; nrom; clear Hv; intros Hv.
rewrite Zpower_nat_S, (Zmult_comm wB), Zmult_assoc, Zmult_mod, Hrec.
nrom; rewrite Zplus_0_r, <- Zmult_mod.
apply f_equal2 with (f := Zmod); auto.
rewrite <- Zminus_0_r, Hv; ring.
rewrite Zpower_nat_S, (Zmult_comm wB), Zmult_assoc, Zmult_mod, Hrec.
rewrite <- Zmult_mod, shift_correct, add_correct, scal_correct; nrom.
rewrite Zmult_plus_distr_l, reduce_aux_step.
rewrite Zplus_assoc, Z_mod_plus_full.
apply f_equal2 with (f := Zmod); auto.
rewrite Hv; ring.
Qed.

Lemma reduce_amd_aux_le n t1 t2 res :
  ([t1] < Zpower_nat wB n -> [t2] < [M] ->
  [res] <  2 * [M]  - 1 -> [reduce_amd_aux_num n t1 t2 res] < 2 * [M])%Z.
Proof.
generalize t1 t2 res; clear t1 t2 res.
induction n as [ |n1 Hrec]; intros t1 t2 res;
   unfold reduce_amd_aux_num; fold reduce_amd_aux_num.
rewrite Zpower_nat_0; intros H1t1 Ht2 Hres.
assert (H2t1 := phi_pos t1).
rewrite add_correct, prod_correct.
replace [t1] with 0%Z; auto with zarith.
destruct t1 as [ | a t3].
intros _ Ht2 Hres.
apply reduce_aux_le.
apply Zlt_le_trans with (1 := Hres).
apply Zle_trans with (2 * [M])%Z; auto with zarith.
rewrite Zmult_comm.
apply Zmult_le_compat_l.
apply Zle_trans with wB; try (red; discriminate).
rewrite <- (Zmult_1_r wB) at 1; rewrite Zpower_nat_S.
apply Zmult_le_compat_l.
generalize (Zpower_base_pos n1); auto with zarith.
red; discriminate.
apply Zlt_le_weak; apply M_pos.
nrom; intros Ht3 Ht2 Hres.
set (v :=  add_num res (scal_num a t2)).
assert (Hv: [v] = ([res] + phi a * [t2])%Z).
unfold v; rewrite add_correct, scal_correct; auto.
generalize Hv; destruct v as [ | b v1]; nrom; clear Hv; intros Hv.
apply Hrec; auto with zarith.
apply Zmult_lt_reg_r with wB; auto with zarith; try (red; auto; fail).
repeat rewrite <- (Zmult_comm wB); apply Zle_lt_trans with (2 := Ht3).
case (phi_bounded a); auto with zarith.
nrom; generalize M_pos; auto with zarith.
apply Hrec; auto with zarith.
apply Zmult_lt_reg_r with wB; auto with zarith; try (red; auto; fail).
repeat rewrite <- (Zmult_comm wB); apply Zle_lt_trans with (2 := Ht3).
case (phi_bounded a); auto with zarith.
rewrite shift_correct, add_correct, scal_correct; nrom.
rewrite Hv.
apply Zdiv_lt_upper_bound; try (red; auto; fail); auto with zarith.
repeat apply Zplus_le_0_compat; repeat apply Zmult_le_0_compat;
  try apply phi_pos; try (red; discriminate).
case (phi_bounded a); nrom; intros H1a H2a.
case (phi_bounded (b * m')); nrom; intros H1bm H2bm.
apply Zle_lt_trans with
  (((2 * [M] - 2) + (wB - 1) * ([M] - 1) + (wB - 1) * [M])%Z).
repeat apply Zplus_le_compat; auto with zarith.
apply Zmult_le_compat; auto with zarith.
apply phi_pos.
apply Zmult_le_compat; auto with zarith.
apply Zlt_le_weak; apply M_pos.
ring_simplify; auto with zarith.
Qed.

Definition reduce_mult_num (n: nat) (t1 t2 : number) :=
  let res := reduce_amd_aux_num n t1 t2 nil in
  match cp_num res M with
  | Lt => res
  | _ => sub_num res M
  end.

Lemma reduce_mult_correct n t1 t2 :
 ([reduce_mult_num n t1 t2] * (Zpower_nat wB n) mod [M] =
  ([t1] * [t2])  mod [M])%Z.
Proof.
assert (H:= M_pos).
generalize (reduce_amd_aux_correct n t1 t2 nil).
nrom; rewrite Zplus_0_r; intros HH.
unfold reduce_mult_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct, Zmult_minus_distr_r; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
rewrite (Zmult_comm [M]); unfold Zminus.
rewrite Zopp_mult_distr_l, Z_mod_plus; auto with zarith.
Qed.

Lemma reduce_mult_bound n t1 t2 :
  ([t1] < Zpower_nat wB n -> [t2] < [M] ->
  0 <= [reduce_mult_num n t1 t2] < [M])%Z.
Proof.
intros Ht1 Ht2; split.
apply phi_pos.
assert (Hres: ([nil] < 2 * [M] - 1)%Z).
  nrom; generalize M_pos; auto with zarith.
assert (HH := reduce_amd_aux_le _ _ _ _ Ht1 Ht2 Hres).
unfold reduce_mult_num; case cp_spec; intros HH1; auto with zarith;
  rewrite sub_correct; auto with zarith.
Qed.

Definition r_square n :=
 Z_to_num ((Zpower_nat wB  n * Zpower_nat wB n) mod [M]).

Lemma r_square_lt n : (0 <= [r_square n] < [M])%Z.
Proof.
unfold r_square.
rewrite num_phi; auto with zarith.
apply Z_mod_lt; auto with zarith.
apply Zlt_gt; apply M_pos.
case (Z_mod_lt (Zpower_nat wB n * Zpower_nat wB n) [M]);
  auto with zarith.
apply Zlt_gt; apply M_pos.
Qed.

Definition encode n z : number :=
  reduce_mult_num n (Z_to_num (z mod [M])) (r_square n).

Definition decode n m :=  [reduce_num n m].

Variable n : nat.

Hypothesis M_small : ([M] < Zpower_nat wB n)%Z.

Let HF0 := M_pos.
Let HF1:  (0 <= (Zpower_nat wB n * Zpower_nat wB n) mod [M])%Z.
Proof.
case (Z.mod_pos_bound (Zpower_nat wB n * Zpower_nat wB n) [M]); auto with zarith.
Qed.

Lemma reduce_bound_small t :
  (0 <= [t] < [M] -> 0 <= [reduce_num n t] < [M])%Z.
Proof.
intros Ht; apply reduce_bound.
case Ht; intros _ Ht1; apply Zlt_le_trans with (1 := Ht1).
rewrite <-(Zmult_1_r [M]) at 1.
apply Zmult_le_compat_l; auto with zarith.
Qed.

Hint Resolve reduce_bound_small add_mod_bound sub_mod_bound.

Lemma reduce_mult_bound_small t1 t2 :
  (0 <= [t1] < [M] -> 0 <= [t2] < [M] ->
   0 <= [reduce_mult_num n t1 t2] < [M])%Z.
Proof.
intros Ht1 Ht2; apply reduce_mult_bound; auto with zarith.
Qed.

Hint Resolve reduce_mult_bound_small.

Lemma encode_correct z :
  (0 <= z < [M] -> [encode n z] = (z * Zpower_nat wB n) mod [M])%Z.
Proof.
intros Hz.
unfold encode; rewrite Zmod_small; auto with zarith.
rewrite <-(Zmod_small _ [M]); auto with zarith.
apply (eq_Tn_correct _ _ n).
rewrite reduce_mult_correct.
unfold r_square.
rewrite !num_phi; auto with zarith.
rewrite Zmult_mod, Zmod_mod, <-Zmult_mod, Zmult_assoc; auto with zarith.
apply reduce_mult_bound_small; auto with zarith.
rewrite num_phi; auto with zarith.
unfold r_square.
rewrite num_phi; auto with zarith.
apply Z_mod_lt; auto with zarith.
Qed.

Lemma encode_bound z :
  (0 <= z < [M] -> 0 <= [encode n z] < [M])%Z.
Proof.
intros Hz.
rewrite encode_correct; auto with zarith.
apply Z_mod_lt; auto with zarith.
Qed.

Hint Resolve encode_bound.

Lemma decode_encode p :
  (0 <= p < [M])%Z -> decode n (encode n p) = p.
Proof.
intros Hp.
unfold decode, encode.
assert (F1 : (0 <= [Z_to_num (p mod [M])] < [M])%Z).
  rewrite num_phi; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  case (Z.mod_pos_bound p [M]); auto with zarith.
assert (F2: ([Z_to_num (p mod [M])] < Zpower_nat wB n)%Z).
  apply (Zlt_trans _ [M]); auto with zarith.
assert (F3: ([r_square n] < [M])%Z).
  case (r_square_lt n); auto.
generalize (reduce_mult_bound _ _ _ F2 F3); intros F4.
rewrite <-(Zmod_small p [M]); auto with zarith.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
rewrite reduce_correct.
apply (eq_Tn_correct _ _ n).
rewrite reduce_mult_correct.
unfold r_square.
rewrite !num_phi; auto with zarith.
rewrite Zmod_mod, <-Zmult_mod, Zmult_assoc; auto.
case (Z.mod_pos_bound (Zpower_nat wB n * Zpower_nat wB n) [M]);
  auto with zarith.
case (Z.mod_pos_bound (p mod [M]) [M]); auto with zarith.
case (Z.mod_pos_bound p [M]); auto with zarith.
intros; apply reduce_bound_small.
rewrite Zmod_mod; auto with zarith.
Qed.

Lemma decode_encode_add p1 p2 :
  (0 <= p1 < [M])%Z -> (0 <= p2 < [M])%Z ->
  decode n (add_mod M (encode n p1) (encode n p2)) = ((p1 + p2) mod [M])%Z.
Proof.
intros Hp1 Hp2.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
unfold decode; rewrite reduce_correct.
rewrite add_mod_correct; auto with zarith.
rewrite !encode_correct; auto with zarith.
rewrite <-Zplus_mod, Zmod_mod, Zmult_plus_distr_l; auto with zarith.
unfold decode; auto with zarith.
Qed.

Lemma decode_encode_sub p1 p2 :
  (0 <= p1 < [M])%Z -> (0 <= p2 < [M])%Z ->
  decode n (sub_mod M (encode n p1) (encode n p2)) = ((p1 - p2) mod [M])%Z.
Proof.
intros Hp1 Hp2.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
unfold decode; rewrite reduce_correct.
rewrite sub_mod_correct; auto with zarith.
rewrite !encode_correct; auto with zarith.
rewrite <-Zminus_mod, Zmod_mod, Zmult_minus_distr_r; auto with zarith.
unfold decode; auto with zarith.
Qed.

Lemma decode_encode_mult p1 p2 :
  (0 <= p1 < [M])%Z -> (0 <= p2 < [M])%Z ->
  decode n (reduce_mult_num n (encode n p1) (encode n p2))
     = ((p1 * p2) mod [M])%Z.
Proof.
intros Hp1 Hp2.
rewrite <-(Zmod_small _ [M]).
apply (eq_Tn_correct _ _ n).
unfold decode; rewrite reduce_correct.
apply (eq_Tn_correct _ _ n).
rewrite reduce_mult_correct.
rewrite !encode_correct; auto with zarith.
rewrite <-Zmult_mod; apply f_equal2 with (f := Zmod); auto with zarith.
ring.
unfold decode; auto with zarith.
Qed.

End Reduce.


From CoqAlgs Require Import ListLemmas.
From CoqAlgs Require Export RedBlack.
From CoqAlgs Require Import Sorting.Sort.

(** Sorting with red-black trees. *)

Definition redblackSort
  {A : Type} (leb : A -> A -> bool) (l : list A) : list A :=
    inorder (fromList leb l).

(** Sortedness properties *)

Lemma Sorted_inorder :
  forall (A : Ord) (t : RBTree A),
    isBST t -> Sorted trich_le (inorder t).
Proof.
  induction t as [| c l Hl v r Hr]; cbn; intros.
    constructor.
    inv H. apply Sorted_app_all; auto.
      case_eq (inorder r); intros; subst; auto. constructor.
        apply H6. rewrite <- Elem_inorder. rewrite H. cbn. auto.
        rewrite <- H. auto.
      intros. apply Elem_inorder in H. auto.
Qed.

Lemma Sorted_redblackSort :
  forall (A : Ord) (l : list A),
    Sorted trich_le (redblackSort trich_leb l).
Proof.
  intros. unfold redblackSort. apply Sorted_inorder, isBST_fromList.
Qed.

(** Permutation properties (proved directly). *)

Lemma Permutation_inorder_balance :
  forall (A : Type) (c : color) (v : A) (l r : RBTree A),
    Permutation (inorder (balance c l v r)) (inorder (N c l v r)).
Proof.
  intros.
  functional induction balance c l v r;
  cbn; rewrite <- ?app_assoc; cbn;
  try reflexivity.
    rewrite <- !app_assoc. cbn. reflexivity.
Qed.

Lemma Permutation_inorder_ins :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (t : RBTree A),
    Permutation (inorder (ins leb x t)) (x :: inorder t).
Proof.
  intros. functional induction ins leb x t.
    cbn. reflexivity.
    rewrite Permutation_inorder_balance. cbn. rewrite IHr. cbn. reflexivity.
    rewrite Permutation_inorder_balance. cbn. rewrite IHr.
      rewrite Permutation_middle. apply Permutation_app.
        reflexivity.
        constructor.
Qed.

Lemma Permutation_inorder_insert :
  forall {A : Type} (leb : A -> A -> bool) (x : A) (t : RBTree A),
    Permutation (inorder (insert leb x t)) (x :: inorder t).
Proof.
  intros. unfold insert. destruct (ins leb x t) eqn: Heq; cbn.
    apply (f_equal (Elem x)) in Heq. cut (@Elem color A x E).
      inv 1.
      rewrite <- Heq. rewrite Elem_ins. left. reflexivity.
    rewrite <- (Permutation_inorder_ins leb x t). rewrite Heq.
      cbn. reflexivity.
Qed.

Lemma Permutation_redblackSort :
  forall {A : Type} (leb : A -> A -> bool) (l : list A),
    Permutation (redblackSort leb l) l.
Proof.
  intros. unfold redblackSort.
  induction l as [| h t]; cbn.
    reflexivity.
    rewrite Permutation_inorder_insert, IHt. reflexivity.
Qed.

#[export]
Instance Sort_redblackSort (A : Ord) : Sort trich_le :=
{
    sort := redblackSort trich_leb;
    Sorted_sort := @Sorted_redblackSort A;
    Permutation_sort := @Permutation_redblackSort A trich_leb;
}.

(** Permutation properties proved by way of counting. *)

Lemma countEBT_balance :
  forall (A : Type) (p : A -> bool) (c : color) (v : A) (l r : RBTree A),
    countEBT p (balance c l v r) = countEBT p (N c l v r).
Proof.
  intros.
  functional induction balance c l v r;
  cbn;
  repeat match goal with
      | |- context [if ?p then _ else _] => destruct p
  end;
  lia.
Qed.

Lemma countEBT_makeBlack :
  forall (A : Type) (p : A -> bool) (t : RBTree A),
    countEBT p (makeBlack t) = countEBT p t.
Proof.
  destruct t; reflexivity.
Qed.

Lemma countEBT_ins :
  forall {A : Type} (leb : A -> A -> bool) (p : A -> bool) (x : A) (t : RBTree A),
    countEBT p (ins leb x t) = (if p x then 1 else 0) + countEBT p t.
Proof.
  induction t; cbn;
  try destruct (leb x a);
  rewrite ?countEBT_balance; cbn; rewrite ?IHt1, ?IHt2;
  repeat match goal with
      | |- context [if ?p then _ else _] => destruct p
  end;
  lia.
Qed.

Lemma countEBT_insert :
  forall {A : Type} (leb : A -> A -> bool) (p : A -> bool) (x : A) (t : RBTree A),
    countEBT p (insert leb x t) = (if p x then 1 else 0) + countEBT p t.
Proof.
  intros. unfold insert.
  rewrite countEBT_makeBlack, countEBT_ins. reflexivity.
Qed.

Lemma inorder_countEBT :
  forall (A : Type) (p : A -> bool) (t : RBTree A),
    countEBT p t = count p (inorder t).
Proof.
  induction t; cbn.
    reflexivity.
    rewrite count_app, IHt1, IHt2.
      cbn. destruct (p a); lia.
Qed.

Lemma countEBT_fromList :
  forall {A : Type} (leb : A -> A -> bool) (p : A -> bool) (l : list A),
    countEBT p (fromList leb l) = count p l.
Proof.
  induction l as [| h t]; cbn; trich;
  rewrite countEBT_insert, IHt.
  destruct (p h); reflexivity.
Qed.

Lemma perm_redblackSort :
  forall {A : Type} (leb : A -> A -> bool) (l : list A),
    perm l (redblackSort leb l).
Proof.
  unfold perm, redblackSort. intros.
  rewrite <- inorder_countEBT, countEBT_fromList. reflexivity.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Bishop.Exp.

Import BishopNotations.
Import ExpNotations.

Open Scope bishop_scope.

Close Scope nat.

#[program]
Definition prod (A B: Bishop): Bishop := A * B /~ {| equiv x y := fst x == fst y ∧ snd x == snd y |}.

Next Obligation.
Proof.
  exists.
  all: unfold Reflexive, Symmetric, Transitive.
  - split.
    all: reflexivity.
  - intros ? ? p.
    destruct p.
    split.
    all: symmetry.
    all: assumption.
  - intros ? ? ? p q.
    destruct p as [p p'], q as [q q'].
    rewrite p, q, p', q'.
    split.
    all: reflexivity.
Qed.

#[program]
Definition fanout {C A B: Bishop} (f: exp C A) (g: exp C B): exp C (prod A B) := λ x, (f x, g x).

Next Obligation.
Proof.
  intros ? ? p.
  cbn.
  split.
  all: rewrite p.
  all: reflexivity.
Qed.

#[program]
Definition fst {A B: Bishop}: exp (prod A B) A := fst.

Next Obligation.
Proof.
  intros ? ? p.
  destruct p as [p q].
  apply p.
Qed.

#[program]
 Definition snd {A B: Bishop}: exp (prod A B) B := snd.

Next Obligation.
Proof.
  intros ? ? p.
  destruct p as [p q].
  apply q.
Qed.

Module ProdNotations.
  Infix "*" := prod : bishop_scope.
End ProdNotations.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * dfa: Deterministic Finite Automata, decidability of language inclusion *)

Require Import comparisons positives ordinal pair lset.
Require Import monoid boolean prop sups bmx.
Set Implicit Arguments.
Unset Printing Implicit Defensive.

(** * DFA and associated language *)

(** A DFA is given by its number of states, a deterministic transition
   function, an acceptance condition, and a finite subset of the
   alphabet.

   States are represented by ordinals of the appropriate size.

   Making the finite subset of the alphabet explicit avoids us to use
   ordinals for the alphabet. *)

Record t := mk {
  n: nat;
  u: ord n;
  M: ord n -> positive -> ord n;
  v: ord n -> bool;
  vars: list positive
}.
Notation "x ^u" := (u x) (at level 2, left associativity).
Notation "x ^M" := (M x) (at level 2, left associativity).
Notation "x ^v" := (v x) (at level 2, left associativity).

(** changing the initial state *)
Definition reroot A i := mk i A^M A^v (vars A).

Lemma reroot_id A: A = reroot A (A^u).
Proof. destruct A; reflexivity. Qed.

(** language of a DFA [A], starting from state [i] *)
Fixpoint lang A i w :=
  match w with
    | nil => is_true (A^v i)
    | cons a w => In a (vars A) /\ lang A (A^M i a) w
  end.

(** * Reduction of DFA language inclusion to DFA language emptiness  *)

Section diff.

Variables A B: t.

(** automaton for [A\B] *)
Definition diff := mk
  (pair.mk (u A) (u B))
  (fun p a => pair.mk (M A (pair.pi1 p) a) (M B (pair.pi2 p) a))
  (fun p => v A (pair.pi1 p) \cap ! v B (pair.pi2 p))
  (vars A).

(** specification of its language *)
Lemma diff_spec: vars A <== vars B ->
  forall i j, lang A i <== lang B j <-> lang diff (pair.mk i j) <== bot.
Proof.
  intro H.
  cut (forall w i j, lang A i w <== lang B j w <-> ~ lang diff (pair.mk i j) w).
   intros G i j. split. intros Hij w Hw. apply G in Hw as []. apply Hij.
   intros Hij w. apply G. intro Hw. elim (Hij _ Hw).
  induction w; intros i j; simpl lang; rewrite pair.pi1mk, pair.pi2mk.
   case (v A i); case (v B j); firstorder discriminate.
    split. intros Hij [HaB Hw]. apply IHw in Hw as []. intro Aw. apply Hij. now split.
    intros Hw [Ha Aw]. split. apply H, Ha. eapply IHw. 2: eassumption. tauto.
Qed.

End diff.

(** * Decidability of DFA language emptiness

   We proceed as follows:
   1. we forget all transition labels to get a directed graph whose
      nodes have an accepting status.
   2. we compute the reflexive and transitive closure of this graph
   3. we deduce the set of all states reachable from the initial state.
   4. the DFA is empty iff this set does not contain any accepting
      states.

   All these computations are straightforward, except for 2, for which
   we exploit Kleene star on Boolean matrices.

   The resulting algorithm is not efficient at all. We don't care
   because this is not the one we execute in the end: this one is just
   used to establish KA completeness. *)

Section empty_dec.

Variables A: t.

(** erased transition graph, represented as a Boolean matrix *)
Definition step: bmx (n A) (n A) := fun i j => \sup_(a\in vars A) eqb_ord (M A i a) j.

(** reflexive transitive closure of this graph *)
Definition steps := (@str bmx _ step).

Variable i: ord (n A).

(** basic properties of this closed graph *)
Lemma steps_refl: steps i i.
Proof. apply bmx_str_clot. constructor. Qed.

Lemma steps_snoc: forall j a, steps i j -> In a (vars A) -> steps i (M A j a).
Proof.
  setoid_rewrite bmx_str_clot. intros. eapply clot_snoc. eassumption.
  setoid_rewrite is_true_sup. eexists. split. eassumption. apply eqb_refl.
Qed.

(** state reached from [i] by following a word [w] in the DFA *)
Fixpoint Ms i w := match w with nil => i | cons a w => Ms (M A i a) w end.

(** each unlabelled path in the erased graph corresponds to a labelled
   path (word) in the DFA *)
Lemma steps_least: forall j, steps i j -> exists w, w <== vars A /\ j = Ms i w.
Proof.
  intros j H. apply bmx_str_clot in H. induction H as [i|i j k Hij _ [w [Hw ->]]].
   exists nil. split. lattice. reflexivity.
  setoid_rewrite is_true_sup in Hij. destruct Hij as [a [Ha Hij]].
  exists (a::w). split. intros b [<-|Hb]. assumption. now apply Hw.
  revert Hij. case eqb_ord_spec. 2: discriminate. now intros <-.
Qed.

(** can we reach an accepting state from [i] *)
Definition empty := \inf_(j<_) (steps i j <<< !v A j).

(* TODO: les deux lemmes suivants sont certainement simplifiables en
   prouvant directement l'équivalence *)

(** if not, all states reachable from [i] map to the empty language *)
Lemma empty_lang1 j: steps i j -> empty -> lang A j <== bot.
Proof.
  intros Hj He. setoid_rewrite is_true_inf in He. setoid_rewrite le_bool_spec in He.
  pose proof (fun i => He i (ordinal.in_seq _)) as H. clear He.
  intro w. revert j Hj. induction w as [|a w IH]; simpl lang; intros j Hj.
  apply (H j), negb_spec in Hj. rewrite Hj. discriminate.
  intros [Ha Hj']. apply IH in Hj' as []. now apply steps_snoc.
Qed.

(** conversely, if [i] maps to them empty language, then there is no
   reachable accepting state *)
Lemma empty_lang2: lang A i <== bot -> empty.
Proof.
  intro H. setoid_rewrite is_true_inf. intros j _.
  rewrite le_bool_spec. intro Hj. apply steps_least in Hj as [w [Hw ->]].
  generalize i (H w) Hw. clear. induction w; intros i Hi Hw.
   simpl in *. destruct (v A i). now elim Hi. reflexivity.
   apply IHw. intro H. elim Hi. split. apply Hw. now left. assumption.
   intros ? ?. apply Hw. now right.
Qed.

(** decidability of language emptiness follows *)
Theorem empty_dec: {lang A i <== bot} + {~ (lang A i <== bot)}.
Proof.
  case_eq empty; [left|right].
   apply (empty_lang1 _ steps_refl H).
  intro E. apply empty_lang2 in E. rewrite H in E. discriminate.
Qed.

End empty_dec.

(** * Decidability of DFA language inclusion *)

Corollary lang_incl_dec A B: vars A <== vars B ->
  forall i j, {lang A i <== lang B j} + {~(lang A i <== lang B j)}.
Proof. intros. eapply sumbool_iff. symmetry. now apply diff_spec. apply empty_dec. Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section weak_inverse_projection_postulate_weak_tarski_s_parallel_postulate.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** Formalization of a proof from Bachmann's article "Zur Parallelenfrage" *)

Lemma weak_inverse_projection_postulate__weak_tarski_s_parallel_postulate :
  weak_inverse_projection_postulate -> weak_tarski_s_parallel_postulate.
Proof.
intro wipp.
cut (forall A B C P T,
       Per A B C -> InAngle T A B C ->
       P <> T -> CongA P B A P B C -> Per B P T -> Coplanar A B C P ->
       exists X Y, Out B A X /\ Col T P X /\ Out B C Y /\ Col T P Y).

  {
  intros rabp A B C T HPer HInAngle.
  assert_diffs.
  destruct (angle_bisector A B C) as [P0 [HIn HConga]]; auto.
  assert_diffs.
  assert (HNCol1 : ~ Col A B C) by (apply per_not_col; auto).
  assert (HNCol2 : ~ Col P0 B A).
  { assert (SumA P0 B A P0 B A A B C) by (apply (conga3_suma__suma A B P0 P0 B C A B C); CongA; SumA).
    intro; apply HNCol1, (col2_suma__col P0 B A P0 B A); assumption.
  }
  assert (HXY : exists X Y, Out B A X /\ Out B C Y /\ Col X T Y).
  { destruct (col_dec B P0 T).
    - assert (HT' : exists T', InAngle T' A B C /\ Perp B T T T').
      { destruct (l10_15 B P0 T A) as [T0 [HPerp HOS]]; Col.
        destruct (cop_inangle__ex_col_inangle A B C T T0) as [T' [HT1 [HT2 HT3]]]; trivial.
            intro; apply HNCol1; Col.
            CopR.
        exists T'; split; trivial.
        assert_diffs.
        apply perp_col with P0; Col.
        apply perp_col1 with T0; Perp.
      }
      destruct HT' as [T' []].
      assert_diffs.
      destruct (rabp A B C T T') as [X [Y]]; Perp; Cop.
        apply col_conga__conga with P0; auto.
      spliter; exists X, Y; repeat (split; [assumption|]); ColR.
    - destruct (l8_18_existence B P0 T) as [P [HP1 HP2]]; trivial.
      assert (Out B P P0).
        apply (acute_col_perp__out T); trivial.
        apply acute_sym, conga_inangle2_per__acute with A C; trivial.
      assert_diffs.
      destruct (rabp A B C P T) as [X [Y]]; auto.
        apply col_conga__conga with P0; auto.
        apply perp_per_1, perp_left_comm, perp_col with P0; auto.
        CopR.
      spliter; exists X, Y; repeat (split; [assumption|]); ColR.
  }
  destruct HXY as [X [Y [HOutX [HOutY HCol]]]].
  assert_diffs.
  assert (HNCol3 : ~ Col A B Y) by (intro; apply HNCol1; ColR).
  assert (X <> Y) by (intro; subst; apply HNCol3; Col).
  exists X, Y; repeat (split; [assumption|]).
  destruct (eq_dec_points T X) as [|HTX]; [subst; Between|].
  destruct (eq_dec_points T Y) as [|HTY]; [subst; Between|].
  apply out2__bet.
  - apply col_one_side_out with B; trivial.
    apply invert_one_side, col_one_side with A; Col.
    apply out_out_one_side with C; trivial.
    apply invert_one_side, in_angle_one_side; Col.
    intro; apply HTX, (l6_21 A B Y X); Col.
  - apply col_one_side_out with B; Col.
    apply invert_one_side, col_one_side with C; Col.
    apply one_side_symmetry, out_out_one_side with A; trivial.
    apply invert_one_side, in_angle_one_side; [Col| |apply l11_24, HInAngle].
    intro; apply HTY, (l6_21 B C X Y); Col.
    intro; apply HNCol1; ColR.
  }

  {
  intros A B C P T HPer HInangle HPT HConga HPerP HCop.
  assert_diffs.
  assert (HIn : InAngle P A B C) by (apply conga_cop_inangle_per2__inangle with T; assumption).
  assert (HSumA : SumA P B A P B A A B C).
    apply (conga3_suma__suma A B P P B C A B C); CongA; SumA.
  assert (HAcute : Acute P B A) by (apply acute_sym, conga_inangle_per__acute with C; assumption).
  assert (HOut : Out B P P) by (apply out_trivial; auto).
  assert (~ Col A B C) by (apply per_not_col; auto).
  destruct (wipp P B A A B C P T) as [X [HX1 HX2]]; trivial; [CopR|].
  destruct (wipp P B C C B A P T) as [Y [HY1 HY2]]; Perp.
    apply (acute_conga__acute P B A); assumption.
    apply (conga3_suma__suma P B A P B A A B C); CongA.
    CopR.
  exists X, Y; repeat (split; Col).
  }
Qed.

End weak_inverse_projection_postulate_weak_tarski_s_parallel_postulate.


(* This files proves some general Lemmas about the real numbers that are
usefull when considering computability. *)

From mathcomp Require Import ssreflect ssrnat ssrbool ssrfun.
From mf Require Import all_mf.
Require Import Reals Psatz.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Local Open Scope R_scope.

Section accumulation.
  Definition acc P x := forall eps, eps > 0 -> exists y, P y /\ Rabs (y - x) < eps.

  Lemma cond_eq_P P x y:
    acc P 0 -> (forall z, P z -> Rabs (x - y) <= Rabs z) -> x = y.
  Proof.
    move => acc prp; apply cond_eq => eps epsg0.
    have [z [pz ineq]]:= acc eps epsg0.
    apply /Rle_lt_trans; first by apply (prp z).
    by rewrite Rminus_0_r in ineq.
  Qed.

  Lemma cond_leq x y: (forall eps, 0 < eps -> x <= y + eps) -> x <= y.
  Proof.
    move => prp.
    apply/Rnot_lt_le => xg0.
    suff: x = y by lra.
    apply/cond_eq => eps eg0.
    by have := prp (eps/2); split_Rabs; lra.
  Qed.

  Definition acc_f_zero_plus T (f: T -> R) := forall eps, eps > 0 -> exists t, 0 < f t < eps.

  Lemma acc_f_acc T (f: T -> R):
    acc_f_zero_plus f <-> acc (fun x => codom (F2MF f) x /\ x > 0) 0.
  Proof.
    split => acc eps epsg0; have := acc eps epsg0.
    - move => [t [g0 leps]]; exists (f t); split.
      + by split; try lra; exists t.
      by rewrite /R_dist Rminus_0_r Rabs_pos_eq; lra.
    move => [y [[[t <-] neq]]]; rewrite /R_dist Rminus_0_r => ineq.
    exists t; split => //.
    by rewrite -[f t]Rabs_pos_eq; lra.
  Qed.

  Lemma cond_eq_f T (f: T -> R) x y:
    acc_f_zero_plus f -> (forall z, 0 < f z -> R_dist x y <= f z) -> x = y.
  Proof.
    move => accu prp.
    apply cond_eq => eps epsg0.
    have [t [g0 ineq]]:= accu eps epsg0.
    by apply/ Rle_lt_trans; first by apply /prp /g0.
  Qed.

  Lemma pwr2gtz m: exists n, (2^n > m)%nat.
  Proof.
    elim: m => [ | m [n /leP ih]]; first by exists 0%nat; apply /leP => /=; lia.
    by exists n.+1; apply /leP => /=; lia.
  Qed.
End accumulation.

Section tpmn.
  Lemma tpmnP n m: reflect (/2^n <= /2^m) (m <= n)%nat.
  Proof.
    case E: (m <= n)%nat.
    - apply/ReflectT/Rinv_le_contravar/Rle_pow/leP/E; try lra.
      by apply/pow_lt; lra.
    apply/ReflectF/Rlt_not_le/Rinv_lt_contravar/Rlt_pow/leP; try lra.
    - apply/Rmult_lt_0_compat; apply/pow_lt; try lra.
    by rewrite ltnNge E.
  Qed.

  Lemma tpmn_half n: / 2 ^ n = / 2 ^ n.+1 + / 2 ^ n.+1.
  Proof. by have pos:= pow_lt 2 n; rewrite /= Rinv_mult_distr; lra. Qed.

  Lemma tpmn_pos n: 0 <= /2^n.
  Proof. by apply/Rlt_le/Rinv_0_lt_compat/pow_lt; lra. Qed.

  Lemma tpmn_lt n: 0 < /2^n.
  Proof. apply/Rinv_0_lt_compat/pow_lt; lra. Qed.

  Lemma accf_tpmn: acc_f_zero_plus (fun n => /2^n).
  Proof.
    move => r rgt0; pose z := Z.to_nat (up (1/r)).
    have [n /leP nprp]:= pwr2gtz z; have g0: 0 < 2^n by apply pow_lt; lra.
    exists n; split; first by apply /Rinv_0_lt_compat /pow_lt; lra.
    rewrite -[r]Rinv_involutive; try lra.
    apply Rinv_lt_contravar; first by rewrite Rmult_comm; apply Rdiv_lt_0_compat;  try lra.
    apply /Rlt_trans; first by have:= (archimed (1 / r)).1 => ineq; rewrite -[/r]Rmult_1_l; apply ineq.
    case E: (up (1/r)) => [ | p | p] //; have pos:= (Pos2Z.pos_is_pos p); last first.
    - by apply /(@Rlt_le_trans _ (IZR 0)); [apply IZR_lt; lia | apply Rlt_le].
    rewrite -[Z.pos _]Z2Nat.id; try lia; rewrite -E -/z -INR_IZR_INZ.
    have ->: 2 = INR 2 by trivial.
    by rewrite -pow_INR; apply lt_INR => /=; lia.
  Qed.

  Lemma dns0_tpmn: forall eps, 0 < eps -> exists n, /2^n < eps.
  Proof. by move => eps /accf_tpmn [n []]; exists n. Qed.
End tpmn.


(** porder_tactic_test.v *)

From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality.

From Babel Require Export SetFacility POrderFacility.

From Babel Require Import Ranko.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma upper_bound_em (T : poset) :
    forall a, @upper_bound T ∅ a.
Proof. ranko. Qed.

Lemma lower_bound_em (T : poset):
    forall a, @lower_bound T ∅ a.
Proof. porder_level. Qed.

(* ub_em : ub(∅) = X *)
Lemma ub_em (T : poset) : @ub T ∅ = 𝕌.
Proof. porder_level. Qed.

(* lb_em : lb(∅) {=} X *)
Lemma lb_em (T : poset) : @lb T ∅ = 𝕌.
Proof. porder_level. Qed.

Lemma in_lb_ub (T : poset) (A : 𝒫(T)) : A ⊆ lb (ub A).
Proof. porder_level. Qed.

Lemma in_ub_lb (T : poset) (A : 𝒫(T)) : A ⊆ ub (lb A).
Proof. porder_level. Qed.

(** The first relation on poset can actually be "subposet" *)
Add Parametric Morphism {T : poset} : (@ub T)
    with signature (@supset T) ==> (@subset T) as ub_mor_sub.
Proof. porder_level. Qed.

Add Parametric Morphism {T : poset} : (@lb T)
    with signature (@supset T) ==> (@subset T) as lb_mor_sub.
Proof. porder_level. Qed.

(* lar_unique : largest element of A is unique *)
Lemma lar_unique (T : poset) (A : 𝒫(T)) (a b : T)
        (Ha_largest : largest A a) (Hb_largest : largest A b)
        : a = b.
Proof. all_move_down. porder_level. Qed.

(* lea_unique : least element of A is unique *)
Lemma lea_unique (T : poset) (A : 𝒫(T)) (a b : T)
        (Ha_least : least A a) (Hb_least : least A b)
        : a = b.
Proof. all_move_down. porder_level. Qed.

(* lar_in_ub : largest element is an upper bound *)
Lemma lar_in_ub (T : poset) (A : 𝒫(T)) (x : T) :
    largest A x -> upper_bound A x.
Proof. porder_level. Qed.

(* lea_in_ub : least element is a lower bound *)
Lemma lea_in_lb (T : poset) (A : 𝒫(T)) (x : T) :
    least A x -> lower_bound A x.
Proof. porder_level. Qed.

Lemma uni_lar_upper_boundP (T : poset) (x : T) :
    largest 𝕌 x <-> upper_bound 𝕌 x.
Proof. porder_level. Qed.

Lemma uni_lea_lower_boundP (T : poset) (x : T) :
    least 𝕌 x <-> lower_bound 𝕌 x.
Proof. porder_level. Qed.

(* lar_subset : A ⊆ B -> largest (A) ⊑ largest (B) *)
Lemma lar_subset (T : poset) (A B: 𝒫(T))
    (a b : T) (HAinB : A ⊆ B)
    (Ha_lar : largest A a) (Hb_lar : largest B b) : a ⊑ b.
Proof. all_move_down. porder_level. Qed.

(* lea_subset : A ⊆ B -> least (B) ⊑ least (A) *)
Lemma lea_subset (T : poset) (A B: 𝒫(T))
    (a b : T) (HAinB : A ⊆ B)
    (Ha_lea : least A a) (Hb_lea : least B b) : b ⊑ a.
Proof. all_move_down. porder_level. Qed.

(** Another view of supremum (least upper bound). *)
Lemma lubP (T : poset) (A : 𝒫(T)) (x : T) :
    supremum A x <-> (forall' a ∈ A, a ⊑ x)
                    /\ (forall u, (forall' a ∈ A, a ⊑ u) -> x ⊑ u).
Proof. porder_level. Qed.

(** Another view of infimum (greatest lower bound). *)
Lemma glbP (T : poset) (A : 𝒫(T)) (x : T) :
    infimum A x <-> (forall' a ∈ A, x ⊑ a)
                    /\ (forall u, (forall' a ∈ A, u ⊑ a) -> u ⊑ x).
Proof. porder_level. Qed.

(* sup_unique : supremum is unique *)
Lemma sup_unique (T : poset) (A : 𝒫(T)) (a b : T)
    (Ha_sup : supremum A a) (Hb_sup : supremum A b)
    : a = b.
Proof. (* porder_level. (time consuming) *) Abort.

(* inf_unique : infimum element of A is unique *)
Lemma inf_unique (T : poset) (A : 𝒫(T)) (a b : T)
    (Ha_inf : infimum A a) (Hb_inf : infimum A b)
    : a = b.
Proof. (* porder_level. (time consuming) *) Abort.

(* lar_is_sup : x = largest A -> x = sup A *)
Lemma lar_is_sup (T : poset) :
    forall (A : 𝒫(T)) (x : T), largest A x -> supremum A x.
Proof. porder_level. Qed.

(* lea_is_inf : x = least A -> x = inf A *)
Lemma lea_is_inf (T : poset) :
    forall (A : 𝒫(T)) (x : T), least A x -> infimum A x.
Proof. porder_level. Qed.

(* sup_le_upper_bound : sup A ⊑ some upper bound of A *)
Lemma sup_le_upper_bound (T : poset) :
    forall (A : 𝒫(T)) (a b : T),
        upper_bound A a -> supremum A b -> b ⊑ a.
Proof. porder_level. Qed.

(* inf_ge_lower_bound : some lower bound of A ⊑ inf A*)
Lemma inf_ge_lower_bound (T : poset) :
    forall (A : 𝒫(T)) (a b : T),
        lower_bound A a -> infimum A b -> a ⊑ b.
Proof. porder_level. Qed.

(* le_sup : ∀ x ∈ A, x ⊑ ⊔A *)
Lemma le_sup (T : poset) (A : 𝒫(T)) (a : T):
    supremum A a -> forall' x ∈ A, x ⊑ a.
Proof. porder_level. Qed.

(* ge_inf : ∀ x ∈ A, × ⊒ ⊓A *)
Lemma ge_inf (T : poset) (A : 𝒫(T)) (a : T):
    infimum A a -> forall' x ∈ A, a ⊑ x.
Proof. porder_level. Qed.

Lemma sup_em_iff_lea_uni (T : poset) (a : T):
    supremum ∅ a <-> least 𝕌 a.
Proof. porder_level. Qed.

Lemma inf_em_iff_lar_uni (T : poset) (a : T):
    infimum ∅ a <-> largest 𝕌 a.
Proof. porder_level. Qed.

Lemma sup_uni_iff_lar_uni (T : poset) (a : T):
    supremum 𝕌 a <-> largest 𝕌 a.
Proof. porder_level. Qed.

Lemma inf_uni_iff_lea_uni (T : poset) (a : T):
    infimum 𝕌 a <-> least 𝕌 a.
Proof. porder_level. Qed.

(* sup_em : sup ∅ = least X *)
Lemma sup_em (T : poset) (a : T):
    supremum ∅ a <-> least 𝕌 a.
Proof. porder_level. Qed.

(* inf_em : sup ∅ {=} largest X *)
Lemma inf_em (T : poset) (a : T):
    infimum ∅ a <-> largest 𝕌 a.
Proof. porder_level. Qed.

(* sup_in_is_lar : sup A ∈ A -> sup A = largest A *)
Lemma sup_in_is_lar (T : poset) (A : 𝒫(T)) (a : T)
    (Ha_sup : supremum A a) (Ha_in : a ∈ A) : largest A a.
Proof. all_move_down. porder_level. Qed.

(* inf_in_is_lea : inf A ∈ A -> inf A = least A *)
Lemma inf_in_is_lea (T : poset) (A : 𝒫(T)) (a : T)
    (Ha_inf : infimum A a) (Ha_in : a ∈ A) : least A a.
Proof. all_move_down. porder_level. Qed.

(* sup_subset : A ⊆ B -> sup A ⊑ sup B *)
Lemma sup_subset (T : poset) (A B: 𝒫(T))
    (a b : T) (HAinB : A ⊆ B)
    (Ha_sup : supremum A a) (Hb_sup : supremum B b) : a ⊑ b.
Proof. all_move_down. porder_level. Qed.

(* inf_subset : A ⊆ B -> inf B ⊑ inf A *)
Lemma inf_subset (T : poset) (A B: 𝒫(T))
    (a b : T) (HAinB : A ⊆ B)
    (Ha_inf : infimum A a) (Hb_inf : infimum B b) : b ⊑ a.
Proof. all_move_down. porder_level. Qed.

(* inf_ub_is_sup : the infimum of upper bounds of A is the supremum of A *)
Lemma inf_ub_is_sup (T : poset) (A : 𝒫(T)):
    forall a, infimum (ub A) a -> supremum A a.
Proof. porder_level. Qed.

(* sup_lb_is_inf : the supremum of lower bounds of A is the infimum of A *)
Lemma sup_lb_is_inf (T : poset) (A : 𝒫(T)):
    forall a, supremum (lb A) a -> infimum A a.
Proof. porder_level. Qed.

Lemma CPO_bottom (C : cpo) : least 𝕌 (⊔ᶜᵖᵒ (set_em C)).
Proof. porder_level. Qed.

Module SubsetOrder.
Section OrderDef.

(** inclusion order (subset) *)
Definition poset_mixin (T : Type): Poset.mixin_of 𝒫(T) :=
    Poset.Mixin {|
        ord_refl := subset_refl;
        ord_trans := subset_trans;
        ord_antisym := subset_asymm;
    |}.

Canonical poset_type (T : Type) := Poset 𝒫(T) (poset_mixin T).

(** Directly construction of complete lattice. *)
Definition clattice_essence (T : Type) : CLattice.essence_of 𝒫(T).
Proof.
    constructor.
    refine (@CLattice.JoinEssence _ big_union _).
    porder_level.
    refine (@CLattice.MeetEssence _ big_itsct _).
    porder_level.
Defined.

Definition AUX_clattice_type (T : Type) := CLattice 𝒫(T)
            (CLattice.essence_to_mixin (clattice_essence T)).

Definition lattice_mixin (T : Type) : Lattice.mixin_of (Poset.class 𝒫(T)) :=
    Lattice.class [lattice of AUX_clattice_type T].

Canonical lattice_type (T : Type) := Lattice 𝒫(T) (lattice_mixin T).

Definition clattice_mixin (T : Type) : CLattice.mixin_of (Lattice.class 𝒫(T)) :=
    CLattice.class [clattice of AUX_clattice_type T].

Canonical clattice_type (T : Type) := CLattice 𝒫(T) (clattice_mixin T).

Canonical cpo_type (T : Type) : cpo := CPO 𝒫(T) (CPO.class [cpo of [clattice of 𝒫(T)]]).

(*########################################################################*)
(** prove that certaion operators are continuous *)

(** monotonicity of mapR *)
Definition mapR_monotonicMixin {X Y: Type} (f : X -> Y) :
    MonotonicFun.mixin_of (f [<]).
Proof. porder_level. Qed.

Canonical mapR_monotonicType {X Y: Type} (f : X -> Y) :=
    MonotonicFun (f [<]) (@mapR_monotonicMixin _ _ f).

(** continuity of mapR *)
Definition mapR_continuousMixin {X Y: Type} (f : X -> Y) :
    ContinuousFun.mixin_of (MonotonicFun.class (f [<])).
Proof. porder_level. Qed.

Canonical mapR_continuousType {X Y: Type} (f : X -> Y) :=
    ContinuousFun (f[<]) (@mapR_continuousMixin _ _ f).

(** monotonicity of bigU *)

Definition bigU_monotonicMixin {X : Type} :
    MonotonicFun.mixin_of (@big_union X).
Proof. porder_level. Qed.

Canonical bigU_monotonicType (X : Type) :=
    MonotonicFun big_union (@bigU_monotonicMixin X).

(** continuity of bigU *)

Definition bigU_continuousMixin {X : Type} :
    ContinuousFun.mixin_of (MonotonicFun.class (@big_union X)).
Proof. porder_level. Qed.

Canonical bigU_continuousType {X : Type} :=
    ContinuousFun big_union (@bigU_continuousMixin X).

End OrderDef.

End SubsetOrder.


Hypothesis U : Set.
Hypothesis u : U.
Hypothesis P : U -> Prop.

Axiom LEM : forall P : Prop, P \/ ~P.

Lemma drinkerParadox : exists x, (P x -> forall y, P y).
Proof.
  specialize (LEM (exists x, ~ P x)).
  intro H1.
  destruct H1 as [H2 | H3].
  +
    destruct H2 as [z H3].
    exists z.
    intro H4.
    contradiction.
  +
    exists u.
    intro H5.
    intro w.
    specialize (LEM (P w)).
    intro H6.
    destruct H6 as [H7 | H8].
    *
      assumption.
    *
      absurd (exists x, ~ P x).
      -
        assumption.
      -
        exists w.
        assumption.
Qed.


From Coq Require Import ZArith.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import div choice fintype tuple finfun bigop finset prime.
From mathcomp Require Import order binomial ssralg countalg ssrnum ssrint.
From mathcomp Require Import zify_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.Theory GRing.Theory Num.Theory.

Definition int_of_Z (n : Z) : int :=
  match n with
  | Z0 => Posz 0
  | Zpos p => Posz (Pos.to_nat p)
  | Zneg p => Negz (Pos.to_nat p).-1
  end.

Definition Z_of_int (n : int) : Z :=
  match n with
  | Posz n => Z.of_nat n
  | Negz n' => Z.opp (Z.of_nat (n' + 1))
  end.

Lemma int_of_ZK : cancel int_of_Z Z_of_int.
Proof. by case=> //= p; lia. Qed.

Lemma Z_of_intK : cancel Z_of_int int_of_Z.
Proof.
case=> [[|n]|n] //=.
  congr Posz; lia.
rewrite addnC /=; congr Negz; lia.
Qed.

Module ZInstances.

Implicit Types (m n : Z).

Fact eqZP : Equality.axiom Z.eqb.
Proof. by move=> x y; apply: (iffP idP); lia. Qed.

Canonical Z_eqType := EqType Z (EqMixin eqZP).
Canonical Z_choiceType := ChoiceType Z (CanChoiceMixin int_of_ZK).
Canonical Z_countType := CountType Z (CanCountMixin int_of_ZK).

Definition Z_zmodMixin :=
  ZmodMixin Zplus_assoc Zplus_comm Zplus_0_l Zplus_opp_l.
Canonical Z_zmodType := ZmodType Z Z_zmodMixin.

Definition Z_ringMixin :=
  RingMixin
    Zmult_assoc Zmult_1_l Zmult_1_r Zmult_plus_distr_l Zmult_plus_distr_r isT.
Canonical Z_ringType := RingType Z Z_ringMixin.
Canonical Z_comRingType := ComRingType Z Zmult_comm.

Definition unitZ := [qualify a n : Z | (n == Z.pos xH) || (n == Z.neg xH)].
Definition invZ n := n.

Fact mulVZ : {in unitZ, left_inverse 1%R invZ *%R}.
Proof. by move=> n /pred2P[] ->. Qed.

Fact unitZPl m n : (n * m = 1)%R -> m \is a unitZ.
Proof. case: m n => [|[m|m|]|[m|m|]] [|n|n] //= []; lia. Qed.

Fact invZ_out : {in [predC unitZ], invZ =1 id}.
Proof. exact. Qed.

Fact idomain_axiomZ m n : (m * n = 0)%R -> (m == 0%R) || (n == 0%R).
Proof. by case: m n => [|m|m] []. Qed.

Canonical Z_unitRingType :=
  UnitRingType Z (ComUnitRingMixin mulVZ unitZPl invZ_out).
Canonical Z_comUnitRing := [comUnitRingType of Z].
Canonical Z_idomainType := IdomainType Z idomain_axiomZ.

Canonical Z_countZmodType := [countZmodType of Z].
Canonical Z_countRingType := [countRingType of Z].
Canonical Z_countComRingType := [countComRingType of Z].
Canonical Z_countUnitRingType := [countUnitRingType of Z].
Canonical Z_countComUnitRingType := [countComUnitRingType of Z].
Canonical Z_countIdomainType := [countIdomainType of Z].

Fact leZ_add m n : Z.leb 0 m -> Z.leb 0 n -> Z.leb 0 (m + n). Proof. lia. Qed.
Fact leZ_mul m n : Z.leb 0 m -> Z.leb 0 n -> Z.leb 0 (m * n). Proof. lia. Qed.
Fact leZ_anti m : Z.leb 0 m -> Z.leb m 0 -> m = Z0. Proof. lia. Qed.

Fact subZ_ge0 m n : Z.leb 0 (n - m)%R = Z.leb m n.
Proof. by rewrite /GRing.add /GRing.opp /=; lia. Qed.

Fact leZ_total m n : Z.leb m n || Z.leb n m. Proof. lia. Qed.

Fact normZN m : Z.abs (- m) = Z.abs m. Proof. lia. Qed.

Fact geZ0_norm m : Z.leb 0 m -> Z.abs m = m. Proof. lia. Qed.

Fact ltZ_def m n : (Z.ltb m n) = (n != m) && (Z.leb m n).
Proof. by rewrite eqE /=; lia. Qed.

Definition Mixin : realLeMixin [idomainType of Z] :=
  RealLeMixin
    leZ_add leZ_mul leZ_anti subZ_ge0 (leZ_total 0) normZN geZ0_norm ltZ_def.

Canonical Z_porderType := POrderType ring_display Z Mixin.
Canonical Z_latticeType := LatticeType Z Mixin.
Canonical Z_distrLatticeType := DistrLatticeType Z Mixin.
Canonical Z_orderType := OrderType Z leZ_total.
Canonical Z_numDomainType := NumDomainType Z Mixin.
Canonical Z_normedZmodType := NormedZmodType Z Z Mixin.
Canonical Z_realDomainType := [realDomainType of Z].

Fact Z_of_intE (n : int) : Z_of_int n = (n%:~R)%R.
Proof.
have Hnat (m : nat) : Z.of_nat m = (m%:R)%R.
  by elim: m => // m; rewrite Nat2Z.inj_succ -Z.add_1_l mulrS => ->.
case: n => n; rewrite /intmul /=; first exact: Hnat.
by congr Z.opp; rewrite Nat2Z.inj_add /= mulrSr Hnat.
Qed.

Fact Z_of_int_is_additive : additive Z_of_int.
Proof. by move=> m n; rewrite !Z_of_intE raddfB. Qed.

Canonical Z_of_int_additive := Additive Z_of_int_is_additive.

Fact int_of_Z_is_additive : additive int_of_Z.
Proof. exact: can2_additive Z_of_intK int_of_ZK. Qed.

Canonical int_of_Z_additive := Additive int_of_Z_is_additive.

Fact Z_of_int_is_multiplicative : multiplicative Z_of_int.
Proof. by split => // n m; rewrite !Z_of_intE rmorphM. Qed.

Canonical Z_of_int_rmorphism := AddRMorphism Z_of_int_is_multiplicative.

Fact int_of_Z_is_multiplicative : multiplicative int_of_Z.
Proof. exact: can2_rmorphism Z_of_intK int_of_ZK. Qed.

Canonical int_of_Z_rmorphism := AddRMorphism int_of_Z_is_multiplicative.

End ZInstances.

Canonical ZInstances.Z_eqType.
Canonical ZInstances.Z_choiceType.
Canonical ZInstances.Z_countType.
Canonical ZInstances.Z_zmodType.
Canonical ZInstances.Z_ringType.
Canonical ZInstances.Z_comRingType.
Canonical ZInstances.Z_unitRingType.
Canonical ZInstances.Z_comUnitRing.
Canonical ZInstances.Z_idomainType.
Canonical ZInstances.Z_countZmodType.
Canonical ZInstances.Z_countRingType.
Canonical ZInstances.Z_countComRingType.
Canonical ZInstances.Z_countUnitRingType.
Canonical ZInstances.Z_countComUnitRingType.
Canonical ZInstances.Z_countIdomainType.
Canonical ZInstances.Z_porderType.
Canonical ZInstances.Z_latticeType.
Canonical ZInstances.Z_distrLatticeType.
Canonical ZInstances.Z_orderType.
Canonical ZInstances.Z_numDomainType.
Canonical ZInstances.Z_normedZmodType.
Canonical ZInstances.Z_realDomainType.
Canonical ZInstances.Z_of_int_additive.
Canonical ZInstances.int_of_Z_additive.
Canonical ZInstances.Z_of_int_rmorphism.
Canonical ZInstances.int_of_Z_rmorphism.


From TLTT Require Import MLTT2.Overture.
From TLTT Require Import Strict_eq.

Require Import Reedy.Overture.

Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

(* Strict isomorphism *)

Infix "∘" := (compose) (at level 70).

Class StrictIso (A B : Type) :=
  { to : A -> B;
    from : B -> A;
    left_inv : from ∘ to ≡≡ idmap;
    right_inv : to ∘ from ≡≡ idmap;
  }.

Notation "A ≃ˢ B" := (StrictIso A B) (at level 70).

Definition to_fn {A B : Type} (e : StrictIso A B) : A → B := @to A B e.
Infix "∙" := (to_fn) (at level 70).

Section StrictIso.

  Definition SI_symm {A B : Type} (φ : A ≃ˢ B) : B ≃ˢ A :=
    {| to:= from ;
       from := to;
       left_inv := λ x, right_inv _ ▹ˢ eq_refl;
       right_inv := λ x, left_inv _ ▹ˢ eq_refl |}.

  Instance SI_trans {A B C : Type} (φ : A ≃ˢ B) (ψ : B ≃ˢ C) : A ≃ˢ C.
    destruct φ as [f g l r].
    destruct ψ as [f' g' l' r'].
    refine {| to:= f' ∘ f ;
              from := g ∘ g';
              left_inv := _;
              right_inv := _ |}.
  - intros. rewrite l',l. reflexivity.
  - intros. rewrite r,r'. reflexivity.
  Defined.

  Definition SI_refl {A : Type} : A ≃ˢ A :=
    {| to:= idmap;
       from := idmap;
       left_inv := λ x, eq_refl;
       right_inv := λ x, eq_refl |}.

(* Notation "[| x ≡ y :: p ; '___' ≡ z :: q ; '___' ≡ .. ; '___' ≡ u :: v |]" := *)
(*   (@Econcat _ x y z p (@Econcat _ y z z q .. (@Econcat _ _ _ _ v eq_refl) ..)) (at level 70). *)
  (*   (cons    x (cons    y .. (cons    z nil    ) ..)) *)

  Instance pi_congr₁ {A A' : Type} {F : A'  → Type} (φ : A ≃ˢ A')
    : (Π (a : A), F (φ ∙ a)) ≃ˢ (Π (a : A'), F a).
  Proof.
    destruct φ as [f g l r].
    simpl in *.
    (* Here I had to provide more type annotations in comparison with Lean code *)
    refine {| to:= (λ (k : Π (a : A), F (f a)) x', r x' ▹ˢ k (g x'));
              from := (λ (h : (Π (a : A'), F a)) x, h (f x));
              left_inv := _;
              right_inv := _ |}.
    - intros k. apply functional_extensionality_dep. intro x.
      assert (r (f x) ≡ Eap f (l x)) by apply Eq_UIP. rewrite H.
      rewrite Enaturality_transport.
      rewrite EapD.
      reflexivity.
    - intros. apply functional_extensionality_dep. intros x'.
      apply EapD.
  Qed.

  Instance pi_congr₂ {A : Type} {F G : A → Type} (φ : Π a, F a ≃ˢ G a)
    : (Π (a : A), F a) ≃ˢ (Π (a : A), G a).
  Proof.
    refine {| to:= λ x a, (φ a) ∙ x a;
              from := λ x b, from (x b);
              left_inv := _ ;
              right_inv := _ |}.
    - intros x. apply functional_extensionality_dep.
      intros a. rewrite left_inv. reflexivity.
    - intros x. apply functional_extensionality_dep.
      intros a. unfold to_fn. rewrite right_inv. reflexivity.
  Qed.

  Definition pi_congr {A A': Type} {F : A → Type} {F' : A' → Type}
             (φ : A ≃ˢ A') (φ' : Π a, F a ≃ˢ F' (φ ∙ a)) :  (Π a : A, F a) ≃ˢ (Π a : A', F' a)
    := _.

  Definition sigma_congr₁ {A B: Type} {F : B → Type} (φ : A ≃ˢ B):
    (Σ a : A, F (φ ∙ a)) ≃ˢ Σ b : B, F b.
    refine {| to:= λ (x : Σ a : A, F (φ ∙ a)), (φ ∙ x.1; x.2);
              from := λ x, (from x.1; Etransport (λ x, F x) (- right_inv x.1) x.2);
              left_inv := _;
              right_inv := _ |}.
    - intros.
      destruct φ as [f g l r].
      destruct x as [x₁ x₂]. simpl.
      unfold to_fn.
      apply (eq_sigma _ (l x₁)).
      replace (r (f x₁)) with (Eap f (l x₁)) by apply Eq_UIP.
      rewrite Eap_inv.
      rewrite Enaturality_transport.
      rewrite Etransport_concat.
      rewrite Econcat_inv_r.
      reflexivity.
    - intros x.
      destruct φ as [f g l r].
      destruct x as [x₁ x₂]. simpl.
      apply (eq_sigma _ (r x₁)).
      rewrite Etransport_concat.
      rewrite Econcat_inv_r.
      reflexivity.
  Qed.

  Definition sigma_swap {A B : Type} {F : A → B → Type} :
    (Σ (a : A) (b : B), F a b) ≃ˢ Σ (b : B) (a : A), F a b.
     refine {| to:= λ (x : Σ (a : A) (b : B), F a b), (x.2.1 ; (x.1; x.2.2));
               from := λ (x : Σ (b : B) (a : A), F a b), (x.2.1 ; (x.1; x.2.2));
               left_inv := _;
               right_inv := _ |}.
     - destruct x as [p1 p2]; destruct p2; reflexivity.
     - destruct x as [p1 p2]; destruct p2; reflexivity.
  Qed.

  Locate "↔".

  Instance iff_impl_equiv {A B : Prop} (Hiff : A ↔ B) : A ≃ˢ B.
  Proof.
    destruct Hiff as [f g].
    refine {| to := f;
       from := g;
       left_inv := λ x, proof_irrelevance _ _ _;
       right_inv := λ x, proof_irrelevance _ _ _ |}.
  Qed.

End StrictIso.

(* In this development, we assume that fibrant type are closed under strict isomorphims *)

Axiom StrictIso_Fibrant : Π (A B: Type) {FibA : Fibrant A}, A ≃ˢ B → Fibrant B.