From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E F Aprime Cprime Dprime Fprime A0 C0 D0 F0 : Universe, ((wd_ Cprime B /\ (wd_ C B /\ (wd_ Dprime E /\ (wd_ D E /\ (wd_ Fprime E /\ (wd_ F E /\ (wd_ Aprime B /\ (wd_ A B /\ (wd_ B A0 /\ (wd_ E F0 /\ (wd_ E D0 /\ (wd_ B C0 /\ (wd_ D D0 /\ (wd_ C C0 /\ (wd_ A A0 /\ (wd_ F F0 /\ (col_ E F F0 /\ (col_ E D D0 /\ (col_ B C C0 /\ (col_ B A A0 /\ (col_ E Fprime F /\ (col_ E Dprime D /\ (col_ B Cprime C /\ col_ B Aprime A))))))))))))))))))))))) -> col_ B Aprime A0)).
Proof.
  time tac.
Qed.

End FOFProblem.


From iris.proofmode Require Import proofmode.
From iris.base_logic.lib Require Import mono_nat.
From iris.program_logic Require Export total_adequacy.
From iris.heap_lang Require Export adequacy.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

Definition heap_total Σ `{!heapGpreS Σ} s e σ φ :
  (∀ `{!heapGS_gen HasNoLc Σ}, ⊢ inv_heap_inv -∗ WP e @ s; ⊤ [{ v, ⌜φ v⌝ }]) →
  sn erased_step ([e], σ).
Proof.
  intros Hwp; eapply (twp_total _ _); iIntros (?) "".
  iMod (gen_heap_init σ.(heap)) as (?) "[Hh _]".
  iMod (inv_heap_init loc (option val)) as (?) ">Hi".
  iMod (proph_map_init [] σ.(used_proph_id)) as (?) "Hp".
  iMod (mono_nat_own_alloc 0) as (γ) "[Hsteps _]".
  iModIntro.
  iExists
    (λ σ ns κs _, (gen_heap_interp σ.(heap) ∗
                   proph_map_interp κs σ.(used_proph_id) ∗
                   mono_nat_auth_own γ 1 ns)%I),
    id, (λ _, True%I), _; iFrame.
  by iApply (Hwp (HeapGS _ _ _ _ _ _ _ _)).
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2013 Sylvie Boldo
#<br />#
Copyright (C) 2011-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import ZArith.
Require Import Zquot.

Section Zmissing.

(** About Z *)
Theorem Zopp_le_cancel :
  forall x y : Z,
  (-y <= -x)%Z -> Z.le x y.
Proof.
intros x y Hxy.
apply Zplus_le_reg_r with (-x - y)%Z.
now ring_simplify.
Qed.

Theorem Zgt_not_eq :
  forall x y : Z,
  (y < x)%Z -> (x <> y)%Z.
Proof.
intros x y H Hn.
apply Z.lt_irrefl with x.
now rewrite Hn at 1.
Qed.

End Zmissing.

Section Proof_Irrelevance.

Scheme eq_dep_elim := Induction for eq Sort Type.

Definition eqbool_dep P (h1 : P true) b :=
  match b return P b -> Prop with
  | true => fun (h2 : P true) => h1 = h2
  | false => fun (h2 : P false) => False
  end.

Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2.
Proof.
assert (forall (h : true = true), refl_equal true = h).
apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)).
intros b.
case b.
intros h1 h2.
now rewrite <- (H h1).
intros h.
discriminate h.
Qed.

End Proof_Irrelevance.

Section Even_Odd.

(** Zeven, used for rounding to nearest, ties to even *)
Definition Zeven (n : Z) :=
  match n with
  | Zpos (xO _) => true
  | Zneg (xO _) => true
  | Z0 => true
  | _ => false
  end.

Theorem Zeven_mult :
  forall x y, Zeven (x * y) = orb (Zeven x) (Zeven y).
Proof.
now intros [|[xp|xp|]|[xp|xp|]] [|[yp|yp|]|[yp|yp|]].
Qed.

Theorem Zeven_opp :
  forall x, Zeven (- x) = Zeven x.
Proof.
now intros [|[n|n|]|[n|n|]].
Qed.

Theorem Zeven_ex :
  forall x, exists p, x = (2 * p + if Zeven x then 0 else 1)%Z.
Proof.
intros [|[n|n|]|[n|n|]].
now exists Z0.
now exists (Zpos n).
now exists (Zpos n).
now exists Z0.
exists (Zneg n - 1)%Z.
change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z.
ring.
now exists (Zneg n).
now exists (-1)%Z.
Qed.

Theorem Zeven_2xp1 :
  forall n, Zeven (2 * n + 1) = false.
Proof.
intros n.
destruct (Zeven_ex (2 * n + 1)) as (p, Hp).
revert Hp.
case (Zeven (2 * n + 1)) ; try easy.
intros H.
apply False_ind.
omega.
Qed.

Theorem Zeven_plus :
  forall x y, Zeven (x + y) = Bool.eqb (Zeven x) (Zeven y).
Proof.
intros x y.
destruct (Zeven_ex x) as (px, Hx).
rewrite Hx at 1.
destruct (Zeven_ex y) as (py, Hy).
rewrite Hy at 1.
replace (2 * px + (if Zeven x then 0 else 1) + (2 * py + (if Zeven y then 0 else 1)))%Z
  with (2 * (px + py) + ((if Zeven x then 0 else 1) + (if Zeven y then 0 else 1)))%Z by ring.
case (Zeven x) ; case (Zeven y).
rewrite Zplus_0_r.
now rewrite Zeven_mult.
apply Zeven_2xp1.
apply Zeven_2xp1.
replace (2 * (px + py) + (1 + 1))%Z with (2 * (px + py + 1))%Z by ring.
now rewrite Zeven_mult.
Qed.

End Even_Odd.

Section Zpower.

Theorem Zpower_plus :
  forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z ->
  Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z.
Proof.
intros n k1 k2 H1 H2.
now apply Zpower_exp ; apply Z.le_ge.
Qed.

Theorem Zpower_Zpower_nat :
  forall b e, (0 <= e)%Z ->
  Zpower b e = Zpower_nat b (Z.abs_nat e).
Proof.
intros b [|e|e] He.
apply refl_equal.
apply Zpower_pos_nat.
elim He.
apply refl_equal.
Qed.

