From mathcomp Require Import ssreflect ssrnat eqtype ssrbool ssrfun seq.
From mathcomp Require Import finmap choice finfun fintype.
From coqspec Require Import utilities substitution.
From deriving Require Import deriving.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Open Scope fmap_scope.
Open Scope fset_scope.

Inductive Cntr :=
  | CONStest of Arg
  | ATOMtest of Exp & Exp.
Notation "CONS?" := (CONStest) (only parsing).
Notation "'EQA?'"  := (ATOMtest) (only parsing).

Definition FVCntr (c : Cntr) : {fset Var} :=
  match c with
  | EQA? x y => FVExp x `|` FVExp y
  | CONS? x  => FVArg x
  end.

Inductive Tree :=
  | RET  of Exp
  | LET  of Var  & Exp  & Tree
  | COND of Cntr & Tree & Tree
  | HT   of Var & Var & Var & Tree
  | CALL of FName & seq Exp.
Coercion RET : Exp >-> Tree.

Fixpoint VTree (t : Tree) : {fset Var} :=
  match t with
  | RET e        => FVExp e
  | LET v x t    => v |` (FVExp x `|` VTree t)
  | COND c t1 t2 => FVCntr c `|` VTree t1 `|` VTree t2
  | HT v u x t   => [fset v; u; x] `|`  (VTree t)
  | CALL f xs    => [fset x | y in xs, x in FVExp y]
  end.

Fixpoint FVTree (t : Tree) : {fset Var} :=
  match t with
  | RET e        => FVExp e
  | LET v x t    => (FVExp x `|` FVTree t) `\ v
  | COND c t1 t2 => FVCntr c `|` FVTree t1 `|` FVTree t2
  | HT v u x t   => (FVExp x `|` FVTree t) `\ v `\ u
  | CALL f xs    => [fset x | y in xs, x in FVExp y]
  end.

Definition maxvar (t : Tree) : Var := max_set (VTree t).

Lemma subst_max (e1 e2 : Env) (e : Exp) :
  (forall x, x <= maxvar e -> e1 x = e2 x) ->
  e /s/ e1 = e /s/ e2.
Proof.
elim: e=> [[[]|?]|? IHe1 ? IHe2 I] //=; first apply.
- rewrite /maxvar /=; apply/max_setin; by rewrite ?inE.
  by rewrite IHe1 ?IHe2 //; move=> ? I'; apply/I; rewrite /maxvar /=;
rewrite max_setU leq_max I' ?orbT.
Qed.

Inductive Def := DEFINE of FName & seq Var & Tree.

Definition Prog := seq Def.

Inductive Branch :=
  | TRUE  of Env
  | FALSE of Env
  | ERR.

Definition cntr (c : Cntr) (e : Env) : Branch :=
  match c with
  | EQA? x y    =>
    match x /s/ e, y /s/ e with
    | Arg_Val 'a, Arg_Val 'b => if a == b then TRUE e else FALSE e
    | _, _ => ERR
    end
  | CONS? x =>
    if x /s/ e is CONS a _ then
      TRUE e
    else FALSE e
  end.

Fixpoint get_func (f : FName) (p : Prog) : (Tree * seq Var)%type :=
  match p with
  | [::]                  => (RET ERROR, [::])
  | (DEFINE g xs t) :: ps =>
    if f == g then (t, xs)
    else get_func f ps
  end.

Fixpoint int (n : nat) (t : Tree) (e : Env) (p : Prog) : Exp :=
  match t with
  | RET x         =>
    if n is n'.+1 then
      subst x e
    else ERROR
  | LET v x t     =>
    if n is n'.+1 then
      int n' t  [fsfun e with v |-> x /s/ e] p
    else ERROR
  | COND c t' t'' =>
    if n is n'.+1 then
      match cntr c e with
      | TRUE e'   => int n' t'  e'  p
      | FALSE e'' => int n' t'' e'' p
      | ERR       => ERROR
      end
    else ERROR
  | HT v u x t =>
    if n is n'.+1 then
      if x /s/ e is CONS a b then
        int n' t [fsfun e with v |-> a, u |-> b] p
      else ERROR
    else ERROR
  | CALL f args =>
    if n is n'.+1 then
      let: (t, xs) := (get_func f p) in
        int n' t (mkEnv xs (map (subst^~ e) args)) p
    else ERROR
  end.

Lemma aux_CONS e a:
  aux e (FVCntr (CONS? a)) = FVExp (a /s/ e).
Proof.
move=> /=; have->: FVArg a = FVExp a by case: a=> [[]|].
exact/aux_FVExp.
Qed.

Lemma aux_EQA e a1 a2:
  aux e (FVCntr (EQA? a1 a2)) = FVExp (a1 /s/ e) `|` FVExp (a2 /s/ e).
Proof. by move=> /=; rewrite auxU ?aux_FVExp. Qed.

Lemma auxE e c rs:
  aux e (FVCntr c) `<=` FVCntr c `|` whole (e, rs).
Proof.
apply/fsubsetP=> y /mem_aux[x I].
rewrite -[e x]/((Exp_Arg (Arg_Var x)) /s/ e)=> /(fsubsetP (whole_subst _ rs _)).
move=> /=; rewrite 2?inE => /orP[/eqP->|H]; first by rewrite inE I.
by rewrite inE H orbT.
Qed.

Lemma cntr_env_TRUE c env e:
  cntr c env = TRUE e ->
  (env = e).
Proof.
case: c=> /= [?|??]; case: (_ /s/ env)=> //.
- by move=> ?? [].
by case=> // [[]] ?; case: (_ /s/ _)=> // [[]] // [] ?; case: ifP=> // ? [].
Qed.

Lemma cntr_env_FALSE c env e:
  cntr c env = FALSE e -> e = env.
Proof.
case: c=> [/= >|/= ??]; case (_ /s/ _)=> //; first by move=> ?[->].
case=> //[][]. case: (_ /s/ _)=> //[][]//[] ??.
by case:ifP=> // ?[->].
Qed.

Section IntSpec.

Context {p : Prog}.

Fixpoint well_typed (t : Tree) : bool :=
  match t with
  | RET _ => true
  | LET v x t => well_typed t && (v \notin FVExp x)
  | COND c t1 t2 =>  well_typed t1 && well_typed t2
  | HT v u x t => [&& x != v, x != u, v != u & well_typed t]
  | CALL f xs => size xs == size (get_func f p).2
  end.

Lemma int_freevar (e1 e2 : Env) t n:
  well_typed t ->
  (forall x, x \in FVTree t -> e1 x = e2 x) ->
  int n t e1 p = int n t e2 p.
Proof.
elim: t e1 e2 n=> [??? n ? H *|??? IHt ?? n|c ? IHt1 ? IHt2 ++ n|?? v ? IHt e1 e2 n|++++ n].
all: case: n=> // n.
- apply/subst_fv=> *; exact/H.
- move=> /andP[? /negbTE NI I]; apply/IHt=> // ? F; rewrite ?fsfun_withE.
  case: ifP=> [/eqP E|N].
  - apply/subst_fv=> ? I'; apply/I; rewrite /= ?inE I' /= andbT.
    apply/negP=> /eqP E'; by rewrite E' NI in I'.
  by apply/I; rewrite ?inE F N orbT.
