(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

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

Require Import ZArith Znumtheory Zpow_facts.
Require Import CyclicAxioms DoubleCyclic BigN Cyclic31 Int31.
Require Import W.
Require Import Mod_op.
Require Import ZEll.
Require Import Bits.
Import CyclicAxioms DoubleType DoubleBase.

Set Implicit Arguments.

Open Scope Z_scope.

Record ex: Set := mkEx {
  vN : positive;
  vS : positive;
  vR:  List.list (positive * positive);
  vA:  Z;
  vB:  Z;
  vx:  Z;
  vy:  Z
}.

Record ex_spec (exx: ex): Prop := mkExS {
  n2_div: ~(2 | Zpos exx.(vN));
  n_pos: 2 < Zpos exx.(vN);
 lprime:
  forall p : positive * positive, List.In p (vR exx) -> prime (Zpos (fst p));
   lbig:
    4 * Zpos (vN exx) < (Zpos (Zmullp (vR exx)) - 1) ^ 2;
   inC:
    vy exx ^ 2 mod (Zpos (vN exx)) = (vx exx ^ 3 + vA exx * vx exx + vB exx) mod (Zpos (vN exx))
}.

Section NEll.

Variable exx: ex.
Variable exxs: ex_spec exx.

Variable zZ: Type.
Variable op: znz_op zZ.
Variable op_spec: znz_spec op.
Definition z2Z z := op.(znz_to_Z) z.
Definition zN := snd (op.(znz_of_pos) exx.(vN)).
Variable mop: mod_op zZ.
Variable mop_spec: mod_spec op zN mop.
Variable N_small:  Zpos exx.(vN) < base (znz_digits op).

Lemma z2ZN: z2Z zN = Zpos exx.(vN).
apply (@znz_of_Z_correct _ _ op_spec (Zpos exx.(vN))); split; auto with zarith.
Qed.

Definition Z2z z :=
 match z mod (Zpos exx.(vN)) with
 | Zpos p => snd (op.(znz_of_pos) p)
 | _ => op.(znz_0)
 end.

Definition S := exx.(vS).
Definition R := exx.(vR).
Definition A := Z2z exx.(vA).
Definition B := Z2z exx.(vB).
Definition xx := Z2z exx.(vx).
Definition yy := Z2z exx.(vy).
Definition c3 := Z2z 3.
Definition c2 := Z2z 2.
Definition c1 := Z2z 1.
Definition c0 := Z2z 0.

Inductive nelt: Type :=
  nzero | ntriple: zZ -> zZ -> zZ  -> nelt.

Definition pp := ntriple xx yy c1.

Definition nplus x y := mop.(add_mod) x y.
Definition nmul x y :=  mop.(mul_mod) x y.
Definition nsub x y :=  mop.(sub_mod) x y.
Definition neq x y := match op.(znz_compare) x y with Eq => true | _ => false end.

Notation "x +++ y " := (nplus x y) (at level 50, left associativity).
Notation "x -- y" := (nsub x y) (at level 50, left associativity).
Notation "x ** y" := (nmul x y) (at level 40, left associativity).
Notation "x ?= y" := (neq x y).

Definition ndouble: zZ -> nelt -> (nelt * zZ):= fun (sc: zZ) (p1: nelt) =>
 match p1 with
  nzero => (p1, sc)
 | (ntriple x1 y1 z1) =>
    if (y1 ?= c0) then (nzero, z1 ** sc) else
     (* we do 2p *)
    let m' := c3 ** x1 ** x1 +++ A ** z1 ** z1 in
    let l' := c2 ** y1 ** z1 in
    let m'2 := m' ** m' in
    let l'2 := l' ** l' in
    let l'3 := l'2 ** l' in
    let x3 := m'2 ** z1 -- c2 ** x1 ** l'2 in
    (ntriple
          (l' ** x3)
          (l'2 ** (m' ** x1 -- y1 ** l') -- m' ** x3)
          (z1 ** l'3), sc)
  end.

Definition nadd := fun (sc: zZ) (p1 p2: nelt) =>
 match p1, p2 with
  nzero, _ => (p2, sc)
 | _ , nzero => (p1, sc)
 | (ntriple x1 y1 z1), (ntriple x2 y2 z2) =>
  let d1 := x2 ** z1 in
  let d2 := x1 ** z2 in
  let l := d1 -- d2 in
  let dl := d1 +++ d2 in
  let m := y2 ** z1 -- y1 ** z2 in
  if (l ?= c0) then
   (* we have p1 = p2 o p1 = -p2 *)
   if (m ?= c0) then
    if (y1 ?= c0) then (nzero, z1 ** z2 ** sc) else
     (* we do 2p *)
    let m' := c3 ** x1 ** x1 +++ A ** z1 ** z1 in
    let l' := c2 ** y1 ** z1 in
    let m'2 := m' ** m' in
    let l'2 := l' ** l' in
    let l'3 := l'2 ** l' in
    let x3 := m'2 ** z1 -- c2 ** x1 ** l'2 in
    (ntriple
          (l' ** x3)
          (l'2 ** (m' ** x1 -- y1 ** l') -- m' ** x3)
          (z1 ** l'3), z2 ** sc)
    else (* p - p *)  (nzero, m ** z1 ** z2 ** sc)
  else
     let l2 := l ** l in
     let l3 := l2 ** l in
     let m2 := m ** m in
     let x3 := z1 ** z2 ** m2 -- l2 ** dl in
      (ntriple (l ** x3)
             (z2 ** l2 ** (m ** x1 -- y1 ** l) -- m ** x3)
             (z1 ** z2 ** l3), sc)
  end.

Definition nopp p :=
  match p with nzero => p | (ntriple x1 y1 z1) => (ntriple x1 (c0 -- y1) z1) end.

Fixpoint scalb (sc: zZ) (b:bool) (a: nelt) (p: positive) {struct p}:
 nelt * zZ :=
 match p with
   xH => if b then ndouble sc a else (a,sc)
 | xO p1 => let (a1, sc1) := scalb sc false a p1 in
              if b then
                let (a2, sc2) := ndouble sc1 a1 in
                nadd sc2 a a2
              else ndouble sc1 a1
 | xI p1 => let (a1, sc1) := scalb sc true a p1 in
              if b then  ndouble sc1 a1
              else
              let (a2, sc2) := ndouble sc1 a1 in
              nadd sc2 (nopp a) a2
 end.

Definition scal sc a p := scalb sc false a p.

Definition scal_list sc a l :=
  List.fold_left
  (fun (asc: nelt * zZ) p1 => let (a,sc) := asc in scal sc a p1) l (a,sc).

Fixpoint scalL (sc:zZ) (a: nelt) (l: List.list positive) {struct l}: (nelt * zZ) :=
   match l with
     List.nil => (a,sc)
   | List.cons n l1 =>
        let (a1, sc1) := scal sc a n in
        let (a2, sc2) := scal_list sc1 a l1 in
          match a2 with
             nzero => (nzero, c0)
          |  ntriple _ _ z => scalL (sc2 ** z) a1 l1
          end
   end.

Definition zpow sc p n :=
  let (p,sc') := scal sc p n in
  (p, op.(znz_to_Z) (op.(znz_gcd) sc' zN)).

Definition e2E n :=
  match n with
    nzero => ZEll.nzero
  | ntriple x1 y1 z1 => ZEll.ntriple (z2Z x1) (z2Z y1) (z2Z z1)
  end.

Definition wft t :=  z2Z t = (z2Z t) mod (z2Z zN).

Lemma vN_pos: 0 < (Zpos exx.(vN)).
red; simpl; auto.
Qed.

Hint Resolve vN_pos.

Lemma nplusz: forall x y, wft x -> wft y ->
      z2Z (x +++ y) = ZEll.nplus (Zpos (vN exx)) (z2Z x) (z2Z y).
Proof.
intros x y Hx Hy.
unfold z2Z, nplus.
rewrite (mop_spec.(add_mod_spec) _ _ _ _ Hx Hy); auto.
rewrite <- z2ZN; auto.
Qed.

Lemma nplusw: forall x y, wft x -> wft y ->  wft (x +++ y).
Proof.
intros x y Hx Hy.
unfold wft.
pattern (z2Z (x +++ y)) at 2; rewrite (nplusz Hx Hy).
unfold ZEll.nplus; rewrite z2ZN.
rewrite Zmod_mod; auto.
apply (nplusz Hx Hy).
Qed.

Lemma nsubz: forall x y, wft x -> wft y ->
      z2Z (x -- y) = ZEll.nsub (Zpos (vN exx)) (z2Z x) (z2Z y).
Proof.
intros x y Hx Hy.
unfold z2Z, nsub.
rewrite (mop_spec.(sub_mod_spec) _ _ _ _ Hx Hy); auto.
rewrite <- z2ZN; auto.
Qed.

Lemma nsubw: forall x y, wft x -> wft y ->  wft (x -- y).
Proof.
intros x y Hx Hy.
unfold wft.
pattern (z2Z (x -- y)) at 2; rewrite (nsubz Hx Hy).
unfold ZEll.nsub; rewrite z2ZN.
rewrite Zmod_mod; auto.
apply (nsubz Hx Hy).
Qed.

Lemma nmulz: forall x y, wft x -> wft y ->
      z2Z (x ** y) = ZEll.nmul (Zpos (vN exx)) (z2Z x) (z2Z y).
Proof.
intros x y Hx Hy.
unfold z2Z, nmul.
rewrite (mop_spec.(mul_mod_spec) _ _ _ _ Hx Hy); auto.
rewrite <- z2ZN; auto.
Qed.

Lemma nmulw: forall x y, wft x -> wft y ->  wft (x ** y).
Proof.
intros x y Hx Hy.
unfold wft.
pattern (z2Z (x ** y)) at 2; rewrite (nmulz Hx Hy).
unfold ZEll.nmul; rewrite z2ZN.
rewrite Zmod_mod; auto.
apply (nmulz Hx Hy).
Qed.

Hint Resolve nmulw nplusw nsubw.

Definition wfe p := match p with
  ntriple x y z => wft x /\ wft y /\ wft z
| _ => True
end.

Lemma z2Zx: forall x, z2Z (Z2z x) = x mod (Zpos exx.(vN)).
unfold Z2z; intros x.
generalize (Z_mod_lt x (Zpos exx.(vN))).
case_eq (x mod (Zpos exx.(vN))).
intros _ _.
simpl; unfold z2Z; rewrite op_spec.(spec_0); auto.
intros p Hp HH; case HH; auto with zarith; clear HH.
intros _ HH1.
case (op_spec.(spec_to_Z) zN).
generalize  z2ZN; unfold z2Z; intros HH; rewrite HH; auto.
intros _ H0.
set (v := znz_of_pos op p); generalize HH1.
rewrite (op_spec.(spec_of_pos) p); fold v.
case (fst v).
  simpl; auto.
intros p1 H1.
contradict H0; apply Zle_not_lt.
apply Zlt_le_weak; apply Zle_lt_trans with (2:= H1).
apply Zle_trans with (1 * base (znz_digits op) + 0); auto with zarith.
apply Zplus_le_compat; auto.
apply Zmult_gt_0_le_compat_r; auto with zarith.
  case (op_spec.(spec_to_Z) (snd v)); auto with zarith.
  case p1; red; simpl; intros; discriminate.
  case (op_spec.(spec_to_Z) (snd v)); auto with zarith.
intros p Hp; case (Z_mod_lt x (Zpos exx.(vN))); auto with zarith.
rewrite Hp; intros HH; case HH; auto.
Qed.

Lemma z2Zx1: forall x, z2Z (Z2z x) = z2Z (Z2z x) mod z2Z zN.
Proof.
unfold Z2z; intros x.
generalize (Z_mod_lt x (Zpos exx.(vN))).
case_eq (x mod (Zpos exx.(vN))).
intros _ _.
simpl; unfold z2Z; rewrite op_spec.(spec_0).
rewrite Zmod_small; split; auto with zarith.
generalize  z2ZN; unfold z2Z; intros HH; rewrite HH; auto.
intros p H1 H2.
case (op_spec.(spec_to_Z) zN).
generalize  z2ZN; unfold z2Z; intros HH; rewrite HH; auto.
intros _ H0.
case H2; auto with zarith; clear H2; intros _ H2.
rewrite Zmod_small; auto.
set (v := znz_of_pos op p).
split.
  case (op_spec.(spec_to_Z) (snd v)); auto.
generalize H2; rewrite (op_spec.(spec_of_pos) p); fold v.
case (fst v).
  simpl; auto.
intros p1 H.
contradict H0; apply Zle_not_lt.
apply Zlt_le_weak; apply Zle_lt_trans with (2:= H).
apply Zle_trans with (1 * base (znz_digits op) + 0); auto with zarith.
apply Zplus_le_compat; auto.
apply Zmult_gt_0_le_compat_r; auto with zarith.
  case (op_spec.(spec_to_Z) (snd v)); auto with zarith.
  case p1; red; simpl; intros; discriminate.
  case (op_spec.(spec_to_Z) (snd v)); auto with zarith.
intros p Hp; case (Z_mod_lt x (Zpos exx.(vN))); auto with zarith.
rewrite Hp; intros HH; case HH; auto.
Qed.

Lemma c0w: wft c0.
Proof.
red; unfold c0; apply z2Zx1.
Qed.

Lemma c2w: wft c2.
Proof.
red; unfold c2; apply z2Zx1.
Qed.

Lemma c3w: wft c3.
Proof.
red; unfold c3; apply z2Zx1.
Qed.

Lemma Aw: wft A.
Proof.
red; unfold A; apply z2Zx1.
Qed.

Hint Resolve c0w c2w c3w Aw.

Ltac nw :=
  repeat (apply nplusw || apply nsubw || apply nmulw || apply c2w ||
          apply c3w || apply Aw); auto.

Lemma nadd_wf: forall x y sc,
  wfe x -> wfe y -> wft sc ->
  wfe (fst (nadd sc x y)) /\  wft (snd (nadd sc x y)).
Proof.
intros x; case x; clear; auto.
intros x1 y1 z1 y; case y; clear; auto.
  intros x2 y2 z2 sc (wfx1,(wfy1, wfz1)) (wfx2,(wfy2, wfz2)) wfsc;
    simpl; auto.
  repeat (case neq; repeat split; simpl; nw; auto).
Qed.

 Lemma ztest: forall x y,
     x ?= y =Zeq_bool (z2Z x) (z2Z y).
 Proof.
 intros x y; generalize (op_spec.(spec_compare) x y);
   unfold neq; case znz_compare; intros H.
 symmetry; apply GZnZ.Zeq_iok; auto.
 case_eq (Zeq_bool (z2Z x) (z2Z y)); intros H1; auto;
   generalize H; generalize (Zeq_bool_eq _ _ H1); unfold z2Z;
   intros HH; rewrite HH; auto with zarith.
 case_eq (Zeq_bool (z2Z x) (z2Z y)); intros H1; auto;
   generalize H; generalize (Zeq_bool_eq _ _ H1); unfold z2Z;
   intros HH; rewrite HH; auto with zarith.
 Qed.

 Lemma zc0: z2Z c0 = 0.
 Proof.
 unfold z2Z, c0, z2Z; simpl.
 generalize op_spec.(spec_0); auto.
 Qed.

Ltac iftac t :=
  match t with
   context[if ?x ?= ?y then _ else _] =>
      case_eq (x ?= y)
  end.

Ltac ftac := match goal with
  |- context[?x = ?y] => (iftac x);
    let H := fresh "tmp" in
     (try rewrite ztest; try rewrite zc0; intros H;
      repeat ((rewrite nmulz in H || rewrite nplusz in H || rewrite nsubz in H); auto);
      try (rewrite H; clear H))
    end.

Require Import Zmod.

Lemma c2ww: forall x, ZEll.nmul (Zpos (vN exx)) 2 x = ZEll.nmul (Zpos (vN exx)) (z2Z c2) x.
intros x; unfold ZEll.nmul.
unfold c2; rewrite z2Zx; rewrite Zmodml; auto.
Qed.

Lemma c3ww: forall x, ZEll.nmul (Zpos (vN exx)) 3 x = ZEll.nmul (Zpos (vN exx)) (z2Z c3) x.
intros x; unfold ZEll.nmul.
unfold c3; rewrite z2Zx; rewrite Zmodml; auto.
Qed.

Lemma Aww: forall x, ZEll.nmul (Zpos (vN exx)) exx.(vA) x = ZEll.nmul (Zpos (vN exx)) (z2Z A) x.
intros x; unfold ZEll.nmul.
unfold A; rewrite z2Zx; rewrite Zmodml; auto.
Qed.

Lemma nadd_correct: forall x y sc,
  wfe x -> wfe y -> wft sc ->
  e2E (fst (nadd sc x y)) = fst (ZEll.nadd (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) (e2E y) )/\
  z2Z (snd (nadd sc x y)) = snd (ZEll.nadd (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) (e2E y)).
Proof.
intros x; case x; clear; auto.
intros x1 y1 z1 y; case y; clear; auto.
  intros x2 y2 z2 sc (wfx1,(wfy1, wfz1)) (wfx2,(wfy2, wfz2)) wfsc; simpl.
  ftac.
  ftac.
  ftac.
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz); auto).
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz||
           rewrite c2ww || rewrite c3ww || rewrite Aww); try nw; auto).
  rewrite nmulz; auto.
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz); auto).
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz ||
           rewrite c2ww || rewrite c3ww || rewrite Aww); try nw; auto).
  Qed.

 Lemma ndouble_wf: forall x sc,
  wfe x -> wft sc ->
  wfe (fst (ndouble sc x)) /\  wft (snd (ndouble sc x)).
Proof.
intros x; case x; clear; auto.
intros x1 y1 z1 sc (wfx1,(wfy1, wfz1)) wfsc;
    simpl; auto.
  repeat (case neq; repeat split; simpl; nw; auto).
Qed.

Lemma ndouble_correct: forall x sc,
  wfe x -> wft sc ->
  e2E (fst (ndouble sc x)) = fst (ZEll.ndouble (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x))/\
  z2Z (snd (ndouble sc x)) = snd (ZEll.ndouble (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x)).
Proof.
intros x; case x; clear; auto.
  intros x1 y1 z1 sc (wfx1,(wfy1, wfz1))  wfsc; simpl.
  ftac.
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz); auto).
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz ||
           rewrite c2ww || rewrite c3ww || rewrite Aww); try nw; auto).
  Qed.

