(*
Copyright © 2009 Valentin Blot

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import CPoly_Degree Lia.
Import CRing_Homomorphisms.coercions.

Set Implicit Arguments.
Unset Strict Implicit.

Section poly_eucl.
Variable CR : CRing.

Add Ring CR: (CRing_Ring CR).
Add Ring cpolycring_th : (CRing_Ring (cpoly_cring CR)).

Lemma degree_poly_div : forall (m n : nat) (f g : cpoly CR),
  let f1 := (_C_ (nth_coeff n g) [*] f [-] _C_ (nth_coeff (S m) f) [*] ((_X_ [^] ((S m) - n)) [*] g)) in
    S m >= n -> degree_le (S m) f -> degree_le n g -> degree_le m f1.
Proof.
 intros m n f g f1 ge_m_n df dg p Hp; unfold f1; clear f1.
 rewrite -> nth_coeff_minus, nth_coeff_c_mult_p, nth_coeff_c_mult_p, nth_coeff_mult.
 rewrite -> (Sum_term _ _ _ (S m - n)); [ | lia | lia | intros ].
  rewrite -> nth_coeff_nexp_eq.
  destruct Hp.
   replace (S m - (S m - n)) with n by lia.
   unfold cg_minus. ring.
  rewrite -> (dg (S m0 - (S m - n))); [ | lia].
  rewrite -> df; [ unfold cg_minus; ring | lia].
 rewrite nth_coeff_nexp_neq. ring. assumption.
Qed.

Theorem cpoly_div1 : forall (m n : nat) (f g : cpoly_cring CR),
  degree_le m f -> degree_le (S n) g -> n <= m ->
    {qr: (cpoly_cring CR)*(cpoly_cring CR) &
    let (q,r):=qr in f [*] _C_ ((nth_coeff (S n) g) [^] (m - n)) [=] q [*] g [+] r &
    let (q,r):=qr in degree_le n r}.
Proof.
 intros m n; generalize (refl_equal (m - n)).
 generalize (m - n) at 1 as p; intro p; revert m n; induction p; intros.
  exists (([0] : cpoly_cring CR),f).
   rewrite <- H.
   simpl (nth_coeff (S n) g[^]0). rewrite <- c_one. ring.
  replace n with m by lia; assumption.
 set (f1 := (_C_ (nth_coeff (S n) g) [*] f [-] _C_ (nth_coeff m f) [*] ((_X_ [^] (m - (S n))) [*] g))).
 destruct (IHp (m - 1) n) with (f := f1) (g := g); [ lia | | assumption | lia | ].
  unfold f1; clear f1.
  assert (HypTmp : m = S (m - 1)); [ lia | rewrite HypTmp; rewrite <- HypTmp at 1 ].
  apply degree_poly_div; [ lia | rewrite <- HypTmp; assumption | assumption ].
 destruct x as [q1 r1].
 exists (q1 [+] _C_ ((nth_coeff (S n) g)[^](m - S n) [*] (nth_coeff m f)) [*] _X_ [^] (m - S n), r1); [ | assumption].
 unfold f1 in y.
 rewrite -> ring_distl_unfolded. rewrite <- plus_assoc_unfolded. rewrite -> (cag_commutes _ _ r1). rewrite -> plus_assoc_unfolded. rewrite  <- y.
 replace (m - n) with (S (m - S n)) by lia.
 replace (m - 1 - n) with (m - S n) by lia.
 rewrite <- nexp_Sn.
 generalize (nth_coeff (S n) g) (nth_coeff m f) (m - S n).
 intros. rewrite c_mult, c_mult. unfold cg_minus. ring.
Qed.

Definition degree_lt_pair (p q : cpoly_cring CR) := (forall n : nat, degree_le (S n) q -> degree_le n p) and (degree_le O q -> p [=] [0]).
Lemma cpoly_div2 : forall (n m : nat) (a b c : cpoly_cring CR),
  degree_le n a -> monic m b -> degree_lt_pair c b -> a [*] b [=] c ->
    a [=] [0].
Proof.
 induction n.
  intros m a b c H X H1 H2; destruct (degree_le_zero _ _ H) as [x s].
  revert H1. rewrite -> s; destruct X as [H0 H1]; rewrite -> c_zero. rewrite -> s in H2. intro. apply cpoly_const_eq.
  destruct m.
   generalize (nth_coeff_wd _ 0 _ _ H2); destruct H3 as [d s0].
   rewrite -> nth_coeff_c_mult_p, H0, mult_one, (nth_coeff_wd _ _ _ _ (s0 H1)). intro tmp; apply tmp.
   generalize (nth_coeff_wd _ (S m) _ _ H2); destruct H3 as [d s0].
  rewrite -> nth_coeff_c_mult_p, H0, mult_one, (d m H1 (S m)).  intro; assumption. apply le_n.
  intros.
 induction a as [ | a s ] using cpoly_induc; [ reflexivity | ].
 apply _linear_eq_zero.
 revert H2. rewrite -> cpoly_lin, ring_distl_unfolded. intro H2.
 cut (a [=] [0]); [ intro aeqz; split; [ | apply aeqz ] | ].
  assert (s [=] nth_coeff m (_C_ s[*]b[+]_X_[*]a[*]b)).
   destruct H0; rewrite -> nth_coeff_plus, nth_coeff_c_mult_p, H0.
   rewrite -> (nth_coeff_wd _ _ _ [0]); [ simpl; ring | ].
   rewrite -> aeqz; ring.
  rewrite -> H3.
  rewrite -> (nth_coeff_wd _ _ _ _ H2).
  destruct H1 as [d s0].
  destruct H0 as [H0 H1].
  destruct m; [ rewrite -> (nth_coeff_wd _ _ _ _ (s0 H1)); reflexivity | apply (d m H1); apply le_n ].
 apply (IHn (S m) _ ([0] [+X*] b) (c [-] _C_ s [*] b)); [ | | | rewrite <- H2, cpoly_lin, <- c_zero; unfold cg_minus; ring ].
   unfold degree_le; intros; rewrite <- (coeff_Sm_lin _ _ s).
   apply H; apply lt_n_S; apply H3.
  split; [ rewrite -> coeff_Sm_lin; destruct H0; apply H0 | unfold degree_le; intros ].
  destruct m0; [ inversion H3 | simpl; destruct H0 ].
  apply H4; apply lt_S_n; apply H3.
 unfold degree_lt_pair.
 split; intros.
  unfold degree_le; intros.
  rewrite -> nth_coeff_minus, nth_coeff_c_mult_p, (degree_le_cpoly_linear _ _ _ _ H3); [ | apply H4 ].
  rewrite -> cring_mult_zero, cg_inv_zero; destruct H1 as [d s0].
  destruct m; [ destruct H0; apply (nth_coeff_wd _ _ _ _ (s0 H1)) | ].
  apply (d n0); [ | apply H4 ].
  apply (degree_le_mon _ _ n0); [ apply le_S; apply le_n | apply (degree_le_cpoly_linear _ _ _ _ H3) ].
 destruct (degree_le_zero _ _ H3) as [x s0]. revert s0. rewrite -> cpoly_C_. intro s0.
 destruct (linear_eq_linear_ _ _ _ _ _ s0) as [H4 H5].
 rewrite <- H2, -> H5. unfold cg_minus. ring.
Qed.

Lemma cpoly_div : forall (f g : cpoly_cring CR) (n : nat), monic n g ->
  ex_unq (fun (qr : ProdCSetoid (cpoly_cring CR) (cpoly_cring CR)) => f[=](fst qr)[*]g[+](snd qr) and degree_lt_pair (snd qr) g).
Proof.
 intros f g n H; destruct n.
  destruct H; destruct (degree_le_zero _ _ H0).
  rewrite -> (nth_coeff_wd _ _ _ _ s) in H. simpl in H; rewrite -> H in s.
  exists (f,[0]).
   intros; destruct y; simpl (snd (s0, s1)) in *; simpl (fst (s0, s1)) in *.
   rename H1 into X. destruct X; destruct d; split; [ | symmetry; apply (s3 H0) ].
   rewrite -> s2, (s3 H0), s, <- c_one; ring.
  simpl (fst (f, [0] : cpoly_cring CR)); simpl (snd (f, [0] : cpoly_cring CR)).
  replace (cpoly_zero CR) with ([0] : cpoly_cring CR) by (simpl;reflexivity).
  split; [ rewrite -> s, <- c_one; ring | ].
  split; [ | reflexivity ].
  unfold degree_le; intros; apply nth_coeff_zero.
 destruct (@cpoly_div1 (max (lth_of_poly f) n) n f g); [ | destruct H; assumption | apply le_max_r | ].
  apply (@degree_le_mon _ _ (lth_of_poly f)); [ apply le_max_l | apply poly_degree_lth ].
 destruct H; destruct x as [q r].
 rewrite -> H, one_nexp, mult_one in y.
 assert (f[=]q[*]g[+]r and degree_lt_pair r g).
  split; [ assumption | ].
  split.
   intros; unfold degree_le; intros; apply y0; apply le_lt_trans with n0; [ | assumption ].
   unfold degree_le in H1; apply not_gt; intro; unfold gt in H3.
   set (tmp := (H1 (S n) (lt_n_S _ _ H3))); rewrite -> H in tmp.
   apply (eq_imp_not_ap _ _ _ tmp); apply ring_non_triv.
  intro; unfold degree_le in H1; rewrite -> H1 in H; [ | apply lt_O_Sn ].
  destruct (eq_imp_not_ap _ _ _ H); apply ap_symmetric; apply ring_non_triv.
 exists (q,r); [ | assumption ].
 intros y1 X0; destruct y1 as [q1 r1]; simpl (fst (q1, r1)); simpl (snd (q1, r1)) in X0.
 rename H1 into X. destruct X; destruct X0; rewrite -> s in s0; assert (q [=] q1).
  apply cg_inv_unique_2.
  apply (@cpoly_div2 (lth_of_poly (q [-] q1)) (S n) (q [-] q1) g (r1 [-] r)); [ apply poly_degree_lth | split; assumption | | ].
   destruct d; destruct d0; split.
    intros; apply degree_le_minus; [ apply d0 | apply d ]; assumption.
   intro; rewrite -> (s1 H1) ,(s2 H1); unfold cg_minus; ring.
  assert (r1[=]q1[*]g[+]r1[-]q1[*]g); [ unfold cg_minus; ring | ].
  rewrite -> H1, <- s0; unfold cg_minus; ring.
 split; [ assumption | ].
 rewrite -> H1 in s0; apply (cg_cancel_lft _ _ _ _ s0).
Qed.

End poly_eucl.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

Require Import ClassicalEpsilon.

Inductive _map (a b:Type) :=
  | _map_constr : (a -> b) -> _map a b.

(* Why3 goal *)
Definition map : forall (a:Type) (b:Type), Type.
intros.
exact (_map a b).
Defined.

Global Instance map_WhyType : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Proof.
intros.
repeat split.
exact (fun _ => why_inhabitant).
intros x y.
apply excluded_middle_informative.
Qed.

(* Why3 goal *)
Definition get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.
intros a a_WT b b_WT (m) x.
exact (m x).
Defined.

(* Why3 goal *)
Definition set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).
intros a a_WT b b_WT (m) x y.
split.
intros x'.
destruct (why_decidable_eq x x') as [H|H].
exact y.
exact (m x').
Defined.

(* Why3 goal *)
Lemma Select_eq : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (m:(map a b)), forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) ->
  ((get (set m a1 b1) a2) = b1).
Proof.
intros a a_WT b b_WT (m) a1 a2 b1 h1.
unfold get, set.
now case why_decidable_eq.
Qed.

(* Why3 goal *)
Lemma Select_neq : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (m:(map a b)), forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).
Proof.
intros a a_WT b b_WT (m) a1 a2 b1 h1.
unfold get, set.
now case why_decidable_eq.
Qed.