- case: c=> [[[a ?? /andP[??] I]|v e1 e2 /andP[??] I]|] /=.
  - apply/IHt2=> // ? I'; apply/I; by rewrite ?inE I' orbT.
  - have->: e1 v = e2 v by apply/I; rewrite ?inE eq_refl.
    case E: (e2 v); [apply/IHt2 | apply/IHt1] => // ? I'; apply/I;
    by rewrite ?inE I' orbT.
  - move=> e e' e1 e2 /andP[??] I.
    have->: (e /s/ e1 = e /s/ e2).
    - by apply/subst_fv=> ? I'; apply/I; rewrite ?inE I'.
    case: (e /s/ e2)=> // [[[]|]] //= ?.
    have->: (e' /s/ e1 = e' /s/ e2).
    - by apply/subst_fv=> ? I'; apply/I; rewrite ?inE I' orbT.
    case: (e' /s/ e2)=> // [[]] // [?]; case: ifP=> ?;
    [apply/IHt1 | apply/IHt2] => // ? I'; apply/I; by rewrite ?inE I' ?orbT.
- case/and4P=> N1 N2 ?? I /=.
  have->: e1 v = e2 v.
  - by apply/I=> /=; rewrite ?inE N1 N2 eq_refl /=.
  case: (e2 v)=> // ??; apply/IHt=> // ? I'; rewrite ?fsfun_withE.
  (do? case: ifP=> //)=> N1' N2'; apply/I; by rewrite ?inE N1' N2' I' orbT.
move=> f l e1 e2 ? IH /=.
case: (get_func f p)=> ? xs.
have-> //: (mkEnv xs [seq x /s/ e1 | x <- l]) =  (mkEnv xs [seq x /s/ e2 | x <- l]).
apply/congr1/eq_in_map=> x H. apply/subst_fv=> y ?.
apply/IH/imfset2P; exists x=> //; by exists y.
Qed.

Lemma int_maxvar (e1 e2 : Env) t n:
  well_typed t ->
  (forall x, x <= maxvar t -> e1 x = e2 x) ->
  int n t e1 p = int n t e2 p.
Proof.
move=> wf H; apply/int_freevar=> // ? I; rewrite H // /maxvar max_setin //.
elim: t I {wf H}=> //= [??? IH|?? IH1 ? IH2|???? IH]; rewrite ?inE.
- case/andP=> ? /orP[|/IH]->; by rewrite ?orbT.
- case/orP=> [/orP[|/IH1]|/IH2]->; by rewrite ?orbT.
case/and3P=> ?? /orP[|/IH]->; by rewrite ?orbT.
Qed.

Arguments int: simpl nomatch.

Lemma int_not0 n t e:
  int n t e p <> ERROR ->
  int n t e p = int n.+1 t e p.
Proof.
elim: n t e p=> [[]|] // n IH [] //=.
- move=> *; by rewrite IH.
- move=> c ?? e ?; case: c=> //= [[[]??|v]|] //=; rewrite 1?IH //;
  rewrite /int /= -/int.
  - case E: (e v)=> ?; by rewrite IH.
  move=> e1 e2 /=. case: (e1 /s/ e)=> //= [[]] // [] //.
  case (e2 /s/ e)=> [] // [] // [] ??; case: ifP=> ??; by rewrite IH.
- move=> ?? v ?; rewrite /int/= -/int=> e; case: (e v)=> // *.
  by rewrite IH.
move=> ????. rewrite {1 2 3}/int/=-/int. case: (get_func _ _)=> // ???.
by rewrite IH.
Qed.

End IntSpec.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A Bprime : Universe, ((wd_ A O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Bprime O /\ (wd_ Bprime E /\ (wd_ O E /\ (col_ O E A /\ (col_ O Eprime Bprime /\ (col_ Bprime O E /\ col_ E O E)))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.Spec.MxDH.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Examples.X25519_64.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import bedrock2.Semantics.
Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.

Require Import Crypto.Spec.ModularArithmetic.
Definition F := F (2^255 - 19).
Definition a24 : F := F.of_Z _ 121665.

(* Gallina specification *)
Definition ladderstep_gallina
           (X1 : F) (P1 P2 : F * F) : F * F * (F * F) :=
  @MxDH.ladderstep F F.add F.sub F.mul a24 X1 P1 P2.

Existing Instances
         default_parameters default_parameters_ok
         curve25519_bedrock2_funcs curve25519_bedrock2_specs
         curve25519_bedrock2_correctness.

Local Notation n := X25519_64.n.
Local Notation s := X25519_64.s.
Local Notation c := X25519_64.c.
Local Notation M := (UnsaturatedSolinas.m s c).
Local Notation word := BasicC64Semantics.word.
Local Notation mem := BasicC64Semantics.mem.
Local Notation weight :=
  (ModOps.weight (QArith_base.Qnum
                    (UnsaturatedSolinasHeuristics.limbwidth n s c))
                 (Z.pos (QArith_base.Qden
                           (UnsaturatedSolinasHeuristics.limbwidth n s c)))).
Local Notation eval := (Positional.eval weight n).
Local Notation loose_bounds := (UnsaturatedSolinasHeuristics.loose_bounds n s c).
Local Notation tight_bounds := (UnsaturatedSolinasHeuristics.tight_bounds n s c).

Local Open Scope string_scope.
Local Infix "*" := sep : sep_scope.
Delimit Scope sep_scope with sep.

Existing Instances
  curve25519_bedrock2_scmul121665_func
  curve25519_bedrock2_scmul121665_spec
  curve25519_bedrock2_scmul121665_correctness.
Require Import bedrock2.NotationsCustomEntry.

Definition ladderstep : Syntax.func :=
  let mul := "curve25519_carry_mul" in
  let square := "curve25519_carry_square" in
  let add := "curve25519_add" in
  let sub := "curve25519_sub" in
  let scmul121665 := "curve25519_carry_scmul_const121665" in
  ("ladderstep",
   (["X1"; "X2"; "Z2"; "X3"; "Z3";
       "A"; "AA"; "B"; "BB"; "E"; "C"; "D"; "DA"; "CB"], [],
    (* store results back in P1 (X2, Z2) and P2 (X3, Z3) *)
    bedrock_func_body:(
      $add (A, X2, Z2) ;     (* llet A  := X2+Z2 in *)
      $square (AA, A) ;      (* llet AA := A^2 in *)
      $sub (B, X2, Z2) ;     (* llet B  := X2-Z2 in *)
      $square (BB, B) ;      (* llet BB := B^2 in *)
      $sub (E, AA, BB) ;     (* llet E  := AA-BB in *)
      $add (C, X3, Z3) ;     (* llet C  := X3+Z3 in *)
      $sub (D, X3, Z3) ;     (* llet D  := X3-Z3 in *)
      $mul (DA, D, A) ;      (* llet DA := D*A in *)
      $mul (CB, C, B) ;      (* llet CB := C*B in *)
      $add (X3, DA, CB) ;    (* llet X3 := (DA+CB)^2 in *)
      $square (X3, X3) ;
      $sub (Z3, DA, CB) ;    (* llet Z3 := X1*(DA-CB)^2 in *)
      $square (Z3, Z3) ;
      $mul (Z3, X1, Z3) ;
      $mul (X2, AA, BB) ;    (* llet X2 := AA*BB in *)
      $scmul121665 (Z2, E) ; (* llet Z2 := E*(AA + a24*E) in *)
      $add (Z2, AA, Z2) ;
      $mul (Z2, E, Z2)        (* pair4 X2 Z2 X3 Z3 *)
  ))).

Instance spec_of_ladderstep : spec_of ladderstep :=
  fun functions =>
    forall (X1 X2 Z2 X3 Z3 A AA B BB E C D DA CB : list word)
           (pX1 pX2 pZ2 pX3 pZ3
                pA pAA pB pBB pE pC pD pDA pCB : word)
           t m (R : Interface.map.rep (map:=mem) -> Prop),
      (* inputs must be bounded by loose_bounds *)
      let X1z := map word.unsigned X1 in
      let X2z := map word.unsigned X2 in
      let Z2z := map word.unsigned Z2 in
      let X3z := map word.unsigned X3 in
      let Z3z := map word.unsigned Z3 in
      list_Z_bounded_by tight_bounds X1z ->
      list_Z_bounded_by tight_bounds X2z ->
      list_Z_bounded_by tight_bounds Z2z ->
      list_Z_bounded_by tight_bounds X3z ->
      list_Z_bounded_by tight_bounds Z3z ->
      (Bignum n pX1 X1
       * Bignum n pX2 X2
       * Bignum n pZ2 Z2
       * Bignum n pX3 X3
       * Bignum n pZ3 Z3
       * Bignum n pA A
       * Bignum n pAA AA
       * Bignum n pB B
       * Bignum n pBB BB
       * Bignum n pE E
       * Bignum n pC C
       * Bignum n pD D
       * Bignum n pDA DA
       * Bignum n pCB CB)%sep m ->
      WeakestPrecondition.call
        functions ladderstep t m
        [pX1; pX2; pZ2; pX3; pZ3; pA; pAA; pB; pBB; pE; pC; pD; pDA; pCB]
        (fun t' m' rets =>
           t = t' /\
           rets = []%list /\
           exists X4 Z4 X5 Z5 (* output values *)
                  A' AA' B' BB' E' C' D' DA' CB' (* new intermediates *)
                  : list word,
             let X4z := map word.unsigned X4 in
             let Z4z := map word.unsigned Z4 in
             let X5z := map word.unsigned X5 in
             let Z5z := map word.unsigned Z5 in
             let toF := fun x => F.of_Z (2^255 - 19) (eval x) in
             ladderstep_gallina
               (toF X1z) (toF X2z, toF Z2z) (toF X3z, toF Z3z) =
             ((toF X4z, toF Z4z), (toF X5z, toF Z5z))
             /\ list_Z_bounded_by tight_bounds X4z
             /\ list_Z_bounded_by tight_bounds Z4z
             /\ list_Z_bounded_by tight_bounds X5z
             /\ list_Z_bounded_by tight_bounds Z5z
             /\ (Bignum n pX1 X1
                 * Bignum n pX2 X4
                 * Bignum n pZ2 Z4
                 * Bignum n pX3 X5
                 * Bignum n pZ3 Z5
                 * Bignum n pA A'
                 * Bignum n pAA AA'
                 * Bignum n pB B'
                 * Bignum n pBB BB'
                 * Bignum n pE E'
                 * Bignum n pC C'
                 * Bignum n pD D'
                 * Bignum n pDA DA'
                 * Bignum n pCB CB')%sep m').

Instance spec_of_curve25519_carry_mul :
  spec_of "curve25519_carry_mul" := spec_of_carry_mul.
Instance spec_of_curve25519_carry_square :
  spec_of "curve25519_carry_square" := spec_of_carry_square.
Instance spec_of_curve25519_add :
  spec_of "curve25519_add" := spec_of_add.
Instance spec_of_curve25519_sub :
  spec_of "curve25519_sub" := spec_of_sub.
Instance spec_of_curve25519_carry_scmul_const121665 :
  spec_of "curve25519_carry_scmul_const121665"
  := @spec_of_carry_scmul_const _ curve25519_bedrock2_scmul121665_spec.

Ltac prove_bounds :=
  lazymatch goal with
  | H : list_Z_bounded_by tight_bounds ?x
    |- list_Z_bounded_by loose_bounds ?x =>
    apply UnsaturatedSolinas.relax_valid; apply H
  | H : list_Z_bounded_by ?b ?x |- list_Z_bounded_by ?b ?x =>
    apply H
  end.
Ltac prove_length :=
  match goal with
  | |- length (map _ _) = _ => rewrite ?map_length; assumption
  | |- length _ = X25519_64.n =>
    apply bounded_by_loose_bounds_length
      with (s:=X25519_64.s) (c:=X25519_64.c); prove_bounds
  end.
Ltac prove_preconditions :=
  lazymatch goal with
  | |- length _ = _ => prove_length
  | |- list_Z_bounded_by _ _ => prove_bounds
  end.

(* tactics for solving the final arithmetic equivalence *)
Ltac push_FtoZ :=
  cbv [F.sub];
  repeat first [ rewrite ModularArithmeticTheorems.F.to_Z_add
               | rewrite ModularArithmeticTheorems.F.to_Z_mul
               | rewrite ModularArithmeticTheorems.F.to_Z_opp
               | rewrite ModularArithmeticTheorems.F.of_Z_to_Z
               | rewrite ModularArithmeticTheorems.F.to_Z_of_Z
               ].
Ltac rewrite_field_postconditions :=
  repeat lazymatch goal with
         | H : eval (map word.unsigned ?x) mod M = _
           |- context [map word.unsigned ?x] =>
           autorewrite with push_Zmod in H;
           rewrite H
         end.
Ltac solve_F_eq :=
  apply ModularArithmeticTheorems.F.eq_of_Z_iff;
  push_FtoZ; change (Z.pos (2^255 - 19)) with M; pull_Zmod;
  let LHS := fresh "LHS" in
  match goal with |- ?lhs = _ =>
                  set (LHS := lhs) end;
  rewrite_field_postconditions; pull_Zmod;
  subst LHS; try reflexivity.

Ltac t := repeat straightline; handle_call; [ prove_preconditions .. | ].

Lemma ladderstep_correct :
  program_logic_goal_for_function! ladderstep.
Proof.
  straightline_init_with_change.
  Time
  repeat t.

  (* now prove postcondition *)
  repeat split; try reflexivity.
  repeat lazymatch goal with
         | |- exists _, _ => eexists
         | |- _ /\ _ => split
         end;
    lazymatch goal with
    | |- sep _ _ _ => clear_old_seps; ecancel_assumption
    | _ => idtac
    end.
  all: try prove_bounds.
  cbv [ladderstep_gallina MxDH.ladderstep].
  repeat match goal with
           |- (_ , _) = (_ , _) => apply f_equal2
         end.
  all:solve_F_eq.
Qed.


Require Import VST.msl.msl_standard.
Require Import VST.msl.Coqlib2.

Set Implicit Arguments.

Lemma share_lemma87:
  forall a b, Share.glb a b = Share.bot -> Share.glb (Share.comp a) b = b.
Proof.
intros.
rewrite <- (Share.glb_top b) at 2.
rewrite (Share.glb_commute b).
rewrite <- (Share.comp1 a).
rewrite (Share.glb_commute (Share.lub _ _)).
rewrite Share.distrib1.
rewrite (Share.glb_commute b).
rewrite H.
rewrite (Share.lub_commute Share.bot), Share.lub_bot.
apply Share.glb_commute.
Qed.

Lemma join_top_comp:
  forall a b, join a b Share.top -> Share.comp a = b.
Proof.
intros.
destruct H.
pose proof (share_lemma87 H).
rewrite <- H1.
rewrite Share.glb_commute.
symmetry.
rewrite <- (Share.comp_inv b).
apply share_lemma87.
rewrite <- Share.demorgan1.
rewrite Share.lub_commute, H0.
clear.
pose proof (Share.comp1 Share.bot).
rewrite Share.lub_commute, Share.lub_bot in H.
rewrite <- H.
rewrite Share.comp_inv.
auto.
Qed.

Lemma comp_bot: Share.comp Share.bot = Share.top.
Proof.
apply join_top_comp.
apply bot_join_eq.
Qed.

Lemma share_distrib1':
      forall w x y z : Share.t,
       Share.glb (Share.lub w x) (Share.lub y z) =
       Share.lub (Share.lub (Share.glb w y)  (Share.glb x y))
                     (Share.lub (Share.glb w z) (Share.glb x z)).
Proof.
intros.
rewrite Share.distrib1.
rewrite <- (Share.glb_commute y), <- (Share.glb_commute z).
rewrite !Share.distrib1.
f_equal; f_equal; apply Share.glb_commute.
Qed.

Lemma share_distrib2':
   forall w x y z : Share.t,
       Share.lub (Share.glb w x) (Share.glb y z) =
       Share.glb (Share.glb (Share.lub w y) (Share.lub x y))
                      (Share.glb (Share.lub w z) (Share.lub x z)).
Proof.
intros.
rewrite Share.distrib2.
rewrite <- (Share.lub_commute y), <- (Share.lub_commute z).
rewrite !Share.distrib2.
f_equal; f_equal; apply Share.lub_commute.
Qed.

Lemma lub_bot_e:
  forall x y, Share.lub x y = Share.bot -> x = Share.bot /\ y = Share.bot.
Proof.
intros.
pose proof (Share.lub_upper1 x y).
pose proof (Share.lub_upper2 x y).
rewrite H in H0,H1.
split; apply Share.ord_antisym; auto; apply Share.bot_correct.
Qed.

Lemma glb_less_both:
  forall a L b R,
   Share.Ord a L -> Share.Ord b R ->
   Share.Ord (Share.glb a b) (Share.glb L R).
Proof.
 intros.
 generalize (Share.glb_lower1 a b);intro.
 generalize (Share.glb_lower2 a b);intro.
 generalize (Share.ord_trans _ _ _ H1 H);intro.
 generalize (Share.ord_trans _ _ _ H2 H0);intro.
 eapply Share.glb_greatest;auto.
Qed.

Lemma comp_Lsh_Rsh:
  Share.comp Share.Lsh = Share.Rsh.
Proof.
 unfold Share.Lsh, Share.Rsh.
 destruct (Share.split Share.top) eqn:?H; simpl.
 apply split_join in H.
 apply join_top_comp; auto.
Qed.

Lemma share_lemma88:
   forall sh, Share.glb sh Share.Rsh = Share.bot ->
                 join_sub sh Share.Lsh.
Proof.
 intros.
 exists (Share.glb (Share.comp sh) Share.Lsh).
 rewrite <- (Share.comp_inv Share.Lsh) at 1.
 rewrite comp_Lsh_Rsh.
 split.
*
 rewrite <- Share.glb_assoc.
 rewrite Share.comp2. rewrite Share.glb_commute. apply Share.glb_bot.
*
 rewrite <- Share.demorgan1.
 rewrite <- Share.comp_inv; symmetry; rewrite <- Share.comp_inv; symmetry.
 f_equal.
 rewrite comp_Lsh_Rsh.
 rewrite <- (Share.comp_inv sh) at 1.
 rewrite <- Share.demorgan2.
 rewrite Share.comp_inv.
 rewrite Share.distrib1.
 rewrite Share.glb_commute.
 rewrite Share.comp2.
 rewrite Share.lub_commute,  Share.lub_bot.
 forget Share.Rsh as b.
 apply share_lemma87; auto.
Qed.

Definition Tsh : share := Share.top.

Definition nonempty_share (sh: share) :=
       sepalg.nonidentity sh.
Definition readable_share (sh: share) :=
       nonempty_share (Share.glb Share.Rsh sh).
Definition writable_share (sh: share) :=
    nonempty_share (Share.glb Share.Lsh sh) /\ join_sub Share.Rsh sh.

Lemma lub_Lsh_Rsh:
 Share.lub Share.Lsh Share.Rsh = Share.top.
Proof.
unfold Share.Lsh, Share.Rsh.
destruct (Share.split Share.top) eqn:H; simpl.
apply Share.split_together; auto.
Qed.

Lemma glb_Lsh_Rsh:
 Share.glb Share.Lsh Share.Rsh = Share.bot.
Proof.
unfold Share.Lsh, Share.Rsh.
destruct (Share.split Share.top) eqn:H; simpl.
apply (Share.split_disjoint _ _ _ H).
Qed.

Lemma readable_share_dec:
  forall sh, {readable_share sh}+{~ readable_share sh}.
Proof.
intros.
unfold readable_share, nonempty_share.
unfold nonidentity.
destruct (dec_share_identity (Share.glb Share.Rsh sh)); [ right | left]; auto.
Defined.

Lemma writable_share_dec: forall sh, {writable_share sh} + {~ writable_share sh}.
Proof.
  unfold writable_share. intros.
  destruct (Share.EqDec_share (Share.glb Share.Rsh sh) Share.Rsh); [|right].
*
  destruct (Share.EqDec_share (Share.glb Share.Lsh sh) Share.bot); [right|left].
 + intros [? ?]. rewrite e0 in H. apply H. apply bot_identity.
 +
  split. unfold nonempty_share, nonidentity. contradict n.
  apply identity_share_bot; auto.
  clear n.
  exists (Share.glb Share.Lsh sh).
  split.
  -
  rewrite <- Share.glb_assoc.
  rewrite (Share.glb_commute Share.Rsh).
  unfold Share.Rsh, Share.Lsh.
  destruct (Share.split Share.top) eqn:?. simpl.
  apply Share.split_disjoint in Heqp. rewrite Heqp.
  rewrite Share.glb_commute, Share.glb_bot. auto.
  -
  apply Share.distrib_spec with Share.Rsh.
  rewrite <- Share.lub_assoc. rewrite Share.lub_idem.
  rewrite Share.distrib2.
  rewrite Share.lub_commute.
  destruct (Share.split Share.top) eqn:?.
  unfold Share.Lsh, Share.Rsh at 1.
  rewrite Heqp. simpl.
  rewrite (Share.split_together _ _ _ Heqp).
  rewrite Share.glb_commute, Share.glb_top. auto.
  rewrite Share.glb_absorb. rewrite e. auto.
*
  contradict n.
  destruct n as [_ [a [? ?]]].
  subst sh.
  rewrite Share.glb_absorb. auto.
Qed.

Lemma writable_readable:
 forall sh, writable_share sh -> readable_share sh.
Proof.
unfold writable_share, readable_share.
intros. destruct H as [_ H].
intro.
destruct H as [a ?].
destruct H.
subst sh.
rewrite Share.glb_absorb in H0.
clear - H0. unfold Share.Rsh in H0.
destruct (Share.split Share.top) eqn:?. simpl in H0.
apply split_nontrivial' in Heqp; auto.
apply top_share_nonidentity in Heqp. auto.
Qed.

Lemma readable_share_top:
  readable_share Share.top.
Proof.
hnf. intros.
rewrite Share.glb_top in H.
unfold Share.Rsh in H.
destruct (Share.split Share.top) eqn:?.
apply split_nontrivial' in Heqp.
apply identity_share_bot in Heqp.
apply Share.nontrivial; auto.
simpl in H; auto.
Qed.
Hint Resolve writable_readable.

Lemma top_pfullshare: forall psh, pshare_sh psh = Share.top -> psh = pfullshare.
Proof.
intros psh H.
apply lifted_eq; auto.
Qed.

Lemma fst_split_fullshare_not_bot: fst (Share.split fullshare) <> Share.bot.
Proof.
intro.
case_eq (Share.split fullshare); intros.
rewrite H0 in H. simpl in H. subst.
apply Share.split_nontrivial in H0; auto.
apply Share.nontrivial in H0. contradiction.
Qed.

Lemma fst_split_fullshare_not_top: fst (Share.split fullshare) <> Share.top.
Proof.
case_eq (Share.split fullshare); intros.
simpl; intro. subst.
apply nonemp_split_neq1 in H.
apply H; auto.
apply top_share_nonidentity.
Qed.

Lemma glb_Rsh_not_top:
   forall sh, Share.glb Share.Rsh sh <> Share.top.
Proof.
 intros.
 intro.
 unfold Share.Rsh in H.
 destruct (Share.split Share.top) eqn:?H.
  pose proof (Share.split_disjoint _ _ _ H0).
 simpl in H.
  pose proof (Share.glb_lower1 t0 sh).
  rewrite H in H2.
  apply leq_join_sub in H2.
  destruct H2. destruct H2.
  rewrite Share.lub_commute, Share.lub_top in H3.
  subst.
  clear - H0.
  apply nonemp_split_neq2 in H0; auto.
  intro. apply identity_share_bot in H.
  contradiction Share.nontrivial.
Qed.
Arguments glb_Rsh_not_top sh _ : clear implicits.

Lemma writable_share_top: writable_share Tsh.
Proof.
red.
split.
*
rewrite Share.glb_top.
unfold Share.Lsh.
intro.
destruct (Share.split Share.top) eqn:?H.
apply split_nontrivial' in H0; auto.
apply identity_share_bot in H0.
apply Share.nontrivial; auto.
*
exists Share.Lsh.
apply join_comm.
unfold Share.Lsh, Share.Rsh, Tsh.
destruct (Share.split Share.top) eqn:?. simpl.
apply split_join; auto.
Qed.
Hint Resolve writable_share_top.

Lemma writable_readable_share:
 forall sh, writable_share sh -> readable_share sh.
Proof.
apply writable_readable; auto.
Qed.
Hint Resolve writable_readable_share.

Definition extern_retainer := fst (Share.split Share.Lsh).

Definition Ews (* extern_write_share *) :=
  Share.lub extern_retainer Share.Rsh.

Lemma writable_Ews: writable_share Ews.
Proof.
split; unfold Ews.
*
unfold extern_retainer.
rewrite Share.distrib1.
rewrite glb_Lsh_Rsh, Share.lub_bot.
destruct (Share.split Share.Lsh) eqn:?H.
assert (H1: nonempty_share t). {
 intro. apply identity_share_bot in H0. subst.
 apply Share.split_nontrivial in H; auto.
 unfold Share.Lsh in H.
 destruct (Share.split Share.top) eqn:?H.
 apply Share.split_nontrivial in H0; auto.
 apply Share.nontrivial; auto.
}
apply split_join in H.
simpl.
destruct H.
rewrite <- H0.
rewrite Share.glb_commute, Share.distrib1.
rewrite H, Share.lub_bot.
rewrite Share.glb_idem; auto.
*
apply leq_join_sub.
apply Share.lub_upper2.
Qed.

Lemma writable_Rsh: writable_share Share.Rsh.
Proof.
  unfold writable_share.
Abort.  (* Not true any more *)

Hint Resolve writable_Ews.

Definition Ers (* Extern read share *) :=
  Share.lub extern_retainer (fst (Share.split Share.Rsh)).

Lemma readable_nonidentity: forall sh, readable_share sh -> sepalg.nonidentity sh.
Proof.
intros.
do 2 red in H.
red in H|-*. contradict H.
apply identity_share_bot in H. subst.
rewrite Share.glb_bot.
apply bot_identity.
Qed.

Hint Resolve readable_nonidentity.

Lemma sub_glb_bot:
  forall r a c : share,
   sepalg.join_sub a c ->
   Share.glb r c = Share.bot ->
   Share.glb r a = Share.bot.
Proof.
intros.
apply leq_join_sub in H.
apply Share.ord_spec1 in H.
rewrite H. rewrite <- Share.glb_assoc.
rewrite (Share.glb_commute r).
rewrite Share.glb_assoc. rewrite H0.
apply Share.glb_bot.
Qed.

Lemma glb_split: forall sh,
 Share.glb (fst (Share.split sh)) (snd (Share.split sh)) = Share.bot.
Proof.
intros.
destruct (Share.split sh) eqn:?H.
simpl.
apply split_join in H.
destruct H.
auto.
Qed.

Lemma Lsh_nonidentity:   sepalg.nonidentity Share.Lsh.
Proof.
unfold Share.Lsh.
destruct (Share.split Share.top) eqn:?. simpl; intro.
apply identity_share_bot in H. subst.
pose proof (Share.split_nontrivial _ _ _ Heqp).
spec H;[auto | ].
apply Share.nontrivial in H. auto.
Qed.

Lemma Rsh_nonidentity:   sepalg.nonidentity Share.Rsh.
Proof.
unfold Share.Rsh.
destruct (Share.split Share.top) eqn:?. simpl; intro.
apply identity_share_bot in H. subst.
pose proof (Share.split_nontrivial _ _ _ Heqp).
spec H;[auto | ].
apply Share.nontrivial in H. auto.
Qed.

Lemma nonidentity_extern_retainer: ~identity extern_retainer.
Proof.
unfold extern_retainer.
intro.
destruct (Share.split Share.Lsh) eqn:?H.
simpl in H.
apply split_nontrivial' in H0; auto.
apply Lsh_nonidentity.
auto.
Qed.

Lemma glb_split_x:
  forall a, Share.glb a (fst (Share.split a)) = fst (Share.split a).
Proof.
intros.
destruct (Share.split a) eqn:H; simpl in *.
destruct (split_join _ _ _ H).
subst a.
rewrite Share.glb_commute, Share.distrib1.
rewrite H0.
rewrite Share.glb_idem.
rewrite Share.lub_bot.
auto.
Qed.

Lemma readable_Ers: readable_share Ers.
Proof.
hnf; intros.
unfold Ers in H.
unfold extern_retainer in H.
rewrite Share.distrib1 in H.
apply identity_share_bot in H.
match type of H with Share.lub ?A _ = _ => forget A as a end.
rewrite glb_split_x in H.
pose proof (Share.lub_upper2 a (fst (Share.split Share.Rsh))).
rewrite H in H0.
apply leq_join_sub in H0.
destruct H0.
apply split_identity in H0; auto.
clear - H0.
destruct (Share.split Share.Rsh) eqn:?. simpl in *.
apply identity_share_bot in H0. subst.
pose proof (Share.split_nontrivial _ _ _ Heqp).
spec H;[auto | ].
assert (identity Share.Rsh) by (rewrite H; auto).
contradiction Rsh_nonidentity.
Qed.

Lemma join_sub_readable:
  forall sh sh', sepalg.join_sub sh sh' -> readable_share sh -> readable_share sh'.
Proof.
unfold readable_share;
intros.
hnf in H0|-*.
contradict H0.
apply identity_share_bot in H0.
eapply sub_glb_bot in H0; eauto.
rewrite H0.
apply bot_identity.
Qed.

Lemma join_unreadable_shares:
 forall sh1 sh2 sh,
  sepalg.join sh1 sh2 sh ->
  ~ readable_share sh1 ->
  ~ readable_share sh2 ->
 ~ readable_share sh.
Proof.
unfold readable_share; intros.
unfold nonempty_share in *.
unfold sepalg.nonidentity in *.
contradict H0. contradict H1. contradict H0.
destruct H.
subst sh.
apply identity_share_bot in H1.
apply identity_share_bot in H0.
rewrite Share.distrib1, H0,H1.
rewrite Share.lub_bot.
apply bot_identity.
Qed.

Lemma readable_share_join_left:
  forall sh1 sh2 sh,
    sepalg.join sh1 sh2 sh ->
    readable_share sh1 -> readable_share sh.
Proof.
intros.
unfold readable_share, nonempty_share, nonidentity in *.
contradict H0.
destruct H.
subst sh.
rewrite Share.distrib1 in H0.
pose proof (Share.lub_upper1 (Share.glb Share.Rsh sh1) (Share.glb Share.Rsh sh2)).
apply identity_share_bot in H0. rewrite H0 in H1.
pose proof Share.bot_correct (Share.glb Share.Rsh sh1).
pose proof (Share.ord_antisym _ _ H1 H2).
rewrite H3.
apply bot_identity.
Qed.

Lemma readable_share_join:
  forall sh1 sh2 sh,
    sepalg.join sh1 sh2 sh ->
    readable_share sh1 \/ readable_share sh2 -> readable_share sh.
Proof.
  intros.
  destruct H0.
  + eapply readable_share_join_left; eauto.
  + apply join_comm in H.
    eapply readable_share_join_left; eauto.
Qed.

Lemma Lsh_bot_neq: Share.Lsh <> Share.bot.
Proof.
  pose proof Lsh_nonidentity.
  pose proof bot_identity.
  intro.
  rewrite <- H1 in H0.
  apply H; auto.
Qed.

Lemma not_nonunit_bot: forall sh, ~ nonunit sh <-> sh = Share.bot.
Proof.
  intros; split; intros.
  + destruct (dec_share_identity sh).
    - apply identity_share_bot; auto.
    - exfalso; apply H.
      apply nonidentity_nonunit.
      auto.
  + subst.
    intro.
    apply nonunit_nonidentity in H.
    apply H.
    apply bot_identity.
Qed.

Lemma join_readable1:
  forall sh1 sh2 sh3,
    join sh1 sh2 sh3 ->
    readable_share sh1 -> readable_share sh3.
Proof.
intros.
eapply readable_share_join; eauto.
Qed.

Lemma join_readable2:
  forall sh1 sh2 sh3,
    join sh1 sh2 sh3 ->
    readable_share sh2 -> readable_share sh3.
Proof.
intros.
eapply readable_share_join; eauto.
Qed.

Lemma bot_unreadable: ~readable_share Share.bot.
Proof.
intro.
unfold readable_share, nonempty_share, nonidentity in H.
apply H; clear H.
rewrite Share.glb_bot. apply bot_identity.
Qed.

Definition pure_readable_share (sh: Share.t) :=
  Share.glb Share.Lsh sh = Share.bot /\ readable_share sh.

Definition rshare := sig pure_readable_share.

Definition readable_part: forall (sh: Share.t) (rsh: readable_share sh), rshare.
intros.
exists (Share.glb Share.Rsh sh).
split.
rewrite <- Share.glb_assoc. rewrite glb_Lsh_Rsh.
rewrite Share.glb_commute. apply Share.glb_bot.
unfold readable_share.
rewrite <- Share.glb_assoc.
rewrite Share.glb_idem.
apply rsh.
Defined.

Lemma readable_not_identity: forall sh P,
  readable_share sh -> identity sh -> P.
Proof.
 intros.
 unfold readable_share in H.
 unfold nonempty_share, nonidentity in H. contradiction H.
 apply identity_share_bot in H0; subst.
 rewrite Share.glb_bot. apply bot_identity.
Qed.
Arguments readable_not_identity sh P _ _ : clear implicits.

Lemma comp_parts:
  forall L R : Share.t,
  Share.comp L = R ->
  forall sh: Share.t, sh = Share.lub (Share.glb L sh) (Share.glb R sh).
Proof.
intros.
subst R.
rewrite <- !(Share.glb_commute sh).
rewrite <- Share.distrib1.
rewrite Share.comp1.
rewrite Share.glb_top. auto.
Qed.

Lemma join_comp_parts:
  forall L R : Share.t,
  Share.comp L = R ->
  forall a b c : Share.t,
  join a b c ->
  (join (Share.glb L a) (Share.glb L b) (Share.glb L c) /\
   join (Share.glb R a) (Share.glb R b) (Share.glb R c)).
Proof.
intros.
split; split.
*
rewrite (comp_parts H a) in H0.
rewrite (comp_parts H b) in H0.
rewrite (comp_parts H c) in H0.
destruct H0 as [H0 _].
pose proof (@glb_less_both
             (Share.glb L a) (Share.lub (Share.glb L a) (Share.glb R a))
             (Share.glb L b) (Share.lub (Share.glb L b) (Share.glb R b))).
apply Share.ord_antisym; [ | apply Share.bot_correct].
eapply Share.ord_trans; try apply H1; try apply Share.lub_upper1.
rewrite H0. apply Share.ord_refl.
*
destruct H0 as [_ H0].
subst c.
rewrite <- Share.distrib1. auto.
*
rewrite (comp_parts H a) in H0.
rewrite (comp_parts H b) in H0.
rewrite (comp_parts H c) in H0.
destruct H0 as [H0 _].
pose proof (@glb_less_both
             (Share.glb R a) (Share.lub (Share.glb L a) (Share.glb R a))
             (Share.glb R b) (Share.lub (Share.glb L b) (Share.glb R b))).
apply Share.ord_antisym; [ | apply Share.bot_correct].
eapply Share.ord_trans; try apply H1; try apply Share.lub_upper2.
rewrite H0. apply Share.ord_refl.
*
destruct H0 as [_ H0].
subst c.
rewrite <- Share.distrib1. auto.
Qed.

Lemma join_pure_readable:
  forall sh1 sh2 sh3,
    join sh1 sh2 sh3 ->
    pure_readable_share sh1 ->
    pure_readable_share sh2 ->
    pure_readable_share sh3.
Proof.
intros.
destruct H0,H1.
split.
destruct (join_comp_parts comp_Lsh_Rsh H).
rewrite H0,H1 in *. apply join_unit1_e in H4; auto.
eapply readable_share_join; eauto.
Qed.

Instance Join_rshare: Join rshare :=
  fun a b c => join (proj1_sig a) (proj1_sig b) (proj1_sig c).

Instance Perm_rshare: Perm_alg rshare. (* move me! *)
Proof.
  unfold rshare.
  constructor; intros.
*
  destruct z, z'. apply exist_ext.
  do 2 red in H, H0. simpl in *. eapply join_eq; eauto.
*
  destruct a,b,c,d,e; do 2 red in H,H0. simpl in *.
  destruct (join_assoc H H0) as [a [? ?]].
  assert (pure_readable_share a).
  eapply join_pure_readable; eauto.
  exists (exist pure_readable_share _ H3).
  split; eassumption.
*
  destruct a,b,c; do 2 red in H|-*; simpl in *. apply join_comm; auto.
*
  destruct a,a',b,b'; do 2 red in H,H0; simpl in *.
  apply exist_ext.
  eapply join_positivity; eauto.
Qed.

Lemma dec_readable sh : {readable_share sh}+{~readable_share sh}.
Proof.
unfold readable_share, nonempty_share, nonidentity.
destruct (dec_share_identity (Share.glb Share.Rsh sh));[right|left].
intro. contradiction.
auto.
Defined.

Lemma dec_pure_readable sh : {pure_readable_share sh}+{~pure_readable_share sh}.
Proof.
unfold pure_readable_share.
apply sumbool_dec_and.
apply eq_dec.
unfold readable_share, nonempty_share, nonidentity.
destruct (dec_share_identity (Share.glb Share.Rsh sh));[right|left].
intro. contradiction.
auto.
Defined.

Lemma dec_share_identity': forall sh: Share.t, Decidable.decidable (identity sh).
Proof.
intros.
destruct (dec_share_identity sh); [left|right]; auto.
Qed.

Lemma not_not_share_identity: forall sh: Share.t,
  ~ ~ (identity sh) -> identity sh.
Proof.
intros.
 apply (Decidable.not_not _ (dec_share_identity' _)). auto.
Qed.

Lemma join_readable_part_eq:
  forall sh1 (rsh1: readable_share sh1)
         sh2 (nsh2: ~readable_share sh2)
         sh3 (rsh3: readable_share sh3),
        join sh1 sh2 sh3 ->
        readable_part rsh1 = readable_part rsh3.
Proof.
 intros.
 apply exist_ext.
 apply not_not_share_identity in nsh2.
 destruct H. subst sh3.
 apply identity_share_bot in nsh2.
 rewrite Share.distrib1. rewrite nsh2. rewrite Share.lub_bot.
 auto.
Qed.

Lemma join_readable_part:
  forall sh1 (rsh1: readable_share sh1) sh2 (rsh2: readable_share sh2) sh3 (rsh3: readable_share sh3),
   join sh1 sh2 sh3 ->
  join (readable_part rsh1) (readable_part rsh2)(readable_part rsh3).
Proof.
intros.
red. red. simpl.
destruct H. subst.
split.
rewrite Share.glb_assoc. rewrite (Share.glb_commute sh1).
rewrite <- Share.glb_assoc.
rewrite <- (Share.glb_assoc Share.Rsh).
rewrite Share.glb_idem. rewrite Share.glb_assoc.
rewrite (Share.glb_commute sh2). rewrite H.
apply Share.glb_bot.
rewrite <- Share.distrib1. auto.
Qed.

Lemma share_self_join_bot:
  forall sh: Share.t, join sh sh sh -> sh = Share.bot.
Proof.
 intros.
  destruct H.
  rewrite Share.glb_idem in H. auto.
Qed.

Definition retainer_part (sh: Share.t) := Share.glb Share.Lsh sh.

Lemma retainer_part_nonreadable:
  forall sh, ~readable_share (retainer_part sh).
Proof.
 intros.
 unfold readable_share, retainer_part, nonempty_share, nonidentity.
 intro. apply H; clear H.
 rewrite <- Share.glb_assoc.
 rewrite (Share.glb_commute Share.Rsh).
 rewrite glb_Lsh_Rsh.
 rewrite Share.glb_commute, Share.glb_bot.
 apply bot_identity.
Qed.
Arguments retainer_part_nonreadable: clear implicits.

Lemma readable_share_lub:
 forall a b: Share.t, readable_share b -> readable_share (Share.lub a b).
Proof.
intros.
do 3 red in H|-*.
contradict H.
apply identity_share_bot in H.
rewrite Share.distrib1 in H.
apply lub_bot_e in H. destruct H.
rewrite H0.
apply bot_identity.
Qed.

Lemma retainer_part_join: forall sh1 sh2 sh3,
  join sh1 sh2 sh3 -> join (retainer_part sh1) (retainer_part sh2) (retainer_part sh3).
Proof.
intros.
 unfold retainer_part.
 destruct H; subst; simpl  in *; split.
 rewrite Share.glb_assoc. rewrite (Share.glb_commute sh1).
 rewrite <- Share.glb_assoc. rewrite <- Share.glb_assoc. rewrite Share.glb_idem.
 rewrite Share.glb_assoc. rewrite (Share.glb_commute sh2). rewrite H.
 apply Share.glb_bot.
 rewrite <- Share.distrib1. auto.
Qed.

Lemma not_readable_Rsh_part:
 forall sh, ~ readable_share sh -> Share.glb Share.Rsh sh = Share.bot.
Proof.
intros.
apply not_not_share_identity in H.
apply identity_share_bot in H. auto.
Qed.

Lemma join_parts1:
  forall L R (HC: Share.comp L = R) sh1 sh2 sh,
         join sh1 sh2 (Share.glb L sh) ->
         Share.glb L sh1 = sh1 /\
         Share.glb R sh1 = Share.bot.
Proof.
intros.
cut (Share.glb L sh1 = sh1).
*
intro. split; auto.
rewrite <- H0.
rewrite <- Share.glb_assoc.
rewrite (Share.glb_commute R).
subst R. rewrite Share.comp2.
rewrite Share.glb_commute.
apply Share.glb_bot.
*
assert (Share.Ord sh1 L).
apply Share.ord_trans with (Share.glb L sh).
apply leq_join_sub.
exists sh2; auto.
apply Share.glb_lower1.
clear H.
apply Share.ord_spec1 in H0.
symmetry.
rewrite Share.glb_commute.
auto.
Qed.

Lemma join_parts:
  forall L R (HC: Share.comp L = R) sh1 sh2 sh,
         join sh1 sh2 (Share.glb L sh) ->
         Share.glb L sh1 = sh1 /\
         Share.glb R sh1 = Share.bot /\
         Share.glb L sh2 = sh2 /\
         Share.glb R sh2 = Share.bot.
Proof.
intros.
destruct (join_parts1 HC H).
destruct (join_parts1 HC (join_comm H)).
split3; auto.
Qed.

Lemma comp_Rsh_Lsh: Share.comp Share.Rsh = Share.Lsh.
Proof.
rewrite <- (Share.comp_inv Share.Lsh).
f_equal. symmetry. apply comp_Lsh_Rsh.
Qed.

Lemma glb_twice: forall a b, Share.glb a (Share.glb a b) = Share.glb a b.
Proof.
intros. rewrite <- Share.glb_assoc. rewrite Share.glb_idem; auto.
Qed.

Lemma glb_Lsh_Rsh':
  forall sh, Share.glb Share.Lsh (Share.glb Share.Rsh sh) = Share.bot.
Proof.
intros.
rewrite <- Share.glb_assoc. rewrite glb_Lsh_Rsh.
rewrite Share.glb_commute; apply Share.glb_bot.
Qed.

Lemma comp_parts_join:
 forall L R (HC: Share.comp L = R) a b c,
  join (Share.glb L a) (Share.glb L b) (Share.glb L c) ->
  join (Share.glb R a) (Share.glb R b) (Share.glb R c) ->
  join a b c.
Proof.
intros.
subst R.
split.
*
destruct H,H0.
clear H1 H2.
rewrite <- (Share.glb_top a), <- (Share.glb_commute Share.top).
rewrite <- (Share.comp1 L).
rewrite !(Share.glb_commute (Share.lub _ _)).
rewrite !Share.distrib1.
rewrite <- (Share.glb_top b), <- (Share.glb_commute Share.top).
rewrite <- (Share.comp1 L).
rewrite !(Share.glb_commute _ b).
rewrite (Share.distrib1 b).
rewrite !(Share.glb_commute a).
rewrite !(Share.glb_commute b).
pose proof (Share.glb_lower1 L a).
pose proof (Share.glb_lower1 L b).
pose proof (Share.glb_lower2 a (Share.comp L)). rewrite Share.glb_commute in H3.
pose proof (Share.glb_lower2 b (Share.comp L)). rewrite Share.glb_commute in H4.
forget (Share.glb L a) as al.
forget (Share.glb (Share.comp L) a) as ar.
forget (Share.glb L b) as bl.
forget (Share.glb (Share.comp L) b) as br.
rewrite Share.distrib1.
rewrite (Share.glb_commute _ bl).
rewrite Share.distrib1.
rewrite Share.glb_commute. rewrite H.
rewrite (Share.lub_commute Share.bot), Share.lub_bot.
rewrite (Share.glb_commute _ br).
rewrite Share.distrib1.
rewrite (Share.glb_commute br ar). rewrite H0.
rewrite Share.lub_bot.
apply Share.ord_spec1 in H1.
apply Share.ord_spec1 in H2.
apply Share.ord_spec1 in H3.
apply Share.ord_spec1 in H4.
rewrite H1,H2,H3,H4.
clear.
rewrite Share.glb_assoc. rewrite (Share.glb_commute ar). rewrite <- (Share.glb_assoc L).
rewrite (Share.comp2 L).
rewrite (Share.glb_commute Share.bot). rewrite Share.glb_bot.
rewrite Share.glb_bot.
rewrite (Share.lub_commute Share.bot). rewrite Share.lub_bot.
rewrite Share.glb_assoc. rewrite (Share.glb_commute al).
rewrite <- (Share.glb_assoc (Share.comp L)).
rewrite (Share.glb_commute (Share.comp L)).
rewrite (Share.comp2 L). rewrite (Share.glb_commute Share.bot). rewrite Share.glb_bot.
apply Share.glb_bot.
*
destruct H,H0.
clear H H0.
rewrite <- (Share.glb_top c).
rewrite <- (Share.comp1 L).
rewrite Share.distrib1.
rewrite !(Share.glb_commute c).
rewrite <- H1. rewrite <- H2.
rewrite Share.lub_assoc.
rewrite <- (Share.lub_assoc (Share.glb L b)).
rewrite (Share.lub_commute (Share.glb L b)).
rewrite Share.lub_assoc.
rewrite <- Share.lub_assoc.
f_equal.
rewrite !(Share.glb_commute _ a).
rewrite <- Share.distrib1.
rewrite (Share.comp1 L).
rewrite Share.glb_top.
auto.
rewrite !(Share.glb_commute _ b).
rewrite <- Share.distrib1.
rewrite (Share.comp1 L).
rewrite Share.glb_top.
auto.
Qed.

Lemma left_right_join:
 forall a b c,
  join (Share.glb Share.Lsh a) (Share.glb Share.Lsh b) (Share.glb Share.Lsh c) ->
  join (Share.glb Share.Rsh a) (Share.glb Share.Rsh b) (Share.glb Share.Rsh c) ->
  join a b c.
Proof.
apply comp_parts_join.
apply comp_Lsh_Rsh.
Qed.

Lemma lub_bot': forall sh, Share.lub Share.bot sh = sh.
Proof.
intros.
rewrite Share.lub_commute.
apply Share.lub_bot.
Qed.

Lemma glb_Rsh_Lsh: Share.glb Share.Rsh Share.Lsh = Share.bot.
Proof.
rewrite Share.glb_commute.
apply glb_Lsh_Rsh.
Qed.

Lemma join_writable1: forall sh1 sh2 sh,
   join sh1 sh2 sh -> writable_share sh1 -> writable_share sh.
Proof.
intros.
red in H0|-*.
destruct H0 as [H1 H0]; split.
*
unfold nonempty_share, nonidentity in *.
contradict H1.
destruct H0.
destruct (join_comp_parts comp_Rsh_Lsh H) as [_ ?].
apply split_identity in H2; auto.
*
eapply join_sub_trans; [apply H0 | ].
exists sh2; auto.
Qed.

Lemma join_writable_readable:
  forall {sh1 sh2 sh},
   join sh1 sh2 sh -> writable_share sh1 -> readable_share sh2 -> False.
Proof.
intros.
red in H0,H1.
destruct H0 as [_ [a ?]].
destruct (join_assoc (join_comm H0) H) as [f [? ?]].
destruct H2.
rewrite H2 in H1.
apply H1; auto.
Qed.

Definition writable0_share (sh: share) :=
    join_sub Share.Rsh sh.

Lemma writable_writable0: forall sh,
  writable_share sh -> writable0_share sh.
Proof.
intros.
destruct H. auto.
Qed.
Hint Resolve writable_writable0.

Lemma writable0_readable: forall sh,
  writable0_share sh -> readable_share sh.
Proof.
unfold writable_share, readable_share.
intros.
intro.
destruct H as [a ?].
destruct H.
subst sh.
rewrite Share.glb_absorb in H0.
clear - H0. unfold Share.Rsh in H0.
destruct (Share.split Share.top) eqn:?. simpl in H0.
apply split_nontrivial' in Heqp; auto.
apply top_share_nonidentity in Heqp. auto.
Qed.
Hint Resolve writable0_readable.

Lemma writable0_Rsh: writable0_share Share.Rsh.
Proof.
  unfold writable_share.
  apply join_sub_refl.
Qed.

Lemma join_writable0_readable:
  forall {sh1 sh2 sh},
   join sh1 sh2 sh -> writable0_share sh1 -> readable_share sh2 -> False.
Proof.
intros.
red in H0,H1.
destruct H0 as [a ?].
destruct (join_assoc (join_comm H0) H) as [f [? ?]].
destruct H2.
rewrite H2 in H1.
apply H1; auto.
Qed.

Lemma join_writable01: forall sh1 sh2 sh,
   join sh1 sh2 sh -> writable0_share sh1 -> writable0_share sh.
Proof.
intros.
red in H0|-*.
eapply join_sub_trans; [apply H0 | ].
exists sh2; auto.
Qed.

Lemma writable0_share_dec: forall sh, {writable0_share sh} + {~ writable0_share sh}.
Proof.
  unfold writable0_share. intros.
  destruct (Share.EqDec_share (Share.glb Share.Rsh sh) Share.Rsh); [left|right].
*
  exists (Share.glb Share.Lsh sh).
  split.
  -
  rewrite <- Share.glb_assoc.
  rewrite (Share.glb_commute Share.Rsh).
  unfold Share.Rsh, Share.Lsh.
  destruct (Share.split Share.top) eqn:?. simpl.
  apply Share.split_disjoint in Heqp. rewrite Heqp.
  rewrite Share.glb_commute, Share.glb_bot. auto.
  -
  apply Share.distrib_spec with Share.Rsh.
  rewrite <- Share.lub_assoc. rewrite Share.lub_idem.
  rewrite Share.distrib2.
  rewrite Share.lub_commute.
  destruct (Share.split Share.top) eqn:?.
  unfold Share.Lsh, Share.Rsh at 1.
  rewrite Heqp. simpl.
  rewrite (Share.split_together _ _ _ Heqp).
  rewrite Share.glb_commute, Share.glb_top. auto.
  rewrite Share.glb_absorb. rewrite e. auto.
*
  contradict n.
  destruct n as [a [? ?]].
  subst sh.
  rewrite Share.glb_absorb. auto.
Qed.

Lemma writable0_share_glb_Rsh:
  forall sh, writable0_share sh -> writable0_share (Share.glb Share.Rsh sh).
Proof.
intros.
unfold writable0_share in *.
apply leq_join_sub in H.
apply leq_join_sub.
apply Share.ord_spec1.
apply Share.ord_spec1 in H.
rewrite <- H.
rewrite Share.glb_idem; auto.
Qed.

Lemma glb_split_lemma1:
  forall a b, Share.glb Share.Rsh a = Share.glb Share.Rsh b ->
     Share.glb Share.Rsh (fst (Share.split a)) =
     Share.glb Share.Rsh (fst (Share.split b)).
Proof.
intros.
Abort.  (* Probably true, but not absolutely needed *)

Lemma glb_split_lemma2:
  forall a b, Share.glb Share.Rsh a = Share.glb Share.Rsh b ->
     Share.glb Share.Rsh (snd (Share.split a)) =
     Share.glb Share.Rsh (snd (Share.split b)).
Proof.
Abort.  (* Probably true, but not absolutely needed *)

Lemma fst_split_glb_orthogonal: forall sh : share,
identity (Share.glb Share.Rsh (fst (Share.split sh))) ->
identity (Share.glb Share.Rsh sh).
Proof.
Abort. (* not true? *)

Lemma snd_split_glb_orthogonal: forall sh : share,
identity (Share.glb Share.Rsh (snd (Share.split sh))) ->
identity (Share.glb Share.Rsh sh).
Abort.  (* not needed? *)

(** the following lemmas are useful in the concurrency proofs *)

  Lemma writable_not_join_readable:
    forall sh1 sh2,
      joins sh1 sh2 ->
      writable_share sh1 ->
      ~ readable_share sh2.
  Proof.
    intros.
    intro.
    destruct H as [sh ?].
    apply join_writable_readable in H; eauto.
 Qed.

  Lemma writable_not_join_writable :
    forall sh1 sh2,
      joins sh1 sh2 ->
      writable_share sh1 ->
      ~ writable_share sh2.
   Proof.
     intros. intro.
    pose proof (writable_not_join_readable H H0).
    apply H2. auto.
   Qed.

  Lemma only_bot_joins_top:
    forall sh, joins Share.top sh -> sh = Share.bot.
  Proof.
    intros. destruct H. destruct H.
    rewrite Share.glb_commute in H. rewrite Share.glb_top in H. auto.
  Qed.

(*
  Lemma glb_Rsh_not_top:
    forall sh, ~ Share.glb Share.Rsh sh = Share.top.
  Proof.
    intros. apply glb_Rsh_not_top.
  Qed.
*)
  Lemma writable0_right:
    forall sh,  writable0_share (Share.glb Share.Rsh sh) ->
           writable0_share sh.
  Proof.
     intros.
     unfold writable0_share in *.
     apply leq_join_sub in H.
     apply leq_join_sub.
     eapply Share.ord_trans; try eassumption.
     rewrite Share.glb_commute.
     apply Share.glb_lower1.
  Qed.

Lemma join_readable_unreadable:
  forall sh1 sh2 sh3,
    join sh1 sh2 sh3 ->
    ~ writable0_share sh1 ->
    ~ readable_share sh2 ->
    ~ writable0_share sh3.
 (* Not true for for writable, only for writable0 *)
Proof.
 intros.
 contradict H0.
 unfold writable0_share in *.
 destruct H0.
 destruct (join_comp_parts comp_Lsh_Rsh H) as [_ ?].
 destruct (join_comp_parts comp_Lsh_Rsh H0) as [_ ?].
 rewrite Share.glb_idem in H3.
 apply not_readable_Rsh_part in H1.
 rewrite H1 in H2.
 apply join_unit2_e in H2; [ | apply bot_identity].
 rewrite <- H2 in H3.
 assert (join_sub Share.Rsh (Share.glb Share.Rsh sh1)).
 eexists; eauto.
 apply leq_join_sub in H4.
 eapply leq_join_sub.
 eapply Share.ord_trans; eauto.
 apply Share.glb_lower2.
Qed.

Lemma readable_glb:
   forall sh,
     readable_share sh ->
     readable_share (Share.glb Share.Rsh sh).
 Proof.
   intros.
   unfold readable_share in *. rewrite glb_twice. auto.
 Qed.

 Lemma unreadable_glb:
   forall sh,
     ~readable_share sh ->
     ~readable_share (Share.glb Share.Rsh sh).
 Proof.
   intros.
   unfold readable_share in *. rewrite glb_twice. auto.
 Qed.

  Lemma nonreadable_emptyshare: ~ readable_share emptyshare.
  Proof.
    unfold emptyshare.
    intro.
    hnf in H.
    rewrite Share.glb_bot in H.
    apply H; auto.
  Qed.

Lemma join_comp_Tsh:
  forall sh, sepalg.join sh (Share.comp sh) Tsh.
Proof.
intros.
split.
apply Share.comp2.
apply Share.comp1.
Qed.


Require Export Basic_Definitions.
Require Export Finite_Character.

(** Axiom of Choice **)

Module Type Axiom_Choice.

Axiom Choice_Axiom : forall (X: Class),
  Ensemble X -> exists ε, Choice_Function ε X.

Hint Resolve Choice_Axiom : Axiom_of_Choice.

End Axiom_Choice.

(** Tukey's Lemma **)

Module Type Tukey_Lemma.

Declare Module AC : Axiom_Choice.

(* Hypotheses *)

Definition En_F' F f := \{ λ x, x ∈ (∪f) /\ (F ∪ [x])∈f \}.

Definition eq_dec (A : Type) := forall x y: A, {x = y} + {x <> y}.
Parameter beq : eq_dec Class.
Definition Fun_X (F f ε: Class) : Class :=
  match beq ((En_F' F f) ~ F) Φ with
  | left _ => F
  | right _ => F ∪ [ε[(En_F' F f)~F]]
  end.

Definition tSubclass f' f ε : Prop :=
  f' ⊂ f /\ Φ∈f' /\ (forall F, F∈f' -> (Fun_X F f ε) ∈ f')
  /\ (forall φ, φ ⊂ f' /\ Nest φ -> (∪φ) ∈ f').

Definition En_f'0 f ε := ∩ \{ λ f', tSubclass f' f ε \}.

Definition En_u C f ε := \{ λ A, A ∈ (En_f'0 f ε) /\ (A ⊂ C \/ C ⊂ A) \}.

Definition En_f'1 f ε : Class :=
  \{ λ C, C ∈ (En_f'0 f ε) /\ (En_u C f ε) = (En_f'0 f ε) \}.

Definition En_v D f ε : Class :=
  \{ λ A, A ∈ (En_f'0 f ε) /\ (A⊂D \/ (Fun_X D f ε) ⊂ A) \}.

(* Property Proof *)

Lemma Property_Φ : forall x y, y ⊂ x -> x ~ y = Φ <-> x = y.
Proof.
  intros; split; intros.
  - apply Property_ProperSubclass in H; destruct H; auto.
    apply Property_ProperSubclass' in H; destruct H as [z H], H.
    assert (z ∈ (x ~ y)).
    { unfold Setminus; apply Theorem4'; split; auto.
      unfold Complement; apply Axiom_Scheme; split; Ens. }
    rewrite H0 in H2; generalize (Theorem16 z); intros.
    contradiction.
  - rewrite <- H0; apply Axiom_Extent; split; intros.
    + unfold Setminus in H1; apply Theorem4' in H1.
      destruct H1; unfold Complement in H2.
      apply Axiom_Scheme in H2; destruct H2; contradiction.
    + generalize (Theorem16 z); intros; contradiction.
Qed.

Lemma Property_x : forall ε F f,
  Choice_Function ε (∪f) -> F∈f -> F ⊂ (Fun_X F f ε).
Proof.
  intros.
  generalize (classic ((En_F' F f) ~ F = Φ)); intros; destruct H1.
  - unfold Fun_X; destruct (beq (En_F' F f ~ F) Φ); try tauto.
    unfold Subclass; intros; auto.
  - unfold Fun_X; destruct (beq (En_F' F f ~ F) Φ); try tauto.
    unfold Subclass; intros; apply Theorem4; tauto.
Qed.

Lemma Ens_F'F : forall f F, Ensemble (∪ f) -> Ensemble (En_F' F f ~ F).
Proof.
  intros.
  assert (En_F' F f ~ F ⊂ ∪ f).
  { unfold Subclass; intros.
    unfold Setminus in H0; apply Theorem4' in H0; destruct H0.
    unfold En_F' in H0; apply Axiom_Scheme in H0; apply H0. }
  apply Theorem33 in H0; auto.
Qed.

Lemma Property_f'0 : forall f ε,
  Finite_Character f /\ f ≠ Φ -> Choice_Function ε (∪f) -> tSubclass (En_f'0 f ε) f ε
  /\ (forall f', f' ⊂ f /\ tSubclass f' f ε -> (En_f'0 f ε) ⊂ f').
Proof.
  intros; double H.
  apply Property_FinChar in H; unfold Finite_Character in H1; destruct H1, H1.
  apply Property_NotEmpty in H2; destruct H2 as [F H2]; split.
  - assert (tSubclass f f ε).
    { unfold tSubclass; repeat split; try apply H; intros.
      - unfold Subclass; intros; auto.
      - generalize (Theorem26 F); intros.
        apply H with (A:=F); split; auto.
      - generalize (classic((En_F' F0 f) ~ F0 = Φ)); intros; destruct H5.
        + unfold Fun_X; destruct (beq (En_F' F0 f ~ F0) Φ); tauto.
        + double H5; unfold Fun_X.
          destruct (beq (En_F' F0 f ~ F0) Φ); try tauto.
          unfold Choice_Function in H0; destruct H0, H7, H8.
          assert ((En_F' F0 f ~ F0) ∈ dom( ε)).
          { rewrite H8; unfold Setminus at 2; apply Theorem4'; split.
            - unfold PowerClass; apply Axiom_Scheme.
              apply Axiom_Amalgamation in H1.
              split; try (apply Ens_F'F); auto.
              unfold Subclass; intros; unfold Setminus in H10.
              apply Theorem4' in H10; destruct H10.
              unfold En_F' in H10; apply Axiom_Scheme in H10; apply H10.
            - unfold Complement; apply Axiom_Scheme; double H1.
              apply Axiom_Amalgamation in H10; split; try (apply Ens_F'F); auto.
              intro; unfold Singleton in H11; apply Axiom_Scheme in H11.
              destruct H11; rewrite H12 in H6; try contradiction.
              apply Theorem19; generalize (Theorem26 f); intros.
              apply Theorem33 in H13; auto. }
           apply H9 in H10; unfold Setminus in H10.
           apply Theorem4' in H10; destruct H10.
           unfold En_F' at 2 in H10; apply Axiom_Scheme in H10; apply H10. }
    assert ((En_f'0 f ε) ⊂ f).
    { unfold En_f'0; unfold Subclass; intros.
      unfold Element_I in H5; apply Axiom_Scheme in H5.
      apply H5; apply Axiom_Scheme; split; auto. }
    unfold tSubclass; repeat split; auto.
    + unfold En_f'0; apply Axiom_Scheme; split; intros.
      * generalize (Theorem26 f); intros; apply Theorem33 in H6; auto.
      * apply Axiom_Scheme in H6; destruct H6; unfold tSubclass in H7; apply H7.
    + intros; double H6; unfold Subclass in H5.
      apply H5 in H7; unfold tSubclass in H4; apply H4 in H7.
      unfold En_f'0; apply Axiom_Scheme; split; intros; Ens.
      apply Axiom_Scheme in H8; destruct H8.
      double H9; unfold tSubclass in H9; apply H9.
      unfold En_f'0 in H6; apply Axiom_Scheme in H6; destruct H6.
      apply H11; apply Axiom_Scheme; split; auto.
    + intros; unfold tSubclass in H4; destruct H6; double H6.
      add ((En_f'0 f ε) ⊂ f) H6; apply Theorem28 in H6.
      add (Nest φ) H6; apply H4 in H6; unfold En_f'0; apply Axiom_Scheme.
      split; Ens; intros; apply Axiom_Scheme in H9; destruct H9.
      unfold tSubclass in H10; apply H10; split; auto.
      assert ((En_f'0 f ε) ⊂ y).
      { unfold Subclass; intros; unfold En_f'0 in H11.
        unfold Element_I; apply Axiom_Scheme in H11.
        destruct H11; apply H12; apply Axiom_Scheme; split; auto. }
      add ((En_f'0 f ε) ⊂ y) H8; apply Theorem28 in H8; auto.
  - intros; destruct H4; unfold Subclass; intros.
    unfold En_f'0 in H6; unfold Element_I in H6.
    apply Axiom_Scheme in H6; destruct H6; apply H7.
    apply Axiom_Scheme; apply Theorem33 in H4; auto.
Qed.

Lemma FF' : forall (f ε F: Class),
  Finite_Character f /\ f ≠ Φ -> Choice_Function ε (∪f) -> F∈f ->
  (En_F' F f)~F ≠ Φ ->  F = F ∪ [ε[(En_F' F f)~F]] -> False.
Proof.
  intros.
  unfold Choice_Function in H0; assert (F~F=Φ).
  { unfold Φ; apply Axiom_Extent; split; intros.
    - unfold Setminus in H4; apply Theorem4' in H4; destruct H4.
      apply Axiom_Scheme in H5; destruct H5; contradiction.
    - apply Axiom_Scheme in H4; destruct H4; contradiction. }
  assert (F~F≠Φ); try contradiction.
  { rewrite H3 at 1; apply Property_NotEmpty; exists (ε [En_F' F f ~ F]).
    assert ((En_F' F f ~ F) ∈ dom( ε)).
    { destruct H0, H5, H6; rewrite H6; assert (En_F' F f ~ F ⊂ ∪ f).
      { unfold Subclass; intros; apply Theorem4' in H8; destruct H8.
        unfold En_F' in H8; apply Axiom_Scheme in H8; apply H8. }
      assert (Ensemble (En_F' F f ~ F)).
      { apply Theorem33 in H8; auto; destruct H.
        unfold Finite_Character in H; destruct H; apply Axiom_Amalgamation; auto. }
      unfold Setminus at 2; apply Theorem4'; split.
      - unfold PowerClass; apply Axiom_Scheme; split; auto.
      - unfold Complement; apply Axiom_Scheme; split; auto.
        unfold NotIn; intro; unfold Singleton in H10.
        apply Axiom_Scheme in H10; destruct H10; assert (Φ ∈ μ).
        { apply Theorem19; generalize (Theorem26 (∪ f)); intros.
          unfold Finite_Character in H; destruct H.
          apply Theorem33 in H12; auto; apply Axiom_Amalgamation; apply H. }
        apply H11 in H12; contradiction. }
    apply H0 in H5; unfold Setminus in H5.
    apply Axiom_Scheme in H5; destruct H5, H6; unfold Setminus.
    apply Theorem4'; split; auto; apply Theorem4; right.
    unfold Singleton; apply Axiom_Scheme; split; auto. }
Qed.

Lemma Property_F' : forall F f, F ∈ f -> F ⊂ (En_F' F f).
Proof.
  unfold En_F', Subclass; intros.
  apply Axiom_Scheme; repeat split; Ens.
  - unfold Element_U; apply Axiom_Scheme; split; Ens.
  - assert (F ∪ [z] = F).
    { apply Axiom_Extent; split; intros; try (apply Theorem4; tauto).
      apply Theorem4 in H1; destruct H1; auto.
      unfold Singleton in H1; apply Axiom_Scheme in H1.
      destruct H1; rewrite H2; auto; apply Theorem19; Ens. }
    rewrite H1; auto.
Qed.

(* Lemma Proof *)

Lemma LemmaT1 : forall f ε,
  Finite_Character f /\ f ≠ Φ -> Choice_Function ε (∪f) ->
  (forall D, D ∈ (En_f'1 f ε) -> tSubclass (En_v D f ε) f ε).
Proof.
  intros.
  apply (Property_f'0 _ ε) in H; auto; destruct H.
  assert ((En_v D f ε) ⊂ f).
  { unfold En_v; unfold Subclass; intros.
    apply Axiom_Scheme in H3; destruct H3, H4.
    unfold tSubclass in H; destruct H.
    unfold Subclass in H; apply H in H4; auto. }
  unfold tSubclass; repeat split; auto.
  - unfold En_v; apply Axiom_Scheme.
    unfold tSubclass in H; destruct H, H4.
    repeat split; Ens; left; apply Theorem26.
  - intro A; intros.
    double H4; unfold Subclass in H3; apply H3 in H4.
    unfold En_v in H5; unfold En_v.
    apply Axiom_Scheme; apply Axiom_Scheme in H5; destruct H5, H6.
    double H6; unfold tSubclass in H; apply H in H8.
    repeat split; Ens; destruct H7.
    + apply Property_ProperSubclass in H7; destruct H7.
      * left; generalize (classic ((Fun_X A f ε) ⊂ D)); intros.
        destruct H9; auto; unfold En_f'1 in H1; apply Axiom_Scheme in H1.
        destruct H1, H10; rewrite <- H11 in H8.
        unfold En_u in H8; apply Axiom_Scheme in H8; destruct H8, H12.
        apply Property_ProperSubclass'' in H13; auto.
        double H7; apply Property_ProperSubclass' in H7.
        double H13; apply Property_ProperSubclass' in H13.
        destruct H7, H13, H7, H13.
        generalize (classic (x=x0)); intros; destruct H18.
        -- rewrite H18 in H7; contradiction.
        -- unfold ProperSubclass in H15; destruct H15.
           unfold Subclass in H15; apply H15 in H7.
           assert (x0 ∉ A).
           { unfold NotIn; intro; unfold ProperSubclass in H14.
             destruct H14; unfold Subclass in H14.
             apply H14 in H20; contradiction. }
           generalize (classic ((En_F' A f)~A=Φ)); intros; destruct H21.
           ++ unfold Fun_X in H13; unfold NotIn in H20.
              destruct (beq (En_F' A f ~ A) Φ); tauto.
           ++ unfold Fun_X in H7, H8, H13.
              destruct (beq (En_F' A f ~ A) Φ); try tauto.
              apply Theorem4 in H7; apply Theorem4 in H13.
              destruct H7, H13; try contradiction.
              unfold Singleton in H13; apply Axiom_Scheme in H13.
              unfold Singleton in H7; apply Axiom_Scheme in H7.
              destruct H13, H7; apply Axiom_Union' in H8; destruct H8.
              apply Theorem42' in H24; apply Theorem19 in H24.
              double H24; apply H22 in H24; apply H23 in H25.
              rewrite <- H24 in H25; contradiction.
      * right; rewrite H7.
        unfold Subclass; intros; auto.
    + apply (Property_x ε _ _) in H4; auto.
      add (A ⊂ Fun_X A f ε) H7; apply Theorem28 in H7; auto.
  - intro ϑ; intros; destruct H4.
    unfold En_v; apply Axiom_Scheme.
    assert ((∪ ϑ) ∈ (En_f'0 f ε)).
    { unfold tSubclass in H; apply H; split; auto.
      red; intros; unfold Subclass in H4.
      apply H4 in H6; unfold En_v in H6.
      apply Axiom_Scheme in H6; apply H6. }
    repeat split; Ens.
    generalize (classic (forall B, B∈ϑ -> B ⊂ D)).
    intros; destruct H7.
    + left; unfold Subclass; intros.
      unfold Element_U in H8; apply Axiom_Scheme in H8.
      destruct H8, H9, H9; apply H7 in H10.
      unfold Subclass in H10; apply H10 in H9; auto.
    + apply not_all_ex_not in H7; destruct H7.
      apply imply_to_and in H7; destruct H7.
      double H7; unfold Subclass in H4; apply H4 in H7.
      unfold En_v in H7; apply Axiom_Scheme in H7.
      destruct H7, H10, H11; try contradiction.
      right; unfold Subclass; intros.
      unfold Element_U; apply Axiom_Scheme; split; Ens.
Qed.

Lemma LemmaT2 : forall f ε,
  Finite_Character f /\ f ≠ Φ -> Choice_Function ε (∪f) ->
  (forall D, D ∈ (En_f'1 f ε) -> (Fun_X D f ε) ∈ (En_f'1 f ε)).
Proof.
  intros; double H1.
  unfold En_f'1 in H2; apply Axiom_Scheme in H2.
  destruct H2, H3; double H3; unfold En_f'0 in H5.
  double H; apply (Property_f'0 _ ε) in H6; auto.
  destruct H6; unfold tSubclass in H6.
  double H3; apply H6 in H8; double H8.
  unfold En_f'0 in H9; destruct H6.
  unfold Subclass in H6; apply H6 in H3.
  apply (Property_x ε _ _) in H3; auto.
  assert ((En_v D f ε) ⊂ (En_u (Fun_X D f ε) f ε)).
  { unfold En_v, En_u, Subclass; intros.
    apply Axiom_Scheme in H11; apply Axiom_Scheme; destruct H11, H12.
    repeat split; auto; destruct H13; auto. }
  assert ((En_u (Fun_X D f ε) f ε) ⊂ (En_f'0 f ε)).
  { unfold En_u, Subclass; intros.
    apply Axiom_Scheme in H12; apply H12. }
  apply (LemmaT1 f ε) in H1; auto.
  unfold Finite_Character in H; destruct H, H.
  assert ((En_v D f ε) ⊂ f /\ tSubclass (En_v D f ε) f ε).
  { split; auto; unfold En_v, Subclass; intros.
    apply Axiom_Scheme in H15; destruct H15, H16.
    apply H6 in H16; auto. }
  apply H7 in H15; add ((En_v D f ε) ⊂ (En_u (Fun_X D f ε) f ε)) H15.
  apply Theorem28 in H15.
  add ((En_f'0 f ε) ⊂ (En_u (Fun_X D f ε) f ε)) H12.
  apply Theorem27 in H12; auto.
  unfold En_f'1; apply Axiom_Scheme; repeat split; Ens.
Qed.

Lemma LemmaT3 : forall f ε,
  Finite_Character f /\ f ≠ Φ -> Choice_Function ε (∪f) -> Nest (En_f'0 f ε).
Proof.
  intros; double H.
  apply (Property_f'0 _ ε) in H1; auto; destruct H1.
  assert ((En_f'1 f ε) ⊂ (En_f'0 f ε) /\ Nest (En_f'1 f ε)).
  { assert ((En_f'1 f ε) ⊂ (En_f'0 f ε)).
    { unfold Subclass; intros.
      unfold En_f'1 in H3; apply Axiom_Scheme in H3; apply H3. }
    split; auto; unfold tSubclass in H1.
    add ((En_f'0 f ε) ⊂ f) H3; try apply H1.
    apply Theorem28 in H3; unfold Finite_Character in H; destruct H, H.
    apply Theorem33 with (z:=(En_f'1 f ε)) in H; auto.
    unfold Nest; intros; unfold En_f'1 in H6; destruct H6.
    apply Axiom_Scheme in H6; apply Axiom_Scheme in H7.
    destruct H6, H7, H8, H9; rewrite <- H11 in H8.
    unfold En_u in H8; apply Axiom_Scheme in H8; apply H8. }
  destruct H3.
  assert ((En_f'1 f ε) ⊂ f /\ tSubclass (En_f'1 f ε) f ε).
  { unfold tSubclass in H1.
    add ((En_f'0 f ε) ⊂ f) H3; try apply H1.
    apply Theorem28 in H3; split; auto.
    unfold tSubclass; repeat split; auto; intros.
    - unfold En_f'1; apply Axiom_Scheme.
      destruct H1, H5; repeat split; Ens.
      apply Axiom_Extent; split; intros.
      + unfold En_u; apply Axiom_Scheme in H7; apply H7.
      + unfold En_u; apply Axiom_Scheme; repeat split; Ens.
        right; apply Theorem26.
    - apply (LemmaT2 _ ε); auto.
    - unfold En_f'1; apply Axiom_Scheme.
      assert ((∪ φ) ∈ (En_f'0 f ε)).
      { destruct H5; assert (φ ⊂ (En_f'0 f ε)).
        { unfold Subclass; intros.
          unfold Subclass in H5; apply H5 in H7.
          unfold En_f'1; apply Axiom_Scheme in H7; apply H7. }
        add (Nest φ) H7; apply H1 in H7; auto. }
      repeat split; Ens.
      apply Axiom_Extent; split; intros.
      + unfold En_u in H7; apply Axiom_Scheme in H7; apply H7.
      + unfold En_u; apply Axiom_Scheme; repeat split; Ens.
        generalize (classic (forall B, B ∈ φ -> B ⊂ z)).
        intros; destruct H8.
        * right; unfold Subclass; intros.
          unfold Element_U in H9; apply Axiom_Scheme in H9.
          destruct H9, H10, H10; apply H8 in H11.
          unfold Subclass in H11; apply H11; auto.
        * apply not_all_ex_not in H8; destruct H8.
          apply imply_to_and in H8; destruct H5, H8.
          double H8; unfold Subclass in H5; apply H5 in H8.
          unfold En_f'1 in H8; apply Axiom_Scheme in H8; destruct H8, H12.
          rewrite <- H13 in H7; unfold En_u in H7; apply Axiom_Scheme in H7.
          destruct H7, H14; destruct H15; try contradiction.
          left; unfold Subclass; intros.
          unfold Element_U; apply Axiom_Scheme; split; Ens. }
  apply H2 in H5; add ((En_f'1 f ε) ⊂ (En_f'0 f ε)) H5.
  apply Theorem27 in H5; auto; rewrite H5; auto.
Qed.

Lemma LemmaT4 : forall f ε,
  Finite_Character f /\ f ≠ Φ -> Choice_Function ε (∪f) -> (∪ En_f'0 f ε) ∈ f /\
  (Fun_X (∪ (En_f'0 f ε)) f ε) = ∪ (En_f'0 f ε).
Proof.
  intros; double H.
  apply (Property_f'0 _ ε) in H1; auto.
  destruct H1; unfold tSubclass in H1.
  assert ((En_f'0 f ε) ⊂ (En_f'0 f ε) /\ Nest (En_f'0 f ε)).
  { split; try unfold Subclass; auto.
    apply (LemmaT3 _ ε) in H; auto. }
  apply H1 in H3; split.
  - destruct H1; unfold Subclass in H1; apply H1 in H3; auto.
  - unfold En_f'0 at 2 in H3; destruct H1.
    unfold Subclass in H1; double H3; apply H1 in H5.
    apply (Property_x ε _ _) in H5; auto.
    assert ((Fun_X (∪ (En_f'0 f ε)) f ε) ⊂ ∪ (En_f'0 f ε)).
    { apply H4 in H3; unfold Subclass; intros.
    unfold Element_U; apply Axiom_Scheme; split; Ens. }
    apply Theorem27; auto.
Qed.

(* Tukey's Lemma Proof *)

Theorem Tukey : forall (f: Class),
  Finite_Character f /\ f ≠ Φ -> exists x, MaxMember x f.
Proof.
  intros; double H.
  unfold Finite_Character in H0; destruct H0, H0.
  assert (Ensemble (∪f)). { apply Axiom_Amalgamation in H0; auto. }
  apply AC.Choice_Axiom in H3; destruct H3 as [ε H3].
  assert (exists F, F∈f /\ (En_F' F f) ~ F = Φ).
  { exists (∪(En_f'0 f ε)); double H3.
    apply (LemmaT4 _ ε) in H4; auto; destruct H4; split; auto.
    generalize (classic(En_F'(∪ En_f'0 f ε)f~(∪ En_f'0 f ε)=Φ)).
    intros; destruct H6; auto.
    assert ((Fun_X (∪ (En_f'0 f ε)) f ε) = (∪ En_f'0 f ε) ∪
    [ε [En_F' (∪ En_f'0 f ε) f ~ (∪ En_f'0 f ε)]]).
    { unfold Fun_X; destruct (beq (En_F' (∪ En_f'0 f ε) f ~
      (∪ En_f'0 f ε)) Φ); tauto. }
    rewrite H5 in H7; apply FF' in H7; auto; inversion H7. }
  destruct H4 as [F H4]; destruct H4; exists F.
  apply -> Property_Φ in H5; try (apply Property_F'; auto).
  unfold MaxMember; intro; clear H6; repeat split; auto; intros F' H6; intro.
  double H7; rewrite <- H5 in H8; apply Property_ProperSubclass' in H8.
  destruct H8 as [z H8], H8; assert (F' ⊂ (En_F' F f)).
  { unfold En_F', Subclass; intros; apply Axiom_Scheme; repeat split; Ens.
    - unfold Element_U; apply Axiom_Scheme; split; Ens.
    - assert ((F ∪ [z0]) ⊂ F').
      { unfold ProperSubclass in H7; destruct H7.
        unfold Subclass in H7; unfold Subclass; intros.
        apply Theorem4 in H12; destruct H12; try (apply H7 in H12; auto).
        unfold Singleton in H12; apply Axiom_Scheme in H12.
        destruct H12; rewrite H13; auto; apply Theorem19; Ens. }
      apply Property_FinChar in H; apply H with (A:= F'); split; auto. }
  unfold Subclass in H10; apply H10 in H8; contradiction.
Qed.

Hint Resolve Tukey : Axiom_of_Choice.

End Tukey_Lemma.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import coqutil.Word.Interface.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.PushButtonSynthesis.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.ReifiedOperation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Translation.Proofs.ValidComputable.Func.
Require Import Crypto.Util.Tactics.SpecializeBy.
Local Open Scope Z_scope.
Import ListNotations.
Import AbstractInterpretation.Compilers.

Class bedrock2_wbwmontgomery_funcs :=
  { mul : func;
    square : func;
    add : func;
    sub : func;
    opp : func;
    to_montgomery : func;
    from_montgomery : func;
    nonzero : func;
    selectznz : func;
    to_bytes : func;
    from_bytes : func }.

Class bedrock2_wbwmontgomery_specs
      {funcs : bedrock2_wbwmontgomery_funcs }:=
  { spec_of_mul : spec_of (fst mul);
    spec_of_square : spec_of (fst square);
    spec_of_add : spec_of (fst add);
    spec_of_sub : spec_of (fst sub);
    spec_of_opp : spec_of (fst opp);
    spec_of_to_montgomery : spec_of (fst to_montgomery);
    spec_of_from_montgomery : spec_of (fst from_montgomery);
    spec_of_nonzero : spec_of (fst nonzero);
    spec_of_selectznz : spec_of (fst selectznz);
    spec_of_to_bytes : spec_of (fst to_bytes);
    spec_of_from_bytes : spec_of (fst from_bytes) }.

Class bedrock2_wbwmontgomery_correctness
      {funcs : bedrock2_wbwmontgomery_funcs}
      {specs : bedrock2_wbwmontgomery_specs} :=
  { mul_correct :
      forall functions,
        spec_of_mul (mul :: functions);
    square_correct :
      forall functions,
        spec_of_square (square :: functions);
    add_correct :
      forall functions,
        spec_of_add (add :: functions);
    sub_correct :
      forall functions,
        spec_of_sub (sub :: functions);
    opp_correct :
      forall functions,
        spec_of_opp (opp :: functions);
    to_montgomery_correct :
      forall functions,
        spec_of_to_montgomery (to_montgomery :: functions);
    from_montgomery_correct :
      forall functions,
        spec_of_from_montgomery (from_montgomery :: functions);
    nonzero_correct :
      forall functions,
        spec_of_nonzero (nonzero :: functions);
    selectznz_correct :
      forall functions,
        spec_of_selectznz (selectznz :: functions);
    to_bytes_correct :
      forall functions,
        spec_of_to_bytes (to_bytes :: functions);
    from_bytes_correct :
      forall functions,
        spec_of_from_bytes (from_bytes :: functions) }.

Class names_of_operations :=
  { name_of_mul : string;
    name_of_square : string;
    name_of_add : string;
    name_of_sub : string;
    name_of_opp : string;
    name_of_to_montgomery : string;
    name_of_from_montgomery : string;
    name_of_nonzero : string;
    name_of_selectznz : string;
    name_of_to_bytes : string;
    name_of_from_bytes : string }.

Record wbwmontgomery_reified_ops
  {width BW word mem locals env ext_spec varname_gen error}
  {parameters_sentinel : @Types.parameters width BW word mem locals env ext_spec varname_gen error}
       {names : names_of_operations} {m} :=
  { reified_mul :
      reified_op name_of_mul
                 (Generic.WordByWordMontgomery.mul m)
                 (PushButtonSynthesis.WordByWordMontgomery.mul m width);
    reified_square :
      reified_op name_of_square
                 (Generic.WordByWordMontgomery.square m)
                 (PushButtonSynthesis.WordByWordMontgomery.square m width);
    reified_add :
      reified_op name_of_add
                 (Generic.WordByWordMontgomery.add m)
                 (PushButtonSynthesis.WordByWordMontgomery.add m width);
    reified_sub :
      reified_op name_of_sub
                 (Generic.WordByWordMontgomery.sub m)
                 (PushButtonSynthesis.WordByWordMontgomery.sub m width);
    reified_opp :
      reified_op name_of_opp
                 (Generic.WordByWordMontgomery.opp m)
                 (PushButtonSynthesis.WordByWordMontgomery.opp m width);
    reified_to_montgomery :
      reified_op name_of_to_montgomery
                 (Generic.WordByWordMontgomery.to_montgomery m)
                 (PushButtonSynthesis.WordByWordMontgomery.to_montgomery m width);
    reified_from_montgomery :
      reified_op name_of_from_montgomery
                 (Generic.WordByWordMontgomery.from_montgomery m)
                 (PushButtonSynthesis.WordByWordMontgomery.from_montgomery m width);
    reified_nonzero :
      reified_op name_of_nonzero
                 (Generic.WordByWordMontgomery.nonzero m)
                 (PushButtonSynthesis.WordByWordMontgomery.nonzero m width);
    reified_selectznz :
      reified_op name_of_selectznz
                 (Generic.WordByWordMontgomery.selectznz m)
                 (PushButtonSynthesis.WordByWordMontgomery.selectznz m width);
    reified_to_bytes :
      reified_op name_of_to_bytes
                 (Generic.WordByWordMontgomery.to_bytes m)
                 (PushButtonSynthesis.WordByWordMontgomery.to_bytes m width);
    reified_from_bytes :
      reified_op name_of_from_bytes
                 (Generic.WordByWordMontgomery.from_bytes m)
                 (PushButtonSynthesis.WordByWordMontgomery.from_bytes m width) }.
Arguments wbwmontgomery_reified_ops {_ _ _ _ _ _ _ _ _ _ _} m.

(*** Helpers ***)

Definition names_from_prefix (prefix : string)
  : names_of_operations :=
  {| name_of_mul := (prefix ++ "mul")%string;
     name_of_square := (prefix ++ "square")%string;
     name_of_add := (prefix ++ "add")%string;
     name_of_sub := (prefix ++ "sub")%string;
     name_of_opp := (prefix ++ "opp")%string;
     name_of_to_montgomery := (prefix ++ "to_montgomery")%string;
     name_of_from_montgomery := (prefix ++ "from_montgomery")%string;
     name_of_nonzero := (prefix ++ "nonzero")%string;
     name_of_selectznz := (prefix ++ "selectznz")%string;
     name_of_to_bytes := (prefix ++ "to_bytes")%string;
     name_of_from_bytes := (prefix ++ "from_bytes")%string
  |}.

(*** Synthesis Tactics ***)

Ltac funcs_from_ops ops :=
  let mul_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_mul ops))) in
  let square_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_square ops))) in
  let add_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_add ops))) in
  let sub_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_sub ops))) in
  let to_montgomery_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_to_montgomery ops))) in
  let from_montgomery_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_from_montgomery ops))) in
  let opp_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_opp ops))) in
  let nonzero_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_nonzero ops))) in
  let selectznz_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_selectznz ops))) in
  let to_bytes_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_to_bytes ops))) in
  let from_bytes_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_from_bytes ops))) in
  exact {| mul := mul_func_value;
           square := square_func_value;
           add := add_func_value;
           sub := sub_func_value;
           opp := opp_func_value;
           to_montgomery := to_montgomery_func_value;
           from_montgomery := from_montgomery_func_value;
           nonzero := nonzero_func_value;
           selectznz := selectznz_func_value;
           to_bytes := to_bytes_func_value;
           from_bytes := from_bytes_func_value |}.

Ltac specs_from_ops ops m :=
  let p := lazymatch type of ops with wbwmontgomery_reified_ops(parameters_sentinel:=?p) _ => p end in
  let mul_name := (eval compute in name_of_mul) in
  let square_name := (eval compute in name_of_square) in
  let add_name := (eval compute in name_of_add) in
  let sub_name := (eval compute in name_of_sub) in
  let opp_name := (eval compute in name_of_opp) in
  let to_montgomery_name := (eval compute in name_of_to_montgomery) in
  let from_montgomery_name := (eval compute in name_of_from_montgomery) in
  let nonzero_name := (eval compute in name_of_nonzero) in
  let selectznz_name := (eval compute in name_of_selectznz) in
  let to_bytes_name := (eval compute in name_of_to_bytes) in
  let from_bytes_name := (eval compute in name_of_from_bytes) in
  let mul_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.mul
                 Generic.WordByWordMontgomery.spec_of_mul] in
          (Generic.WordByWordMontgomery.spec_of_mul
             (parameters_sentinel:=p) m mul_name)) in
  let square_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.square
                 Generic.WordByWordMontgomery.spec_of_square] in
          (Generic.WordByWordMontgomery.spec_of_square
             (parameters_sentinel:=p) m square_name)) in
  let add_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.add
                 Generic.WordByWordMontgomery.spec_of_add] in
          (Generic.WordByWordMontgomery.spec_of_add
             (parameters_sentinel:=p) m add_name)) in
  let sub_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.sub
                 Generic.WordByWordMontgomery.spec_of_sub] in
          (Generic.WordByWordMontgomery.spec_of_sub
             (parameters_sentinel:=p) m sub_name)) in
  let to_montgomery_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.to_montgomery
                 Generic.WordByWordMontgomery.spec_of_to_montgomery] in
          (Generic.WordByWordMontgomery.spec_of_to_montgomery
             (parameters_sentinel:=p) m to_montgomery_name)) in
  let from_montgomery_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.from_montgomery
                 Generic.WordByWordMontgomery.spec_of_from_montgomery] in
          (Generic.WordByWordMontgomery.spec_of_from_montgomery
             (parameters_sentinel:=p) m from_montgomery_name)) in
  let opp_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.opp
                 Generic.WordByWordMontgomery.spec_of_opp] in
          (Generic.WordByWordMontgomery.spec_of_opp
             (parameters_sentinel:=p) m opp_name)) in
  let nonzero_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.nonzero
                 Generic.WordByWordMontgomery.spec_of_nonzero] in
          (Generic.WordByWordMontgomery.spec_of_nonzero
             (parameters_sentinel:=p) m nonzero_name)) in
  let selectznz_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.selectznz
                 Generic.WordByWordMontgomery.spec_of_selectznz] in
          (Generic.WordByWordMontgomery.spec_of_selectznz
             (parameters_sentinel:=p) m selectznz_name)) in
  let to_bytes_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.to_bytes
                 Generic.WordByWordMontgomery.spec_of_to_bytes] in
          (Generic.WordByWordMontgomery.spec_of_to_bytes
             (parameters_sentinel:=p) m to_bytes_name)) in
  let from_bytes_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.from_bytes
                 Generic.WordByWordMontgomery.spec_of_from_bytes] in
          (Generic.WordByWordMontgomery.spec_of_from_bytes
             (parameters_sentinel:=p) m from_bytes_name)) in
  exact {| spec_of_mul := mul_spec;
           spec_of_square := square_spec;
           spec_of_add := add_spec;
           spec_of_sub := sub_spec;
           spec_of_opp := opp_spec;
           spec_of_to_montgomery := to_montgomery_spec;
           spec_of_from_montgomery := from_montgomery_spec;
           spec_of_nonzero := nonzero_spec;
           spec_of_selectznz := selectznz_spec;
           spec_of_to_bytes := to_bytes_spec;
           spec_of_from_bytes := from_bytes_spec |}.

Ltac handle_easy_preconditions :=
  lazymatch goal with
  | |- ZRange.type.option.is_tighter_than _ _ = true =>
    abstract vm_cast_no_check (eq_refl true)
  | |- Types.ok => solve [typeclasses eauto]
  | |- _ = ErrorT.Success _ => solve [apply reified_eq]
  | |- API.Wf _ => solve [apply reified_Wf]
  | |- Func.valid_func _ => solve [apply reified_valid]
  | _ => first [ apply inname_gen_varname_gen_disjoint
               | apply outname_gen_varname_gen_disjoint
               | apply outname_gen_inname_gen_disjoint
               | apply prefix_name_gen_unique ]
  | |- ?g => fail "Unrecognized goal" g
  end.

Ltac use_correctness_proofs p m :=
  let Hc := fresh in
  match goal with
  | |- context [Generic.WordByWordMontgomery.mul] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.mul_correct
  | |- context [Generic.WordByWordMontgomery.square] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.square_correct
  | |- context [Generic.WordByWordMontgomery.add] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.add_correct
  | |- context [Generic.WordByWordMontgomery.sub] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.sub_correct
  | |- context [Generic.WordByWordMontgomery.opp] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.opp_correct
  | |- context [Generic.WordByWordMontgomery.to_montgomery] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.to_montgomery_correct
  | |- context [Generic.WordByWordMontgomery.from_montgomery] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.from_montgomery_correct
  | |- context [Generic.WordByWordMontgomery.nonzero] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.nonzero_correct
  | |- context [Generic.WordByWordMontgomery.selectznz] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.selectznz_correct
  | |- context [Generic.WordByWordMontgomery.to_bytes] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.to_bytes_correct
  | |- context [Generic.WordByWordMontgomery.from_bytes] =>
    Coq.Program.Tactics.rapply @Generic.WordByWordMontgomery.from_bytes_correct
  end.

Ltac change_with_computed_func ops :=
  lazymatch goal with
  | |- context [mul] =>
    change mul with (computed_bedrock_func (reified_mul ops))
  | |- context [square] =>
    change square with (computed_bedrock_func (reified_square ops))
  | |- context [add] =>
    change add with (computed_bedrock_func (reified_add ops))
  | |- context [sub] =>
    change sub with (computed_bedrock_func (reified_sub ops))
  | |- context [opp] =>
    change opp with (computed_bedrock_func (reified_opp ops))
  | |- context [to_montgomery] =>
    change to_montgomery with (computed_bedrock_func (reified_to_montgomery ops))
  | |- context [from_montgomery] =>
    change from_montgomery with (computed_bedrock_func (reified_from_montgomery ops))
  | |- context [nonzero] =>
    change nonzero with (computed_bedrock_func (reified_nonzero ops))
  | |- context [selectznz] =>
    change selectznz with (computed_bedrock_func (reified_selectznz ops))
  | |- context [to_bytes] =>
    change to_bytes with (computed_bedrock_func (reified_to_bytes ops))
  | |- context [from_bytes] =>
    change from_bytes with (computed_bedrock_func (reified_from_bytes ops))
  end.

Ltac prove_correctness ops m :=
  let width := lazymatch type of ops with wbwmontgomery_reified_ops(width:=?width) _ => width end in
  assert (WordByWordMontgomery.check_args
            m width [] (ErrorT.Success tt) =
          ErrorT.Success tt) by abstract (native_compute; reflexivity);
  lazymatch goal with
    | |- bedrock2_wbwmontgomery_correctness => econstructor end;
  change_with_computed_func ops; rewrite computed_bedrock_func_eq;
  let p := lazymatch type of ops with wbwmontgomery_reified_ops(parameters_sentinel:=?p) _ => p end in
  use_correctness_proofs p m; try assumption;
  handle_easy_preconditions.

Ltac make_names_of_operations prefix :=
  match goal with
  | |- names_of_operations =>
    let n := eval vm_compute in (names_from_prefix prefix) in
        exact n
  end.

Ltac make_reified_ops :=
  lazymatch goal with
    |- wbwmontgomery_reified_ops ?m =>
    eapply Build_wbwmontgomery_reified_ops
  end; prove_reified_op.