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

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

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

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

(** * Floating-point format with abrupt underflow *)
Require Import Raux Defs Round_pred Generic_fmt.
Require Import Float_prop Ulp FLX.

Section RND_FTZ.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

Inductive FTZ_format (x : R) : Prop :=
  FTZ_spec (f : float beta) :
    x = F2R f ->
    (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z ->
    (emin <= Fexp f)%Z ->
    FTZ_format x.

Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z.

(** Properties of the FTZ format *)
Global Instance FTZ_exp_valid : Valid_exp FTZ_exp.
Proof.
intros k.
unfold FTZ_exp.
generalize (Zlt_cases (k - prec) emin).
case (Zlt_bool (k - prec) emin) ; intros H1.
split ; intros H2.
omega.
split.
generalize (Zlt_cases (emin + prec + 1 - prec) emin).
case (Zlt_bool (emin + prec + 1 - prec) emin) ; intros H3.
omega.
generalize (Zlt_cases (emin + prec - 1 + 1 - prec) emin).
generalize (prec_gt_0 prec).
case (Zlt_bool (emin + prec - 1 + 1 - prec) emin) ; omega.
intros l H3.
generalize (Zlt_cases (l - prec) emin).
case (Zlt_bool (l - prec) emin) ; omega.
split ; intros H2.
generalize (Zlt_cases (k + 1 - prec) emin).
case (Zlt_bool (k + 1 - prec) emin) ; omega.
generalize (prec_gt_0 prec).
split ; intros ; omega.
Qed.

Theorem FLXN_format_FTZ :
  forall x, FTZ_format x -> FLXN_format beta prec x.
Proof.
intros x [[xm xe] Hx1 Hx2 Hx3].
eexists.
exact Hx1.
exact Hx2.
Qed.

Theorem generic_format_FTZ :
  forall x, FTZ_format x -> generic_format beta FTZ_exp x.
Proof.
intros x Hx.
cut (generic_format beta (FLX_exp prec) x).
apply generic_inclusion_mag.
intros Zx.
destruct Hx as [[xm xe] Hx1 Hx2 Hx3].
simpl in Hx2, Hx3.
specialize (Hx2 Zx).
assert (Zxm: xm <> Z0).
contradict Zx.
rewrite Hx1, Zx.
apply F2R_0.
unfold FTZ_exp, FLX_exp.
rewrite Zlt_bool_false.
apply Z.le_refl.
rewrite Hx1, mag_F2R with (1 := Zxm).
cut (prec - 1 < mag beta (IZR xm))%Z.
clear -Hx3 ; omega.
apply mag_gt_Zpower with (1 := Zxm).
apply Hx2.
apply generic_format_FLXN.
now apply FLXN_format_FTZ.
Qed.

Theorem FTZ_format_generic :
  forall x, generic_format beta FTZ_exp x -> FTZ_format x.
Proof.
intros x Hx.
destruct (Req_dec x 0) as [->|Hx3].
exists (Float beta 0 emin).
apply sym_eq, F2R_0.
intros H.
now elim H.
apply Z.le_refl.
unfold generic_format, scaled_mantissa, cexp, FTZ_exp in Hx.
destruct (mag beta x) as (ex, Hx4).
simpl in Hx.
specialize (Hx4 Hx3).
generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx.
case (Zlt_bool (ex - prec) emin) ; intros Hx5 Hx2.
elim Rlt_not_ge with (1 := proj2 Hx4).
apply Rle_ge.
rewrite Hx2, <- F2R_Zabs.
rewrite <- (Rmult_1_l (bpow ex)).
unfold F2R. simpl.
apply Rmult_le_compat.
now apply IZR_le.
apply bpow_ge_0.
apply IZR_le.
apply (Zlt_le_succ 0).
apply lt_IZR.
apply Rmult_lt_reg_r with (bpow (emin + prec - 1)).
apply bpow_gt_0.
rewrite Rmult_0_l.
change (0 < F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R.
rewrite F2R_Zabs, <- Hx2.
now apply Rabs_pos_lt.
apply bpow_le.
omega.
rewrite Hx2.
eexists ; repeat split ; simpl.
apply le_IZR.
rewrite IZR_Zpower.
apply Rmult_le_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring.
change (bpow (ex - 1) <= F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
apply Zle_minus_le_0.
now apply (Zlt_le_succ 0).
apply lt_IZR.
rewrite IZR_Zpower.
apply Rmult_lt_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec + (ex - prec))%Z with ex by ring.
change (F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
now apply Zlt_le_weak.
now apply Z.ge_le.
Qed.

Theorem FTZ_format_satisfies_any :
  satisfies_any FTZ_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FTZ_exp)).
intros x.
split.
apply FTZ_format_generic.
apply generic_format_FTZ.
Qed.

Theorem FTZ_format_FLXN :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  FLXN_format beta prec x -> FTZ_format x.
Proof.
intros x Hx Fx.
apply FTZ_format_generic.
apply generic_format_FLXN in Fx.
revert Hx Fx.
apply generic_inclusion_ge.
intros e He.
unfold FTZ_exp.
rewrite Zlt_bool_false.
apply Z.le_refl.
omega.
Qed.

Theorem ulp_FTZ_0 :
  ulp beta FTZ_exp 0 = bpow (emin+prec-1).
Proof with auto with typeclass_instances.
unfold ulp; rewrite Req_bool_true; trivial.
case (negligible_exp_spec FTZ_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
apply Zle_not_lt; unfold FTZ_exp; unfold Prec_gt_0 in prec_gt_0_.
rewrite Zlt_bool_true; omega.
assert (V:(FTZ_exp (emin+prec-1) = emin+prec-1)%Z).
unfold FTZ_exp; rewrite Zlt_bool_true; omega.
intros n H2; rewrite <-V.
apply f_equal, fexp_negligible_exp_eq...
omega.
Qed.

Section FTZ_round.

(** Rounding with FTZ *)
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Definition Zrnd_FTZ x :=
  if Rle_bool 1 (Rabs x) then rnd x else Z0.

Global Instance valid_rnd_FTZ : Valid_rnd Zrnd_FTZ.
Proof with auto with typeclass_instances.
split.
(* *)
intros x y Hxy.
unfold Zrnd_FTZ.
case Rle_bool_spec ; intros Hx ;
  case Rle_bool_spec ; intros Hy.
4: easy.
(* 1 <= |x| *)
now apply Zrnd_le.
rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rle_trans with (-1)%R. 2: now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1].
exact Hx1.
elim Rle_not_lt with (1 := Hx1).
apply Rle_lt_trans with (2 := Hy).
apply Rle_trans with (1 := Hxy).
apply RRle_abs.
(* |x| < 1 *)
rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rle_trans with 1%R.
now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1].
elim Rle_not_lt with (1 := Hy1).
apply Rlt_le_trans with (2 := Hxy).
apply (Rabs_def2 _ _ Hx).
exact Hy1.
(* *)
intros n.
unfold Zrnd_FTZ.
rewrite Zrnd_IZR...
case Rle_bool_spec.
easy.
rewrite <- abs_IZR.
intros H.
generalize (lt_IZR _ 1 H).
clear.
now case n ; trivial ; simpl ; intros [p|p|].
Qed.

Theorem round_FTZ_FLX :
  forall x : R,
  (bpow (emin + prec - 1) <= Rabs x)%R ->
  round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x.
Proof.
intros x Hx.
unfold round, scaled_mantissa, cexp.
destruct (mag beta x) as (ex, He). simpl.
assert (Hx0: x <> 0%R).
intros Hx0.
apply Rle_not_lt with (1 := Hx).
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
specialize (He Hx0).
assert (He': (emin + prec <= ex)%Z).
apply (bpow_lt_bpow beta).
apply Rle_lt_trans with (1 := Hx).
apply He.
replace (FTZ_exp ex) with (FLX_exp prec ex).
unfold Zrnd_FTZ.
rewrite Rle_bool_true.
apply refl_equal.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FLX_exp prec ex))).
change 1%R with (bpow 0).
rewrite <- (Zplus_opp_r (FLX_exp prec ex)).
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rle_trans with (2 := proj1 He).
apply bpow_le.
unfold FLX_exp.
generalize (prec_gt_0 prec).
clear -He' ; omega.
apply bpow_ge_0.
unfold FLX_exp, FTZ_exp.
rewrite Zlt_bool_false.
apply refl_equal.
clear -He' ; omega.
Qed.

Theorem round_FTZ_small :
  forall x : R,
  (Rabs x < bpow (emin + prec - 1))%R ->
  round beta FTZ_exp Zrnd_FTZ x = 0%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply round_0...
unfold round, scaled_mantissa, cexp.
destruct (mag beta x) as (ex, He). simpl.
specialize (He Hx0).
unfold Zrnd_FTZ.
rewrite Rle_bool_false.
apply F2R_0.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow (- FTZ_exp ex))).
change 1%R with (bpow 0).
rewrite <- (Zplus_opp_r (FTZ_exp ex)).
rewrite bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
unfold FTZ_exp.
generalize (Zlt_cases (ex - prec) emin).
case Zlt_bool.
intros _.
apply Z.le_refl.
intros He'.
elim Rlt_not_le with (1 := Hx).
apply Rle_trans with (2 := proj1 He).
apply bpow_le.
omega.
apply bpow_ge_0.
Qed.

End FTZ_round.

End RND_FTZ.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Language LN LibTactics.
Require Import SubAndTopLike Appsub. (* Hint Base: subtyping *)
Require Import Ptype Disjoint Value. (* Hint Base: ptype, value, lc *)
Require Import Tred Consistent. (* Hint Base: tred, con *)
Require Import Papp.
Require Import Program.Tactics.
Require Import Psatz. (* lia *)

Set Printing Parentheses.

Theorem determinism:
  forall (e e1 e2 : trm) (A : typ),
    typing nil e A ->
    step e e1 -> step e e2 -> e1 = e2.
Proof with eauto with value.
  intros e e1 e2 A Htyp Hstep1 Hstep2.
  gen e2 A.
  dependent induction Hstep1; intros.
  - dependent destruction Hstep2...
  - dependent destruction Hstep2...
  - dependent destruction Hstep2.
    + eapply split_determinism in H0; eauto.
      destruct H0. subst. reflexivity.
    + exfalso. eapply pvalue_and_value; eauto.
    + contradiction.
  - dependent destruction Hstep2...
    eapply papp_determinism. eapply H. eapply H0. eapply H1. eapply H4. eapply Htyp.
  - dependent destruction Hstep2...
    + dependent destruction Htyp.
      eapply tred_determinism; eauto.
  - dependent destruction Hstep2...
    + contradiction.
    + assert (Heq: e' = e'0).
      dependent destruction Htyp; eauto.
      congruence.
  - dependent destruction Hstep2...
    + dependent destruction Htyp; eauto.
      assert (e1' = e1'0); eauto. congruence.
  - dependent destruction Hstep2...
    + dependent destruction Htyp.
      assert (e2' = e2'0); eauto. congruence.
  - dependent destruction Hstep2...
    + dependent destruction Htyp.
      * assert (e1' = e1'0)...
        assert (e2' = e2'0)...
        congruence.
      * assert (e1' = e1'0)...
        assert (e2' = e2'0)...
        congruence.
  - dependent destruction Hstep2...
    + assert (e1' = e1'0).
      dependent destruction Htyp; eapply IHHstep1; eauto.
      congruence.
  - dependent destruction Hstep2...
    assert (e2' = e2'0); eauto.
    dependent destruction Htyp; eauto.
    congruence.