Lemma nopp_wf: forall x, wfe x -> wfe (nopp x).
Proof.
intros x; case x; simpl nopp; auto.
intros x1 y1 z1 [H1 [H2 H3]]; repeat split; auto.
Qed.

Lemma scalb_wf: forall n b x sc,
  wfe x -> wft sc ->
  wfe (fst (scalb sc b x n)) /\  wft (snd (scalb sc b x n)).
Proof.
intros n; elim n; unfold scalb; fold scalb; auto.
  intros n1 Hrec b x sc H H1.
    case (Hrec true x sc H H1).
    case scalb; simpl fst; simpl snd.
    intros a1 sc1 H2 H3.
    case (ndouble_wf _ H2 H3); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
    case b; auto.
    case (nadd_wf _ _ (nopp_wf _ H) H4 H5); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
  intros n1 Hrec b x sc H H1.
    case (Hrec false x sc H H1).
    case scalb; simpl fst; simpl snd.
    intros a1 sc1 H2 H3.
    case (ndouble_wf _ H2 H3); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
    case b; auto.
    case (nadd_wf _ _ H H4 H5); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
intros b x sc H H1; case b; auto.
case (ndouble_wf _ H H1); auto.
Qed.

Lemma scal_wf: forall n x sc,
  wfe x -> wft sc ->
  wfe (fst (scal sc x n)) /\  wft (snd (scal sc x n)).
Proof.
intros n; exact (scalb_wf n false).
Qed.

Lemma nopp_correct: forall x,
  wfe x -> e2E x = ZEll.nopp (Zpos exx.(vN)) (e2E (nopp x)).
Proof.
intros x; case x; simpl; auto.
intros x1 y1 z1 [H1 [H2 H3]]; apply f_equal3 with (f := ZEll.ntriple); auto.
rewrite nsubz; auto.
rewrite zc0.
unfold ZEll.nsub, ninv; simpl.
apply sym_equal.
rewrite <- (Z_mod_plus) with (b := -(-z2Z y1 / (Zpos exx.(vN)))); auto with zarith.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zopp_plus_distr.
rewrite Zmult_comm; rewrite Zplus_comm.
rewrite <- Z_div_mod_eq; auto with zarith.
rewrite Zopp_involutive; rewrite <- z2ZN.
apply sym_equal; auto.
Qed.

Lemma scalb_correct: forall n b x sc,
  wfe x -> wft sc ->
  e2E (fst (scalb sc b x n)) = fst (ZEll.scalb (Zpos exx.(vN)) exx.(vA) (z2Z sc) b (e2E x) n)/\
  z2Z (snd (scalb sc b x n)) = snd (ZEll.scalb (Zpos exx.(vN)) exx.(vA) (z2Z sc) b (e2E x) n).