(* Why3 goal *)
Definition const: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  b -> (map a b).
intros a a_WT b b_WT y.
exact (_map_constr _ _ (fun _ => y)).
Defined.

(* Why3 goal *)
Lemma Const : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (b1:b) (a1:a), ((get (const b1: (map a b)) a1) = b1).
Proof.
easy.
Qed.


Require Import
  Coq.ZArith.ZArith
  Hask.Control.Monad
  Hask.Data.Maybe
  Pact.Data.Either
  Pact.Data.IList
  Pact.Lib
  Pact.Ty
  Pact.Exp
  Pact.Value
  Pact.Lang
  Pact.Lang.CapabilityType.

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

Set Equations With UIP.

Generalizable All Variables.
Set Primitive Projections.

Import ListNotations.

Definition SemPrimTy (ty : PrimType) : Type :=
  match ty with
  | PrimVoid    => False
  | PrimUnit    => unit
  | PrimInteger => Z
  | PrimDecimal => N
  | PrimTime    => nat
  | PrimBool    => bool
  | PrimString  => string
  end.

#[export]
Program Instance SemPrimTy_EqDec {ty} : EqDec (SemPrimTy ty).
Next Obligation.
  induction ty; auto; sauto.
Defined.

Section SemTy.

Context {m : Type → Type}.

Fixpoint SemTy (τ : Ty) : Type :=
  match τ with
  | TyArrow dom cod => SemTy dom → m (SemTy cod)

  | TyError         => Err
  | TySym           => string
  | TyPrim p        => SemPrimTy p

  | TyList t        => list (SemTy t)
  | TyPair t1 t2    => SemTy t1 * SemTy t2
  | TySum t1 t2     => SemTy t1 + SemTy t2

  (** Capabilities *)
  | TyCap p v       => Cap {| paramTy := reifyTy p; valueTy := reifyTy v |}
  end.

Lemma reflectTy_reifyTy {τ} :
  ConcreteP τ → reflectTy (reifyTy τ) = SemTy τ.
Proof.
  induction τ; try sauto.
Qed.

#[export]
Program Instance Concrete_EqDec {t} (H : ConcreteP t) : EqDec (SemTy t).
Next Obligation.
  generalize dependent y.
  generalize dependent x.
  induction t; simpl; intros; auto.
  - sauto.
  - sauto.
  - apply SemPrimTy_EqDec.
  - reduce.
    assert (ConcreteP t1 ∧ ConcreteP t2) as H0 by sauto.
    destruct (IHt1 (proj1 H0) s1 s).
    + destruct (IHt2 (proj2 H0) s2 s0); sauto.
    + sauto.
  - reduce.
    destruct x, y.
    + assert (ConcreteP t1) as H0 by sauto.
      destruct (IHt1 H0 s s0); sauto.
    + sauto.
    + sauto.
    + assert (ConcreteP t2) as H0 by sauto.
      destruct (IHt2 H0 s s0); sauto.
  - apply list_eqdec.
    unfold EqDec.
    apply IHt; sauto.
  - sauto.
Defined.

End SemTy.