Theorem Zpower_nat_S :
  forall b e,
  Zpower_nat b (S e) = (b * Zpower_nat b e)%Z.
Proof.
intros b e.
rewrite (Zpower_nat_is_exp 1 e).
apply (f_equal (fun x => x * _)%Z).
apply Zmult_1_r.
Qed.

Theorem Zpower_pos_gt_0 :
  forall b p, (0 < b)%Z ->
  (0 < Zpower_pos b p)%Z.
Proof.
intros b p Hb.
rewrite Zpower_pos_nat.
induction (nat_of_P p).
easy.
rewrite Zpower_nat_S.
now apply Zmult_lt_0_compat.
Qed.

Theorem Zeven_Zpower :
  forall b e, (0 < e)%Z ->
  Zeven (Zpower b e) = Zeven b.
Proof.
intros b e He.
case_eq (Zeven b) ; intros Hb.
(* b even *)
replace e with (e - 1 + 1)%Z by ring.
rewrite Zpower_exp.
rewrite Zeven_mult.
replace (Zeven (b ^ 1)) with true.
apply Bool.orb_true_r.
unfold Zpower, Zpower_pos. simpl.
now rewrite Zmult_1_r.
omega.
discriminate.
(* b odd *)
rewrite Zpower_Zpower_nat.
induction (Z.abs_nat e).
easy.
unfold Zpower_nat. simpl.
rewrite Zeven_mult.
now rewrite Hb.
now apply Zlt_le_weak.
Qed.

Theorem Zeven_Zpower_odd :
  forall b e, (0 <= e)%Z -> Zeven b = false ->
  Zeven (Zpower b e) = false.
Proof.
intros b e He Hb.
destruct (Z_le_lt_eq_dec _ _ He) as [He'|He'].
rewrite <- Hb.
now apply Zeven_Zpower.
now rewrite <- He'.
Qed.

(** The radix must be greater than 1 *)
Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }.

Theorem radix_val_inj :
  forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2.
Proof.
intros (r1, H1) (r2, H2) H.
simpl in H.
revert H1.
rewrite H.
intros H1.
apply f_equal.
apply eqbool_irrelevance.
Qed.

Definition radix2 := Build_radix 2 (refl_equal _).

Variable r : radix.

Theorem radix_gt_0 : (0 < r)%Z.
Proof.
apply Z.lt_le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

Theorem radix_gt_1 : (1 < r)%Z.
Proof.
destruct r as (v, Hr). simpl.
apply Z.lt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.

Theorem Zpower_gt_1 :
  forall p,
  (0 < p)%Z ->
  (1 < Zpower r p)%Z.
Proof.
intros [|p|p] Hp ; try easy.
simpl.
rewrite Zpower_pos_nat.
generalize (lt_O_nat_of_P p).
induction (nat_of_P p).
easy.
intros _.
rewrite Zpower_nat_S.
assert (0 < Zpower_nat r n)%Z.
clear.
induction n.
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
apply Z.le_lt_trans with (1 * Zpower_nat r n)%Z.
rewrite Zmult_1_l.
now apply (Zlt_le_succ 0).
apply Zmult_lt_compat_r with (1 := H).
apply radix_gt_1.
Qed.

Theorem Zpower_gt_0 :
  forall p,
  (0 <= p)%Z ->
  (0 < Zpower r p)%Z.
Proof.
intros p Hp.
rewrite Zpower_Zpower_nat with (1 := Hp).
induction (Z.abs_nat p).
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
Qed.

Theorem Zpower_ge_0 :
  forall e,
  (0 <= Zpower r e)%Z.
Proof.
intros [|e|e] ; try easy.
apply Zlt_le_weak.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_le :
  forall e1 e2, (e1 <= e2)%Z ->
  (Zpower r e1 <= Zpower r e2)%Z.
Proof.
intros e1 e2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite <- (Zmult_1_l (r ^ e1)) at 1.
apply Zmult_le_compat_r.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zpower_ge_0.
now apply Zle_minus_le_0.
clear He.
destruct e1 as [|e1|e1] ; try easy.
apply Zpower_ge_0.
Qed.

Theorem Zpower_lt :
  forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z ->
  (Zpower r e1 < Zpower r e2)%Z.
Proof.
intros e1 e2 He2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite Zmult_comm.
rewrite <- (Zmult_1_r (r ^ e1)) at 1.
apply Zmult_lt_compat2.
split.
now apply Zpower_gt_0.
apply Z.le_refl.
split.
easy.
apply Zpower_gt_1.
clear -He ; omega.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
revert H1.
clear -He2.
destruct e1 ; try easy.
intros _.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_lt_Zpower :
  forall e1 e2,
  (Zpower r (e1 - 1) < Zpower r e2)%Z ->
  (e1 <= e2)%Z.
Proof.
intros e1 e2 He.
apply Znot_gt_le.
intros H.
apply Zlt_not_le with (1 := He).
apply Zpower_le.
clear -H ; omega.
Qed.

End Zpower.

Section Div_Mod.

Theorem Zmod_mod_mult :
  forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
  Zmod (Zmod n (a * b)) b = Zmod n b.
Proof.
intros n a [|b|b] Ha Hb.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Z.lt_gt.
easy.
now elim Hb.
Qed.

Theorem ZOmod_eq :
  forall a b,
  Z.rem a b = (a - Z.quot a b * b)%Z.
