From Coq Require Import ZArith Rdefinitions String Psatz List.
From ExtLib Require Import Monad.
From MathClasses Require Import interfaces.canonical_names.
From Flocq Require Import Binary Bits Core.Defs.

Require Import Gappa.Gappa_tactic.

Require Import Helix.Util.VecSetoid.
Require Import Helix.Util.OptionSetoid.
Require Import Helix.Util.ErrorSetoid.
Require Import Helix.Util.FloatUtil.
Require Import Helix.Tactics.StructTactics.
Require Import Helix.Tactics.HelixTactics.

Require Import Helix.HCOL.CarrierType.
Require Import Helix.HCOL.HCOL.
Require Import Helix.HCOL.THCOL.

Require Import Helix.SigmaHCOL.SVector.
Require Import Helix.SigmaHCOL.Rtheta.
Require Import Helix.SigmaHCOL.SigmaHCOL.
Require Import Helix.SigmaHCOL.TSigmaHCOL.
Require Import Helix.SigmaHCOL.IndexFunctions.

Require Import Helix.MSigmaHCOL.RasCT.
Require Import Helix.MSigmaHCOL.ReifySHCOL.
Require Import Helix.MSigmaHCOL.MSigmaHCOL.
Require Import Helix.MSigmaHCOL.ReifyProofs.
Require Import Helix.MSigmaHCOL.RasCarrierA.
Require Import Helix.MSigmaHCOL.MemSetoid.

Require Import Helix.RSigmaHCOL.ReifyProofs.
Require Import Helix.RSigmaHCOL.RSigmaHCOL.

Require Import Helix.FSigmaHCOL.ReifyRHCOL.
Require Import Helix.FSigmaHCOL.Float64asCT.
Require Import Helix.FSigmaHCOL.FSigmaHCOL.

Require Import Helix.SymbolicDHCOL.SymbolicCT.
Require Import Helix.SymbolicDHCOL.RHCOLtoSRHCOL.
Require Import Helix.SymbolicDHCOL.FHCOLtoSFHCOL.

Require Import Helix.DynWin.DynWin.
Require Import Helix.DynWin.DynWinProofs.

Import ListNotations.
Import MonadNotation.
Import DynWin_CompareEpsilon.