Notation "⟦ t ⟧" := (SemTy t) (at level 9) : type_scope.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^384 - 2^128 - 2^96 + 2^32 - 1
Base: 42 + 2/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 42 + 2/3;
    bitwidth := 64;
    s := 2^384;
    c := [(1, 1); (2^32, -1); (2^96, 1); (2^128, 1)];
    carry_chains := Some [[2; 1; 8; 8]; [3; 2; 0; 4; 1; 5; 6; 7; 8]; [3; 2; 0; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.
Require Import  p5_0.
Require Import  p5_1.
Require Import  p5_2.
Require Import  p5_3.
Require Import  p5_4.
Require Import  p5_5.
Require Import  p5_6.
Require Import  p5_7.
Require Import  p5_8.
Require Import  p5_9.
Require Import  p5_10.
Require Import  p5_11.
Require Import  p5_12.
Require Import  p5_13.
Require Import  p5_14.
Require Import  p5_15.
Require Import  p5_16.
Require Import  p5_17.
Require Import  p5_18.
Require Import  p5_19.
Require Import  p5_20.
Require Import  p5_21.
Require Import  p5_22.
Require Import  p5_23.
Require Import  p5_24.
Require Import  p5_25.
Require Import  p5_26.
Require Import  p5_27.
Require Import  p5_28.
Require Import  p5_29.
Require Import  p5_30.
Require Import  p5_31.
Require Import  p5_32.
Require Import  p5_33.
Require Import  p5_34.
Require Import  p5_35.
Require Import  p5_36.
Require Import  p5_37.
Require Import  p5_38.
Require Import  p5_39.
Require Import  p5_40.
Require Import  p5_41.
Require Import  p5_42.
Require Import  p5_43.
Require Import  p5_44.
Require Import  p5_45.
Require Import  p5_46.
Require Import  p5_47.
Require Import  p5_48.
Require Import  p5_49.
Require Import  p5_50.
Require Import  p5_51.
Require Import  p5_52.
Require Import  p5_53.
Require Import  p5_54.
Require Import  p5_55.
Require Import  p5_56.
Require Import  p5_57.
Require Import  p5_58.
Require Import  p5_59.
Require Import  p5_60.
Require Import  p5_61.
Require Import  p5_62.
Require Import  p5_63.
Require Import  p5_64.
Require Import  p5_65.
Require Import  p5_66.
Require Import  p5_67.
Require Import  p5_68.
Require Import  p5_69.
Require Import  p5_70.
Require Import  p5_71.
Require Import  p5_72.
Require Import  p5_73.
Require Import  p5_74.
Require Import  p5_75.
Require Import  p5_76.
Require Import  p5_77.
Require Import  p5_78.
Require Import  p5_79.
Require Import  p5_80.

Lemma  primo: prime 17308863289560797768083675694283954643563199165299081653726514315074575569721461305666176054750039730093502509709883842612972709866553115853069672974671929576863037407723483183057609061282582986696039342455262822910845478389812153008092268861072282573957698527854913251949179306714915231970904706078568262989724653261757544559531914970277290518968202369757567330028430949260849349634807374731912063214572498276460376824393156145942143478701981777577522872086387284432727427227911952795570479230583016830064254595100458594572670551462319475408101759165736651691436110684719260113243358951512803177396629802648071121871.
Proof.
exact
(primo0 (primo1 (primo2 (primo3 (primo4 (primo5 (primo6 (primo7 (primo8 (primo9 (primo10 (primo11 (primo12 (primo13 (primo14 (primo15 (primo16 (primo17 (primo18 (primo19 (primo20 (primo21 (primo22 (primo23 (primo24 (primo25 (primo26 (primo27 (primo28 (primo29 (primo30 (primo31 (primo32 (primo33 (primo34 (primo35 (primo36 (primo37 (primo38 (primo39 (primo40 (primo41 (primo42 (primo43 (primo44 (primo45 (primo46 (primo47 (primo48 (primo49 (primo50 (primo51 (primo52 (primo53 (primo54 (primo55 (primo56 (primo57 (primo58 (primo59 (primo60 (primo61 (primo62 (primo63 (primo64 (primo65 (primo66 (primo67 (primo68 (primo69 (primo70 (primo71 (primo72 (primo73 (primo74 (primo75 (primo76 (primo77 (primo78 (primo79 primo80)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).
Qed.


Require Import Thread0 Bootstrap.

Module Type HIDE.
  Parameter heapSize4 : N -> N.
  Axiom heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.

  Parameter to_nat : N -> nat.
  Axiom to_nat_eq : to_nat = N.to_nat.
End HIDE.

Module Hide : HIDE.
  Definition heapSize4 n := (n * 4)%N.
  Theorem heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.
    auto.
  Qed.

  Definition to_nat := N.to_nat.
  Theorem to_nat_eq : to_nat = N.to_nat.
    auto.
  Qed.
End Hide.

Module Type S.
  Parameter heapSize : N.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := ((heapSize + 50) * 4)%N.
End M'.
Import M'.

Module T := Thread0.Make(M').

Section boot.
  Definition heapSize' := Hide.to_nat heapSize.

  Hypothesis heapSizeLowerBound : (3 <= heapSize)%N.

  Let heapSizeLowerBound' : (3 <= heapSize')%nat.
    intros; unfold heapSize'; rewrite Hide.to_nat_eq.
    assert (heapSize >= 3)%N by (apply N.le_ge; auto); nomega.
  Qed.

  Definition size := heapSize' + 50 + 2.
  (* The reserved heap slots are:
   * 1) scheduler
   * 2) saved Bedrock stack pointer for current thread *)

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize' * 4).
    goodSize.
  Qed.

  Lemma heapSizeLowerBound'' : natToW 3 <= NToW heapSize.
    hnf; intros.
    red in H.
    pre_nomega.
    rewrite wordToNat_natToWord_idempotent in H by reflexivity.
    unfold heapSize' in *.
    rewrite Hide.to_nat_eq in *.
    unfold NToW in *.
    rewrite NToWord_nat in *.
    rewrite wordToNat_natToWord_idempotent in H.
    omega.
    rewrite N2Nat.id.
    eapply goodSize_weaken in mem_size.
    2: instantiate (1 := N.to_nat heapSize); unfold size.
    Transparent goodSize.
    unfold goodSize in *.
    rewrite N2Nat.id in *.
    assumption.
    unfold heapSize'.
    rewrite Hide.to_nat_eq.
    omega.
  Qed.

  Hint Immediate heapSizeLowerBound''.

  Definition appmainS := SPEC reserving 49
    PREonly[_] mallocHeap 0.

  Definition bootS := bootS heapSize' 2.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "app"!"main" @ [appmainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%N;;

        Assert [PREmain[_] globalSched =?> 2 * 0 =?> heapSize'];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSched =?> 2 * mallocHeap 0];;

        Goto "app"!"main"
      end
    }}.

  Lemma bootstrap_Sp_nonzero : forall sp : W,
    sp = 0
    -> sp = (heapSize' * 4)%nat
    -> goodSize (heapSize' * 4)
    -> False.
    intros; eapply bootstrap_Sp_nonzero; try eassumption; eauto.
  Qed.

  Lemma bootstrap_Sp_freeable : forall sp : W,
    sp = (heapSize' * 4)%nat
    -> freeable sp 50.
    intros; eapply bootstrap_Sp_freeable; try eassumption; eauto.
  Qed.

  Lemma noWrap : noWrapAround 4 (wordToNat (NToW heapSize) - 1).
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize' in *; rewrite Hide.to_nat_eq in *.
    rewrite wordToNat_natToWord_idempotent.
    apply noWrap; eauto.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Local Hint Immediate bootstrap_Sp_nonzero bootstrap_Sp_freeable noWrap.

  Lemma break : NToW ((heapSize + 50) * 4)%N = ((heapSize' + 50) * 4)%nat.
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; rewrite N2Nat.inj_add; auto.
  Qed.

  Lemma times4 : (Hide.heapSize4 heapSize : W) = (heapSize' * 4)%nat.
    rewrite Hide.heapSize4_eq; intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; auto.
  Qed.

  Lemma wordToNat_heapSize : wordToNat (NToW heapSize) = heapSize'.
    unfold heapSize'; rewrite Hide.to_nat_eq.
    unfold NToW.
    rewrite NToWord_nat.
    apply wordToNat_natToWord_idempotent.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Hint Rewrite break times4 wordToNat_heapSize : sepFormula.

  Ltac t := unfold globalSched, localsInvariantMain, globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    unfold boot; rewrite <- Hide.heapSize4_eq; vcgen; abstract t.
  Qed.

  Global Opaque heapSize'.

  Definition m := link boot T.T.m.

  Theorem ok : moduleOk m.
    link ok0 T.T.ok.
  Qed.

  (* No final proof here, because that crucial app.main() function is outside the
   * scope of Bedrock! *)
End boot.

End Make.


Require Import RamifyCoq.sample_mark.env_unionfind.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.UnionFindGraph.
Require Import RamifyCoq.msl_application.GList.
Require Import RamifyCoq.msl_application.GList_UnionFind.
Require Import RamifyCoq.floyd_ext.share.
Require Import RamifyCoq.sample_mark.spatial_graph_glist.

Local Coercion UGraph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation vertices_at sh P g:= (@vertices_at _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ P g).
Notation whole_graph sh g := (vertices_at sh (vvalid g) g).
Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ x g).
Notation Graph := (@Graph pSGG_VST).
Notation uf_under_bound g := (uf_under_bound id g).
Existing Instances maGraph finGraph liGraph RGF.

Definition vlabel_in_bound (g: Graph) := forall x, vvalid g x -> Z.of_nat (vlabel g x) <= Int.max_unsigned.

Lemma rank_unchanged_in_bound: forall (g g': Graph), uf_equiv g g' -> rank_unchanged g g' -> vlabel_in_bound g -> vlabel_in_bound g'.
Proof. unfold uf_equiv, rank_unchanged, vlabel_in_bound. intros. destruct H as [? _]. pose proof H2. rewrite <- H in H2. rewrite <- H0; auto. Qed.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh: wshare, n:Z
  PRE [ 67%positive OF tint]
     PROP (0 <= n <= Int.max_signed)
     LOCAL (temp 67%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: addr,
     PROP ()
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (data_at sh node_type (pointer_val_val null, (Vint (Int.repr 0)))
              (pointer_val_val v)).

Definition find_spec :=
 DECLARE _find
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (vvalid g x /\ uf_under_bound g)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (whole_graph sh g)
  POST [ tptr (Tstruct _Node noattr) ]
        EX g': Graph, EX rt : pointer_val,
        PROP (uf_equiv g g' /\ uf_root g' x rt /\ uf_under_bound g' /\ rank_unchanged g g')
        LOCAL (temp ret_temp (pointer_val_val rt))
        SEP (whole_graph sh g').

Definition unionS_spec :=
 DECLARE _unionS
  WITH sh: wshare, g: Graph, x: pointer_val, y: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr)), _y OF (tptr (Tstruct _Node noattr))]
          PROP  (vvalid g x /\ vvalid g y /\ uf_under_bound g /\ vlabel_in_bound g)
          LOCAL (temp _x (pointer_val_val x); temp _y (pointer_val_val y))
          SEP   (whole_graph sh g)
  POST [ Tvoid ]
        EX g': Graph,
        PROP (uf_union g x y g' /\ uf_under_bound g')
        LOCAL()
        SEP (whole_graph sh g').

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, g: Graph
    PRE []
      PROP (uf_under_bound g)
      LOCAL ()
      SEP (whole_graph sh g)
    POST [tptr (Tstruct _Node noattr)]
      EX g': Graph, EX rt: pointer_val,
      PROP (~ vvalid g rt /\ vvalid g' rt /\ is_partial_graph g g' /\ uf_under_bound g')
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (whole_graph sh g').

Definition Gprog : funspecs := ltac:(with_library prog [mallocN_spec; makeSet_spec; find_spec; unionS_spec]).

Lemma body_makeSet: semax_body Vprog Gprog f_makeSet makeSet_spec.
Proof.
  start_function.
  forward_call (sh, 8).
  - compute. split; intros; inversion H0.
  - Intros x.
    assert_PROP (x <> null) as x_not_null by (entailer !; destruct H1 as [? _]; apply H1).
    assert_PROP (~ vvalid g x) by (entailer; apply (@vertices_at_sepcon_unique_1x _ _ _ _ SGBA_VST _ _ (SGA_VST sh) (SGAvs_VST sh) g x (vvalid g) (O, null))).
    forward. forward. forward.
    Exists (make_set_Graph O tt tt x g x_not_null H0) x. entailer !.
    + split; [|split]; simpl; [right | apply is_partial_make_set_pregraph | apply uf_under_bound_make_set_graph]; auto.
    + assert (Coqlib.Prop_join (vvalid g) (eq x) (vvalid (make_set_Graph 0%nat tt tt x g x_not_null H0))). {
        simpl; hnf; split; intros; [unfold graph_gen.addValidFunc | subst a]; intuition.
      } assert (vgamma (make_set_Graph O tt tt x g x_not_null H0) x = (O, x)). {
        unfold vgamma, UnionFindGraph.vgamma. simpl. f_equal.
        - destruct (SGBA_VE x x); [| hnf in c; unfold Equivalence.equiv in c; exfalso]; auto.
        - unfold graph_gen.updateEdgeFunc. destruct (EquivDec.equiv_dec (x, tt) (x, tt)). 2: compute in c; exfalso; auto. destruct (SGBA_VE null null); auto.
          hnf in c. unfold Equivalence.equiv in c. exfalso; auto.
      } rewrite <- (vertices_at_sepcon_1x (make_set_Graph 0%nat tt tt x g x_not_null H0) x (vvalid g) _ (O, x)); auto. apply sepcon_derives. 1: apply derives_refl.
      assert (vertices_at sh (vvalid g) g = vertices_at sh (vvalid g) (make_set_Graph O tt tt x g x_not_null H0)). {
        apply vertices_at_vertices_identical. simpl. hnf. intros. destruct a as [y ?]. unfold Morphisms_ext.app_sig. simpl.
        unfold UnionFindGraph.vgamma. simpl. unfold graph_gen.updateEdgeFunc. f_equal.
        - destruct (SGBA_VE y x); [hnf in e; subst y; exfalso |]; auto.
        - destruct (EquivDec.equiv_dec (x, tt) (y, tt)); auto. hnf in e. inversion e. subst y. exfalso; auto.
      } rewrite <- H6. apply derives_refl.
Qed.

Lemma false_Cne_eq: forall x y, typed_false tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst; auto.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma true_Cne_neq: forall x y, typed_true tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + subst b0. pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro; apply H0. inversion H1. reflexivity.
  - intro. inversion H0. auto.
Qed.

Lemma graph_local_facts: forall sh x (g: Graph), vvalid g x -> whole_graph sh g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. eapply derives_trans; [apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (vgamma g x)); auto |].
  simpl vertex_at at 1. unfold binode. entailer!.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function.
  destruct H. remember (vgamma g x) as rpa eqn:?H. destruct rpa as [r pa].
  (* p = x -> parent; *)
  localize [data_at sh node_type (vgamma2cdata (vgamma g x)) (pointer_val_val x)]. rewrite <- H1. simpl vgamma2cdata.
  forward. 1: entailer!; destruct pa; simpl; auto.
  unlocalize [whole_graph sh g].
  1: rewrite <- H1; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (r, pa)); auto.
  assert (H_PARENT_Valid: vvalid g pa) by (eapply valid_parent; eauto).
  (* if (p != x) { *)
  forward_if
    (EX g': Graph, EX rt : pointer_val,
     PROP (uf_equiv g g' /\ uf_root g' x rt /\ uf_under_bound g' /\ rank_unchanged g g')
     LOCAL (temp _p (pointer_val_val rt); temp _x (pointer_val_val x))
     SEP (whole_graph sh g')).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - (* p0 = find(p); *)
    forward_call (sh, g, pa). Intros vret. destruct vret as [g' root]. simpl fst in *. simpl snd in *.
    Opaque pointer_val_val. forward. Transparent pointer_val_val.
    pose proof (true_Cne_neq _ _ H2).
    assert (weak_valid g' root) by (right; destruct H4; apply reachable_foot_valid in H4; auto).
    assert (vvalid g' x) by (destruct H3 as [? _]; rewrite <- H3; apply H).
    assert (~ reachable g' root x) by (apply (uf_equiv_not_reachable g g' x r pa root); auto).
    assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g' x root H8 H9 H10)) (Graph_gen_redirect_parent g' x root H8 H9 H10) =
            vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' x root H8 H9 H10)). {
      apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
    remember (vgamma g' x) as rpa eqn:?H. destruct rpa as [r' pa']. symmetry in H12.
    localize [data_at sh node_type (Vint (Int.repr (Z.of_nat r')), pointer_val_val pa') (pointer_val_val x)].
    forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g' x root H8 H9 H10)].
    + rewrite H11. apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto. destruct H4.
      apply reachable_foot_valid in H4. intro. subst root. apply (valid_not_null g' null H4). simpl. auto.
    + Exists (Graph_gen_redirect_parent g' x root H8 H9 H10) root. rewrite H11. entailer!.
      assert (uf_root g' x root). {
        rewrite <- (uf_equiv_root_the_same g g' x root); auto.
        apply (uf_root_edge _ (liGraph g) _ pa); [| apply (vgamma_not_dst g x r pa) | rewrite (uf_equiv_root_the_same g g')]; auto.
      } split; [|split].
      * apply (graph_gen_redirect_parent_equiv g g' x r pa); auto.
      * simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto. apply reachable_refl; auto.
      * apply uf_under_bound_redirect_parent; auto.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H2. subst pa. split; [|split; [split |]]; auto.
    + apply (uf_equiv_refl _  (liGraph g)).
    + apply uf_root_vgamma with (n := r); auto.
    + repeat intro; auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed. (* Original: 56.251 secs; VST 2.*: 2.084 secs*)

(* Print Assumptions body_find. *)

Lemma true_Ceq_eq: forall x y, typed_true tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst. reflexivity.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma false_Ceq_neq: forall x y, typed_false tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro. apply H0. inversion H1. reflexivity.
  - intro. apply n. inversion H0; reflexivity.
Qed.

Lemma body_unionS: semax_body Vprog Gprog f_unionS unionS_spec.
Proof.
  start_function.
  destruct H as [? [? [? ?]]]. forward_call (sh, g, x). Intros vret. destruct vret as [g1 x_root]. simpl fst in *. simpl snd in *. apply rank_unchanged_in_bound in H6; auto.
  assert (vvalid g1 y) by (destruct H3 as [? _]; rewrite <- H3; apply H0).
  forward_call (sh, g1, y). Intros vret. destruct vret as [g2 y_root]. simpl fst in *. simpl snd in *. apply rank_unchanged_in_bound in H11; auto.
  assert (H_VALID_XROOT: vvalid g2 x_root) by (destruct H8 as [? _]; rewrite <- H8; destruct H4; apply reachable_foot_valid in H4; apply H4).
  assert (H_VALID_YROOT: vvalid g2 y_root) by (destruct H9; apply reachable_foot_valid in H9; apply H9).
  assert (H_XROOT_NOT_NULL: x_root <> null) by (intro; subst x_root; apply (valid_not_null g2 null H_VALID_XROOT); simpl; auto).
  assert (H_YROOT_NOT_NULL: y_root <> null) by (intro; subst y_root; apply (valid_not_null g2 null H_VALID_YROOT); simpl; auto).
  forward_if_tac
    (PROP (x_root <> y_root)
     LOCAL (temp _yRoot (pointer_val_val y_root); temp _xRoot (pointer_val_val x_root);
     temp _x (pointer_val_val x); temp _y (pointer_val_val y))
     SEP (vertices_at sh (vvalid g2) g2)).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - forward. apply true_Ceq_eq in H12. Exists g2. subst y_root. entailer!. apply (the_same_root_union g g1 g2 x y x_root); auto.
  - forward. apply false_Ceq_neq in H12. entailer!.
  - Intros. (* xRank = xRoot -> rank; *)
    remember (vgamma g2 x_root) as rpa eqn:?H. destruct rpa as [rankXRoot paXRoot]. symmetry in H13.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
    rewrite H13. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H13; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) x_root (rankXRoot, paXRoot)); auto.
    (* yRank = yRoot -> rank; *)
    remember (vgamma g2 y_root) as rpa eqn:?H. destruct rpa as [rankYRoot paYRoot]. symmetry in H14.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
    rewrite H14. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H14; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) y_root (rankYRoot, paYRoot)); auto.
    rename H_VALID_XROOT into H15. clear H1 H2 H5 H6.
    assert (Int.unsigned (Int.repr (Z.of_nat rankXRoot)) = Z.of_nat (vlabel g2 x_root)). {
      simpl vgamma in H13. inversion H13. apply Int.unsigned_repr. split; [apply Zle_0_nat | specialize (H11 x_root H15); auto].
    } assert (Int.unsigned (Int.repr (Z.of_nat rankYRoot)) = Z.of_nat (vlabel g2 y_root)). {
      simpl vgamma in H14. inversion H14. apply Int.unsigned_repr. split; [apply Zle_0_nat | specialize (H11 y_root H_VALID_YROOT); auto].
    } clear H11.
    forward_if
      (EX g': Graph,
       PROP (uf_union g x y g' /\ uf_under_bound g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
    + assert (weak_valid g2 y_root) by (right; auto).
      assert (~ reachable g2 y_root x_root) by (intro; destruct H9; specialize (H16 _ H11); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11)) (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      (* xRoot -> parent = yRoot; *)
      localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
      rewrite H13. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11)].
      1: rewrite H13; simpl vgamma2cdata; rewrite H16; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
      Exists (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11). entailer !. split.
      * apply (diff_root_union_1 g g1 g2 x y x_root y_root); auto.
      * rewrite H1 in *. rewrite H2 in *. rewrite <- Nat2Z.inj_lt in H5. destruct H9. apply uf_under_bound_redirect_parent_lt; auto.
    + assert (weak_valid g2 x_root) by (right; auto). rename H_VALID_YROOT into H11.
      assert (~ reachable g2 x_root y_root) by (intro; rewrite (uf_equiv_root_the_same g1 g2) in H4; auto; destruct H4; specialize (H17 _ H16); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)) (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      forward_if
      (EX g': Graph,
       PROP (uf_union g x y g' /\ uf_under_bound g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H14. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)].
        1: rewrite H14; simpl vgamma2cdata; rewrite H17; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        Exists (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16). entailer!. split.
        -- apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
        -- rewrite H1 in *. rewrite H2 in *. rewrite <- Nat2Z.inj_lt in H18. apply uf_under_bound_redirect_parent_lt; auto.
           rewrite (uf_equiv_root_the_same g1 g2) in H4; auto. destruct H4. auto.
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H14. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)].
        1: rewrite H14; simpl vgamma2cdata; rewrite H17; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        set (g3 := Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16).
        assert (uf_union g x y g3) by (subst g3; simpl; apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto).
        (* xRoot -> rank = xRank + 1; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
        rewrite H13. simpl vgamma2cdata. forward.
        rewrite add_repr. replace (Z.of_nat rankXRoot + 1) with (Z.of_nat (rankXRoot + 1)). 2: rewrite Nat2Z.inj_add; simpl; auto.
        unlocalize [whole_graph sh (Graph_vgen g3 x_root (rankXRoot + 1)%nat)].
        -- assert (vertices_at sh (vvalid (Graph_vgen g3 x_root (rankXRoot + 1)%nat)) (Graph_vgen g3 x_root (rankXRoot + 1)%nat) =
                   vertices_at sh (vvalid g3) (Graph_vgen g3 x_root (rankXRoot + 1)%nat)). {
             apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition.
           } rewrite H20. clear H20. rewrite H13. simpl vgamma2cdata. apply (@graph_vgen_ramify _ (sSGG_VST sh)).
           ++ subst g3. simpl. destruct H8 as [? _]. rewrite <- H8. destruct H4; apply reachable_foot_valid in H4; apply H4.
           ++ subst g3. remember (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16) as g3.
              apply (graph_gen_redirect_parent_vgamma _ _ _ rankXRoot paXRoot) in Heqg3; auto. intros. inversion H20; auto.
        -- Exists (Graph_vgen g3 x_root (rankXRoot + 1)%nat). entailer!. rewrite H1 in *; rewrite H2 in *.
           assert (Z.of_nat (vlabel g2 x_root) = Z.of_nat (vlabel g2 y_root)) by (clear -H5 H18; intuition). apply Nat2Z.inj in H24.
           simpl in H13. inversion H13. apply uf_under_bound_redirect_parent_eq; auto. rewrite (uf_equiv_root_the_same g1 g2) in H4; auto. destruct H4. auto.
    + Intros g'. forward. Exists g'. entailer!.
Qed. (* Original: 192.772 secs; VST 2.*: 4.786 secs *)


Set Implicit Arguments.

Ltac intro_til tac := tac || (intro ; intro_til tac).

(* This file explores extensively different properties
   we might expect to hold of derived rules,

   though only for the exists-path system.

 There's a property "derived valid" which is just based on the assumption about
 your rules that comes up most naturally when trying to prove that
 stable (derived F X) assuming subrel X (stepF (derived F X)).

 However, proving derived_valid F lets you in places inspect terms
 of type derived F X, which lets you justify rules whose proof may
  depend critically on that being the only derived rule used.
 (is this even a semantic possibility?)

 derived_valid' generalizes over F in these results in the most stupid
 way to allow any set G of derived rules which expands on F.
 Under the assumption that F is monotone (subrel S T -> subrel (F S) (F T)),
 derived_valid and two successively simpler properties,
 derived_valid'' are all equivalent.

 Also defined monotonize, which is the smallest (pointwise) monotonic
 operator extending F, and showed that
 derived_valid' F <-> derived_valid' (monotonize F).

 To complete a chain like derived_valid' F <-> derived_valid''' (monotinize F),
 would need something like derived_valid' (monotonize F) -> derived_valid' F.

 -- one note is that the mendler-style stuff in derived means that F can't
    effectively depend on things being NOT in the argument relation,
   so we ought to be able to prove
   derived F X x P <-> derived (monotonize F) X x P.
  Not sure how that fits with soundness conditions.
  Guess that at least says something in the fully semantic derived_valid_0...

  Ahh, that means derived assumes by itself that F is "w.l.o.g" mono.

  and, under assumption that F in mono_op, we can show also the
  derived_valid that makes no special provisions is equivalent to all of the
  above, and also an inlined version of derived_valid,

  Definition derived_valid_m (F : RRel -> RRel) : Prop :=
    forall (X : RRel), subrel (F (stepF (derived F X))) (stepF (derived F X)).

  The simplest looking of the rules is
  Definition derived_valid''' (F : RRel -> RRel) : Prop :=
    forall (X : RRel), subrel (F (stepF X)) (stepF (derived F X)).
  but in practice derived_valid_m seems to be even easier to prove, because
  if F Q has children of Q, the cildren are already in the form stepF (derived F X),
  so the proof (automation) doesn't have to figure out how to lift stepF X into
  stepF (derived X) (though maybe registering a lemma to that effect could help).

  Because of this equivalence of all the different version, under assumptions of
  monotonicity, we can freely combine any sets of valid operators!
 *)

Module Type language.
Parameter cfg : Set.
Parameter step : cfg -> cfg -> Prop.
End language.

Module Cotrans(L : language).

Import L.

(* Type of reachability relations: if X x P holds for
   X : RRel, say  "X claims x reaches P" *)
Definition RRel : Type := cfg -> (cfg -> Prop) -> Prop.

(* Being a subrelation *)
Definition subrel (A B : RRel) : Prop := forall x P, A x P -> B x P.
Lemma subrel_trans (P Q R : RRel) :
  subrel P Q -> subrel Q R -> subrel P R.
Proof. firstorder. Qed.
Lemma subrel_refl (P : RRel) : subrel P P.
Proof. firstorder. Qed.

(* Some starting tactics for proving with subrel *)
Create HintDb subrel discriminated.
Hint Resolve subrel_refl subrel_trans : subrel.
(*
Hint Extern 4 (subrel ?P ?Q) =>
  match goal with
  | [H : subrel P ?M |- _] => refine (subrel_trans H _)
  | [H : subrel ?M ?Q |- subrel ?P ?Q] => refine (subrel_trans _ H)
  end
  : subrel.
  *)

Ltac fold_subrel :=
  match goal with [|- forall x P, ?R1 x P -> ?R2 x P] => fold (subrel R1 R2) end.
(* If the goal is to show that a particular x P is included in a relation,
   and the only thing we know about (x,P) is that it's included in another
   relation, it must be a subrel problem *)
Ltac by_subrel :=
match goal with [HxP : ?S ?x ?P |- ?T ?x ?P ] =>
   revert x P HxP; fold (subrel S T)
end.

(* Defining actual reachability. *)
CoInductive reaches (x : cfg) (P : cfg -> Prop) : Prop :=
  | Done : P x -> reaches x P
  | Step : forall y, step x y -> reaches y P -> reaches x P
  .
(* The rest of the game is to define the reachabiliy relation
   corresponding to the specific claims we make about a program,
   and somehow show it's a subset of the true claims *)
Definition sound (X : RRel) : Prop := subrel X reaches.

(* To do this we'll use coinduction, based on showing that
   reaches is the greatest fixpoint of this operator that
   transforms reachability relations *)
Inductive stepF (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | DoneF : P x -> stepF X x P
  | StepF : forall y, step x y -> X y P -> stepF X x P.
(* First, prove reaches is a fixpoint of stepF *)
Lemma reaches_unfold : subrel reaches (stepF reaches).
destruct 1;econstructor(eassumption).
Qed.
Lemma reaches_fold : subrel (stepF reaches) reaches.
destruct 1;econstructor(eassumption).
Qed.
(* Second, that it's the greatest fixpoint.
   It's actually greater than any set X with subrel X (stepF X).
   In other words, any stepF-stable set is sound.
   *)
Definition stable (X : RRel) : Prop := subrel X (stepF X).
CoFixpoint stable_sound X (Hstable : stable X) : sound X :=
  fun x P HxP =>
  match Hstable _ _ HxP with
  | DoneF Px => Done _ _ Px
  | StepF y Rxy XyP => Step Rxy (@stable_sound _ Hstable _ _ XyP)
  end.

(* Fixpoints are only guaranteed to exists for montone operators. *)
Definition mono (F : RRel -> RRel) : Prop :=
  forall (S T : RRel), subrel S T -> subrel (F S) (F T).
Lemma by_mono (F : RRel -> RRel) (S T : RRel) :
  mono F -> subrel S T -> subrel (F S) (F T).
Proof. auto. Qed.

(* The operator stepF is in fact monotonic *)
Lemma stepF_mono : mono stepF.
  (* or, (P Q : RRel) : subrel P Q -> subrel (stepF P) (stepF Q). *)
unfold subrel; induction 2;eauto using stepF.
Qed.
Hint Resolve by_mono stepF_mono : subrel.

(* Constructing a set that's directly stable in this sense
   is quite tedious because everything has to be supported
   after one step -
     if you make any claim (x,P), you must also explicitly
     make a claim (y,P) for some immediate successor y of x.

  Proving something about each claim of X consists of
  showing that X is a subset of some set.

  In the most general notion, we'd have an operator
  (F : RRel -> RRel), such that proving X is stable
  under F implies it's sound: subrel X (F X) -> subrel X reaches.

TODO:
  Getting more specific, without having seriously analysed
  the general form, we'll think of "derived rules" as monotone
  functions that compute the set of claims that are immediate
  consequences of a starting set of claims, construct
  an operator "derived" that closes an initial set of
  claims under a rule, and consider when the result is stable.
  By construction we'll have

  X `subrel` derived F X

  So when we do have

  derived F X `subrel` stepF (derived F X)

  we also have

  X `subrel` reaches.

  By transitivity, a necessary condition for the
  derived set to be stable is that

  X `subrel` F X `subrel` stepF (F X).

  To be a good rule, so only have to reason about
  claims contained in X, this should also be sufficient.

  In a bit more detail, dervied starts with the operator F,
  and find the least fixpoint of (stepF + F) which is greater than X -
  in other words, the least fixpoint of (stepF + F + const X).

  stepF is included because it should always be sound.

  See fixpoints.v for generic constructions and results about
  fixpoints, which we don't use here.
 *)

(* Uses Mendler style in drule', becuase F (derived F X) x P
   is a non-strictly-positive occurance of derived *)
Inductive derived (F : RRel -> RRel)
                   (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | dleaf : X x P -> derived F X x P
  | ddone : P x -> derived F X x P
  | dstep : forall y, step x y -> derived F X y P -> derived F X x P
  | drule' : forall Q, subrel Q (derived F X) -> F Q x P -> derived F X x P.
Definition drule F X : forall x P, F (derived F X) x P -> derived F X x P :=
(* or, forall F X, subrel (F (derived F X)) (derived F X) *)
 fun x P => drule' x P (fun _ _ H => H).
(* And basic monotonicity properties, that derived is
   monotone in both X and F *)
Lemma deri_mono : forall F P Q, subrel P Q -> subrel (derived F P) (derived F Q).
unfold mono; intros. unfold subrel in H.
induction 1;eauto using derived, drule.
Qed.
Lemma deri_lift (F G : RRel -> RRel)
  (Hlift : forall X, subrel (F X) (G X)) :
  forall X, subrel (derived F X) (derived G X).
unfold subrel; induction 1;eauto using derived.
apply (drule' _ _ H0). by_subrel;eauto with subrel.
Qed.
Hint Resolve deri_mono deri_lift : subrel.

(* For the fixpoint to be well-defined, we might expect to requrie
   that F monotone, but the mendler-style recursion effectively
   monotonizes F, by letting us pick a smaller Q if it makes a difference.
   A few lemmas demonstrating this.

  The main upside of this is that when considering valitity conditions,
  we might as well assume that F is monotone if it helps prove anything.

  To show this, we define how monotonize, and show
  derived F X is equivalent to derived (monotonize F X)
  *)
(* This is the minimal monotonic extension of a relation transformer *)
Inductive monotonize (F : RRel -> RRel) (X : RRel) (x : cfg) (P : cfg -> Prop)
 : Prop := | m_mono : forall Y, F Y x P -> subrel Y X -> monotonize F X x P.
(* Proving it's actually correct: 1) monotonic *)
Lemma monotonize_mono F : mono (monotonize F).
destruct 2.
econstructor;[eassumption|];instantiate;eauto with subrel.
Qed.
(* 2) includes F *)
Lemma monotonize_includes F :
 forall X, subrel (F X) (monotonize F X).
econstructor;[eassumption|];instantiate;auto with subrel.
Qed.
(* 3) Is smaller than any other monotone relation which F *)
Lemma monotonize_min F :
   (forall (G : RRel -> RRel),
      mono G ->
      (forall X, subrel (F X) (G X)) ->
      (forall X, subrel (monotonize F X) (G X))).
destruct 3. apply H in H2. by_subrel;eauto with subrel.
Qed.
(* A further property *)
Lemma monotonize_pointwise F G:
  (forall X, subrel (F X) (G X)) ->
  (forall X, subrel (monotonize F X) (monotonize G X)).
unfold subrel. destruct 2. eapply m_mono;eauto.
Qed.

(* Now actually prove derived ignores whether F is mono *)
Lemma derived_wlog_mono (F : RRel -> RRel) :
  forall X x P, derived (monotonize F) X x P <-> derived F X x P.
Proof.
split;induction 1;eauto using derived.
(* forward *)
destruct H1.
apply drule' with Y;eauto with subrel.
(* backward *)
apply drule; eauto using monotonize.
Qed.

(* Now a few properties about derived, for reasoning about the
   generated relation *)

(* by construction, derived is closed under step *)
Lemma deri_step :
   forall F X x P, stepF (derived F X) x P -> derived F X x P.
   (* kept open so auto can more easily use it pointwise *)
destruct 1;eauto using derived.
Qed.
Lemma deri_step_subrel :
   forall F X, subrel (stepF (derived F X)) (derived F X).
   (* and folded for subrel goals *)
destruct 1;eauto using derived.
Qed.
Lemma drule_subrel :
   forall F X Q,
     subrel Q (derived F X) ->
     subrel (F Q) (derived F X).
unfold subrel;eauto using derived.
Qed.
Lemma dleaf_subrel : forall F X, subrel X (derived F X).
unfold subrel;eauto using derived.
Qed.

Hint Resolve deri_step_subrel drule_subrel : subrel.
(* combining deri_step and dleaf, used in a few places *)
Lemma deri_incl_step F X : subrel (stepF X) (derived F X).
unfold subrel;destruct 1;eauto using derived.
Qed.
(* closing a set again adds no additional conclusions.
   This is useful in combination with deri_lift to
   prove lemmas about combining sets of rules *)
Lemma deri_join : forall F X x P, derived F (derived F X) x P -> derived F X x P.
induction 1;eauto using derived.
Qed.
Lemma deri_join_subrel : forall F X, subrel (derived F (derived F X)) (derived F X).
exact deri_join.
Qed.

(* this is the notion of a set X having a proof which uses rules F. *)
Definition derived_stable F X := subrel X (stepF (derived F X)).

(* Now consider various validity conditions.
   Beyond simply ensuring validity of a single set of rules,
   we would like to find composable conditions.
 *)

(* First, the most direct statement of validity as a derived rule *)
Definition validity_definition (F : RRel -> RRel) : Prop :=
  forall (X : RRel),
    derived_stable F X -> stable (derived F X).

(* TODO:
   Perhaps we can eliminate X:
   by using the derived_stable assumption to unfold it,
   derived_stable F X implies
   X `subset` stepF(gfp (F^* (stepF (-)))).
   Maybe some condition on F and this set is
   equivalent?

   derived_valid implies
   F (gfp (stepF (F^* -))) <= gfp (stepF (F^* -)),
   which in turn implies that F reaches <= reaches.
   Don't see that that implies back to any of the
   validity conditions
   (though I think it does ensure soundness)
   Also doesn't seem to combine freely.
   Certainly have example (where relation has some
     initial states, and some sets they don't reach,
     so theres's a set Initial of false claims about
     initial points)
   where reaches is F-closed and G-closed,
    and gfp (step o F^* ) = gfp (step o G^* ) = gfp ste
    but gfp (step o (F+G)* ) is step (universe)
   (F X = X when X <= gfp step, X + Initial otherwse,
    G X = X when X disjoint from Initial, U otherwise)
   *)
(* By trying to prove forall F, validity_definition F
   by induction on the (derived F X) from stable,
   we see the leaf/done/step cases can be handled independently
   of F, leaving a case equivalent to this*)
Definition derived_valid_case (F : RRel -> RRel) : Prop :=
  forall X, subrel X (stepF (derived F X)) ->
  forall Q, subrel Q (stepF (derived F X)) ->
    subrel (F Q) (stepF (derived F X)).

(* These are in fact equivalent *)
Lemma validity_equivalence : forall F,
  (validity_definition F <-> derived_valid_case F).
unfold validity_definition,derived_valid_case.
split;intros.
apply H in H0; eauto with subrel.
induction 1; eauto using stepF. by_subrel;eauto with subrel.
Qed.

(* Assuming monotonicity, we might as well set Q to it's upper bound *)
Definition derived_valid (F : RRel -> RRel) : Prop :=
  forall X, subrel X (stepF (derived F X)) ->
    subrel (F (stepF (derived F X))) (stepF (derived F X)).

(* this is obviously equivalent *)
Lemma drop_Q : forall F, mono F ->
  (derived_valid_case F <-> derived_valid F).
unfold derived_valid_case, derived_valid.
Proof. firstorder. Qed.

(* It seems strange to need the assumption about X in derived_valid -
   it's not guaranteed a value (derived F X) x P even actually contains
   a dleaf case so a proof derived_valid_case F can hardly assume it
   happens, and if it does occur, assumption about X can be wrapped up
   into derived F X by dleaf for use on the right hand side.

   Perhaps a rule that somehow throws away progress could use that
   hypothesis to unfold to stepF (stepF (derived F X)) or even more.

   Anyway, I haven't been able to show equivalence or find a counterexample,
   and the simpler definition is easily proved for all the imporant rules.

   Also, that hypothesis, by fixing the set of rules used in the proof of X,
   gets in the way of compositionality.
 *)
Definition derived_valid_m (F : RRel -> RRel) : Prop :=
  forall (X : RRel), subrel (F (stepF (derived F X))) (stepF (derived F X)).

(* This is obviously stronger *)
Lemma valid_m_stronger : forall F, derived_valid_m F -> derived_valid F.
Proof. firstorder. Qed.

Lemma deri_sound F (Hvalid : validity_definition F)
                 X (X_stable : derived_stable F X) :
                 sound X.
intros x P HxP;apply stable_sound with (derived F X);auto using dleaf.
Qed.

Lemma validity_from_m : forall F, mono F -> derived_valid_m F -> validity_definition F.
intros.
apply validity_equivalence.
apply drop_Q. assumption.
apply valid_m_stronger.
assumption.
Qed.

Module OverlySemanticNonsense.
(* There's actually an even more semantical statement,
    derived_stable F X -> sound X,
   but it doesn't contribute much - any proof of that basically
   has to apply coinduction itself to show X is in reaches,
   meaning it either finds a stable superset some other way than
   constructing derived F X, or obscures the construction.

   Either way, it doesn't make it easy to show a rule is valid,
   and it doesn't contribute to compositionality.
  *)

(* Really, a rule is valid if derived F X is sound *)
Definition derived_valid_0 (F : RRel -> RRel) :=
  forall X,
   subrel X (stepF (derived F X)) ->
   sound (derived F X).
(* With that definition, we can sum up the above lemmas as saying
   that derived_valid implies derived_valid_0 *)
Lemma obv1 F : validity_definition F -> derived_valid_0 F.
unfold derived_valid_0; intros; apply stable_sound; auto.
Qed.

Goal forall F, mono F -> derived_valid_0 F -> subrel (F reaches) reaches.
unfold mono, derived_valid_0, sound.
intros F F_mono F_valid.
eapply subrel_trans with (derived F reaches).
unfold subrel;intros. apply drule.
revert x P H. apply F_mono. unfold subrel;eauto using dleaf.
apply F_valid.
clear;destruct 1;eauto using stepF,dleaf.
Qed.

Lemma deri_pres_close : forall F, mono F ->
                                  subrel (F reaches) reaches ->
                                  subrel (derived F reaches) reaches.
intros F H.
induction 2.
assumption.
apply Done;assumption.
eapply Step;eauto.
apply H in H2.
apply H0.
apply H2.
assumption.
Qed.

(* F reaches <= reaches means the least fixed point of F
   is no more than reaches,
   but that doesn't tell us a whole lot about the
   least fixed point greater than X,
   unless there's a lot more to squeeze out of
  X <= Step[Derived[F,X]] than I think.
   ...
   for example, could define
   F[X] = emptyset if X <= reaches,
        = all      otherwise
   then Step[all] <= Step[Derived[F,X]],
   but F still meets the monotonicity and closedness
   conditions.,
   so it's not derived_valid_0.
 *)

Goal forall F, mono F ->
               subrel (F (derived F reaches)) reaches ->
               derived_valid_0 F.
unfold mono, derived_valid_0, sound.
intros F F_mono dF_closed X X_proof.
assert (subrel X reaches).
Abort.

(* So, what can we conclude just from derived_valid_0? *)
(* One conclusion, just from focusing on the drule' case in soundness *)
Lemma interesting F : derived_valid_0 F ->
  (forall X : RRel,
      subrel X (stepF (derived F X)) ->
      forall Q : RRel, subrel Q (derived F X) -> subrel (F Q) reaches).
Proof.
unfold derived_valid_0. unfold sound.
intro Hvalid0.
intros X HRel Q Qsub.
unfold subrel.
intros x P HF.
apply (Hvalid0 X HRel).
refine (drule' _ _ Qsub HF).
Qed.
End OverlySemanticNonsense.

(* Now we show that various rules satisfy the soundness conditions *)

(* Here's a generic proof tactic for derived_valid_m rule_type which
   assume a value of rule_type Q x P contains only one instance Q x S
   for any S. It splits it, tries to automtically finish from (S x) in
   the done case, and in the step case it takes the same step,
   assumes the remaining (derived F X) starts by drule,
   and hopes eauto finishes
 *)
Ltac simple_derived_rule :=
match goal with [|- derived_valid_m ?rule_type ] =>
destruct 1;match goal with
  [H : stepF _ ?x _ |- stepF _ ?x _] =>
  let Hstep := fresh "Hstep" in
  destruct H as [|? Hstep];
    [auto using DoneF
    |apply (StepF _ _ Hstep);clear x Hstep;apply drule]
end;eauto using rule_type, deri_step
end.

(* Transitivity using the generic derived rule mechanism *)
Inductive trans_rule (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | dtrans : forall (Q : cfg -> Prop), X x Q ->
             (forall y, Q y -> X y P) -> trans_rule X x P.

Lemma trans_mono : mono trans_rule.
firstorder.
Qed.
Hint Resolve trans_mono : subrel.

Lemma trans_valid : derived_valid_m trans_rule.
simple_derived_rule.
Qed.

(* Definition trans_rule_sound := deri_sound trans_valid. *)

Inductive weak_rule (X : RRel) (x : cfg) (P : cfg -> Prop) : Prop :=
  | dweak : forall (Q : cfg -> Prop), (forall a, Q a -> P a) -> X x Q -> weak_rule X x P.

Lemma weak_mono : mono weak_rule.
firstorder.
Qed.

Lemma weak_valid : derived_valid_m weak_rule.
simple_derived_rule.
Qed.

(* A more semantical derived rule:
   if f is a simulation, we can project any
   true rule through it
  *)
Definition simul (f : cfg -> cfg) : Prop :=
  forall x y, step x y -> step (f x) (f y).

Definition img (f : cfg -> cfg) (P : cfg -> Prop) : cfg -> Prop :=
  fun y => exists x, y = f x /\ P x.

Lemma simul_sound f (Hf : simul f) :
  forall (x : cfg) (P : cfg -> Prop),
  reaches x P -> reaches (f x) (img f P).
cofix.
destruct 1.
apply Done. exists x. clear simul_sound; intuition.
apply Step with (f y).  clear simul_sound. auto.
apply simul_sound. assumption.
Qed.

Inductive automorph (f : cfg -> cfg) (X : RRel) : RRel :=
  | dsubst : forall x P, X x P -> automorph f X (f x) (img f P).

Lemma automorph_mono : forall f, mono (automorph f).
intro f. unfold mono. intros.
unfold subrel; intros.
destruct H0.
constructor. auto.
Qed.

Lemma automorph_valid : forall f, simul f ->
  derived_valid_m (automorph f).
intros.
unfold derived_valid_m, subrel.
intros X x P.
destruct 1.
destruct H0.
apply DoneF.
unfold img. exists x;intuition.
apply StepF with (f y).
auto.
apply drule. constructor. assumption.
Qed.

(* The most semantical derived rule ever *)
Definition ground_truth (X : RRel) : RRel := reaches.
Lemma gt_mono : mono ground_truth. firstorder. Qed.

Lemma gt_valid : derived_valid_m ground_truth.
unfold derived_valid_m, subrel.
intros.
destruct H.
apply DoneF. assumption.
apply StepF with y. assumption.
apply drule. assumption.
Qed.

(* Now let's consider rule compositionality *)

(* TODO
   Here's some new idea about composing rules even with the
   hypothesis about a proof of X.

   Need to check it's actually compositional.

   Probably need to say more about G
   if this is going to have any hope of being equivalent
   to the generic defition.
  *)
Definition compos_derived_valid (F : RRel -> RRel) : Prop :=
  forall X G, (forall Y, subrel (F Y) (G Y)) ->
     subrel X (stepF (derived G X)) ->
    subrel (F (stepF (derived G X))) (stepF (derived G X)).

(* To directly enable compositionaly, take derived_valid without
   the hypothesis on X, and generialize the rules allowed in
   the right hand sides to be any G pointwise greater than F.

   We'll prove further rules showing this equivalent to
   other things.
 *)
Definition derived_valid' (F : RRel -> RRel) : Prop :=
  forall (X Q : RRel) (G : RRel -> RRel)
    (HQ : subrel Q (stepF (derived G X)))
    (HG : forall X, subrel (F X) (G X)),
    subrel (F Q) (stepF (derived G X)).

(* Show this condition is preserved by monotonizing F,
   so we might as well assume F mono.
 *)
Lemma comp_valid1_wlog_mono (F : RRel -> RRel) :
  derived_valid' F <-> derived_valid' (monotonize F).
split.
destruct 4;by_subrel;eauto using monotonize_includes with subrel.

unfold derived_valid'.
intros Hvalid X Q G HQ HG.
specialize (Hvalid X Q (monotonize G)).
eapply subrel_trans;[apply monotonize_includes|].
eapply subrel_trans;[apply Hvalid|];clear Hvalid.
apply (subrel_trans HQ). apply stepF_mono;unfold subrel;apply derived_wlog_mono.
apply monotonize_pointwise;assumption.
apply stepF_mono;unfold subrel;apply derived_wlog_mono.
Qed.

(* For a monotone F, might as well pre-apply HQ *)
Definition derived_valid'' (F : RRel -> RRel) : Prop :=
  forall (X : RRel) (G : RRel -> RRel)
    (HG : forall X, subrel (F X) (G X)),
    subrel (F (stepF (derived G X))) (stepF (derived G X)).

(* 2 follows from 1 always *)
Lemma comp_valid2_from_1 : forall F, derived_valid' F -> derived_valid'' F.
Proof.
unfold derived_valid', derived_valid'',subrel;firstorder.
Qed.
(* 1 follows from 2 for monotone F *)
Lemma comp_valid1_from_2_when_mono : forall F (F_mono : mono F),
  derived_valid'' F -> derived_valid' F.
Proof.
unfold derived_valid'', derived_valid';eauto with subrel.
Qed.

(* Because we know nothing about G, and the first constructor of
   derived G X could be a drule, we might as well replace derived G X
   with an opaque set on the left. On the right, we just need to
   know we can apply F.
   So, this should be equivalent, but perhaps we won't
   be able to prove that.
  *)
Definition derived_valid''' (F : RRel -> RRel) : Prop :=
  forall (X : RRel), subrel (F (stepF X)) (stepF (derived F X)).

(* It implies 2, even without assuming monotonicity *)
Lemma comp_valid2_from_3 : forall F,
   derived_valid''' F -> derived_valid'' F.
unfold derived_valid''', derived_valid''.
eauto using deri_lift,deri_join_subrel with subrel.
Qed.

(* To go the other way, we have an arbitrary X,
   and need monotonicity to make use of the fact that
   any X is included in derived F X
 *)
Lemma comp_valid3_from_2_when_mono : forall F,
   mono F -> derived_valid'' F -> derived_valid''' F.
unfold derived_valid'', derived_valid'''.
intros. pose proof (dleaf_subrel F X); eauto with subrel.
Qed.

(* This is also very close to derived_valid_m *)
Lemma valid_m_from_3 : forall F,
  derived_valid''' F -> derived_valid_m F.
unfold derived_valid_m, derived_valid'''.
eauto using deri_join_subrel with subrel.
Qed.
Lemma comp_valid3_from_m_when_mono : forall F, mono F ->
  derived_valid_m F -> derived_valid''' F.
unfold derived_valid_m, derived_valid'''.
eauto using dleaf_subrel with subrel.
Qed.

Lemma derived'_from_m : forall F, mono F -> derived_valid_m F -> derived_valid' F.
intros;apply comp_valid1_from_2_when_mono;
[|apply comp_valid2_from_3;apply comp_valid3_from_m_when_mono];assumption.
Qed.

(* That's enough about equivalence of conditions.
   Let's show that some of these guys are actually compositional! *)

(* Combining rules *)
Definition union_rrel (R1 R2 : RRel) : RRel :=
  fun x P => R1 x P \/ R2 x P.
Lemma union_rrel_l (R1 R2: RRel) : subrel R1 (union_rrel R1 R2).
firstorder.
Qed.
Lemma union_rrel_r (R1 R2: RRel) : subrel R2 (union_rrel R1 R2).
firstorder.
Qed.

Hint Resolve stepF_mono union_rrel_l union_rrel_r : subrel.

Lemma union_split (P1 P2 Q : RRel) :
  subrel P1 Q -> subrel P2 Q -> subrel (union_rrel P1 P2) Q.
Proof.
firstorder.
Qed.
Hint Resolve union_split : subrel.

Inductive union_rules (F G : RRel -> RRel) (X : RRel) : RRel :=
  | d_union_left : forall x P, F X x P -> union_rules F G X x P
  | d_union_right : forall x P, G X x P -> union_rules F G X x P
  .

Lemma union_mono F G :
  mono F -> mono G -> mono (union_rules F G).
Proof. unfold mono, subrel.
destruct 4;[apply d_union_left|apply d_union_right];firstorder.
Qed.

(* Condition 3 is compositional, even without extra monotonicity assumptions *)
Lemma union_rules_valid''' F G :
  derived_valid''' F -> derived_valid''' G ->
  derived_valid''' (union_rules F G).
intros Fvalid Gvalid.
unfold derived_valid'''. intros X.
unfold subrel. intros x P.
destruct 1;[apply Fvalid in H|apply Gvalid in H];revert x P H;
apply stepF_mono;apply deri_lift;clear;unfold subrel;auto using union_rules.
Qed.

(* An example linking lemma *)
Lemma link2 (F : RRel -> RRel) (F_mono : mono F) (P1 Q1 P2 Q2 : RRel) :
            (subrel P1 (stepF (derived F Q1))) ->
            (subrel P2 (stepF (derived F Q2))) ->
            (subrel Q1 (union_rrel P1 P2)) ->
            (subrel Q2 (union_rrel P1 P2)) ->
            derived_stable F (union_rrel P1 P2).
unfold derived_stable;intros.
apply union_split;eauto with subrel.
Qed.
End Cotrans.


(** * Auto: More Automation *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import omega.Omega.
From LF Require Import Maps.
From LF Require Import Imp.

(** Up to now, we've used the more manual part of Coq's tactic
    facilities.  In this chapter, we'll learn more about some of Coq's
    powerful automation features: proof search via the [auto] tactic,
    automated forward reasoning via the [Ltac] hypothesis matching
    machinery, and deferred instantiation of existential variables
    using [eapply] and [eauto].  Using these features together with
    Ltac's scripting facilities will enable us to make our proofs
    startlingly short!  Used properly, they can also make proofs more
    maintainable and robust to changes in underlying definitions.  A
    deeper treatment of [auto] and [eauto] can be found in the
    [UseAuto] chapter in _Programming Language Foundations_.

    There's another major category of automation we haven't discussed
    much yet, namely built-in decision procedures for specific kinds
    of problems: [omega] is one example, but there are others.  This
    topic will be deferred for a while longer.

    Our motivating example will be this proof, repeated with just a
    few small changes from the [Imp] chapter.  We will simplify
    this proof in several stages. *)

(** First, define a little Ltac macro to compress a common
    pattern into a single command. *)
Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; apply H1. }
    subst st'0.
    apply IHE1_2. assumption.
  (* E_IfTrue *)
  - (* b evaluates to true *)
    apply IHE1. assumption.
  - (* b evaluates to false (contradiction) *)
    rewrite H in H5. inversion H5.
  (* E_IfFalse *)
  - (* b evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* b evaluates to false *)
    apply IHE1. assumption.
  (* E_WhileFalse *)
  - (* b evaluates to false *)
    reflexivity.
  - (* b evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.  Qed.

(* ################################################################# *)
(** * The [auto] Tactic *)

(** Thus far, our proof scripts mostly apply relevant hypotheses or
    lemmas by name, and one at a time. *)

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. assumption.
Qed.

(** The [auto] tactic frees us from this drudgery by _searching_ for a
    sequence of applications that will prove the goal: *)

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

(** The [auto] tactic solves goals that are solvable by any combination of
     - [intros] and
     - [apply] (of hypotheses from the local context, by default). *)

(** Using [auto] is always "safe" in the sense that it will never fail
    and will never change the proof state: either it completely solves
    the current goal, or it does nothing. *)

(** Here is a more interesting example showing [auto]'s power: *)

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

(** Proof search could, in principle, take an arbitrarily long time,
    so there are limits to how far [auto] will search by default. *)

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  (* When it cannot solve the goal, [auto] does nothing *)
  auto.
  (* Optional argument says how deep to search (default is 5) *)
  auto 6.
Qed.

(** When searching for potential proofs of the current goal,
    [auto] considers the hypotheses in the current context together
    with a _hint database_ of other lemmas and constructors.  Some
    common lemmas about equality and logical operators are installed
    in this hint database by default. *)

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof. auto. Qed.

(** We can extend the hint database just for the purposes of one
    application of [auto] by writing "[auto using ...]". *)

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto using le_antisym.
Qed.

(** Of course, in any given development there will probably be
    some specific constructors and lemmas that are used very often in
    proofs.  We can add these to the global hint database by writing

      Hint Resolve T.

    at the top level, where [T] is a top-level theorem or a
    constructor of an inductively defined proposition (i.e., anything
    whose type is an implication).  As a shorthand, we can write

      Hint Constructors c.

    to tell Coq to do a [Hint Resolve] for _all_ of the constructors
    from the inductive definition of [c].

    It is also sometimes necessary to add

      Hint Unfold d.

    where [d] is a defined symbol, so that [auto] knows to expand uses
    of [d], thus enabling further possibilities for applying lemmas that
    it knows about. *)

(** It is also possible to define specialized hint databases that can
    be activated only when needed.  See the Coq reference manual for
    more. *)

Hint Resolve le_antisym.

Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. (* picks up hint from database *)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  auto.  (* does nothing *)
Abort.

Hint Unfold is_fortytwo.

Example auto_example_7' : forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof. auto. Qed.

(** Let's take a first pass over [ceval_deterministic] to simplify the
    proof script. *)

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
       induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
Qed.

(** When we are using a particular tactic many times in a proof, we
    can use a variant of the [Proof] command to make that tactic into
    a default within the proof.  Saying [Proof with t] (where [t] is
    an arbitrary tactic) allows us to use [t1...] as a shorthand for
    [t1;t] within the proof.  As an illustration, here is an alternate
    version of the previous proof, using [Proof with auto]. *)

Theorem ceval_deterministic'_alt: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof with auto.
  intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1;
           intros st2 E2; inv E2...
  - (* E_Seq *)
    assert (st' = st'0) as EQ1...
    subst st'0...
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rewrite H in H2. inversion H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1...
    subst st'0...
Qed.

(* ################################################################# *)
(** * Searching For Hypotheses *)

(** The proof has become simpler, but there is still an annoying
    amount of repetition. Let's start by tackling the contradiction
    cases. Each of them occurs in a situation where we have both

      H1: beval st b = false

    and

      H2: beval st b = true

    as hypotheses.  The contradiction is evident, but demonstrating it
    is a little complicated: we have to locate the two hypotheses [H1]
    and [H2] and do a [rewrite] following by an [inversion].  We'd
    like to automate this process.

    (In fact, Coq has a built-in tactic [congruence] that will do the
    job in this case.  But we'll ignore the existence of this tactic
    for now, in order to demonstrate how to build forward search
    tactics by hand.)

    As a first step, we can abstract out the piece of script in
    question by writing a little function in Ltac. *)

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Theorem ceval_deterministic'': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_IfTrue *)
    + (* b evaluates to false (contradiction) *)
      rwinv H H5.
  - (* E_IfFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H5.
  - (* E_WhileFalse *)
    + (* b evaluates to true (contradiction) *)
      rwinv H H2.
  (* E_WhileTrue *)
  - (* b evaluates to false (contradiction) *)
    rwinv H H4.
  - (* b evaluates to true *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto. Qed.

(** That was a bit better, but we really want Coq to discover the
    relevant hypotheses for us.  We can do this by using the [match
    goal] facility of Ltac. *)

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

(** This [match goal] looks for two distinct hypotheses that
    have the form of equalities, with the same arbitrary expression
    [E] on the left and with conflicting boolean values on the right.
    If such hypotheses are found, it binds [H1] and [H2] to their
    names and applies the [rwinv] tactic to [H1] and [H2].

    Adding this tactic to the ones that we invoke in each case of the
    induction handles all of the contradictory cases. *)

Theorem ceval_deterministic''': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1 by auto.
    subst st'0.
    auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      assert (st' = st'0) as EQ1 by auto.
      subst st'0.
      auto. Qed.

(** Let's see about the remaining cases. Each of them involves
    applying a conditional hypothesis to extract an equality.
    Currently we have phrased these as assertions, so that we have to
    predict what the resulting equality will be (although we can then
    use [auto] to prove it).  An alternative is to pick the relevant
    hypotheses to use and then [rewrite] with them, as follows: *)

Theorem ceval_deterministic'''': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv; auto.
  - (* E_Seq *)
    rewrite (IHE1_1 st'0 H1) in *. auto.
  - (* E_WhileTrue *)
    + (* b evaluates to true *)
      rewrite (IHE1_1 st'0 H3) in *. auto. Qed.

(** Now we can automate the task of finding the relevant hypotheses to
    rewrite with. *)

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

(** The pattern [forall x, ?P x -> ?L = ?R] matches any hypothesis of
    the form "for all [x], _some property of [x]_ implies _some
    equality_."  The property of [x] is bound to the pattern variable
    [P], and the left- and right-hand sides of the equality are bound
    to [L] and [R].  The name of this hypothesis is bound to [H1].
    Then the pattern [?P ?X] matches any hypothesis that provides
    evidence that [P] holds for some concrete [X].  If both patterns
    succeed, we apply the [rewrite] tactic (instantiating the
    quantified [x] with [X] and providing [H2] as the required
    evidence for [P X]) in all hypotheses and the goal.

    One problem remains: in general, there may be several pairs of
    hypotheses that have the right general form, and it seems tricky
    to pick out the ones we actually need.  A key trick is to realize
    that we can _try them all_!  Here's how this works:

    - each execution of [match goal] will keep trying to find a valid
      pair of hypotheses until the tactic on the RHS of the match
      succeeds; if there are no such pairs, it fails;
    - [rewrite] will fail given a trivial equation of the form [X = X];
    - we can wrap the whole thing in a [repeat], which will keep doing
      useful rewrites until only trivial ones are left. *)

Theorem ceval_deterministic''''': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2; try find_rwinv;
    repeat find_eqn; auto.
Qed.

(** The big payoff in this approach is that our proof script should be
    more robust in the face of modest changes to our language.  To
    test this, let's try adding a [REPEAT] command to the language. *)

Module Repeat.

Inductive com : Type :=
  | CSkip
  | CAsgn (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CRepeat (c : com) (b : bexp).

(** [REPEAT] behaves like [WHILE], except that the loop guard is
    checked _after_ each execution of the body, with the loop
    repeating as long as the guard stays _false_.  Because of this,
    the body will always execute at least once. *)

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "X '::=' a" :=
  (CAsgn X a) (at level 60).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'REPEAT' e1 'UNTIL' b2 'END'" :=
  (CRepeat e1 b2) (at level 80, right associativity).

Inductive ceval : state -> com -> state -> Prop :=
  | E_Skip : forall st,
      ceval st SKIP st
  | E_Ass  : forall st a1 n X,
      aeval st a1 = n ->
      ceval st (X ::= a1) (t_update st X n)
  | E_Seq : forall c1 c2 st st' st'',
      ceval st c1 st' ->
      ceval st' c2 st'' ->
      ceval st (c1 ; c2) st''
  | E_IfTrue : forall st st' b1 c1 c2,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_IfFalse : forall st st' b1 c1 c2,
      beval st b1 = false ->
      ceval st c2 st' ->
      ceval st (TEST b1 THEN c1 ELSE c2 FI) st'
  | E_WhileFalse : forall b1 st c1,
      beval st b1 = false ->
      ceval st (WHILE b1 DO c1 END) st
  | E_WhileTrue : forall st st' st'' b1 c1,
      beval st b1 = true ->
      ceval st c1 st' ->
      ceval st' (WHILE b1 DO c1 END) st'' ->
      ceval st (WHILE b1 DO c1 END) st''
  | E_RepeatEnd : forall st st' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = true ->
      ceval st (CRepeat c1 b1) st'
  | E_RepeatLoop : forall st st' st'' b1 c1,
      ceval st c1 st' ->
      beval st' b1 = false ->
      ceval st' (CRepeat c1 b1) st'' ->
      ceval st (CRepeat c1 b1) st''.

Notation "st '=[' c ']=>' st'" := (ceval st c st')
                                 (at level 40).

(** Our first attempt at the determinacy proof does not quite succeed:
    the [E_RepeatEnd] and [E_RepeatLoop] cases are not handled by our
    previous automation. *)

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; try find_rwinv; repeat find_eqn; auto.
  - (* E_RepeatEnd *)
    + (* b evaluates to false (contradiction) *)
       find_rwinv.
       (* oops: why didn't [find_rwinv] solve this for us already?
          answer: we did things in the wrong order. *)
  - (* E_RepeatLoop *)
     + (* b evaluates to true (contradiction) *)
        find_rwinv.
Qed.

(** Fortunately, to fix this, we just have to swap the invocations of
    [find_eqn] and [find_rwinv]. *)

Theorem ceval_deterministic': forall c st st1 st2,
    st =[ c ]=> st1  ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2;
  induction E1;
    intros st2 E2; inv E2; repeat find_eqn; try find_rwinv; auto.
Qed.

End Repeat.

(** These examples just give a flavor of what "hyper-automation"
    can achieve in Coq.  The details of [match goal] are a bit
    tricky (and debugging scripts using it is, frankly, not very
    pleasant).  But it is well worth adding at least simple uses to
    your proofs, both to avoid tedium and to "future proof" them. *)

(* ================================================================= *)
(** ** The [eapply] and [eauto] variants *)

(** To close the chapter, we'll introduce one more convenient feature
    of Coq: its ability to delay instantiation of quantifiers.  To
    motivate this feature, recall this example from the [Imp]
    chapter: *)

Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  (* We supply the intermediate state [st']... *)
  apply E_Seq with (X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** In the first step of the proof, we had to explicitly provide a
    longish expression to help Coq instantiate a "hidden" argument to
    the [E_Seq] constructor.  This was needed because the definition
    of [E_Seq]...

          E_Seq : forall c1 c2 st st' st'',
            st  =[ c1 ]=> st'  ->
            st' =[ c2 ]=> st'' ->
            st  =[ c1 ;; c2 ]=> st''

   is quantified over a variable, [st'], that does not appear in its
   conclusion, so unifying its conclusion with the goal state doesn't
   help Coq find a suitable value for this variable.  If we leave
   out the [with], this step fails ("Error: Unable to find an
   instance for the variable [st']").

   What's silly about this error is that the appropriate value for [st']
   will actually become obvious in the very next step, where we apply
   [E_Ass].  If Coq could just wait until we get to this step, there
   would be no need to give the value explicitly.  This is exactly what
   the [eapply] tactic gives us: *)

Example ceval'_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  eapply E_Seq. (* 1 *)
  - apply E_Ass. (* 2 *)
    reflexivity. (* 3 *)
  - (* 4 *) apply E_IfFalse. reflexivity. apply E_Ass. reflexivity.
Qed.

(** The [eapply H] tactic behaves just like [apply H] except
    that, after it finishes unifying the goal state with the
    conclusion of [H], it does not bother to check whether all the
    variables that were introduced in the process have been given
    concrete values during unification.

    If you step through the proof above, you'll see that the goal
    state at position [1] mentions the _existential variable_ [?st']
    in both of the generated subgoals.  The next step (which gets us
    to position [2]) replaces [?st'] with a concrete value.  This new
    value contains a new existential variable [?n], which is
    instantiated in its turn by the following [reflexivity] step,
    position [3].  When we start working on the second
    subgoal (position [4]), we observe that the occurrence of [?st']
    in this subgoal has been replaced by the value that it was given
    during the first subgoal. *)

(** Several of the tactics that we've seen so far, including [exists],
    [constructor], and [auto], have similar variants.  For example,
    here's a proof using [eauto]: *)

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Definition st12 := (Y !-> 2 ; X !-> 1).
Definition st21 := (Y !-> 1 ; X !-> 2).

Example eauto_example : exists s',
  st21 =[
    TEST X <= Y
      THEN Z ::= Y - X
      ELSE Y ::= X + Z
    FI
  ]=> s'.
Proof. eauto. Qed.

(** The [eauto] tactic works just like [auto], except that it uses
    [eapply] instead of [apply].

    Pro tip: One might think that, since [eapply] and [eauto] are more
    powerful than [apply] and [auto], it would be a good idea to use
    them all the time.  Unfortunately, they are also significantly
    slower -- especially [eauto].  Coq experts tend to use [apply] and
    [auto] most of the time, only switching to the [e] variants when
    the ordinary variants don't do the job. *)

(* Wed Jan 9 12:02:47 EST 2019 *)


Require Import ExtLib.Data.HList.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.CtxLogic.

Section definitions.
  Variables typ expr : Type.
  Context {RType_typ : RType typ}.
  Context {Expr_expr : Expr _ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.

  (** instantiate **)
  Variable instantiate : (uvar -> option expr) -> nat -> expr -> expr.

  Definition sem_preserves_if_ho tus tvs
             (P : exprT tus tvs Prop -> Prop)
             (f : nat -> option expr) : Prop :=
    forall u e t get,
      f u = Some e ->
      nth_error_get_hlist_nth _ tus u = Some (@existT _ _ t get) ->
      exists eD,
        exprD' tus tvs e t = Some eD /\
        P (fun us vs => get us = eD us vs).

  Definition sem_preserves_if tus tvs
             (P : hlist _ tus -> hlist _ tvs -> Prop)
             (f : nat -> option expr) : Prop :=
    forall u e t get,
      f u = Some e ->
      nth_error_get_hlist_nth _ tus u = Some (@existT _ _ t get) ->
      exists eD,
        exprD' tus tvs e t = Some eD /\
        forall us vs,
          P us vs ->
          get us = eD us vs.

(*
  Definition instantiate_mentionsU : Prop :=
    forall f n e u,
      mentionsU u (instantiate f n e) = true <-> (** do i need iff? **)
      (   (f u = None /\ mentionsU u e = true)
       \/ exists u' e',
            f u' = Some e' /\
            mentionsU u' e = true/\
            mentionsU u e' = true).

  Definition exprD'_instantiate : Prop :=
    forall tus tvs f e tvs' t eD P,
      sem_preserves_if tus tvs P f ->
      exprD' tus (tvs' ++ tvs) e t = Some eD ->
      exists eD',
        exprD' tus (tvs' ++ tvs) (instantiate f (length tvs') e) t = Some eD' /\
        forall us vs vs',
          P us vs ->
          eD us (hlist_app vs' vs) = eD' us (hlist_app vs' vs).

  Definition sem_instantiate_ho {T TD} (R : TD -> TD -> Prop)
             (exprD' : forall tus tvs, T -> option (exprT tus tvs TD))
             (instantiate : (nat -> option expr) -> nat -> T -> T)
  : Prop :=
    forall tus tvs f e tvs' eD P (App : ExprTApplicative P),
      sem_preserves_if_ho tus tvs P f ->
      exprD' tus (tvs' ++ tvs) e = Some eD ->
      exists eD',
        exprD' tus (tvs' ++ tvs) (instantiate f (length tvs') e) = Some eD' /\
        P (fun us vs => forall vs',
                          eD us (hlist_app vs' vs) = eD' us (hlist_app vs' vs)).
*)

(*
  Goal (forall t : typ, @sem_instantiate_ho expr (typD t) (@eq _)
                                            (fun tus tvs e => exprD' tus tvs e t)
                                            instantiate) ->
  exprD'_instantiate.
  Proof.
    unfold exprD'_instantiate, sem_instantiate_ho.
    intuition.
    specialize (@H t tus tvs f e tvs' eD
                   (fun (P' : exprT tus tvs Prop) => forall us vs,
                                P us vs ->
                                P' us vs)).
    destruct H.
    - clear. constructor; firstorder.
    - red. red in H0. intros.
      eapply H0 in H; eauto.
    - eauto.
    - exists x. intuition.
  Qed.
*)

End definitions.

Arguments sem_preserves_if {typ expr RType Expr} _ _ _ _ : rename.
Arguments sem_preserves_if_ho {typ expr RType Expr} tus tvs C f : rename.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Syntax.
Require Import bedrock2.Semantics.
Require Import bedrock2.BasicC64Semantics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ZRange.
Import API.Compilers.

Require Import Crypto.Util.Notations.
Import Types.Notations ListNotations.
Local Open Scope Z_scope.
Local Open Scope string_scope.

(* Declares default parameters for the bedrock2 backend specific to systems with
a 64-bit word size. *)

Section Defaults_64.
  Definition machine_wordsize := 64.

  (* Define how to split mul/multi-return functions *)
  Definition possible_values
    := prefix_with_carry [machine_wordsize; 2 * machine_wordsize]%Z.
  Instance no_select_size : no_select_size_opt :=
    no_select_size_of_no_select machine_wordsize.
  Instance split_mul_to : split_mul_to_opt :=
    split_mul_to_of_should_split_mul machine_wordsize possible_values.
  Instance split_multiret_to : split_multiret_to_opt :=
    split_multiret_to_of_should_split_multiret machine_wordsize possible_values.
  Let wordsize_bytes := Eval vm_compute in (machine_wordsize / 8)%Z.
  Instance default_parameters : Types.parameters :=
    {| semantics := BasicC64Semantics.parameters;
       varname_gen := default_varname_gen;
       error := expr.var Defaults.ERROR;
       word_size_in_bytes := wordsize_bytes;
    |}.
  Instance default_parameters_ok : Types.ok.
  Proof.
    constructor.
    { exact BasicC64Semantics.parameters_ok. }
    { reflexivity. }
    { reflexivity. }
    { reflexivity. }
    { apply prefix_name_gen_unique. }
  Defined.
End Defaults_64.

Module Notations.
  Notation "'uint64,uint64'" := (ident.Literal
                                   (r[0 ~> 18446744073709551615]%zrange,
                                    r[0 ~> 18446744073709551615]%zrange)%core) : expr_scope.
  Notation "'uint64'" :=
    (ident.Literal (t:=Compilers.zrange) r[0 ~> 18446744073709551615]%zrange) : expr_scope.
End Notations.