Proof.
intros a b.
rewrite (Z.quot_rem' a b) at 2.
ring.
Qed.

Theorem ZOmod_mod_mult :
  forall n a b,
  Z.rem (Z.rem n (a * b)) b = Z.rem n b.
Proof.
intros n a b.
assert (Z.rem n (a * b) = n + - (Z.quot n (a * b) * a) * b)%Z.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zmult_assoc.
apply ZOmod_eq.
rewrite H.
apply Z_rem_plus.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem Zdiv_mod_mult :
  forall n a b, (0 <= a)%Z -> (0 <= b)%Z ->
  (Z.div (Zmod n (a * b)) a) = Zmod (Z.div n a) b.
Proof.
intros n a b Ha Hb.
destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha'].
destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb'].
rewrite (Zmod_eq n (a * b)).
rewrite (Zmult_comm a b) at 2.
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
rewrite Z_div_plus by now apply Z.lt_gt.
rewrite <- Zdiv_Zdiv by easy.
apply sym_eq.
apply Zmod_eq.
now apply Z.lt_gt.
now apply Zmult_gt_0_compat ; apply Z.lt_gt.
rewrite <- Hb'.
rewrite Zmult_0_r, 2!Zmod_0_r.
apply Zdiv_0_l.
rewrite <- Ha'.
now rewrite 2!Zdiv_0_r, Zmod_0_l.
Qed.

Theorem ZOdiv_mod_mult :
  forall n a b,
  (Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b.
Proof.
intros n a b.
destruct (Z.eq_dec a 0) as [Za|Za].
rewrite Za.
now rewrite 2!Zquot_0_r, Zrem_0_l.
assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z.
rewrite (ZOmod_eq n (a * b)) at 1.
rewrite Zquot_Zquot.
ring.
rewrite H.
rewrite Z_quot_plus with (2 := Za).
apply sym_eq.
apply ZOmod_eq.
rewrite <- H.
apply Zrem_sgn2.
Qed.

Theorem ZOdiv_small_abs :
  forall a b,
  (Z.abs a < b)%Z -> Z.quot a b = Z0.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Z.quot_small.
split.
exact H.
now rewrite Z.abs_eq in Ha.
apply Z.opp_inj.
rewrite <- Zquot_opp_l, Z.opp_0.
apply Z.quot_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOmod_small_abs :
  forall a b,
  (Z.abs a < b)%Z -> Z.rem a b = a.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply Z.rem_small.
split.
exact H.
now rewrite Z.abs_eq in Ha.
apply Z.opp_inj.
rewrite <- Zrem_opp_l.
apply Z.rem_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOdiv_plus :
  forall a b c, (0 <= a * b)%Z ->
  (Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z.
Proof.
intros a b c Hab.
destruct (Z.eq_dec c 0) as [Zc|Zc].
now rewrite Zc, 4!Zquot_0_r.
apply Zmult_reg_r with (1 := Zc).
rewrite 2!Zmult_plus_distr_l.
assert (forall d, Z.quot d c * c = d - Z.rem d c)%Z.
intros d.
rewrite ZOmod_eq.
ring.
rewrite 4!H.
rewrite <- Zplus_rem with (1 := Hab).
ring.
Qed.

End Div_Mod.

Section Same_sign.

Theorem Zsame_sign_trans :
  forall v u w, v <> Z0 ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv.
Qed.

Theorem Zsame_sign_trans_weak :
  forall v u w, (v = Z0 -> w = Z0) ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv.
Qed.

Theorem Zsame_sign_imp :
  forall u v,
  (0 < u -> 0 <= v)%Z ->
  (0 < -u -> 0 <= -v)%Z ->
  (0 <= u * v)%Z.
Proof.
intros [|u|u] v Hp Hn.
easy.
apply Zmult_le_0_compat.
easy.
now apply Hp.
replace (Zneg u * v)%Z with (Zpos u * (-v))%Z.
apply Zmult_le_0_compat.
easy.
now apply Hn.
rewrite <- Zopp_mult_distr_r.
apply Zopp_mult_distr_l.
Qed.

Theorem Zsame_sign_odiv :
  forall u v, (0 <= v)%Z ->
  (0 <= u * Z.quot u v)%Z.
Proof.
intros u v Hv.
apply Zsame_sign_imp ; intros Hu.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
rewrite <- Zquot_opp_l.
apply Z_quot_pos with (2 := Hv).
now apply Zlt_le_weak.
Qed.

End Same_sign.

(** Boolean comparisons *)

Section Zeq_bool.

Inductive Zeq_bool_prop (x y : Z) : bool -> Prop :=
  | Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true
  | Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false.

Theorem Zeq_bool_spec :
  forall x y, Zeq_bool_prop x y (Zeq_bool x y).
Proof.
intros x y.
generalize (Zeq_is_eq_bool x y).
case (Zeq_bool x y) ; intros (H1, H2) ; constructor.
now apply H2.
intros H.
specialize (H1 H).
discriminate H1.
Qed.

Theorem Zeq_bool_true :
  forall x y, x = y -> Zeq_bool x y = true.
Proof.
intros x y.
apply -> Zeq_is_eq_bool.
Qed.

Theorem Zeq_bool_false :
  forall x y, x <> y -> Zeq_bool x y = false.
Proof.
intros x y.
generalize (proj2 (Zeq_is_eq_bool x y)).
case Zeq_bool.
intros He Hn.
elim Hn.
now apply He.
now intros _ _.
Qed.

End Zeq_bool.

Section Zle_bool.

Inductive Zle_bool_prop (x y : Z) : bool -> Prop :=
  | Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true
  | Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false.

Theorem Zle_bool_spec :
  forall x y, Zle_bool_prop x y (Zle_bool x y).
Proof.
intros x y.
generalize (Zle_is_le_bool x y).
case Zle_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt x y) as [H|H].
now specialize (H1 H).
exact H.
Qed.

Theorem Zle_bool_true :
  forall x y : Z,
  (x <= y)%Z -> Zle_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zle_is_le_bool x y)).
Qed.

Theorem Zle_bool_false :
  forall x y : Z,
  (y < x)%Z -> Zle_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zle_cases x y).
case Zle_bool ; intros H.
elim (Z.lt_irrefl x).
now apply Z.le_lt_trans with y.
apply refl_equal.
Qed.

End Zle_bool.

Section Zlt_bool.

Inductive Zlt_bool_prop (x y : Z) : bool -> Prop :=
  | Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true
  | Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false.

Theorem Zlt_bool_spec :
  forall x y, Zlt_bool_prop x y (Zlt_bool x y).
Proof.
intros x y.
generalize (Zlt_is_lt_bool x y).
case Zlt_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt y x) as [H|H].
exact H.
now specialize (H1 H).
Qed.

Theorem Zlt_bool_true :
  forall x y : Z,
  (x < y)%Z -> Zlt_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zlt_is_lt_bool x y)).
Qed.

Theorem Zlt_bool_false :
  forall x y : Z,
  (y <= x)%Z -> Zlt_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zlt_cases x y).
case Zlt_bool ; intros H.
elim (Z.lt_irrefl x).
now apply Z.lt_le_trans with y.
apply refl_equal.
Qed.

Theorem negb_Zle_bool :
  forall x y : Z,
  negb (Zle_bool x y) = Zlt_bool y x.
Proof.
intros x y.
case Zle_bool_spec ; intros H.
now rewrite Zlt_bool_false.
now rewrite Zlt_bool_true.
Qed.