Proof.
intros n; elim n; clear; auto.
intros p Hrec b x sc H1 H2.
  case b; unfold scalb; fold scalb.
    generalize (scalb_wf p true x H1 H2);
    generalize (Hrec true _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    apply ndouble_correct; auto.
    generalize (scalb_wf p true x H1 H2);
    generalize (Hrec true _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    generalize (ndouble_wf _ H5 H6);
      generalize (ndouble_correct _ H5 H6); case ndouble; simpl.
    case ZEll.ndouble; intros r1 rc1; simpl.
    intros a3 sc3 (H7,H8) (H9,H10); subst r1 rc1.
    replace (ZEll.nopp (Zpos (vN exx)) (e2E x)) with
      (e2E (nopp x)).
    apply nadd_correct; auto.
    generalize H1; case x; auto.
    intros x1 y1 z1 [HH1 [HH2 HH3]]; split; auto.
    rewrite nopp_correct; auto.
    apply f_equal2 with (f := ZEll.nopp); auto.
    generalize H1; case x; simpl; auto; clear x H1.
    intros x1 y1 z1 [HH1 [HH2 HH3]];
      apply f_equal3 with (f := ZEll.ntriple); auto.
    repeat rewrite nsubz; auto.
    rewrite zc0.
    unfold ZEll.nsub; simpl.
    rewrite <- (Z_mod_plus) with (b := -(-z2Z y1 / (Zpos exx.(vN)))); auto with zarith.
    rewrite <- Zopp_mult_distr_l.
    rewrite <- Zopp_plus_distr.
    rewrite Zmult_comm; rewrite Zplus_comm.
    rewrite <- Z_div_mod_eq; auto with zarith.
    rewrite Zopp_involutive; rewrite <- z2ZN.
    apply sym_equal; auto.
    generalize H1; case x; auto.
    intros x1 y1 z1 [HH1 [HH2 HH3]]; split; auto.
intros p Hrec b x sc H1 H2.
  case b; unfold scalb; fold scalb.
    generalize (scalb_wf p false x H1 H2);
    generalize (Hrec false _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    generalize (ndouble_wf _ H5 H6);
      generalize (ndouble_correct _ H5 H6); case ndouble; simpl.
    case ZEll.ndouble; intros r1 rc1; simpl.
    intros a3 sc3 (H7,H8) (H9,H10); subst r1 rc1.
    replace (ZEll.nopp (Zpos (vN exx)) (e2E x)) with
      (e2E (nopp x)).
    apply nadd_correct; auto.
    rewrite nopp_correct; auto.
    apply f_equal2 with (f := ZEll.nopp); auto.
    generalize H1; case x; simpl; auto; clear x H1.
    intros x1 y1 z1 [HH1 [HH2 HH3]];
      apply f_equal3 with (f := ZEll.ntriple); auto.
    repeat rewrite nsubz; auto.
    rewrite zc0.
    unfold ZEll.nsub; simpl.
    rewrite <- (Z_mod_plus) with (b := -(-z2Z y1 / (Zpos exx.(vN)))); auto with zarith.
    rewrite <- Zopp_mult_distr_l.
    rewrite <- Zopp_plus_distr.
    rewrite Zmult_comm; rewrite Zplus_comm.
    rewrite <- Z_div_mod_eq; auto with zarith.
    rewrite Zopp_involutive; rewrite <- z2ZN.
    apply sym_equal; auto.
    generalize H1; case x; auto.
    intros x1 y1 z1 [HH1 [HH2 HH3]]; split; auto.
    generalize (scalb_wf p false x H1 H2);
    generalize (Hrec false _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    apply ndouble_correct; auto.
intros b x sc H H1.
case b; simpl; auto.
apply ndouble_correct; auto.
Qed.

Lemma scal_correct: forall n x sc,
  wfe x -> wft sc ->
  e2E (fst (scal sc x n)) = fst (ZEll.scal (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) n)/\
  z2Z (snd (scal sc x n)) = snd (ZEll.scal (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) n).
Proof.
intros n; exact (scalb_correct n false).
Qed.

Lemma scal_list_correct: forall l x sc,
  wfe x -> wft sc ->
  e2E (fst (scal_list sc x l)) = fst (ZEll.scal_list (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) l)/\
  z2Z (snd (scal_list sc x l)) = snd (ZEll.scal_list (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) l).
Proof.
intros l1; elim l1; simpl; auto.
unfold scal_list, ZEll.scal_list; simpl; intros a l2 Hrec x sc H1 H2.
generalize (scal_correct a _ H1 H2) (scal_wf a _ H1 H2); case scal.
case ZEll.scal; intros r1 rsc1; simpl.
simpl; intros a1 sc1 (H3, H4) (H5, H6); subst r1 rsc1; auto.
Qed.

Lemma scal_list_wf: forall l x sc,
  wfe x -> wft sc ->
  wfe (fst (scal_list sc x l)) /\  wft (snd (scal_list sc x l)).
Proof.
intros l1; elim l1; simpl; auto.
unfold scal_list; intros a l Hrec x sc H1 H2; simpl.
generalize (@scal_wf a _ _ H1 H2);
  case (scal sc x a); simpl; intros x1 sc1 [H3 H4]; auto.
Qed.

Lemma scalL_wf: forall l x sc,
  wfe x -> wft sc ->
  wfe (fst (scalL sc x l)) /\  wft (snd (scalL sc x l)).
Proof.
intros l1; elim l1; simpl; auto.
intros a l2 Hrec x sc H1 H2.
generalize (scal_wf a _ H1 H2); case scal; simpl.
intros a1 sc1 (H3, H4); auto.
generalize (scal_list_wf l2 _ H1 H4); case scal_list; simpl.
intros a2 sc2; case a2; simpl; auto.
intros x1 y1 z1 ((V1, (V2, V3)), V4); apply Hrec; auto.
Qed.

Lemma scalL_correct: forall l x sc,
  wfe x -> wft sc ->
  e2E (fst (scalL sc x l)) = fst (ZEll.scalL (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) l)/\
  z2Z (snd (scalL sc x l)) = snd (ZEll.scalL (Zpos exx.(vN)) exx.(vA) (z2Z sc) (e2E x) l).
Proof.
intros l1; elim l1; simpl; auto.
intros a l2 Hrec x sc H1 H2.
generalize (scal_wf a _ H1 H2) (scal_correct a _ H1 H2); case scal; simpl.
case ZEll.scal; intros r1 rsc1; simpl.
intros a1 sc1 (H3, H4) (H5, H6); subst r1 rsc1.
generalize (scal_list_wf l2 _ H1 H4) (scal_list_correct l2 _ H1 H4); case scal_list; simpl.
case ZEll.scal_list; intros r1 rsc1; simpl.
intros a2 sc2 (H7, H8) (H9, H10); subst r1 rsc1.
generalize H7; clear H7; case a2; simpl; auto.
rewrite zc0; auto.
intros x1 y1 z1 (V1, (V2, V3)); auto.
generalize (nmulw H8 V3) (nmulz H8 V3); intros V4 V5; rewrite <- V5.
apply Hrec; auto.
Qed.

Lemma f4 : wft (Z2z 4).
Proof.
red; apply z2Zx1.
Qed.

Lemma f27 : wft (Z2z 27).
Proof.
red; apply z2Zx1.
Qed.

Lemma Bw : wft B.
Proof.
red; unfold B; apply z2Zx1.
Qed.

Hint Resolve f4 f27 Bw.

Lemma mww: forall x y, ZEll.nmul (Zpos (vN exx)) (x mod (Zpos (vN exx)) ) y = ZEll.nmul (Zpos (vN exx)) x y.
intros x  y; unfold ZEll.nmul; rewrite Zmodml; auto.
Qed.

Lemma wwA: forall x, ZEll.nmul (Zpos (vN exx)) x exx.(vA) = ZEll.nmul (Zpos (vN exx)) x (z2Z A).
intros x; unfold ZEll.nmul.
unfold A; rewrite z2Zx; rewrite Zmodmr; auto.
Qed.

Lemma wwB: forall x, ZEll.nmul (Zpos (vN exx)) x exx.(vB) = ZEll.nmul (Zpos (vN exx)) x (z2Z B).
intros x; unfold ZEll.nmul.
unfold B; rewrite z2Zx; rewrite Zmodmr; auto.
Qed.

 Lemma  scalL_prime:
  let a := ntriple (Z2z (exx.(vx))) (Z2z (exx.(vy))) c1 in
  let isc := (Z2z 4) ** A ** A ** A  +++ (Z2z 27) ** B ** B in
  let (a1, sc1) := scal isc a exx.(vS) in
  let (S1,R1) := psplit exx.(vR) in
  let (a2, sc2) := scal sc1 a1 S1 in
  let (a3, sc3) := scalL sc2 a2 R1 in
    match a3 with
     nzero => if (Zeq_bool (Zgcd (z2Z sc3) (Zpos exx.(vN))) 1) then prime (Zpos exx.(vN))
              else True
   | _ => True
   end.
  Proof.
  intros a isc.
  case_eq (scal isc a (vS exx)); intros a1 sc1 Ha1.
  case_eq (psplit (vR exx)); intros S1 R1 HS1.
  case_eq (scal sc1 a1 S1); intros a2 sc2 Ha2.
  case_eq (scalL sc2 a2 R1); intros a3 sc3; case a3; auto.
  intros Ha3; case_eq (Zeq_bool (Zgcd (z2Z sc3) (Zpos (vN exx))) 1); auto.
  intros H1.
  assert (F0:
     (vy exx mod (Zpos (vN exx))) ^ 2 mod (Zpos (vN exx)) =
       ((vx exx mod (Zpos (vN exx))) ^ 3 + vA exx * (vx exx mod (Zpos (vN exx))) +
        vB exx) mod (Zpos (vN exx))).
      generalize exxs.(inC).
      simpl; unfold Zpower_pos; simpl.
      repeat rewrite Zmult_1_r.
      intros HH.
      match goal with |- ?t1 = ?t2 => rmod t1; auto end.
      rewrite HH.
      rewrite Zplus_mod; auto; symmetry; rewrite Zplus_mod; auto; symmetry.
      apply f_equal2 with (f := Zmod); auto.
      apply f_equal2 with (f := Zplus); auto.
      rewrite Zplus_mod; auto; symmetry; rewrite Zplus_mod; auto; symmetry.
      apply f_equal2 with (f := Zmod); auto.
      apply f_equal2 with (f := Zplus); auto.
      rewrite Zmult_mod; auto; symmetry; rewrite Zmult_mod; auto; symmetry.
      apply f_equal2 with (f := Zmod); auto.
      apply f_equal2 with (f := Zmult); auto.
      rewrite Zmod_mod; auto.
      match goal with |- ?t1 = ?t2 => rmod t2; auto end.
      rewrite Zmult_mod; auto; symmetry; rewrite Zmult_mod; auto; symmetry.
      apply f_equal2 with (f := Zmod); auto.
      rewrite Zmod_mod; auto.
   generalize (@ZEll.scalL_prime (Zpos exx.(vN))
               (exx.(vx) mod (Zpos exx.(vN)))
               (exx.(vy) mod (Zpos exx.(vN)))
               exx.(vA)
               exx.(vB)
               exxs.(n_pos) exxs.(n2_div) exx.(vR)
               exxs.(lprime) exx.(vS) exxs.(lbig) F0); simpl.
generalize (@scal_wf (vS exx) a isc) (@scal_correct (vS exx) a isc).
unfold isc.
rewrite nplusz; auto; try nw; auto.
repeat rewrite nmulz; auto; try nw; auto.
  repeat rewrite z2Zx.
repeat rewrite wwA || rewrite wwB|| rewrite mww.
replace (e2E a) with (ZEll.ntriple (vx exx mod (Zpos (vN exx))) (vy exx mod (Zpos (vN exx))) 1).
case ZEll.scal.
fold isc; rewrite HS1; rewrite Ha1; simpl; auto.
intros r1 rsc1 HH1 HH2.
case HH1; clear HH1.
  unfold c1; repeat split; red; try apply z2Zx1.
  unfold isc; nw.
case HH2; clear HH2.
  unfold c1; repeat split; red; try apply z2Zx1.
  unfold isc; nw.
intros U1 U2 W1 W2; subst r1 rsc1.
generalize (@scal_wf S1 a1 sc1) (@scal_correct S1 a1 sc1).
case ZEll.scal.
intros r1 rsc1 HH1 HH2.
case HH1; clear HH1; auto.
case HH2; clear HH2; auto.
rewrite Ha2; simpl.
intros U1 U2 W3 W4; subst r1 rsc1.
generalize (@scalL_wf R1 a2 sc2) (@scalL_correct R1 a2 sc2).
case ZEll.scalL.
intros n; case n; auto.
rewrite Ha3; simpl.
intros rsc1 HH1 HH2.
case HH1; clear HH1; auto.
case HH2; clear HH2; auto.
intros _ U2 _ W5; subst rsc1.
rewrite H1; auto.
intros x1 y1 z1 sc4; rewrite Ha3; simpl; auto.
intros _ HH; case HH; auto.
intros; discriminate.
unfold a; simpl.
unfold c1; repeat rewrite z2Zx.
rewrite (Zmod_small 1); auto.
generalize exxs.(n_pos).
auto with zarith.
Qed.

End NEll.

Fixpoint plength (p: positive) : positive :=
  match p with
    xH => xH
  | xO p1 => Psucc (plength p1)
  | xI p1 => Psucc (plength p1)
  end.

Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z.
assert (F: (forall p, 2 ^ (Zpos (Psucc p)) = 2 * 2 ^ Zpos p)%Z).
intros p; replace (Zpos (Psucc p)) with (1 + Zpos p)%Z.
rewrite Zpower_exp; auto with zarith.
rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
intros p; elim p; simpl plength; auto.
intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI.
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1).
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
rewrite Zpower_1_r; auto with zarith.
Qed.

Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Ppred p)))
%Z.
intros p; case (Psucc_pred p); intros H1.
subst; simpl plength.
rewrite Zpower_1_r; auto with zarith.
pattern p at 1; rewrite <- H1.
rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith.
generalize (plength_correct (Ppred p)); auto with zarith.
Qed.

Definition pheight p := plength (Ppred (plength (Ppred p))).

Theorem pheight_correct: forall p, (Zpos p <= 2 ^ (2 ^ (Zpos (pheight p))))%Z.
intros p; apply Zle_trans with (1 := (plength_pred_correct p)).
apply Zpower_le_monotone; auto with zarith.
split; auto with zarith.
unfold pheight; apply plength_pred_correct.
Qed.

Definition isM2 p :=
  match p with
    xH   => false
|    xO _ => false
|     _ => true
end.

Lemma isM2_correct: forall p,
  if isM2 p then ~(2| Zpos p) /\ 2 < Zpos p else True.
Proof.
intros p; case p; simpl; auto; clear p.
intros p1; split; auto.
intros HH; inversion_clear HH.
  generalize H; rewrite Zmult_comm; simpl; case q; simpl;
    intros; discriminate.
case p1; red; simpl; auto.
Qed.

Definition ell_test (N S: positive) (l: List.list (positive * positive))
                      (A B x y: Z) :=
  let op := cmk_op (pred (nat_of_P (get_height 31 (plength N)))) in
  let mop := make_mod_op op (znz_of_Z op (Zpos N)) in
    if isM2 N then
    match (4 * (Zpos N)) ?= (Zpos (ZEll.Zmullp l) - 1) ^ 2  with
      Lt =>
       match y ^ 2 mod (Zpos N) ?= (x ^ 3 + A * x + B) mod (Zpos N) with
       Eq =>
          let ex := mkEx N S l A B x y in
          let a := ntriple (Z2z ex op x) (Z2z ex op y) (Z2z ex op 1)  in
          let A := (Z2z  ex op A) in
          let B := (Z2z  ex op B) in
          let d4 := (Z2z  ex op 4) in
          let d27 := (Z2z  ex op 27) in
          let da := mop.(add_mod) in
          let dm := mop.(mul_mod) in
          let isc := (da (dm (dm  (dm d4 A) A) A) (dm (dm d27 B) B)) in
          let (a1, sc1) := scal ex op mop isc a S in
          let (S1,R1) := ZEll.psplit l in
          let (a2, sc2) := scal ex op mop sc1 a1 S1 in
          let (a3, sc3) := scalL ex op mop sc2 a2 R1 in
          match a3 with
           nzero => if (Zeq_bool (Zgcd (z2Z op sc3) (Zpos N)) 1) then true
                    else false
          | _ => false
          end
      | _  => false
       end
    | _  => false
    end
    else false.

Lemma Zcompare_correct: forall x y,
  match x ?= y with Eq => x = y | Gt => x > y | Lt => x < y end.
Proof.
intros x y; unfold Zlt, Zgt; generalize (Zcompare_Eq_eq x y); case Zcompare; auto.
Qed.

Lemma ell_test_correct: forall (N S: positive) (l: List.list (positive * positive))
                      (A B x y: Z),
  (forall p, List.In p l -> prime (Zpos (fst p))) ->
  if ell_test N S l A B x y then prime (Zpos N) else True.
intros N S1 l A1 B1 x y H; unfold ell_test.
generalize (isM2_correct N); case isM2; auto.
intros (H1, H2).
match goal with |- context[?x ?= ?y] =>
  generalize (Zcompare_correct x y); case Zcompare; auto
end; intros H3.
match goal with |- context[?x ?= ?y] =>
  generalize (Zcompare_correct x y); case Zcompare; auto
end; intros H4.
set (n := pred (nat_of_P (get_height 31 (plength N)))).
set (op := cmk_op n).
set (mop := make_mod_op op (znz_of_Z op (Zpos N))).
set (exx := mkEx N S1 l A1 B1 x y).
set (op_spec := cmk_spec n).
assert (exxs: ex_spec exx).
  constructor; auto.
assert (H0: (Zpos N) < base (znz_digits op)).
  apply Zlt_le_trans with (1 := plength_correct N).
  unfold op, base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split; auto with zarith.
  generalize (get_height_correct 31 (plength N)); unfold n.
  set (p := plength N).
  replace (Z_of_nat (pred (nat_of_P (get_height 31 p)))) with
       ((Zpos (get_height 31 p) - 1) ); auto with zarith.
  rewrite pred_of_minus; rewrite inj_minus1; auto with zarith.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
  generalize (lt_O_nat_of_P (get_height 31 p)); auto with zarith.
assert (mspec: mod_spec op (zN exx op) mop).
  unfold mop; apply make_mod_spec; auto.
  rewrite znz_of_Z_correct; auto with zarith.
generalize (@scalL_prime exx exxs _ op (cmk_spec n) mop mspec H0).
lazy zeta.
unfold c1, A, B,  nplus, nmul;
  simpl exx.(vA); simpl exx.(vB); simpl exx.(vx); simpl exx.(vy);
  simpl exx.(vS); simpl exx.(vR); simpl exx.(vN).
case scal; intros a1 sc1.
case ZEll.psplit; intros S2 R2.
case scal; intros a2 sc2.
case scalL; intros a3 sc3.
case a3; auto.
case Zeq_bool; auto.
Qed.

Time Eval vm_compute in (ell_test
  329719147332060395689499
  8209062
  (List.cons (40165264598163841%positive,1%positive) List.nil)
  (-94080)
  9834496
  0
  3136).

Time Eval vm_compute in (ell_test
  1384435372850622112932804334308326689651568940268408537
  13077052794
  (List.cons (105867537178241517538435987563198410444088809%positive, 1%positive) List.nil)
  (-677530058123796416781392907869501000001421915645008494)
  0
  (-169382514530949104195348226967375250000355478911252124)
  1045670343788723904542107880373576189650857982445904291
).


(* entails_prim *)

Load CDS_primitives.
Open Scope sem_scope.

Axiom p_entails : prop -> prop -> Prop.
Infix "entails" := p_entails (at level 50) : sem_scope.
Definition p_equiv : prop -> prop -> Prop := fun p q : prop => (p entails q) /\ (q entails p).
Infix "≡" := p_equiv (at level 40) : sem_scope.

