(**
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.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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
.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


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 Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^152 - 17
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 64;
    bitwidth := 64;
    s := 2^152;
    c := [(1, 17)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    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 Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e165m25_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e152m17_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


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.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e235m15_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Verse.BitVector.
Require Import Verse.Machine.BitVector.

Require Import Verse.

Require Import Verse.AnnotatedCode.
Require Import Verse.HlistMachine.

Require Import List.
Import ListNotations.

Set Implicit Arguments.

Section Code.

  Variable v : VariableT.

  Variable A B : v of type Word8.

  Definition test : Repeat (line bvDenote v).
    verse
      ([code| A := B |]
         ++
         (ASSERT VAL A = VAL B)
         ++
         [code| A := B |]
         ++
         (ASSERT INIT B = VAL A + 1)
         ++
         [code| A := B |])%list%verse.
  Defined.

End Code.

(* TODO : Prop extraction tactics need to be readded for old
          AnnotatedCode. The name IntAnnotatedCode also needs
          change.
 *)

Definition toProve : Prop.
  getProp test.
Defined.

Require Import Verse.ProofTac.

Definition proof : toProve.
  realize.
Abort.