Theorem negb_Zlt_bool :
  forall x y : Z,
  negb (Zlt_bool x y) = Zle_bool y x.
Proof.
intros x y.
case Zlt_bool_spec ; intros H.
now rewrite Zle_bool_false.
now rewrite Zle_bool_true.
Qed.

End Zlt_bool.

Section Zcompare.

Inductive Zcompare_prop (x y : Z) : comparison -> Prop :=
  | Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt
  | Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq
  | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt.

Theorem Zcompare_spec :
  forall x y, Zcompare_prop x y (Z.compare x y).
Proof.
intros x y.
destruct (Z_dec x y) as [[H|H]|H].
generalize (Zlt_compare _ _ H).
case (Z.compare x y) ; try easy.
now constructor.
generalize (Zgt_compare _ _ H).
case (Z.compare x y) ; try easy.
constructor.
now apply Z.gt_lt.
generalize (proj2 (Zcompare_Eq_iff_eq _ _) H).
case (Z.compare x y) ; try easy.
now constructor.
Qed.

Theorem Zcompare_Lt :
  forall x y,
  (x < y)%Z -> Z.compare x y = Lt.
Proof.
easy.
Qed.

Theorem Zcompare_Eq :
  forall x y,
  (x = y)%Z -> Z.compare x y = Eq.
Proof.
intros x y.
apply <- Zcompare_Eq_iff_eq.
Qed.

Theorem Zcompare_Gt :
  forall x y,
  (y < x)%Z -> Z.compare x y = Gt.
Proof.
intros x y.
apply Z.lt_gt.
Qed.

End Zcompare.

Section cond_Zopp.

Definition cond_Zopp (b : bool) m := if b then Z.opp m else m.

Theorem abs_cond_Zopp :
  forall b m,
  Z.abs (cond_Zopp b m) = Z.abs m.
Proof.
intros [|] m.
apply Zabs_Zopp.
apply refl_equal.
Qed.

Theorem cond_Zopp_Zlt_bool :
  forall m,
  cond_Zopp (Zlt_bool m 0) m = Z.abs m.
Proof.
intros m.
apply sym_eq.
case Zlt_bool_spec ; intros Hm.
apply Zabs_non_eq.
now apply Zlt_le_weak.
now apply Z.abs_eq.
Qed.

End cond_Zopp.

Section fast_pow_pos.

Fixpoint Zfast_pow_pos (v : Z) (e : positive) : Z :=
  match e with
  | xH => v
  | xO e' => Z.square (Zfast_pow_pos v e')
  | xI e' => Zmult v (Z.square (Zfast_pow_pos v e'))
  end.

Theorem Zfast_pow_pos_correct :
  forall v e, Zfast_pow_pos v e = Zpower_pos v e.
Proof.
intros v e.
rewrite <- (Zmult_1_r (Zfast_pow_pos v e)).
unfold Z.pow_pos.
generalize 1%Z.
revert v.
induction e ; intros v f ; simpl.
- rewrite <- 2!IHe.
  rewrite Z.square_spec.
  ring.
- rewrite <- 2!IHe.
  rewrite Z.square_spec.
  apply eq_sym, Zmult_assoc.
- apply eq_refl.
Qed.

End fast_pow_pos.

Section faster_div.

Lemma Zdiv_eucl_unique :
  forall a b,
  Z.div_eucl a b = (Z.div a b, Zmod a b).
Proof.
intros a b.
unfold Z.div, Zmod.
now case Z.div_eucl.
Qed.

Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} :=
  match b with
  | xO b' =>
    match a with
    | xO a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r)%Z
    | xI a' => let (q, r) := Zpos_div_eucl_aux1 a' b' in (q, 2 * r + 1)%Z
    | xH => (Z0, Zpos a)
    end
  | xH => (Zpos a, Z0)
  | xI _ => Z.pos_div_eucl a (Zpos b)
  end.

Lemma Zpos_div_eucl_aux1_correct :
  forall a b,
  Zpos_div_eucl_aux1 a b = Z.pos_div_eucl a (Zpos b).
Proof.
intros a b.
revert a.
induction b ; intros a.
- easy.
- change (Z.pos_div_eucl a (Zpos b~0)) with (Z.div_eucl (Zpos a) (Zpos b~0)).
  rewrite Zdiv_eucl_unique.
  change (Zpos b~0) with (2 * Zpos b)%Z.
  rewrite Z.rem_mul_r by easy.
  rewrite <- Zdiv_Zdiv by easy.
  destruct a as [a|a|].
  + change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z).
    rewrite IHb. clear IHb.
    change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
    rewrite Zdiv_eucl_unique.
    change (Zpos a~1) with (1 + 2 * Zpos a)%Z.
    rewrite (Zmult_comm 2 (Zpos a)).
    rewrite Z_div_plus_full by easy.
    apply f_equal.
    rewrite Z_mod_plus_full.
    apply Zplus_comm.
  + change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z).
    rewrite IHb. clear IHb.
    change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
    rewrite Zdiv_eucl_unique.
    change (Zpos a~0) with (2 * Zpos a)%Z.
    rewrite (Zmult_comm 2 (Zpos a)).
    rewrite Z_div_mult_full by easy.
    apply f_equal.
    now rewrite Z_mod_mult.
  + easy.
- change (Z.pos_div_eucl a 1) with (Z.div_eucl (Zpos a) 1).
  rewrite Zdiv_eucl_unique.
  now rewrite Zdiv_1_r, Zmod_1_r.
Qed.

Definition Zpos_div_eucl_aux (a b : positive) :=
  match Pos.compare a b with
  | Lt => (Z0, Zpos a)
  | Eq => (1%Z, Z0)
  | Gt => Zpos_div_eucl_aux1 a b
  end.

Lemma Zpos_div_eucl_aux_correct :
  forall a b,
  Zpos_div_eucl_aux a b = Z.pos_div_eucl a (Zpos b).
Proof.
intros a b.
unfold Zpos_div_eucl_aux.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
case Pos.compare_spec ; intros H.
now rewrite H, Z_div_same, Z_mod_same.
now rewrite Zdiv_small, Zmod_small by (split ; easy).
rewrite Zpos_div_eucl_aux1_correct.
change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
apply Zdiv_eucl_unique.
Qed.

