(** * Classification of the [×] Type *)
(** In this file, we classify the basic structure of [×] types ([prod]
    in Coq).  In particular, we classify equalities of non-dependent
    pairs (inhabitants of [×] types), so that when we have an equality
    between two such pairs, or when we want such an equality, we have
    a systematic way of reducing such equalities to equalities at
    simpler types. *)
Require Import Crypto.Util.Equality.
Require Import Crypto.Util.GlobalSettings.

Local Arguments fst {_ _} _.
Local Arguments snd {_ _} _.
Local Arguments f_equal {_ _} _ {_ _} _.

Scheme Equality for prod.

(** ** Equality for [prod] *)
Section prod.
  (** *** Projecting an equality of a pair to equality of the first components *)
  Definition fst_path {A B} {u v : prod A B} (p : u = v)
  : fst u = fst v
    := f_equal fst p.

  (** *** Projecting an equality of a pair to equality of the second components *)
  Definition snd_path {A B} {u v : prod A B} (p : u = v)
  : snd u = snd v
    := f_equal snd p.

  (** *** Equality of [prod] is itself a [prod] *)
  Definition path_prod_uncurried {A B : Type} (u v : prod A B)
             (pq : prod (fst u = fst v) (snd u = snd v))
    : u = v.
  Proof.
    destruct u as [u1 u2], v as [v1 v2]; simpl in *.
    destruct pq as [p q].
    destruct p, q; simpl in *.
    reflexivity.
  Defined.

  (** *** Curried version of proving equality of sigma types *)
  Definition path_prod {A B : Type} (u v : prod A B)
             (p : fst u = fst v) (q : snd u = snd v)
    : u = v
    := path_prod_uncurried u v (pair p q).

  (** *** Equivalence of equality of [prod] with a [prod] of equality *)
  (** We could actually use [IsIso] here, but for simplicity, we
      don't.  If we wanted to deal with proofs of equality of × types
      in dependent positions, we'd need it. *)
  Definition path_prod_uncurried_iff {A B}
             (u v : @prod A B)
    : u = v <-> (prod (fst u = fst v) (snd u = snd v)).
  Proof.
    split; [ intro; subst; split; reflexivity | apply path_prod_uncurried ].
  Defined.

  (** *** Eta-expansion of [@eq (prod _ _)] *)
  Definition path_prod_eta {A B} {u v : @prod A B} (p : u = v)
    : p = path_prod_uncurried u v (fst_path p, snd_path p).
  Proof. destruct u, p; reflexivity. Defined.

  (** *** Induction principle for [@eq (prod _ _)] *)
  Definition path_prod_rect {A B} {u v : @prod A B} (P : u = v -> Type)
             (f : forall p q, P (path_prod_uncurried u v (p, q)))
    : forall p, P p.
  Proof. intro p; specialize (f (fst_path p) (snd_path p)); destruct u, p; exact f. Defined.
  Definition path_prod_rec {A B u v} (P : u = v :> @prod A B -> Set) := path_prod_rect P.
  Definition path_prod_ind {A B u v} (P : u = v :> @prod A B -> Prop) := path_prod_rec P.
End prod.

(** ** Useful Tactics *)
(** *** [inversion_prod] *)
Ltac simpl_proj_pair_in H :=
  repeat match type of H with
         | context G[fst (pair ?x ?p)]
           => let G' := context G[x] in change G' in H
         | context G[snd (pair ?x ?p)]
           => let G' := context G[p] in change G' in H
         end.
Ltac induction_path_prod H :=
  let H0 := fresh H in
  let H1 := fresh H in
  induction H as [H0 H1] using path_prod_rect;
  simpl_proj_pair_in H0;
  simpl_proj_pair_in H1.
Ltac inversion_prod_step :=
  match goal with
  | [ H : _ = pair _ _ |- _ ]
    => induction_path_prod H
  | [ H : pair _ _ = _ |- _ ]
    => induction_path_prod H
  end.
Ltac inversion_prod := repeat inversion_prod_step.

(** This turns a goal like [x = let v := p in let '(x, y) := f v in x
    + y)] into a goal like [x = fst (f p) + snd (f p)].  Note that it
    inlines [let ... in ...] as well as destructuring lets. *)