(* TODO: axiomatize this s.t. we entails, which will be a preorder, s.t. the propositional connectives form a boolean algebra *)
(* is everything in Preboolean_Axioms enough? *)
Section Preboolean_Axioms.
    (* "entails" is a preorder *)
    Axiom entail_refl   : forall p : prop, p entails p.
    Axiom entail_trans  : forall p q r : prop, (p entails q) -> (q entails r) -> (p entails r).

    (* "and" is a glb *)
    Axiom p_and_e1  : forall p q : prop, (p and q) entails p.
    Axiom p_and_e2  : forall p q : prop, (p and q) entails q.
    Axiom p_and_i   : forall p q r : prop, (p entails q) -> (p entails r) -> (p entails (q and r)).

    (* "or" is an lub *)
    Axiom p_or_e    : forall p q r : prop, (p entails r) -> (q entails r) -> ((p or q) entails r).
    Axiom p_or_i1   : forall p q : prop, p entails (p or q).
    Axiom p_or_i2   : forall p q : prop, q entails (p or q).

    (* "truth" and "falsity" are top and bottom, respectively *)
    Axiom truth_top     : forall p : prop, p entails truth.
    Axiom falsity_bot   : forall p : prop, falsity entails p.

    (* "implies" is a residual operator *)
    Axiom residual_law1 : forall p q r : prop, ((p and q) entails r) -> (p entails (q implies r)).
    Axiom residual_law2 : forall p q r : prop, (p entails (q implies r)) -> ((p and q) entails r).

    (* "iff" is bi-implication *)
    Axiom p_iff_e1  : forall p q : prop, (p iff q) entails (p implies q).
    Axiom p_iff_e2  : forall p q : prop, (p iff q) entails (q implies p).
    Axiom p_iff_i   : forall p q : prop, ((p implies q) and (q implies p)) entails (p iff q).

    (* "p_not" is complement *)
    Axiom p_not_comp    : forall p : prop, (p and (not p)) entails falsity. (* thus, provably, (not p) entails (p implies falsity) *)
    Axiom pif_p_not_p   : forall p : prop, (p implies falsity) entails (not p).
        (* can't actually prove this w/ everything else (as best I could tell) *)
    Axiom dne           : forall  : prop, (not (not p)) entails p.

    (* Quantifiers (for prop's only) TODO: generalize quantifiers over sense types *)
    Axiom p_forall_e    : forall (R : prop -> prop) (p : prop), (p_forall R) entails (R p).
    Axiom p_forall_i    : forall (R : prop -> prop) (p : prop), (forall q : prop, p entails (R q)) -> (p entails (p_forall R)).
    Axiom p_exists_e    : forall (R : prop -> prop) (p : prop), (forall q : prop, (R q) entails p) -> ((p_exists R) entails p).
    Axiom p_exists_i    : forall (R : prop -> prop) (p : prop), (R p) entails (p_exists R).

    (* non-degeneracy *)
    Axiom nondeg        : ~(truth entails falsity).
        (* no point in making it ~(truth ≡ falsity) since we already have 2 proofs of (falsity entails truth), don't need a third! *)

    (* equality axioms (for prop's only) TODO: generalize quantifiers over sense types *)
    (* does one of these follow from the other? *)
    Axiom eq_one    : forall p q : prop, ((p equals q) ≡ truth) \/ ((p equals q) ≡ falsity).
        (* for similar reasons as in nondeg, may just change this to (truth entails (p equals q)) \/ ((p equals q) entails falsity) *)
    Axiom eq_two    : forall p q : prop, ((p equals q) ≡ truth) <-> (p = q).
End Preboolean_Axioms.

(* Move into CDS_primitives? *)
Definition pset : Set := prop -> bool.
Section Ultra.
    Variable s : pset.

    Definition uc  : pset -> Prop := fun s : pset => forall p q : prop, ((s p) = true) -> (p entails q) -> ((s q) = true).
    Definition ac  : pset -> Prop := fun s : pset => forall p q : prop, ((s p) = true) -> ((s q) = true) -> ((s (p and q)) = true).
    Definition sai : pset -> Prop := fun s : pset => forall p   : prop, ((s p) = true) \/ ((s (not p)) = true).
    Definition cst : pset -> Prop := fun s : pset => (s falsity) = false.
    Definition ultrafilter : pset -> Prop := fun s : pset => (uc s) /\ (ac s) /\ (sai s) /\ (cst s).
        (* for the record, "/\" associates to the right, so this comes out as (uc s) /\ ((ac s) /\ ((sai s) /\ (cst s))) *)
End Ultra.
(* define world as the type of ultrafilters on props *)
Definition world : Set := {s : pset | ultrafilter s}.
Definition tv : prop -> world -> bool := fun (p : prop) (w : world) => proj1_sig w p.
Definition facts : world -> pset := fun w : world => proj1_sig w.
(* mappings from each world to each of the parts of the proof it is an ultrafilter *)
Definition upcl     : forall w : world, uc  (facts w)
    := sig_ind (fun w : world => uc  (facts w)) (fun (s : pset) (u : ultrafilter s) => proj1 u).
Definition ancl     : forall w : world, ac  (facts w)
    := sig_ind (fun w : world => ac  (facts w)) (fun (s : pset) (u : ultrafilter s) => proj1 (proj2 u)).
Definition stalis   : forall w : world, sai (facts w)
    := sig_ind (fun w : world => sai (facts w)) (fun (s : pset) (u : ultrafilter s) => proj1 (proj2 (proj2 u))).
Definition consist  : forall w : world, cst (facts w)
    := sig_ind (fun w : world => cst (facts w)) (fun (s : pset) (u : ultrafilter s) => proj2 (proj2 (proj2 u))).

Open Scope bool_scope.
Infix    "→"    := implb    (at level 50) : bool_scope.
Notation "¬ x"  := (negb x) (at level 50) : bool_scope.

Section bool_lemmas.
    Definition demorgish : forall s t : bool, ~((s = true) /\ (t = true)) -> ((s = false) \/ (t = false))
        :=  fun s : bool => bool_ind
                (fun t : bool => ~((s = true) /\ (t = true)) -> ((s = false) \/ (t = false)))
                (fun n : ~((s = true) /\ (true = true)) => or_introl
                    (bool_ind (fun b : bool => ~((b = true) /\ (true = true)) -> (b = false))
                        (fun m : ~((true = true) /\ (true = true)) => False_ind (true = false) (m (conj eq_refl eq_refl)))
                        (fun _  => eq_refl) s n))
                (fun _ => or_intror eq_refl).

    Definition sflortfltosntfl : forall s t : bool, ((s = false) \/ (t = false)) -> ((s && t) = false)
        := fun s t : bool => or_ind (fun c : s = false => f_equal  (fun b : bool =>  b && t) c)
                                    (fun d : t = false => bool_ind (fun b : bool => (b && t) = false) d eq_refl s).

    Definition tnf : true <> false := eq_ind true (fun c : bool => if c then True else False) I false.

    Definition sorttrtostrorttr : forall s t : bool, (s || t) = true -> ((s = true) \/ (t = true))
        := fun s t : bool => bool_ind   (fun b : bool => (b || t) = true -> (b = true) \/ (t = true))
                                        (fun e : true = true => or_introl e)
                                        (fun e : t = true => or_intror e) s.

    Definition nttof : forall s : bool, s <> true -> s = false
        := bool_ind (fun s : bool => (s <> true) -> s = false)
                    (fun n : true <> true => False_ind (true = false) (n eq_refl))
                    (fun _ : false <> true => eq_refl).

    Definition bnttont : forall s : bool, s <> true -> ¬s = true
        := bool_ind (fun s : bool => (s <> true) -> (¬s = true))
                    (fun n : true <> true => False_ind (false = true) (n eq_refl))
                    (fun _ : false <> true => eq_refl).

    Definition nftot : forall s : bool, s <> false -> s = true
        := bool_ind (fun s : bool => s <> false -> s = true) (fun _ => eq_refl)
            (fun n : false <> false => False_ind (false = true) (n eq_refl)).

    Definition randbool : forall b c : bool, ¬b = c -> b = ¬c
        := fun b c : bool => bool_ind (fun s : bool => ¬s = c -> s = ¬c)
                                (fun e : false = c => f_equal negb e) (fun e : true = c => f_equal negb e) b.

    Definition dubneg : forall b : bool, b = ¬(¬b) := bool_ind (fun b : bool => b = ¬(¬b)) eq_refl eq_refl.

    Definition sflottr2sittr : forall s t : bool, (¬s = true) \/ (t = true) -> (s→t) = true
        :=  fun s t : bool =>
            or_ind  (fun c : ¬s = true => f_equal (fun b : bool => b→t) (eq_trans (dubneg s) (f_equal negb c)))
                    (fun d : t = true => bool_ind (fun b : bool => (b→t) = true) d eq_refl s).
End bool_lemmas.

Section prop_lemmas.
    Definition pandcomm : forall p q : prop, (p and q) entails (q and p)
        := fun p q : prop => p_and_i (p and q) q p (p_and_e2 p q) (p_and_e1 p q).

    Definition propdist1a : forall p q r : prop, (p and (q or r)) entails ((p and q) or (p and r))
        := fun p q r : prop =>
            entail_trans (p and (q or r)) ((q or r) and p) ((p and q) or (p and r))
            (pandcomm p (q or r))
            (residual_law2 (q or r) p ((p and q) or (p and r))
                (p_or_e q r (p implies ((p and q) or (p and r)))
                    (residual_law1 q p ((p and q) or (p and r))
                        (entail_trans (q and p) (p and q) ((p and q) or (p and r)) (pandcomm q p) (p_or_i1 (p and q) (p and r))))
                    (residual_law1 r p ((p and q) or (p and r))
                        (entail_trans (r and p) (p and r) ((p and q) or (p and r)) (pandcomm r p) (p_or_i2 (p and q) (p and r)))))).

    Definition propdemo : forall p q : prop, ((not p) and (not q)) entails (not (p or q))
        := fun p q : prop =>
            entail_trans ((not p) and (not q)) ((p or q) implies falsity) (not (p or q))
                (residual_law1 ((not p) and (not q)) (p or q) falsity
                    (entail_trans (((not p) and (not q)) and (p or q))
                        ((((not p) and (not q)) and p) or (((not p) and (not q)) and q))
                        falsity (propdist1a ((not p) and (not q)) p q)
                        (p_or_e (((not p) and (not q)) and p) (((not p) and (not q)) and q) falsity
                           (entail_trans (((not p) and (not q)) and p) (p and (not p)) falsity
                                (p_and_i (((not p) and (not q)) and p) p (not p)
                                    (p_and_e2 ((not p) and (not q)) p)
                                    (entail_trans (((not p) and (not q)) and p) ((not p) and (not q)) (not p)
                                        (p_and_e1 ((not p) and (not q)) p)
                                        (p_and_e1 (not p) (not q))))
                                (p_not_comp p))
                            (entail_trans (((not p) and (not q)) and q) (q and (not q)) falsity
                                (p_and_i (((not p) and (not q)) and q) q (not q)
                                    (p_and_e2 ((not p) and (not q)) q)
                                    (entail_trans (((not p) and (not q)) and q) ((not p) and (not q)) (not q)
                                        (p_and_e1 ((not p) and (not q)) q)
                                        (p_and_e2 (not p) (not q))))
                                (p_not_comp q)))))
                (pif_p_not_p (p or q)).

    Definition disjcs : forall (p q : prop) (w : world), (tv (p or q) w) = false -> ((tv p w) = false) /\ ((tv q w) = false)
        :=  fun (p q : prop) (w : world) (e : (tv (p or q) w) = false) =>
            conj    (nttof (tv p w) (fun c : (tv p w) = true => tnf (eq_trans (eq_sym (upcl w p (p or q) c (p_or_i1 p q))) e)))
                    (nttof (tv q w) (fun c : (tv q w) = true => tnf (eq_trans (eq_sym (upcl w q (p or q) c (p_or_i2 p q))) e))).

    (* This is definitely not the most efficient way of proving this- gotta work on it *)
    (* should be in prop_thms, but mvngout depends on it *)
    Definition p_not_ax      : forall (p : prop) (w : world), (tv (not p) w) = ¬(tv p w)
        :=  fun (p : prop) (w : world) => or_ind
                (fun e : (tv p w) = true =>
                   eq_ind true (fun b : bool => (tv (not p) w) = ¬b)
                      (nttof (tv (not p) w)
                         (fun d : (tv (not p) w) = true =>
                            tnf (eq_trans   (eq_sym (upcl w (p and (not p)) falsity (ancl w p (not p) e d) (p_not_comp p)))
                                            (consist w))))
                      (tv p w) (eq_sym e))
                (fun e : (tv (not p) w) = true =>
                   eq_ind true (fun b : bool => b = ¬(tv p w))
                      (eq_sym (bnttont (tv p w)
                            (fun d : (tv p w) = true =>
                                tnf (eq_trans   (eq_sym (upcl w (p and (not p)) falsity (ancl w p (not p) d e) (p_not_comp p)))
                                                (consist w)))))
                      (tv (not p) w) (eq_sym e))
                (stalis w p).

    Definition mvngout : forall (p : prop) (w : world) (b : bool), (tv p w) = b -> (tv (not p) w) = ¬b
        := fun (p : prop) (w : world) (b : bool) (e : (tv p w) = b) => eq_trans (p_not_ax p w) (f_equal negb e).

    Definition pimplies_true : forall (p q : prop) (w : world), (tv (p implies q) w) = true -> ((tv p w) → (tv q w)) = true
        :=  fun (p q : prop) (w : world) (e : (tv (p implies q) w) = true) =>
            sflottr2sittr (tv p w) (tv q w)
                (or_ind (fun x : (tv (not p) w) = true => or_introl (eq_trans (eq_sym (p_not_ax p w)) x))
                        (fun y : (tv q w) = true => or_intror y)
                        (bool_ind
                            (fun b : bool => (tv q w) = b -> ((tv (not p) w) = true) \/ ((tv q w) = true))
                            (fun c : (tv q w) = true => or_intror c)
                            (fun d : (tv q w) = false =>
                                or_introl (or_ind
                                    (fun m : (tv p w) = true =>
                                        False_ind ((tv (not p) w) = true)
                                            (tnf (eq_trans (eq_sym (upcl w ((p implies q) and p) q
                                                                            (ancl w (p implies q) p e m)
                                                                            (residual_law2 (p implies q) p q
                                                                            (entail_refl (p implies q))))) d)))
                                      (fun n : (tv (not p) w) = true => n)
                                      (stalis w p)))
                            (tv q w) eq_refl)).

    Definition pimplies_false : forall (p q : prop) (w : world), (tv (p implies q) w) = false -> ((tv p w) → (tv q w)) = false
        :=  fun (p q : prop) (w : world) (e : (tv (p implies q) w) = false) =>
            f_equal2 implb
                (nftot (tv p w)
                     (fun c : (tv p w) = false =>
                        tnf (eq_trans
                                (eq_sym (upcl w (not p) (p implies q) (mvngout p w false c)
                                    (residual_law1 (not p) p q
                                        (entail_trans ((not p) and p) (p and (not p)) q
                                            (pandcomm (not p) p)
                                            (entail_trans (p and (not p)) falsity q (p_not_comp p) (falsity_bot q))))))
                                e)))
                (nttof (tv q w)
                     (fun d : (tv q w) = true =>
                        tnf (eq_trans (eq_sym (upcl w q (p implies q) d (residual_law1 q p q (p_and_e1 q p)))) e))).
End prop_lemmas.

(* potential plan: split these up into cases- ie ∀p,q,w.[(p and q)@w = true -> (p@w = true) /\ (q@w = true)], etc. *)
Section prop_thms.
    Definition p_and_ax      : forall (p q : prop) (w : world), (tv (p  and    q) w) = ((tv p w) && (tv q w))
        := fun (p q : prop) (w : world) =>
            eq_sym (bool_ind (fun b : bool => ((tv (p and q) w) = b) -> (((tv p w) && (tv q w)) = b))
                            (fun e : (tv (p and q) w) = true => f_equal2 andb   (upcl w (p and q) p e (p_and_e1 p q))
                                                                                (upcl w (p and q) q e (p_and_e2 p q)))
                            (fun e : tv (p and q) w = false => sflortfltosntfl (tv p w) (tv q w) (demorgish (tv p w) (tv q w)
                                (and_ind (fun (a : (tv p w) = true) (b : (tv q w) = true) =>
                                    tnf (eq_trans (eq_sym (ancl w p q a b)) e)))))
                            (tv (p and q) w) eq_refl).

    Definition p_or_ax : forall (p q : prop) (w : world), (tv (p or q) w) = ((tv p w) || (tv q w))
        := fun (p q : prop) (w : world) =>
            eq_sym (bool_ind (fun b : bool => (tv (p or q) w) = b -> ((tv p w) || (tv q w)) = b)
                    (fun e : (tv (p or q) w) = true =>
                        bool_ind (fun b : bool => (tv p w) = b -> (b || (tv q w)) = true) (fun _ => eq_refl)
                            (fun c : (tv p w) = false =>
                                nftot (tv q w)
                                    (fun d : (tv q w) = false =>
                                        tnf (eq_trans (eq_sym e)
                                                (randbool (tv (p or q) w) true
                                                    (eq_trans (eq_sym (p_not_ax (p or q) w))
                                                        (upcl w ((not p) and (not q)) (not (p or q))
                                                            (ancl w (not p) (not q) (mvngout p w false c) (mvngout q w false d))
                                                            (propdemo p q)))))))
                            (tv p w)
                            eq_refl)
                    (fun e : (tv (p or q) w) = false => and_ind (fun a b => f_equal2 orb a b) (disjcs p q w e))
                    (tv (p or q) w)
                    eq_refl).

    Definition p_implies_ax  : forall (p q : prop) (w : world), (tv (p implies q) w) = ((tv p w) →  (tv q w))
        := fun (p q : prop) (w : world) => eq_sym (bool_ind (fun b : bool => (tv (p implies q) w) = b -> ((tv p w) → (tv q w)) = b)
        (pimplies_true p q w) (pimplies_false p q w) (tv (p implies q) w) eq_refl).

    Definition truth_ax      : forall w : world, (tv truth w) = true
        := fun w : world =>
            or_ind  (fun e : (tv truth w) = true => e)
                    (fun e : (tv (not truth) w) = true =>
                       False_ind ((tv truth w) = true)
                         (tnf   (eq_trans
                                    (eq_sym (upcl w (not truth) falsity e
                                         (entail_trans (not truth) (truth and (not truth)) falsity
                                            (p_and_i (not truth) truth (not truth)
                                                (truth_top (not truth)) (entail_refl (not truth)))
                                            (p_not_comp truth))))
                                    (consist w))))
                    (stalis w truth).

    Definition falsity_ax    : forall w : world, (tv falsity w) = false := consist.

    (* This too will surely need a revision or two *)
    Definition p_iff_ax      : forall (p q : prop) (w : world), (tv (p iff q) w) = ((tv (p implies q) w) && (tv (q implies p) w))
        :=  fun (p q : prop) (w : world) => eq_sym
            (   let piq := p implies q in
                let qip := q implies p in
                bool_ind    (fun b : bool => (tv (p iff q) w) = b -> (tv piq w) && (tv qip w) = b)
                            (fun e : (tv (p iff q) w) = true =>
                                f_equal2 andb   (upcl w (p iff q) piq e (p_iff_e1 p q))
                                                (upcl w (p iff q) qip e (p_iff_e2 p q)))
                            (fun e : (tv (p iff q) w) = false =>
                                sflortfltosntfl (tv piq w) (tv qip w)
                                    (demorgish (tv piq w) (tv qip w)
                                        (and_ind (fun (a : (tv piq w) = true) (b : (tv qip w) = true) =>
                                            tnf (eq_trans   (eq_sym (upcl w (piq and qip) (p iff q) (ancl w piq qip a b) (p_iff_i p q)))
                                                            e)))))
                            (tv (p iff q) w) eq_refl).

    Definition p_equals_ax   : forall (p q : prop) (w : world), ((tv (p equals q) w) = true) <-> (p = q)
        :=  fun (p q : prop) (w : world) =>
            conj    (fun e : (tv (p equals q) w) = true =>
                        proj1 (eq_two p q)
                            (conj   (truth_top (p equals q))
                                    (or_ind (fun c : (p equals q) ≡ truth   => proj2 c)
                                            (fun d : (p equals q) ≡ falsity =>
                                                False_ind (truth entails (p equals q))
                                                    (tnf (eq_trans  (eq_sym (upcl w (p equals q) falsity e (proj1 d)))
                                                                    (consist w))))
                                            (eq_one p q))))
                    (fun e : p = q => upcl w truth (p equals q) (truth_ax w) (proj2 (proj2 (eq_two p q) e))).

    (* haven't gotten to these just yet *)
    (* Definition p_exists_ax   : forall (R : prop -> prop) (w : world),
                                ((tv (p_exists R) w) = true) <-> (exists p : prop, (tv (R p) w) = true). *)
    (* Definition p_forall_ax   : forall (R : prop -> prop) (w : world),
                                ((tv (p_forall R) w) = true) <-> (forall p : prop, (tv (R p) w) = true). *)

    Definition complement : forall (p : prop) (w : world), (tv (p and (not p)) w) = false
        := fun (p : prop) (w : world) =>
            nttof   (tv (p and (not p)) w)
                    (fun e : (tv (p and (not p)) w) = true =>
                        tnf (eq_trans (eq_sym (upcl w (p and (not p)) falsity e (p_not_comp p))) (consist w))).

    Definition lem : forall (p : prop) (w : world), (tv (p or (not p)) w) = true
        :=  fun (p : prop) (w : world) =>
            or_ind  (fun e : (tv p w) = true => upcl w p (p or (not p)) e (p_or_i1 p (not p)))
                    (fun e : (tv (not p) w) = true => upcl w (not p) (p or (not p)) e (p_or_i2 p (not p)))
                    (stalis w p).

    (* might have to assume this one- can't say w/o proof irrelevance that all proofs that s is an ultrafilter are equal
        (and in fact may not be, without assuming proof irrelevance) *)
    (* Definition fact_inj : forall w v : world, (facts w) = (facts v) -> w = v. *)

    Definition all_ultras_worlds : forall s : pset, (ultrafilter s) -> exists w : world, s = (facts w)
        := fun (s : pset) (u : ultrafilter s) => ex_intro (fun w : world => s = facts w) (exist ultrafilter s u) eq_refl.

    (* (in)equality at one world means (in)equality in all worlds *)
    Definition eqiseqev : forall (p q : prop) (w : world),
        (tv (p equals q) w) = true -> forall u : world, (tv (p equals q) u) = true
        := fun (p q : prop) (w : world) (e : (tv (p equals q) w) = true) (u : world) =>
                proj2 (p_equals_ax p q u) (proj1 (p_equals_ax p q w) e).

    Definition neqisneqev : forall (p q : prop) (w : world),
                                (tv (p equals q) w) = false -> forall v : world, (tv (p equals q) v) <> true
        :=  fun (p q : prop) (w : world) (e : (tv (p equals q) w) = false) (v : world) (c : (tv (p equals q) v) = true) =>
            tnf (eq_trans (eq_sym (eqiseqev p q v c w)) e).
End prop_thms.

(* "enough ultrafilters" axiom: ⊢∀p,q:prop.[~(p entails q) -> ∃u:p -> bool.[(ultrafilter u) /\ ((u p) = true) /\ ((u q) = false]] *)
(* aka: ⊢∀p,q:prop.[~(p entails q) -> ∃w:world.[((tv p w) = true) /\ ((tv q w) = false]] *)


Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Local Open Scope cat.

Declare Custom Entry obj.
Declare Custom Entry mor.

  Notation "| x |" := (x) (x custom obj).
  Notation "< x >" := (x) (x custom mor).
  Notation "| x |" := (identity x) (x custom obj, in custom mor).
  Notation "{ x }" := (x) (in custom obj, x constr).
  Notation "{ x }" := (x) (in custom mor, x constr).
  Notation "( x )" := (x) (in custom mor).
  Notation "x y" := (functor_on_objects x y)  (in custom obj at level 1, right associativity).
  Notation "x y" := (# x y)  (in custom mor at level 1, right associativity).
  Infix "·" := (compose)  (in custom mor at level 40, left associativity).
  Notation "x" := x (in custom obj at level 0, x global).
  Notation "x" := x (in custom mor at level 0, x global).

  Notation "{ x = y }" := (x = y) (x custom mor, y custom mor).

(* *************

This section consists of lemmas and tactics and notations to turn
a statement into something that the graph editor can parse.

Usage:
norm_graph.
Open Scope myscope.

********* *)
    Coercion identity' {C : category} (c : ob C) : precategory_morphisms c c := identity c.
    Check (fun c => identity' c).

Definition comp' {C : category}{a b c : ob C} : a --> b -> b --> c -> a --> c := @compose C a b c.
    Lemma add_id_left {C : category} {x y : C}(f g : x -->  y) :   comp' (identity _) f  = comp' (identity _) g -> f = g.
      unfold comp'.
      rewrite 2!id_left.
      apply idfun.
    Qed.

    Lemma comp'_comp {C : category}{x1 x2 x3 x4 : C}(a : x3 --> x4)
                        (b : x2  --> x3)
                        (c : x1  --> x2):
                         comp' c  (b · a) = comp' (comp' c b) a .
      unfold comp'.
      apply assoc.
    Qed.
    #[export] Hint Rewrite <- @functor_id : grapheditor.
    #[export] Hint Rewrite  @comp'_comp : grapheditor.
    Ltac norm_graph := apply add_id_left;  autorewrite with grapheditor;
                       change (identity ?x) with (identity' x).

  Notation " f -- g -> z" := (@comp' _ _ _ z f g )  (z custom obj, in custom mor at level 40, left associativity).
  (* Notation "d _{ X }" := (nat_trans_data_from_nat_trans_funclass d X)(d ident, X custom obj, in custom mor, *)
  (*                                                           format "d '_{' X '}'"). *)

  Ltac duplicate_goal :=
    let x := fresh in
    let y := fresh in
    let h := fresh in
    (unshelve refine (let x := _ in let y := _ in let h := x = y in x)).


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import Coq.Logic.ProofIrrelevance.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.
Require Import TRInductM2.
Require Import WeakM2.
Require Import TSoundnessM2.
Require Import IdModType.
Require Import IdMod2.
Require Import Hardware_Deep_v2.
Require Import Coq.Logic.EqdepFacts.

Module Hoare_Test <: IdModType.

Module HardwareC := Hardware IdModM2.
Export HardwareC.

Definition Id := HardwareC.Id.
Definition IdEqDec := HardwareC.IdEqDec.
Definition IdEq := HardwareC.IdEq.
Definition W := HardwareC.W.
Definition Loc_PI := HardwareC.Loc_PI.
Definition BInit := HardwareC.BInit.
Definition WP := HardwareC.WP.

(**************************************************)

Open Scope state_scope.

Definition xf_read : XFun unit W := {|
   b_mod := fun x _ => (x, x)
|}.

Definition xf_write : XFun W unit := {|
   b_mod := fun _ x => (x, tt)
|}.

Definition Read (VW: ValTyp W) : Exp :=
  Modify unit W UnitV VW xf_read (QV (cst unit tt)).

Definition Write (VW: ValTyp W) (x: nat) : Exp :=
  Modify W unit VW UnitV xf_write (QV (cst nat x)).

Definition ReadN : Exp := Read NatV.

Definition WriteN (x: nat) : Exp := Write NatV x.

(** 1 *)

Lemma write_nat_1 (P0: nat -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat):
  forall (s s': W) (e: Exp),
    EStep fenv env (Conf Exp s (WriteN x))
                      (Conf Exp s' e) ->
  P0 x -> P0 s'.
Proof.
intros s s' e H1 H2.
inversion H1; subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H9.
rewrite H7.
unfold b_exec.
unfold b_mod.
unfold xf_write.
simpl.
auto.
inversion X.
Qed.

Definition WriteNat1SHT (P0: nat -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: nat) :=
  HoareTriple_Step (fun _ => P0 x) (fun _ s => P0 s) fenv env (WriteN x).

Lemma write_nat_1_sht (P0: nat -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat):
  forall (s s': W) (e: Exp),
    WriteNat1SHT P0 fenv env x.
Proof.
intros s s' e.
unfold WriteNat1SHT.
unfold HoareTriple_Step.
apply write_nat_1.
Qed.

(** 2 *)

Lemma write_nat_2 (P0: nat -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat):
  forall (s s': W) (e: Exp),
    EStep fenv env (Conf Exp s (WriteN x))
                      (Conf Exp s' e) ->
  P0 x -> P0 s' /\ s' = x.
Proof.
intros s s' e H1 H2.
split.
eapply write_nat_1.
eauto. auto.
inversion H1;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7.
rewrite H9.
unfold b_exec.
unfold xf_write.
unfold b_mod.
simpl.
reflexivity.
inversion X.
Qed.

Definition WriteNat2SHT (P0: nat -> Prop)
                       (fenv: funEnv) (env: valEnv) (x: nat) :=
  HoareTriple_Step (fun _ => P0 x) (fun _ s => P0 s /\ s = x)
                   fenv env (WriteN x).

Lemma write_nat_2_sht (P0: nat -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat):
  forall (s s': W) (e: Exp),
    WriteNat2SHT P0 fenv env x.
intros s s' e.
unfold WriteNat2SHT.
unfold HoareTriple_Step.
apply write_nat_2.
Qed.

(** 3 *)

Lemma read_nat_1 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s ReadN)
             (Conf Exp s' (Val v)) ->
    P0 (cst nat s) -> P0 v.
Proof.
intros s s' v H1 H2.
inversion H1;subst.
inversion X;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7 in X.
rewrite H9 in X.
unfold xf_read in X.
unfold b_exec in X.
unfold b_eval in X.
unfold b_mod in X.
simpl in *.
rewrite H7 in X0.
rewrite H9 in X0.
unfold xf_read in X0.
unfold b_exec in X0.
unfold b_eval in X0.
unfold b_mod in X0.
simpl in *.
destruct v.
destruct v.
unfold cst in *.
inversion X0;subst.
apply inj_pair2 in H10.
eauto.
inversion X1;subst.
inversion X1.
Qed.

Definition ReadNat1SHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) :=
  HoareTriple_Step (fun s => P0 (cst nat s))
                   (fun e _ => forall v: Value,
                                 e = Val v -> P0 v) fenv env ReadN.

Definition ReadNat1VHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) :=
  HoareTriple_Eval (fun s => P0 (cst nat s))
                   (fun v _ => P0 v) fenv env ReadN.

(** 4 *)

Lemma read_nat_2 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s ReadN)
             (Conf Exp s' (Val v)) ->
    P0 (cst nat s) -> P0 v /\ v = (cst nat s').
Proof.
intros s s' v H1 H2.
eauto.
split.
eapply read_nat_1.
eauto. auto.
destruct v.
destruct v.
unfold cst in *.
inversion H1;subst.
inversion X;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7 in X.
rewrite H9 in X.
unfold xf_read in X.
unfold b_exec in X.
unfold b_eval in X.
unfold b_mod in X.
simpl in *.
rewrite H7 in X0.
rewrite H9 in X0.
unfold xf_read in X0.
unfold b_exec in X0.
unfold b_eval in X0.
unfold b_mod in X0.
simpl in *.
inversion X0;subst.
auto.
inversion X;subst.
inversion X1.
inversion X1.
Qed.

Definition ReadNat2SHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) :=
  HoareTriple_Step (fun s => P0 (cst nat s))
                   (fun e s => forall v: Value,
                          e = Val v -> P0 v /\ v = cst nat s) fenv env ReadN.

Definition ReadNat2VHT (P0: Value -> Prop)
                       (fenv: funEnv) (env: valEnv) :=
  HoareTriple_Eval (fun s => P0 (cst nat s))
                   (fun v s => P0 v /\ v = cst nat s) fenv env ReadN.

(** 5 *)

Lemma wread_nat_1 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s (BindN (WriteN x) ReadN))
                      (Conf Exp s' (Val v)) ->
  P0 (cst nat x) -> P0 v.
Proof.
intros s s' v H1 H2.
inversion H1;subst.
inversion X;subst.
inversion X1;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
rewrite H7 in X.
rewrite H9 in X.
unfold xf_write in X.
unfold b_exec in X.
unfold b_eval in X.
unfold b_mod in X.
simpl in *.
rewrite H7 in X0.
rewrite H9 in X0.
unfold xf_write in X0.
unfold b_exec in X0.
unfold b_eval in X0.
unfold b_mod in X0.
simpl in *.
rewrite H7 in X1.
rewrite H9 in X1.
unfold xf_write in X1.
unfold b_exec in X1.
unfold b_eval in X1.
unfold b_mod in X1.
simpl in *.
destruct v.
destruct v.
unfold cst in *.
inversion X0;subst.
inversion X2;subst.
inversion X3;subst.
inversion X4;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H10.
rewrite H7 in X5.
rewrite H10 in X5.
unfold b_exec in X5.
unfold b_eval in X5.
unfold xf_read in X5.
unfold b_mod in X5.
simpl in *.
rewrite H7 in X4.
rewrite H10 in X4.
unfold b_exec in X4.
unfold b_eval in X4.
unfold xf_read in X4.
unfold b_mod in X4.
simpl in *.
inversion X5;subst.
eauto.
inversion X6.
inversion X6.
inversion X4.
inversion X2.
Qed.

Definition WReadNat1EHT (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat) :=
  HoareTriple_ExtendedStep (fun _ => P0 (cst nat x))
                           (fun e _ => forall v: Value, e = Val v -> P0 v)
                           fenv env (BindN (WriteN x) ReadN).

Lemma wread_nat_1_eht (P0: Value -> Prop)
      (fenv: funEnv) (env: valEnv) (x: nat):
    WReadNat1EHT P0 fenv env x.
Proof.
unfold WReadNat1EHT.
unfold HoareTriple_ExtendedStep.
intros s s' e' H1 H2 v H3.
eapply wread_nat_1.
rewrite <- H3.
eauto. auto.
Qed.

Definition WReadNat1VHT (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat) :=
  HoareTriple_Eval (fun _ => P0 (cst nat x))
                    (fun v _ => P0 v)
                    fenv env (BindN (WriteN x) ReadN).

Lemma wread_nat_1_vht (P0: Value -> Prop)
      (fenv: funEnv) (env: valEnv) (x: nat):
    WReadNat1VHT P0 fenv env x.
Proof.
unfold WReadNat1VHT.
unfold HoareTriple_Eval.
eapply wread_nat_1.
Qed.

(** 6 *)

Lemma wread_nat_2 (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat):
  forall (s s': W) (v: Value),
    EClosure fenv env (Conf Exp s (BindN (WriteN x) ReadN))
                      (Conf Exp s' (Val v)) ->
  P0 (cst nat x) -> P0 v /\ x = s' /\ v = cst nat x.
Proof.
intros s s' v H1 H2.
split.
eapply wread_nat_1.
eauto. auto.
split.
-inversion H1;subst.
 inversion X;subst.
 inversion X1;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H9.
 rewrite H7 in X.
 rewrite H9 in X.
 unfold b_exec in X.
 unfold b_eval in X.
 unfold xf_write in X.
 unfold b_mod in X.
 simpl in *.
 rewrite H7 in X0.
 rewrite H9 in X0.
 unfold b_exec in X0.
 unfold b_eval in X0.
 unfold xf_write in X0.
 unfold b_mod in X0.
 simpl in *.
 rewrite H7 in X1.
 rewrite H9 in X1.
 unfold b_exec in X1.
 unfold b_eval in X1.
 unfold xf_write in X1.
 unfold b_mod in X1.
 simpl in *.
 inversion X0;subst.
 inversion X2;subst.
 inversion X3;subst.
 inversion X4;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H10.
 rewrite H7 in X5.
 rewrite H10 in X5.
 unfold b_exec in X5.
 unfold b_eval in X5.
 unfold xf_write in X5.
 unfold b_mod in X5.
 simpl in *.
 inversion X5;subst.
 auto.
 inversion X6.
 inversion X6.
 inversion X4.
 inversion X2.
-destruct v.
 destruct v.
 unfold cst in *.
 inversion H1;subst.
 inversion X;subst.
 inversion X1;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H9.
 rewrite H7 in X1.
 rewrite H9 in X1.
 unfold b_eval in X1.
 unfold b_exec in X1.
 unfold xf_write in X1.
 unfold b_mod in X1.
 simpl in *.
 rewrite H7 in X0.
 rewrite H9 in X0.
 unfold b_eval in X0.
 unfold b_exec in X0.
 unfold xf_write in X0.
 unfold b_mod in X0.
 simpl in *.
 rewrite H7 in X.
 rewrite H9 in X.
 unfold b_eval in X.
 unfold b_exec in X.
 unfold xf_write in X.
 unfold b_mod in X.
 simpl in *.
 inversion X1;subst.
 repeat apply inj_pair2 in H10.
 apply inj_pair2 in H12.
 apply inj_pair2 in H15.
 rewrite H10 in H1.
 unfold b_exec in H1.
 unfold xf_write in H1.
 unfold b_mod in H1.
 simpl in *.
 inversion H1;subst.
 inversion X2;subst.
 inversion X3;subst.
 inversion X4;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H10.
 rewrite H7 in X4.
 rewrite H10 in X4.
 unfold b_eval in X4.
 unfold b_exec in X4.
 unfold xf_write in X4.
 unfold b_mod in X4.
 simpl in *.
 rewrite H7 in X3.
 rewrite H10 in X3.
 unfold b_eval in X3.
 unfold b_exec in X3.
 unfold xf_write in X3.
 unfold b_mod in X3.
 simpl in *.
 rewrite H7 in X2.
 rewrite H10 in X2.
 unfold b_eval in X2.
 unfold b_exec in X2.
 unfold xf_write in X2.
 unfold b_mod in X2.
 simpl in *.
 inversion X5;subst.
 inversion X6;subst.
 inversion X7;subst.
 repeat apply inj_pair2 in H7.
 apply inj_pair2 in H13.
 rewrite H7 in X8.
 rewrite H13 in X8.
 unfold b_eval in X8.
 unfold b_exec in X8.
 unfold xf_write in X8.
 unfold xf_read in X8.
 unfold b_mod in X8.
 simpl in *.
 rewrite H7 in X7.
 rewrite H13 in X7.
 unfold b_eval in X7.
 unfold b_exec in X7.
 unfold xf_write in X7.
 unfold xf_read in X7.
 unfold b_mod in X7.
 simpl in *.
 inversion X8;subst.
 reflexivity.
 inversion X9;subst.
 inversion X9.
 inversion X7;subst.
 inversion X7.
 inversion X2.
Qed.

Definition WReadNat2VHT (P0: Value -> Prop)
           (fenv: funEnv) (env: valEnv) (x: nat) :=
  HoareTriple_Eval (fun _ => P0 (cst nat x))
                    (fun v s => P0 v /\ x = s /\ v = cst nat x)
                    fenv env (BindN (WriteN x) ReadN).

Lemma wread_nat_2_vht (P0: Value -> Prop)
      (fenv: funEnv) (env: valEnv) (x: nat):
    WReadNat2VHT P0 fenv env x.
Proof.
unfold WReadNat2VHT.
unfold HoareTriple_Eval.
eapply wread_nat_2.
Qed.

(** 7 *)

Lemma bindn_congruence1 (P: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e: Exp) :
    HoareTriple_Step P (fun _ => P) fenv env e ->
    forall e1: Exp,
       HoareTriple_Step P (fun _ => P) fenv env (BindN e e1).
Proof.
intros H1 e1.
unfold HoareTriple_Step.
intros s s' e' H2 H3.
unfold HoareTriple_Step in H1.
inversion H2;subst.
assumption.
eapply H1.
eauto.
assumption.
Qed.

Lemma bindn_congruence2 (P P1: W -> Prop)
      (fenv: funEnv) (env: valEnv) (e e': Exp) :
    HoareTriple_Step P (fun _ => P1) fenv env e ->
    (forall (e1: Exp) (v: Value),
       HoareTriple_Step P (fun _ => P1) fenv env (BindN (Val v) e1)) ->
    forall e1: Exp,
       HoareTriple_Step P (fun _ => P1) fenv env (BindN e e1).
Proof.
intros.
unfold HoareTriple_Step.
intros.
unfold HoareTriple_Step in H.
unfold HoareTriple_Step in H0.
inversion X;subst.
eapply H0.
eauto.
assumption.
eapply H.
eauto.
assumption.
Qed.

End Hoare_Test.


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

(** Base-2 Logarithm Properties *)

Require Import NAxioms NSub NPow NParity NZLog.

Module Type NLog2Prop
 (A : NAxiomsSig)
 (B : NSubProp A)
 (C : NParityProp A B)
 (D : NPowProp A B C).

 (** For the moment we simply reuse NZ properties *)

 Include NZLog2Prop A A A B D.NZPowP.
 Include NZLog2UpProp A A A B D.NZPowP.
End NLog2Prop.


(** * Composition of functors *)
Require Import Category.Core Functor.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.

Section composition.
  Variables B C D E : PreCategory.
  Variable G : Functor D E.
  Variable F : Functor C D.

  (** We usually don't want to see the proofs of composition in functors, because the proofs are hProps, and so we don't care about them.  But occasionally, we want to be able to reduce the proofs.  Having the proofs transparent allows the composition of the identity functor with itself to be judgementally the identity.  Since the only way to hide something from within a proof is [abstract], and that makes the definitions opaque, we need to define the laws separately. *)

  Local Notation c_object_of c := (G (F c)) (only parsing).
  Local Notation c_morphism_of m := (G _1 (F _1 m)) (only parsing).
  Definition compose_composition_of s d d'
      (m1 : morphism C s d) (m2 : morphism C d d')
  : c_morphism_of (m2 o m1) = c_morphism_of m2 o c_morphism_of m1
    := transport (@paths _ (c_morphism_of (m2 o m1)))
                 (composition_of G _ _ _ _ _)
                 (ap (fun m => G _1 m) (composition_of F _ _ _ m1 m2)).

  Definition compose_identity_of x
  : c_morphism_of (identity x) = identity (c_object_of x)
    := transport (@paths _ _)
                 (identity_of G _)
                 (ap (fun m => G _1 m) (identity_of F x)).

  Definition compose : Functor C E
    := Build_Functor
         C E
         (fun c => G (F c))
         (fun _ _ m => G _1 (F _1 m))
         compose_composition_of
         compose_identity_of.
End composition.

Global Arguments compose_composition_of / .
Global Arguments compose_identity_of / .

Module Export FunctorCompositionCoreNotations.
  Infix "o" := compose : functor_scope.
End FunctorCompositionCoreNotations.


Require Export XR_R.
Require Export XR_Rmult.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 * r = r2 * r.
Proof.
  intros x y z.
  intro heq.
  subst z.
  reflexivity.
Qed.


Set Universe Polymorphism.
Set Primitive Projections.
Unset Printing Primitive Projection Compatibility.

Inductive unit := tt.

Record sig A (P : A -> Type) := exist {
  wit : A;
  prf : P wit;
}.

Arguments wit {_ _} _.
Arguments prf {_ _} _.

Definition M A := forall Ω : Prop, (A -> Ω) -> Ω.
Definition ret {A} (x : A) : M A := fun Ω k => k x.

(** The underlying type is the type of stacks *)
Inductive Typeᴿ : M (Prop -> Type) -> Type :=
| IsType : forall (A : Prop -> Type),
  ((forall Ω : Prop, A Ω -> Ω) -> Type) -> Typeᴿ (ret A)
.

Definition TYPE := sig (M (Prop -> Type)) Typeᴿ.

Definition Typeᶠ : TYPE :=
 exist _ _ _ (IsType (fun Ω : Prop => (Prop -> Type) -> Ω) Typeᴿ).

Definition C (Ω : Prop) (A : TYPE) : Type :=
  match A.(prf) with IsType A Aᴿ => A Ω end.

Definition Cᴿ (A : TYPE) : (forall Ω : Prop, C Ω A -> Ω) -> Type :=
  match A.(prf) as T return
    (forall Ω, match T with IsType A _ => _ end -> _) -> Type
  with IsType A Aᴿ => Aᴿ end.

Definition El (A : TYPE) : Type := sig (forall Ω : Prop, C Ω A -> Ω) (Cᴿ A).

Check Typeᶠ : El Typeᶠ.

Definition Prodᶠ (A : TYPE) (B : El A -> TYPE) : El Typeᶠ.
Proof.
unshelve refine (exist _ _ (ret _) _).
+ refine (sig (El A) (fun x => C (B x))).
+ refine (IsType _ (fun f => _)).
  refine (forall x : El A, Cᴿ (B x) (fun ω => f (exist _ _ x ω))).
Defined.

Notation "A →ᶠ B" := (Prodᶠ A (fun _ => B)) (at level 99, right associativity, B at level 200).
Notation "'Πᶠ'  x .. y , P" := (Prodᶠ _ (fun x => .. (Prodᶠ _ (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity).

Definition Lamᶠ {A B} (f : forall x : El A, El (B x)) : El (Prodᶠ A B).
Proof.
unshelve refine (exist _ _ (fun ω => _) _).
+ unshelve refine ((f ω.(wit)).(wit) ω.(prf)).
+ unshelve refine (fun x => (f x).(prf)).
Defined.

Notation "'λᶠ'  x .. y , t" := (Lamᶠ (fun x => .. (Lamᶠ (fun y => t)) ..))
  (at level 200, x binder, y binder, right associativity).

Definition Appᶠ {A B} (f : El (Prodᶠ A B)) (x : El A) : El (B x).
Proof.
unshelve refine (exist _ _ (fun ω => f.(wit) (exist _ _ x ω)) _).
unshelve refine (f.(prf) _).
Defined.

Eval compute in eq_refl : (fun A B f x => Appᶠ (@Lamᶠ A B f) x) = (fun A B f x => f x).
Eval compute in eq_refl : (fun A B f => @Lamᶠ A B (fun x => Appᶠ f x)) = (fun A B f => f).

Notation "t · u" := (Appᶠ t u) (at level 11, left associativity).

Inductive Falseᴿ : M False -> Type :=.

Definition Falseᶠ : TYPE :=
  exist _ _ (ret (False -> Ω)) (IsType _ Falseᴿ).

Inductive boolᴿ : M bool -> Type :=
| trueᴿ : boolᴿ (ret true)
| falseᴿ : boolᴿ (ret false).

Definition boolᶠ : TYPE :=
  exist _ _ (ret (bool -> Ω)) (IsType _ boolᴿ).

Definition trueᶠ : El boolᶠ := exist _ _ _ trueᴿ.
Definition falseᶠ : El boolᶠ := exist _ _ _ falseᴿ.

Definition bool_rectᶠ : El
  (Πᶠ (P : El (boolᶠ →ᶠ Typeᶠ)), P · trueᶠ →ᶠ P · falseᶠ →ᶠ
  Πᶠ (b : El boolᶠ), P · b).
Proof.
refine (λᶠ P Pt Pf b, _).
refine (
match b.(prf) as br in boolᴿ b return El (Appᶠ P (exist _ _ _ br)) with
| trueᴿ => Pt
| falseᴿ => Pf
end
).
Defined.

Eval compute in eq_refl :
  (fun P Pt Pf => bool_rectᶠ · P · Pt · Pf · trueᶠ) = (fun P Pt Pf => Pt).
Eval compute in eq_refl :
  (fun P Pt Pf => bool_rectᶠ · P · Pt · Pf · falseᶠ) = (fun P Pt Pf => Pf).

Definition squash : El (Typeᶠ →ᶠ Typeᶠ).
Proof.
refine (λᶠ A, _).
unshelve refine (exist _ _ (ret (C A)) (IsType _ _)).
unshelve refine (fun _ => unit).
Defined.

Notation "[[ A ]]" := (squash · A).

Definition inhabits : El (Πᶠ (A : El Typeᶠ), A →ᶠ [[ A ]]).
Proof.
refine (λᶠ A x, _).
unshelve refine (exist _ _ x.(wit) tt).
Defined.

Lemma cc : El (Πᶠ (A B : El Typeᶠ), ((A →ᶠ [[ B ]]) →ᶠ A) →ᶠ [[ A ]]).
Proof.
refine (λᶠ A B f, _).
simple refine (exist _ _ (fun ω => _) _).
+ unshelve refine ((f).(wit) (exist _ _ _ _)); [|refine ω].
  unshelve refine (exist _ _ (fun k => (k.(wit).(wit) ω)) _).
  refine (fun _ => tt).
+ refine tt.
Defined.

Lemma squash_consistency : El ([[ Falseᶠ ]]) -> False.
Proof.
refine (fun e => match e.(wit) (False_rect _) with end).
Defined.

Definition squash_bool_caseᶠ :
  El (Πᶠ (P : El Typeᶠ) (Pt : El [[ P ]]) (Pf : El [[ P ]]) (b : El [[ boolᶠ ]]), [[ P ]]).
Proof.
unshelve refine (λᶠ P Pt Pf b, exist _ _ (fun ω => _) _).
+ refine (b.(wit) (fun b => match b with true => Pt.(wit) ω | false => Pf.(wit) ω end)).
+ exact tt.
Defined.

(* Not true : we would need extensional unit types *)
(* Check (eq_refl : (fun P Pt Pf => squash_bool_caseᶠ · P · Pt · Pf · (inhabits · boolᶠ · trueᶠ)) = (fun P Pt Pf => Pt)). *)
(* Check (eq_refl : (fun P Pt Pf => squash_bool_caseᶠ · P · Pt · Pf · (inhabits · boolᶠ · falseᶠ)) = (fun P Pt Pf => Pf)). *)

Lemma squash_bool_caseᶠ_true :
  forall P Pt Pf, squash_bool_caseᶠ · P · Pt · Pf · (inhabits · boolᶠ · trueᶠ) = Pt.
Proof.
intros P Pt Pf; compute.
destruct Pt as [? [ ] ]; reflexivity.
Defined.

Lemma squash_bool_caseᶠ_false :
  forall P Pt Pf, squash_bool_caseᶠ · P · Pt · Pf · (inhabits · boolᶠ · falseᶠ) = Pf.
Proof.
intros P Pt Pf; compute.
destruct Pf as [? [ ] ]; reflexivity.
Defined.

Inductive psigma (A : Type) (B : A -> Type) :=
| pexist : forall x, B x -> psigma A B.

Inductive sigmaᴿ (A : El Typeᶠ) (B : El (A →ᶠ Typeᶠ)) :
  M (psigma (El A) (fun x => El (B · x))) -> Type :=
| existᴿ : forall x y, sigmaᴿ A B (ret (pexist _ _ x y)).

Definition sigmaᶠ : El (Πᶠ (A : El Typeᶠ) (B : El (A →ᶠ Typeᶠ)), Typeᶠ).
Proof.
refine (λᶠ A B, _).
unshelve refine (exist _ _ (ret (_ -> Ω)) (IsType _ _)).
+ refine (psigma (El A) (fun x => El (B · x))).
+ refine (sigmaᴿ _ _).
Defined.

Definition existᶠ : El (
  Πᶠ (A : El Typeᶠ) (B : El (A →ᶠ Typeᶠ)) (x : El A) (y : El (B · x)),
    sigmaᶠ · A · B).
Proof.
refine (λᶠ A B x y, _).
refine (exist _ _ (ret _) (existᴿ A B x y)).
Defined.

Definition sigma_rectᶠ : El
  (Πᶠ (A : El Typeᶠ) (B : El (A →ᶠ Typeᶠ)) (P : El (sigmaᶠ · A · B →ᶠ Typeᶠ)),
  (Πᶠ x y, P · (existᶠ · A · B · x · y)) →ᶠ Πᶠ (p : El (sigmaᶠ · A · B)), P · p).
Proof.
refine (λᶠ A B P Pex p, _).
refine (
match p.(prf) as pr in sigmaᴿ _ _ p return El (P · (exist _ _ _ pr)) with
| existᴿ _ _ x y => Pex · x · y
end
).
Defined.

Definition choice : El (
  Πᶠ (A B : El Typeᶠ) (P : El (A →ᶠ B →ᶠ Typeᶠ)),
    (Πᶠ x, [[ sigmaᶠ · B · (λᶠ y, P · x · y) ]]) →ᶠ
    [[ sigmaᶠ · (A →ᶠ B) · (λᶠ f, Πᶠ x, P · x · (f · x)) ]]
).
Proof.
refine (λᶠ A B P f, _).
revert f; intros [f _].
unshelve refine (exist _ _ _ tt).
cbn in *.
refine (fun k => _).
assert (k' := fun f y => k (pexist _ _ f y)); clear k; rename k' into k.
cbn in *.
assert (f' := fun x y => f (exist _ _ x y)); clear f; rename f' into f.
cbn in *.

unshelve refine (k _ _).
+ unshelve refine (exist _ _ _ _).
  - cbn; intros [x ω].
    refine (f x _).
    intros [y _]; refine (y.(wit) ω).
  - intros x.
cbn.

Abort.

Definition choice : El (
  Πᶠ (A : El Typeᶠ) (B : El (A →ᶠ Typeᶠ)),
    (Πᶠ x, [[ B · x ]]) →ᶠ
    [[ Πᶠ x, B · x ]]
).
Proof.
refine (λᶠ A B f, _).
refine (exist _ _ _ tt).
cbn; intros [x k].
refine (f.(wit) (exist _ _ x k)).
Defined.

Inductive sum (A B : Type) :=
| inl : A -> sum A B
| inr : B -> sum A B.

Inductive sumᴿ (A B : El Typeᶠ) :
  M (sum (El A) (El B)) -> Type :=
| inlᴿ : forall x, sumᴿ A B (ret (inl _ _ x))
| inrᴿ : forall y, sumᴿ A B (ret (inr _ _ y)).

Definition sumᶠ : El (Typeᶠ →ᶠ Typeᶠ →ᶠ Typeᶠ).
Proof.
refine (λᶠ A B, _).
refine (exist _ _ (ret _) (IsType _ (sumᴿ A B))).
Defined.

Definition em : El (Πᶠ A, [[ sumᶠ · A · (A →ᶠ Falseᶠ) ]]).
Proof.
refine (λᶠ A, _).
refine (exist _ _ _ tt).
cbn.
refine (fun ω => ω (inr _ _ (λᶠ x, _))).
destruct (ω (inl _ _ x)).
Defined.


(**********************************************************************)
(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*               Delayed Substitution Lambda Calculus                 *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                        Tuple_Terms.v                               *)
(*                                                                    *)
(* adapted from Terms.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.

(* lambda terms using de Bruijn's indices *)

Inductive lambda:  Set :=
| Unit  : lambda
| Pair: lambda -> lambda -> lambda
| Ref : nat -> lambda -> lambda
| Raise: lambda -> nat -> nat -> lambda
| Abs : nat -> lambda -> lambda
| App : lambda -> lambda -> lambda .

Lemma decidable_term_equality : forall (M N: lambda), M = N \/ M<> N.
Proof.
  induction M; induction N; intros; try (left; congruence); try(right; congruence).
  (* 5 *)
  elim(IHM1 N1); elim(IHM2 N2); auto; (right; congruence; fail) || left; congruence.
  (* 4 *)
  elim(decidable_nats n0 n); auto. elim(IHM N); split_all. left; congruence. right; congruence.
  right; congruence.
  (* 3 *)
  elim(decidable_nats n1 n); auto. elim(decidable_nats n0 n2); auto.
  elim(IHM N); split_all. left; congruence. right; congruence.
  right; congruence.  right; congruence.
  (* 2 *)
  elim(IHM N); split_all.  elim(decidable_nats n0 n); auto. left; congruence.
  right; congruence.  right; congruence.
  (* 1 *)
   elim(IHM1 N1); elim(IHM2 N2); auto; (right; congruence; fail) || left; congruence.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import NetCore.NetCoreEval.
Require Import Common.Types.
Require Import Classifier.Classifier.
Require Import Word.WordInterface.
Require Import Pattern.Pattern.
(* TODO: MJR Move 'switchId' from messagesDef so that we don't have to include this whole thing *)
Require Import OpenFlow.OpenFlow0x01Types.
Require Import Network.NetworkPacket.

Set Implicit Arguments.

Import ListNotations.

Fixpoint compile_pred (opt : Classifier bool -> Classifier bool)
         (pr : pred) (sw : switchId) : Classifier bool :=
  match pr with
    | PrHdr pat => [(pat, true)]
    | PrOnSwitch sw' =>
      match Word64.eq_dec sw sw' with
        | left _ => [(Pattern.all, true)]
        | right _ => []
      end
    | PrOr pr1 pr2 => opt (union orb (compile_pred opt pr1 sw)
                                 (compile_pred opt pr2 sw))
    | PrAnd pr1 pr2 => opt (inter andb (compile_pred opt pr1 sw)
                                  (compile_pred opt pr2 sw))
    | PrNot pr' =>
      opt (map (second negb)
               (compile_pred opt pr' sw ++ [(Pattern.all, false)]))
    | PrAll => [(Pattern.all, true)]
    | PrNone => []
  end.

Definition apply_act (a : list act) (b : bool) :=
  match b with
    | true => a
    | false => nil
  end.

(** TODO(arjun): rank-2 polymorphism. The extracted code makes me nervous. *)
Fixpoint compile_pol
  (opt : forall (A : Type), Classifier A -> Classifier A)
  (p : pol) (sw : switchId) : Classifier (list act) :=
  match p with
    | PoAtom pr act =>
      opt _ (map (second (apply_act act))
                 (compile_pred (opt bool) pr sw ++ [(Pattern.all, false)]))
    | PoUnion pol1 pol2 =>
      opt _ (union (@app act)
                   (compile_pol opt pol1 sw)
                   (compile_pol opt pol2 sw))
  end.

Fixpoint strip_empty_rules (A : Type) (cf : Classifier A) : Classifier A :=
  match cf with
    | nil => nil
    | (pat, acts) :: cf =>
      if Pattern.is_empty pat
      then strip_empty_rules cf
      else (pat, acts) :: strip_empty_rules cf
  end.

Definition no_opt (A : Type) := @Datatypes.id (Classifier A).

Definition compile_no_opt := compile_pol no_opt.

Definition compile_opt :=
  compile_pol ((fun A x  => @strip_empty_rules A (@elim_shadowed A x))).


Require Import ExtLib.Data.Sum.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Instantiate.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.RTac.Simplify.

Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Context {typ : Set}.
  Context {expr : Set}.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  Definition INSTANTIATE
  : rtac typ expr :=
    @SIMPLIFY typ expr
              (fun subst Subst_subst _ctx sub =>
                 instantiate (fun u => subst_lookup u sub) 0).

  Theorem INSTANTIATE_sound : rtac_sound INSTANTIATE.
  Proof.
    intros. eapply SIMPLIFY_sound.
    red. intros; forward.
    unfold propD, exprD_typ0 in *.
    forward.
    eapply (@instantiate_sound_ho  _ _ _ _ _ _ _ _ _ nil) in H3;
      [ | | eapply sem_preserves_if_ho_ctx_lookup; eauto ]; eauto.
    { forward_reason; inv_all; subst.
      change_rewrite H3.
      autorewrite with eq_rw. eexists; split; eauto.
      intros.
      gather_facts.
      eapply Pure_pctxD; eauto.
      clear. firstorder. specialize (H HList.Hnil).
      revert H1. autorewrite with eq_rw.
      simpl in *. rewrite H.
      exact (fun x => x). }
    constructor.
    { intros. eapply Pure_pctxD; eauto. }
    { intros.
      specialize (H6 us vs).
      eapply Ap_pctxD; eauto. }
  Qed.

End parameterized.


Require Import Coq.Vectors.Vector.
        Import VectorNotations.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Lt.
Require Import Coq.Arith.Gt.
Require Import Coq.Program.Equality.

Fixpoint uniques  {n : nat} {A : Type} (deck : t A n) : Prop :=
      match deck with
        | nil _            => True
        | cons _ c0 _ rest => (Forall (fun c : A => c <> c0) rest ) /\ uniques rest
      end.

Module Type PokerFunctions.

  (* Of Cards and Decks *)
  Parameter  Card              : Type.
  Parameter  standard_deck     : t Card 52.
  Axiom unique_deck : uniques standard_deck.

  Parameter  shuffle           : forall n : nat, t Card n -> t Card n.

  Axiom      shuffle_changes   : forall n : nat, forall deck : t Card n,
                                        n > 1 -> uniques deck -> shuffle n deck <> deck.
  Axiom      Shuffle_perumute  : forall n : nat, forall deck : t Card n,
                                 Permutation (to_list deck) (to_list (shuffle n deck)).
  Parameter  count_cards : Card -> nat.
  Axiom countable_cards : forall n : nat,
      n < 14 -> exists c0 c1 c2 c3 : Card,
            (count_cards c0 = count_cards c1) /\
            (count_cards c2 = count_cards c3) /\
            (count_cards c0 = count_cards c3).
  Definition hand              := option (prod Card Card).

  (* Of Players *)
  Definition Player           : Type := (nat * hand).
  Definition get_hand  : Player -> hand    := snd .
  Definition get_money : Player -> nat := fst.
  Parameter  number_of_players : nat.
  Definition max_players       := 6.
  Axiom      multiple_players  : (number_of_players > 1) /\ (number_of_players <= max_players).
  Definition Players           := t Player number_of_players.
  Definition Active {n : nat} {c0 c1 : Card} (p: Player) : Prop := p = (n,Some (c0,c1)).

  (* Of Card Flops *)
  Definition flop : Type       := (Card * Card * Card).
  Definition turn              := prod Card flop.
  Definition river             := prod Card turn.
  Definition get_flop { n : nat } (deck : t Card (S ( S ( S ( S ( S n)))))) :
                                 ((t Card (S (S n))) * flop ):=
      let c1 := hd deck                 in
      let c2 := hd (tl deck)            in
      let c3 := hd (tl (tl deck))       in
      let new_deck := tl (tl (tl deck)) in
      (new_deck, (c1,c2,c3)).
  Definition get_turn {n : nat} (deck : t Card (S (S n))) (fl : flop) :
    ((t Card (S n)) * turn) :=
    (tl deck, (hd deck, fl)).
  Definition get_river {n : nat} (deck : t Card (S n)) (fl : flop) :
    ((t Card n) * turn) :=
    (tl deck, (hd deck, fl)).

  (* Of Betting *)
  Definition bet (pl : Player) (pot : nat) (bet : nat)
    : (Player * nat)  :=
    ( (get_money pl - bet, get_hand pl) , pot + bet).

End PokerFunctions.

Print All.

Module Type single_n.
  Parameter n : nat.
  Axiom    in_range : (n > 1) /\ n < 7.
End single_n.

Module impl (n' : single_n) <: PokerFunctions.

Inductive Name : Type :=
| Ace   : Name
| Two   : Name
| Three : Name
| Four  : Name
| Five  : Name
| Six   : Name
| Seven : Name
| Eight : Name
| Nine  : Name
| Ten   : Name
| Jack  : Name
| Queen : Name
| King  : Name
.

Definition Names : t Name 13  :=
  [
    Ace   ;
    Two   ;
    Three ;
    Four  ;
    Five  ;
    Six   ;
    Seven ;
    Eight ;
    Nine  ;
    Ten   ;
    Jack  ;
    Queen ;
    King
  ]
.

Inductive Card' : Type :=
| Heart   : Name -> Card'
| Spade   : Name -> Card'
| Club    : Name -> Card'
| Diamond : Name -> Card'
.

Definition Card := Card'.

Definition standard_deck : t Card 52 :=
    map Heart   Names ++
    map Spade   Names ++
    map Club    Names ++
    map Diamond Names
.

Definition unique_deck : uniques standard_deck.
Proof.

constructor.
all:constructor.
all:simpl.

all:repeat (
(try discriminate) ;
(constructor)
).
Qed.

Definition shuffle {n : nat} (deck : t Card n) : t Card n := rev (A:=Card) (n:=n) deck.
Definition shuffle_changes : forall n : nat, forall deck : t Card n,
                                        n > 1 -> (uniques deck) -> (shuffle (n:=n) deck) <> deck.
Proof.
intros.
inversion H.
Check deck.
subst.
dependent induction deck.
dependent induction deck.
dependent induction deck.
simpl.
cut (h <> h0).
all:(try
(dependent induction deck ||
dependent induction deck  ||
dependent induction deck
)).
intros.
Check shuffle.
Compute (shuffle (n:=2) [h; h0]).

unfold shuffle.
unfold rev.
unfold rev_append.
unfold rev_append_tail.
unfold eq_rect_r.
unfold eq_rect.
unfold eq_sym.
simpl.
pattern shuffle.

Check .
dependent induction n.

inversion deck.
case deck.
assert (n <> 0).
intuition.

absurd H1 H.

End impl.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus Zero (plus (mult lv0 lv1) lv2)) (plus lv2 (mult lv0 lv1))).
Admitted.
QuickChick conj22synthconj1.


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

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 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.
*)

(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)

From Coq Require Import ZArith Reals Lia.

Require Import Zaux Raux Defs Digits Generic_fmt Float_prop Bracket.

Set Implicit Arguments.
Set Strongly Strict Implicit.

Section Fcalc_sqrt.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real square root of the
    input floating-point number.

The algorithm performs the following steps:
- Shift the mantissa so that it has at least 2p-1 digits;
  shift it one digit more if the new exponent is not even.
- Compute the square root s (at least p digits) of the new
  mantissa, and its remainder r.
- Compute the position according to the remainder:
  -- r == 0  =>  Eq,
  -- r <= s  =>  Lo,
  -- r >= s  =>  Up.

Complexity is fine as long as p1 <= 2p-1.
*)

Lemma mag_sqrt_F2R :
  forall m1 e1,
  (0 < m1)%Z ->
  mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z.
Proof.
intros m1 e1 Hm1.
rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
apply mag_sqrt.
now apply F2R_gt_0.
Qed.

Definition Fsqrt_core m1 e1 e :=
  let d1 := Zdigits beta m1 in
  let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in
  let (q, r) := Z.sqrtrem m1' in
  let l :=
    if Zeq_bool r 0 then loc_Exact
    else loc_Inexact (if Zle_bool r q then Lt else Gt) in
  (q, l).

Theorem Fsqrt_core_correct :
  forall m1 e1 e,
  (0 < m1)%Z ->
  (2 * e <= e1)%Z ->
  let '(m, l) := Fsqrt_core m1 e1 e in
  inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l.
Proof.
intros m1 e1 e Hm1 He.
unfold Fsqrt_core.
set (m' := Zmult _ _).
assert (0 <= m')%Z as Hm'.
{ apply Z.mul_nonneg_nonneg.
  now apply Zlt_le_weak.
  apply Zpower_ge_0. }
assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf.
{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0.
  rewrite <- sqrt_mult.
  unfold Rsqr, m'.
  rewrite mult_IZR, IZR_Zpower by lia.
  rewrite Rmult_assoc, <- 2!bpow_plus.
  now replace (_ + _)%Z with e1 by ring.
  now apply IZR_le.
  apply Rle_0_sqr. }
generalize (Z.sqrtrem_spec m' Hm').
destruct Z.sqrtrem as [q r].
intros [Hq Hr].
rewrite Hf.
unfold inbetween_float, F2R. simpl Fnum.
apply inbetween_mult_compat.
apply bpow_gt_0.
rewrite Hq.
case Zeq_bool_spec ; intros Hr'.
(* .. r = 0 *)
rewrite Hr', Zplus_0_r, mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
now constructor.
apply IZR_le.
clear -Hr ; lia.
(* .. r <> 0 *)
constructor.
split.
(* ... bounds *)
apply Rle_lt_trans with (sqrt (IZR (q * q))).
rewrite mult_IZR.
fold (Rsqr (IZR q)).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; lia.
apply sqrt_lt_1.
rewrite mult_IZR.
apply Rle_0_sqr.
rewrite <- Hq.
now apply IZR_le.
apply IZR_lt.
lia.
apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))).
apply sqrt_lt_1.
rewrite <- Hq.
now apply IZR_le.
rewrite mult_IZR.
apply Rle_0_sqr.
apply IZR_lt.
ring_simplify.
lia.
rewrite mult_IZR.
fold (Rsqr (IZR (q + 1))).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply IZR_le.
clear -Hr ; lia.
(* ... location *)
rewrite Rcompare_half_r.
generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))).
rewrite 2!Rabs_pos_eq.
intros <-.
replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R
  with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring).
rewrite Rsqr_sqrt.
rewrite <- plus_IZR, <- 2!mult_IZR.
rewrite Rcompare_IZR.
replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
generalize (Zle_cases r q).
case (Zle_bool r q) ; intros Hr''.
change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
lia.
change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
lia.
rewrite <- Hq.
now apply IZR_le.
rewrite <- plus_IZR.
apply IZR_le.
clear -Hr ; lia.
apply Rmult_le_pos.
now apply IZR_le.
apply sqrt_ge_0.
Qed.

Definition Fsqrt (x : float beta) :=
  let (m1, e1) := x in
  let e' := (Zdigits beta m1 + e1 + 1)%Z in
  let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in
  let '(m, l) := Fsqrt_core m1 e1 e in
  (m, e, l).

Theorem Fsqrt_correct :
  forall x,
  (0 < F2R x)%R ->
  let '(m, e, l) := Fsqrt x in
  (e <= cexp beta fexp (sqrt (F2R x)))%Z /\
  inbetween_float beta m e (sqrt (F2R x)) l.
Proof.
intros [m1 e1] Hm1.
apply gt_0_F2R in Hm1.
unfold Fsqrt.
set (e := Z.min _ _).
assert (2 * e <= e1)%Z as He.
{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r.
  rewrite (Zdiv2_odd_eqn e1).
  destruct Z.odd ; lia. }
generalize (Fsqrt_core_correct m1 e1 e Hm1 He).
destruct Fsqrt_core as [m l].
apply conj.
apply Z.le_trans with (1 := Z.le_min_l _ _).
unfold cexp.
rewrite (mag_sqrt_F2R m1 e1 Hm1).
apply Z.le_refl.
Qed.

End Fcalc_sqrt.