Definition Zfast_div_eucl (a b : Z) :=
  match a with
  | Z0 => (0, 0)%Z
  | Zpos a' =>
    match b with
    | Z0 => (0, 0)%Z
    | Zpos b' => Zpos_div_eucl_aux a' b'
    | Zneg b' =>
      let (q, r) := Zpos_div_eucl_aux a' b' in
      match r with
      | Z0 => (-q, 0)%Z
      | Zpos _ => (-(q + 1), (b + r))%Z
      | Zneg _ => (-(q + 1), (b + r))%Z
      end
    end
  | Zneg a' =>
    match b with
    | Z0 => (0, 0)%Z
    | Zpos b' =>
      let (q, r) := Zpos_div_eucl_aux a' b' in
      match r with
      | Z0 => (-q, 0)%Z
      | Zpos _ => (-(q + 1), (b - r))%Z
      | Zneg _ => (-(q + 1), (b - r))%Z
      end
    | Zneg b' => let (q, r) := Zpos_div_eucl_aux a' b' in (q, (-r)%Z)
    end
  end.

Theorem Zfast_div_eucl_correct :
  forall a b : Z,
  Zfast_div_eucl a b = Z.div_eucl a b.
Proof.
unfold Zfast_div_eucl.
intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy.
Qed.

End faster_div.

Section Iter.

Context {A : Type}.
Variable (f : A -> A).

Fixpoint iter_nat (n : nat) (x : A) {struct n} : A :=
  match n with
  | S n' => iter_nat n' (f x)
  | O => x
  end.

Lemma iter_nat_plus :
  forall (p q : nat) (x : A),
  iter_nat (p + q) x = iter_nat p (iter_nat q x).
Proof.
induction q.
now rewrite plus_0_r.
intros x.
rewrite <- plus_n_Sm.
apply IHq.
Qed.

Lemma iter_nat_S :
  forall (p : nat) (x : A),
  iter_nat (S p) x = f (iter_nat p x).
Proof.
induction p.
easy.
simpl.
intros x.
apply IHp.
Qed.

Fixpoint iter_pos (n : positive) (x : A) {struct n} : A :=
  match n with
  | xI n' => iter_pos n' (iter_pos n' (f x))
  | xO n' => iter_pos n' (iter_pos n' x)
  | xH => f x
  end.

Lemma iter_pos_nat :
  forall (p : positive) (x : A),
  iter_pos p x = iter_nat (Pos.to_nat p) x.
Proof.
induction p ; intros x.
rewrite Pos2Nat.inj_xI.
simpl.
rewrite plus_0_r.
rewrite iter_nat_plus.
rewrite (IHp (f x)).
apply IHp.
rewrite Pos2Nat.inj_xO.
simpl.
rewrite plus_0_r.
rewrite iter_nat_plus.
rewrite (IHp x).
apply IHp.
easy.
Qed.

End Iter.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Adjunction.Natural.Transformation.
Require Import Category.Theory.Adjunction.
Require Import Category.Instance.Sets.

Generalizable All Variables.

Section AdjunctionToTransform.

Context {C : Category}.
Context {D : Category}.
Context {F : D ⟶ C}.
Context {U : C ⟶ D}.

Program Definition Adjunction_from_Transform (A : F ∹ U) : F ⊣ U := {|
  adj := fun a b =>
    {| to   := {| morphism := fun f =>
         fmap f ∘ @Transformation.unit _ _ _ _ A a |}
     ; from := {| morphism := fun f =>
         @Transformation.counit _ _ _ _ A b ∘ fmap f |} |}
|}.
Next Obligation. proper; rewrites; reflexivity. Qed.
Next Obligation. proper; rewrites; reflexivity. Qed.
Next Obligation.
  rewrite fmap_comp.
  rewrite <- comp_assoc.
  srewrite (naturality[Transformation.unit]).
  rewrite comp_assoc.
  srewrite (@Transformation.fmap_counit_unit); cat.
Qed.
Next Obligation.
  rewrite fmap_comp.
  rewrite comp_assoc.
  srewrite_r (naturality[Transformation.counit]).
  rewrite <- comp_assoc.
  srewrite (@Transformation.counit_fmap_unit); cat.
Qed.
Next Obligation.
  rewrite fmap_comp.
  rewrite <- comp_assoc.
  srewrite (naturality[Transformation.unit]).
  rewrite comp_assoc.
  reflexivity.
Qed.
Next Obligation.
  rewrite fmap_comp.
  rewrite comp_assoc.
  reflexivity.
Qed.
Next Obligation.
  rewrite fmap_comp.
  rewrite comp_assoc.
  reflexivity.
Qed.
Next Obligation.
  rewrite fmap_comp.
  rewrite comp_assoc.
  srewrite_r (naturality[Transformation.counit]).
  rewrite <- comp_assoc.
  reflexivity.
Qed.

Program Definition Adjunction_to_Transform {A : F ⊣ U} : F ∹ U := {|
  Transformation.unit   := {| transform := fun a => @unit _ _ _ _ A a |};
  Transformation.counit := {| transform := fun b => @counit _ _ _ _ A b |}
|}.
Next Obligation.
  unfold unit.
  rewrite <- to_adj_nat_r, <- to_adj_nat_l; cat.
Qed.
Next Obligation.
  unfold unit.
  rewrite <- to_adj_nat_r, <- to_adj_nat_l; cat.
Qed.
Next Obligation.
  unfold counit.
  rewrite <- from_adj_nat_r, <- from_adj_nat_l; cat.
Qed.
Next Obligation.
  unfold counit.
  rewrite <- from_adj_nat_r, <- from_adj_nat_l; cat.
Qed.
Next Obligation.
  unfold unit, counit.
  rewrite <- from_adj_nat_l; cat.
  apply (@iso_from_to _ _ _ adj _).
Qed.
Next Obligation.
  unfold unit, counit.
  rewrite <- to_adj_nat_r; cat.
  apply (@iso_to_from _ _ _ adj _).
Qed.

End AdjunctionToTransform.


Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.Wf.
Require Import Crypto.Reflection.Named.ContextDefinitions.
Require Import Crypto.Reflection.Named.ContextProperties.
Require Import Crypto.Reflection.Named.InterpretToPHOAS.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Wf.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {Name : Type}
          {base_type_code_dec : DecidableRel (@eq base_type_code)}
          {Name_dec : DecidableRel (@eq Name)}
          {interp_base_type : base_type_code -> Type}
          {interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst}.
  Section with_context.
    Context {Context : Context Name interp_base_type}
            {ContextOk : ContextOk Context}
            (failb : forall t, @Syntax.exprf base_type_code op interp_base_type (Tbase t)).

    Lemma interpf_interpf_to_phoas
          (ctx : Context)
          {t} (e : @Named.exprf base_type_code op Name t)
          (Hwf : prop_of_option (Named.wff ctx e))
      : Named.interpf (interp_op:=interp_op) (ctx:=ctx) e
        = Some (Syntax.interpf interp_op (interpf_to_phoas failb ctx e)).
    Proof.
      revert dependent ctx; induction e;
        repeat first [ progress intros
                     | progress subst
                     | progress inversion_option
                     | progress destruct_head' and
                     | progress break_innermost_match_step
                     | progress unfold option_map, LetIn.Let_In in *
                     | apply (f_equal (@Some _))
                     | apply (f_equal (@interp_op _ _ _))
                     | progress simpl in *
                     | progress autorewrite with push_prop_of_option in *
                     | solve [ eauto | congruence | tauto ]
                     | match goal with
                       | [ H : forall ctx Hwf', Named.interpf ?e = Some _, Hwf : prop_of_option (Named.wff _ ?e) |- _ ]
                         => specialize (H _ Hwf)
                       | [ H : forall ctx Hwf, Named.interpf ?e = Some _ |- Named.interpf ?e = Some _ ]
                         => rewrite H by auto
                       end ].
    Qed.

    Lemma interp_interp_to_phoas
          (ctx : Context)
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf : Named.wf ctx e)
          v
      : Named.interp (interp_op:=interp_op) (ctx:=ctx) e v
        = Some (Syntax.interp interp_op (interp_to_phoas failb ctx e) v).
    Proof.
      unfold interp, interp_to_phoas, Named.interp; apply interpf_interpf_to_phoas; auto.
    Qed.
  End with_context.

  Section all.
    Context {Context : forall var, @Context base_type_code Name var}
            {ContextOk : forall var, ContextOk (Context var)}
            (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)).

    Lemma Interp_InterpToPHOAS_gen
          {ctx : forall var, Context var}
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf : forall var, Named.wf (ctx var) e)
          v
      : Named.interp (interp_op:=interp_op) (ctx:=ctx _) e v
        = Some (Interp interp_op (InterpToPHOAS_gen failb ctx e) v).
    Proof. apply interp_interp_to_phoas; auto. Qed.

    Lemma Interp_InterpToPHOAS
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf : Named.Wf Context e)
          v
      : Named.interp (Context:=Context _) (interp_op:=interp_op) (ctx:=empty) e v
        = Some (Interp interp_op (InterpToPHOAS (Context:=Context) failb e) v).
    Proof. apply interp_interp_to_phoas; auto. Qed.
  End all.