Section RHCOL_to_FHCOL_bounds.

  Open Scope R_scope.

  (* The memory cell in which the boolean output is written by DynWin *)
  Definition dynwin_y_offset := 0%nat.

  (** Constraints on physical parameters **)
  (* Obstacle velocity constraint *)
  (* 0 <= V <= 20 (m/s) (<= 72 Kmh) *)
  Definition V_constr := (b64_0, b64_20).
  (* 1 < b <= 6 (m/s^2)
     https://copradar.com/chapts/references/acceleration.html *)
  Definition b_constr := (b64_1, b64_6).
  (* 0 <= A <= 5 (m/s^2)
     https://hypertextbook.com/facts/2001/MeredithBarricella.shtml *)
  Definition A_constr := (b64_0, b64_5).
  Definition e_constr := (b64_0_01, b64_0_1). (* 1/100 <= e <= 1/10. 10-100 Hz *)
  (* Constraints for obstacle and robot coordinates.
     Our robot operates on cartesian grid ~10x10 Km *)
  Definition x_constr := (b64_opp b64_5000, b64_5000).
  Definition y_constr := (b64_opp b64_5000, b64_5000).
  (* Robot velocity constraint *)
  Definition v_constr := (b64_0, b64_20).

  (*
    "a" layout:
     a0 = (A/b + 1.0) * ((A/2.0)*e*e + e*V)
     a1 = V/b + e*(A/b+1.0)
     a2 = 1.0/(2.0*b)

    "x" layout:
    0. robot velocity
    1. robot position (X)
    2. robot position (Y)
    3. obstacle position (X)
    4. obstacle position (Y)
   *)
  Definition make_a64 (V64 b64 A64 e64 : binary64) : FHCOL.mem_block :=
    (* DHCOL (and therefore CType) has no division *)
    let FT_div := b64_div FT_Rounding in

    let a0 :=
      MFloat64asCT.CTypeMult
        (MFloat64asCT.CTypePlus (FT_div A64 b64) b64_1)
        (MFloat64asCT.CTypePlus
           (MFloat64asCT.CTypeMult (MFloat64asCT.CTypeMult (FT_div A64 b64_2) e64) e64)
           (MFloat64asCT.CTypeMult e64 V64))
    in
    let a1 :=
      (MFloat64asCT.CTypePlus
         (FT_div V64 b64)
         (MFloat64asCT.CTypeMult
            e64
            (MFloat64asCT.CTypePlus (FT_div A64 b64) b64_1)))
    in
    let a2 :=
      FT_div
        b64_1
        (MFloat64asCT.CTypeMult b64_2 b64)
    in
    FHCOLEval.mem_add 0%nat a0
      (FHCOLEval.mem_add 1%nat a1
         (FHCOLEval.mem_add 2%nat a2
            (FHCOLEval.mem_empty))).

  Definition make_x64 (r_v_64 r_x_64 r_y_64 o_x_64 o_y_64 : binary64) : FHCOL.mem_block :=
    FHCOLEval.mem_add 0%nat r_v_64
      (FHCOLEval.mem_add 1%nat r_x_64
        (FHCOLEval.mem_add 2%nat r_y_64
          (FHCOLEval.mem_add 3%nat o_x_64
            (FHCOLEval.mem_add 4%nat o_y_64
              (FHCOLEval.mem_empty))))).

  (* Constraints on input memory blocks which we assume to prove
     numerical stability of FHCOL DynWin code.  Here, we enforce some
     reasonable numerical bounds on dynwin physical parameters.  *)
  Definition DynWinInConstr (a : RHCOLEval.mem_block) (x : RHCOLEval.mem_block): Prop
    :=
    exists V64 (* max obstacle speed *)
      b64 (* max braking *)
      A64 (* max accel *)
      e64 (* sampling period *)
      r_v_64
      r_x_64
      r_y_64
      o_x_64
      o_y_64,

      in_range_64 V_constr V64
      /\ in_range_64 b_constr b64
      /\ in_range_64 A_constr A64
      /\ in_range_64 e_constr e64
      /\ RHCOLtoFHCOL.heq_mem_block () RF_CHE
          a (make_a64 V64 b64 A64 e64)
      /\ in_range_64 v_constr r_v_64
      /\ in_range_64 x_constr r_x_64
      /\ in_range_64 y_constr r_y_64
      /\ in_range_64 x_constr o_x_64
      /\ in_range_64 y_constr o_y_64
      /\ RHCOLtoFHCOL.heq_mem_block () RF_CHE
          x (make_x64 r_v_64 r_x_64 r_y_64 o_x_64 o_y_64).

  (* Parametric relation between RHCOL and FHCOL coumputation results  *)
  (*
    Requisite relation:

     Binary64 out | Real out ||  Status
     -------------------------------------
     Safe         | Safe     ||  OK        (agreeing)
     Safe         | Unsafe   ||  FORBIDDEN (dangerous in reality, "safe" in 64)
     Unsafe       | Safe     ||  OK        (overly cautious)
     Unsafe       | Unsafe   ||  OK        (agreeing)

     in boolean terms, given "Safe" = true, "Unsafe" = false,
     this is

     [Binary64 out] => [Real out]

     (alternatively "Real = safe \/ Binary64 = unsafe")
   *)
  Definition DynWinOutRel
             (a_r:RHCOLEval.mem_block)
             (x_r:RHCOLEval.mem_block)
             (y_r:RHCOLEval.mem_block)
             (y_64:FHCOLEval.mem_block): Prop
    :=
    hopt_r (flip CType_impl)
      (RHCOLEval.mem_lookup dynwin_y_offset y_r)
      (FHCOLEval.mem_lookup dynwin_y_offset y_64).

  Global Instance DynWinOutRel_Proper :
    Proper ((=) ==> (=) ==> (=) ==> (=) ==> (iff)) DynWinOutRel.
  Proof.
    intros a1 a2 A x1 x2 X y1 y2 Y y64_1 y64_2 Y64.
    unfold DynWinOutRel.
    clear - Y Y64.
    specialize (Y dynwin_y_offset).
    specialize (Y64 dynwin_y_offset).
    rewrite Y, Y64.
    tauto.
  Qed.

End RHCOL_to_FHCOL_bounds.

Section Gappa.

  Open Scope Float64asCT_scope.

  Hint Rewrite
    b64_plus_to_R b64_minus_to_R
    b64_mult_to_R b64_div_to_R
    b64_max_to_R b64_abs_to_R

    b64_plus_finite b64_minus_finite
    b64_mult_finite b64_div_finite
    b64_max_finite b64_abs_finite
    : rewrite_to_R.

  Ltac not_known A :=
    match goal with
    | H : A |- _ => fail 1 "Assertion" A "already known in" H
    | _ => idtac
    end.

  Ltac assert_if_new_as Name H :=
    not_known H; assert (Name : H).

  Ltac known_finite x :=
    match goal with
    | [H : is_finite _ _ x ≡ true |- _] => idtac
    | _ => fail 1
    end.

  Ltac rewrite_to_R :=
    autounfold with unfold_FCT;
    autorewrite with rewrite_to_R;
    try assumption.

  Ltac gappa_form :=
    try apply bpow_lt_to_le;
    repeat (cbv [Defs.F2R IZR IPR IPR_2 Z.pow_pos Pos.iter] in *;
            simpl in *).

  Ltac simple_R :=
    match goal with
    | |- B2R _ _ (B754_finite _ _ _ _ _ _) ≢ 0%R => cbv; lra
    end.

  Ltac gappa_crush :=
    rewrite_to_R;
    autounfold with sugar64 F64_const in *;
    try simple_R;
    gappa_form;
    gappa.

  (* Extra safe match to avoid unnecessarily calling the heavy [gappa_crush] *)
  Ltac solve_with_gappa :=
    match goal with
    | |- no_overflow64 _ => gappa_crush
    | |- _ ≢ 0%R => gappa_crush
    | |- context [Rmax] => unfold Rmax; break_match_goal; gappa_crush
    end.

  Ltac crush_floats :=
    first
      [ assumption
      | reflexivity
      | eapply in_range_finite; eassumption
      | eapply in_range_l_finite; eassumption
      | rewrite_to_R; solve_with_gappa].

  Ltac assert_finite :=
    let FIN := fresh "FIN" in
    match goal with
    | [H : in_range_64 _ ?x |- _] =>
        assert_if_new_as FIN (is_finite _ _ x ≡ true)
    | [H : in_range_64_l _ ?x |- _] =>
        assert_if_new_as FIN (is_finite _ _ x ≡ true)
    | [H : context [?x ⊞ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as FIN (is_finite _ _ (x ⊞ y) ≡ true)
    | [H : context [?x ⊟ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as FIN (is_finite _ _ (x ⊟ y) ≡ true)
    | [H : context [?x ⊠ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as FIN (is_finite _ _ (x ⊠ y) ≡ true)
    | [H : context [?x ⧄ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as FIN (is_finite _ _ (x ⧄ y) ≡ true)
    | [H : context [fabs ?x] |- _] =>
        known_finite x;
        assert_if_new_as FIN (is_finite _ _ (fabs x) ≡ true)
    | [H : context [fmax ?x ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as FIN (is_finite _ _ (fmax x y) ≡ true)
    end.

  Ltac assert_no_overflow :=
    let NOVF := fresh "NOVF" in
    match goal with
    | [H : context [?x ⊞ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as NOVF
          (no_overflow64 (◻ (B64R x + B64R y)))
    | [H : context [?x ⊟ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as NOVF
          (no_overflow64 (◻ (B64R x - B64R y)))
    | [H : context [?x ⊠ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as NOVF
          (no_overflow64 (◻ (B64R x * B64R y)))
    | [H : context [?x ⧄ ?y] |- _] =>
        known_finite x; known_finite y;
        assert_if_new_as NOVF
          (no_overflow64 (◻ (B64R x / B64R y)))
    end.

  Ltac assert_divisor_nz :=
    let NZ := fresh "NZ" in
    match goal with
    | [H : context [?x ⧄ ?y] |- _] =>
        known_finite y;
        assert_if_new_as NZ (B64R y ≢ 0%R)
    end.

  Ltac assert_next :=
    first [assert_divisor_nz | assert_no_overflow | assert_finite].

  Open Scope R_scope.

  Lemma DynWin_arith
    (e a b vr vo a0 a1 a2 rx ry ox oy cheb64 poly64 cheb poly : R)
    (E : B64R b64_0_01 <= e <= B64R b64_0_1)
    (A : B64R b64_0 <= a <= B64R b64_5)
    (B : B64R b64_1 <= b <= B64R b64_6)
    (VR : B64R b64_0 <= vr <= B64R b64_20)
    (VO : B64R b64_0 <= vo <= B64R b64_20)
    (RX : B64R (b64_opp b64_5000) <= rx <= B64R b64_5000)
    (RY : B64R (b64_opp b64_5000) <= ry <= B64R b64_5000)
    (OX : B64R (b64_opp b64_5000) <= ox <= B64R b64_5000)
    (OY : B64R (b64_opp b64_5000) <= oy <= B64R b64_5000)
    (A0 : a0 ≡ ◻ (◻ (◻ (a / b) + B64R b64_1) *
                    ◻ (◻ (◻ (◻ (a / B64R b64_2) * e) * e) + ◻ (e * vo))))
    (A1 : a1 ≡ ◻ (◻ (vo / b) + ◻ (e * ◻ (◻ (a / b) + B64R b64_1))))
    (A2 : a2 ≡ ◻ (B64R b64_1 / ◻ (B64R b64_2 * b)))
    (CHEB64 : cheb64 ≡ Rmax (Rabs ◻ (rx - ox)) (Rabs ◻ (ry - oy)))
    (POLY64 : poly64 ≡ ◻ (◻ (◻ (B64R b64_0 + ◻ (B64R b64_1 * a0)) +
                               ◻ (◻ (B64R b64_1 * vr) * a1)) +
                            ◻ (◻ (◻ (B64R b64_1 * vr) * vr) * a2)))
    (CHEB : cheb ≡ Rmax (Rabs (ox - rx)) (Rabs (oy - ry)))
    (* TODO: this ([CU]) upper bound shouldn't be necessary here *)
    (CU : no_overflow64 ◻ (cheb64 - poly64))
    (POLY : poly ≡ a0 + vr * a1 + vr * vr * a2)
    :
    B64R compare_epsilon < ◻ (cheb64 - poly64) -> (poly < cheb)%R.
  Proof.
    intros LT64.
    (* 1b-40 *)
    pose (cheb_delta := B64R (
            B754_finite 53 1024 false 4503599627370496 (-92)
              (binary_float_of_bits_aux_correct 52 11 eq_refl eq_refl eq_refl
                 4427038433705197568))).

    assert (CHEB_DELTA : - cheb_delta <= cheb64 - cheb <= cheb_delta).
    {
      clear - RX RY OX OY CHEB CHEB64.
      subst.

      replace cheb_delta with (Rmax cheb_delta cheb_delta)
        by (unfold Rmax; break_if; reflexivity).

      eapply Rmax_no_error.
      -
        replace (Rabs (ox - rx)) with (Rabs (rx - ox))
          by (unfold Rabs; repeat break_if; lra).
        eapply Rabs_no_error.
        subst cheb_delta.
        gappa_crush.
      -
        replace (Rabs (oy - ry)) with (Rabs (ry - oy))
          by (unfold Rabs; repeat break_if; lra).
        eapply Rabs_no_error.
        subst cheb_delta.
        gappa_crush.
    }
    clear CHEB CHEB64.

    pose (poly_delta :=
            B64R (B754_finite 53 1024 false 5665758678918104 (-94)
                    (binary_float_of_bits_aux_correct 52 11 eq_refl eq_refl eq_refl
                       4419193393502004184))).

    assert (POLY_DELTA : - poly_delta <= poly64 - poly <= poly_delta).
    {
      clear LT64 CHEB_DELTA.
      subst cheb_delta poly_delta.
      replace (B64R b64_0) with 0 in * by reflexivity.
      replace (B64R b64_1) with 1 in * by (cbv; lra).
      repeat match goal with
             | [H : context [0 + ?x] |- _] =>
                 replace (0 + x) with x in * by lra
             | [H : context [1 * ?x] |- _] =>
                 replace (1 * x) with x in * by lra
             end.

      gappa_crush.
    }

    clear - LT64 CU CHEB_DELTA POLY_DELTA.
    subst cheb_delta poly_delta.
    apply RIneq.Rlt_le in LT64.
    enough (E : B64R float64_subnormal_eps <=
                  cheb - poly
                <= 2 * Raux.bpow radix2 1024)
      by (cbv in E; lra).

    assert (BND64 : B64R compare_epsilon <= ◻ (cheb64 - poly64) <= Raux.bpow radix2 1024).
    {
      clear - CU LT64.
      split; [assumption |].
      unfold no_overflow64, Rabs in *.
      break_if; lra.
    }
    clear CU LT64.

    gappa_crush.
  Qed.

  Close Scope R_scope.

  Lemma DynWin_numerical_stability
    (V64 b64 A64 e64 v64 rx64 ry64 ox64 oy64 : binary64)
    (fa0 fa1 fa2 fx0 fx1 fx2 fx3 fx4 : binary64)
    (VC  : in_range_64 V_constr V64)
    (bC  : in_range_64 b_constr b64)
    (AC  : in_range_64 A_constr A64)
    (eC  : in_range_64 e_constr e64)
    (vC  : in_range_64 v_constr v64)
    (rxC : in_range_64 x_constr rx64)
    (ryC : in_range_64 y_constr ry64)
    (oxC : in_range_64 x_constr ox64)
    (oyC : in_range_64 y_constr oy64)

    (FFA0 : is_finite _ _ fa0 ≡ true)
    (FFA1 : is_finite _ _ fa1 ≡ true)
    (FFA2 : is_finite _ _ fa2 ≡ true)
    (FFX0 : is_finite _ _ fx0 ≡ true)
    (FFX1 : is_finite _ _ fx1 ≡ true)
    (FFX2 : is_finite _ _ fx2 ≡ true)
    (FFX3 : is_finite _ _ fx3 ≡ true)
    (FFX4 : is_finite _ _ fx4 ≡ true)

    (FX0 : B64R fx0 ≡ B64R v64)
    (FX1 : B64R fx1 ≡ B64R rx64)
    (FX2 : B64R fx2 ≡ B64R ry64)
    (FX3 : B64R fx3 ≡ B64R ox64)
    (FX4 : B64R fx4 ≡ B64R oy64)

    (FA0 : B64R fa0
           ≡ B64R ((A64 ⧄ b64 ⊞ b64_1) ⊠ ((A64 ⧄ b64_2 ⊠ e64) ⊠ e64 ⊞ e64 ⊠ V64)))
    (FA1 : B64R fa1 ≡ B64R (V64 ⧄ b64 ⊞ e64 ⊠ (A64 ⧄ b64 ⊞ b64_1)))
    (FA2 : B64R fa2 ≡ B64R (b64_1 ⧄ (b64_2 ⊠ b64)))

    (F : safe_lt64 FT_Rounding compare_epsilon
           (((0.0 ⊞ 1.0 ⊠ fa0) ⊞ (1.0 ⊠ fx0) ⊠ fa1) ⊞ ((1.0 ⊠ fx0) ⊠ fx0) ⊠ fa2)
           (fmax (fmax 0.0 (fabs (fx1 ⊟ fx3))) (fabs (fx2 ⊟ fx4))))
      :
      (MRasCT.CTypePlus
         (MRasCT.CTypePlus
            (MRasCT.CTypePlus MRasCT.CTypeZero
               (MRasCT.CTypeMult MRasCT.CTypeOne (B64R fa0)))
            (MRasCT.CTypeMult (MRasCT.CTypeMult MRasCT.CTypeOne (B64R fx0)) (B64R fa1)))
         (MRasCT.CTypeMult
            (MRasCT.CTypeMult (MRasCT.CTypeMult MRasCT.CTypeOne (B64R fx0)) (B64R fx0))
            (B64R fa2)) <
         MRasCT.CTypeMax
           (MRasCT.CTypeMax MRasCT.CTypeZero
              (MRasCT.CTypeAbs (MRasCT.CTypeSub (B64R fx1) (B64R fx3))))
           (MRasCT.CTypeAbs (MRasCT.CTypeSub (B64R fx2) (B64R fx4))))%R.
  Proof.
    rewrite !fmaxZeroAbs, !R_MaxZeroAbs, !R_PlusZeroLeft, !R_MultOneLeft in *.

    autounfold with unfold_RCT.
    unfold plus, negate, CarrierAneg, Basics.compose.
    replace (- B64R fx1 + B64R fx3)%R
      with (B64R fx3 - B64R fx1)%R
      by lra.
    replace (- B64R fx2 + B64R fx4)%R
      with (B64R fx4 - B64R fx2)%R
      by lra.

    unfold safe_lt64 in *.
    fold MFloat64asCT.CTypeSub in *.

    repeat
      (let RAN := fresh "RAN" in
       match goal with
       | [H : in_range_64 ?constr ?x |- _] =>
           assert_if_new_as RAN
             (B64R (fst constr) <= B64R x <= B64R (snd constr))%R
       | [H : in_range_64_l ?constr ?x |- _] =>
           assert_if_new_as RAN
             (B64R (fst constr) < B64R x <= B64R (snd constr))%R
       end;
      [first [eapply in_range_64_to_R | eapply in_range_64_l_to_R];
       try reflexivity; eassumption
      |]).
    repeat match goal with
           | [H : context[fst ?x] |- _] => unfold x in *
           | [H : context[snd ?x] |- _] => unfold x in *
           end;
      cbn [fst snd] in *.

    assert (FIN : is_finite _ _ b64_1 ≡ true) by reflexivity.
    assert (FIN0 : is_finite _ _ b64_2 ≡ true) by reflexivity.
    assert (FIN1 : is_finite _ _ 0.0 ≡ true) by reflexivity.
    assert (FIN2 : is_finite _ _ 1.0 ≡ true) by reflexivity.
    assert (FIN3 : is_finite _ _ compare_epsilon ≡ true) by reflexivity.

    (* a hack to avoid matching *)
    pose (hidden_finite := is_finite).
    replace is_finite with hidden_finite in FFA0, FFA1, FFA2 by reflexivity.

    repeat (assert_next; [shelve |]).

    subst hidden_finite.

    autounfold with unfold_FCT in FA0, FA1, FA2;
      autorewrite with rewrite_to_R in FA0, FA1, FA2;
      try assumption.

    repeat (assert_next; [shelve |]).

    apply lt64_correct in F; try assumption.

    pose proof NOVF22 as UF.
    autounfold with unfold_FCT in F;
      autorewrite with rewrite_to_R in F;
      try assumption.

    autounfold with unfold_FCT in UF;
      autorewrite with rewrite_to_R in UF;
      try assumption.

    rewrite !FX0, !FX1, !FX2, !FX3, !FX4 in *.
    clear - FA0 FA1 FA2 UF F RAN RAN0 RAN1 RAN2 RAN3 RAN4 RAN5 RAN6 RAN7.

    generalize dependent (B64R v64); intros vr ? VR.
    generalize dependent (B64R e64); intros e ? ? E.
    generalize dependent (B64R A64); intros a A ? ?.
    generalize dependent (B64R b64); intros b ? B ?.
    generalize dependent (B64R V64); intros vo VO ? ?.

    generalize dependent (B64R fa0); intros a0 ? A0.
    generalize dependent (B64R fa1); intros a1 A1 ?.
    generalize dependent (B64R fa2); intros a2 A2 ?.

    generalize dependent (B64R rx64); intros rx RX ?.
    generalize dependent (B64R ry64); intros ry RY ?.
    generalize dependent (B64R ox64); intros ox OX ?.
    generalize dependent (B64R oy64); intros oy OY ?.
    intros UF.

    repeat match goal with
           | [f : binary64 |- _] => clear f
           end.

    rewrite RCT_max_Rmax.
    setoid_rewrite RCT_abs_Rabs.

    remember (Rmax (Rabs (ox - rx)) (Rabs (oy - ry))) as cheb eqn:CHEB.
    remember (Rmax (Rabs ◻ (rx - ox)) (Rabs ◻ (ry - oy))) as cheb64 eqn:CHEB64.
    remember (a0 + vr * a1 + vr * vr * a2)%R as poly eqn:POLY.
    remember (◻ (◻ (◻ (B64R b64_0 + ◻ (B64R b64_1 * a0)) +
                      ◻ (◻ (B64R b64_1 * vr) * a1)) +
                   ◻ (◻ (◻ (B64R b64_1 * vr) * vr) * a2)))
               as poly64 eqn:POLY64.

    do 15 match goal with | [r : R |- _] => move r at top end.
    move F at bottom.
    move A2 after OY.
    move A1 after OY.
    move A0 after OY.

    eapply DynWin_arith.
    1-3: eassumption.
    eapply VR.
    eapply VO.
    eapply RX.
    eapply RY.
    eapply OX.
    eapply OY.
    all: eassumption.

    (* This would be nicely suitable for [par:] instead of [all:],
       but that encounters an anomaly *)
    Unshelve.
    all: crush_floats.
  Qed.

End Gappa.

Section DynWin_Symbolic.

  Variable ar : vector R 3.
  Variable xr : vector R dynwin_i.

  Fact lt0_3 : 0 < 3. repeat constructor. Qed.
  Fact lt1_3 : 1 < 3. repeat constructor. Qed.
  Fact lt2_3 : 2 < 3. repeat constructor. Qed.

  Fact lt0_5 : 0 < 5. repeat constructor. Qed.
  Fact lt1_5 : 1 < 5. repeat constructor. Qed.
  Fact lt2_5 : 2 < 5. repeat constructor. Qed.
  Fact lt3_5 : 3 < 5. repeat constructor. Qed.
  Fact lt4_5 : 4 < 5. repeat constructor. Qed.

  Let R_env :=
    [Vnth ar lt0_3;
     Vnth ar lt1_3;
     Vnth ar lt2_3;

     Vnth xr lt0_5;
     Vnth xr lt1_5;
     Vnth xr lt2_5;
     Vnth xr lt3_5;
     Vnth xr lt4_5].

  Let r_imemory := dynwin_R_memory ar xr.

  Definition dynwin_SR_σ :=
    [(SRHCOLEval.DSHPtrVal dynwin_a_addr 3, false);
     (SRHCOLEval.DSHPtrVal dynwin_y_addr 1, false);
     (SRHCOLEval.DSHPtrVal dynwin_x_addr 5, false)].

  Definition R_a_mb :=
    SRHCOLEval.mem_add 0 (SVar 0)
      (SRHCOLEval.mem_add 1 (SVar 1)
         (SRHCOLEval.mem_add 2 (SVar 2)
            SRHCOLEval.mem_empty)).

  Definition R_x_mb :=
    SRHCOLEval.mem_add 0 (SVar 3)
      (SRHCOLEval.mem_add 1 (SVar 4)
         (SRHCOLEval.mem_add 2 (SVar 5)
            (SRHCOLEval.mem_add 3 (SVar 6)
               (SRHCOLEval.mem_add 4 (SVar 7)
                  SRHCOLEval.mem_empty)))).

  Definition dynwin_SR_memory :=
    SRHCOLEval.memory_set
      (SRHCOLEval.memory_set
         (SRHCOLEval.memory_set SRHCOLEval.memory_empty
            dynwin_a_addr R_a_mb)
         dynwin_x_addr R_x_mb)
      dynwin_y_addr SRHCOLEval.mem_empty.

  Definition i1 := {| Int64asNT.Int64.intval := 1;
                     Int64asNT.Int64.intrange := conj eq_refl eq_refl |}.
  Definition i3 := {| Int64asNT.Int64.intval := 3;
                     Int64asNT.Int64.intrange := conj eq_refl eq_refl |}.
  Definition i5 := {| Int64asNT.Int64.intval := 5;
                     Int64asNT.Int64.intrange := conj eq_refl eq_refl |}.

  Definition dynwin_SF_σ :=
    [(SFHCOLEval.DSHPtrVal dynwin_a_addr i3, false);
     (SFHCOLEval.DSHPtrVal dynwin_y_addr i1, false);
     (SFHCOLEval.DSHPtrVal dynwin_x_addr i5, false)].

  Definition Fmemory_lookup_deep_unsafe
    (m : FHCOLEval.memory) '(i, off) : MFloat64asCT.t :=
    match FHCOLEval.memory_lookup m i with
    | Some mb => match FHCOLEval.mem_lookup off mb with
                | Some v => v
                | _ => MFloat64asCT.CTypeZero
                end
    | _ => MFloat64asCT.CTypeZero
    end.

  Definition Float_env m :=
    List.map (Fmemory_lookup_deep_unsafe m)
      [(0,0); (0,1); (0,2);
       (2,0); (2,1); (2,2); (2,3); (2,4)].

  (* Convenience wrapper over [RHCOLtoSRHCOL_semantic_preservation] *)
  Lemma RHCOL_to_symbolic_lookup
    (r_σ : RHCOLEval.evalContext)
    (r_op : RHCOLEval.DSHOperator)
    (r_m r_m' : RHCOLEval.memory)
    (r_mb : RHCOLEval.mem_block)

    (sr_σ : SRHCOLEval.evalContext)
    (sr_op : SRHCOLEval.DSHOperator)
    (sr_m : SRHCOLEval.memory)

    (i off : nat)
    (env : RealEnv)
    :
    RHCOLtoSRHCOL.heq_evalContext env RSR_NHE RSR_CHE r_σ sr_σ ->
    RHCOLtoSRHCOL.heq_memory env RSR_CHE r_m sr_m ->

    RHCOLtoSRHCOL.translate r_op = inr sr_op ->

    RHCOLEval.evalDSHOperator r_σ r_op r_m (RHCOLEval.estimateFuel r_op)
    = Some (inr r_m') ->
    RHCOLEval.memory_lookup r_m' i = Some r_mb ->

    RHCOLEval.mem_lookup off r_mb =
      match SRHCOLEval.evalDSHOperator sr_σ sr_op sr_m
              (SRHCOLEval.estimateFuel sr_op) with
      | Some (inr sr_m') =>
          match SRHCOLEval.memory_lookup sr_m' i with
          | Some sr_mb =>
              match SRHCOLEval.mem_lookup off sr_mb with
              | Some sexpr =>
                  evalRealSExpr env sexpr
              | _ => None
              end
          | _ => None
          end
      | _ => None
      end.
  Proof.
    intros Σ M OP RE MB.
    pose proof RHCOLtoSRHCOL_semantic_preservation
      r_op sr_op
      r_σ sr_σ
      r_m sr_m
      env
      as SR_EQUIV.
    full_autospecialize SR_EQUIV; try assumption.

    apply RHCOLtoSRHCOL.translation_syntax_always_correct;
      [apply RSR_NTP | assumption ].

    (* poor man's setoid_rewrite *)
    eapply hopt_r_proper in SR_EQUIV;
      [
      | eapply herr_c_proper, RHCOLtoSRHCOL.heq_memory_proper
      | now rewrite RE
      | reflexivity ].

    invc SR_EQUIV.
    invc H1.
    specialize (H2 i).

    eapply hopt_r_proper in H2;
      [
      | eapply RHCOLtoSRHCOL.heq_mem_block_proper
      | now rewrite MB
      | reflexivity ].

    invc H2.
    specialize (H3 off).

    invc H3.
    reflexivity.
    rewrite H4.
    reflexivity.
  Qed.

  (* TODO: this is exactly the same as the above *)
  Lemma FHCOL_to_symbolic_lookup
    (r_σ : FHCOLEval.evalContext)
    (r_op : FHCOLEval.DSHOperator)
    (r_m r_m' : FHCOLEval.memory)
    (r_mb : FHCOLEval.mem_block)

    (sr_σ : SFHCOLEval.evalContext)
    (sr_op : SFHCOLEval.DSHOperator)
    (sr_m : SFHCOLEval.memory)

    (i off : nat)
    (env : FloatEnv)
    :
    FHCOLtoSFHCOL.heq_evalContext env FSF_NHE FSF_CHE r_σ sr_σ ->
    FHCOLtoSFHCOL.heq_memory env FSF_CHE r_m sr_m ->

    FHCOLtoSFHCOL.translate r_op = inr sr_op ->

    FHCOLEval.evalDSHOperator r_σ r_op r_m (FHCOLEval.estimateFuel r_op)
    = Some (inr r_m') ->
    FHCOLEval.memory_lookup r_m' i = Some r_mb ->

    FHCOLEval.mem_lookup off r_mb =
      match SFHCOLEval.evalDSHOperator sr_σ sr_op sr_m
              (SFHCOLEval.estimateFuel sr_op) with
      | Some (inr sr_m') =>
          match SFHCOLEval.memory_lookup sr_m' i with
          | Some sr_mb =>
              match SFHCOLEval.mem_lookup off sr_mb with
              | Some sexpr =>
                  evalFloatSExpr env sexpr
              | _ => None
              end
          | _ => None
          end
      | _ => None
      end.
  Proof.
    intros Σ M OP RE MB.
    pose proof FHCOLtoSFHCOL_semantic_preservation
      r_op sr_op
      r_σ sr_σ
      r_m sr_m
      env
      as SF_EQUIV.
    full_autospecialize SF_EQUIV; try assumption.

    apply FHCOLtoSFHCOL.translation_syntax_always_correct;
      [apply FSF_NTP | assumption ].

    (* poor man's setoid_rewrite *)
    eapply hopt_r_proper in SF_EQUIV;
      [
      | eapply herr_c_proper, FHCOLtoSFHCOL.heq_memory_proper
      | now rewrite RE
      | reflexivity ].

    invc SF_EQUIV.
    invc H1.
    specialize (H2 i).

    eapply hopt_r_proper in H2;
      [
      | eapply FHCOLtoSFHCOL.heq_mem_block_proper
      | now rewrite MB
      | reflexivity ].

    invc H2.
    specialize (H3 off).

    invc H3.
    reflexivity.
    rewrite H4.
    reflexivity.
  Qed.

  (* For some reason the lhs of this
     doesn't [cbn/cbv/etc], but easily [Compute]s *)
  Fact DynWin_Symbolic_out :
    match
      evalDSHOperator dynwin_SF_σ DynWin_SFHCOL_hard dynwin_SR_memory
        (estimateFuel DynWin_SFHCOL_hard)
    with
    | Some (inr sr_m') =>
        match memory_lookup sr_m' dynwin_y_addr with
        | Some sr_mb =>
            match mem_lookup dynwin_y_offset sr_mb with
            | Some sexpr => Some sexpr
            | None => None
            end
        | None => None
        end
    | _ => None
    end
    ≡ Some
        (SZLess
           (SPlus
              (SPlus (SPlus SConstZero (SMult SConstOne (SVar 0)))
                 (SMult (SMult SConstOne (SVar 3)) (SVar 1)))
              (SMult (SMult (SMult SConstOne (SVar 3)) (SVar 3)) (SVar 2)))
           (SMax (SMax SConstZero (SAbs (SSub (SVar 4) (SVar 6))))
              (SAbs (SSub (SVar 5) (SVar 7))))).
  Proof.
    reflexivity.
  Qed.

  Lemma RHCOL_to_FHCOL_numerical_correct
    (r_omemory : RHCOLEval.memory)
    (a_rmem x_rmem y_rmem : RHCOLEval.mem_block)
    (f_imemory f_omemory : FHCOLEval.memory)
    (f_iσ : FHCOLEval.evalContext)
    (y_fmem : FHCOLEval.mem_block)
    (DynWin_FHCOL : FHCOLEval.DSHOperator)

    (R_EVAL : RHCOLEval.evalDSHOperator dynwin_R_σ DynWin_RHCOL r_imemory
                (RHCOLEval.estimateFuel DynWin_RHCOL)
              = Some (inr r_omemory))
    (A_RMEM : RHCOLEval.memory_lookup r_imemory dynwin_a_addr = Some a_rmem)
    (X_RMEM : RHCOLEval.memory_lookup r_imemory dynwin_x_addr = Some x_rmem)
    (Y_RMEM : RHCOLEval.memory_lookup r_omemory dynwin_y_addr = Some y_rmem)

    (F_EVAL : FHCOLEval.evalDSHOperator f_iσ DynWin_FHCOL f_imemory
                (FHCOLEval.estimateFuel DynWin_FHCOL)
              = Some (inr f_omemory))
    (Y_FMEM : FHCOLEval.memory_lookup f_omemory dynwin_y_addr = Some y_fmem)

    (TRANSLATE_OP : RHCOLtoFHCOL.translate DynWin_RHCOL = inr DynWin_FHCOL)
    (RF_IM : RHCOLtoFHCOL.heq_memory () RF_CHE r_imemory f_imemory)
    (RF_IΣ : RHCOLtoFHCOL.heq_evalContext () RF_NHE RF_CHE dynwin_R_σ f_iσ)
    :
    DynWinInConstr a_rmem x_rmem ->
    DynWinOutRel a_rmem x_rmem y_rmem y_fmem.
  Proof.
    intros INCONSTR.
    unfold DynWinOutRel.

    (* poor man's [setoid_rewrite RHCOL_to_symbolic_lookup] *)
    eapply hopt_r_proper;
      [typeclasses eauto | | reflexivity |].
    {
      rewrite RHCOL_to_symbolic_lookup with
        (sr_σ := dynwin_SR_σ)
        (sr_m := dynwin_SR_memory)
        (i := dynwin_y_addr)
        (off := dynwin_y_offset)
        (env := R_env).
      5,6: eassumption.
      4: {
        rewrite DynWin_RHCOL_hard_OK, DynWin_SRHCOL_hard_OK.
        reflexivity.
      }

      reflexivity.

      -
        repeat constructor.
      -
        intros k.
        do 3 try destruct k.
        + (* a *)
          unfold r_imemory.
          cbn - [ctvector_to_mem_block].
          constructor.
          intros k.
          do 3 try destruct k.
          1-3: erewrite mem_lookup_ctvector_to_mem_block.
          1-3: now constructor.
          cbn - [ctvector_to_mem_block].
          rewrite ctvector_to_mem_block_key_oob.
          constructor.
          lia.
        + (* y *)
          unfold r_imemory.
          cbn - [ctvector_to_mem_block].
          repeat constructor.
        + (* x *)
          unfold r_imemory.
          cbn - [ctvector_to_mem_block].
          constructor.
          intros k.
          do 5 try destruct k.
          1-5: erewrite mem_lookup_ctvector_to_mem_block.
          1-5: now constructor.
          cbn - [ctvector_to_mem_block].
          rewrite ctvector_to_mem_block_key_oob.
          constructor.
          lia.
        +
          constructor.
    }

    cbv - [FHCOLEval.mem_lookup CType_impl evalRealSExpr R_env].
    eapply hopt_r_proper;
      [typeclasses eauto | reflexivity | |].
    {
      rewrite FHCOL_to_symbolic_lookup with
        (sr_σ := dynwin_SF_σ)
        (sr_m := dynwin_SR_memory)
        (i := dynwin_y_addr)
        (off := dynwin_y_offset)
        (env := Float_env f_imemory).
      5,6: eassumption.
      4: {
        rewrite DynWin_FHCOL_hard_OK in TRANSLATE_OP.
        invc TRANSLATE_OP.
        erewrite FHCOLtoSFHCOL.translate_proper.
        now rewrite DynWin_SFHCOL_hard_OK.
        now rewrite H1.
      }

      reflexivity.
      -
        clear - RF_IΣ RF_IM.
        invc RF_IΣ; invc H3; invc H5; invc H6.
        repeat constructor.
        all: unfold RHCOLtoFHCOL.heq_evalContextElem in *.
        all: repeat break_let; subst_max.
        all: invc H1; invc H2; invc H3.
        all: invc H; invc H1; invc H2.
        all: invc H0; invc H4; invc H5.
        all: repeat constructor; try congruence.
        all: cbn in *; unfold heq_nat_int in *.
        all: destruct s', s'0, s'1; cbv in H6, H7, H8; subst.
        all: cbv; f_equal; apply proof_irrelevance.
      -
        clear - RF_IM.
        intros k; specialize (RF_IM k).
        do 3 try destruct k.
        + (* a *)
          unfold r_imemory in *.
          cbn - [Float_env ctvector_to_mem_block] in *.
          invc RF_IM.
          constructor.
          intros off; specialize (H1 off).
          do 3 try destruct off.
          4: {
            rewrite ctvector_to_mem_block_key_oob in H1 by lia.
            invc H1.
            constructor.
          }

          all: erewrite mem_lookup_ctvector_to_mem_block in H1.
          all: invc H1.
          all: cbn - [Float_env].
          all: constructor.
          all: unfold heq_Float_SExpr; cbn.
          all: now rewrite <-H0, <-H2.
          Unshelve.
          all: cbv; lia.
        + (* y *)
          unfold r_imemory in *.
          cbn - [Float_env ctvector_to_mem_block] in *.
          invc RF_IM.
          constructor.
          intros off; specialize (H1 off); invc H1.
          cbn.
          constructor.
        + (* x *)
          unfold r_imemory in *.
          cbn - [Float_env ctvector_to_mem_block] in *.
          invc RF_IM.
          constructor.
          intros off; specialize (H1 off).
          do 5 try destruct off.
          6: {
            rewrite ctvector_to_mem_block_key_oob in H1 by lia.
            invc H1.
            constructor.
          }

          all: erewrite mem_lookup_ctvector_to_mem_block in H1.
          all: invc H1.
          all: cbn - [Float_env].
          all: constructor.
          all: unfold heq_Float_SExpr; cbn.
          all: now rewrite <-H0, <-H2.
          Unshelve.
          all: cbv; lia.
        +
          invc RF_IM.
          constructor.
    }

    pose proof DynWin_Symbolic_out as DS.
    repeat break_match_goal; try some_none.
    invc DS.

    (*
    (evalDSHOperator dynwin_SF_σ DynWin_SFHCOL_hard dynwin_SR_memory
       (estimateFuel DynWin_SFHCOL_hard))
      with (Some (@inr string _ hackity_hack))
      by reflexivity.
    unfold hackity_hack.
     *)
    cbv - [CType_impl evalRealSExpr R_env evalFloatSExpr Float_env].

    assert (RF_Env : forall k, nth_error R_env k ≡
                   liftM (B2R _ _) (nth_error (Float_env f_imemory) k)).
    {
      clear - RF_IM.
      intros.
      do 8 try destruct k.
      9: cbn; now rewrite !nth_error_nil_None.

      all: cbn.
      all: match goal with
           | |- context[FHCOLEval.memory_lookup _ ?n] =>
               specialize (RF_IM n)
           end.
      all: cbn - [ctvector_to_mem_block] in RF_IM; invc RF_IM.
      all: match goal with
           | |- context[FHCOLEval.mem_lookup ?n _] =>
               specialize (H1 n)
           end.
      all: erewrite mem_lookup_ctvector_to_mem_block in H1.
      all: invc H1; invc H3.
      all: rewrite H1; reflexivity.
    }

    clear - INCONSTR A_RMEM X_RMEM RF_IM RF_Env.
    cbn [evalRealSExpr evalFloatSExpr].
    rewrite !RF_Env; clear RF_Env.

    unfold Float_env.
    rewrite !Coqlib.list_map_nth.
    cbn [nth_error Coqlib.option_map
           liftM liftM2 OptionMonad.Monad_option bind ret].
    constructor.

    pose proof RF_IM 0 as RF_A_IM.
    rewrite A_RMEM in RF_A_IM.
    invc RF_A_IM.

    pose proof RF_IM 2 as RF_X_IM.
    rewrite X_RMEM in RF_X_IM.
    invc RF_X_IM.

    cbn [Fmemory_lookup_deep_unsafe].
    rewrite <-!H0, <-!H2.
    clear - INCONSTR H1 H3.
    rename b into a_fmem, b0 into x_fmem, H1 into FA, H3 into FX.

    unfold DynWinInConstr in INCONSTR.
    destruct INCONSTR as
      (V64 & b64 & A64 & e64 & v64 & rx64 & ry64 & ox64 & oy64 & INCONSTR).
    destruct INCONSTR as
      (VC & bC & AC & eC & A & vC & rxC & ryC & oxC & oyC & X).

    unfold make_a64 in *.

    Ltac mem_lookup_simpl :=
      unfold FHCOLEval.mem_add, FHCOLEval.mem_lookup in *;
      repeat (try rewrite Memory.NP.F.add_eq_o in * by lia;
              try rewrite Memory.NP.F.add_neq_o in * by lia).

    (* Hardcoded lookups in a *)
    pose proof (A 0) as A0.
    pose proof (FA 0) as FA0.
    mem_lookup_simpl.
    inversion A0 as [| a0 ? A0E A0'];
      subst; rewrite <-A0' in *; clear A0 A0'.
    inversion FA0 as [| a0' ? FA0E TMP1 TMP2];
      subst; rename b into fa0; clear TMP2 FA0.

    pose proof (A 1) as A1.
    pose proof (FA 1) as FA1.
    mem_lookup_simpl.
    inversion A1 as [| a1 ? A1E A1'];
      subst; rewrite <-A1' in *; clear A1 A1'.
    inversion FA1 as [| a1' ? FA1E TMP1 TMP2];
      subst; rename b into fa1; clear TMP2 FA1.

    pose proof (A 2) as A2.
    pose proof (FA 2) as FA2.
    mem_lookup_simpl.
    remember (b64_div FT_Rounding b64_1 (MFloat64asCT.CTypeMult b64_2 b64)) as T.
    inversion A2 as [| a2 ? A2E A2'];
      subst; rewrite <-A2' in *; clear A2 A2'.
    inversion FA2 as [| a2' ? FA2E TMP1 TMP2];
      subst; rename b into fa2; clear TMP2 FA2.

    clear A FA.

    (* Hardcoded lookups in x *)
    pose proof (X 0) as X0.
    pose proof (FX 0) as FX0.
    mem_lookup_simpl.
    inversion X0 as [| x0 ? X0E X0'];
      subst; rewrite <-X0' in *; clear X0 X0'.
    inversion FX0 as [| x0' ? FX0E TMP1 TMP2];
      subst; rename b into fx0; clear TMP2 FX0.

    pose proof (X 1) as X1.
    pose proof (FX 1) as FX1.
    mem_lookup_simpl.
    inversion X1 as [| x1 ? X1E X1'];
      subst; rewrite <-X1' in *; clear X1 X1'.
    inversion FX1 as [| x1' ? FX1E TMP1 TMP2];
      subst; rename b into fx1; clear TMP2 FX1.

    pose proof (X 2) as X2.
    pose proof (FX 2) as FX2.
    mem_lookup_simpl.
    inversion X2 as [| x2 ? X2E X2'];
      subst; rewrite <-X2' in *; clear X2 X2'.
    inversion FX2 as [| x2' ? FX2E TMP1 TMP2];
      subst; rename b into fx2; clear TMP2 FX2.

    pose proof (X 3) as X3.
    pose proof (FX 3) as FX3.
    mem_lookup_simpl.
    inversion X3 as [| x3 ? X3E X3'];
      subst; rewrite <-X3' in *; clear X3 X3'.
    inversion FX3 as [| x3' ? FX3E TMP1 TMP2];
      subst; rename b into fx3; clear TMP2 FX3.

    pose proof (X 4) as X4.
    pose proof (FX 4) as FX4.
    mem_lookup_simpl.
    inversion X4 as [| x4 ? X4E X4'];
      subst; rewrite <-X4' in *; clear X4 X4'.
    inversion FX4 as [| x4' ? FX4E TMP1 TMP2];
      subst; rename b into fx4; clear TMP2 FX4.

    clear X FX.

    unfold RHCOLtoFHCOL.heq_CType', RF_CHE in *.
    destruct FA0E as [FA0F FA0].
    destruct FA1E as [FA1F FA1].
    destruct FA2E as [FA2F FA2].
    destruct FX0E as [FX0F FX0].
    destruct FX1E as [FX1F FX1].
    destruct FX2E as [FX2F FX2].
    destruct FX3E as [FX3F FX3].
    destruct FX4E as [FX4F FX4].
    destruct A0E as [A0F A0].
    destruct A1E as [A1F A1].
    destruct A2E as [A2F A2].
    destruct X0E as [X0F X0].
    destruct X1E as [X1F X1].
    destruct X2E as [X2F X2].
    destruct X3E as [X3F X3].
    destruct X4E as [X4F X4].
    subst.

    intros F.
    rewrite float_as_bool_Zless in F; apply R_as_bool_Zless.

    eapply DynWin_numerical_stability.
    eapply VC.
    eapply bC.
    eapply AC.
    eapply eC.
    eapply vC.
    eapply rxC.
    eapply ryC.
    eapply oxC.
    eapply oyC.
    all: assumption.
  Qed.

End DynWin_Symbolic.

(*
  Translation validation proof of semantic preservation
  of successful translation of [dynwin_orig] into FHCOL program.

  Using following definitons from DynWin.v:
   1. dynwin_i
   2. dynwin_o
   3. dynwin_orig

   And the following definition are produced with TemplateCoq:
   1. dynwin_RHCOL
 *)
Theorem HCOL_to_FHCOL_Correctness (a: vector CarrierA 3):
  forall x y,
    (* evaluatoion of original operator *)
    dynwin_orig a x = y ->

    forall dynwin_F_memory dynwin_F_σ (dynwin_FHCOL:FHCOL.DSHOperator),
      (* Compile -> RHCOL -> FHCOL *)
      RHCOLtoFHCOL.translate DynWin_RHCOL = inr dynwin_FHCOL ->

      (* Equivalent inputs *)
      RHCOLtoFHCOL.heq_memory () RF_CHE (dynwin_R_memory a x) dynwin_F_memory ->
      RHCOLtoFHCOL.heq_evalContext () RF_NHE RF_CHE dynwin_R_σ dynwin_F_σ ->

      forall a_rmem x_rmem,
        RHCOLEval.memory_lookup (dynwin_R_memory a x) dynwin_a_addr = Some a_rmem ->
        RHCOLEval.memory_lookup (dynwin_R_memory a x) dynwin_x_addr = Some x_rmem ->
        DynWinInConstr a_rmem x_rmem ->

        (* Everything correct on Reals *)
        exists r_omemory y_rmem,
          RHCOLEval.evalDSHOperator
            dynwin_R_σ
            DynWin_RHCOL
            (dynwin_R_memory a x)
            (RHCOLEval.estimateFuel DynWin_RHCOL) = Some (inr r_omemory)
          /\ RHCOLEval.memory_lookup r_omemory dynwin_y_addr = Some y_rmem
          /\ ctvector_to_mem_block y = y_rmem

          (* And floats *)
          /\ exists f_omemory y_fmem,
            FHCOLEval.evalDSHOperator
              dynwin_F_σ dynwin_FHCOL
              dynwin_F_memory
              (FHCOLEval.estimateFuel dynwin_FHCOL) = (Some (inr f_omemory))
            /\ FHCOLEval.memory_lookup f_omemory dynwin_y_addr = Some y_fmem
            /\ DynWinOutRel a_rmem x_rmem y_rmem y_fmem.
Proof.
  intros * HC * CR CRM CRE * RA RX INCONSTR.

  remember (RHCOLEval.memory_set
              (dynwin_R_memory a x)
              dynwin_y_addr
              (ctvector_to_mem_block y)) as r_omemory eqn:ROM.

  assert(RHCOLEval.evalDSHOperator
           dynwin_R_σ
           DynWin_RHCOL
           (dynwin_R_memory a x)
           (RHCOLEval.estimateFuel DynWin_RHCOL) = Some (inr r_omemory)) as RO.
  {
    pose proof (DynWin_MSH_DSH_compat a) as MRHCOL.
    pose proof (DynWin_pure) as MAPURE.
    pose proof (dynwin_SHCOL_MSHCOL_compat a) as MCOMP.
    pose proof (SHCOL_to_SHCOL1_Rewriting a) as SH1.
    pose proof (DynWinSigmaHCOL_Value_Correctness a) as HSH.
    pose proof (DynWinHCOL a x x) as HH.
    autospecialize HH; [reflexivity|].
    rewrite HC in HH. clear HC.

    (* moved from [dynwin_orig] to [dynwin_HCOL] *)

    remember (sparsify Monoid_RthetaFlags x) as sx eqn:SX.
    remember (sparsify Monoid_RthetaFlags y) as sy eqn:SY.
    assert(SHY: op _ (dynwin_SHCOL a) sx = sy).
    {
      subst sy.
      rewrite_clear HH.

      specialize (HSH sx sx).
      autospecialize HSH; [reflexivity|].
      rewrite <- HSH. clear HSH.
      unfold liftM_HOperator.
      Opaque dynwin_HCOL equiv.
      cbn.
      unfold SigmaHCOLImpl.liftM_HOperator_impl.
      unfold Basics.compose.
      f_equiv.
      subst sx.
      rewrite densify_sparsify.
      reflexivity.
    }
    Transparent dynwin_HCOL equiv.
    clear HH HSH.

    (* moved from [dynwin_HCOL] to [dynwin_SHCOL] *)

    assert(SH1Y: op _ (dynwin_SHCOL1 a) sx = sy).
    {
      rewrite <- SHY. clear SHY.
      destruct SH1.
      rewrite H.
      reflexivity.
    }
    clear SHY SH1.

    (* moved from [dynwin_SHCOL] to [dynwin_SHCOL1] *)

    assert(M1: mem_op (dynwin_MSHCOL1 a) (svector_to_mem_block Monoid_RthetaFlags sx) = Some (svector_to_mem_block Monoid_RthetaFlags sy)).
    {
      cut(Some (svector_to_mem_block Monoid_RthetaFlags (op Monoid_RthetaFlags (dynwin_SHCOL1 a) sx)) = mem_op (dynwin_MSHCOL1 a) (svector_to_mem_block Monoid_RthetaFlags sx)).
      {
        intros M0.
        rewrite <- M0. clear M0.
        apply Some_proper.

        cut(svector_is_dense _ (op Monoid_RthetaFlags (dynwin_SHCOL1 a) sx)).
        intros YD.

        apply svector_to_mem_block_dense_kind_of_proper.
        apply YD.

        subst sy.
        apply sparsify_is_dense.
        typeclasses eauto.

        apply SH1Y.

        {
          pose proof (@out_as_range _ _ _ _ _ _ (DynWinSigmaHCOL1_Facts a)) as D.
          specialize (D sx).

          autospecialize D.
          {
            intros j jc H.
            destruct (dynwin_SHCOL1 a).
            cbn in H.
            subst sx.
            rewrite Vnth_sparsify.
            apply Is_Val_mkValue.
          }

              unfold svector_is_dense.
          apply Vforall_nth_intro.
          intros i ip.
          apply D.
          cbn.
          constructor.
        }
      }
      {
        destruct MCOMP.
        apply mem_vec_preservation.
        cut(svector_is_dense Monoid_RthetaFlags (sparsify _ x)).
        intros SD.
        unfold svector_is_dense in SD.
        intros j jc H.
        apply (Vforall_nth jc) in SD.
        subst sx.
        apply SD.
        apply sparsify_is_dense.
        typeclasses eauto.
      }
    }
    clear SH1Y MCOMP.

    (* moved from [dynwin_SHCOL1] to [dynwin_MSHCOL1] *)

    remember (svector_to_mem_block Monoid_RthetaFlags sx) as mx eqn:MX.
    remember (svector_to_mem_block Monoid_RthetaFlags sy) as my eqn:MY.

    specialize (MRHCOL x).
    destruct MRHCOL as [MRHCOL].
    specialize (MRHCOL (ctvector_to_mem_block x) RHCOLEval.mem_empty).
    autospecialize MRHCOL.
    reflexivity.
    autospecialize MRHCOL.
    reflexivity.

    destruct_h_opt_opterr_c MM AE.
    -
      destruct s; inversion_clear MRHCOL.
      f_equiv; f_equiv.
      rename m0 into m'.
      destruct (lookup_PExpr dynwin_R_σ m' DSH_y_p) eqn:RY.
      +
        exfalso.
        clear - MAPURE AE RY.
        cbn in RY.
        assert (RHCOL.mem_block_exists 1 m').
        {
          erewrite <-mem_stable.
          2: now rewrite AE.
          now apply RHCOLEval.memory_is_set_is_Some.
        }
        apply RHCOLEval.memory_is_set_is_Some in H.
        unfold util.is_Some, RHCOLEval.memory_lookup_err in *.
        break_match; try contradiction.
        inv RY.
      +
        inversion_clear H.
        rename m into ym.
        rename m0 into ym'.
        subst.
        destruct (dynwin_MSHCOL1 a).
        rewrite 2!svector_to_mem_block_ctvector_to_mem_block
          in M1
            by typeclasses eauto.
        Opaque ctvector_to_mem_block.
        cbn in M1, MM.
        rewrite MM in M1.
        clear MM.
        some_inv.
        Transparent ctvector_to_mem_block.

        rewrite <-M1.
        assert (YM : ym = ym').
        {
          clear - H0.
          intros k.
          specialize (H0 k).
          cbn in H0.
          unfold RHCOL.mem_lookup in *.
          inv H0.
          -
            unfold util.is_None in *.
            now break_match.
          -
            symmetry; assumption.
        }
        rewrite YM.

        clear - AE RY MAPURE.
        destruct MAPURE as [_ MWS].
        cbn; cbn in RY.
        eapply memory_equiv_except_memory_set_inv.
        eapply MWS.
        now erewrite AE.
        now cbv.
        eapply RHCOLEval.memory_lookup_err_inr_Some.
        now rewrite RY.
    -
      exfalso.
      pose proof (@RHCOLEval.evalDSHOperator_estimateFuel dynwin_R_σ DynWin_RHCOL (dynwin_R_memory a x)) as CC.
      clear - CC AE.
      apply util.is_None_def in AE.
      generalize dependent (RHCOLEval.evalDSHOperator dynwin_R_σ DynWin_RHCOL
                                                      (dynwin_R_memory a x) (RHCOLEval.estimateFuel DynWin_RHCOL)).
      intros o AE CC.
      some_none.
    -
      exfalso.
      remember (dynwin_MSHCOL1 a) as m.
      destruct m.
      subst sx mx.
      rewrite svector_to_mem_block_ctvector_to_mem_block in M1.
      eq_to_equiv.
      some_none.
      typeclasses eauto.
    -
      exfalso.
      remember (dynwin_MSHCOL1 a) as m.
      destruct m.
      subst sx mx.
      rewrite svector_to_mem_block_ctvector_to_mem_block in M1.
      eq_to_equiv.
      some_none.
      typeclasses eauto.
  }

  (* moved from [dynwin_MSHCOL1] to [dynwin_rhcol] *)

  generalize dependent (ctvector_to_mem_block y).
  intros y_rmem R_OMEM.

  exists r_omemory.
  exists y_rmem.

  split; [assumption |].
  split.
  1: {
    rewrite R_OMEM.
    now rewrite memory_lookup_memory_set_eq by reflexivity.
  }
  split; [reflexivity |].

  pose proof
       RF_Structural_Semantic_Preservation
       DynWin_RHCOL
       dynwin_FHCOL
       (RHCOLEval.estimateFuel DynWin_RHCOL)
       (FHCOLEval.estimateFuel dynwin_FHCOL)
       dynwin_R_σ
       dynwin_F_σ
       (dynwin_R_memory a x)
       dynwin_F_memory
    as HEQRF.
  full_autospecialize HEQRF.
  {
    eapply RHCOLtoFHCOL.translation_syntax_always_correct.
    eapply RF_NTP.
    assumption.
  }
  {
    clear - CRE.
    induction CRE.
    -
      constructor.
    -
      constructor;
        [| apply IHCRE].
      unfold RHCOLtoFHCOL.heq_evalContextElem in *.
      repeat break_let; subst.
      repeat constructor.
      intuition.
      destruct H as [_ D].
      invc D; repeat constructor; assumption.
  }
  {
    clear - CRM.
    generalize dependent (dynwin_R_memory a x).
    clear.
    intros dynwin_R_memory M.

    intros k.
    specialize (M k).
    invc M; constructor.

    intros k'.
    specialize (H1 k').
    invc H1; constructor.
    constructor.
  }
  {
    eapply @RHCOLtoFHCOL_NExpr_closure_trace_equiv.
    assumption.
    clear - CRE.
    eapply CRE.
  }

  subst r_omemory.
  destruct RHCOLEval.evalDSHOperator as [[e | r_omemory] |] eqn:RE in *;
    try some_none; repeat some_inv;
    try inl_inr; repeat inl_inr_inv.

  invc HEQRF; invc H1.
  rename b0 into f_omemory, H0 into F_EVAL, H2 into RF_OM.
  symmetry in RO, F_EVAL.

  exists f_omemory.

  unfold RHCOLEval.memory_set in RE.
  pose proof RF_OM as RF_YO.
  pose proof RO as R_YO.
  specialize (RF_YO dynwin_y_addr).
  specialize (R_YO dynwin_y_addr).
  unfold RHCOLEval.memory_set, RHCOLEval.memory_lookup in *.
  rewrite Memory.NP.F.add_eq_o in R_YO by reflexivity.

  invc RF_YO;
    [rewrite <-H0 in *; some_none |].
  rename b into y_fmem, H0 into Y_FMEM.
  rename a0 into y_rmem', H into Y_RMEM'.
  rename H1 into Y_RFE.
  symmetry in Y_RMEM', Y_FMEM.

  exists y_fmem.
  do 2 (split; [reflexivity |]).

  (* get rid of duplicate [y_rmem] *)
  rewrite Y_RMEM' in *.
  some_inv.
  rewrite R_YO.
  clear RO R_YO y_rmem.
  rename y_rmem' into y_rmem, Y_RMEM' into Y_RMEM.

  clear y HC.

  subst.

  eapply RHCOL_to_FHCOL_numerical_correct;
    try eassumption.
  now rewrite RE.
  now rewrite <-Y_RMEM.
  now rewrite F_EVAL.
  now rewrite <-Y_FMEM.
Qed.


From Coq Require Export List.
From Coq Require Export Lia.
From Coq Require Export Arith.Compare_dec.
From Coq Require Export Arith.

From Classes Require Export Classes.
Require Export Helpers.RelationAlgebra.
Require Export Tactical.ProofAutomation.

Require Export Spec.Proc.
Require Export Spec.ProcTheorems.
Require Export Spec.Hoare.
Require Export Spec.Abstraction.
Require Export Spec.AbstractionSpec.
Require Export Spec.Layer.

Export ProcNotations.

(* require proofs to be strictly bulleted (with only one goal focused at a
time) *)
Global Set Default Goal Selector "!".


(** * Compute a list of liveness values for each binding *)
Require Import Coq.Lists.List.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.CountLets.
Require Import Crypto.Util.ListUtil.

Local Notation eta x := (fst x, snd x).

Local Open Scope ctype_scope.
Delimit Scope nexpr_scope with nexpr.

Inductive liveness := live | dead.
Fixpoint merge_liveness (ls1 ls2 : list liveness) :=
  match ls1, ls2 with
  | cons x xs, cons y ys
    => cons match x, y with
            | live, _
            | _, live
              => live
            | dead, dead
              => dead
            end
            (@merge_liveness xs ys)
  | nil, ls
  | ls, nil
    => ls
  end.

Section language.
  Context (base_type_code : Type)
          (interp_base_type : base_type_code -> Type)
          (op : flat_type base_type_code -> flat_type base_type_code -> Type).

  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).
  Let Tbase := @Tbase base_type_code.
  Local Coercion Tbase : base_type_code >-> Syntax.flat_type.
  Local Notation interp_type := (interp_type interp_base_type).
  Local Notation interp_flat_type := (interp_flat_type_gen interp_base_type).
  Local Notation exprf := (@exprf base_type_code interp_base_type op).
  Local Notation expr := (@expr base_type_code interp_base_type op).

  Section internal.
    Context (Name : Type)
            (OutName : Type)
            {Context : Context Name (fun _ : base_type_code => list liveness)}.

    Definition compute_livenessf_step
               (compute_livenessf : forall (ctx : Context) {t} (e : exprf Name t) (prefix : list liveness), list liveness)
               (ctx : Context)
               {t} (e : exprf Name t) (prefix : list liveness)
      : list liveness
      := match e with
         | Const _ x => prefix
         | Var t' name => match lookup ctx t' name with
                          | Some ls => ls
                          | _ => nil
                          end
         | Op _ _ op args
           => @compute_livenessf ctx _ args prefix
         | LetIn tx n ex _ eC
           => let lx := @compute_livenessf ctx _ ex prefix in
              let lx := merge_liveness lx (prefix ++ repeat live (count_pairs tx)) in
              let ctx := extend ctx n (SmartVal _ (fun _ => lx) tx) in
              @compute_livenessf ctx _ eC (prefix ++ repeat dead (count_pairs tx))
         | Pair _ ex _ ey
           => merge_liveness (@compute_livenessf ctx _ ex prefix)
                             (@compute_livenessf ctx _ ey prefix)
         end.

    Fixpoint compute_livenessf ctx {t} e prefix
      := @compute_livenessf_step (@compute_livenessf) ctx t e prefix.

    Fixpoint compute_liveness (ctx : Context)
             {t} (e : expr Name t) (prefix : list liveness)
      : list liveness
      := match e with
         | Return _ x => compute_livenessf ctx x prefix
         | Abs src _ n f
           => let prefix := prefix ++ (live::nil) in
              let ctx := extendb (t:=src) ctx n prefix in
              @compute_liveness ctx _ f prefix
         end.

    Section insert_dead.
      Context (default_out : option OutName).

      Fixpoint insert_dead_names_gen (ls : list liveness) (lsn : list OutName)
        : list (option OutName)
        := match ls with
           | nil => nil
           | cons live xs
             => match lsn with
                | cons n lsn' => Some n :: @insert_dead_names_gen xs lsn'
                | nil => default_out :: @insert_dead_names_gen xs nil
                end
           | cons dead xs
             => None :: @insert_dead_names_gen xs lsn
           end.
      Definition insert_dead_names {t} (e : expr Name t)
        := insert_dead_names_gen (compute_liveness empty e nil).
    End insert_dead.
  End internal.
End language.

Global Arguments compute_livenessf {_ _ _ _ _} ctx {t} e prefix.
Global Arguments compute_liveness {_ _ _ _ _} ctx {t} e prefix.
Global Arguments insert_dead_names {_ _ _ _ _ _} default_out {t} e lsn.


(** * General-purpose definitions *)

(** Not specific to itrees. *)

(* begin hide *)
From Coq Require
     Ensembles.

From Coq Require Import
     RelationClasses.

From ExtLib Require Import
     Structures.Functor
     Structures.Monad
     Data.Monads.StateMonad
     Data.Monads.ReaderMonad
     Data.Monads.OptionMonad
     Data.Monads.EitherMonad.

Import
  FunctorNotation
  MonadNotation.
Local Open Scope monad.
(* end hide *)

(** ** Parametric functions *)

(** A notation for a certain class of parametric functions.
    Some common names of things that can be represented by such a type:

    - Natural transformations (functor morphisms)
    - Monad morphisms
    - Event morphisms (if [E] and [F] are simply
      indexed types with no particular structure)
    - Event handlers (if [F] is a monad)
 *)
Notation "E ~> F" := (forall T, E T -> F T)
  (at level 99, right associativity, only parsing) : type_scope.
(* The same level as [->]. *)
(* This might actually not be such a good idea. *)

(** Identity morphism. *)
Definition idM {E : Type -> Type} : E ~> E := fun _ e => e.

(** [void] is a shorthand for [Empty_set]. *)
Notation void := Empty_set.

(** ** Common monads and transformers. *)

Module Monads.

Definition identity (a : Type) : Type := a.

Definition stateT (s : Type) (m : Type -> Type) (a : Type) : Type :=
  s -> m (prod s a).
Definition state (s a : Type) := s -> prod s a.

Definition run_stateT {s m a} (x : stateT s m a) : s -> m (s * a)%type := x.

Definition liftState {s a f} `{Functor f} (fa : f a) : Monads.stateT s f a :=
  fun s => pair s <$> fa.

Definition readerT (r : Type) (m : Type -> Type) (a : Type) : Type :=
  r -> m a.
Definition reader (r a : Type) := r -> a.

Definition writerT (w : Type) (m : Type -> Type) (a : Type) : Type :=
  m (prod w a).
Definition writer := prod.

#[global] Instance Functor_stateT {m s} {Fm : Functor m} : Functor (stateT s m)
  := {|
    fmap _ _ f := fun run s => fmap (fun sa => (fst sa, f (snd sa))) (run s)
    |}.

#[global] Instance Monad_stateT {m s} {Fm : Monad m} : Monad (stateT s m)
  := {|
    ret _ a := fun s => ret (s, a)
  ; bind _ _ t k := fun s =>
      sa <- t s ;;
      k (snd sa) (fst sa)
    |}.

End Monads.

(** ** Loop operator *)

(** [iter]: A primitive for general recursion.
    Iterate a function updating an accumulator [I], until it produces
    an output [R].
 *)
Polymorphic Class MonadIter (M : Type -> Type) : Type :=
  iter : forall {R I: Type}, (I -> M (I + R)%type) -> I -> M R.

(** *** Transformer instances *)

(** And the standard transformers can lift [iter].

    Quite easily in fact, no [Monad] assumption needed.
 *)

#[global] Instance MonadIter_stateT {M S} {MM : Monad M} {AM : MonadIter M}
  : MonadIter (stateT S M) :=
  fun _ _ step i => mkStateT (fun s =>
    iter (fun is =>
      let i := fst is in
      let s := snd is in
      is' <- runStateT (step i) s ;;
      ret match fst is' with
          | inl i' => inl (i', snd is')
          | inr r => inr (r, snd is')
          end) (i, s)).

#[global] Polymorphic Instance MonadIter_stateT0 {M S} {MM : Monad M} {AM : MonadIter M}
  : MonadIter (Monads.stateT S M) :=
  fun _ _ step i s =>
    iter (fun si =>
      let s := fst si in
      let i := snd si in
      si' <- step i s;;
      ret match snd si' with
          | inl i' => inl (fst si', i')
          | inr r => inr (fst si', r)
          end) (s, i).

#[global] Instance MonadIter_readerT {M S} {AM : MonadIter M} : MonadIter (readerT S M) :=
  fun _ _ step i => mkReaderT (fun s =>
    iter (fun i => runReaderT (step i) s) i).

#[global] Instance MonadIter_optionT {M} {MM : Monad M} {AM : MonadIter M}
  : MonadIter (optionT M) :=
  fun _ _ step i => mkOptionT (
    iter (fun i =>
      oi <- unOptionT (step i) ;;
      ret match oi with
          | None => inr None
          | Some (inl i) => inl i
          | Some (inr r) => inr (Some r)
          end) i).

#[global] Instance MonadIter_eitherT {M E} {MM : Monad M} {AM : MonadIter M}
  : MonadIter (eitherT E M) :=
  fun _ _ step i => mkEitherT (
    iter (fun i =>
      ei <- unEitherT (step i) ;;
      ret match ei with
          | inl e => inr (inl e)
          | inr (inl i) => inl i
          | inr (inr r) => inr (inr r)
          end) i).

(** And the nondeterminism monad [_ -> Prop] also has one. *)

Inductive iter_Prop {R I : Type} (step : I -> I + R -> Prop) (i : I) (r : R)
  : Prop :=
| iter_done
  : step i (inr r) -> iter_Prop step i r
| iter_step i'
  : step i (inl i') ->
    iter_Prop step i' r ->
    iter_Prop step i r
.

#[global] Polymorphic Instance MonadIter_Prop : MonadIter Ensembles.Ensemble := @iter_Prop.

(* Elementary constructs for predicates. To be moved in their own file eventually *)
Definition equiv_pred {A : Type} (R S: A -> Prop): Prop :=
  forall a, R a <-> S a.

Definition sum_pred {A B : Type} (PA : A -> Prop) (PB : B -> Prop) : A + B -> Prop :=
  fun x => match x with | inl a => PA a | inr b => PB b end.

Definition prod_pred {A B : Type} (PA : A -> Prop) (PB : B -> Prop) : A * B -> Prop :=
  fun '(a,b) => PA a /\ PB b.

Definition TT {A : Type} : A -> Prop := fun _ => True.
Global Hint Unfold TT sum_pred prod_pred: core.

#[global] Instance equiv_pred_refl  {A} : Reflexive (@equiv_pred A).
Proof.
  split; auto.
Qed.
#[global] Instance equiv_pred_symm  {A} : Symmetric (@equiv_pred A).
Proof.
  red; intros * EQ; split; intros; eapply EQ; auto.
Qed.
#[global] Instance equiv_pred_trans {A} : Transitive (@equiv_pred A).
Proof.
  red; intros * EQ1 EQ2; split; intros; (apply EQ1,EQ2 || apply EQ2,EQ1); auto.
Qed.
#[global] Instance equiv_pred_equiv {A} : Equivalence (@equiv_pred A).
Proof.
  split; typeclasses eauto.
Qed.


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 conj20synthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv0 lv1)).
Admitted.
QuickChick conj20synthconj5.


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 Oprime Aprime Bprime Cprime Eprimeprime Bprimeprime C2 C3 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ Bprimeprime O /\ (wd_ Bprime Oprime /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ C Bprimeprime /\ (wd_ Cprime C3 /\ (wd_ B Bprimeprime /\ (wd_ Bprime C3 /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ O Eprimeprime C3 /\ col_ O A C)))))))))))))))))))))))))))))))))))) -> col_ Oprime C2 C3)).
Proof.
  time tac.
Qed.

End FOFProblem.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

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

(* Why3 assumption *)
Inductive mode :=
  | NearestTiesToEven : mode
  | ToZero : mode
  | Up : mode
  | Down : mode
  | NearestTiesToAway : mode.
Axiom mode_WhyType : WhyType mode.
Existing Instance mode_WhyType.


Require Import Bool.
Require Import RelationClasses.
Require Import Program.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.

From PromisingLib Require Import Event.
Require Import List.

Require Import Sequential.
Require Import OracleFacts.

Require Import SeqAux.
Require Import SimAux.
Require Import SeqAux.

Set Implicit Arguments.

Module SeqTrace.
  Variant result: Type :=
  | term (v: ValueMap.t) (f: Flags.t)
  | partial (f: Flags.t)
  | ub
  .

  Definition t: Type := list (ProgramEvent.t * SeqEvent.input * Oracle.output) * result.

  Inductive le: Flags.t -> t -> t -> Prop :=
  | le_term
      d v_src v_tgt f_src f_tgt
      (VAL: ValueMap.le v_tgt v_src)
      (FLAG: Flags.le (Flags.join d f_tgt) f_src)
    :
      le d ([], term v_tgt f_tgt) ([], term v_src f_src)
  | le_partial
      d tr_src f_src f_tgt w
      (TRACE: SeqThread.writing_trace tr_src w)
      (FLAG: Flags.le (Flags.join d f_tgt) (Flags.join w f_src))
    :
      le d ([], partial f_tgt) (tr_src, partial f_src)
  | le_ub
      d tr_src tr_tgt w
      (TRACE: SeqThread.writing_trace tr_src w)
    :
      le d tr_tgt (tr_src, ub)
  | le_cons
      d0 d1 e_src e_tgt i_src i_tgt o tr_src tr_tgt r_src r_tgt
      (LE: le d1 (tr_tgt, r_tgt) (tr_src, r_src))
      (MATCH: SeqEvent.input_match d0 d1 i_src i_tgt)
      (EVENT: ProgramEvent.le e_tgt e_src)
    :
      le d0 ((e_tgt, i_tgt, o)::tr_tgt, r_tgt) ((e_src, i_src, o)::tr_src, r_src)
  .

  Lemma le_deferred_mon d0 d1 tr0 tr1
        (DEFERRED: Flags.le d0 d1)
        (LE: le d1 tr0 tr1)
    :
      le d0 tr0 tr1.
  Proof.
    induction LE.
    { econs 1; eauto. etrans; eauto.
      eapply Flags.join_mon_l. eauto. }
    { econs 2; eauto.
      etrans; eauto. eapply Flags.join_mon_l; eauto.
    }
    { econs 3; eauto. }
    { econs 4.
      { eauto. }
      { eapply SeqEvent.input_match_mon; eauto. refl. }
      { eauto. }
    }
  Qed.

  Definition incl (b0: t -> Prop) (b1: t -> Prop): Prop :=
    forall tr0, b0 tr0 -> exists tr1, b1 tr1 /\ le Flags.bot tr0 tr1.
End SeqTrace.

Module SeqBehavior.
Section LANG.
  Variable lang: language.
  Variable state_step:
    Perms.t -> MachineEvent.t -> SeqState.t lang -> SeqState.t lang -> Prop.

  Inductive behavior: forall (th0: SeqThread.t lang) (tr: SeqTrace.t), Prop :=
  | behavior_term
      st v f p o
      (TERMINAL: lang.(Language.is_terminal) st)
    :
      behavior (SeqThread.mk (SeqState.mk _ st (SeqMemory.mk v f)) p o) ([], SeqTrace.term v f)
  | behavior_partial
      st v f p o
    :
      behavior (SeqThread.mk (SeqState.mk _ st (SeqMemory.mk v f)) p o) ([], SeqTrace.partial f)
  | behavior_ub
      st m p o
      (FAILURE: SeqThread.failure state_step (SeqThread.mk (SeqState.mk _ st m) p o))
    :
      behavior (SeqThread.mk (SeqState.mk _ st m) p o) ([], SeqTrace.ub)
  | behavior_na_step
      th0 th1 tr
      (STEP: SeqThread.na_step state_step MachineEvent.silent th0 th1)
      (BEHAVIOR: behavior th1 tr)
    :
      behavior th0 tr
  | behavior_at_step
      e i o th0 th1 es st
      (STEP: SeqThread.at_step e i o th0 th1)
      (BEHAVIOR: behavior th1 (es, st))
    :
      behavior th0 ((e, i, o)::es, st)
  .
End LANG.

Definition refine
           (lang_tgt lang_src: language)
           (st_tgt: lang_tgt.(Language.state)) (st_src: lang_src.(Language.state))
  : Prop :=
  forall p m o (WF: Oracle.wf o),
    SeqTrace.incl
      (behavior (@SeqState.na_step _) (SeqThread.mk (SeqState.mk _ st_tgt m) p o))
      (behavior (@SeqState.na_step _) (SeqThread.mk (SeqState.mk _ st_src m) p o)).
End SeqBehavior.

Section DETERMINISM.
  Variable lang: language.

  Definition similar (e0 e1: ProgramEvent.t): Prop :=
    match e0, e1 with
    | ProgramEvent.read loc0 val0 ord0, ProgramEvent.read loc1 val1 ord1 =>
      loc0 = loc1 /\ ord0 = ord1
    | ProgramEvent.write loc0 val0 ord0, ProgramEvent.write loc1 val1 ord1 =>
      loc0 = loc1 /\ ord0 = ord1 /\ val0 = val1
    | ProgramEvent.update loc0 valr0 valw0 ordr0 ordw0, ProgramEvent.update loc1 valr1 valw1 ordr1 ordw1 =>
      loc0 = loc1 /\ ordr0 = ordr1 /\ ordw0 = ordw1 /\ (valr0 = valr1 -> valw0 = valw1)
    | ProgramEvent.read loc0 val0 ord0, ProgramEvent.update loc1 valr1 valw1 ordr1 ordw1 =>
      loc0 = loc1 /\ ord0 = ordr1 /\ val0 <> valr1
    | ProgramEvent.update loc0 valr0 valw0 ordr0 ordw0, ProgramEvent.read loc1 val1 ord1 =>
      loc0 = loc1 /\ ordr0 = ord1 /\ valr0 <> val1
    | ProgramEvent.fence ordr0 ordw0, ProgramEvent.fence ordr1 ordw1 =>
      ordr0 = ordr1 /\ ordw0 = ordw1
    | _, _ => e0 = e1
    end.

  Lemma similar_le_eq
        e1 e2 e
        (SIMILAR: similar e1 e2)
        (LE1: ProgramEvent.le e e1)
        (LE2: ProgramEvent.le e e2):
    e1 = e2.
  Proof.
    destruct e1, e2, e; ss.
    - inv LE1. inv LE2. ss.
    - des. subst. ss.
    - des. subst. exploit SIMILAR2; eauto. i. subst. ss.
    - inv LE1. inv LE2. ss.
  Qed.

  Variant _deterministic (deterministic: lang.(Language.state) -> Prop) (st0: lang.(Language.state)): Prop :=
  | deterministic_intro
      (PRESERVE:
         forall e st1 (STEP: lang.(Language.step) e st0 st1),
           deterministic st1)
      (STEP_TERMINAL:
         forall e st1 (STEP: lang.(Language.step) e st0 st1)
                (TERMINAL: lang.(Language.is_terminal) st0), False)
      (STEP_STEP:
         forall e1 st1 (STEP1: lang.(Language.step) e1 st0 st1)
                e2 st2 (STEP2: lang.(Language.step) e2 st0 st2),
           similar e1 e2 /\ (e1 = e2 -> st1 = st2))
      (NO_NA_UPDATE:
         forall loc valr valw ordr ordw st1
           (STEP: lang.(Language.step) (ProgramEvent.update loc valr valw ordr ordw) st0 st1),
           Ordering.le Ordering.plain ordr /\ Ordering.le Ordering.plain ordw)
  .

  Lemma deterministic_mon: monotone1 _deterministic.
  Proof.
    ii. inv IN. econs; eauto.
  Qed.
  Hint Resolve deterministic_mon: paco.

  Definition deterministic := paco1 _deterministic bot1.
End DETERMINISM.
#[export] Hint Resolve deterministic_mon: paco.

Lemma deterministic_step
      lang e1 e2 st st1 st2
      (DETERM: deterministic lang st)
      (STEP1: lang.(Language.step) e1 st st1)
      (STEP2: lang.(Language.step) e2 st st2):
  similar e1 e2 /\ (e1 = e2 -> st1 = st2).
Proof.
  punfold DETERM. inv DETERM. eauto.
Qed.

Lemma deterministic_terminal
      lang e st1 st2
      (DETERM: deterministic lang st1)
      (STEP: lang.(Language.step) e st1 st2)
      (TERMINAL: lang.(Language.is_terminal) st1):
  False.
Proof.
  punfold DETERM. inv DETERM. eauto.
Qed.

Lemma step_deterministic
      lang e st0 st1
      (DETERM: deterministic lang st0)
      (STEP: lang.(Language.step) e st0 st1):
  deterministic lang st1.
Proof.
  punfold DETERM. inv DETERM.
  exploit PRESERVE; eauto. intros x. inv x; done.
Qed.

Definition monotone_read_state lang (st: lang.(Language.state)): Prop :=
  forall p m o (WF: Oracle.wf o),
    SeqBehavior.behavior (@SeqState.na_step _) (SeqThread.mk (SeqState.mk _ st m) p o) <1= SeqBehavior.behavior (@SeqState.na_step_determ _) (SeqThread.mk (SeqState.mk _ st m) p o).

Section RECEPTIVE.
  Variable lang: language.

  Variant _receptive (receptive: lang.(Language.state) -> Prop) (st0: lang.(Language.state)): Prop :=
  | receptive_intro
      (PRESERVE:
         forall e st1 (STEP: lang.(Language.step) e st0 st1),
           receptive st1)
      (READ:
         forall loc val ord st1
           (STEP: lang.(Language.step) (ProgramEvent.read loc val ord) st0 st1),
         forall val',
           (exists st1', lang.(Language.step) (ProgramEvent.read loc val' ord) st0 st1') \/
           (exists valw ordw st1',
               lang.(Language.step) (ProgramEvent.update loc val' valw ord ordw) st0 st1'))
      (UPDATE:
         forall loc valr valw ordr ordw st1
           (STEP: lang.(Language.step) (ProgramEvent.update loc valr valw ordr ordw) st0 st1),
         forall val',
           (exists st1', lang.(Language.step) (ProgramEvent.read loc val' ordr) st0 st1') \/
           (exists valw' st1',
               lang.(Language.step) (ProgramEvent.update loc val' valw' ordr ordw) st0 st1'))
      (NO_NA_UPDATE:
         forall loc valr valw ordr ordw st1
           (STEP: lang.(Language.step) (ProgramEvent.update loc valr valw ordr ordw) st0 st1),
           Ordering.le Ordering.plain ordr /\ Ordering.le Ordering.plain ordw)
  .

  Lemma receptive_mon: monotone1 _receptive.
  Proof.
    ii. inv IN. econs; eauto.
  Qed.
  Hint Resolve receptive_mon: paco.

  Definition receptive := paco1 _receptive bot1.
End RECEPTIVE.
#[export] Hint Resolve receptive_mon: paco.

Definition wsimilar (e0 e1: ProgramEvent.t): Prop :=
  match e0, e1 with
  | ProgramEvent.read loc0 val0 ord0, ProgramEvent.read loc1 val1 ord1 =>
    loc0 = loc1 /\ ord0 = ord1
  | ProgramEvent.write loc0 val0 ord0, ProgramEvent.write loc1 val1 ord1 =>
    loc0 = loc1 /\ ord0 = ord1 /\ val0 = val1
  | ProgramEvent.update loc0 valr0 valw0 ordr0 ordw0, ProgramEvent.update loc1 valr1 valw1 ordr1 ordw1 =>
    loc0 = loc1 /\ ordr0 = ordr1 /\ ordw0 = ordw1
  | ProgramEvent.read loc0 val0 ord0, ProgramEvent.update loc1 valr1 valw1 ordr1 ordw1 =>
    loc0 = loc1 /\ ord0 = ordr1
  | ProgramEvent.update loc0 valr0 valw0 ordr0 ordw0, ProgramEvent.read loc1 val1 ord1 =>
    loc0 = loc1 /\ ordr0 = ord1
  | ProgramEvent.fence ordr0 ordw0, ProgramEvent.fence ordr1 ordw1 =>
    ordr0 = ordr1 /\ ordw0 = ordw1
  | _, _ => e0 = e1
  end.

Lemma similar_wsimilar
      e1 e2
      (SIMILAR: similar e1 e2):
  wsimilar e1 e2.
Proof.
  destruct e1, e2; ss; des; subst; ss.
Qed.

Lemma receptive_oracle_progress
      lang e st1 st2
      orc1
      (RECEPTIVE: receptive _ st1)
      (ORACLE: Oracle.wf orc1)
      (STEP: lang.(Language.step) e st1 st2)
      (ATOMIC: is_atomic_event e):
  exists e' st2',
    (<<EVENT: wsimilar e e'>>) /\
    (<<STEP: lang.(Language.step) e' st1 st2'>>) /\
    (<<ATOMIC: is_atomic_event e'>>) /\
    (<<PROGRESS: Oracle.progress e' orc1>>).
Proof.
  punfold RECEPTIVE. inv RECEPTIVE.
  punfold ORACLE. inv ORACLE.
  destruct e; ss.
  - specialize (LOAD loc ord). des.
    exploit READ; eauto. i. des.
    + esplits; eauto. ss.
    + exploit NO_NA_UPDATE; eauto. i. des.
      esplits; eauto; ss.
      destruct ord, ordw; ss.
  - specialize (STORE loc ord val).
    esplits; try exact STORE; eauto. ss.
  - specialize (LOAD loc ordr). des.
    exploit UPDATE; eauto. i. des.
    + esplits; eauto. ss. destruct ordr; ss.
    + exploit NO_NA_UPDATE; eauto. i. des.
      esplits; eauto; ss.
  - specialize (FENCE ordr ordw).
    esplits; try exact FENCE; eauto. ss.
  - esplits; try apply SYSCALL; eauto.
Qed.

Lemma step_receptive
      lang e st1 st2
      (RECEPTIVE: receptive lang st1)
      (STEP: lang.(Language.step) e st1 st2):
  receptive _ st2.
Proof.
  punfold RECEPTIVE. inv RECEPTIVE.
  exploit PRESERVE; eauto. intros x. inv x; ss.
Qed.


Require Import QuickChick.

Class liftable (A B : Type) :=
  {
    lift_m : A -> B
  }.

Instance lift0 {A} : liftable (G A) (G A) :=
  {
    lift_m := id
  }.

Instance liftN {A B R} `(liftable (G B) R) : liftable (G (A -> B)) (G A -> R):=
   {
     lift_m f ga :=
       lift_m (liftGen2 id f ga)
   }.

Definition liftM {A B R} `{liftable (G B) R} (f : A -> B) (g : G A) : R :=
  lift_m (fmap f g).

Definition ex1 : G nat := liftM (fun x => x + 3) (returnGen 0).
Definition ex2 : G nat := liftM (fun x y => x + y) (returnGen 0) (returnGen 1).
Definition ex3 : G nat := liftM (fun x y z => x + y + z)
                                (returnGen 0) (returnGen 1) (returnGen 2).

(*
Eval cbv -[plus] in ex1.
(* = fmap (fun x : nat => x + 3) (returnGen 0) -- fair enough *)

Eval cbv -[plus] in ex2.
(* = liftGen2 id (fmap (fun x y : nat => x + y) (returnGen 0)) (returnGen 1)
where
fmap : (nat -> (nat -> nat)) -> G nat -> G (nat -> nat)
liftGen2 : ((nat -> nat) -> nat -> nat) ->
            (G (nat -> nat)) -> G nat -> G nat
 *)

Eval cbv -[plus] in ex3.
(* = liftGen2 (fun x : nat -> nat => x)
         (liftGen2 (fun x : nat -> nat -> nat => x)
            (fmap (fun x y z : nat => x + y + z) (returnGen 0))
            (returnGen 1)) (returnGen 2)
*)

(* this is not well typed ... wtf? *)
Check (liftM (fun x y => x + y + y) (returnGen 0) (returnGen 1) (returnGen 2)
  : G nat).

(* it's even worse ... all kinds of stuff are accepted in Check and Eval *)
Eval simpl in (liftM (fun x => x + 1) (returnGen 0) 0 0 : G nat).
*)
(*
liftM nat nat (nat -> nat -> G nat) `{liftable (G nat) (nat -> nat -> G nat)} ...
-- but we don't have such an instance!
We need to use definitions to get a type error
Definition xxx := (liftM (fun x => x + 1) (returnGen 0) 0 0 : G nat).
Toplevel input, characters 19-24:
Error: Cannot infer the implicit parameter H of
liftM.
Could not find an instance for "liftable (G nat) (nat -> nat -> G nat)".
*)


Require Import Lang.BindingsFacts.
Require Import Lang.Sig.
Require Import Lang.SigFacts.
Require Import Rel.Definitions.
Set Implicit Arguments.

Section section_compat_val.

Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).

Lemma compat_val_unit n :
n ⊨ ⟦ Ξ Γ ⊢ val_unit ≼ˡᵒᵍᵥ val_unit : 𝟙 ⟧.
Proof.
repeat iintro ; crush.
Qed.

Lemma compat_val_var n x :
n ⊨ ⟦ Ξ Γ ⊢ (val_var x) ≼ˡᵒᵍᵥ (val_var x) : (Γ x) ⟧.
Proof.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iespecialize Hγ ; apply Hγ.
Qed.

Lemma compat_val_md n m₁ m₂ σ X :
n ⊨ ⟦ Ξ Γ ⊢ m₁ ≼ˡᵒᵍₘ m₂ : σ ^ (lbl_id (lid_f X)) ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (val_md m₁ (lid_f X)) ≼ˡᵒᵍᵥ (val_md m₂ (lid_f X)) :
      ty_ms σ (lbl_id (lid_f X)) ⟧.
Proof.
intro H.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iespecialize H.
ispecialize H ; [ eassumption | ].
ispecialize H ; [ eassumption | ].
ispecialize H ; [ eassumption | ].
ispecialize H ; [ eassumption | ].
simpl 𝓥_Fun ; repeat ieexists ; repeat isplit.
* iintro_prop ; crush.
* iintro_prop ; crush.
* apply H.
Qed.

Lemma compat_val_fix n m₁ m₂ N X :
n ⊨ ▷ ⟦ Ξ (env_ext Γ (ty_it N (lbl_id (lid_f X)))) ⊢ m₁ ≼ˡᵒᵍₘ m₂ : (it_msig N) ^ (lbl_id (lid_f X)) ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (val_fix m₁ (lid_f X)) ≼ˡᵒᵍᵥ (val_fix m₂ (lid_f X)) :
      ty_it N (lbl_id (lid_f X)) ⟧.
Proof.
intro H.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
loeb_induction LöbIH.
apply I_later_forall_down in H ; ispecialize H ξ₁ ;
apply I_later_forall_down in H ; ispecialize H ξ₂.
apply I_later_forall_down in H ; ispecialize H δ₁ ;
apply I_later_forall_down in H ; ispecialize H δ₂ ;
apply I_later_forall_down in H ; ispecialize H δ.
apply I_later_forall_down in H ; ispecialize H ρ₁ ;
apply I_later_forall_down in H ; ispecialize H ρ₂ ;
apply I_later_forall_down in H ; ispecialize H ρ.
apply I_later_forall_down in H ; ispecialize H (
  env_ext γ₁ (subst_val δ₁ ρ₁ γ₁ (val_fix m₁ (lid_f X)))
).
apply I_later_forall_down in H ; ispecialize H (
  env_ext γ₂ (subst_val δ₂ ρ₂ γ₂ (val_fix m₂ (lid_f X)))
).
apply I_later_arrow_down in H ; ispecialize H.
{ iintro_later ; eassumption. }
apply I_later_arrow_down in H ; ispecialize H.
{ iintro_later ; eassumption. }
apply I_later_arrow_down in H ; ispecialize H.
{ iintro_later ; eassumption. }
apply I_later_arrow_down in H ; ispecialize H.
{
  later_shift.
  iintro x ; destruct x as [ | x ]  ; simpl 𝜞 ; simpl env_ext.
  + apply LöbIH.
  + iespecialize Hγ ; apply Hγ.
}

clear - H.
simpl 𝓥_Fun.
repeat ieexists ; repeat isplit ; [ auto | auto | ].
later_shift.
apply 𝓥_roll ; simpl 𝓥_Fun.
repeat ieexists ; repeat isplit ; [ auto | auto | ].
simpl subst_md in H.
repeat erewrite V_bind_bind_md.
{ apply H. }
{
  intro x ; destruct x as [|x] ; simpl ; [ auto | ].
  erewrite V_bind_map_val, V_map_val_id, V_bind_val_id ; crush.
}
{
  intro x ; destruct x as [|x] ; simpl ; [ auto | ].
  erewrite V_bind_map_val, V_map_val_id, V_bind_val_id ; crush.
}
Qed.

Lemma compat_val_ktx n K₁ K₂ Ta Ea Tb Eb  :
n ⊨ ⟦ Ξ Γ ⊢ K₁ ≼ˡᵒᵍ K₂ : Ta # Ea ⇢ Tb # Eb ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (val_cont K₁) ≼ˡᵒᵍᵥ (val_cont K₂) : ty_cont Ta Ea Tb Eb ⟧.
Proof.
intro H.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂ ;
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iespecialize H.
ispecialize H ; [ eassumption | ].
ispecialize H ; [ eassumption | ].
ispecialize H ; [ eassumption | ].
ispecialize H ; [ eassumption | ].
simpl 𝓥_Fun ; repeat ieexists ; repeat isplit.
* iintro_prop ; crush.
* apply H.
Qed.

End section_compat_val.


Require Export Prelude.
Require Import Psatz.
Require Import TLC.LibLN.
Require Import TLC.LibEnv.
Require Import Infrastructure.
Require Export Notations.
Require Export Regularity.
Require Export Regularity2.

Ltac fs := exact \{}.

Ltac ininv :=
  match goal with
  | H: List.In _ _ |- _ =>
    inversions H
  end.

Ltac destruct_const_len_list :=
  repeat (match goal with
          | H: length ?L = ?n |- _ =>
            destruct L; inversions H
          end).

Ltac binds_inv :=
  match goal with
  | H: binds ?x ?a empty |- _ =>
    apply binds_empty_inv in H; contradiction
  | H: binds ?x ?a ?E |- _ =>
    binds_cases H;
    try match goal with
        | H: binds ?x ?a empty |- _ =>
          apply binds_empty_inv in H; contradiction
        end;
    subst
  | |- ?x \notin \{ ?y } =>
    apply* notin_inverse
  end.

Ltac solve_dom all_distinct :=
  simpl_dom; notin_solve; try (apply notin_singleton; lets*: all_distinct).

Ltac distinct2 :=
  match goal with
  | H1: DistinctList ?L |- _ =>
    inversions H1;
    match goal with
    | H2: ~ List.In ?v ?L1 |- _ =>
      cbn in H2; eauto
    end
  end.

Ltac solve_bind_core :=
  lazymatch goal with
  | |- binds ?Var ?What (?Left & ?Right) =>
    match goal with
    | |- binds Var What (Left & Var ~ ?Sth) =>
      apply* binds_concat_right; apply* binds_single_eq
    | _ => apply* binds_concat_left
    end
  end.

Ltac solve_bind :=
  (repeat solve_bind_core); try (solve_dom).

Export Definitions.
Export Psatz.
Export TLC.LibLN.
Export TLC.LibEnv.
Export Infrastructure. (* TODO only the gathering parts, should be split out *)

Inductive evals : trm -> trm -> Prop :=
| eval_step : forall a b c, a --> b -> evals b c -> evals a c
| eval_finish : forall a, evals a a.

Lemma is_var_defined_split : forall A B c, (is_var_defined A c \/ is_var_defined B c) -> is_var_defined (A |,| B) c.
  unfold is_var_defined.
  intros.
  apply List.in_or_app.
  destruct H; auto.
Qed.

Ltac autotyper1 :=
  repeat progress (
           cbn;
           match goal with
           | [ H: False |- _ ] => false*
           | [ |- ok ?A ] => econstructor
           | [ |- okt ?A ?B ?C ] => econstructor
           | [ |- binds ?A ?B ?C ] => solve_bind
           | [ |- ?A \notin ?B ] => simpl_dom; notin_solve; try (apply notin_singleton)
           | [ |- typing ?TT ?A ?B ?C ?D ?E ] => econstructor
           | [ |- forall x, x \notin ?L -> ?P ] =>
             let free := gather_vars in
             let x' := fresh "x" in
             let xiL := fresh "xiL" in
             intros x' xiL; intros;
             try instantiate (1 := free) in xiL
           | [ |- okGadt empty ] => econstructor
           | [ |- wft ?A ?B ?C ] => econstructor
           | [ |- value ?A ] => econstructor
           | [ |- term ?A ] => econstructor
           | [ |- type ?A ] => econstructor
           | [ H: binds ?A ?B ?C |- _ ] => binds_inv
           | [ |- ?A /\ ?B ] => split
           | [ H: {| Tarity := ?A; Tconstructors := ?B |} = ?C |- _ ] =>
             inversions H
           | [ H: ?A \/ ?B |- _ ] => destruct H
           | [ |- is_var_defined (?A |,| ?B) ?c ] => apply is_var_defined_split
           | _ => intros; auto
           end;
           cbn; subst).

(* TODO merge with autotyper1 *)
Ltac autotyper0 :=
  repeat progress (
           cbn;
           match goal with
           | [ H: False |- _ ] => false*
           | [ |- ok ?A ] => econstructor
           | [ |- okt ?A ?B ?C ] => econstructor
           | [ |- binds ?A ?B ?C ] => solve_bind
           | [ |- ?A \notin ?B ] => simpl_dom; notin_solve; try (apply notin_singleton)
           | [ |- forall x, x \notin ?L -> ?P ] =>
             let free := gather_vars in
             let x' := fresh "x" in
             let xiL := fresh "xiL" in
             intros x' xiL; intros;
             try instantiate (1 := free) in xiL
           | [ |- okGadt empty ] => econstructor
           | [ |- wft ?A ?B ?C ] => econstructor
           | [ |- value ?A ] => econstructor
           | [ |- term ?A ] => econstructor
           | [ |- type ?A ] => econstructor
           | [ H: binds ?A ?B ?C |- _ ] => binds_inv
           | [ |- ?A /\ ?B ] => split
           | [ H: {| Tarity := ?A; Tconstructors := ?B |} = ?C |- _ ] =>
             inversions H
           | [ H: ?A \/ ?B |- _ ] => destruct H
           | [ |- is_var_defined (?A |,| ?B) ?c ] => apply is_var_defined_split
           | _ => intros; auto
           end;
           cbn; subst).

Lemma neq_from_notin : forall (A : Type) (x y : A), x \notin \{ y } -> x <> y.
  intros.
  intro HF.
  subst.
  apply* notin_same.
Qed.

Ltac autotyper2 :=
  repeat progress (
           cbn;
           let free := gather_vars in
           let x' := fresh "x" in
           let xiL := fresh "xiL" in
           match goal with
           | [ H: False |- _ ] => false*
           | [ |- ok ?A ] => econstructor
           | [ |- okt ?A ?B ?C ] => econstructor
           | [ |- binds ?A ?B ?C ] => solve_bind
           | [ |- typing ?TT ?A ?B ?C (trm_unit) ?E ] => eapply typing_unit
           | [ |- typing ?TT ?A ?B ?C (trm_fvar ?k ?X) ?E ] => eapply typing_var with (vk:=k)
           | [ |- typing ?TT ?A ?B ?C (trm_constructor ?Ts ?N ?e) ?E ] => eapply typing_cons
           | [ |- typing ?TT ?A ?B ?C (trm_abs ?T ?e) ?E ] => eapply typing_abs with (L:=free)
           | [ |- typing ?TT ?A ?B ?C (trm_tabs ?e) ?E ] => eapply typing_tabs with (L:=free)
           | [ |- typing ?TT ?A ?B ?C (trm_app ?e1 ?e2) ?E ] => eapply typing_app
           | [ |- typing ?TT ?A ?B ?C (trm_tapp ?e1 ?T) ?E ] => eapply typing_tapp
           | [ |- typing ?TT ?A ?B ?C (trm_tuple ?e1 ?e2) ?E ] => eapply typing_tuple
           | [ |- typing ?TT ?A ?B ?C (trm_fst ?e1) ?E ] => eapply typing_fst
           | [ |- typing ?TT ?A ?B ?C (trm_snd ?e1) ?E ] => eapply typing_snd
           | [ |- typing ?TT ?A ?B ?C (trm_fix ?T ?e) ?E ] => eapply typing_fix with (L:=free)
           | [ |- typing ?TT ?A ?B ?C (trm_let ?e1 ?e2) ?E ] => eapply typing_let with (L:=free)
           | [ |- typing ?TT ?A ?B ?C (trm_matchgadt ?e1 ?N ?ms) ?E ] => eapply typing_case with (L:=free)
           | [ |- ?A \notin ?B ] => simpl_dom; notin_solve; try (apply notin_singleton)
           | [ |- forall x, x \notin ?L -> ?P ] =>
             let free := gather_vars in
             let x' := fresh "x" in
             let xiL := fresh "xiL" in
             intros x' xiL; intros;
             try instantiate (1 := free) in xiL
           | [ |- okGadt empty ] => econstructor
           | [ |- wft ?A ?B ?C ] => econstructor
           | [ |- value ?A ] => econstructor
           | [ |- term ?A ] => econstructor
           | [ |- type ?A ] => econstructor
           | [ H: binds ?A ?B ?C |- _ ] => binds_inv
           | [ |- ?A /\ ?B ] => split
           | [ H: {| Tarity := ?A; Tconstructors := ?B |} = ?C |- _ ] =>
             inversions H
           | [ H: ?A \/ ?B |- _ ] => destruct H
           | [ H: ?C = (?A, ?B) |- _ ] => inversions H
           | [ H: (?A, ?B) = ?C |- _ ] => inversions H
           | [ |- is_var_defined (?A |,| ?B) ?c ] => apply is_var_defined_split
           | _ => intros; auto
           end;
           cbn; subst).

Ltac autotyper3 :=
  autotyper2; cbn in *;
  destruct_const_len_list; cbn; autotyper2.

Ltac autotyper4 :=
  autotyper3;
  try solve [left~ | repeat right~].

Lemma Forall2_eq : forall A B (f : A -> B) Ts Us,
    List.length Ts = List.length Us ->
    (forall T U, List.In (T, U) (zip Ts Us) -> f T = f U) ->
    List.map f Ts =
    List.map f Us.
  induction Ts as [ | T Ts]; destruct Us as [ | U Us]; intros Len F; cbn in *; inversion Len.
  - auto.
  - f_equal; auto.
Qed.

Lemma eq_typ_gadt : forall Σ Δ Ts Us N,
    List.Forall2 (fun T U => entails_semantic Σ Δ (T ≡ U)) Ts Us ->
    entails_semantic Σ Δ (typ_gadt Ts N ≡ typ_gadt Us N).
  introv FF.
  cbn in *.
  apply F2_iff_In_zip in FF.
  destruct FF.
  intros O M.
  repeat rewrite subst_tt_prime_reduce_typ_gadt.
  f_equal.
  apply~ Forall2_eq.
Qed.

Ltac ininv2 :=
  match goal with
  | H: List.In _ _ |- _ =>
    inversions H
  | [ H: ?C = (?A, ?B) |- _ ] => inversions H
  | [ H: (?A, ?B) = ?C |- _ ] => inversions H
  end.

Lemma eq_typ_tuple : forall Σ Δ A B C D,
    entails_semantic Σ Δ (A ≡ C) ->
    entails_semantic Σ Δ (B ≡ D) ->
    entails_semantic Σ Δ ((A ** B) ≡ (C ** D)).
  introv EQ1 EQ2.
  cbn in *.
  intros O M.
  repeat rewrite subst_tt_prime_reduce_tuple.
  f_equal; auto.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_onBounce (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Import TVMModel.LedgerClass.
Opaque roundStepEqb.

Lemma letIf: forall X Y (b: bool) (f g: X*Ledger) (h: X -> Ledger -> Y),
(let (x, t) := if b then f else g in h x t)=
if b then let (x, t) := f in h x t else
          let (x, t) := g in h x t .
Proof.
  intros.
  destruct b; auto.
Qed.

Lemma matchIf: forall X (b: bool) (f g: LedgerT X) (l: Ledger),
(match (if b then f else g) with | SimpleState c => c end l)=
if b then match f with | SimpleState c => c end l else
match g with | SimpleState c => c end l.
Proof.
  intros.
  destruct b; auto.
Qed.

Lemma DePoolContract_Ф_onBounce_exec : forall (l : Ledger) (body : TvmSlice),

let (functionId, body') := decode_uint32 body in
let process_new_stake_id := tvm_functionId IProxy_И_process_new_stakeF in
let recover_stake_id := tvm_functionId IProxy_И_recover_stakeF in

let (roundId, _) := decode_uint64 body' in
let optRound := eval_state (↓ RoundsBase_Ф_fetchRound roundId) l in
let round := maybeGet optRound in
let roundFound : bool := isSome optRound in
let isRound1 : bool := eval_state (↓ RoundsBase_Ф_isRound1 roundId) l in
let isRound2 : bool := eval_state (↓ RoundsBase_Ф_isRound2 roundId) l in
let step := RoundsBase_ι_Round_ι_step round in
let step_wsa : bool := eqb step RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted in
let step_wr : bool := eqb step RoundsBase_ι_RoundStepP_ι_WaitingReward in
let step_wwe : bool := eqb step RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections in

let oldEvents := eval_state ( ↑16 ε VMState_ι_events ) l in
let queryId := DePoolLib_ι_Request_ι_queryId (RoundsBase_ι_Round_ι_validatorRequest round) in
let l_emit1 := {$ l With VMState_ι_events := ProxyHasRejectedTheStake queryId :: oldEvents $} in
let l_emit2 := {$ l With VMState_ι_events := ProxyHasRejectedRecoverRequest roundId :: oldEvents $} in

let isProcessNewStake := functionId =? process_new_stake_id in
let isRecoverStake := functionId =? recover_stake_id in
let round_pns :=
    {$ round with (RoundsBase_ι_Round_ι_step , RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest) $} in
let round_recover_1 :=
    {$ round with (RoundsBase_ι_Round_ι_step , RoundsBase_ι_RoundStepP_ι_WaitingValidationStart) $} in
let round_recover_2 :=
    {$ round with (RoundsBase_ι_Round_ι_step , RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze) $} in

exec_state (↓ DePoolContract_Ф_onBounce body) l =

if (isProcessNewStake || isRecoverStake)%bool then
    if (isProcessNewStake) then
        if isRound1 then
            if roundFound then
                if step_wsa then exec_state (↓ RoundsBase_Ф_setRound roundId round_pns) l_emit1
                            else l
            else l
        else l
    else
        if isRound2 then
            if roundFound then
                if step_wr then exec_state (↓ RoundsBase_Ф_setRound roundId round_recover_2) l_emit2
                else l
            else l
        else if isRound1 then
                if roundFound then
                    if step_wwe then exec_state (↓ RoundsBase_Ф_setRound roundId round_recover_1) l_emit2
                    else l
                else l
        else injEmbed (VMState_ι_savedDePoolContracts (Ledger_ι_VMState l)) l
else  l.

Proof.

  intros.
  destructLedger l.
  compute.

  all: destruct (decode_uint32 body). idtac.
  all: destruct (decode_uint64 t). idtac.

  repeat rewrite matchIf.  idtac.
  repeat rewrite letIf.  idtac.
  repeat rewrite matchIf.  idtac.
  repeat rewrite letIf.  idtac.
  repeat rewrite matchIf.  idtac.
  repeat rewrite letIf.  idtac.

  Time repeat destructIf_solve.  idtac.

  all: try setoid_rewrite H3 in H4; try discriminate. idtac.
  all: try setoid_rewrite H4 in H5; try discriminate.
(* Require Import depoolContract.Lib.CommonStateProofs.

apply ledgerEq; simpl; auto.
apply RoundsBaseEq; simpl; auto.
remember (match hmapLookup Z.eqb x0 RoundsBase_ι_m_rounds with
  | Some x1 => x1
  | None => default
end) as rx0.
setoid_rewrite <- Heqrx0.
destruct rx0; auto. *)
Qed.

Lemma DePoolContract_Ф_onBounce_eval : forall (l : Ledger) (body : TvmSlice),

let (functionId, body') := decode_uint32 body in
let process_new_stake_id := tvm_functionId IProxy_И_process_new_stakeF in
let recover_stake_id := tvm_functionId IProxy_И_recover_stakeF in
let (roundId, _) := decode_uint64 body' in
let optRound := eval_state (↓ RoundsBase_Ф_fetchRound roundId) l in
let round := maybeGet optRound in
let roundFound : bool := isSome optRound in
let isRound1 : bool := eval_state (↓ RoundsBase_Ф_isRound1 roundId) l in
let isRound2 : bool := eval_state (↓ RoundsBase_Ф_isRound2 roundId) l in
let step := RoundsBase_ι_Round_ι_step round in
let step_wsa : bool := roundStepEqb step RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted in
let step_wr : bool := roundStepEqb step RoundsBase_ι_RoundStepP_ι_WaitingReward in
let step_wwe : bool := roundStepEqb step RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections in
let isProcessNewStake := eqb functionId  process_new_stake_id in
let isRecoverStake := eqb functionId  recover_stake_id in

eval_state (DePoolContract_Ф_onBounce body) l =

if (isProcessNewStake || isRecoverStake)%bool then
    if (isProcessNewStake) then
        if isRound1 then
            if roundFound then
                if step_wsa then Value I
                            else Error InternalErrors_ι_ERROR525
            else Error InternalErrors_ι_ERROR519
        else Error InternalErrors_ι_ERROR524
    else
        if isRound2 then
            if roundFound then
                if step_wr then Value I
                else Error InternalErrors_ι_ERROR526
            else Error InternalErrors_ι_ERROR519
        else if isRound1 then
                if roundFound then
                    if step_wwe then Value I
                    else Error InternalErrors_ι_ERROR527
                else Error InternalErrors_ι_ERROR519
        else Error InternalErrors_ι_ERROR528
else Value I.
Proof.

  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve.  idtac.

  all: destruct (decode_uint32 body). idtac.
  all: destruct (decode_uint64 t). idtac.
  all: try rewrite H. idtac.
  all: try rewrite H0. idtac.
  all: try rewrite H1. idtac.
  all: try rewrite H2. idtac.
  all: try rewrite H3; auto. idtac.
  all: try rewrite H4; auto.

Qed.

End DePoolContract_Ф_onBounce.