Ltac only_eta_expand_and_contract :=
  repeat match goal with
         | [ |- context[let '(x, y) := ?e in _] ]
           => rewrite (surjective_pairing e)
         | _ => rewrite <- !surjective_pairing
         end.
Ltac eta_expand :=
  repeat match goal with
         | _ => progress cbv beta iota zeta
         | [ |- context[let '(x, y) := ?e in _] ]
           => rewrite (surjective_pairing e)
         | _ => rewrite <- !surjective_pairing
         end.


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

Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax.

Open Scope Q_scope.

(** * QSig *)

(** Interface of a rich structure about rational numbers.
    Specifications are written via translation to Q.
*)

Module Type QType.

 Parameter t : Type.

 Parameter to_Q : t -> Q.
 Local Notation "[ x ]" := (to_Q x).

 Definition eq x y := [x] == [y].
 Definition lt x y := [x] < [y].
 Definition le x y := [x] <= [y].

 Parameter of_Q : Q -> t.
 Parameter spec_of_Q: forall x, to_Q (of_Q x) == x.

 Parameter red : t -> t.
 Parameter compare : t -> t -> comparison.
 Parameter eq_bool : t -> t -> bool.
 Parameter max : t -> t -> t.
 Parameter min : t -> t -> t.
 Parameter zero : t.
 Parameter one : t.
 Parameter minus_one : t.
 Parameter add : t -> t -> t.
 Parameter sub : t -> t -> t.
 Parameter opp : t -> t.
 Parameter mul : t -> t -> t.
 Parameter square : t -> t.
 Parameter inv : t -> t.
 Parameter div : t -> t -> t.
 Parameter power : t -> Z -> t.

 Parameter spec_red : forall x, [red x] == [x].
 Parameter strong_spec_red : forall x, [red x] = Qred [x].
 Parameter spec_compare : forall x y, compare x y = ([x] ?= [y]).
 Parameter spec_eq_bool : forall x y, eq_bool x y = Qeq_bool [x] [y].
 Parameter spec_max : forall x y, [max x y] == Qmax [x] [y].
 Parameter spec_min : forall x y, [min x y] == Qmin [x] [y].
 Parameter spec_0: [zero] == 0.
 Parameter spec_1: [one] == 1.
 Parameter spec_m1: [minus_one] == -(1).
 Parameter spec_add: forall x y, [add x y] == [x] + [y].
 Parameter spec_sub: forall x y, [sub x y] == [x] - [y].
 Parameter spec_opp: forall x, [opp x] == - [x].
 Parameter spec_mul: forall x y, [mul x y] == [x] * [y].
 Parameter spec_square: forall x, [square x] == [x] ^ 2.
 Parameter spec_inv : forall x, [inv x] == / [x].
 Parameter spec_div: forall x y, [div x y] == [x] / [y].
 Parameter spec_power: forall x z, [power x z] == [x] ^ z.

End QType.

(** NB: several of the above functions come with [..._norm] variants
     that expect reduced arguments and return reduced results. *)

(** TODO : also speak of specifications via Qcanon ... *)

Module Type QType_Notation (Import Q : QType).
 Notation "[ x ]" := (to_Q x).
 Infix "=="  := eq (at level 70).
 Notation "x != y" := (~x==y) (at level 70).
 Infix "<=" := le.
 Infix "<" := lt.
 Notation "0" := zero.
 Notation "1" := one.
 Infix "+" := add.
 Infix "-" := sub.
 Infix "*" := mul.
 Notation "- x" := (opp x).
 Infix "/" := div.
 Notation "/ x" := (inv x).
 Infix "^" := power.
End QType_Notation.

Module Type QType' := QType <+ QType_Notation.

Module QProperties (Import Q : QType').

(** Conversion to Q *)

#[global]
Hint Rewrite
 spec_red spec_compare spec_eq_bool spec_min spec_max
 spec_add spec_sub spec_opp spec_mul spec_square spec_inv spec_div
 spec_power : qsimpl.
Ltac qify := unfold eq, lt, le in *; autorewrite with qsimpl;
 try rewrite spec_0 in *; try rewrite spec_1 in *; try rewrite spec_m1 in *.

(** NB: do not add [spec_0] in the autorewrite database. Otherwise,
    after instantiation in BigQ, this lemma become convertible to 0=0,
    and autorewrite loops. Idem for [spec_1] and [spec_m1] *)

(** Morphisms *)

Ltac solve_wd1 := intros x x' Hx; qify; now rewrite Hx.
Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy.

Local Obligation Tactic := solve_wd2 || solve_wd1.

#[global]
Instance : Measure to_Q := {}.
#[global]
Instance eq_equiv : Equivalence eq.
Proof.
  change eq with (RelCompFun Qeq to_Q); apply _.
Defined.

#[global]
Program Instance lt_wd : Proper (eq==>eq==>iff) lt.
#[global]
Program Instance le_wd : Proper (eq==>eq==>iff) le.
#[global]
Program Instance red_wd : Proper (eq==>eq) red.
#[global]
Program Instance compare_wd : Proper (eq==>eq==>Logic.eq) compare.
#[global]
Program Instance eq_bool_wd : Proper (eq==>eq==>Logic.eq) eq_bool.
#[global]
Program Instance min_wd : Proper (eq==>eq==>eq) min.
#[global]
Program Instance max_wd : Proper (eq==>eq==>eq) max.
#[global]
Program Instance add_wd : Proper (eq==>eq==>eq) add.
#[global]
Program Instance sub_wd : Proper (eq==>eq==>eq) sub.
#[global]
Program Instance opp_wd : Proper (eq==>eq) opp.
#[global]
Program Instance mul_wd : Proper (eq==>eq==>eq) mul.
#[global]
Program Instance square_wd : Proper (eq==>eq) square.
#[global]
Program Instance inv_wd : Proper (eq==>eq) inv.
#[global]
Program Instance div_wd : Proper (eq==>eq==>eq) div.
#[global]
Program Instance power_wd : Proper (eq==>Logic.eq==>eq) power.

(** Let's implement [HasCompare] *)

Lemma compare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (compare x y).
Proof. intros. qify. destruct (Qcompare_spec [x] [y]); auto. Qed.

(** Let's implement [TotalOrder] *)

Definition lt_compat := lt_wd.
#[global]
Instance lt_strorder : StrictOrder lt.
Proof.
  change lt with (RelCompFun Qlt to_Q); apply _.
Qed.

Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y.
Proof. intros. qify. apply Qle_lteq. Qed.

Lemma lt_total : forall x y, x<y \/ x==y \/ y<x.
Proof. intros. destruct (compare_spec x y); auto. Qed.

(** Let's implement [HasEqBool] *)

Definition eqb := eq_bool.

Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y.
Proof. intros. qify. apply Qeq_bool_iff. Qed.

Lemma eqb_correct : forall x y, eq_bool x y = true -> x == y.
Proof. now apply eqb_eq. Qed.

Lemma eqb_complete : forall x y, x == y -> eq_bool x y = true.
Proof. now apply eqb_eq. Qed.

(** Let's implement [HasMinMax] *)

Lemma max_l : forall x y, y<=x -> max x y == x.
Proof. intros x y. qify. apply Qminmax.Q.max_l. Qed.

Lemma max_r : forall x y, x<=y -> max x y == y.
Proof. intros x y. qify. apply Qminmax.Q.max_r. Qed.

Lemma min_l : forall x y, x<=y -> min x y == x.
Proof. intros x y. qify. apply Qminmax.Q.min_l. Qed.

Lemma min_r : forall x y, y<=x -> min x y == y.
Proof. intros x y. qify. apply Qminmax.Q.min_r. Qed.

(** Q is a ring *)

Lemma add_0_l : forall x, 0+x == x.
Proof. intros. qify. apply Qplus_0_l. Qed.

Lemma add_comm : forall x y, x+y == y+x.
Proof. intros. qify. apply Qplus_comm. Qed.

Lemma add_assoc : forall x y z, x+(y+z) == x+y+z.
Proof. intros. qify. apply Qplus_assoc. Qed.

Lemma mul_1_l : forall x, 1*x == x.
Proof. intros. qify. apply Qmult_1_l. Qed.

Lemma mul_comm : forall x y, x*y == y*x.
Proof. intros. qify. apply Qmult_comm. Qed.

Lemma mul_assoc : forall x y z, x*(y*z) == x*y*z.
Proof. intros. qify. apply Qmult_assoc. Qed.

Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z.
Proof. intros. qify. apply Qmult_plus_distr_l. Qed.

Lemma sub_add_opp : forall x y, x-y == x+(-y).
Proof. intros. qify. now unfold Qminus. Qed.

Lemma add_opp_diag_r : forall x, x+(-x) == 0.
Proof. intros. qify. apply Qplus_opp_r. Qed.

(** Q is a field *)

Lemma neq_1_0 : 1!=0.
Proof. intros. qify. apply Q_apart_0_1. Qed.

Lemma div_mul_inv : forall x y, x/y == x*(/y).
Proof. intros. qify. now unfold Qdiv. Qed.

Lemma mul_inv_diag_l : forall x, x!=0 -> /x * x == 1.
Proof. intros x. qify. rewrite Qmult_comm. apply Qmult_inv_r. Qed.

End QProperties.

Module QTypeExt (Q : QType)
 <: QType <: TotalOrder <: HasCompare Q <: HasMinMax Q <: HasEqBool Q
 := Q <+ QProperties.


(*
    Authors: Thierry Coquand, Vincent Siles
*)
(* begin hide *)
Require Import Mergesort Permutation.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype path.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.
(* end hide *)

(** Definition of the eqType structure of the 3 states type _comparison_ *)
Lemma comparison_negK : forall s t, s = CompOpp t -> t = CompOpp s.
Proof.
by case => [] [] .
Qed.

Fixpoint eq_comparison (a b:comparison) : bool := match a,b with
 | Lt,Lt => true
 | Eq,Eq => true
 | Gt,Gt => true
 | _,_ => false
end.

Lemma eq_comparison_axiom : Equality.axiom eq_comparison.
Proof.
move => a b. apply: (iffP idP).
by case : a b => [] [].
by move => ->; case :b .
Qed.

Definition comparison_eq_mixin := EqMixin eq_comparison_axiom.
Canonical Structure comparison_eqType := EqType comparison
   comparison_eq_mixin.

(** Definition of a canonical structure of an eqType with a 3 states
    total comparison function *)
Record osym_module_mixin (symbol:eqType) : Type := OSymModuleMixin{
  cmp : symbol -> symbol -> comparison;
  cmp_refl : forall s, cmp s s = Eq;
  cmp_eq_axiom : forall s t, reflect (s = t) (cmp s t == Eq);
  cmp_trans : forall (s t u:symbol) (x:comparison),
    cmp s t = x -> cmp t u = x -> cmp s u = x;
  cmp_neg : forall (s t:symbol), cmp t s = CompOpp (cmp s t)
}.

Record osym_module : Type := OSymModule {
  carrier :> eqType;
  spec : osym_module_mixin carrier
}.

Definition cmpS (s:osym_module) := cmp (spec s).
Definition leS (S:osym_module) := fun (x y:S) => if cmpS x y is Gt then false else true.

Lemma cmpS_refl : forall (S:osym_module) (b:S), cmpS b b = Eq.
Proof.
move => S b.
by rewrite /cmpS cmp_refl.
Qed.

Lemma cmpS_eq_axiom : forall (S:osym_module) (a b:S), reflect (a = b) (cmpS a b == Eq).
Proof.
move => S a b. rewrite /cmpS. by apply: cmp_eq_axiom.
Qed.

Lemma cmpS_trans : forall (S:osym_module) (a b c:S) (x: comparison),
  cmpS a b = x -> cmpS b c = x -> cmpS a c = x.
Proof.
move => S a b c x.
rewrite /cmpS => h1 h2. by apply  (@cmp_trans _ _ a b c).
Qed.

Lemma cmpS_neg : forall (S:osym_module) (a b: S),
  cmpS a b = CompOpp (cmpS b a).
Proof.
move => S a b. by rewrite /cmpS cmp_neg.
Qed.

Lemma leS_refl : forall (S:osym_module), reflexive (@leS S).
Proof.
rewrite /leS => S a. by rewrite cmpS_refl.
Qed.

Lemma leS_trans : forall (S:osym_module), transitive (@leS S).
Proof.
rewrite /leS => S b a c. case_eq (cmpS a b) => // hc1 _.
- case_eq (cmpS b c) => // hc2 _. by rewrite (cmpS_trans hc1 hc2).
  move/eqP: hc1. move/cmpS_eq_axiom. move => ->. by rewrite hc2.
- case_eq (cmpS b c ) => // hc2 _. move/eqP: hc2. move/cmpS_eq_axiom.
  by move => <-; rewrite hc1.
by rewrite (cmpS_trans hc1 hc2).
Qed.

Lemma leS_antisym : forall (S: osym_module), antisymmetric (@leS S).
Proof.
rewrite /leS => S a b. rewrite cmpS_neg. case_eq (cmpS b a) => //=.
move/eqP. move/cmpS_eq_axiom. by move => <-.
Qed.

Lemma leS_total : forall (S:osym_module), total (@leS S).
Proof.
rewrite /leS => S a b. rewrite cmpS_neg. by case: (cmpS b a).
Qed.

(** Some very general definitions and missing
    properties in ssreflect stdlib *)
Section Glue.
Variable A B: Type.

Fixpoint seq_to_list (s:seq A) : list A := match s with
 | nil => List.nil
 | hd:: tl => (hd::(seq_to_list tl))%list
end.

Lemma flatten_cat: forall (l l':seq (seq A)) ,
  flatten (l++l') = flatten l ++ flatten l'.
Proof.
elim => [ | hd tl Ih] l' //=.
by rewrite -catA Ih.
Qed.

Lemma flatten_map_cons : forall (l:seq A),
  flatten (map (fun xx => [::xx]) l) = l.
Proof.
elim => [ | hd tl ih] //=. by rewrite {1}ih.
Qed.

Definition dupl (X: seq (A*B)) : seq (A*A*B) :=
  map (fun (ab:A*B) => let (a,b) := ab in (a,a,b)) X.

Definition strip (X: seq (A*A*B)) : seq (A*B) :=
  map (fun ab:A*A*B => let (aa,b) := ab in let (a,_) := aa in (a,b)) X.

Lemma dupl_strip : forall (X:seq (A*B)), strip (dupl X) = X.
Proof.
elim => [ | [hda hdb] tl hi ] //=. by rewrite hi.
Qed.
End Glue.

Section Glue2.

Variable T T':eqType.
Variable R: rel T.

(** some usefull lemmas to deal with sorted + undup sequences *)
Lemma path_undup : forall (hR : transitive R) l (x:T), path R x l -> path R x (undup l).
Proof.
move => hR. elim => [ | hd tl hi] x //=.
case/andP => hhd htl. case: (hd \in tl) => //=.
- apply:hi. elim: tl htl => [ | a b hi] //=.
  case/andP => hd2 h. apply/andP ; split => //. by apply (hR hd).
- apply/andP; split => //. by apply: hi.
Qed.

Lemma sorted_undup : forall (hR: transitive R) (l:seq T), sorted R l -> sorted R (undup l).
Proof.
move => hR. elim => [ | hd tl hi] //=.
case: (hd \in tl) => hp /=.
- apply: hi. by apply: (@path_sorted _ _ hd).
- by apply: path_undup.
Qed.

Lemma tool_undup_size : forall (l l': seq T), size (undup l') <= size (undup (l++l')).
Proof.
elim => [ | hd tl hi] l' //=. case: (hd \in tl ++ l') => //=.
by apply (@leq_trans (size (undup (tl++l')))).
Qed.

Lemma tool_undup_size2 : forall (l l': seq T), size (undup l) <= size (undup (l++l')).
Proof.
move => l l'. rewrite (@perm_eq_size _ (undup (l ++ l')) (undup (l'++l))).
by apply tool_undup_size. apply uniq_perm_eq. by apply undup_uniq. by apply undup_uniq.
move => u. rewrite !mem_undup !mem_cat. by apply orbC.
Qed.

Lemma merge_sort_sym : forall (hR1:transitive R) (hR2: antisymmetric R) (hR3: total R)
 (l1 l2:seq T), sorted R l1 -> sorted R l2 -> merge R l1 l2 = merge R l2 l1.
Proof.
move => hR1 hR2 hR3 l1 l2 h1 h2. apply (eq_sorted hR1 hR2).
by apply merge_sorted.
by apply merge_sorted.
by rewrite perm_merge perm_eq_sym perm_merge perm_catC.
Qed.

Lemma tool_normP_in : forall (hd:T) tl l, perm_eq (hd::tl) l ->
 exists l1, exists l2, l = l1 ++ hd :: l2 /\ tl =i l1 ++ l2.
Proof.
move => hd tl l hp.
have hs: (splitr hd l).
- apply: splitPr. rewrite -(perm_eq_mem hp). by rewrite in_cons eq_refl.
case: hs hp => l1 l2 hp.  exists l1; exists l2;  split => //.
apply: perm_eq_mem. move: hp.
by rewrite -[hd :: l2]cat1s perm_eq_sym perm_catCA /= perm_cons perm_eq_sym.
Qed.

(** boolean operator to check inclusion of lists:
    lincl l l' means that forall x in l, x is in l'
*)
Fixpoint lincl (l l':seq T) : bool :=
match l with
 | [::] => true
 | hd :: tl => (hd \in l') && (lincl tl l')
end.

Lemma lincl_cons : forall (l l1:seq T) a, lincl l l1 -> lincl l (a::l1).
Proof.
elim => [ | hd tl hi] l1 a //=.
case/andP => hhd hdtl. apply/andP; split.
by rewrite in_cons hhd orbT. by apply: hi.
Qed.

Lemma lincl_catr : forall (l l1 l2: seq T), lincl l l1 -> lincl l (l1 ++ l2).
Proof.
elim => [ | hd tl hi] l1 l2 //=.
case/andP => hhd htl. by rewrite mem_cat hhd; apply : hi.
Qed.

Lemma lincl_refl : forall (l:seq T), lincl l l.
Proof.
elim => [ | hd tl hi] //=. apply/andP; split.
- by rewrite in_cons eq_refl.
- by apply: lincl_cons.
Qed.

Lemma lincl_nil : forall (l:seq T), lincl l [::] -> l = [::].
Proof.
by case.
Qed.

Lemma linclP : forall (l l':seq T),
  reflect (forall a, (a \in l) -> (a \in l')) (lincl l l').
Proof.
move => l l'; apply : (iffP idP).
- elim : l => [ | hd tl hi] //=.
  case/andP => hhd htl a. rewrite in_cons; case/orP => hu.
  by rewrite (eqP hu).
  by apply: hi.
- elim : l => [ | hd tl hi] //=.
  move => h. apply/andP; split.
  by apply: h; rewrite in_cons eq_refl.
  apply: hi => a h'.
  apply: h.
  by rewrite in_cons h' orbT.
Qed.

Lemma lincl_mem: forall (l l': seq T), lincl l l' ->
 forall a, (a\in l) -> (a \in l').
Proof.
move => l l' h. by apply/linclP.
Qed.

Lemma lincl_trans : transitive lincl.
Proof.
rewrite /transitive => y.
elim => [ | hd tl hi] z //=.
case/andP => hhd htl hincl.
rewrite (hi z htl hincl) andbT /=.
move/linclP : hincl.  by apply.
Qed.

Lemma strip_in : forall (X: seq (T*T*T')) (a a':T) (b:T'),
  (a,a',b) \in X -> (a,b) \in (strip X).
Proof.
elim => [ | [[hd1 hd2] hdb] tl hi] //= a a' b.
rewrite !in_cons. case/orP.
- rewrite eqE /=. case/andP. case/andP => /= heq _ heq2.
  by rewrite (eqP heq) (eqP heq2) eq_refl .
- move => h. by rewrite (hi a a' b h) orbT.
Qed.

End Glue2.


Inductive iex {A: Type} (P: A -> Prop): SProp := iex_intro: forall x, P x -> iex P.
Inductive isig {A: Type} (P: A -> SProp): Type := isig_intro: forall x, P x ->  isig P.

(* We replace usual notations: *)
Notation "'iexists' x .. y , p" := (iex (fun x => .. (iex (fun y => p)) ..)) (at level 100, x binder, y binder, right associativity,
   format "'[' 'iexists'  '/  ' x  ..  y ,  '/  ' p ']'") : type_scope.
Notation "{ x | 'irr' P }" := (isig (fun x => P)) (at level 0, x at level 99, P at level 100) : type_scope .


Require Export XR_Rle.
Require Export XR_Rplus_lt_0_compat.

Local Open Scope R_scope.

Lemma Rplus_le_lt_0_compat : forall r1 r2, R0 <= r1 -> R0 < r2 -> R0 < r1 + r2.
Proof.
  intros x y.
  intros hx hy.
  unfold "<=" in hx.
  destruct hx as [ hx | heq ].
  {
    apply Rplus_lt_0_compat.
    { exact hx. }
    { exact hy. }
    }
  {
    subst x.
    rewrite Rplus_0_l.
    exact hy.
  }
Qed.


Require Import Coq.omega.Omega.
Require Import Platform.AutoSep Platform.Util.
Require Import Coq.Arith.Arith Coq.Lists.List.

Set Implicit Arguments.

Local Hint Extern 1 (himp _ (allocated _ _ _) (allocated _ _ _)) => apply allocated_shift_base.

(** * A free-list heap managed by the malloc library *)

Definition noWrapAround (p : W) (sz : nat) :=
  forall n, (n < 4 * sz)%nat -> p ^+ $ (n) <> $0.

Definition freeable (p : W) (sz : nat) := (sz >= 2)%nat
  /\ noWrapAround p sz.

Lemma BigEnough : forall p sz, freeable p sz -> (sz >= 2)%nat.
  unfold freeable; tauto.
Qed.

Lemma SmallEnough : forall p sz, freeable p sz -> noWrapAround p sz.
  unfold freeable; tauto.
Qed.

Local Hint Immediate BigEnough SmallEnough.
Local Hint Unfold freeable.

Module Type FREE_LIST.
  Parameter freeList : nat (* number of elements in list *) -> W -> HProp.
  Parameter mallocHeap : W -> HProp.

  Axiom freeList_extensional : forall n p, HProp_extensional (freeList n p).
  Axiom mallocHeap_extensional : forall p, HProp_extensional (mallocHeap p).

  Axiom mallocHeap_fwd : forall p, mallocHeap p ===> Ex n, Ex p', p =*> p' * freeList n p'.
  Axiom mallocHeap_bwd : forall p, (Ex n, Ex p', p =*> p' * freeList n p') ===> mallocHeap p.

  Axiom nil_bwd : forall n p, p = 0 -> [| n = 0 |] ===> freeList n p.
  Axiom cons_bwd : forall n (p : W), p <> 0
    -> (Ex n', Ex sz, Ex p', [| n = S n' |]
      * [| noWrapAround p (2 + wordToNat sz) |]
      * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p')
    ===> freeList n p.

  Axiom cons_fwd : forall n (p : W), p <> 0
    -> freeList n p
    ===> Ex n', Ex sz, Ex p', [| n = S n' |]
    * [| noWrapAround p (2 + wordToNat sz) |]
    * (p ==*> sz, p')  * (p ^+ $8) =?> wordToNat sz * freeList n' p'.
End FREE_LIST.

Module FreeList : FREE_LIST.
  Open Scope Sep_scope.

  Fixpoint freeList (n : nat) (p : W) : HProp :=
    match n with
      | O => [| p = 0 |]
      | S n' => [| p <> 0 |] * Ex sz, Ex p',
        [| noWrapAround p (2 + wordToNat sz) |]
        * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p'
    end.

  Definition mallocHeap (p : W) := Ex n, Ex p', p =*> p' * freeList n p'.

  Theorem freeList_extensional : forall n p, HProp_extensional (freeList n p).
    destruct n; reflexivity.
  Qed.

  Theorem mallocHeap_extensional : forall p, HProp_extensional (mallocHeap p).
    reflexivity.
  Qed.

  Theorem mallocHeap_fwd : forall p, mallocHeap p ===> Ex n, Ex p', p =*> p' * freeList n p'.
    unfold mallocHeap; sepLemma.
  Qed.

  Theorem mallocHeap_bwd : forall p, (Ex n, Ex p', p =*> p' * freeList n p') ===> mallocHeap p.
    unfold mallocHeap; sepLemma.
  Qed.

  Theorem nil_bwd : forall n p, p = 0 -> [| n = 0 |] ===> freeList n p.
    destruct n; sepLemma.
  Qed.

  Theorem cons_bwd : forall n (p : W), p <> 0
    -> (Ex n', Ex sz, Ex p', [| n = S n' |]
      * [| noWrapAround p (2 + wordToNat sz) |]
      * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p')
    ===> freeList n p.
    destruct n; sepLemma; match goal with
                            | [ H : S _ = S _ |- _ ] => injection H
                          end; sepLemma.
  Qed.

  Theorem cons_fwd : forall n (p : W), p <> 0
    -> freeList n p
    ===> Ex n', Ex sz, Ex p', [| n = S n' |]
    * [| noWrapAround p (2 + wordToNat sz) |]
    * (p ==*> sz, p') * (p ^+ $8) =?> wordToNat sz * freeList n' p'.
    destruct n; sepLemma.
  Qed.
End FreeList.

Import FreeList.
Export FreeList.
Hint Immediate freeList_extensional mallocHeap_extensional.

Ltac expose := intros w ?; case_eq (wordToNat w); [ intro Heq;
  apply (f_equal (natToWord 32)) in Heq; rewrite natToWord_wordToNat in Heq;
    subst; elimtype False; auto
  | intros n Heq; repeat (destruct n; [
    apply (f_equal (natToWord 32)) in Heq; rewrite natToWord_wordToNat in Heq;
      subst; elimtype False; auto
    | eauto ]) ].

Lemma expose2N : forall n,
  (n >= 2)%nat
  -> exists n', n = S (S n').
  destruct n as [ | [ | ] ]; eauto; intros; omega.
Qed.

Lemma expose2' : forall w : W,
  $2 <= w
  -> exists n', wordToNat w = S (S n').
  expose.
Qed.

Lemma expose3' : forall (w : W),
  w >= $3
  -> exists n, wordToNat w = S (S (S n)).
  expose.
Qed.

Inductive fwd : Prop := Fwd.
Inductive bwd : Prop := Bwd.
Hint Constructors fwd bwd.

Lemma freeable_fwd : forall p sz,
  freeable p sz
  -> fwd
  -> p =?> sz ===> Ex u, Ex v, p =*> u * (p ^+ $4) =*> v * (p ^+ $8) =?> (sz-2).
  intuition idtac; destruct (expose2N (BigEnough H)) as [? Heq];
    rewrite Heq; sepLemma; apply allocated_shift_base; omega || words.
Qed.

Lemma expose2_bwd : forall p (sz : W),
  $2 <= sz
  -> bwd
  -> (Ex u, Ex v, p =*> u * (p ^+ $4) =*> v * (p ^+ $8) =?> (wordToNat sz-2)) ===> p =?> wordToNat sz.
  intros; destruct (expose2' H) as [? Heq];
    rewrite Heq; sepLemma; apply allocated_shift_base; omega || words.
Qed.

Lemma expose3_fwd : forall p (sz : W),
  sz >= $3
  -> p =?> wordToNat sz ===> Ex u, Ex v, Ex w, p =*> u * (p ^+ $4) =*> v * (p ^+ $8) =*> w * (p ^+ $12) =?> (wordToNat sz-3).
  intros; destruct (expose3' H) as [? Heq]; rewrite Heq; sepLemma;
    apply allocated_shift_base; omega || words.
Qed.

Definition hints : TacPackage.
  prepare (mallocHeap_fwd, cons_fwd, freeable_fwd, expose3_fwd)
  (mallocHeap_bwd, nil_bwd, cons_bwd, expose2_bwd).
Defined.

Definition initS : spec := SPEC("base", "size") reserving 0
  PRE[V] [| $3 <= V "size" |]
    * [| noWrapAround (V "base" ^+ $4) (wordToNat (V "size") - 1) |]
    * V "base" =?> wordToNat (V "size")
  POST[_] mallocHeap (V "base").

Definition freeS : spec := SPEC("base", "p", "n") reserving 2
  PRE[V] [| V "p" <> 0 |] * [| freeable (V "p") (wordToNat (V "n")) |]
    * V "p" =?> wordToNat (V "n") * mallocHeap (V "base")
  POST[_] mallocHeap (V "base").

Definition mallocS : spec := SPEC("base", "n") reserving 4
  PRE[V] [| V "n" >= $2 |] * mallocHeap (V "base")
  POST[R] [| R <> 0 |] * [| freeable R (wordToNat (V "n")) |]
    * R =?> wordToNat (V "n") * mallocHeap (V "base").

Definition m := bmodule "malloc" {{
  bfunction "init"("base", "size") [initS]
    "base" *<- "base" + 4;;
    "base" + 4 *<- "size" - 3;;
    "base" + 8 *<- 0;;
    Return 0
  end with bfunction "free"("base", "p", "n", "cur", "tmp") [freeS]
    "cur" <-* "base";;

    [Al len,
      PRE[V] [| V "p" <> 0 |] * [| freeable (V "p") (wordToNat (V "n")) |] * V "p" =?> wordToNat (V "n")
        * V "base" =*> V "cur" * freeList len (V "cur")
      POST[R] Ex p, Ex len', V "base" =*> p * freeList len' p]
    While ("cur" <> 0) {
      "tmp" <- 4 * "n";;
      "tmp" <- "p" + "tmp";;

      If ("tmp" = "cur") {
        (* The block we are freeing appears immediately before this free block.  Let's merge. *)

        Note [fwd];;

        (* Update size. *)
        "tmp" <-* "cur";;
        "tmp" <- "tmp" + "n";;
        "p" *<- "tmp";;

        (* Update next pointer. *)
        "tmp" <-* "cur"+4;;
        "p"+4 *<- "tmp";;

        "base" *<- "p";;

        Return 0
      } else {
        "tmp" <-* "cur";;
        "tmp" <- 4 * "tmp";;
        "tmp" <- "cur" + "tmp";;
        "tmp" <- "tmp" + 8;;

        If ("tmp" = "p") {
          (* The block we are freeing appears immediately after this free block.  Let's merge. *)

          "tmp" <-* "cur"+4;;

          If ("tmp" = 0) {
            (* Simple merge-after case *)

            (* Update size field. *)
            "base" <-* "cur";;
            "base" <- "base" + "n";;
            "cur" *<- "base";;

            Return 0
          } else {
            "base" <- 4 * "n";;
            "base" <- "p" + "base";;

            If ("tmp" = "base") {
              (* The block we are freeing appears sandwiched between the next two free blocks.  Mega-merge! *)

              (* Update size field. *)
              "base" <-* "base";;
              "base" <- "base" + "n";;
              "base" <- "base" + 2;;
              "n" <-* "cur";;
              "base" <- "base" + "n";;
              "cur" *<- "base";;

              (* Update next pointer. *)
              "tmp" <-* "tmp"+4;;
              "cur"+4 *<- "tmp";;

              Return 0
            } else {
              (* Simpler merge-after case *)

              (* Update size field. *)
              "base" <-* "cur";;
              "base" <- "base" + "n";;
              "cur" *<- "base";;

              Return 0
            }
          }
        } else {
          If ("p" < "cur") {
            (* We keep the free list sorted, so this is the appropriate point to insert the current block. *)

            Note [fwd];;
            "p" *<- "n" - 2;;
            "tmp" <-* "base";;
            "base" *<- "p";;
            "p" + 4 *<- "tmp";;

            Return 0
          } else {
            (* We haven't yet reached the right place in the free list.  Keep looping. *)

            "base" <- "cur"+4;;
            "cur" <-* "base"
          }
        }
      }
    };;

    (* We reached the end of the free list without finding a block with a higher address.  Insert here. *)

    Note [fwd];;
    "p" *<- "n" - 2;;
    "tmp" <-* "base";;
    "base" *<- "p";;
    "p" + 4 *<- "tmp";;

    Return 0
  end with bfunction "malloc"("base", "n", "cur", "prev", "tmp", "tmp2") [mallocS]
    "cur" <-* "base";;
    "prev" <- "base";;

    [Al len,
      PRE[V] [| (V "n" >= $2)%word |] * V "prev" =*> V "cur" * freeList len (V "cur")
      POST[R] Ex p, Ex len', [| R <> 0 |] * [| freeable R (wordToNat (V "n")) |] * R =?> wordToNat (V "n")
        * V "prev" =*> p * freeList len' p]
    While ("cur" <> 0) {
      "tmp" <-* "cur";;
      "tmp" <- "tmp" + 2;;
      If ("tmp" = "n") {
        (* Exact size match on the current free list block *)
        Note [bwd];;

        "tmp" <-* "cur" + 4;;
        "prev" *<- "tmp";;
        Return "cur"
      } else {
        "tmp2" <-* "cur";;
        If ("n" < "tmp2") {
          (* This free list block is large enough to split in two. *)

          (* Calculate starting address of a suffix of this free block to return to caller. *)
          "tmp" <- "tmp2" - "n";;
          "tmp" <- "tmp" + 2;;
          "tmp" <- 4 * "tmp";;
          "tmp" <- "cur" + "tmp";;

          (* Decrement size of free list block to reflect deleted suffix. *)
          "tmp2" <- "tmp2" - "n";;
          "cur" *<- "tmp2";;

          (* Return suffix starting address. *)
          Return "tmp"
        } else {
          (* Current block too small; continue to next. *)
          "prev" <- "cur" + 4;;
          "cur" <-* "prev"
        }
      }
    };;

    Diverge (* out of memory! *)
  end
}}.

Local Hint Extern 1 (@eq (word _) _ _) => words.
Local Hint Extern 5 (@eq nat _ _) => omega.
Local Hint Extern 5 (_ <= _)%nat => omega.

Lemma three_le : forall w : W,
  $3 <= w
  -> (wordToNat w >= 3)%nat.
  intros; destruct (le_lt_dec (wordToNat w) 3); auto.
  pre_nomega.
  change (wordToNat (natToWord _ 3)) with 3 in H.
  omega.
Qed.

Lemma noWrapAround_plus4 : forall p (sz : W),
  noWrapAround p (wordToNat sz - 1)
  -> $3 <= sz
  -> p <> $0.
  intros.
  intro.
  eapply H.
  2: instantiate (1 := 0); words.
  apply three_le in H0.
  omega.
Qed.

Lemma noWrapAround_weaken : forall p sz p' sz',
  noWrapAround p sz
  -> (sz' <= sz)%nat
  -> p' = p ^+ $ (4 * (sz - sz'))
  -> noWrapAround p' sz'.
  unfold noWrapAround; intros; subst.
  intro.
  rewrite <- wplus_assoc in H1.
  rewrite <- natToW_plus in H1.
  eapply H; [ | eassumption ].
  omega.
Qed.

Local Hint Extern 1 (noWrapAround _ _) =>
  eapply noWrapAround_weaken; [ eassumption | | ].

Lemma weq_cong : forall (w : W) n m,
  n = m
  -> w ^+ $ (n) = w ^+ $ (m).
  intros; subst; W_eq.
Qed.

Lemma weq_0 : forall (w w' : W) n,
  w = w'
  -> n = 0
  -> w = w' ^+ $ (n).
  intros; subst; W_eq.
Qed.

Local Hint Resolve weq_0 weq_cong.

Lemma two_ge : forall w : W,
  (wordToNat w >= 2)%nat
  -> w >= $2.
  intros.
  intro.
  red in H0.
  pre_nomega.
  change (wordToNat (natToWord _ 2)) with 2 in *.
  omega.
Qed.

Lemma wminus0 : forall (w : W),
  (wordToNat w >= 2)%nat
  -> wordToNat (w ^- $2) = wordToNat w - 2.
  intros; rewrite wordToNat_wminus; auto.
  apply two_ge; auto.
Qed.

Hint Rewrite wminus0 using assumption : sepFormula.

Lemma sub2 : forall w w' : W,
  w' ^+ $2 = w
  -> $2 <= w
  -> wordToNat w - 2 = wordToNat w'.
  intros; apply (f_equal (fun x => x ^- $2)) in H.
  replace (w' ^+ $2 ^- $2) with w' in H by W_eq.
  subst.
  symmetry; apply wordToNat_wminus; auto.
Qed.

Lemma two_le : forall w : W,
  $2 <= w
  -> (2 <= wordToNat w)%nat.
  intros.
  destruct (le_lt_dec 2 (wordToNat w)); auto.
  elimtype False; apply H.
  pre_nomega.
  change (wordToNat (natToWord _ 2)) with 2 in *.
  omega.
Qed.

Lemma four_times_wordToNat : forall w : W,
  $ (4 * wordToNat w) = $4 ^* w.
  intros; rewrite wmult_alt; auto.
Qed.

Lemma noWrapAround_weaken' : forall p sz sz',
  noWrapAround p sz
  -> (sz' <= sz)%nat
  -> noWrapAround p sz'.
  unfold noWrapAround; auto.
Qed.

Lemma the_ole_switcheroo : forall a b : W,
  a ^+ natToW 8 ^+ $ (4 * wordToNat b) = a ^+ natToW 4 ^* (b ^+ natToW 2) ^+ $0.
  intros; replace (natToW 4 ^* (b ^+ natToW 2)) with ($4 ^* b ^+ $8) by words;
    rewrite four_times_wordToNat; words.
Qed.

Lemma noWrapAround_merge_before : forall p n cur (sz : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> p ^+ natToW 4 ^* n = cur
  -> noWrapAround p (S (S (wordToNat sz + wordToNat n))).
  unfold noWrapAround in *; intros; subst.

  destruct (le_lt_dec (4 * wordToNat n) n0); auto.
  replace n0 with (4 * wordToNat n + (n0 - 4 * wordToNat n)) by auto.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite mult_comm.
  rewrite natToW_times4.
  rewrite wmult_comm.
  unfold natToW at 2.
  rewrite natToWord_wordToNat.
  auto.
Qed.

Local Hint Immediate noWrapAround_merge_before.

Ltac isConst n :=
  match n with
    | O => idtac
    | S ?n' => isConst n'
  end.

Ltac deS1 := match goal with
               | [ |- context[S ?N] ] =>
                 let rec count N k :=
                   match N with
                     | S ?N' => count N' ltac:(fun n e => k (S n) e)
                     | _ => k O N
                   end in
                   (isConst N; fail 1)
                   || count (S N) ltac:(fun n e => change (S N) with (n + e)%nat)
             end; repeat rewrite natToW_plus.
Ltac deS := repeat deS1.

Lemma allocatedSS : forall base offset len,
  (Ex v1, Ex v2, (base ^+ natToW offset) =*> v1 * (base ^+ natToW offset ^+ $4) =*> v2 * allocated base (8 + offset) len)
  ===> allocated base offset (S (S len)).
  sepLemma; destruct offset; sepLemma.

  match goal with
    | [ |- himp _ (?N =*> _)%Sep (?M =*> _)%Sep ] => replace M with N; [ reflexivity | ]
  end.

  deS; words.
Qed.

Lemma goodSize_dec : forall n, {goodSize n} + {~goodSize n}.
  Transparent goodSize.
  unfold goodSize, Nlt; intros.
  destruct (N.of_nat n ?= Npow2 32)%N; auto; right; discriminate.
  Opaque goodSize.
Qed.

Lemma not_goodSize : forall n, ~goodSize n -> (n >= pow2 32)%nat.
  Transparent goodSize.
  unfold goodSize; intros.
  generalize dependent 32; intro sz; intros.
  assert (N.of_nat n >= Npow2 sz)%N.
  nomega.
  apply Nge_out in H0.
  rewrite Npow2_nat in *.
  rewrite Nat2N.id in *; auto.
  Opaque goodSize.
Qed.

Lemma noWrapAround_goodSize' : forall p (n : W) cur (sz : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> p ^+ natToW 4 ^* n = cur
  -> goodSize (4 * (wordToNat sz + wordToNat n)).
  intros; assert (noWrapAround p (S (S (wordToNat sz + wordToNat n)))) by eauto.
  destruct (goodSize_dec (4 * (wordToNat sz + wordToNat n))); auto.
  clear H H0.
  elimtype False; apply H2 with (pow2 32 - wordToNat p).

  Focus 2.
  rewrite natToW_minus.
  unfold natToW; rewrite natToWord_wordToNat.
  rewrite natToWord_pow2; words.
  specialize (wordToNat_bound p); omega.

  apply not_goodSize in n0.
  omega.
Qed.

Lemma noWrapAround_goodSize : forall p (n : W) cur (sz : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> p ^+ natToW 4 ^* n = cur
  -> goodSize (wordToNat sz + wordToNat n).
  intros; eapply goodSize_weaken; [ eapply noWrapAround_goodSize'; eauto | omega ].
Qed.

Local Hint Immediate noWrapAround_goodSize.

Lemma noWrapAround_merge_after : forall p (n : W) cur (sz : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> cur ^+ natToW 4 ^* sz ^+ natToW 8 = p
  -> noWrapAround cur (S (S (wordToNat sz + wordToNat n))).
  unfold noWrapAround in *; intros; subst.

  destruct (le_lt_dec (4 * S (S (wordToNat sz))) n0); auto.
  replace n0 with (4 * wordToNat sz + 8 + (n0 - 4 * S (S (wordToNat sz)))) by auto.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite mult_comm.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite natToW_times4.
  rewrite wmult_comm.
  unfold natToW at 2.
  rewrite natToWord_wordToNat.
  auto.
Qed.

Local Hint Immediate noWrapAround_merge_after.

Lemma noWrapAround_after_goodSize' : forall p (n : W) cur (sz : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> cur ^+ natToW 4 ^* sz ^+ natToW 8 = p
  -> goodSize (4 * (wordToNat sz + wordToNat n)).
  intros; assert (noWrapAround cur (S (S (wordToNat sz + wordToNat n)))) by eauto.
  destruct (goodSize_dec (4 * (wordToNat sz + wordToNat n))); auto.
  clear H H0.
  elimtype False; apply H2 with (pow2 32 - wordToNat cur).

  apply not_goodSize in n0.
  omega.

  rewrite natToW_minus.
  unfold natToW; rewrite natToWord_wordToNat.
  rewrite natToWord_pow2; words.
  specialize (wordToNat_bound cur); omega.
Qed.

Lemma noWrapAround_after_goodSize : forall p (n : W) cur (sz : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> cur ^+ natToW 4 ^* sz ^+ natToW 8 = p
  -> goodSize (wordToNat sz + wordToNat n).
  intros; eapply goodSize_weaken; [ eapply noWrapAround_after_goodSize'; eauto | omega ].
Qed.

Local Hint Immediate noWrapAround_after_goodSize.

Lemma noWrapAround_merge_middle : forall p (n : W) cur (sz sz' : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> noWrapAround (p ^+ natToW 4 ^* n) (S (S (wordToNat sz')))
  -> cur ^+ natToW 4 ^* sz ^+ natToW 8 = p
  -> noWrapAround cur (S (S (wordToNat sz' + wordToNat n + 2 + wordToNat sz))).
  unfold noWrapAround in *; intros; subst.

  destruct (le_lt_dec (4 * S (S (wordToNat sz))) n0); auto.
  destruct (le_lt_dec (4 * S (S (wordToNat sz)) + 4 * wordToNat n) n0); auto.

  replace n0 with (4 * wordToNat sz + 8 + 4 * wordToNat n + (n0 - 4 * wordToNat sz - 8 - 4 * wordToNat n))
    by auto.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite mult_comm.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite natToW_times4.
  rewrite wmult_comm.
  unfold natToW at 2.
  rewrite natToWord_wordToNat.
  rewrite mult_comm.
  rewrite natToW_times4.
  rewrite (wmult_comm _ (natToW 4)).
  unfold natToW at 4.
  rewrite natToWord_wordToNat.
  auto.

  replace n0 with (4 * wordToNat sz + 8 + (n0 - 4 * S (S (wordToNat sz)))) by auto.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite mult_comm.
  rewrite natToW_plus.
  rewrite wplus_assoc.
  rewrite natToW_times4.
  rewrite wmult_comm.
  unfold natToW at 2.
  rewrite natToWord_wordToNat.
  auto.
Qed.

Local Hint Immediate noWrapAround_merge_middle.

Lemma noWrapAround_middle_goodSize' : forall p (n : W) cur (sz sz' : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> noWrapAround (p ^+ natToW 4 ^* n) (S (S (wordToNat sz')))
  -> cur ^+ natToW 4 ^* sz ^+ natToW 8 = p
  -> goodSize (4 * (wordToNat sz + wordToNat n + wordToNat (natToW 2) + wordToNat sz')).
  change (wordToNat (natToW 2)) with 2.
  intros; assert (noWrapAround cur (S (S (wordToNat sz' + wordToNat n + 2 + wordToNat sz)))) by eauto.
  destruct (goodSize_dec (4 * (wordToNat sz + wordToNat n + 2 + wordToNat sz'))); auto.
  clear H H0 H1.
  elimtype False; apply H3 with (pow2 32 - wordToNat cur).

  apply not_goodSize in n0.
  omega.

  rewrite natToW_minus.
  unfold natToW; rewrite natToWord_wordToNat.
  rewrite natToWord_pow2; words.
  specialize (wordToNat_bound cur); omega.
Qed.

Lemma noWrapAround_middle_goodSize : forall p (n : W) cur (sz sz' : W),
  noWrapAround p (wordToNat n)
  -> noWrapAround (p ^+ natToW 4 ^* n) (S (S (wordToNat sz')))
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> cur ^+ natToW 4 ^* sz ^+ natToW 8 = p
  -> goodSize (wordToNat sz' + wordToNat n + wordToNat (natToW 2) + wordToNat sz).
  intros; replace (wordToNat sz' + wordToNat n + wordToNat (natToW 2) + wordToNat sz)
    with (wordToNat sz + wordToNat n + wordToNat (natToW 2) + wordToNat sz') by omega.
  eapply goodSize_weaken; [ eapply noWrapAround_middle_goodSize'; try apply H; eauto | omega ].
Qed.

Lemma noWrapAround_middle_goodSize_less : forall p (n : W) cur (sz sz' : W),
  cur ^+ natToW 4 ^* sz ^+ natToW 8 = p
  -> noWrapAround (p ^+ natToW 4 ^* n) (S (S (wordToNat sz')))
  -> noWrapAround cur (S (S (wordToNat sz)))
  -> noWrapAround p (wordToNat n)
  -> goodSize (wordToNat sz' + wordToNat n + wordToNat (natToW 2)).
  intros; eapply goodSize_weaken; [ eapply noWrapAround_middle_goodSize; eauto | omega ].
Qed.

Local Hint Immediate noWrapAround_middle_goodSize noWrapAround_middle_goodSize_less.

Lemma tickle : forall n, (n >= 2)%nat -> S (S (n - 2)) = n.
  intros; omega.
Qed.

Ltac warith1 :=
  match goal with
    | [ |- context[natToW (wordToNat _)] ] => unfold natToW; rewrite natToWord_wordToNat
    | [ |- context[(4 * _)%nat] ] => rewrite mult_comm; rewrite natToW_times4
    | [ |- context[_ - _] ] => rewrite natToW_minus by auto
    | [ |- context[wordToNat (_ ^+ _)] ] => rewrite wordToNat_wplus by eauto
    | _ => progress deS
  end.

Ltac warith := repeat warith1; words.

Section ok.
  Ltac t := sep hints; eauto;
    try match goal with
          | [ H : freeable _ _ |- _ ] => destruct H; sep hints; eauto
        end;
    match goal with
      | [ H1 : noWrapAround _ (wordToNat ?sz - 1), H2 : _ <= ?sz |- _ ] =>
        specialize (noWrapAround_plus4 H1 H2); intro
      | [ H : _ |- _ ] => apply sub2 in H; [ | solve [ auto ] ]
    end; sep hints;
    repeat match goal with
             | [ H : _ <= _ |- _ ] => apply three_le in H
             | [ H : _ |- _ ] => apply two_le in H
           end; change (wordToNat (natToW 3)) with 3 in *;
    change (wordToNat (natToWord _ 3)) with 3 in *; eauto.

  Hint Rewrite wordToNat_wplus using solve [ eauto ] : sepFormula.

  Hint Rewrite tickle using assumption : sepFormula.

  Theorem ok : moduleOk m.
    vcgen; try t.

    Opaque mult.

    post.
    evaluate hints.
    destruct H14.
    descend.
    step hints.
    step hints.
    descend.
    step hints.
    step hints.
    eauto.
    rewrite <- H10.
    etransitivity; [ | apply allocated_join ].
    step hints.
    replace (wordToNat x8 + wordToNat (sel x3 "n") - (wordToNat (sel x3 "n") - 2))
      with (S (S (wordToNat x8))) by omega.
    etransitivity; [ | apply allocatedSS ].
    replace (sel x3 "p" ^+ natToW 8 ^+ natToW (4 * (wordToNat (sel x3 "n") - 2))%nat)
      with (sel x3 "p" ^+ natToW 4 ^* sel x3 "n") by warith.
    step hints.
    apply allocated_shift_base; warith || omega.
    omega.

    post.
    evaluate hints.
    destruct H18.
    descend.
    step hints.
    step hints.
    descend.
    step hints.
    step hints.
    eauto.
    rewrite <- H14.
    etransitivity; [ | apply allocated_join ].
    step hints.
    apply allocated_shift_base; warith || omega.
    omega.

    post.
    evaluate hints.
    destruct H21.
    descend.
    step hints.
    step hints.
    descend.
    step hints.
    step hints.
    descend.
    repeat rewrite wordToNat_wplus; eauto.
    rewrite <- H17.
    etransitivity; [ | apply allocated_join ].
    step hints.
    etransitivity; [ | apply allocated_join ].
    etransitivity; [ | apply himp_star_frame; [ apply allocated_shift_base | reflexivity ] ].
    step hints.
    repeat rewrite wordToNat_wplus; eauto.
    instantiate (1 := wordToNat (sel x6 "n")).
    change (wordToNat (natToW 2)) with 2.
    replace (wordToNat x12 + wordToNat (sel x6 "n") + 2 + wordToNat x9 -
      wordToNat x9 - wordToNat (sel x6 "n"))
    with (2 + wordToNat x12) by omega.
    etransitivity; [ | apply allocatedSS ].
    replace (sel x6 "cur" ^+ natToW 8 ^+ natToW (4 * wordToNat x9 + 4 * wordToNat (sel x6 "n")))
      with (sel x6 "cur" ^+ natToW 4 ^* x9 ^+ natToW 8 ^+ natToW 4 ^* sel x6 "n").
    step hints.
    apply allocated_shift_base; warith || omega.
    rewrite mult_comm.
    rewrite natToW_plus.
    rewrite natToW_times4.
    rewrite mult_comm.
    rewrite natToW_times4.
    repeat warith1.
    rewrite natToWord_wordToNat.
    words.
    warith.
    auto.
    repeat rewrite wordToNat_wplus; eauto.
    repeat rewrite wordToNat_wplus; eauto.

    post.
    evaluate hints.
    destruct H21.
    descend.
    step hints.
    step hints.
    descend.
    step hints.
    step hints.
    eauto.
    rewrite <- H17.
    step hints.
    etransitivity; [ | apply allocated_join ].
    step hints.
    apply allocated_shift_base; warith || omega.
    omega.

    sep hints.

    Hint Rewrite wordToNat_wminus using nomega : N.

    Focus 4.
    eapply Himp_trans; [ eapply allocated_split | sepLemma ].
    nomega.
    apply allocated_shift_base.
    repeat match goal with
             | H:_ = _ |- _ => rewrite H
           end.
    apply the_ole_switcheroo.
    nomega.

    rewrite H9.
    rewrite <- four_times_wordToNat.
    apply H17.
    rewrite wordToNat_wplus.
    rewrite wordToNat_wminus.
    nomega.
    nomega.
    rewrite wordToNat_wminus by nomega.
    apply (goodSize_weaken (wordToNat x7)).
    apply goodSize_wordToNat.
    nomega.

    rewrite H9.
    split.
    pre_nomega.
    change (wordToNat (natToW 2)) with 2 in *.
    omega.

    eapply noWrapAround_weaken.
    eassumption.
    nomega.
    f_equal.
    rewrite (mult_comm 4).
    rewrite natToW_times4.
    rewrite wmult_comm.
    f_equal.
    transitivity (natToW (wordToNat x7 - wordToNat (sel x4 "n") + 2)).

    change 2 with (wordToNat (natToW 2)) at 2.
    match goal with
      | [ |- ?X ^+ _ = _ ] => rewrite <- (natToWord_wordToNat X)
    end.
    rewrite <- natToW_plus.
    rewrite wordToNat_wminus.
    auto.
    nomega.

    f_equal.
    Opaque minus.
    nomega.

    eapply noWrapAround_weaken'; [ eassumption | nomega ].
  Qed.
End ok.

Global Opaque freeable.


Require Import Pointed WildCat.
Require Import Truncations.SeparatedTrunc.
Require Import AbelianGroup AbHom AbProjective.
Require Import AbSES.Pullback AbSES.BaerSum AbSES.Core.

(** * The set [Ext B A] of abelian group extensions *)

Definition Ext (B A : AbGroup@{u}) := pTr 0 (AbSES B A).

(** An extension [E : AbSES B A] is trivial in [Ext B A] if and only if [E] merely splits. *)
Proposition iff_ab_ext_trivial_split `{Univalence} {B A : AbGroup} (E : AbSES B A)
  : merely {s : GroupHomomorphism B E & (projection _) $o s == idmap}
           <~> (tr E = point (Ext B A)).
Proof.
  refine (equiv_path_Tr _ _ oE _).
  srapply equiv_iff_hprop;
    apply Trunc_functor;
    apply iff_abses_trivial_split.
Defined.

Definition Ext' (B A : AbGroup@{u}) := Tr 0 (AbSES' B A).

Global Instance isbifunctor_ext'@{u v w | u < v, v < w} `{Univalence}
  : IsBifunctor@{v v w u u v v} (Ext' : AbGroup@{u}^op -> AbGroup@{u} -> Type@{v})
  := isbifunctor_compose _ _ (P:=isbifunctor_abses').

(** [Ext B A] is an abelian group for any [A B : AbGroup]. The proof of commutativity is a bit faster if we separate out the proof that [Ext B A] is a group. *)
Definition grp_ext `{Univalence} (B A : AbGroup@{u}) : Group.
Proof.
  snrapply (Build_Group (Ext B A)).
  - intros E F.
    strip_truncations.
    exact (tr (abses_baer_sum E F)).
  - exact (point (Ext B A)).
  - unfold Negate.
    exact (Trunc_functor _ (abses_pullback (- grp_homo_id))).
  - repeat split.
    1: apply istrunc_truncation.
    all: intro E.  1: intros F G.
    all: strip_truncations; unfold mon_unit, point; apply (ap tr).
    + symmetry; apply baer_sum_associative.
    + apply baer_sum_unit_l.
    + apply baer_sum_unit_r.
    + apply baer_sum_inverse_r.
    + apply baer_sum_inverse_l.
Defined.

(** ** The bifunctor [ab_ext] *)

Definition ab_ext `{Univalence} (B A : AbGroup@{u}) : AbGroup.
Proof.
  snrapply (Build_AbGroup (grp_ext B A)).
  intros E F.
  strip_truncations; cbn.
  apply ap.
  apply baer_sum_commutative.
Defined.

Global Instance is01functor_ext `{Univalence} (B : AbGroup^op)
  : Is0Functor (ab_ext B).
Proof.
  srapply Build_Is0Functor; intros ? ? f.
  snrapply Build_GroupHomomorphism.
  1: exact (fmap01 (A:=AbGroup^op) Ext' B f).
  rapply Trunc_ind; intro E0.
  rapply Trunc_ind; intro E1.
  apply (ap tr); cbn.
  apply baer_sum_pushout.
Defined.

Global Instance is10functor_ext `{Univalence} (A : AbGroup)
  : Is0Functor (fun B : AbGroup^op => ab_ext B A).
Proof.
  srapply Build_Is0Functor; intros ? ? f; cbn.
  snrapply Build_GroupHomomorphism.
  1: exact (fmap10 (A:=AbGroup^op) Ext' f A).
  rapply Trunc_ind; intro E0.
  rapply Trunc_ind; intro E1.
  apply (ap tr); cbn.
  apply baer_sum_pullback.
Defined.

Global Instance isbifunctor_ext `{Univalence}
  : IsBifunctor (A:=AbGroup^op) ab_ext.
Proof.
  snrapply Build_IsBifunctor.
  1,2: exact _.
  intros B B' f A A' g.
  rapply Trunc_ind; intro E.
  apply (ap tr).
  apply abses_pushout_pullback_reorder.
Defined.

(** We can push out a fixed extension while letting the map vary, and this defines a group homomorphism. *)
Definition abses_pushout_ext `{Univalence}
  {B A G : AbGroup@{u}} (E : AbSES B A)
  : GroupHomomorphism (ab_hom A G) (ab_ext B G).
Proof.
  snrapply Build_GroupHomomorphism.
  1: exact (fun f => fmap01 (A:=AbGroup^op) Ext' _ f (tr E)).
  intros f g; cbn.
  nrapply (ap tr).
  exact (baer_sum_distributive_pushouts f g).
Defined.

(** ** Extensions ending in a projective are trivial *)

Proposition abext_trivial_projective `{Univalence}
  (P : AbGroup) `{IsAbProjective P}
  : forall A, forall E : AbSES P A, tr E = point (Ext P A).
Proof.
  intros A E.
  apply iff_ab_ext_trivial_split.
  exact (fst (iff_isabprojective_surjections_split P) _ _ _ _).
Defined.

(** It follows that when [P] is projective, [Ext P A] is contractible. *)
Global Instance contr_abext_projective `{Univalence}
  (P : AbGroup) `{IsAbProjective P} {A : AbGroup}
  : Contr (Ext P A).
Proof.
  exists (point _); intro E.
  strip_truncations.
  symmetry; by apply abext_trivial_projective.
Defined.

(* Converely, if all extensions ending in [P] are trivial, then [P] is projective. *)
Proposition abext_projective_trivial `{Univalence} (P : AbGroup)
  (ext_triv : forall A, forall E : AbSES P A, tr E = point (Ext P A))
  : IsAbProjective P.
Proof.
  apply iff_isabprojective_surjections_split.
  intros E p issurj_p.
  apply (iff_ab_ext_trivial_split (abses_from_surjection p))^-1.
  apply ext_triv.
Defined.


From ZornsLemma Require Import Powerset_facts.
From ZornsLemma Require Export Filters.
From Topology Require Export TopologicalSpaces Neighborhoods Continuity.

Program Definition neighborhood_filter {X:TopologicalSpace} (x0:point_set X) :
  Filter X :=
  {| filter_family := [N : _ | neighborhood N x0 ] |}.
Next Obligation.
intros.
destruct H as [[U [[]]]], H0 as [[V [[]]]].
constructor.
exists (Intersection U V); split.
- constructor; auto with topology sets.
- red; intros. destruct H5; constructor; auto.
Qed.
Next Obligation.
intros.
destruct H as [[U [[]]]].
red. constructor.
exists U; repeat split; trivial.
auto with sets.
Qed.
Next Obligation.
constructor.
exists Full_set; repeat split; auto with sets topology.
Qed.
Next Obligation.
red; intro.
destruct H as [[U [[]]]].
apply H1 in H0.
destruct H0.
Qed.

Definition filter_limit {X:TopologicalSpace} (F:Filter X)
  (x0:point_set X) : Prop :=
  Included (filter_family (neighborhood_filter x0))
           (filter_family F).

Definition filter_cluster_point {X:TopologicalSpace}
  (F:Filter X) (x0:point_set X) : Prop :=
  forall S:Ensemble X, In (filter_family F) S ->
  In (closure S) x0.

Lemma filter_limit_is_cluster_point:
  forall {X:TopologicalSpace} (F:Filter X) (x0:point_set X),
  filter_limit F x0 -> filter_cluster_point F x0.
Proof.
intros.
red; intros.
apply meets_every_open_neighborhood_impl_closure.
intros.
assert (In (filter_family F) U).
{ apply H.
  simpl.
  constructor.
  exists U; repeat split; auto with sets.
}
assert (In (filter_family F) (Intersection S U)).
{ apply filter_intersection; trivial. }
apply NNPP; red; intro.
assert (Intersection S U = Empty_set).
{ apply Extensionality_Ensembles; split; red; intros.
  - contradiction H5.
    exists x; trivial.
  - destruct H6.
}
rewrite H6 in H4.
contradiction (filter_empty _ F).
Qed.

Lemma ultrafilter_cluster_point_is_limit: forall {X:TopologicalSpace}
  (F:Filter X) (x0:point_set X),
  filter_cluster_point F x0 -> ultrafilter F ->
  filter_limit F x0.
Proof.
intros.
red.
red; intros N ?.
destruct H1.
destruct H1 as [U [[]]].
cut (In (filter_family F) U).
{ intros; apply filter_upward_closed with U; trivial. }
clear N H3.
apply NNPP; intro.
assert (In (filter_family F) (Complement U)).
{ pose proof (H0 U).
  tauto.
}
pose proof (H _ H4).
rewrite closure_fixes_closed in H5.
- contradiction H5; trivial.
- red; rewrite Complement_Complement; trivial.
Qed.

Lemma closure_impl_filter_limit: forall {X:TopologicalSpace}
  (S:Ensemble X) (x0:point_set X),
  In (closure S) x0 ->
  exists F:Filter X,
    In (filter_family F) S /\ filter_limit F x0.
Proof.
intros.
assert (Inhabited S).
{ destruct (closure_impl_meets_every_open_neighborhood _ _ _ H
    Full_set).
  - apply open_full.
  - constructor.
  - destruct H0.
    exists x; trivial.
}
unshelve refine (let H1:=_ in let H2:=_ in let H3:=_ in
  let Sfilt := Build_Filter_from_basis (Singleton S)
  H1 H2 H3 in _).
- exists S; constructor.
- red; intro.
  inversion H2.
  rewrite H3 in H0.
  destruct H0.
  destruct H0.
- intros.
  destruct H3.
  destruct H4.
  exists S; split; auto with sets.
- unshelve refine (let H4:=_ in
    ex_intro _ (filter_sum (neighborhood_filter x0) Sfilt H4) _).
  + intros.
    simpl in H4.
    destruct H4 as [[U [[]]]].
    simpl in H5.
    destruct H5 as [[T0 [[]]]].
    destruct (closure_impl_meets_every_open_neighborhood
      _ _ _ H U); trivial.
    destruct H8.
    exists x; constructor; auto.
  + split.
    * simpl.
      constructor.
      exists S.
      split; auto with sets.
      exists ( (Full_set, S) ).
      -- constructor; split.
         ++ constructor.
            exists Full_set; repeat split.
            apply open_full.
         ++ constructor.
            exists S; split; auto with sets.
      -- symmetry. apply Intersection_Full_set.
    * red; red; intros U ?.
      constructor.
      exists U.
      split; auto with sets.
      exists ( (U, Full_set) ).
      -- constructor.
         split; trivial.
         constructor.
         exists S; split; auto with sets.
      -- rewrite Intersection_commutative. symmetry.
         apply Intersection_Full_set.
Qed.

Lemma continuous_function_preserves_filter_limits:
  forall (X Y:TopologicalSpace) (f:point_set X -> point_set Y)
    (x:point_set X) (F:Filter X),
  filter_limit F x -> continuous_at f x ->
  filter_limit (filter_direct_image f F) (f x).
Proof.
intros.
red; intros.
intros V ?.
destruct H1.
constructor.
cut (In (filter_family (neighborhood_filter x))
  (inverse_image f V)).
{ apply H. }
constructor.
apply H0; trivial.
Qed.

Lemma func_preserving_filter_limits_is_continuous:
  forall (X Y:TopologicalSpace) (f:point_set X -> point_set Y)
    (x:point_set X),
  (forall F:Filter X, filter_limit F x ->
                     filter_limit (filter_direct_image f F) (f x)) ->
  continuous_at f x.
Proof.
intros.
assert (filter_limit (filter_direct_image f (neighborhood_filter x))
  (f x)).
{ apply H.
  red; auto with sets.
}
red; intros V ?.
assert (In (filter_family (filter_direct_image f (neighborhood_filter x)))
  V).
{ apply H0.
  constructor.
  trivial.
}
destruct H2.
destruct H2.
trivial.
Qed.


Require Export HoTT Ch06.

Inductive W_tree (A : Type) (B : A -> Type) : Type :=
  | sup : forall a : A, (B a -> W_tree A B) -> W_tree A B.

Lemma ap11_V {A B : Type} {f g : A -> B} (p : f = g) (h : forall x y : A, x = y)
      (x y : A)
  : ap11 p^ (h x y)^ = (ap11 p (h x y))^.
Proof.
  induction p.
  induction (h x y).
  reflexivity.
Defined.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Init.Byte.
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.

Require Import Cava.Util.List.
Require Import Cava.Util.Nat.
Require Import Cava.Util.Tactics.

Require Import coqutil.Tactics.Tactics.

Import ListNotations.

Local Open Scope N.

(* Convert the least significant 8 bits of a number to a byte *)
Definition N_to_byte (x : N) : byte :=
  match Byte.of_N (x mod 2^8) with
  | Some b => b
  | None => x00
  end.

Module BigEndianBytes.
  (* evaluate a big-endian list of bytes *)
  Definition concat_bytes (bs : list byte) : N :=
    List.fold_left (fun acc b => N.lor (N.shiftl acc 8) (Byte.to_N b)) bs 0%N.

  (* convert the least significant (n*8) bits of a number to big-endian bytes *)
  Definition N_to_bytes n (x : N) : list byte :=
    List.map (fun i => N_to_byte (N.shiftr x (N.of_nat (n-1-i)*8)))
             (seq 0 n).

  (* convert a big-endian list of bytes to a list of n-byte words (length of list
   must be a multiple of n) *)
  Definition bytes_to_Ns n (x : list byte) : list N :=
    List.map (fun i => concat_bytes (firstn n (skipn (n*i) x))) (seq 0 (length x / n)).
End BigEndianBytes.

Definition byte_xor (x y : byte) : byte := N_to_byte (N.lxor (Byte.to_N x) (Byte.to_N y)).

Module N2Byte.
  Lemma id (x: N) : ((Byte.to_N (N_to_byte x)) = x mod 256)%N.
  Proof.
    cbv [N_to_byte].
    destr (Byte.of_N (x mod 2 ^ 8)).
    { rewrite Byte.to_of_N with (x:=(x mod 2^8)%N) by apply E. reflexivity. }
    { rewrite (Byte.of_N_None_iff (x mod 2^8))%N in E. exfalso.
      pose (N.mod_upper_bound x (2^8))%N.
      assert (2 ^ 8 <> 0)%N by (cbn;lia).
      specialize (l H).
      replace 255%N with (N.pred 256)%N in E by lia.
      apply N.lt_pred_le in E.
      apply N.lt_le_pred in l.
      rewrite l in E.
      cbn in E.
      lia.
    }
  Qed.

End N2Byte.

Module Byte2N.
  Lemma id x: (N_to_byte (Byte.to_N x) = x )%N.
  Proof. destr x; now cbn. Qed.

  Lemma inj x y: (Byte.to_N x = Byte.to_N y -> x = y)%N.
  Proof.  intro H. rewrite <- (id x), <- (id y). now f_equal. Qed.
End Byte2N.

Lemma testbit_byte b n:
  (8 <= n) ->
  N.testbit (Byte.to_N b) n = false.
Proof.
  intros.
  intros.
  remember (Byte.to_N b) as b'.
  pose (Byte.to_N_bounded b).
  apply N.lt_succ_r in l.
  change (N.succ 255) with (2^8) in l.
  rewrite <- Heqb' in l.
  apply N.testbit_high.
  apply (N.lt_le_trans _ (2^8));
    [ lia | apply N.pow_le_mono_r; lia ].
Qed.

Lemma unfold_N_to_bytes_4 x: BigEndianBytes.N_to_bytes 4 x =
  [N_to_byte (N.shiftr x (N.of_nat (4 - 1 - 0) * 8));
  N_to_byte (N.shiftr x (N.of_nat (4 - 1 - 1) * 8));
  N_to_byte (N.shiftr x (N.of_nat (4 - 1 - 2) * 8));
  N_to_byte (N.shiftr x (N.of_nat (4 - 1 - 3) * 8))].
Proof.
  cbv [BigEndianBytes.N_to_bytes].
  now cbn [List.map seq].
Qed.

Lemma shiftr_byte b x: (8 <= x) ->
  N.shiftr (Byte.to_N b) x = 0.
Proof.
  intros.
  remember (Byte.to_N b) as b'.
  pose (Byte.to_N_bounded b).
  apply N.shiftr_eq_0.
  apply N.lt_succ_r in l.
  apply (N.lt_le_trans _ (N.log2 256)).
  {
    destr (0<?b').
    2:{ destr (b'=?0); try rewrite E0; cbn; lia. }
    apply N.log2_lt_pow2. { lia. }
    cbn. now rewrite Heqb'.
  }
  now cbn.
Qed.

Lemma N_to_bytes_length n x : length (BigEndianBytes.N_to_bytes n x) = n.
Proof. cbv [BigEndianBytes.N_to_bytes]. length_hammer. Qed.
Hint Rewrite @N_to_bytes_length : push_length.

Lemma bytes_to_Ns_length n bs:
  (length (BigEndianBytes.bytes_to_Ns n bs) = length bs / n)%nat.
Proof. cbv [BigEndianBytes.bytes_to_Ns]. length_hammer. Qed.
Hint Rewrite @bytes_to_Ns_length : push_length.

Lemma N_to_byte_to_N x : Byte.to_N (N_to_byte x) = (x mod 256)%N.
Proof.
  cbv [N_to_byte]. change (2 ^ 8)%N with 256%N.
  pose proof N.mod_bound_pos x 256 ltac:(lia) ltac:(lia).
  pose proof proj1 (Byte.of_N_None_iff (x mod 256)).
  apply Byte.to_of_N.
  destruct (Byte.of_N (x mod 256)); [ reflexivity | ].
  lazymatch goal with H : None = None -> _ |- _ =>
                      specialize (H ltac:(reflexivity)) end.
  lia.
Qed.

Lemma nth_bytes_to_Ns i n bs :
  (length bs mod n = 0)%nat ->
  (n <> 0)%nat ->
  List.nth i (BigEndianBytes.bytes_to_Ns n bs) 0%N
  = BigEndianBytes.concat_bytes
      (List.map
         (fun j => List.nth (i*n + j) bs Byte.x00)
         (seq 0 n)).
Proof.
  cbv [BigEndianBytes.bytes_to_Ns]. intros.
  destruct (Compare_dec.lt_dec i (length bs / n)).
  { erewrite map_nth_inbounds with (d2:=0%nat) by length_hammer.
    cbv [BigEndianBytes.concat_bytes]. f_equal; [ ].
    push_nth. natsimpl.
    erewrite firstn_map_nth with (d:=Byte.x00).
    { eapply List.map_ext_in; intros *.
      rewrite in_seq; natsimpl; intros.
      push_nth. f_equal; lia. }
    { push_length.
      Zify.zify.
      (* extra step because zify fails to zify Nat.modulo and Nat.div *)
      rewrite ?mod_Zmod, ?div_Zdiv in * by lia.
      Zify.zify; Z.to_euclidean_division_equations.
      (* N.B. this needs nia instead of lia *)
      nia. } }
  { push_nth. cbv [BigEndianBytes.concat_bytes].
    assert (length bs <= i * n)%nat.
    { Zify.zify.
      (* extra step because zify fails to zify Nat.modulo and Nat.div *)
      rewrite ?mod_Zmod, ?div_Zdiv in * by lia.
      Zify.zify; Z.to_euclidean_division_equations.
      (* N.B. this needs nia instead of lia *)
      nia. }
    apply fold_left_invariant with (I:= eq 0%N); [ reflexivity | | tauto ].
    intros *; rewrite in_map_iff.
    intros; logical_simplify; subst.
    match goal with H : _ |- _ => apply in_seq in H end.
    push_nth. reflexivity. }
Qed.

Lemma N_to_byte_equiv x y :
  (x mod 256 = y mod 256)%N -> N_to_byte x = N_to_byte y.
Proof.
  intro Heq. cbv [N_to_byte]. compute_expr (2 ^ 8)%N.
  rewrite Heq. reflexivity.
Qed.

Lemma nth_N_to_bytes i n x :
  (i < n)%nat ->
  List.nth i (BigEndianBytes.N_to_bytes n x) Byte.x00
  = N_to_byte (N.shiftr (N.land x (N.ones (8 * N.of_nat n)))
                        (N.of_nat (n - 1 - i) * 8)).
Proof.
  intros. cbv [BigEndianBytes.N_to_bytes].
  push_nth; natsimpl. apply N_to_byte_equiv.
  change 256%N with (2 ^ 8)%N.
  apply N.bits_inj; intro j.
  push_Ntestbit; boolsimpl.
  case_eq (j <? 8)%N; intros; N.bool_to_prop; [ | reflexivity ].
  push_Ntestbit. boolsimpl.
  f_equal; lia.
Qed.

Lemma concat_bytes_spec_low bs n:
  n < (N.of_nat (length bs) * 8) + 8->
  forall y,
  (forall n', n' < 8 -> N.testbit y n' = false) ->
  N.testbit
    (fold_left
    (fun (acc : N) (b : byte) => N.lor (N.shiftl acc 8) (Byte.to_N b)) bs y)
    n = N.testbit (Byte.to_N (nth (N.to_nat (n / 8)) (rev bs) "000"%byte)) (n mod 8).
Proof.
  revert n.

  replace bs with (rev (rev bs)) by apply rev_involutive.
  rename bs into x.
  remember (rev x) as bs; clear Heqbs x.
  rewrite rev_involutive.

  induction bs.
  { intros; cbn in *.
    destruct (N.to_nat (n / 8)); destr (n <? 8); try lia;
      rewrite N.mod_small by lia; rewrite H0 by lia; now push_Ntestbit.
  }
  intros.
  cbn [rev].
  rewrite fold_left_app.
  cbn [fold_left].
  destr (n <? 8); push_Ntestbit.
  { replace (n/8) with 0 by (rewrite N.div_small; lia).
    cbn.
    now rewrite N.mod_small by lia.
  }
  replace (n/8) with (1 + ((n - 8)/8)) .
  2:{ zify. Z.to_euclidean_division_equations. lia. }

  replace (N.to_nat (1 + (n - 8) / 8)) with (S (N.to_nat ((n - 8) / 8))) by lia.
  rewrite nth_step.

  replace (n mod 8) with ((n - 8) mod 8).
  2:{ zify. Z.to_euclidean_division_equations. lia. }

  rewrite testbit_byte by lia.
  boolsimpl.
  apply IHbs.
  { remember (n - 8) as n'.
    apply (N.add_cancel_r n' (n-8) 8) in Heqn'.
    rewrite N.sub_add in Heqn' by lia.
    rewrite <- Heqn' in H.
    rewrite rev_length in H.
    cbn [length] in H.
    apply N.add_lt_mono_r in H.
    push_length.
    replace (N.of_nat (length bs) * 8 + 8) with (N.of_nat (S (length bs)) * 8) by lia.
    apply H.
  }
  apply H0.
Qed.

Lemma concat_bytes_spec_high bs n:
  N.of_nat (length bs) * 8 + 8 <= n ->
  N.testbit (fold_left (fun (acc : N) (b : byte) => N.lor (N.shiftl acc 8) (Byte.to_N b)) bs 0) n =
  N.testbit (Byte.to_N (nth (N.to_nat (n / 8)) (rev bs) "000"%byte)) (n mod 8).
Proof.
  intros.
  revert n H.
  replace bs with (rev (rev bs)) by apply rev_involutive.
  rename bs into x.
  remember (rev x) as bs; clear Heqbs x.
  rewrite rev_involutive.
  induction bs.
  { intros. cbn. destruct (N.to_nat (n/8)); now cbn. }

  intros.
  cbn [rev].
  rewrite fold_left_app.
  cbn [fold_left].
  push_Ntestbit.

  replace (n/8) with (1 + ((n - 8)/8)).
  2:{ zify. Z.to_euclidean_division_equations. lia. }

  replace (N.to_nat (1 + (n - 8) / 8)) with (S (N.to_nat ((n - 8) / 8))) by lia.
  rewrite nth_step.

  replace (n mod 8) with ((n - 8) mod 8).
  2:{ zify. Z.to_euclidean_division_equations. lia. }

  rewrite testbit_byte by lia.
  boolsimpl.
  apply IHbs.
  replace (N.of_nat ( length (rev (a:: bs)))) with (1 + N.of_nat (length bs)) in H by (push_length;lia).
  rewrite N.mul_add_distr_r in H.
  rewrite <- N.add_assoc in H.
  apply N.le_add_le_sub_l in H.
  change (1*8) with 8 in H.
  push_length; apply H.
Qed.

Lemma concat_bytes_spec bs n:
  N.testbit (BigEndianBytes.concat_bytes bs) n =
  N.testbit (Byte.to_N (nth (N.to_nat (n / 8)) (rev bs) x00)) (n mod 8).
Proof.
  cbv [BigEndianBytes.concat_bytes].
  destr (n <? N.of_nat (length bs) * 8 + 8).
  {
    apply concat_bytes_spec_low.
    { apply E. }
    { intros. now push_Ntestbit. }
  }
  now apply concat_bytes_spec_high.
Qed.

Hint Rewrite @concat_bytes_spec : push_Ntestbit.

Lemma testbit_mod_idx n m x y:
  m <> 0 ->
  (forall n', n' < m -> N.testbit x n' = y)
  -> N.testbit x (n mod m) = y.
Proof.
  intros.

  rewrite N.mod_eq by lia.
  apply H0.
  zify. Z.to_euclidean_division_equations. lia.
Qed.

Lemma testbit_mod_same_idx n m o x y:
  o <> 0 ->
  (n mod o = m mod o) ->
  (forall n', n' < o -> N.testbit x n' = N.testbit y n')
  -> N.testbit x (n mod o) = N.testbit y (m mod o).
Proof.
  intros.
  do 2 rewrite N.mod_eq by lia.
  repeat rewrite N.mod_eq in H0 by lia.
  rewrite H0.
  apply H1.
  zify. Z.to_euclidean_division_equations. lia.
Qed.

Lemma concat_bytes_last_spec b bs n:
  n < 8 ->
  forall y,
  N.testbit
    (fold_left
    (fun (acc : N) (b : byte) => N.lor (N.shiftl acc 8) (Byte.to_N b)) (bs ++ [b]) y)
       n = N.testbit (Byte.to_N (nth (length bs  - N.to_nat (n / 8)) (bs ++ [b]) "000"%byte)) (n mod 8).
Proof.
  intros H.
  induction bs.

  { intros; cbn.
    rewrite N.mod_small by lia.
    push_Ntestbit.
    reflexivity.
  }

  { intros.
    rewrite <- app_comm_cons.
    rewrite fold_left_cons.
    push_length.
    replace (S (length bs) - N.to_nat (n / 8))%nat with (S (length bs - N.to_nat (n / 8)))%nat by
      now rewrite minus_Sn_m by (rewrite N.div_small; lia).

    rewrite nth_step.
    apply IHbs.
  }
Qed.

Lemma concat_bytes_skip_4_of_8_spec xs n:
    (length xs < 8)%nat ->
    n < 32 ->
      N.testbit
        (BigEndianBytes.concat_bytes (List.resize Byte.x00 8 (skipn 4 xs))) n = false.
Proof.
  repeat (destruct xs; try cbn; try lia);
    intros; repeat rewrite N.lor_0_r; repeat rewrite N.shiftl_shiftl;
    now repeat (push_Ntestbit; boolsimpl).
Qed.

Lemma concat_bytes_lower_8_zero xs n:
    (length xs < 4)%nat ->
    n < 32 ->
      N.testbit
        (BigEndianBytes.concat_bytes (List.resize Byte.x00 8 xs)) n = false.
Proof.
  repeat (destruct xs; try cbn; try lia);
    intros; repeat rewrite N.lor_0_r; repeat rewrite N.shiftl_shiftl;
    now repeat (push_Ntestbit; boolsimpl).
Qed.

Lemma concat_bytes_skip_lower32 xs n:
      32 <= n -> n < 64 ->
      N.testbit (BigEndianBytes.concat_bytes (List.resize Byte.x00 8 xs)) (n - 32) =
      N.testbit (BigEndianBytes.concat_bytes (List.resize Byte.x00 8 (skipn 4 xs))) n.
Proof.
  intros.
  push_Ntestbit.
  apply testbit_mod_same_idx; try lia.
  { zify; Z.to_euclidean_division_equations; lia. }
  intros.
  do 2 f_equal.
  do 2 rewrite rev_nth by
    ( push_length; zify; Z.to_euclidean_division_equations; lia).
  cbv [resize].
  push_length.
  destruct (Nat.ltb_spec
    (Init.Nat.min 8 (length xs) + (8 - length xs) - S (N.to_nat ((n - 32) / 8)))
    (Init.Nat.min 8 (length xs))).
  {
    assert
      (Init.Nat.min 8 (length xs - 4) + (8 - (length xs - 4)) - S (N.to_nat (n / 8))
      < Init.Nat.min 8 (length xs - 4))%nat.
    { zify; Z.to_euclidean_division_equations; lia. }
    repeat rewrite app_nth1 by (push_length; lia).
    repeat rewrite nth_firstn_inbounds by lia.
    rewrite nth_skipn.
    f_equal.
    { zify; Z.to_euclidean_division_equations; lia. }
  }
  assert
    (Init.Nat.min 8 (length xs - 4) + (8 - (length xs - 4)) - S (N.to_nat (n / 8))
    >= Init.Nat.min 8 (length xs - 4))%nat.
  { zify; Z.to_euclidean_division_equations; lia. }
  repeat rewrite app_nth2 by (push_length; lia).
  repeat rewrite nth_repeat.
  now repeat rewrite Tauto.if_same.
Qed.

Lemma concat_bytes_8_is_64bit xs n:
      64 <= n ->
      N.testbit
        (BigEndianBytes.concat_bytes (List.resize Byte.x00 8 xs))
        n = false.
Proof.
  intros. push_Ntestbit.
  assert (8 <= n/8).
  { zify; Z.to_euclidean_division_equations; lia. }
  rewrite <- N2Nat.id with (a:=n/8).
  remember (N.to_nat (n/8)) as x.
  rewrite Nat2N.id.
  destr (x <? 8)%nat;[lia|].
  rewrite nth_overflow by (push_length; lia).
  now push_Ntestbit.
Qed.

Lemma concat_bytes_resize_masked x:
      N.shiftr
        (BigEndianBytes.concat_bytes (List.resize Byte.x00 8 x))
        (N.of_nat 32) mod 2 ^ N.of_nat 32 =
      BigEndianBytes.concat_bytes (List.resize Byte.x00 4 x).
Proof.
  rewrite <- N.land_ones.
  apply N.bits_inj. intros n.
  destr (n <? 32).
  { push_Ntestbit; boolsimpl.
    apply testbit_mod_same_idx; try lia.
    { zify; Z.to_euclidean_division_equations; lia. }
    intros.
    replace ((n + N.of_nat 32) / 8) with ((n/8) + 4).
    2:{ zify; Z.to_euclidean_division_equations; lia. }
    rewrite <- N2Nat.id with (n/8) in *.
    remember (N.to_nat (n/8)) as j.
    rewrite Nat2N.id.
    assert(j < 4)%nat.
    { zify; Z.to_euclidean_division_equations; lia. }
    repeat rewrite rev_nth by (push_length; lia).
    replace (N.to_nat (N.of_nat j + 4)) with (j + 4)%nat by lia.
    push_length.
    f_equal.
    f_equal.
    cbv [resize].
    destruct (Nat.ltb_spec (8 - S (j + 4)) (Init.Nat.min 8 (length x))).
    {
      assert (4 - S j < Init.Nat.min 4 (length x))%nat by lia.
      repeat rewrite app_nth1 by (push_length; lia).
      repeat rewrite nth_firstn_inbounds by lia.
      f_equal.
      lia.
    }
    {
      assert (Init.Nat.min 4 (length x) <= 4 - S j)%nat by lia.
      repeat rewrite app_nth2 by (push_length; lia).
      repeat rewrite nth_repeat.
      now repeat rewrite Tauto.if_same.
    }
  }
  push_Ntestbit;boolsimpl.
  rewrite nth_overflow.
  { now push_Ntestbit. }
  push_length.
  { zify; Z.to_euclidean_division_equations; lia. }
Qed.

Lemma bytes_to_N_id_4 xs:
  length xs = 4%nat ->
  BigEndianBytes.N_to_bytes 4 (BigEndianBytes.concat_bytes xs) = xs.
Proof.
  intros.
  rewrite unfold_N_to_bytes_4.
  do 5 (destruct xs; try (cbn in *; lia)).
  cbn [BigEndianBytes.concat_bytes fold_left Nat.sub Nat.mul].
  do 4 f_equal.
  all:
    apply Byte2N.inj; rewrite N2Byte.id; change 256 with (2^8);
    rewrite <- N.land_ones;
    apply N.bits_inj; intro x; push_Ntestbit; boolsimpl;
    destruct (N.ltb_spec x 8);
    push_Ntestbit; boolsimpl;
      repeat rewrite testbit_byte by lia; [
      repeat rewrite <- N.add_sub_assoc by lia;
      cbn;
      rewrite N.add_0_r;
      repeat match goal with | |- context [N.testbit ?b ?N] => rewrite testbit_byte with (n:=N) by (cbn; lia) end;
      now boolsimpl
    | reflexivity].
Qed.

Local Ltac tb A :=
  rewrite <- Byte2N.id with (x:=A);
  remember (Byte.to_N A).

Lemma concat_bytes_4_bound xs:
  BigEndianBytes.concat_bytes (List.resize Byte.x00 4 xs) < 2 ^ 32.
Proof.
  assert (exists a b c d, [a;b;c;d] = resize Byte.x00 4 xs).
  { do 4 (destruct xs; [repeat eexists|]).
    repeat eexists.
  }
  logical_simplify.
  rewrite <- H.
  cbn.
  repeat rewrite N.shiftl_mul_pow2.
  tb x; tb x0; tb x1; tb x2.
  repeat rewrite N2Byte.id.
  repeat rewrite N.lor_high_low_add.
  cbn. zify. Z.to_euclidean_division_equations. lia.
Qed.

Lemma concat_bytes_8_bound xs:
  BigEndianBytes.concat_bytes (List.resize Byte.x00 8 xs) < 2 ^ 64.
Proof.
  assert (exists a b c d e f g h, [a;b;c;d;e;f;g;h] = resize Byte.x00 8 xs).
  { do 8 (destruct xs; [repeat eexists|]).
    repeat eexists.
  }
  logical_simplify.
  rewrite <- H.
  cbn.
  repeat rewrite N.shiftl_mul_pow2.
  tb x; tb x0; tb x1; tb x2; tb x3; tb x4; tb x5; tb x6.
  repeat rewrite N2Byte.id.
  repeat rewrite N.lor_high_low_add.
  cbn. zify. Z.to_euclidean_division_equations. lia.
Qed.

Lemma concat_bytes_truncation x:
  (N.shiftr
    (BigEndianBytes.concat_bytes (List.resize Byte.x00 8 x))
    (N.of_nat 32) mod 2 ^ N.of_nat 32)%N
    = BigEndianBytes.concat_bytes (List.resize Byte.x00 4 x).
Proof.
  change (N.of_nat 32) with 32.
  rewrite <- N.mod_small with (a:=BigEndianBytes.concat_bytes (resize "000"%byte 4 x)) (b:=2^32)
    by apply concat_bytes_4_bound.

  assert (exists a b c d e f g h, [a;b;c;d;e;f;g;h] = resize Byte.x00 8 x).
  { do 8 (destruct x; [repeat eexists|]).
    repeat eexists.
  }
  logical_simplify.
  rewrite <- H.
  assert ([x0;x1;x2;x3] = resize Byte.x00 4 x).
  {
    rewrite <- resize_resize with (m:=8%nat) by lia.
    rewrite <- H.
    now cbn.
  }
  rewrite <- H0.

  apply N.bits_inj; intro n;push_Ntestbit.
  destruct (N.ltb_spec n 32); [|reflexivity].
  apply testbit_mod_same_idx; try lia.
  { zify. Z.to_euclidean_division_equations. lia. }
  intros.
  cbn.
  replace (N.to_nat ((n+32)/8)) with (N.to_nat (n/8)%N + 4)%nat; cycle 1.
  { zify. Z.to_euclidean_division_equations. lia. }
  remember (N.to_nat (n/8)) as n0.
  destruct n0; cbn; [reflexivity|].
  destruct n0; cbn; [reflexivity|].
  destruct n0; cbn; [reflexivity|].
  destruct n0; cbn; [reflexivity|].
  { zify. Z.to_euclidean_division_equations. lia. }
Qed.

Ltac testbit_crush :=
  repeat lazymatch goal with
         | |- context [N.eqb ?x ?y] => destr (N.eqb x y); try lia; subst
         | |- N.testbit ?x _ = N.testbit ?x _ => f_equal; lia
         | H: (?X < ?Y)%N |- context [if (?X <? ?Y)%N then _ else _] =>
           rewrite (proj2 (N.ltb_lt X Y) H)
         | _ => first [ progress (push_Ntestbit; boolsimpl) | reflexivity ]
         end.


Require Import ssreflect ssrbool.

(**
# 第5回 集合論モデルの練習 (2014/05/04)

## 課題21 (種別:A / 締め切り : 2014/05/11)

次の定理を証明せよ。ただし、Coq.LogicおよびCoq.Setsに定義されている公理を用いても構わない。
各定理について、それを証明するのに必要な公理はできるだけ弱いものに留めるのが望ましい。
なお、autoやtautoなどの自動証明タクティックを用いてもよい。
*)

(**
## 回答

まず、問題1と問題3を解くために必要になる、排中律を定義する。
*)

(**
公理：排中律
*)
Axiom classic : forall A, A \/ ~A.          (* 排中律 *)

(**
### 問題1
*)
Lemma ABC_iff_iff :
  forall A B C : Prop, ((A <-> B) <-> C) <-> (A <-> (B <-> C)).
Proof.
admit.
Qed.

(**
### 問題2

IF P then Q else R は、P/\Q \/ ~P/\R と定義されているので、
(P/\Q)と(~P/\R)による場合分けで解くことができる。
排中律も使用しない。
*)
Print IF_then_else.
(* = fun P Q R : Prop => P /\ Q \/ ~ P /\ R *)

Goal forall P Q R : Prop,
       (IF P then Q else R) ->
       exists b : bool, (if b then Q else R).
Proof.
  move=> P Q R.
  (* IF P then Q else R で場合分けする。 *)
  case=> [HPQ | HnPR].
  (* then節の場合（P /\ Q を前提とする場合） *)
    exists true.
      by case: HPQ.
  (* else節の場合（(~ P) /\ R を前提とする場合） *)
  exists false.
    by case: HnPR.
Qed.

(**
### excluded_middle_informative

問題3の前に excluded_middle_informative の説明をする。
これは、Coq.Logic.ClassicalDescription で定義されているので、
以下をImportすれば定理として使用できるが、ここでは説明のため。

Require Import Logic.ClassicalDescription.
*)

(**
公理：
命題 P x yを満たす x が存在するなら、関数 f:y->x (f = {x|P y x}) がある。

Pがカリー化されて解りにくいが、言いたいことはこういうことなのだろう。
これは、チャーチのiotaオペレータを弱くしたもの。(see. Coq.Logic.Description.v)
 *)
Axiom constructive_indefinite_description :
  forall (A : Type) (P : A -> Prop), (exists x : A, P x) -> {x : A | P x}.

Lemma constructive_definite_description :
  forall (A : Type) (P : A -> Prop), (exists ! x : A, P x) -> {x : A | P x}.
Proof.
  move=> A P H.
  apply constructive_indefinite_description.
  firstorder.                               (* ?? *)
Qed.

Lemma constructive_definite_descr_excluded_middle :
  (forall A : Type, forall P : A -> Prop, (exists ! x : A, P x) -> {x : A | P x}) ->
  (forall P : Prop, P \/ ~ P) ->
  forall P : Prop, {P} + {~ P}.
Proof.
  admit.                                    (* ChoiceFacts.v *)
Qed.

Theorem excluded_middle_informative : forall P : Prop, {P} + {~ P}.
Proof.
  apply
    (constructive_definite_descr_excluded_middle
       constructive_definite_description
       classic).
Defined.

(**
もちろん、自然数に対する「n = m」の特定の命題の場合は、
排中律もチャーチのiotaもなしで証明できる。
 *)
Theorem eq_nat_dec : forall (n m : nat), {n = m} + {n <> m}.
Proof.
  induction n; destruct m; auto.
  elim (IHn m); auto.
Defined.

(**
### 問題3

IF_then_else から if_then_elseの関係は証明できる。これを補題とする。
*)
Lemma IF__if : forall (P Q R : Prop),
                 (IF P then Q else R) ->
                 (if is_left (excluded_middle_informative P) then Q else R).
unfold is_left.
Proof.
  move=> P Q R H.
  case: (excluded_middle_informative P);
    case: H => [HPQ | HnPR]; [case: HPQ | case: HnPR | case: HPQ | case: HnPR];
                by [].
Qed.

(**
補題を適用すると、問題は解ける。
*)
Goal
  forall P Q R : nat -> Prop,
    (forall n, IF P n then Q n else R n) ->
    exists f : nat -> bool, (forall n, if f n then Q n else R n).
Proof.
  move=> P Q R Hn.
  exists (fun (n : nat) => is_left (excluded_middle_informative (P n))).
  move=> n.
  by apply (IF__if (P n) (Q n) (R n)).
Qed.

(**
## おまけ1

if_then_else から IF_then_elseの関係は、排中律を使わずに証明できる。
*)
Lemma if__IF : forall (p : bool) (Q R : Prop),
                 (if p then Q else R) ->
                 (IF (p = true) then Q else R).
Proof.
  rewrite /IF_then_else.
  by case=> Q R H; [left | right].
Qed.

(**
### おまけ2

IF_then_else について考えてみたが、これは弱すぎて使えなかった。

排中律を仮定すると、(IF P then Q else R) -> (Q \/ R) が成立する。
これは、Pと~Pとで場合分けできるからだ。
*)
Lemma IF__or : forall P Q R,
                 (IF P then Q else R) -> Q \/ R.
Proof.
  move=> P Q R.
  case: (classic P) => [HP | HnotP];        (* 排中律で場合分けする。 *)
    by case=> [H1 | H2]; [left; apply H1 | right; apply H2].
Qed.

(**
ifはboolなので、排中律はいらない。
*)
Lemma if__or : forall (p : bool) (Q R : Prop),
                 (if p then Q else R) -> Q \/ R.
Proof.
  move=> p Q R.
    by case: p => [HQ | HR]; [left | right].
Qed.

(**
どちらも、逆が成立しないのは、Q\/Rが成立するからといって、
Qが成立して欲しいとき(Pが成立するとき)にQが成立するとは限らないからである。
*)

(* END *)


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

Section alternate_interior_angles_postulate_triangle.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma alternate_interior__triangle :
  alternate_interior_angles_postulate ->
  triangle_postulate.
Proof.
intros AIA A B C D E F HTrisuma.
elim (col_dec A B C); [intro; apply (col_trisuma__bet A B C); auto|intro HNCol].
destruct(ex_conga_ts B C A C B A) as [B1 [HConga HTS]]; Col.
assert (HPar : Par A C B B1)
  by (apply par_left_comm, par_symmetry, l12_21_b; Side; CongA).
apply (par_not_col_strict _ _ _ _ B) in HPar; Col.
assert (HNCol1 : ~ Col C B B1) by (apply (par_not_col A C); Col).
assert (HNCol2 : ~ Col A B B1) by (apply (par_not_col A C); Col).
destruct (symmetric_point_construction B1 B) as [B2 [HBet HCong]]; assert_diffs.
assert (HTS1 : TS B A B1 B2)
  by (repeat split; Col; [intro; apply HNCol2; ColR|exists B; Col]).
assert (HTS2 : TS B A C B2)
  by (apply (l9_8_2 _ _ B1); auto; apply os_ts1324__os; Side).
apply (bet_conga__bet B1 B B2); auto.
destruct HTrisuma as [D1 [E1 [F1 []]]].
apply (suma2__conga D1 E1 F1 C A B); auto.
assert (CongA A B B2 C A B).
  {
  apply conga_left_comm, AIA; Side.
  apply par_symmetry, (par_col_par _ _ _ B1); Col; Par.
  }
apply (conga3_suma__suma B1 B A A B B2 B1 B B2); try (apply conga_refl); auto;
[exists B2; repeat (split; CongA); Cop; apply l9_9; auto|].
apply (suma2__conga A B C B C A); auto.
apply (conga3_suma__suma A B C C B B1 A B B1); CongA.
exists B1; repeat (split; CongA); Cop; apply l9_9; Side.
Qed.

End alternate_interior_angles_postulate_triangle.