End language.


From Hammer Require Import Hammer.

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import NArith.
Require Import Ndigits.
Require Import Ndec.
From IntMap Require Import Map.
From IntMap Require Import Mapaxioms.
From IntMap Require Import Mapiter.
From IntMap Require Import Fset.
Require Import List.
From IntMap Require Import Lsort.
From IntMap Require Import Mapsubset.
From IntMap Require Import Mapcard.

Section MapCanon.

Variable A : Type.

Inductive mapcanon : Map A -> Prop :=
| M0_canon : mapcanon (M0 A)
| M1_canon : forall (a:ad) (y:A), mapcanon (M1 A a y)
| M2_canon :
forall m1 m2:Map A,
mapcanon m1 ->
mapcanon m2 -> 2 <= MapCard A (M2 A m1 m2) -> mapcanon (M2 A m1 m2).

Lemma mapcanon_M2 :
forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> 2 <= MapCard A (M2 A m1 m2).
Proof. hammer_hook "Mapcanon" "Mapcanon.mapcanon_M2".
intros. inversion H. assumption.
Qed.

Lemma mapcanon_M2_1 :
forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m1.
Proof. hammer_hook "Mapcanon" "Mapcanon.mapcanon_M2_1".
intros. inversion H. assumption.
Qed.

Lemma mapcanon_M2_2 :
forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m2.
Proof. hammer_hook "Mapcanon" "Mapcanon.mapcanon_M2_2".
intros. inversion H. assumption.
Qed.

Lemma M2_eqmap_1 :
forall m0 m1 m2 m3:Map A,
eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m0 m2.
Proof. hammer_hook "Mapcanon" "Mapcanon.M2_eqmap_1".
unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_div2 a).
rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m0 m1).
rewrite <- (MapGet_M2_bit_0_0 A _ (Ndouble_bit0 a) m2 m3).
exact (H (N.double a)).
Qed.

Lemma M2_eqmap_2 :
forall m0 m1 m2 m3:Map A,
eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m1 m3.
Proof. hammer_hook "Mapcanon" "Mapcanon.M2_eqmap_2".
unfold eqmap, eqm in |- *. intros. rewrite <- (Ndouble_plus_one_div2 a).
rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m0 m1).
rewrite <- (MapGet_M2_bit_0_1 A _ (Ndouble_plus_one_bit0 a) m2 m3).
exact (H (Ndouble_plus_one a)).
Qed.

Lemma mapcanon_unique :
forall m m':Map A, mapcanon m -> mapcanon m' -> eqmap A m m' -> m = m'.
Proof. hammer_hook "Mapcanon" "Mapcanon.mapcanon_unique".
simple induction m. simple induction m'. trivial.
intros a y H H0 H1. cut (None = MapGet A (M1 A a y) a). simpl in |- *. rewrite (Neqb_correct a).
intro. discriminate H2.
exact (H1 a).
intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4).
rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = None). simpl in |- *.
rewrite (Neqb_correct a). intro. discriminate H2.
exact (H1 a).
intros a0 y0 H H0 H1. cut (MapGet A (M1 A a y) a = MapGet A (M1 A a0 y0) a). simpl in |- *.
rewrite (Neqb_correct a). intro. elim (sumbool_of_bool (N.eqb a0 a)). intro H3.
rewrite H3 in H2. inversion H2. rewrite (Neqb_complete _ _ H3). reflexivity.
intro H3. rewrite H3 in H2. discriminate H2.
exact (H1 a).
intros. cut (2 <= MapCard A (M1 A a y)). intro. elim (le_Sn_O _ (le_S_n _ _ H4)).
rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2).
simple induction m'. intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4).
rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1).
intros a y H1 H2 H3. cut (2 <= MapCard A (M1 A a y)). intro.
elim (le_Sn_O _ (le_S_n _ _ H4)).
rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1).
intros. rewrite (H m2). rewrite (H0 m3). reflexivity.
exact (mapcanon_M2_2 _ _ H3).
exact (mapcanon_M2_2 _ _ H4).
exact (M2_eqmap_2 _ _ _ _ H5).
exact (mapcanon_M2_1 _ _ H3).
exact (mapcanon_M2_1 _ _ H4).
exact (M2_eqmap_1 _ _ _ _ H5).
Qed.