Qed.

Lemma tred_lc_preservation :
  forall v v' A,
    lc v ->
    typedred v A v' ->
    lc v'.
Proof.
  introv Lc Htred.
  dependent induction Htred; eauto with lc.
Qed.

Hint Resolve tred_lc_preservation : lc.

Lemma papp_lc_preservation :
  forall e1 e2 e,
    lc e1 -> lc e2 -> papp e1 e2 e -> lc e.
Proof.
  introv Lc1 Lc2 Hp.
  dependent induction Hp; eauto 3 with lc.
  - eapply lc_anno. eapply open_abs; eauto with lc.
  - dependent destruction Lc1; eauto.
Qed.

Hint Resolve papp_lc_preservation : lc.

Lemma step_lc_preservation :
  forall e e',
    lc e -> step e e' -> lc e'.
Proof.
  introv Hlc Hstep. gen e'.
  induction Hlc; intros;
    try solve [dependent destruction Hstep; eauto].
  - dependent destruction Hstep; eauto 3 with lc.
  - dependent destruction Hstep; eauto 3 with lc.
    eapply lc_merge; eauto.
Qed.

Hint Resolve step_lc_preservation : lc.

Lemma step_uvalue_preservation :
  forall u u',
    uvalue u -> step u u' -> uvalue u'.
Proof.
  introv Hu Hstep. gen u'.
  induction Hu; intros.
  - dependent destruction Hstep; eauto.
    + assert (value v') by eauto with value.
      eapply value_is_uvalue; assumption.
    + eapply uvalue_anno; eauto with lc.
  - dependent destruction Hstep; eauto with lc.
Qed.

Ltac indExpSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : trm |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => (dependent destruction H) end
    | intros ].

Inductive step_or_value : trm -> trm -> Prop :=
| sov_v : forall v, value v -> step_or_value v v
| sov_s : forall e1 e2, step e1 e2 -> step_or_value e1 e2.

Hint Constructors step_or_value : core.

Lemma size_trm_lg_z :
  forall e, size_trm e > 0.
Proof.
  introv.
  dependent induction e; try solve [eauto | simpl; lia].
Qed.

Hint Resolve size_trm_lg_z : core.

Lemma step_consistent_preservation :
  forall e1 e2 e1' e2' A B,
    uvalue e1 -> uvalue e2 ->
    typing nil e1 A -> typing nil e2 B ->
    consistent e1 e2 ->
    step_or_value e1 e1' -> step_or_value e2 e2' ->
    (forall e e' A, size_trm e < (size_trm e1 + size_trm e2) ->
        typing nil e A -> step e e' -> (exists C, typing nil e' C /\ isomorphic C A)) ->
    consistent e1' e2'.
Proof.
  introv Hu1 Hu2 Htyp1 Htyp2 Hc Hs1 Hs2 IH.
  gen A B e1' e2'.
  dependent induction Hc; intros; eauto with con.
  - dependent destruction Hs1; dependent destruction Hs2; eauto.
    + dependent destruction H1; eauto with value.
      assert (pvalue (trm_abs e A B2)) by eauto with lc. contradiction.
    + dependent destruction H0; eauto with value.
      assert (pvalue (trm_abs e A B1)) by eauto with lc. contradiction.
    + dependent destruction Htyp1. dependent destruction Htyp2.
      dependent destruction H2; eauto with value.
      * dependent destruction H4; eauto with value.
        ** eapply con_merge_l; eauto.
        ** assert (pvalue (trm_abs e A B2)) by eauto with lc. contradiction.
      * assert (pvalue (trm_abs e A B1)) by eauto with lc. contradiction.
  - dependent destruction Hs1; dependent destruction Hs2; eauto.
    + dependent destruction H0. dependent destruction H0.
      ** dependent destruction H2; eauto with con value.
         assert (pvalue (trm_int n)) by eauto. contradiction.
      ** dependent destruction H2; eauto with con value.
         assert (pvalue (trm_abs e A1 B1)) by eauto. contradiction.
    + dependent destruction H1. dependent destruction H1.
      ** dependent destruction H0; eauto with con value.
         assert (pvalue (trm_int n)) by eauto. contradiction.
      ** dependent destruction H0; eauto with con value.
         assert (pvalue (trm_abs e A1 B1)) by eauto. contradiction.
    + dependent destruction Htyp1. dependent destruction Htyp2.
      dependent destruction H2.
      * dependent destruction H4; eauto with con value.
        ** eapply con_merge_l; eauto.
        ** contradiction.
      * dependent destruction H4; eauto with con value.
        eapply tred_consistent_preservation; eauto.
      * dependent destruction H4; eauto with con value.
        ** contradiction.
        ** assert (e' = e'0). eapply determinism; eauto. subst.
           eapply con_anno; eauto with lc.
  - Case "Disjoint".
    dependent destruction Hs1; dependent destruction Hs2; eauto.
    + SCase "Value, Step".
      assert (exists C, typing nil e2 C /\ (isomorphic C B0)).
      eapply IH; eauto 3. assert (size_trm v > 0) by eauto.
      lia. destruct H4. destruct H4.
      assert (uvalue e2). eapply step_uvalue_preservation; eauto.
      eapply typing_to_ptype_uvalue in H4; eauto.
      eapply typing_to_ptype_uvalue in Htyp2; eauto. simpl_deter.
      eapply con_disjoint; eauto. eapply disjoint_iso_l; eauto.
    + SCase "Step, Value".
      assert (exists C, typing nil e2 C /\ (isomorphic C A0)).
      eapply IH; eauto 3. assert (size_trm v > 0) by eauto.
      lia. destruct H4. destruct H4.
      assert (uvalue e2). eapply step_uvalue_preservation. eapply Hu1. assumption.
      eapply typing_to_ptype_uvalue in H4; eauto.
      eapply typing_to_ptype_uvalue in Htyp1; eauto. simpl_deter.
      eapply con_disjoint; eauto. eapply disjoint_iso_l; eauto.
    + SCase "Step, Step".
      assert (exists C, typing nil e2 C /\ (isomorphic C A0)).
      eapply IH; eauto 3. assert (size_trm e0 > 0) by eauto.
      lia. destruct H4. destruct H4.
      assert (exists C, typing nil e3 C /\ (isomorphic C B0)).
      eapply IH; eauto 3. assert (size_trm e1 > 0) by eauto.
      lia. destruct H6. destruct H6.
      pose proof (step_uvalue_preservation _ _ Hu1 H2).
      pose proof (step_uvalue_preservation _ _ Hu2 H3).
      pose proof (typing_to_ptype_uvalue _ _ Hu1 Htyp1).
      pose proof (typing_to_ptype_uvalue _ _ Hu2 Htyp2).
      simpl_deter.
      eapply con_disjoint; eauto.
      eapply disjoint_iso_l; eauto.
  - Case "Merge L".
    dependent destruction Hs1; eauto with con value.
    + dependent destruction Htyp1; eauto with con value.
      * dependent destruction H0.
        eapply con_merge_l.
        ** eapply IHHc1; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
        ** eapply IHHc2; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
      * dependent destruction H3.
        eapply con_merge_l.
        ** eapply IHHc1; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
        ** eapply IHHc2; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
    + dependent destruction Htyp1.
      * dependent destruction Hu1; try solve [inversion H].
        dependent destruction H0.
        ** eapply con_merge_l; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_l; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_l; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
      * dependent destruction H3.
        ** eapply con_merge_l; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_l; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_l; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
  - Case "Merge R".
    dependent destruction Hs2; eauto with con value.
    + dependent destruction Htyp2; eauto with con value.
      * dependent destruction H0.
        eapply con_merge_r.
        ** eapply IHHc1; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
        ** eapply IHHc2; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
      * dependent destruction H3.
        eapply con_merge_r.
        ** eapply IHHc1; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
        ** eapply IHHc2; eauto with value.
           intros. eapply IH; eauto. simpl. lia.
    + dependent destruction Htyp2.
      * dependent destruction Hu2; try solve [inversion H].
        dependent destruction H0.
        ** eapply con_merge_r; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_r; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_r; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
      * dependent destruction H3.
        ** eapply con_merge_r; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_r; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
        ** eapply con_merge_r; eauto with value.
           *** eapply IHHc1; eauto. intros. eapply IH; eauto. simpl; lia.
           *** eapply IHHc2; eauto. intros. eapply IH; eauto. simpl; lia.
Qed.