Lemma MapPut1_canon :
forall (p:positive) (a a':ad) (y y':A), mapcanon (MapPut1 A a y a' y' p).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapPut1_canon".
simple induction p. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon.
apply M1_canon.
apply le_n.
apply M2_canon. apply M1_canon.
apply M1_canon.
apply le_n.
simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M0_canon.
apply H.
simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
apply M2_canon. apply H.
apply M0_canon.
simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n.
simpl in |- *. simpl in |- *. intros. case (Nbit0 a). apply M2_canon. apply M1_canon.
apply M1_canon.
simpl in |- *. apply le_n.
apply M2_canon. apply M1_canon.
apply M1_canon.
simpl in |- *. apply le_n.
Qed.

Lemma MapPut_canon :
forall m:Map A,
mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut A m a y).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapPut_canon".
simple induction m. intros. simpl in |- *. apply M1_canon.
intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon.
intro. apply MapPut1_canon.
intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
exact (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
apply plus_le_compat. exact (MapCard_Put_lb A m0 N0 y).
apply le_n.
intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
apply H0. exact (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
exact (mapcanon_M2 m0 m1 H1).
apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (Npos p0) y).
intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
exact (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
exact (mapcanon_M2 m0 m1 H1).
apply plus_le_compat_r. exact (MapCard_Put_lb A m0 (Npos p0) y).
apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
apply H0. apply (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
exact (mapcanon_M2 m0 m1 H1).
apply plus_le_compat_l. exact (MapCard_Put_lb A m1 N0 y).
Qed.

Lemma MapPut_behind_canon :
forall m:Map A,
mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut_behind A m a y).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapPut_behind_canon".
simple induction m. intros. simpl in |- *. apply M1_canon.
intros a0 y0 H a y. simpl in |- *. case (Nxor a0 a). apply M1_canon.
intro. apply MapPut1_canon.
intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
exact (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1).
apply plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 N0 y).
apply le_n.
intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1).
apply H0. exact (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
exact (mapcanon_M2 m0 m1 H1).
apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (Npos p0) y).
intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
exact (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
exact (mapcanon_M2 m0 m1 H1).
apply plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (Npos p0) y).
apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1).
apply H0. apply (mapcanon_M2_2 m0 m1 H1).
simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1).
exact (mapcanon_M2 m0 m1 H1).
apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 N0 y).
Qed.

Lemma makeM2_canon :
forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (makeM2 A m m').
Proof. hammer_hook "Mapcanon" "Mapcanon.makeM2_canon".
intro. case m. intro. case m'. intros. exact M0_canon.
intros a y H H0. exact (M1_canon (Ndouble_plus_one a) y).
intros. simpl in |- *. apply M2_canon; try assumption. exact (mapcanon_M2 m0 m1 H0).
intros a y m'. case m'. intros. exact (M1_canon (N.double a) y).
intros a0 y0 H H0. simpl in |- *. apply M2_canon; try assumption. apply le_n.
intros. simpl in |- *. apply M2_canon; try assumption.
apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H0).
exact (le_plus_r (MapCard A (M1 A a y)) (MapCard A (M2 A m0 m1))).
simpl in |- *. intros. apply M2_canon; try assumption.
apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H).
exact (le_plus_l (MapCard A (M2 A m0 m1)) (MapCard A m')).
Qed.

Fixpoint MapCanonicalize (m:Map A) : Map A :=
match m with
| M2 m0 m1 => makeM2 A (MapCanonicalize m0) (MapCanonicalize m1)
| _ => m
end.

Lemma mapcanon_exists_1 : forall m:Map A, eqmap A m (MapCanonicalize m).
Proof. hammer_hook "Mapcanon" "Mapcanon.mapcanon_exists_1".
simple induction m. apply eqmap_refl.
intros. apply eqmap_refl.
intros. simpl in |- *. unfold eqmap, eqm in |- *. intro.
rewrite (makeM2_M2 A (MapCanonicalize m0) (MapCanonicalize m1) a).
rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if.
rewrite <- (H (N.div2 a)). rewrite <- (H0 (N.div2 a)). reflexivity.
Qed.

Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m).
Proof. hammer_hook "Mapcanon" "Mapcanon.mapcanon_exists_2".
simple induction m. apply M0_canon.
intros. simpl in |- *. apply M1_canon.
intros. simpl in |- *. apply makeM2_canon; assumption.
Qed.

Lemma mapcanon_exists :
forall m:Map A, {m' : Map A | eqmap A m m' /\ mapcanon m'}.
Proof. hammer_hook "Mapcanon" "Mapcanon.mapcanon_exists".
intro. split with (MapCanonicalize m). split. apply mapcanon_exists_1.
apply mapcanon_exists_2.
Qed.

Lemma MapRemove_canon :
forall m:Map A, mapcanon m -> forall a:ad, mapcanon (MapRemove A m a).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapRemove_canon".
simple induction m. intros. exact M0_canon.
intros a y H a0. simpl in |- *. case (N.eqb a a0). exact M0_canon.
assumption.
intros. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
apply H0. exact (mapcanon_M2_2 _ _ H1).
apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
exact (mapcanon_M2_2 _ _ H1).
Qed.

Lemma MapMerge_canon :
forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapMerge A m m').
Proof. hammer_hook "Mapcanon" "Mapcanon.MapMerge_canon".
simple induction m. intros. exact H0.
simpl in |- *. intros a y m' H H0. exact (MapPut_behind_canon m' H0 a y).
simple induction m'. intros. exact H1.
intros a y H1 H2. unfold MapMerge in |- *. exact (MapPut_canon _ H1 a y).
intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 _ _ H3).
exact (mapcanon_M2_1 _ _ H4).
apply H0. exact (mapcanon_M2_2 _ _ H3).
exact (mapcanon_M2_2 _ _ H4).
change (2 <= MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3))) in |- *.
apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H3).
exact (MapMerge_Card_lb_l A (M2 A m0 m1) (M2 A m2 m3)).
Qed.