Theorem preservation :
  forall (e e' : trm) (A: typ),
    typing nil e A ->
    step e e' ->
    (exists B, typing nil e' B /\ isomorphic B A).
Proof.
  intros e e' A Htyp Hred.
  gen e' A.
  indExpSize (size_trm e).
  dependent destruction Htyp.
  - dependent destruction Hred.
    exists typ_int. split; eauto.
  - dependent destruction Hred.
  - dependent destruction Hred.
    exists (typ_arrow A B). split; eauto 3.
  - dependent destruction Hred.
    + exists (typ_and A1 A2).
      split; eauto.
      dependent induction H.
      * dependent destruction Htyp.
        eapply typing_merge_uvalue; eauto 3.
        eapply typing_anno; eauto.
        eapply sub_inversion_split_r in H1; eauto.
        destruct_conjs. assumption.
        eapply typing_anno; eauto.
        eapply sub_inversion_split_r in H1; eauto.
        destruct_conjs. assumption.
      * dependent destruction Htyp.
        eapply typing_merge_uvalue; eauto 3.
        eapply typing_anno; eauto.
        eapply sub_inversion_split_r in H3; eauto.
        destruct_conjs; eauto.
        eapply typing_anno; eauto.
        eapply sub_inversion_split_r in H3; eauto.
        destruct_conjs; eauto.
    + eapply tred_preservation; eauto.
    + eapply IH in Hred; eauto.
      destruct Hred.
      exists A. split; eauto 3.
      destruct_conjs.
      eapply iso_to_sub in H2.
      assert (sub x A) by (eapply sub_transitivity; eauto).
      eapply typing_anno with (C:=x); eauto.
      simpl in SizeInd. lia.
  - dependent destruction Hred.
    + pose proof (papp_preservation e1 e2 e) as Hp.
      eapply Hp; eauto.
    + assert (exists B0, typing nil e1' B0 /\ isomorphic B0 B).
      eapply IH; eauto. simpl in SizeInd. lia.
      destruct H1.
      destruct H1.
      eapply appsub_iso in H0; eauto.
      destruct H0. destruct H0.
      exists x0. split; eauto.
    + assert (exists B0, typing nil e2' B0 /\ isomorphic B0 A).
      eapply IH; eauto. simpl in SizeInd. lia.
      destruct H1. destruct H1.
      eapply appsub_iso in H0; eauto.
      destruct H0. destruct H0.
      exists x0. split; eauto.
  - dependent destruction Hred.
    + assert (exists C, (typing nil e1' C) /\ (isomorphic C A)).
      eapply IH; eauto. simpl in SizeInd. lia.
      assert (exists C, (typing nil e2' C) /\ (isomorphic C B)).
      eapply IH; eauto. simpl in SizeInd. lia.
      destruct_conjs.
      exists (typ_and H0 H1).
      split.
      eapply typing_merge; eauto.
      eapply disjoint_iso_l; eauto.
      eauto.
    + assert (exists C, (typing nil e1' C) /\ (isomorphic C A)).
      eapply IH; eauto. simpl in SizeInd. lia.
      assert (exists C, (typing nil e2 C) /\ (isomorphic C B)); eauto.
      destruct_conjs.
      exists (typ_and H1 H2).
      split.
      eapply typing_merge; eauto.
      eapply disjoint_iso_l; eauto.
      eauto.
    + assert (exists C, (typing nil e1 C) /\ (isomorphic C A)) by eauto.
      assert (exists C, (typing nil e2' C) /\ (isomorphic C B)).
      eapply IH; eauto. simpl in SizeInd. lia.
      destruct_conjs.
      exists (typ_and H1 H2).
      split.
      eapply typing_merge; eauto.
      eapply disjoint_iso_l; eauto.
      eauto.
  - dependent destruction Hred.
    + assert (exists C, (typing nil e1' C) /\ (isomorphic C A)).
      eapply IH; eauto. simpl in SizeInd. lia.
      assert (exists C, (typing nil e2' C) /\ (isomorphic C B)).
      eapply IH; eauto. simpl in SizeInd. lia.
      destruct_conjs.
      exists (typ_and H3 H4).
      pose proof (step_uvalue_preservation _ _ H0 Hred1).
      pose proof (step_uvalue_preservation _ _ H1 Hred2).
      split; eauto.
      eapply typing_merge_uvalue; eauto.
      pose proof (sov_s _ _ Hred1) as Sov1.
      pose proof (sov_s _ _ Hred2) as Sov2.
      pose proof (step_consistent_preservation u1 u2 e1' e2' A B H0 H1 Htyp1 Htyp2 H2 Sov1 Sov2).
      eapply H11. intros. eapply IH; eauto. simpl in *. lia.
    + assert (exists C, (typing nil e1' C) /\ (isomorphic C A)).
      eapply IH; eauto. simpl in SizeInd. lia.
      destruct_conjs.
      exists (typ_and H4 B).
      pose proof (step_uvalue_preservation _ _ H1 Hred).
      split; eauto.
      eapply typing_merge_uvalue; eauto.
      pose proof (sov_s _ _ Hred) as Sov1.
      pose proof (sov_v _ H) as Sov2.
      pose proof (step_consistent_preservation u1 u2 e1' u2 A B H1 H2 Htyp1 Htyp2 H3 Sov1 Sov2).
      eapply H8; eauto. intros. eapply IH; eauto. simpl in SizeInd. lia.
    + assert (exists C, (typing nil e2' C) /\ (isomorphic C B)).
      eapply IH; eauto. simpl in SizeInd. lia.
      destruct_conjs.
      exists (typ_and A H4).
      pose proof (step_uvalue_preservation _ _ H2 Hred).
      split; eauto.
      eapply typing_merge_uvalue; eauto.
      pose proof (sov_v _ H) as Sov1.
      pose proof (sov_s _ _ Hred) as Sov2.
      pose proof (step_consistent_preservation u1 u2 u1 e2' A B H1 H2 Htyp1 Htyp2 H3 Sov1 Sov2).
      eapply H8; eauto. intros. eapply IH; eauto. simpl in SizeInd. lia.
Qed.

Theorem progress :
  forall (e : trm) (A : typ),
    typing nil e A ->
    value e \/ exists e', step e e'.
Proof.
  introv Htyp.
  dependent induction Htyp; eauto.
  - destruct IHHtyp; eauto.
    + right.
      eapply tred_progress in Htyp; eauto.
      destruct Htyp.
      exists x. eapply step_anno_value; eauto.
    + destruct (pvalue_decidability e);
        destruct (split_or_ord A); eauto.
      * destruct H1.
        ** right. destruct_conjs.
           exists (trm_merge (trm_anno (trm_int n) H2) (trm_anno (trm_int n) H1)); eauto.
        ** right. destruct_conjs.
           exists (trm_merge (trm_anno (trm_abs e A0 B0) H2) (trm_anno (trm_abs e A0 B0) H3)); eauto.
      * destruct H0.
        right. exists (trm_anno x A); eauto.
      * destruct H0.
        right. exists (trm_anno x A); eauto.
  - right. destruct IHHtyp1; destruct IHHtyp2; eauto; try solve [destruct_conjs; eauto].
    + eapply papp_progress in Htyp1; eauto.
      destruct_conjs.
      exists Htyp1. eapply step_papp; eauto.
  - destruct IHHtyp1; destruct IHHtyp2; try solve [eauto | destruct_conjs; eauto].
  - destruct IHHtyp1; destruct IHHtyp2; try solve [eauto | destruct_conjs; eauto].
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A B C AB BC ABC BCprime Cprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ BC O /\ (wd_ AB O /\ (wd_ BC BCprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime BCprime /\ (col_ O Eprime AB /\ col_ O Eprime Cprime))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.NArith.BinNat.
Require Import Common.CoqMaps.
Require Import AbstractMachine.

Inductive CompilerError : Type :=
| NoInfo : CompilerError
| DuplicatedLabels :
    (BinNatMap.t (BinNatMap.t AbstractMachine.lcode)) -> CompilerError
| ExportedProcsLabelsC :
    N ->
    (BinNatMap.t (BinNatMap.t  AbstractMachine.label)) ->
    CompilerError
| ExportedProcsLabelsP :
    N -> N ->
    (BinNatMap.t (BinNatMap.t AbstractMachine.label)) ->
    CompilerError
| NArg : N -> CompilerError
| ProcNotImported : N -> N -> list (N*N) -> CompilerError
| TwoNArg : N -> N -> CompilerError
.


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

(***
Modulus : 2^192 - 2^64 - 1
Base: 19.2
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 19 + 1/5;
    bitwidth := 32;
    s := 2^192;
    c := [(1, 1); (2^64, 1)];
    carry_chains := Some [[2; 9]; [3; 0; 4; 1; 5; 2; 6; 7; 8; 9]; [3; 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.


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

Require Import Platform.Cito.SepHintsUtil.

Set Implicit Arguments.

Section TopSection.

  Local Open Scope nat.

  Definition splittable A (ls : list A) pos := pos <= length ls.

  Definition array_to_split ls p (_ : nat) := array ls p.

  Lemma replace_array_to_split : forall ls p pos, array ls p = array_to_split ls p pos.
    eauto.
  Qed.

  Opaque mult.

  Lemma array_split : forall ls p pos, splittable ls pos -> array_to_split ls p pos ===> array (firstn pos ls) p * array (skipn pos ls) (p ^+ $ (4 * pos)).
    intros.
    eapply Himp_trans; [ apply ptsto32m'_in | ].
    eapply Himp_trans; [ | apply Himp_star_frame; apply ptsto32m'_out ].
    apply ptsto32m'_split; auto.
  Qed.

  Definition to_elim (_ : list W) := True.

  Lemma array_elim : forall ls p, to_elim ls -> array ls p ===> p =?> length ls.
    intros.
    eapply Himp_trans; [ apply ptsto32m'_in | ].
    eapply Himp_trans; [ apply ptsto32m'_elim | ].
    replace (p ^+ $0) with p by words.
    apply Himp_refl.
  Qed.

  Definition buf_to_split p len (_ : nat) := (p =?> len)%Sep.

  Definition buf_splittable (len pos : nat) := pos <= len.

  Lemma buf_split_bwd : forall p len pos, buf_splittable len pos -> p =?> pos * (p ^+ $ (4 * pos)) =?> (len - pos) ===> buf_to_split p len pos.
    intros.
    eapply Himp_trans; [ | apply allocated_join ].
    apply Himp_star_frame.
    apply Himp_refl.
    2: auto.
    apply allocated_shift_base; auto.
    rewrite <- wplus_assoc.
    do 2 f_equal.
    rewrite <- natToWord_plus.
    f_equal; omega.
  Qed.

  Definition hints_array_split : TacPackage.
    prepare array_split tt.
  Defined.

  Definition hints_array_elim : TacPackage.
    prepare array_elim tt.
  Defined.

  Definition hints_buf_split_bwd : TacPackage.
    prepare tt buf_split_bwd.
  Defined.

End TopSection.


From iris.program_logic Require Export language ectx_language ectxi_language.
From iris.algebra Require Export ofe.
From stdpp Require Import gmap.
From Autosubst Require Export Autosubst.
From iris.prelude Require Import options.

Module LambdaRS.
  Definition loc := positive.

  Global Instance loc_dec_eq (l l' : loc) : Decision (l = l') := _.

  Inductive binop := Add | Sub | Mult | Div | Rem | Eq | Le | Lt.

  Global Instance binop_dec_eq (op op' : binop) : Decision (op = op').
  Proof. solve_decision. Defined.

  Inductive expr :=
  | Var (x : var)
  | Rec (e : {bind 2 of expr})
  | App (e1 e2 : expr)
  | Lam (e : {bind expr})
  | LetIn (e1 : expr) (e2 : {bind expr})
  | Seq (e1 e2 : expr)
  (* Base Types *)
  | Unit
  | Nat (n : nat)
  | Bool (b : bool)
  | BinOp (op : binop) (e1 e2 : expr)
  (* If then else *)
  | If (e0 e1 e2 : expr)
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr})
  (* Concurrency *)
  | Fork (e : expr)
  (* Reference Types *)
  | Loc (l : loc)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr)
  (* Compare and swap used for fine-grained concurrency *)
  | CAS (e0 : expr) (e1 : expr) (e2 : expr)
  (* Fetch and add for fine-grained concurrency *)
  | FAA (e1 : expr) (e2 : expr)
  (* Assersion *)
  | Assert (e : expr).
  Global Instance Ids_expr : Ids expr. derive. Defined.
  Global Instance Rename_expr : Rename expr. derive. Defined.
  Global Instance Subst_expr : Subst expr. derive. Defined.
  Global Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  (* Notation for bool and nat *)
  Notation "#♭ b" := (Bool b) (at level 20).
  Notation "#n n" := (Nat n) (at level 20).

  Global Instance expr_dec_eq (e e' : expr) : Decision (e = e').
  Proof. solve_decision. Defined.

  Inductive val :=
  | RecV (e : {bind 1 of expr})
  | LamV (e : {bind expr})
  | UnitV
  | NatV (n : nat)
  | BoolV (b : bool)
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val)
  | LocV (l : loc).

  (* Notation for bool and nat *)
  Notation "'#♭v' b" := (BoolV b) (at level 20).
  Notation "'#nv' n" := (NatV n) (at level 20).

  Definition binop_eval (op : binop) : nat → nat → val :=
    match op with
    | Add => λ a b, #nv(a + b)
    | Sub => λ a b, #nv(a - b)
    | Mult => λ a b, #nv(a * b)
    | Div => λ a b, #nv(a `div` b)
    | Rem => λ a b, #nv(a `mod` b)
    | Eq => λ a b, #♭v (bool_decide (a = b))
    | Le => λ a b, #♭v (bool_decide (a ≤ b))
    | Lt => λ a b, #♭v (bool_decide (a < b))
    end.

  Global Instance val_dec_eq (v v' : val) : Decision (v = v').
  Proof. solve_decision. Defined.

  Global Instance val_inh : Inhabited val := populate UnitV.

  Fixpoint of_val (v : val) : expr :=
    match v with
    | RecV e => Rec e
    | LamV e => Lam e
    | UnitV => Unit
    | NatV v => Nat v
    | BoolV v => Bool v
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    | LocV l => Loc l
    end.

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Rec e => Some (RecV e)
    | Lam e => Some (LamV e)
    | Unit => Some UnitV
    | Nat n => Some (NatV n)
    | Bool b => Some (BoolV b)
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | Loc l => Some (LocV l)
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | LetInCtx (e2 : expr)
  | SeqCtx (e2 : expr)
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | BinOpLCtx (op : binop) (e2 : expr)
  | BinOpRCtx (op : binop) (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr})
  | IfCtx (e1 : {bind expr}) (e2 : {bind expr})
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val)
  | CasLCtx (e1 : expr)  (e2 : expr)
  | CasMCtx (v0 : val) (e2 : expr)
  | CasRCtx (v0 : val) (v1 : val)
  | FAALCtx (e2 : expr)
  | FAARCtx (v1 : val)
  | AssertCtx.

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | LetInCtx e2 => LetIn e e2
    | SeqCtx e2 => Seq e e2
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | BinOpLCtx op e2 => BinOp op e e2
    | BinOpRCtx op v1 => BinOp op (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    | IfCtx e1 e2 => If e e1 e2
    | AllocCtx => Alloc e
    | LoadCtx => Load e
    | StoreLCtx e2 => Store e e2
    | StoreRCtx v1 => Store (of_val v1) e
    | CasLCtx e1 e2 => CAS e e1 e2
    | CasMCtx v0 e2 => CAS (of_val v0) e e2
    | CasRCtx v0 v1 => CAS (of_val v0) (of_val v1) e
    | FAALCtx e2 => FAA e e2
    | FAARCtx v1 => FAA (of_val v1) e
    | AssertCtx => Assert e
    end.

  Record state : Type := {Heap : gmap loc val; Failure: bool}.

  Global Instance: Inhabited state := populate {|Heap := ∅; Failure := false|}.

  Definition update_heap (σ : state) (h : gmap loc val) : state :=
    {|Heap := h; Failure := Failure σ|}.
  Definition set_failure_bit (σ : state) : state := {|Heap := Heap σ; Failure := true|}.

  Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
  (* β *)
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Rec e1) e2) σ [] e1.[(Rec e1), e2/] σ []
  (* Lam-β *)
  | LamBetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
  (* LetIn-β *)
  | LetInBetaS e1 e2 v2 σ :
      to_val e1 = Some v2 →
      head_step (LetIn e1 e2) σ [] e2.[e1/] σ []
  (* Seq-β *)
  | SeqBetaS e1 e2 v2 σ :
      to_val e1 = Some v2 →
      head_step (Seq e1 e2) σ [] e2 σ []
  (* Products *)
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ [] e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ [] e2 σ []
  (* Sums *)
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ []
    (* nat bin op *)
  | BinOpS op a b σ :
      head_step (BinOp op (#n a) (#n b)) σ [] (of_val (binop_eval op a b)) σ []
  (* If then else *)
  | IfFalse e1 e2 σ :
      head_step (If (#♭ false) e1 e2) σ [] e2 σ []
  | IfTrue e1 e2 σ :
      head_step (If (#♭ true) e1 e2) σ [] e1 σ []
  (* Concurrency *)
  | ForkS e σ:
      head_step (Fork e) σ [] Unit σ [e]
  (* Reference Types *)
  | AllocS e v σ l :
     to_val e = Some v → Heap σ !! l = None →
     head_step (Alloc e) σ [] (Loc l) (update_heap σ (<[l:=v]>(Heap σ))) []
  | LoadS l v σ :
     Heap σ !! l = Some v →
     head_step (Load (Loc l)) σ [] (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some (Heap σ !! l) →
     head_step (Store (Loc l) e) σ [] Unit (update_heap σ (<[l:=v]>(Heap σ))) []
  (* Compare and swap *)
  | CasFailS l e1 v1 e2 v2 vl σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     Heap σ !! l = Some vl → vl ≠ v1 →
     head_step (CAS (Loc l) e1 e2) σ [] (#♭ false) σ []
  | CasSucS l e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     Heap σ !! l = Some v1 →
     head_step (CAS (Loc l) e1 e2) σ [] (#♭ true) (update_heap σ (<[l:=v2]>(Heap σ))) []
  | FAAS l m e2 k σ :
      to_val e2 = Some (NatV k) →
      Heap σ !! l = Some (NatV m) →
      head_step (FAA (Loc l) e2) σ [] (#n m) (update_heap σ (<[l:=NatV (m + k)]>(Heap σ))) []
  | AssertSucS e σ :
    to_val e = Some (#♭v true) →
    head_step (Assert e) σ [] Unit σ []
  | AssertFailc e σ :
    to_val e = Some (#♭v false) →
    head_step (Assert e) σ [] Unit (set_failure_bit σ) [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Global Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Global Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 κs e2 σ2 ef :
    head_step e1 σ1 κs e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 κs e2 σ2 ef :
    head_step (fill_item Ki e) σ1 κs e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma alloc_fresh e v σ :
    let l := fresh (dom (Heap σ)) in
    to_val e = Some v → head_step (Alloc e) σ [] (Loc l) (update_heap σ (<[l:=v]>(Heap σ))) [].
  Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset loc)), is_fresh. Qed.

  Lemma val_head_stuck e1 σ1 κs e2 σ2 efs : head_step e1 σ1 κs e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.

  Canonical Structure stateO := leibnizO state.
  Canonical Structure valO := leibnizO val.
  Canonical Structure exprO := leibnizO expr.
End LambdaRS.

Canonical Structure LambdaRS_ectxi_lang :=
  EctxiLanguage LambdaRS.lang_mixin.
Canonical Structure LambdaRS_ectx_lang :=
  EctxLanguageOfEctxi LambdaRS_ectxi_lang.
Canonical Structure LambdaRS_lang :=
  LanguageOfEctx LambdaRS_ectx_lang.

Export LambdaRS.

Global Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Global Hint Extern 5 (IntoVal _ _) =>
  eapply of_to_val; fast_done : typeclass_instances.
Global Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val;
  rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Global Hint Extern 5 (AsVal _) =>
  eexists; eapply of_to_val; fast_done : typeclass_instances.
Global Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val;
  rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Definition is_atomic (e : expr) : Prop :=
  match e with
  | Alloc e => is_Some (to_val e)
  | Load e =>  is_Some (to_val e)
  | Store e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | CAS e1 e2 e3 => is_Some (to_val e1) ∧ is_Some (to_val e2)
                   ∧ is_Some (to_val e3)
  | FAA e1 e2 => is_Some (to_val e1) ∧ is_Some (to_val e2)
  | _ => False
  end.
Local Hint Resolve language.val_irreducible : core.
Local Hint Resolve to_of_val : core.
Local Hint Unfold language.irreducible : core.
Global Instance is_atomic_correct s e : is_atomic e → Atomic s e.
Proof.
  intros Ha; apply strongly_atomic_atomic,  ectx_language_atomic.
  - destruct 1; simpl in *; try tauto; eauto.
  - intros K e' -> Hval%eq_None_not_Some.
    induction K as [|Ki K] using rev_ind; first done.
    simpl in Ha; rewrite fill_app in Ha; simpl in Ha.
    destruct Hval. apply (fill_val K e'); simpl in *.
    destruct Ki; naive_solver.
Qed.

Ltac solve_atomic :=
  apply is_atomic_correct; simpl; repeat split;
    rewrite ?to_of_val; eapply mk_is_Some; fast_done.

Global Hint Extern 0 (Atomic _ _) => solve_atomic : core.
Global Hint Extern 0 (Atomic _ _) => solve_atomic : typeclass_instances.

Fixpoint env_subst (vs : list val) : var → expr :=
  match vs with
  | [] => ids
  | v :: vs' => (of_val v) .: env_subst vs'
  end.

Lemma env_subst_lookup_some vs x v :
  vs !! x = Some v → env_subst vs x = of_val v.
Proof.
  revert vs; induction x as [|x IHx] => vs.
  - by destruct vs; inversion 1.
  - destruct vs as [|w vs]; first by inversion 1.
    rewrite -lookup_tail /=.
    apply IHx.
Qed.

Lemma env_subst_lookup_none vs x :
  vs !! x = None → env_subst vs x = Var (x - length vs).
Proof.
  revert vs; induction x as [|x IHx] => vs.
  - by destruct vs; inversion 1.
  - destruct vs as [|w vs]; first by inversion 1.
    rewrite -lookup_tail /=.
    apply IHx.
Qed.

(* classification of values. *)

Inductive non_nat_val : val → Prop :=
| NN_RecV e : non_nat_val (RecV e)
| NN_LamV e : non_nat_val (LamV e)
| NN_UnitV  : non_nat_val UnitV
| NN_BoolV b : non_nat_val (BoolV b)
| NN_PairV v1 v2 : non_nat_val (PairV v1 v2)
| NN_InjLV v : non_nat_val (InjLV v)
| NN_InjRV v : non_nat_val (InjRV v)
| NN_LocV l : non_nat_val (LocV l).

Lemma val_cases_nat v : (∃ n, v = #nv n) ∨ non_nat_val v.
Proof. destruct v; solve [right; constructor| eauto]. Qed.

Inductive non_bool_val : val → Prop :=
| NB_RecV e : non_bool_val (RecV e)
| NB_LamV e : non_bool_val (LamV e)
| NB_UnitV  : non_bool_val UnitV
| NB_NatV n : non_bool_val (NatV n)
| NB_PairV v1 v2 : non_bool_val (PairV v1 v2)
| NB_InjLV v : non_bool_val (InjLV v)
| NB_InjRV v : non_bool_val (InjRV v)
| NB_LocV l : non_bool_val (LocV l).

Lemma val_cases_bool v : (∃ b, v = #♭v b) ∨ non_bool_val v.
Proof. destruct v; solve [right; constructor| eauto]. Qed.

Inductive non_pair_val : val → Prop :=
| NP_RecV e : non_pair_val (RecV e)
| NP_LamV e : non_pair_val (LamV e)
| NP_UnitV  : non_pair_val UnitV
| NP_NatV n : non_pair_val (NatV n)
| NP_BoolV b : non_pair_val (BoolV b)
| NP_InjLV v : non_pair_val (InjLV v)
| NP_InjRV v : non_pair_val (InjRV v)
| NP_LocV l : non_pair_val (LocV l).

Lemma val_cases_pair v : (∃ v1 v2, v = PairV v1 v2) ∨ non_pair_val v.
Proof. destruct v; solve [right; constructor| eauto]. Qed.

Inductive non_sum_val : val → Prop :=
| NS_RecV e : non_sum_val (RecV e)
| NS_LamV e : non_sum_val (LamV e)
| NS_UnitV  : non_sum_val UnitV
| NS_NatV n : non_sum_val (NatV n)
| NS_BoolV b : non_sum_val (BoolV b)
| NS_PairV v1 v2 : non_sum_val (PairV v1 v2)
| NS_LocV l : non_sum_val (LocV l).

Lemma val_cases_sum v : ((∃ v', v = InjLV v') ∨ (∃ v', v = InjRV v')) ∨ non_sum_val v.
Proof. destruct v; solve [right; constructor| eauto]. Qed.

Inductive non_fun_val : val → Prop :=
| NF_UnitV  : non_fun_val UnitV
| NF_NatV n : non_fun_val (NatV n)
| NF_BoolV b : non_fun_val (BoolV b)
| NF_PairV v1 v2 : non_fun_val (PairV v1 v2)
| NF_InjLV v : non_fun_val (InjLV v)
| NF_InjRV v : non_fun_val (InjRV v)
| NF_LocV l : non_fun_val (LocV l).

Lemma val_cases_fun v : ((∃ e, v = RecV e) ∨ (∃ e, v = LamV e)) ∨ non_fun_val v.
Proof. destruct v; solve [right; constructor| eauto]. Qed.

Inductive non_loc_val : val → Prop :=
| NL_RecV e : non_loc_val (RecV e)
| NL_LamV e : non_loc_val (LamV e)
| NL_UnitV  : non_loc_val UnitV
| NL_NatV n : non_loc_val (NatV n)
| NL_BoolV b : non_loc_val (BoolV b)
| NL_PairV v1 v2 : non_loc_val (PairV v1 v2)
| NL_InjLV v : non_loc_val (InjLV v)
| NL_InjRV v : non_loc_val (InjRV v).

Lemma val_cases_loc v : (∃ l, v = LocV l) ∨ non_loc_val v.
Proof. destruct v; solve [right; constructor| eauto]. Qed.


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 _ _ _ _ _ mpred (@SGP pSGG_VST nat unit (sSGG_VST sh)) (SGA_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).
Existing Instances maGraph finGraph liGraph RGF.

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)
          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)
        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)
          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')
        LOCAL()
        SEP (whole_graph sh g').

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, g: Graph
    PRE []
      PROP ()
      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')
      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).
  - rep_omega.
  - Intros x.
    assert_PROP (x <> null) as x_not_null by (entailer !; destruct H0 as [? _]; apply H0).
    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 H). Exists x. entailer!.
    + split; simpl; [right | apply is_partial_make_set_pregraph]; auto.
    + assert (Coqlib.Prop_join (vvalid g) (eq x) (vvalid (make_set_Graph 0%nat tt tt x g x_not_null H))). {
        simpl; hnf; split; intros; [unfold graph_gen.addValidFunc | subst a]; intuition.
      } assert (vgamma (make_set_Graph O tt tt x g x_not_null H) 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 H) 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 H)). {
        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 <- H5. 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.
  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 <- H0. simpl vgamma2cdata.
  forward. 1: entailer!; destruct pa; simpl; auto.
  unlocalize [whole_graph sh g].
  1: rewrite <- H0; simpl vgamma2cdata; 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)
     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 _ _ H1).
    assert (weak_valid g' root) by (right; destruct H3; apply reachable_foot_valid in H3; auto).
    assert (vvalid g' x) by (destruct H2 as [? _]; rewrite <- H2; 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 H5 H6 H7)) (Graph_gen_redirect_parent g' x root H5 H6 H7) =
            vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' x root H5 H6 H7)). {
      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 H9.
    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 H5 H6 H7)].
    + rewrite H8. apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto. destruct H3.
      apply reachable_foot_valid in H3. intro. subst root. apply (valid_not_null g' null H3). simpl. auto.
    + Exists (Graph_gen_redirect_parent g' x root H5 H6 H7) root. rewrite H8. entailer!. 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. 2: apply reachable_refl; auto.
        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.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H1. subst pa. split; [|split]; auto.
    + apply (uf_equiv_refl _  (liGraph g)).
    + apply uf_root_vgamma with (n := r); auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed.

(* 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.
  forward_call (sh, g, x). Intros vret. destruct vret as [g1 x_root]. simpl fst in *. simpl snd in *.
  assert (vvalid g1 y) by (destruct H1 as [? _]; rewrite <- H1; apply H0).
  forward_call (sh, g1, y). Intros vret. destruct vret as [g2 y_root]. simpl fst in *. simpl snd in *.
  assert (H_VALID_XROOT: vvalid g2 x_root) by (destruct H4 as [? _]; rewrite <- H4; destruct H2; apply reachable_foot_valid in H2; apply H2).
  assert (H_VALID_YROOT: vvalid g2 y_root) by (destruct H5; apply reachable_foot_valid in H5; apply H5).
  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. Exists g2. entailer !. apply true_Ceq_eq in H6. subst y_root. apply (the_same_root_union g g1 g2 x y x_root); auto.
  - forward. apply false_Ceq_neq in H6. entailer!.
  - Intros. (* xRank = xRoot -> rank; *)
    remember (vgamma g2 x_root) as rpa eqn:?H. destruct rpa as [rankXRoot paXRoot]. symmetry in H7.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
    rewrite H7. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H7; 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 H8.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
    rewrite H8. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H8; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) y_root (rankYRoot, paYRoot)); auto.
    forward_if
      (EX g': Graph,
       PROP (uf_union g x y 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). rename H_VALID_XROOT into H11.
      assert (~ reachable g2 y_root x_root) by (intro; destruct H5; specialize (H13 _ H12); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)) (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12) =
          vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)). {
        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 H7. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)].
      1: rewrite H7; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
      Exists (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12). rewrite H13. entailer!. apply (diff_root_union_1 g g1 g2 x y x_root y_root); 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 H2; auto; destruct H2; specialize (H13 _ H12); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)) (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)). {
        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')
       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 H8. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)].
        1: rewrite H8; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        Exists (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12). rewrite H13. entailer!. apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H8. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)].
        1: rewrite H8; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        set (g3 := (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)).
        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 H7. simpl vgamma2cdata. forward.
        rewrite add_repr. replace (Z.of_nat rankXRoot + 1) with (Z.of_nat (rankXRoot + 1)) by (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 H16. clear H16. rewrite H7. simpl vgamma2cdata. apply (@graph_vgen_ramify _ (sSGG_VST sh)).
           ++ subst g3. simpl. auto.
           ++ subst g3. remember (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12) as g3.
              apply (graph_gen_redirect_parent_vgamma _ _ _ rankXRoot paXRoot) in Heqg3; auto. intros. inversion H16; auto.
        -- Exists (Graph_vgen g3 x_root (rankXRoot + 1)%nat). entailer!.
    + Intros g3. forward. Exists g3. entailer!.
Qed. (* 4.207 secs *)


Require Import Platform.AutoSep Platform.Malloc.

Section adt.
  Variable P : list W -> W -> HProp.
  Variable res : nat.

  Definition newS := SPEC("extra_stack", "len") reserving res
    PRE[V] [| goodSize (2 + wordToNat (V "len")) |] * mallocHeap 0
    POST[R] Ex ws, P ws R * [| length ws = wordToNat (V "len") |] * mallocHeap 0.

  Definition deleteS := SPEC("extra_stack", "self") reserving res
    Al ws,
    PRE[V] P ws (V "self") * mallocHeap 0
    POST[_] mallocHeap 0.

  Definition readS := SPEC("extra_stack", "self", "n") reserving res
    Al ws,
    PRE[V] P ws (V "self") * [| V "n" < natToW (length ws) |] * mallocHeap 0
    POST[R] [| R = Array.sel ws (V "n") |] * P ws (V "self") * mallocHeap 0.

  Definition writeS := SPEC("extra_stack", "self", "n", "v") reserving res
    Al ws,
    PRE[V] P ws (V "self") * [| V "n" < natToW (length ws) |] * mallocHeap 0
    POST[_] P (Array.upd ws (V "n") (V "v")) (V "self") * mallocHeap 0.
End adt.


Require Import Coq.Setoids.Setoid.
Require Import Bedrock.DepList Bedrock.Memory.
Require Import Bedrock.Word.

Require Import Coq.Lists.List.

Module Type Heap.

  Parameter addr : Type.

  Parameter mem : Type.

  Parameter mem_get : mem -> addr -> option B.
  Parameter mem_set : mem -> addr -> B -> option mem.

  Parameter mem_acc : mem -> addr -> Prop.

  Parameter mem_get_acc : forall m p,
    mem_acc m p <->
    exists v, mem_get m p = Some v.

  Parameter mem_set_acc : forall m p,
    mem_acc m p <->
    forall v, exists m', mem_set m p v = Some m'.

  Parameter mem_acc_dec : forall m p,
    mem_acc m p \/ ~mem_acc m p.

  (** mem writes persist **)
  Parameter mem_get_set_eq : forall m p v' m',
    mem_set m p v' = Some m' ->
    mem_get m' p = Some v'.

  (** mem writes don't overwrite elsewhere **)
  Parameter mem_get_set_neq : forall m p p' v' m',
    p <> p' ->
    mem_set m p' v' = Some m' ->
    mem_get m' p = mem_get m p.

  (** mem writes don't modify permissions **)
  Parameter mem_set_perm : forall m p v m',
    mem_set m p v = Some m' ->
    (forall p, mem_acc m p -> mem_acc m' p).

  Parameter footprint_w : addr -> addr * addr * addr * addr.

  Parameter footprint_disjoint : forall p a b c d,
    footprint_w p = (a,b,c,d) ->
    a <> b /\ a <> c /\ a <> d /\ b <> c /\ b <> d /\ c <> d.

  Parameter addr_dec : forall a b : addr, {a = b} + {a <> b}.

  Parameter all_addr : list addr.

  Parameter NoDup_all_addr : NoDup all_addr.

End Heap.

Module HeapTheory (B : Heap).
  Import B.

  Definition smem' dom : Type := hlist (fun _ : addr => option B) dom.

  Fixpoint smem_emp' (ls : list addr) : smem' ls :=
    match ls with
      | nil => HNil
      | a :: b => HCons None (smem_emp' b)
    end.
  Fixpoint disjoint' dom : smem' dom -> smem' dom -> Prop :=
    match dom with
      | nil => fun _ _ => True
      | a :: b => fun m1 m2 =>
           (hlist_hd m1 = None \/ hlist_hd m2 = None)
        /\ disjoint' _ (hlist_tl m1) (hlist_tl m2)
    end.
  Fixpoint join' dom : smem' dom -> smem' dom -> smem' dom :=
    match dom with
      | nil => fun _ _ => HNil
      | a :: b => fun m1 m2 =>
        HCons
        match hlist_hd m1 with
          | None => hlist_hd m2
          | Some x => Some x
        end
        (join' _ (hlist_tl m1) (hlist_tl m2))
    end.

  Fixpoint relevant' (ls : list addr) : smem' ls -> list addr :=
    match ls with
      | nil => fun _ => nil
      | a :: b => fun x =>
        match hlist_hd x with
          | None => relevant' _ (hlist_tl x)
          | Some _ => a :: relevant' _ (hlist_tl x)
        end
    end.

  Fixpoint smem_get' dom : addr -> smem' dom -> option B :=
    match dom as dom return addr -> smem' dom -> option B with
      | nil => fun _ _ => None
      | a :: b => fun a' m =>
        if addr_dec a a' then
          hlist_hd m
        else
          smem_get' b a' (hlist_tl m)
    end.

  Fixpoint smem_set' dom : addr -> B -> smem' dom -> option (smem' dom) :=
    match dom as dom return addr -> B -> smem' dom -> option (smem' dom) with
      | nil => fun _ _ _ => None
      | a :: b => fun p v m =>
        if addr_dec a p then
          match hlist_hd m with
            | None => None
            | Some _ => Some (HCons (Some v) (hlist_tl m))
          end
        else
          match smem_set' b p v (hlist_tl m) with
            | None => None
            | Some tl => Some (HCons (hlist_hd m) tl)
          end
    end.

  Fixpoint satisfies' dom (sm : smem' dom) (m : B.mem) : Prop :=
    match sm with
      | HNil => True
      | HCons p _ a b =>
        match a with
          | None => True
          | Some x =>
               B.mem_get m p = Some x /\ mem_acc m p
        end /\ satisfies' _ b m
    end.

  Definition smem : Type := smem' all_addr.

  Definition smem_emp : smem := smem_emp' all_addr.

  Definition smem_get := @smem_get' all_addr.

  Definition smem_set := @smem_set' all_addr.

  Definition smem_get_word (implode : B * B * B * B -> W) (p : addr) (m : smem)
    : option W :=
    let '(a,b,c,d) := footprint_w p in
    match smem_get a m , smem_get b m , smem_get c m , smem_get d m with
      | Some a , Some b , Some c , Some d =>
        Some (implode (a,b,c,d))
      | _ , _ , _ , _ => None
    end.

  Definition smem_set_word (explode : W -> B * B * B * B) (p : addr) (v : W)
    (m : smem) : option smem :=
    let '(a,b,c,d) := footprint_w p in
    let '(av,bv,cv,dv) := explode v in
    match smem_set d dv m with
      | None => None
      | Some m => match smem_set c cv m with
                    | None => None
                    | Some m => match smem_set b bv m with
                                  | None => None
                                  | Some m => smem_set a av m
                                end
                  end
    end.

  Definition disjoint (m1 m2 : smem) : Prop :=
    disjoint' _ m1 m2.

  Definition join (m1 m2 : smem) : smem :=
    join' _ m1 m2.

  Definition split (m ml mr : smem) : Prop :=
    disjoint ml mr /\ m = join ml mr.

  Definition semp (m : smem) : Prop :=
    m = smem_emp.

  Definition satisfies (m : smem) (m' : B.mem) : Prop :=
    satisfies' _ m m'.

  Definition relevant (sm : smem) := relevant' _ sm.

  Global Instance EqDec_addr : EquivDec.EqDec addr (@eq addr) := addr_dec.

  Local Hint Resolve mem_get_set_eq mem_get_set_neq : memory.

  Lemma smem_set_not_in : forall l m p v,
    ~In p l -> smem_set' l p v m = None.
  Proof.
    induction l; simpl; auto.
      intros.
      destruct (addr_dec a p); subst; intuition.
      rewrite IHl; auto.
  Qed.

  Ltac simp ext :=
    intros; simpl in *;
    repeat (instantiate;
      match goal with
        | [ H : prod _ _ |- _ ] => destruct H
        | [ H : context [ footprint_w ?X ] |- _ ] =>
          destruct (footprint_w X)
        | [ H : Some _ = Some _ |- _ ] =>
          inversion H; clear H; try subst
        | [ H : _ = _ |- _ ] => rewrite H in *
        | [ H : NoDup (_ :: _) |- _ ] =>
          inversion H; clear H; subst
        | [ H : context [ addr_dec ?A ?B ] |- _ ] =>
          destruct (addr_dec A B); subst
        | [ |- context [ addr_dec ?A ?B ] ] =>
          destruct (addr_dec A B); subst
        | [ H : match ?X with
                  | Some _ => _
                  | None => _
                end = _ |- _ ] =>
          generalize dependent H; case_eq X; intros
        | [ H : match ?X with
                  | Some _ => _
                  | None => _
                end |- _ ] =>
          generalize dependent H; case_eq X; intros
        | [ H : satisfies' (_ :: _) ?M _ |- _ ] =>
          match M with
            | HCons _ _ => fail 1
            | _ => rewrite (hlist_eta _ M) in H
          end
        | [ |- satisfies' (_ :: _) ?M _ ] =>
          match M with
            | HCons _ _ => fail 1
            | _ => rewrite (hlist_eta _ M)
          end
        | [ H : smem' nil |- _ ] =>
          rewrite (hlist_nil_only _ H) in *
        | [ H : exists x, _ |- _ ] => destruct H
        | [ H : _ /\ _ |- _ ] => destruct H
        | [ |- _ ] => congruence
        | [ |- _ ] => ext
      end; simpl in *); eauto 10 with memory.

  Theorem satisfies_get : forall m m',
    satisfies m m' ->
    forall p v,
      smem_get p m = Some v ->
      mem_get m' p = Some v.
  Proof.
    unfold satisfies, smem_get, smem.
    induction all_addr; simp intuition.
  Qed.

  Lemma satisfies_set_not_in : forall l m sm p v,
    satisfies' l sm m ->
    ~In p l ->
    forall m', mem_set m p v = Some m' ->
    satisfies' l sm m'.
  Proof.
    induction l; try solve [ simp intuition ].
      simp auto.
      destruct (addr_dec a p); destruct (in_dec addr_dec p l); subst; try solve [ intuition ].

      split; eauto. erewrite mem_get_set_neq; eauto.
      split; eauto. eapply mem_set_perm; eauto.
  Qed.

  Local Hint Resolve mem_set_perm satisfies_set_not_in : memory.

  Theorem satisfies_set : forall sm m,
    satisfies sm m ->
    forall p v sm',
      smem_set p v sm = Some sm' ->
      exists m',
      mem_set m p v = Some m' /\ satisfies sm' m'.
  Proof.
    unfold satisfies, smem_set, smem_get, smem, relevant.
    generalize NoDup_all_addr.
    induction all_addr; simp auto.
      destruct (proj1 (mem_set_acc _ _) H2 v). rewrite H3. eexists; split; eauto.
      erewrite mem_get_set_eq; eauto with memory.

      Focus.
      eapply IHl in H1; eauto.
      destruct H1; eexists; intuition; eauto with memory.
      erewrite mem_get_set_neq; eauto.

      Focus.
      eapply IHl in H1; eauto. destruct H1; eexists; intuition eauto.
  Qed.

  Theorem satisfies_get_word : forall i m m',
    satisfies m m' ->
    forall p v,
      smem_get_word i p m = Some v ->
      mem_get_word addr mem footprint_w mem_get i p m' = Some v.
  Proof.
    unfold mem_get_word, smem_get_word; simp intuition.
    repeat erewrite satisfies_get by eauto. auto.
  Qed.

  Lemma smem_set_get_neq : forall p m m' a b,
    smem_set a b m = Some m' ->
    a <> p ->
    smem_get p m' = smem_get p m.
  Proof.
    unfold smem, smem_get, smem_set.
    induction all_addr; simp intuition.
  Qed.

  Lemma smem_set_get_eq : forall m m' a b,
    smem_set a b m = Some m' ->
    smem_get a m' = Some b.
  Proof.
    unfold smem, smem_get, smem_set.
    induction all_addr; simp intuition.
  Qed.

  Lemma smem_set_get_word_eq : forall i e m m' a b,
    (forall x, i (e x) = x) ->
    smem_set_word e a b m = Some m' ->
    smem_get_word i a m' = Some b.
  Proof.
    unfold smem_get_word, smem_set_word; intros.
    generalize (footprint_disjoint a).
    generalize dependent H0. case_eq (e b). simp intuition.
    specialize (H2 _ _ _ _ (refl_equal _)). simp intuition.
    repeat ((erewrite smem_set_get_eq; [ | repeat rewrite smem_set_get_neq by auto; eassumption ])
      || (erewrite smem_set_get_neq by eauto)). simp intuition.
  Qed.

  Lemma split_smem_get : forall a b c p v,
    split a b c ->
      (smem_get p b = Some v \/ smem_get p c = Some v) ->
      smem_get p a = Some v.
  Proof.
    unfold smem, split, disjoint, join, smem_get, smem.
    induction all_addr; simp intuition.
  Qed.

  Lemma split_smem_get_word : forall i a b c p v,
    split a b c ->
      (smem_get_word i p b = Some v \/ smem_get_word i p c = Some v) ->
      smem_get_word i p a = Some v.
  Proof.
    unfold smem_get_word. simp intuition;
    repeat (erewrite split_smem_get by eauto); auto.
  Qed.

  Theorem satisfies_set_word : forall sm m,
    satisfies sm m ->
    forall e p v sm',
      smem_set_word e p v sm = Some sm' ->
      exists m',
           mem_set_word addr mem footprint_w mem_set e p v m = Some m'
        /\ satisfies sm' m'.
  Proof.
    unfold smem_set_word, mem_set_word, smem_get_word; intros.
    simp intuition. destruct (e v); simp intuition.
    repeat match goal with
             | [ H : satisfies _ _ |- _ ] =>
               eapply satisfies_set in H; eauto; destruct H as [ ? [ ? ? ] ]
             | [ H : _ = _ |- _ ] => rewrite H
           end.
    exists x2. intuition eauto.
  Qed.

  Lemma smem_set_get_valid : forall m p v v',
    smem_get p m = Some v' ->
    smem_set p v m <> None.
  Proof.
    unfold smem_get, smem_set, smem.
    induction all_addr; simp intuition.
  Qed.

  Lemma smem_set_get_valid_word : forall i e m p v v',
    smem_get_word i p m = Some v' ->
    smem_set_word e p v m <> None.
  Proof.
    unfold smem_get_word, smem_set_word.
    intros. generalize (footprint_disjoint p).
    intros; destruct (e v); simp intuition;
    specialize (H0 _ _ _ _ (refl_equal _)); simp intuition;
    (eapply smem_set_get_valid; [ | eauto ];
      repeat (erewrite smem_set_get_neq; [ | solve [ eauto ] | solve [ eauto ] ]); eauto).
  Qed.

  Lemma split_set : forall a b,
    disjoint a b ->
    forall p v a',
    smem_set p v a = Some a' ->
      disjoint a' b /\
      smem_set p v (join a b) = Some (join a' b).
  Proof.
    unfold smem, disjoint, join, smem_set, smem.
    induction all_addr; simpl; intros; try congruence.
      destruct (addr_dec a p); subst.
      destruct H. destruct H; rewrite H in *; try congruence.
        destruct (hlist_hd a0); try congruence.
        inversion H0; auto.

      generalize dependent H0.
      case_eq (smem_set' l p v (hlist_tl a0)); intros; try congruence.
        inversion H1; clear H1; subst.
        eapply IHl in H0. 2: destruct H; eauto.
        simp intuition.
  Qed.

  Lemma split_set_word : forall a b,
    disjoint a b ->
    forall i p v a',
    smem_set_word i p v a = Some a' ->
      disjoint a' b /\
      smem_set_word i p v (join a b) = Some (join a' b).
  Proof.
    unfold smem_set_word.
    intros. destruct (i v); simp fail.
    repeat match goal with
      | [ H : smem_set _ _ _ = Some _ |- _ ] =>
        eapply split_set in H; [ rewrite (proj2 H) | eauto ]
    end; tauto.
  Qed.

  Ltac unfold_all :=
    unfold smem, split, join, disjoint, smem_emp, semp;
    unfold smem, split, join, disjoint, smem_emp, semp.
  Ltac break :=
    simpl; intros; try reflexivity;
      repeat (simpl in *; match goal with
                            | [ H : HCons _ _ = HCons _ _ |- _ ] =>
                              inversion H; clear H
                            | [ H : _ /\ _ |- _ ] => destruct H
                            | [ H : @existT _ _ _ _ = @existT _ _ _ _ |- _ ] =>
                              eapply (@Eqdep_dec.inj_pair2_eq_dec _ (list_eq_dec B.addr_dec)) in H
                            | [ H : @existT _ _ _ _ = @existT _ _ _ _ |- _ ] =>
                              eapply (@Eqdep_dec.inj_pair2_eq_dec _ B.addr_dec) in H
                            | [ H : _ = _ |- _ ] => rewrite H in *
                          end).

  Lemma disjoint_join : forall a b, disjoint a b -> join a b = join b a.
  Proof.
    unfold_all; induction a; break; f_equal; intuition; subst.
      destruct (hlist_hd b0); reflexivity.
      rewrite H1. destruct b; reflexivity.
  Qed.

  Lemma disjoint_comm : forall ml mr, disjoint ml mr -> disjoint mr ml.
  Proof.
    unfold_all; induction ml; break; intuition.
  Qed.

  Hint Resolve disjoint_join disjoint_comm : disjoint.

  Lemma split_assoc : forall b a c d e, split a b c -> split c d e ->
    split a (join d b) e.
  Proof.
    unfold_all; induction b; break; eauto.
    edestruct IHb. split; try eassumption. reflexivity. split; try eassumption.
    reflexivity.
    intuition; break; auto. destruct (hlist_hd d); auto.
    destruct (hlist_hd d); try congruence.
  Qed.

  Lemma split_comm : forall ml m mr, split m ml mr -> split m mr ml.
  Proof.
    unfold_all. induction ml; break; eauto. edestruct IHml.
    split; try eassumption. reflexivity.
    intuition; subst. rewrite H3. destruct (hlist_hd mr); auto.
    rewrite H4. rewrite H3. destruct b; auto.
  Qed.

  Lemma disjoint_split_join : forall a b, disjoint a b -> split (join a b) a b.
  Proof.
    unfold split, disjoint; intros; intuition.
  Qed.

  Lemma split_split_disjoint : forall b a c d e,
    split a b c -> split b d e -> disjoint c d.
  Proof.
    unfold_all. induction b; break. subst. split.
    intuition; destruct (hlist_hd c); eauto. destruct (hlist_hd d); auto.
    eapply IHb. split; auto. split; auto. auto.
  Qed.

  Lemma hlist_destruct : forall T (F : T -> Type) a b (m : hlist F (a :: b)),
    exists A, exists B, m = HCons A B.
  Proof.
    intros.
    refine (match m as m in hlist _ ls return
              match ls as ls return hlist _ ls -> Type with
                | nil => fun _ => unit
                | a :: b => fun m => exists A : F a, exists B : hlist F b, m = HCons A B
              end m
              with
              | HNil => tt
              | HCons _ _ _ _ => _
            end).
    do 2 eexists; reflexivity.
  Qed.
  Lemma hlist_nil : forall T (F : T -> Type) (m : hlist F nil), m = HNil.
  Proof.
    intros.
    refine (match m as m in hlist _ ls return
              match ls as ls return hlist _ ls -> Type with
                | nil => fun m => m = HNil
                | _ :: _ => fun _ => unit
              end m
              with
              | HNil => _
              | _ => tt
            end). reflexivity.
  Qed.

  Lemma split_semp : forall b a c,
    split a b c -> semp b -> a = c.
  Proof.
    unfold_all. unfold semp, smem_emp. unfold_all.
    induction b; simpl; intros; subst; auto.
    rewrite hlist_nil. rewrite (hlist_nil _ _ a). reflexivity.
    destruct (hlist_destruct _ _ _ _ a).
    destruct (hlist_destruct _ _ _ _ c).
    destruct H1. destruct H2. subst. specialize (IHb x2 x3).
    rewrite IHb; break; intuition; auto.
  Qed.

  Lemma semp_smem_emp : semp smem_emp.
  Proof.
    unfold semp, smem_emp; auto.
  Qed.

  Lemma split_a_semp_a : forall a,
    split a smem_emp a.
  Proof.
    unfold_all. induction a; simpl; intuition. rewrite <- H0. reflexivity.
  Qed.

  Lemma cons_not_in : forall T (a : T) b ls,
    a :: b = ls ->
    ~ In a ls ->
    forall P, P.
  Proof.
    intros; subst. exfalso; eapply H0. firstorder.
  Qed.

  Lemma relevant_in : forall a l b,
    In a (relevant' l b) ->
    In a l.
  Proof.
    induction l; auto; intros.
      rewrite (hlist_eta _ b) in H. simpl in H.
      destruct (hlist_hd b). destruct H. subst. firstorder.
      simpl in *. right. eapply IHl; eauto.
      right. eapply IHl; eauto.
  Qed.

  Lemma relevant_not_in : forall a l b,
    ~In a l ->
    ~In a (relevant' l b).
  Proof.
    intros. intro. eapply H. eapply relevant_in; eauto.
  Qed.

  Lemma relevant_eq : forall a b c,
    relevant a = relevant b ->
    satisfies a c ->
    satisfies b c ->
    a = b.
  Proof.
    unfold relevant, satisfies, smem. generalize NoDup_all_addr.
    induction all_addr; simpl; intros.
      rewrite (hlist_nil_only _ a). rewrite (hlist_nil_only _ b); auto.

      rewrite (hlist_eta _ a0) in *. rewrite (hlist_eta _ a0) in H1.
      rewrite (hlist_eta _ b) in *. rewrite (hlist_eta _ b) in H2.
      simpl in *.
      destruct (hlist_hd a0); destruct (hlist_hd b); intuition.
        rewrite H2 in H3. inversion H3; subst. inversion H0;  f_equal. eapply IHl; eauto.
          inversion H; auto.

        eapply cons_not_in. eassumption.
        eapply relevant_not_in. inversion H; auto.

        eapply cons_not_in. symmetry. eassumption.
        eapply relevant_not_in. inversion H; auto.

        f_equal; eauto. inversion H. eapply IHl; eauto.
  Qed.

  (** memoryIn **)
  Section memoryIn.
    Variable m : mem.

    Fixpoint memoryIn' (ls : list addr) : smem' ls :=
      match ls with
        | nil => HNil
        | l :: ls => HCons (mem_get m l) (memoryIn' ls)
      end.

    Definition memoryIn : smem := memoryIn' all_addr.
  End memoryIn.

  Theorem smem_set_relevant : forall p v sm sm',
    smem_set p v sm = Some sm' ->
    relevant sm = relevant sm'.
  Proof.
    unfold relevant, smem_set.
    induction all_addr; simpl; intros; auto.
      destruct (addr_dec a p); subst; auto.
      destruct (hlist_hd sm); try congruence.
      inversion H; clear H; subst. simpl. reflexivity.

      revert H. case_eq (smem_set' l p v (hlist_tl sm)); intros; try congruence.
      inversion H0; clear H0; subst; simpl in *.
      destruct (hlist_hd sm); eauto. f_equal; eauto.
  Qed.

  Theorem smem_set_word_relevant : forall ex p v sm sm',
    smem_set_word ex p v sm = Some sm' ->
    relevant sm = relevant sm'.
  Proof.
    unfold smem_set_word; intros.
    destruct (footprint_w p) as [ [ [ ? ? ] ? ] ? ].
    destruct (ex v) as [ [ [ ? ? ] ? ] ? ].
    repeat match goal with
             | [ H : match ?X with
                       | Some _ => _
                       | None => _
                     end = Some _ |- _ ] => revert H; case_eq X; intros; try congruence
             | [ H : smem_set _ _ _ = Some _ |- _ ] =>
               eapply smem_set_relevant in H
           end.
    congruence.
  Qed.

  Theorem satisfies_memoryIn : forall m,
    satisfies (memoryIn m) m.
  Proof.
    unfold satisfies, memoryIn. generalize all_addr.
    induction l; simpl; auto.
    intuition. destruct (mem_acc_dec m a).
    generalize (proj1 (mem_get_acc _ _) H). intro. destruct H0. rewrite H0. auto.
    case_eq (mem_get m a); intuition; auto.
    eapply mem_get_acc. eauto.
  Qed.

(*
Fixpoint memoryInUpto (width init : nat) (m : word width -> option B)
  : hlist (fun _ => option B) (allWordsUpto width init) :=
  match init with
    | O => HNil
    | S init' =>
      let w := natToWord width init' in
      let v := m w in
      HCons v (memoryInUpto (width := width) init' m)
  end.

Definition memoryIn_def (width : nat) :=
  memoryInUpto (width := width) (pow2 width).

Theorem fcong : forall A (B : A -> Type) (f g : forall x, B x) x,
  f = g
  -> f x = g x.
  congruence.
Defined.

Module Type ALL_WORDS.
  Parameter allWords : forall width : nat, list (word width).

  Axiom allWords_eq : allWords = allWords_def.

  Parameter memoryIn : forall width, (word width -> option B) -> hlist (fun _ : word width => option B) (allWords width).

  Axiom memoryIn_eq : forall width,
    memoryIn (width := width)
    = match fcong (fun width => list (word width)) width (sym_eq allWords_eq) in _ = L return _ -> hlist _ L with
        | refl_equal => memoryIn_def (width := width)
      end.
End ALL_WORDS.

Module AllWords : ALL_WORDS.
  Definition allWords := allWords_def.

  Theorem allWords_eq : allWords = allWords_def.
    reflexivity.
  Defined.

  Definition memoryIn := memoryIn_def.

  Theorem memoryIn_eq : forall width,
    memoryIn (width := width)
    = match fcong (fun width => list (word width)) width (sym_eq allWords_eq) in _ = L return _ -> hlist _ L with
        | refl_equal => memoryIn_def (width := width)
      end.
    reflexivity.
  Qed.
End AllWords.
*)

End HeapTheory.


Require Import Equations.Init.
Require Import Equations.Equations.

Require Export Parser.FocusedSyntaxPlug.
Require Export Parser.AmbiguityConflict.

Opaque unfocus_helper.

Program Definition conv { A B } (ls: Layers A B) (pre: empty_layers ls) (x: A): B :=
  match ls as ls' in Layers X Y return empty_layers ls' -> X -> Y with
  | Empty _ => fun H x => x
  | _ => _
  end pre x.

Equations (noind) result { A } (fs: Focused_Syntax A): option A
  by wf (length (layers fs) + count_follow_by (layers fs)) lt :=

  result fs :=
    match nullable_fun (core fs) with
    | None => None
    | Some x =>
      if (dec_empty_layers (layers fs))
      then Some (conv (layers fs) _ x)
      else result (plug (layers fs) x)
    end.

Next Obligation.
  auto using plug_count_follow_by.
Qed.

Fail Next Obligation. (* no more obligation for result *)

Ltac result_def := rewrite result_equation_1 in *.

Opaque result.

Lemma result_sound':
  forall n A (fs : Focused_Syntax A) v,
    length (layers fs) + count_follow_by (layers fs) <= n ->
    result fs = Some v ->
    matches (unfocus fs) [] v.
Proof.
  induction n; destruct fs; result_def;
    repeat light || destruct_match || nullable_fun_spec.

  - destruct layers; light; try lia.
    unfold unfocus; repeat light || unfocus_helper_def.

  - destruct layers; light; try lia.

  - unfold conv in *;
      repeat light || destruct_match.
    unfold unfocus; repeat light || unfocus_helper_def.

  - unshelve epose proof (IHn _ (plug layers i) v _ H0);
      lights.
    + unshelve epose proof (plug_count_follow_by _ _ layers i _);
        lights; try lia.
    + apply_anywhere plug_sound.
      eapply matches_unfocus_sub;
        eauto; repeat light || invert_matches.
Qed.

Lemma result_sound:
  forall A (fs : Focused_Syntax A) v,
    result fs = Some v ->
    matches (unfocus fs) [] v.
Proof.
  eauto using result_sound'.
Qed.

Lemma result_complete':
  forall n A (fs: Focused_Syntax A) v,
    length (layers fs) + count_follow_by (layers fs) <= n ->
    matches (unfocus_helper (layers fs) (core fs)) [] v ->
    ~ has_conflict_ind (unfocus_helper (layers fs) (core fs)) ->
    result fs = Some v.
Proof.
  induction n; destruct fs; result_def;
    repeat light || destruct_match || nullable_fun_spec || f_equal || unfold conv in * || destruct_match ||
           unfocus_helper_def;
    eauto using matches_nil_unicity;
    try solve [ destruct layers; lights; eauto with exfalso lia ].

  - apply_any;
      eauto using plug_no_conflict_unfocus.

    + unshelve epose proof (plug_count_follow_by _ _ layers i _);
        lights; try lia.
    + eapply plug_nullable;
        eauto.

  - apply_anywhere matches_unfocus_helper_nil;
      lights; eauto with exfalso.
Qed.

Lemma result_complete:
  forall A (fs: Focused_Syntax A) v,
    matches (unfocus fs) [] v ->
    ~ has_conflict_ind (unfocus_helper (layers fs) (core fs)) ->
    result fs = Some v.
Proof.
  destruct fs;
    eauto using result_complete'.
Qed.

Lemma result_correct:
  forall A (fs: Focused_Syntax A),
    ll1_ind (unfocus fs) ->
    result fs = nullable_fun (unfocus fs).
Proof.
  unfold ll1_ind; intros.
  destruct (result fs) eqn:RES;
  destruct (nullable_fun (unfocus fs)) eqn:NULL;
    repeat light || nullable_fun_spec.
  - apply_anywhere result_sound; matches_nil_unicity; lights.
  - apply_anywhere result_sound; eauto with exfalso.
  - apply_anywhere result_complete; lights.
Qed.


From Paco Require Import paco.

From stbor.lang Require Export defs.
From stbor.sim Require Export sflib.

CoInductive diverges
  (step: expr * config → expr * config → Prop)
  (cfg: expr * config) : Prop :=
| DivergeStep cfg' (STEP: step cfg cfg') (DIV: diverges step cfg') .

(* We would want to state that the terminal expression should be [value], but
  that comes from the invariant that all functions return [value]'s, which is
  not visible here. Furthermore, we want to state that terminal means ``not
  reducible but safe'', so we cannot exclude Place from terminal.
  Consequently, we use [result]. *)
Definition sim_expr_terminal (e1 e2: expr) :=
  ∀ v2, to_result e2 = Some v2 → to_result e1 = Some v2.
Instance sim_expr_terminal_po : PreOrder sim_expr_terminal.
Proof.
  constructor.
  - intros ?. rewrite /sim_expr_terminal. naive_solver.
  - move => e1 e2 e3 S1 S2 v3 /S2 /S1 //.
Qed.

Notation SIM_CONFIG := (nat → expr * state → expr * state → Prop)%type.

(* This is a simulation between two expressions without any interference.
  It corresponds to a sequential simulation. *)

Section sim.
Variable (fns fnt: fn_env).

(* We use index to account for divergence. TODO: explain more. *)
Record sim_base (sim: SIM_CONFIG) (idx1: nat) (eσ1_src eσ1_tgt: expr * state)
  : Prop := mkSimBase {
  (* (1) If [eσ1_tgt] gets stuck, [eσ1_src] can also get stuck. *)
  sim_stuck :
    (terminal eσ1_tgt.1 ∨ reducible fnt eσ1_tgt.1 eσ1_tgt.2) ;
  (* (2) If [eσ1_tgt] is terminal, then [eσ1_src] terminates with some steps. *)
  sim_terminal :
    terminal eσ1_tgt.1 → ∃ eσ2_src,
      eσ1_src ~{fns}~>* eσ2_src ∧
      terminal eσ2_src.1 ∧ sim_expr_terminal eσ2_src.1 eσ1_tgt.1 ;
  (* (3) If [eσ1_tgt] steps to [eσ2_tgt] with 1 step,
       then exists [eσ2_src] s.t. [eσ1_src] steps to [eσ2_src] with * step. *)
  sim_step :
    ∀ eσ2_tgt, eσ1_tgt ~{fnt}~> eσ2_tgt → ∃ idx2 eσ2_src,
      (eσ1_src ~{fns}~>+ eσ2_src ∨ ((idx2 < idx1)%nat ∧ eσ1_src = eσ2_src)) ∧
      sim idx2 eσ2_src eσ2_tgt;
}.

(* Generator for the actual simulation *)
Definition _sim
  (sim : SIM_CONFIG) (idx1: nat) (eσ1_src eσ1_tgt: expr * state) : Prop :=
  forall (NEVER_STUCK: never_stuck fns eσ1_src.1 eσ1_src.2)
    (WF_SRC: Wf eσ1_src.2)
    (WF_TGT: Wf eσ1_tgt.2),
    sim_base sim idx1 eσ1_src eσ1_tgt.

Lemma _sim_mono : monotone3 (_sim).
Proof.
  intros idx1 eσ_src eσ_tgt r r' TS LE NS WF1 WF2.
  destruct (TS NS WF1 WF2) as [SU TE ST]. repeat split; auto.
  intros eσ2_tgt ONE. destruct (ST _ ONE) as (idx2 & eσ2_src & STEP1 & Hr).
  exists idx2, eσ2_src. split; [done|]. by apply LE.
Qed.

(* Global simulation *)
Definition sim : SIM_CONFIG := paco3 _sim bot3.

End sim.

Hint Resolve _sim_mono: paco.


Require Import TestSuite.admit.
Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Polymorphic Record Category (obj : Type) :=
  Build_Category {
      Object :> _ := obj;
      Morphism : obj -> obj -> Type;

      Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
    }.

Polymorphic Record Functor objC (C : Category objC) objD (D : Category objD) :=
  { ObjectOf :> objC -> objD }.

Polymorphic Record NaturalTransformation objC C objD D (F G : Functor (objC := objC) C (objD := objD) D) :=
  { ComponentsOf' :> forall c, D.(Morphism) (F.(ObjectOf) c) (G.(ObjectOf) c);
    Commutes' : forall s d (m : C.(Morphism) s d), ComponentsOf' s = ComponentsOf' s }.

Ltac present_obj from to :=
  match goal with
           | [ _ : context[from ?obj ?C] |- _ ] => progress change (from obj C) with (to obj C) in *
           | [ |- context[from ?obj ?C] ] => progress change (from obj C) with (to obj C) in *
         end.

Section NaturalTransformationComposition.
  Set Universe Polymorphism.
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Context `(E : @Category objE).
  Variables F F' F'' : Functor C D.
  Unset Universe Polymorphism.

  Polymorphic Definition NTComposeT (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F') :
    NaturalTransformation F F''.
    exists (fun c => Compose _ _ _ _ (T' c) (T c)).
    repeat progress present_obj @Morphism @Morphism. (* removing this line makes the error go away *)
    intros. (* removing this line makes the error go away *)
    admit.
  Defined.
End NaturalTransformationComposition.

Polymorphic Definition FunctorCategory objC (C : Category objC) objD (D : Category objD) :
  @Category (Functor C D)
  := @Build_Category (Functor C D)
                     (NaturalTransformation (C := C) (D := D))
                     (NTComposeT (C := C) (D := D)).

Polymorphic Definition Cat0 : Category Empty_set
  := @Build_Category Empty_set
                     (@eq _)
                     (fun x => match x return _ with end).

Polymorphic Definition FunctorFrom0 objC (C : Category objC) : Functor Cat0 C
  := Build_Functor Cat0 C (fun x => match x with end).

Section Law0.
  Polymorphic Variable objC : Type.
  Polymorphic Variable C : Category objC.

  Set Printing All.
  Set Printing Universes.
  Set Printing Existential Instances.

  Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf' : Object (@FunctorCategory Empty_set Cat0 objC C).
  (* In environment
objC : Type (* Top.154 *)
C : Category (* Top.155 Top.154 *) objC
The term "objC" has type "Type (* Top.154 *)"
while it is expected to have type "Type (* Top.184 *)"
(Universe inconsistency: Cannot enforce Top.154 <= Set)). *)
  Admitted.

  Polymorphic Definition ExponentialLaw0Functor_Inverse_ObjectOf : Object (FunctorCategory Cat0 C).
    hnf.
    refine (@FunctorFrom0 _ _).

    (* Toplevel input, characters 23-40:
Error:
In environment
objC : Type (* Top.61069 *)
C : Category (* Top.61069 Top.61071 *) objC
The term
 "@FunctorFrom0 (* Top.61077 Top.61078 *) ?69 (* [objC, C] *)
    ?70 (* [objC, C] *)" has type
 "@Functor (* Set Prop Top.61077 Top.61078 *) Empty_set Cat0
    ?69 (* [objC, C] *) ?70 (* [objC, C] *)"
 while it is expected to have type
 "@Functor (* Set Prop Set Prop *) Empty_set Cat0 objC C".
*)
  Defined.
End Law0.


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

(***
Modulus : 2^255 - 19
Base: 51
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 51;
    bitwidth := 64;
    s := 2^255;
    c := [(1, 19)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%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.