Lemma MapDelta_canon :
forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapDelta A m m').
Proof. hammer_hook "Mapcanon" "Mapcanon.MapDelta_canon".
simple induction m. intros. exact H0.
simpl in |- *. intros a y m' H H0. case (MapGet A m' a).
intro. exact (MapRemove_canon m' H0 a).
exact (MapPut_canon m' H0 a y).
simple induction m'. intros. exact H1.
unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a).
intro. exact (MapRemove_canon _ H1 a).
exact (MapPut_canon _ H1 a y).
intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H3).
exact (mapcanon_M2_1 _ _ H4).
apply H0. exact (mapcanon_M2_2 _ _ H3).
exact (mapcanon_M2_2 _ _ H4).
Qed.

Variable B : Type.

Lemma MapDomRestrTo_canon :
forall m:Map A,
mapcanon m -> forall m':Map B, mapcanon (MapDomRestrTo A B m m').
Proof. hammer_hook "Mapcanon" "Mapcanon.MapDomRestrTo_canon".
simple induction m. intros. exact M0_canon.
simpl in |- *. intros a y H m'. case (MapGet B m' a).
intro. apply M1_canon.
exact M0_canon.
simple induction m'. exact M0_canon.
unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a).
intro. apply M1_canon.
exact M0_canon.
intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1).
apply H0. exact (mapcanon_M2_2 m0 m1 H1).
Qed.

Lemma MapDomRestrBy_canon :
forall m:Map A,
mapcanon m -> forall m':Map B, mapcanon (MapDomRestrBy A B m m').
Proof. hammer_hook "Mapcanon" "Mapcanon.MapDomRestrBy_canon".
simple induction m. intros. exact M0_canon.
simpl in |- *. intros a y H m'. case (MapGet B m' a); try assumption.
intro. exact M0_canon.
simple induction m'. exact H1.
intros a y. simpl in |- *. case (Nbit0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1).
apply MapRemove_canon. exact (mapcanon_M2_2 _ _ H1).
apply makeM2_canon. apply MapRemove_canon. exact (mapcanon_M2_1 _ _ H1).
exact (mapcanon_M2_2 _ _ H1).
intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1).
apply H0. exact (mapcanon_M2_2 _ _ H1).
Qed.

Lemma Map_of_alist_canon : forall l:alist A, mapcanon (Map_of_alist A l).
Proof. hammer_hook "Mapcanon" "Mapcanon.Map_of_alist_canon".
simple induction l. exact M0_canon.
intro r. elim r. intros a y l0 H. simpl in |- *. apply MapPut_canon. assumption.
Qed.

Lemma MapSubset_c_1 :
forall (m:Map A) (m':Map B),
mapcanon m -> MapSubset A B m m' -> MapDomRestrBy A B m m' = M0 A.
Proof. hammer_hook "Mapcanon" "Mapcanon.MapSubset_c_1".
intros. apply mapcanon_unique. apply MapDomRestrBy_canon. assumption.
apply M0_canon.
exact (MapSubset_imp_2 _ _ m m' H0).
Qed.

Lemma MapSubset_c_2 :
forall (m:Map A) (m':Map B),
MapDomRestrBy A B m m' = M0 A -> MapSubset A B m m'.
Proof. hammer_hook "Mapcanon" "Mapcanon.MapSubset_c_2".
intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *. rewrite H. apply eqmap_refl.
Qed.

End MapCanon.

Section FSetCanon.

Variable A : Type.

Lemma MapDom_canon :
forall m:Map A, mapcanon A m -> mapcanon unit (MapDom A m).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapDom_canon".
simple induction m. intro. exact (M0_canon unit).
intros a y H. exact (M1_canon unit a _).
intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 A _ _ H1).
apply H0. exact (mapcanon_M2_2 A _ _ H1).
change (2 <= MapCard unit (MapDom A (M2 A m0 m1))) in |- *. rewrite <- MapCard_Dom.
exact (mapcanon_M2 A _ _ H1).
Qed.

End FSetCanon.

Section MapFoldCanon.

Variables A B : Type.

Lemma MapFold_canon_1 :
forall m0:Map B,
mapcanon B m0 ->
forall op:Map B -> Map B -> Map B,
(forall m1:Map B,
mapcanon B m1 ->
forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
forall f:ad -> A -> Map B,
(forall (a:ad) (y:A), mapcanon B (f a y)) ->
forall (m:Map A) (pf:ad -> ad),
mapcanon B (MapFold1 A (Map B) m0 op f pf m).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapFold_canon_1".
simple induction m. intro. exact H.
intros a y pf. simpl in |- *. apply H1.
intros. simpl in |- *. apply H0. apply H2.
apply H3.
Qed.

Lemma MapFold_canon :
forall m0:Map B,
mapcanon B m0 ->
forall op:Map B -> Map B -> Map B,
(forall m1:Map B,
mapcanon B m1 ->
forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) ->
forall f:ad -> A -> Map B,
(forall (a:ad) (y:A), mapcanon B (f a y)) ->
forall m:Map A, mapcanon B (MapFold A (Map B) m0 op f m).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapFold_canon".
intros. exact (MapFold_canon_1 m0 H op H0 f H1 m (fun a:ad => a)).
Qed.

Lemma MapCollect_canon :
forall f:ad -> A -> Map B,
(forall (a:ad) (y:A), mapcanon B (f a y)) ->
forall m:Map A, mapcanon B (MapCollect A B f m).
Proof. hammer_hook "Mapcanon" "Mapcanon.MapCollect_canon".
intros. rewrite MapCollect_as_Fold. apply MapFold_canon. apply M0_canon.
intros. exact (MapMerge_canon B m1 m2 H0 H1).
assumption.
Qed.

End MapFoldCanon.


Require Export XR_R.
Require Export XR_R0.
Require Export XR_Rmult.
Require Export XR_Rmult_0_r.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 = R0 -> r1 * r2 = R0.
Proof.
  intros x y.
  intro heq.
  subst y.
  rewrite Rmult_0_r.
  reflexivity.
Qed.