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

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

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

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

(** * Floating-point format with abrupt underflow *)

From Coq Require Import Lia.
Require Import Raux Defs Round_pred Generic_fmt.
Require Import Float_prop Ulp FLX.

Section RND_FTZ.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.

Context { prec_gt_0_ : Prec_gt_0 prec }.

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

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

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

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

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

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

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

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

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

Section FTZ_round.

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

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

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

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

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

End FTZ_round.

End RND_FTZ.


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


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


Require Import extraInv.
Local Open Scope Z.

Definition cond2 :=
 ctrlState1.[of_Z timer1]=ctrlWaiting /\ hands1.[of_Z timer1]=ON /\ dryer2=dryer1.[of_Z timer1 <- ON] /\ ctrlTimer2=0 /\
ctrlState2=ctrlState1.[of_Z timer1 <- ctrlDrying].


Parameter Location : Type.
Parameter Pile : Type.
Parameter Robot : Type.
Parameter Crane : Type.
Parameter Container : Type.

Parameter adjacent : Location -> Location -> Prop.
Parameter atLocation : Robot -> Location -> Prop.
Parameter occupied : Location -> Prop.
Parameter belong : Crane -> Location -> Prop.
Parameter loaded : Robot -> Container -> Prop.
Parameter empty : Crane -> Prop.
Parameter holding : Crane -> Container -> Prop.

Definition move3(r:Robot)(from to:Location)(p1:adjacent from to)
                (p2:atLocation r from)(p3:not (occupied to)) := atLocation r to.

Definition unload2(k:Crane)(c:Container)(r:Robot)(l:Location)(p1:belong k l)
                (p2:atLocation r l)(p3:loaded r c)(p4:empty k) := holding k c.

Variable l1 l2 : Location.
Variable l1AdjacentL2 : adjacent l1 l2.
Variable r : Robot.
Variable rAtL1 : atLocation r l1.
Variable l2NotOccupied : not (occupied l2).
Variable rAtTo : move3 r l1 l2 l1AdiacentL2 rAtL1 l2NotOccupied.

Variable k1 : Crane.
Variable k1BelongL1 : belong k1 l2.
Variable c : Container.
Variable rLoadedC : loaded r c.
Variable emptyK : empty k1.
Variable kHoldingC : unload2 k1 c r l2 k1BelongL1 rAtTo rLoadedC emptyK.

Variable kHoldingC1 : unload2 k1 c r l1 k1BelongL1 rAtTo rLoadedC emptyK.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Require Export common.lhs_sel_nom_reduce.rhs_sel_bnd_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_sel_upp_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_sel_low_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_sel_equ_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_sel_nom_reduce.

Require Export common.lhs_sel_nom_reduce.rhs_nom_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_upp_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_low_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_equ_reduce.

Require Export common.lhs_sel_nom_reduce.rhs_bot_reduce.

Require Export common.lhs_sel_nom_reduce.rhs_all_reduce.

Require Export common.lhs_sel_nom_reduce.rhs_nil_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_con_reduce.

Require Export common.lhs_sel_nom_reduce.rhs_rfn_sel_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_rfn_top_reduce.

Require Export common.lhs_sel_nom_reduce.rhs_sha_sel_reduce.
Require Export common.lhs_sel_nom_reduce.rhs_sha_top_reduce.

Lemma subtype_sel_nom_reduce :
  forall T1 x1 L1 T1',
    T1 = (t_sel_nom x1 L1 T1') ->
    forall T2, subtype T1 T2 = match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (orb (subtype T1' T2) (subtype T1 T2'))
                          | t_sel_upp x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_nom x2 L2 _ => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_sel_bnd x2 L2 => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1' T2)
                          | t_upp L2 T2' => false
                          | t_low L2 T2' => false
                          | t_equ L2 T2' => false
                          | t_nom L2 T2' => false

                          | t_nil => false
                          | t_con _ _ => false

                          | _ => subtype T1' T2
                          end.
Proof.
  intros.

  destruct T2.

  apply subtype_top;
    subst;
    intros;
    intro Hcontra;
    inversion Hcontra.

  subst;
    apply subtype_sel_nom_bot_reduce
      with (x1:=x1)(L1:=L1);
    auto.

  subst;
    apply subtype_sel_nom_sel_upp_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_sel_low_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_sel_equ_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_sel_nom_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_sel_bnd_reduce
      with (x1:=x1)(L1:=L1);
    auto.

  subst;
    apply subtype_sel_nom_rfn_top_reduce
      with (x1:=x1)(L1:=L1)(Ts:=T2);
    auto.

  subst;
    apply subtype_sel_nom_rfn_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(Ts:=T2_1)(T':=T2_2);
    auto.

  subst;
    apply subtype_sel_nom_sha_top_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(ss2:=d);
    auto.

  subst;
    apply subtype_sel_nom_sha_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(T':=T2)(ss2:=d);
    auto.

  subst;
    apply subtype_sel_nom_all_reduce
      with (x1:=x1)(L1:=L1)(T:=T2_1)(T':=T2_2);
    auto.

  subst;
    apply subtype_sel_nom_upp_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_low_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_equ_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_nom_nom_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst; eapply subtype_sel_nom_nil_reduce; eauto.

  subst; eapply subtype_sel_nom_con_reduce; eauto.

Qed.


From Velus Require Import NLustre.
From Velus Require Import Stc.

From Velus Require Import NLustreToStc.Translation.

From Velus Require Import VelusMemory.
From Velus Require Import Common.
From Velus Require Import CoindToIndexed.

From Coq Require Import List.
Import List.ListNotations.
From Coq Require Import Permutation.

Open Scope nat.
Open Scope list.

Module Type NL2STCTYPING
       (Import Ids   : IDS)
       (Import Op    : OPERATORS)
       (Import OpAux : OPERATORS_AUX   Op)
       (Import CStr  : COINDSTREAMS    Op OpAux)
       (Import IStr  : INDEXEDSTREAMS  Op OpAux)
       (Import CIStr : COINDTOINDEXED  Op OpAux CStr IStr)
       (Import CE    : COREEXPR    Ids Op OpAux      IStr)
       (Import NL    : NLUSTRE     Ids Op OpAux CStr IStr CIStr CE)
       (Import Stc   : STC         Ids Op OpAux      IStr       CE)
       (Import Trans : TRANSLATION Ids Op                 CE.Syn NL.Syn Stc.Syn NL.Mem).

  Lemma translate_eqn_wt:
    forall G vars vars' mems eq,
      NL.Typ.wt_equation G vars eq ->
      Permutation (vars' ++ mems) vars ->
      (forall x ty, In (x, ty) vars -> In x (gather_mem_eq eq) -> In (x, ty) mems) ->
      (forall x ty, In (x, ty) vars -> NL.IsV.Is_variable_in_eq x eq -> In (x, ty) vars') ->
      Forall (wt_trconstr (translate G) vars' mems) (translate_eqn eq).
  Proof.
    inversion_clear 1 as [??? Hin|????? Find|??????? Find|];
      intros * SpecVars SpecMems SpecVars'; simpl.
    - constructor; auto.
      constructor; try rewrite SpecVars; auto.
    - destruct xs; auto.
      constructor; auto.
      apply find_node_translate in Find as (?&?&?&?); subst.
      econstructor; try rewrite SpecVars; eauto.
      simpl; eapply Forall2_impl_In; eauto.
      intros ? (? & (? & ?)) ? ? Hin.
      apply SpecVars' in Hin; auto.
    - destruct xs; auto.
      apply find_node_translate in Find as (?&?&?&?); subst.
      constructor; auto.
      + econstructor; eauto.
        rewrite SpecVars; auto using wt_clock.
      + constructor; auto.
        econstructor; try rewrite SpecVars; eauto.
        simpl; eapply Forall2_impl_In; eauto.
        intros ? (? & (?&?)) ? ? Hin.
        apply SpecVars' in Hin; auto.
    - constructor; auto.
      constructor; try rewrite SpecVars; auto.
      apply SpecMems; simpl; auto.
      congruence.
  Qed.

  Lemma translate_eqns_wt:
    forall eqs G vars vars' mems,
      Forall (NL.Typ.wt_equation G vars) eqs ->
      Permutation (vars' ++ mems) vars ->
      (forall x ty, In (x, ty) vars -> In x (gather_mems eqs) -> In (x, ty) mems) ->
      (forall x ty, In (x, ty) vars -> NL.IsV.Is_variable_in x eqs -> In (x, ty) vars') ->
      Forall (wt_trconstr (translate G) vars' mems) (translate_eqns eqs).
  Proof.
    unfold translate_eqns.
    induction eqs; intros * WT SpecVars SpecMems SpecVars';
      inv WT; simpl; try constructor.
    apply Forall_app; split; auto.
    - eapply translate_eqn_wt; eauto.
      + intros * Hin Hin_mems.
        apply SpecMems; auto.
        unfold gather_mems; simpl.
        apply in_app; auto.
      + intros * Hin IsV.
        apply SpecVars'; auto.
        left; auto.
    - eapply IHeqs; eauto.
      + intros * Hin Hin_mems.
        apply SpecMems; auto.
        unfold gather_mems; simpl.
        apply in_app; auto.
      + intros * Hin IsV.
        apply SpecVars'; auto.
        right; auto.
  Qed.

  Definition fby_eq (acc: list (ident * type)) (eq: NL.Syn.equation) : list (ident * type) :=
    match eq with
    | NL.Syn.EqDef x _ _
    | NL.Syn.EqApp x _ _ _ _ => acc
    | NL.Syn.EqFby x _ c _ => (x, type_const c) :: acc
    end.

  Definition fbys (eqs: list NL.Syn.equation) : list (ident * type) :=
    fold_left fby_eq eqs [].

  Lemma in_fbys_spec:
    forall x t eqs acc,
      In (x, t) (fold_left fby_eq eqs acc) <-> In (x, t) (fbys eqs) \/ In (x, t) acc.
  Proof.
    unfold fbys.
    induction eqs as [|[]]; simpl; auto.
    - firstorder.
    - intros.
      rewrite IHeqs; symmetry; rewrite IHeqs.
      split; simpl; intuition.
  Qed.

  Lemma n_nodup_fbys:
    forall n,
      NoDup (fbys (n_eqs n)).
  Proof.
    intro.
    pose proof (NoDup_var_defined_n_eqs n) as Hnodup.
    assert (NoDup (@nil (ident * type))) as Hnodup_acc by constructor.
    assert (forall x, In x (vars_defined (n_eqs n)) -> ~ InMembers x (@nil (ident * type)))
      as Spec by (inversion 2).
    unfold fbys, vars_defined in *.
    revert Hnodup_acc Spec; generalize (@nil (ident * type)).
    induction (n_eqs n) as [|[]]; simpl in *; intros; auto.
    - inv Hnodup; auto.
    - rewrite Permutation_app_comm in Hnodup; apply NoDup_app_weaken in Hnodup; auto.
      apply IHl; auto.
      intros; apply Spec, in_app; auto.
    - inv Hnodup; apply IHl; auto.
      + constructor; auto.
        apply NotInMembers_NotIn; auto.
      + intros ? Hin.
        apply NotInMembers_cons; split; auto.
        simpl; intro; subst; contradiction.
  Qed.

  Lemma fbys_gather_eqs_aux:
    forall eqs l mems mems',
      Permutation (map (fun x => (fst x, type_const (fst (snd x)))) mems) mems' ->
      Permutation
        (map (fun x => (fst x, type_const (fst (snd x))))
             (fst (fold_left gather_eq eqs (mems, l))))
        (fold_left fby_eq eqs mems').
  Proof.
    induction eqs as [|[]]; simpl; intros; try constructor; auto.
    - cases.
    - apply IHeqs; simpl; constructor; auto.
  Qed.

  Lemma fbys_gather_eqs:
    forall eqs,
      Permutation
        (map (fun x => (fst x, type_const (fst (snd x)))) (fst (gather_eqs eqs)))
        (fbys eqs).
  Proof.
    unfold gather_eqs, fbys; intro.
    apply fbys_gather_eqs_aux; auto.
  Qed.

  Lemma filter_fst_idty:
    forall A B (xs: list (ident * (A * B))) P,
      idty (filter (fun x => P (fst x)) xs) = filter (fun x => P (fst x)) (idty xs).
  Proof.
    induction xs; simpl; intros; auto.
    cases; simpl; now rewrite IHxs.
  Qed.

  Lemma fst_partition_memories_fbys:
    forall G n,
      wt_node G n ->
      Permutation
        (idty (fst (partition
                      (fun x => PS.mem (fst x) (NL.Mem.memories n.(n_eqs)))
                      n.(n_vars))))
        (fbys n.(n_eqs)).
  Proof.
    unfold wt_node; intros * WT.
    rewrite fst_partition_filter.
    apply NoDup_Permutation.
    - apply NoDupMembers_NoDup, fst_NoDupMembers.
      rewrite map_fst_idty, filter_mem_fst.
      apply nodup_filter.
      pose proof (n.(n_nodup)) as Hnodup.
      apply NoDupMembers_app_r, NoDupMembers_app_l in Hnodup.
      now apply fst_NoDupMembers.
    - apply n_nodup_fbys.
    - assert (forall x, In x (vars_defined (filter is_fby (n_eqs n))) ->
                   InMembers x (n_vars n)) as Spec
          by (intro; rewrite <-fst_partition_memories_var_defined, fst_partition_filter,
                     filter_mem_fst, filter_In, fst_InMembers; intuition).
      pose proof (filter_fst_idty _ _(n_vars n)
                                  (fun x => PS.mem x (Mem.memories (n_eqs n)))) as E;
        setoid_rewrite E; clear E.
      setoid_rewrite filter_In.
      setoid_rewrite <-PSE.MP.Dec.F.mem_iff.
      unfold Mem.memories, fbys in *.
      induction (n_eqs n) as [|[]]; inversion_clear WT as [|?? WTeq]; simpl; auto.
      + split; try contradiction.
        setoid_rewrite PSE.MP.Dec.F.empty_iff; intuition.
      + inversion_clear WTeq as [| | |???? Hint].
        intros (x, t); split.
        *{ intros * (Hin & Mem); apply in_fbys_spec;
           apply In_fold_left_memory_eq in Mem as [Mem|Mem].
           - apply In_fold_left_memory_eq in Mem as [Mem|Mem];
               [|rewrite PSE.MP.Dec.F.empty_iff in Mem; contradiction].
             left; apply IHl; auto.
             intros * Hin'; apply Spec; simpl; auto.
           - apply PSE.MP.Dec.F.add_iff in Mem as [E|Mem];
               [|rewrite PSE.MP.Dec.F.empty_iff in Mem; contradiction].
             inv E.
             right; constructor; simpl.
             assert (In (x, t) (idty (n_in n ++ n_vars n ++ n_out n))) as Hin'
                 by (rewrite 2 idty_app, 2 in_app; auto).
             f_equal.
             eapply NoDupMembers_det; eauto.
             apply NoDupMembers_idty, n_nodup.
         }
        *{ intros * Hin; rewrite In_fold_left_memory_eq;
           apply in_fbys_spec in Hin as [Hin|Hin].
           - apply IHl in Hin; auto.
             + intuition.
             + intros * Hin'; apply Spec; simpl; auto.
           - inversion_clear Hin as [E|]; try contradiction; inv E.
             rewrite PSE.MP.Dec.F.add_iff; intuition.
             simpl in Spec.
             assert (InMembers x (n_vars n)) as Hin by auto.
             pose proof (n_nodup n) as Hnodup.
             rewrite fst_NoDupMembers, 2 map_app, NoDup_swap, <- 2 map_app, <-fst_NoDupMembers in Hnodup.
             eapply NoDupMembers_app_InMembers, NotInMembers_app in Hnodup as (? & ?); eauto.
             rewrite 2 idty_app, 2 in_app in Hint; destruct Hint as [Hint|[|Hint]]; auto;
               apply In_InMembers in Hint; rewrite InMembers_idty in Hint; contradiction.
         }
  Qed.

  Lemma translate_node_wt:
    forall G n,
      wt_node G n ->
      wt_system (translate G) (translate_node n).
  Proof.
    unfold wt_node, wt_system; intros * WT; simpl.
    eapply translate_eqns_wt; eauto.
    - repeat rewrite idty_app.
      rewrite <-app_assoc.
      apply Permutation_app_head.
      rewrite Permutation_app_comm, app_assoc.
      apply Permutation_app_tail.
      rewrite fbys_gather_eqs, <-fst_partition_memories_fbys; eauto.
      setoid_rewrite ps_from_list_gather_eqs_memories.
      rewrite <-idty_app.
      apply Permutation_map.
      rewrite <-permutation_partition; auto.
    - setoid_rewrite fbys_gather_eqs.
      unfold gather_mems, fbys.
      induction (n_eqs n) as [|[] eqs]; simpl; intros * Hin Mem; try contradiction;
        inversion_clear WT as [|?? WTeq]; auto.
      inv WTeq.
      apply in_fbys_spec.
      destruct Mem as [|Mem].
      + subst.
        right; constructor.
        f_equal.
        eapply NoDupMembers_det; eauto.
        apply NoDupMembers_idty, n_nodup.
      + left; auto.
    - intros * Hin IsV.
      rewrite 2 idty_app, 2 in_app.
      rewrite 2 idty_app, 2 in_app in Hin; destruct Hin as [|[|]]; auto.
      right; left.
      setoid_rewrite ps_from_list_gather_eqs_memories.
      rewrite snd_partition_filter.
      pose proof (filter_fst_idty _ _(n_vars n)
                                  (fun x => negb (PS.mem x (Mem.memories (n_eqs n))))) as E;
        setoid_rewrite E; clear E.
      rewrite filter_In, Bool.negb_true_iff, <-PSE.MP.Dec.F.not_mem_iff.
      intuition.
      eapply not_Is_variable_in_memories; eauto.
      apply NoDup_defs_node.
  Qed.
  Hint Resolve translate_node_wt.

  Theorem translate_wt:
    forall G,
      wt_global G ->
      wt_program (translate G).
  Proof.
    intros * WT.
    induction G; simpl; auto.
    inversion_clear WT as [|???? Hn].
    constructor; auto; simpl.
    clear - Hn.
    induction G; constructor; inv Hn; simpl; auto.
  Qed.

End NL2STCTYPING.

Module NL2StcTypingFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (OpAux : OPERATORS_AUX   Op)
       (CStr  : COINDSTREAMS    Op OpAux)
       (IStr  : INDEXEDSTREAMS  Op OpAux)
       (CIStr : COINDTOINDEXED  Op OpAux CStr IStr)
       (CE    : COREEXPR    Ids Op OpAux      IStr)
       (NL    : NLUSTRE     Ids Op OpAux CStr IStr CIStr CE)
       (Stc   : STC         Ids Op OpAux      IStr       CE)
       (Trans : TRANSLATION Ids Op                 CE.Syn NL.Syn Stc.Syn NL.Mem)
<: NL2STCTYPING Ids Op OpAux CStr IStr CIStr CE NL Stc Trans.
  Include NL2STCTYPING Ids Op OpAux CStr IStr CIStr CE NL Stc Trans.
End NL2StcTypingFun.


Set Implicit Arguments.

Require Import ADT.
Require Import RepInv.

Module Make (Import E : ADT) (Import M : RepInv E).

  Require Import Inv.
  Module Import InvMake := Make E.
  Module Import InvMake2 := Make M.
  Import SemanticsMake.
  Require Import WordMap.
  Require Import FMapFacts.
  Module Import P := Properties WordMap.

  Section TopSection.

    Lemma heap_empty_bwd : Emp ===> is_heap heap_empty.
      unfold is_heap, heap_empty, heap_elements.
      rewrite elements_empty.
      apply Himp_refl.
    Qed.

    Definition hints_heap_empty_bwd : TacPackage.
      prepare tt heap_empty_bwd.
    Defined.

  End TopSection.

End Make.


From CoindSemWhile Require Import SsrExport Trace Language BigRel.
From Coq Require Import JMeq.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* terminality predicate*)
Inductive stop: stmt -> Prop :=
| stop_skip: stop Sskip
| stop_seq: forall s1 s2,
  stop s1 -> stop s2 -> stop (Sseq s1 s2)
(* one-step reduction relation *)
with step : stmt -> state -> stmt -> state -> Prop :=
| step_assign: forall x a st,
  step (Sassign x a) st Sskip (update x (a st) st)
| step_seq1: forall s1 s1' st' s2 st,
  step s1 st s1' st' ->
  step (Sseq s1 s2) st (Sseq s1' s2) st'
| step_seq2: forall s1 s2 s2' st st',
  stop s1 ->
  step s2 st s2' st' -> step (Sseq s1 s2) st s2' st'
| step_ifthenelse_true: forall st a s1 s2,
   is_true (a st) = true ->
   step (Sifthenelse a s1 s2) st s1 st
| step_ifthenelse_false: forall st a s1 s2,
  is_true (a st) = false ->
  step (Sifthenelse a s1 s2) st s2 st
| step_while_false: forall st a s,
  is_true (a st) = false ->
  step (Swhile a s) st Sskip st
| step_while_true: forall st a s,
  is_true (a st) = true ->
  step (Swhile a s) st (Sseq s (Swhile a s)) st.

(* small-step relational semantics *)
CoInductive redm: stmt -> state -> trace -> Prop :=
| redm_stop: forall s st,
  stop s -> redm s st (Tnil st)
| redm_step: forall s st s' st' tr,
  step s st s' st' ->
  redm s' st' tr ->
  redm s st (Tcons st tr).

Lemma stop_step_exclusive: forall s st s' st',
stop s -> step s st s' st' -> False.
Proof.
move => s; induction s;
move => st s' st' h1 h2; do [simpl] in h1 h2.
- by inversion h2.
- by inversion h1.
- foo h1. foo h2.
  - by apply: (IHs1 _ _ _ H1 H6).
  - by apply: (IHs2 _ _ _ H2 H7).
- by inversion h1.
- by inversion h1.
Qed.

Lemma step_deterministic: forall s st s1 st1 s2 st2,
step s st s1 st1 -> step s st s2 st2 -> s1 = s2 /\ st1 = st2.
Proof.
move => s; induction s; move => st s3 st1 s4 st2 h1 h2; foo h1; foo h2.
- done.
- have h3 := IHs1 _ _ _ _ _ H4 H5. by foo h3.
- by have := stop_step_exclusive H1 H4.
- by have := stop_step_exclusive H1 H6.
- have h3 := IHs2 _ _ _ _ _ H5 H7. by foo h3.
- done.
- rewrite H5 in H6. by inversion H6.
- rewrite H5 in H6. by inversion H6.
- done.
- done.
- rewrite H4 in H5; by inversion H5.
- rewrite H4 in H5; by inversion H5.
- done.
Qed.

(* determinism *)
Lemma redm_deterministic:
forall st s tr1 tr2, redm st s tr1 -> redm st s tr2 ->
bisim tr1 tr2.
Proof.
cofix COINDHYP.
move => st s tr1 tr2  h1 h2. foo h1.
- foo h2.
  - by apply bisim_nil.
  - by have := stop_step_exclusive H H0.
- foo h2.
  - by have := stop_step_exclusive H1 H.
  - have h3 := step_deterministic H H1. foo h3. apply bisim_cons.
    by have := COINDHYP _ _ _ _ H0 H2; apply.
Qed.

(* setoid *)
Lemma redm_insensitive:
forall s st tr1 tr2, redm s st tr1 -> bisim tr1 tr2 ->
redm s st tr2.
Proof.
cofix COINDHYP. move => st s tr1 tr2 h1 h2. foo h1.
- foo h2. apply: (redm_stop _ H).
- foo h2. apply: (redm_step H).  apply: (COINDHYP _ _ _  _ H0 H4).
Qed.

Lemma red_exec:
forall s st tr, exec s st tr ->
(stop s /\ tr = Tnil st) \/ (exists s' st' tr', (step s st s' st' /\ bisim tr (Tcons st tr')) /\ exec s' st' tr').
Proof.
move => s; induction s; move => st tr1 h1; foo h1.
-  left. split.
  * by apply: stop_skip.
  * done.
- right. exists Sskip. exists (update i (e st) st).
  exists (Tnil (update i (e st) st)). split.
  * split.
    * by apply: step_assign.
    * by apply: bisim_reflexive.
  * by apply: exec_skip.
- have [h2 | h2]:= IHs1 _ _ H1 => {IHs1}.
  - move: h2 => [h3 h4]. subst. foo H4.
    have [h4 | h4] := IHs2 _ _ H2 => {IHs2}.
    - move: h4 => [h5 h6]. subst. left. split.
      * by have := stop_seq h3 h5; apply.
      * done.
    - move: h4 => [s3 [st1 [tr2 h5]]]. move: h5 => [[h5 h6] h7]. foo h6.
      right. exists s3. exists st1. exists tr2. split.
      * split.
        * by apply: (step_seq2 h3 h5).
        *  by apply: (bisim_cons st H3).
      * by apply: h7.
  - right. move: h2 => [s3 [st1 [tr2 h3]]]. move: h3 => [[h3 h4] h5]. foo h4. foo H4.
    exists (Sseq s3 s2). exists st1. exists tr'. split.
    * split.
      * by apply: (step_seq1 _ h3).
      * by apply: bisim_reflexive.
    *  apply: (exec_seq h5). by apply: (execseq_insensitive_pre H2 H6).
- foo H5. foo H3. have [h1 | h1] := IHs1 _ _ H1 => {IHs1}.
  - move: h1 => [h2 h3]. subst. right. exists s1. exists st. exists (Tnil st).
    split.
    * split.
      *  by apply: (step_ifthenelse_true _ _ H4).
      * by apply: bisim_reflexive.
    * by apply: H1.
  - move: h1 => [s3 [st1 [tr2 h2]]].  move: h2 => [[h2 h3] h4]. right. foo h3.
    exists s1. exists st. exists (Tcons st tr). split.
    * split.
      * by apply: (step_ifthenelse_true _ _ H4).
      * by apply: bisim_reflexive.
    * by apply: H1.
- foo H5. foo H3. have [h1 | h1] := IHs2 _ _ H1=> {IHs1 IHs2}.
  - move: h1 => [h2 h3]. subst. right. exists s2. exists st. exists (Tnil st). split.
    * split.
      * by apply: (step_ifthenelse_false _ _ H4).
      * by apply: bisim_reflexive.
    * by apply: H1.
  - move: h1 => [s3 [st1 [tr1 h2]]]. move: h2 => [[h2 h3] h4]. foo h3. right.
    exists s2. exists st. exists (Tcons st tr). split.
    * split.
      * by apply: (step_ifthenelse_false _ _ H4).
      * by apply: bisim_reflexive.
    * by apply: H1.
- right. exists Sskip. exists st. exists (Tnil st). split.
  * split.
    * by apply: (step_while_false _ H3).
    * by apply: bisim_reflexive.
  * by apply: exec_skip.
- right. exists (Sseq s (Swhile e s)). exists st. foo H2. foo H5. exists tr'0. split.
  * split.
    * by apply: (step_while_true _ H1).
    * by apply: bisim_reflexive.
  * foo H6. by apply: (exec_seq H2 H4).
Qed.

(* the big-step relational semantics correct wrt the small-step relational semantis *)
Lemma exec_correct_redm: forall s st tr,
exec s st tr -> redm s st tr.
Proof.
cofix COINDHYP. move => s st tr h1. have [h2 | h2] := red_exec h1.
- move: h2 => [h3 h4]. rewrite h4. by apply: (redm_stop _ h3).
- move: h2 => [s1 [st1 [tr1 h3]]]. move: h3 => [[h3 h4] h5]. foo h4.
  apply: (redm_step h3). apply: COINDHYP.
  apply: (exec_insensitive h5 (bisim_symmetric H1)).
Qed.

CoInductive midpoint (s1 s2: stmt) (st: state) (tr: trace)
 (h: redm (Sseq s1 s2) st tr) : trace -> Prop :=
| midpoint_stop_seq : stop (s1;; s2) -> midpoint h (Tnil st)
| midpoint_stop_s1 : forall s' st' tr0,
   redm s' st' tr0 -> stop s1 -> step s2 st s' st' ->
   midpoint h (Tnil st)
| midpoint_more : forall s1' st' tr0 (h': redm (s1';; s2) st' tr0) tr',
    step s1 st s1' st' ->
    @midpoint s1' s2 st' tr0 h' tr' ->
    midpoint h (Tcons st tr').

Lemma midpoint_before0: forall s st tr tr' (h: redm s st tr),
forall s1 s2, s = Sseq s1 s2 ->
forall (h1: redm (Sseq s1 s2) st tr),
JMeq h h1 ->
midpoint h1 tr' ->
redm s1 st tr'.
Proof.
cofix COINDHYP. dependent inversion h; subst; move => s2 s3.
- move => h1 h2. subst. move => h3. have h4 := JMeq_eq h3. rewrite -h4.
  inversion s1; subst.
  move => hm. foo hm.
  * by apply redm_stop.
  * by apply stop_step_exclusive in H3.
  * by apply stop_step_exclusive in H.
- move: s st s' st' s1 r h. dependent inversion s1; subst.
  * move => h1 h2 h3. by inversion h3.
  * move => h1 h2 h3 h4 h5. foo h3. have h6 := JMeq_eq h5.
    rewrite -h6 {h5 h6}.
    move => hm. foo hm.
    * foo H.
      by apply stop_step_exclusive in s5.
    * by apply stop_step_exclusive in s5.
    * have Heq: s1'0 = s1' /\ st'0 = st' by apply: step_deterministic; eauto.
      case: Heq => [s10 st0].
      subst.
      apply: (redm_step s5).
      have hje: JMeq h' h' by apply JMeq_refl.
      move: hje H0.
      exact: COINDHYP.
  - move => h1 h2 h3 h4 h5. foo h3. have h6 := JMeq_eq h5. rewrite -h6 {h5 h6}.
    move => hm. foo hm.
    * foo H.
      by apply stop_step_exclusive in s6.
    * by apply (redm_stop _ s5).
    * by apply stop_step_exclusive in H.
  - move => h1 h2 h3. by inversion h3.
  - move => h1 h2 h3. by inversion h3.
  - move => h1 h2 h3. by inversion h3.
  - move => h1 h2 h3. by inversion h3.
Qed.

Lemma midpoint_before: forall s1 s2 st tr tr' (h: redm (Sseq s1 s2) st tr),
midpoint h tr' ->
redm s1 st tr'.
Proof.
move => s1 s2 st tr tr' h. by apply: (midpoint_before0 (refl_equal _) (JMeq_refl _)).
Qed.

CoInductive redm_str: stmt -> trace -> trace -> Prop :=
| redm_nil: forall s st tr,
  redm s st tr ->
  redm_str s (Tnil st) tr
| redm_cons: forall s tr tr' st,
  redm_str s tr tr' ->
  redm_str s (Tcons st tr) (Tcons st tr').

(*
Lemma midpoint_after0: forall s st tr (h: redm s st tr),
forall s1 s2, s = Sseq s1 s2 ->
forall (h1: redm (Sseq s1 s2) st tr),
JMeq h h1 ->
redm_str s2 (midpoint h1) tr.
Proof.
cofix COINDHYP. dependent inversion h; subst; move => s2 s3.
- move => h1 h2. subst. move => h3. have h4 := JMeq_eq h3. rewrite -h4.
  rewrite [midpoint _]trace_destr. simpl. apply: redm_nil.
  inversion s1; subst. by apply: (redm_stop _ H2).
- move: s st s' st' s1 r h. dependent inversion s1; subst.
  - move => h1 h2 h3. by inversion h3.
  - move => h1 h2 h3 h4 h5. foo h3. have h6 := JMeq_eq h5.
    rewrite -h6. rewrite [midpoint _]trace_destr. simpl.
    by apply: (redm_cons _ (COINDHYP _ _ _ _ _ _ (refl_equal _) _ (JMeq_refl _))).
  - move => h1 h2 h3 h4 h5. foo h3. have h6 := JMeq_eq h5. rewrite -h6.
    rewrite [midpoint _]trace_destr. simpl. apply: redm_nil.
    by apply: (redm_step s6 h1).
  - move => h1 h2 h3. by inversion h3.
  - move => h1 h2 h3. by inversion h3.
  - move => h1 h2 h3. by inversion h3.
  - move => h1 h2 h3. by inversion h3.
Qed.

Lemma midpoint_after: forall s1 s2 st tr (h: redm (Sseq s1 s2) st tr),
redm_str s2 (midpoint h) tr.
Proof.
move => s1 s2 st tr h. by apply: (midpoint_after0 (refl_equal  _ ) (JMeq_refl _)).
Qed.

(* the small-step relational semantics correct wrt the big-step relational semantics *)
Lemma redm_correct_exec: forall s st tr, redm s st tr -> exec s st tr.
Proof.
cofix COINDHYP.
have COINDHYP2: forall s tr1 tr2, redm_str s tr1 tr2 -> execseq s tr1 tr2.
* cofix COINDHYP2. move => s tr1 tr2 h1. foo h1.
  - by apply: (execseq_nil (COINDHYP _ _ _ H)).
  - by apply: (execseq_cons _ (COINDHYP2 _ _ _ H)).
* case.
  - move => st tr h1. foo h1.
    - by apply: exec_skip.
    - by inversion H.
  - move => i a st tr h1. foo h1.
    - by inversion H.
    - foo H. foo H0.
      - by apply: exec_assign.
      - by inversion H.
  - move => s1 s2 st tr h1. have h2 := midpoint_before h1.
    have h3 := midpoint_after h1.
    by apply: (exec_seq (COINDHYP _ _ _ h2) (COINDHYP2 _ _ _ h3)).
  - move => a s1 s2 st tr h1. foo h1.
    - by inversion H.
    - foo H.
      - apply: (exec_ifthenelse_true _ H7).
        by apply: (execseq_cons _ (execseq_nil (COINDHYP _ _ _ H0))).
      - apply: (exec_ifthenelse_false _ H7).
        by apply: (execseq_cons _ (execseq_nil (COINDHYP _ _ _ H0))).
  - move => a s st tr h1. foo h1.
    - by inversion H.
    - foo H.
      - foo H0.
        - by apply: (exec_while_false _ H6).
        -  by inversion H.
      - have h2 := midpoint_before H0. have h3 := midpoint_after H0.
        apply: (exec_while_loop H6). apply execseq_cons.  apply: execseq_nil.
        apply (COINDHYP _ _ _ h2). apply: execseq_cons. apply: (COINDHYP2 _ _ _ h3).
Qed.
*)

(* adequacy relative to the inductive semantics *)
Inductive norm: stmt -> state -> state -> Prop :=
| norm_nil: forall s st,
  stop s  -> norm s st st
| norm_cons: forall s st s'  st' st'',
  step s st s' st' ->
  norm s' st' st'' ->
  norm s st st''.

Inductive result: trace -> state -> Prop :=
| res_return: forall st, result (Tnil st) st
| res_step: forall st st' tr,
  result tr st ->
  result (Tcons st' tr) st.

Lemma redm_correct_norm:
forall tr st, result tr st -> forall s st', redm s st' tr -> norm s st' st.
Proof.
induction 1.
- move => s st1 h1. foo h1. by apply: (norm_nil _ H2).
- move => s st1 h1. foo h1. apply: (norm_cons H4). by apply: (IHresult _ _ H5).
Qed.

Lemma norm_correct_redm: forall s st st',
 norm s st st' -> exists tr, redm s st tr /\ result tr st'.
Proof.
move => s st st' h1. induction h1.
- exists (Tnil st). split.
  * by apply: (redm_stop _ _).
  * by apply: res_return.
- move: IHh1 => [tr [h2 h3]].  exists (Tcons st tr). split.
  * by apply: (redm_step _ h2).
  * by apply: (res_step _  h3).
Qed.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From fcsl
Require Import pred.
From scilla
Require Import options.

(* A semantics of contracts with decidable deterministic transitions *)

Section State.

Definition value := nat.
Definition address := nat.
Definition tag := nat.
Definition payload := (seq (nat * seq nat)).

(* Message with a payload *)
Record message := Msg {
      val    : value;
      sender : address;
      to     : address;
      method : tag;
      body   :  payload
}.

(* Augmented state of a contract *)
Record cstate (T : Type) := CState {
      my_id : address;
      balance : value;
      state : T
}.

(* Global blockchain state *)
Record bstate := BState {
      block_num : nat;
      (* Anything else? *)
}.

End State.

Section Protocol.

Section Transitions.

(* State type *)
Variable S: Type.

(* A response from a transition *)
Definition resp_type := (address * value * tag * payload)%type.
Definition msg_bal (rt : resp_type) : value := rt.1.1.2.

(* Transitions are functions *)
Definition trans_fun_type :=
  address -> value -> S -> message -> bstate -> (S * option message).

(* Contract transition in the spirit of I/O automata *)
Record ctransition :=
  CTrans {
      (* Unique tag of a transition in the protocol *)
      ttag : tag;

      (* Funcion (bstate, state, msg) :-> (state', option msg') *)
      tfun : trans_fun_type;
  }.

Definition idle_fun : trans_fun_type := fun _ _ s _ _ => (s, None).
Definition idle := CTrans 0 idle_fun.

End Transitions.

Record Protocol (S : Type) :=
  CProt {
      (*Account id *)
      acc : address;
      (* Initial balance *)
      init_bal : nat;
      (* Initial state of a protocol *)
      init_state : S;
      (* Protocol comes with a set of transitions *)
      transitions : seq (ctransition S);
      (* All transitions have unique tags *)
      _ : uniq (map (@ttag _) transitions)
    }.

Definition tags {S : Type} (p : Protocol S) :=
  map (@ttag _) (transitions p).

End Protocol.

Section Semantics.

Variables (S : Type) (p : Protocol S).

(* Blockchain schedules *)
Definition schedule := seq (bstate * message).

(* In a well-formed schedule block numbers only grow *)
Fixpoint wf_sched (sch : schedule) :=
  if sch is s :: sch'
  then let bnum := block_num s.1 in
       all [pred s' | bnum <= block_num s'.1] sch' && wf_sched sch'
  else true.

Record step :=
  Step {
      pre  : cstate S;
      post : cstate S;
      out  : option message
  }.

Definition trace := seq step.

Definition apply_prot id bal s m bc : (S * option message) :=
  let n  := seq.find (fun t => ttag t == method m) (transitions p) in
  let tr := nth (idle S) (transitions p) n in
  let f  := tfun tr in
  f id bal s m bc.

Definition step_prot pre bc m : step :=
  let: CState id bal s := pre in
  let: (s', out) := apply_prot id bal s m bc in
  let: bal' := if out is Some m' then (bal + val m) - val m' else bal in
  let: post := CState id bal' s' in
  Step pre post out.

(* Map a schedule into a trace *)
Fixpoint execute (pre : cstate S) (sc: schedule) : trace :=
  if sc is (bc, m) :: sc'
  then let stp := step_prot pre bc m in
       stp :: execute (post stp) sc'
  else [::].

Definition state0 := CState (acc p) (init_bal p) (init_state p).

(* Execute from the initial contract state,
   if schedule is empty, repeat the initial state *)
Definition execute0 sc :=
  if sc is _ :: _
  then execute state0 sc
  else [:: Step state0 state0 None].

(****************************************************************)
(* Safety property:

For any state s in _any_ trace, starting from the initial one,
the unary property I holds (i.e., I s).

*)
(****************************************************************)
Definition safe (I : cstate S -> Prop) : Prop :=
  forall sc pre post out,
    Step pre post out \In execute0 sc -> I pre /\ I post.

Lemma bad_tag_step bc m s :
  method m \notin (tags p) -> post (step_prot s bc m) = s.
Proof.
move=>M; rewrite /step_prot; case: s=>id bal s.
rewrite [apply_prot _ _ _ _ _]surjective_pairing/=.
rewrite /apply_prot.
suff X : seq.find (fun t : ctransition S => ttag t == method m) (transitions p) =
         size (transitions p).
by rewrite !X !nth_default ?leqnn//.
move: (find_size (fun t : ctransition S => ttag t == method m) (transitions p)).
rewrite leq_eqVlt; case/orP; first by move/eqP.
rewrite -has_find=>G. suff X: False by [].
rewrite /tags in M; clear s bal id bc.
elim: (transitions p) G M=>//t ts Hi/=.
case/orP; last by move=> {}/Hi Hi H; apply: Hi; rewrite inE in H; case/norP: H.
by move/eqP=>->; rewrite inE eqxx.
Qed.

(* A strong induction principle for proving safety *)
Lemma safe_ind (I : cstate S -> Prop) :
  I state0 ->
  (forall pre bc m,
      (method m \in tags p) -> I pre -> I (post (step_prot pre bc m))) ->
  safe I.
Proof.
move=>H1 H2; case=>[|[bc m] sc] pre pst out; first by case; case=>->->.
case/In_cons=>[E|];[| rewrite -/execute].
- have Z: pst = post (step_prot state0 bc m) by rewrite -E.
  subst pst; split.
  + suff Z: pre = state0 by subst pre.
    move: E; rewrite /step_prot/=.
    by rewrite [apply_prot _ _ _ _ _]surjective_pairing; case.
  case M: (method m \in tags p); first by apply: H2.
  by rewrite bad_tag_step// M.
have Hp: I (post (step_prot state0 bc m)).
- case M: (method m \in tags p); first by apply: H2.
  by rewrite bad_tag_step// M.
move: (post (step_prot state0 bc m)) Hp=>s Hi G; clear H1 bc m.
elim: sc s Hi G=>//[[bc m] sc] Hi s Is.
case/In_cons=>[E|];[|rewrite -/execute]; last first.
- move/Hi=>H; apply: H.
  case M: (method m \in tags p); first by apply: H2.
  by rewrite bad_tag_step// M.
suff Z: s = pre /\ pst = post (step_prot pre bc m).
- case: Z=>??; subst pre pst; split=>//.
  case M: (method m \in tags p); first by apply: H2.
  by rewrite bad_tag_step// M.
move: E; rewrite /step_prot/=; clear Is.
case: s=>id bal s; rewrite [apply_prot _ _ _ _ _]surjective_pairing.
by case=>->; rewrite {4}[apply_prot id bal s m bc]surjective_pairing.
Qed.

(*****************************************************)
(*            Some modal connectives                 *)
(*****************************************************)

Definition reachable' (st st' : cstate S) sc :=
  st' = post (last (Step st st None) (execute st sc)).

Definition reachable (st st' : cstate S) :=
  exists sc, reachable' st st' sc.

(* q holds since p , as long as schedule bits satisfy r. *)
Definition since_as_long
           (p : cstate S -> Prop)
           (q : cstate S -> cstate S -> Prop)
           (r : bstate * message -> Prop) :=
  forall sc st st',
    p st ->
    (forall b, b \In sc -> r b) ->
    reachable' st st' sc ->
    q st st'.

End Semantics.


Require Import Coq.Logic.Decidable.
Require Import PeanoNat.
Require Import Coq.Strings.String.
Require Import Ascii.
Require Import Bool.
Require Import Nat.

Inductive Map (A : Type) : Type :=
| MEmpty : Map A
| MCons : string -> A -> Map A -> Map A
.

Arguments MEmpty {A}.
Arguments MCons {A}.

Notation "v |=> T ; M" := (MCons v T M) (at level 40).

Ltac breakStrDec :=
  simpl in *;
  repeat match goal with
  | [ |- context [string_dec ?v ?v'] ] =>
      destruct (string_dec v v'); subst; try easy
  | [ H: context [string_dec ?v ?v'] |- _ ] =>
      destruct (string_dec v v') in H; subst; try easy
end.

Fixpoint In {A} M var : option A :=
  match M with
  | MEmpty => None
  | var' |=> T; M' => if string_dec var var' then Some T else In M' var
  end.

Lemma InEq' : forall A (M : Map A) var r r',
    In (var |=> r; M) var = Some r' -> r = r'.
Proof. intros. breakStrDec. congruence. Qed.

Lemma InEq : forall A (M : Map A) var r, In (var |=> r; M) var = Some r.
Proof. intros; breakStrDec. Qed.

Lemma InNotEq : forall A (M : Map A) var var' r r',
    var <> var' -> In (var' |=> r; M) var = r' -> In M var = r'.
Proof. intros; breakStrDec. Qed.

Lemma InNotEq' : forall A (M : Map A) var var' r,
    var <> var' -> In (var' |=> r; M) var = In M var.
Proof. intros; breakStrDec. Qed.

Definition inclusion {A} (M : Map A) M' :=
  forall x v, In M x = Some v -> In M' x = Some v.

Lemma inclusion_empty : forall A (M : Map A), inclusion MEmpty M.
Proof. unfold inclusion. inversion 1. Qed.

Lemma inclusion_refl : forall A (M : Map A), inclusion M M.
Proof. unfold inclusion. trivial. Qed.

Lemma inclusion_update : forall A (M : Map A) M' var tvar,
  inclusion M M' -> inclusion (var |=> tvar ; M) (var |=> tvar ; M').
Proof.
  unfold inclusion; intros; breakStrDec; auto.
Qed.

Lemma inclusion_shadow : forall A (M : Map A) var t1 t2,
  inclusion (var |=> t1; (var |=> t2; M)) (var |=> t1; M).
Proof.
  unfold inclusion; intros; breakStrDec.
Qed.

Lemma inclusion_shadow' : forall A (M : Map A) var t1 t2,
  inclusion (var |=> t1; M) (var |=> t1; (var |=> t2; M)).
Proof.
  unfold inclusion; intros; breakStrDec.
Qed.

Lemma inclusion_permute : forall A (M : Map A) var1 var2 t1 t2,
  var1 <> var2 ->
  inclusion (var1 |=> t1; (var2 |=> t2; M))
            (var2 |=> t2; (var1 |=> t1; M)).
Proof.
  unfold inclusion; intros; breakStrDec.
Qed.

Lemma InInclusionEq : forall A (M M' : Map A) var t,
    inclusion (var |=> t; M) M' ->
    In M' var = Some t.
Proof.
  unfold inclusion; eauto using InEq.
Qed.

Lemma InInclusion : forall A (M M' : Map A) var t,
    inclusion (var |=> t; M) M' ->
    In M' var = Some t.
Proof.
  unfold inclusion; intros; eauto using InEq.
Qed.

Definition map_eq {A} (M M' : Map A) := forall var, In M var = In M' var.

Lemma map_eq_In : forall {A} (M M': Map A) var v v',
    In M' var = Some v ->
    map_eq (var |=> v'; M) M' ->
    v = v'.
Proof.
  intros * HI HEq.
  replace (In M' var) with (Some v') in *; try congruence.
  specialize (HEq var). rewrite InEq in HEq. congruence.
Qed.

Lemma map_eq_incl : forall {A} (M M': Map A),
    map_eq M M' -> inclusion M M'.
Proof.
  unfold inclusion; unfold map_eq; intros; congruence.
Qed.

(* map_eq is an equivalence relation *)

Lemma map_eq_refl : forall A (M : Map A), map_eq M M.
Proof. unfold map_eq; trivial. Qed.

Lemma map_eq_sym : forall A (M M': Map A), map_eq M M' -> map_eq M' M.
Proof. unfold map_eq; auto. Qed.

Lemma map_eq_trans : forall A (M M' M'': Map A),
    map_eq M M' ->
    map_eq M' M'' ->
    map_eq M M''.
Proof. unfold map_eq; intros; congruence. Qed.

Lemma eqeq_shadow : forall A (M M' : Map A) var v v',
   map_eq (var |=> v'; M) M' ->
   map_eq (var |=> v; M) (var |=> v; M').
Proof.
  intros * H1.
  intros var'.
  breakStrDec.
  specialize (H1 var').
  rewrite InNotEq' in H1; trivial.
Qed.

Lemma eq_shadow : forall A (M : Map A) var v v',
   map_eq (var |=> v; M) (var |=> v; (var |=> v'; M)).
Proof.
  intros; eauto using eqeq_shadow, map_eq_refl.
Qed.

Lemma eqeq_permute : forall A (M M' : Map A) var var' v v',
   map_eq (var |=> v; M) M' ->
   var <> var' ->
   map_eq (var |=> v; (var' |=> v'; M)) (var' |=> v'; M').
Proof.
  intros * H ?.
  intros var0.
  specialize (H var0).
  breakStrDec.
Qed.


(** * Lemmas about the common part of the interface of the CFG parser *)
Require Import Coq.Classes.RelationClasses Coq.Setoids.Setoid.
Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.

Set Implicit Arguments.

Local Open Scope string_like_scope.

Local Coercion is_true : bool >-> Sortclass.

Section recursive_descent_parser.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {G : grammar Char}
          {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G _}.

  Lemma remove_nonterminal_3
        {ls ps ps'} (H0 : is_valid_nonterminal ls ps = false)
  : is_valid_nonterminal (remove_nonterminal ls ps) ps' = is_valid_nonterminal ls ps'.
  Proof.
    case_eq (is_valid_nonterminal (remove_nonterminal ls ps) ps');
    case_eq (is_valid_nonterminal ls ps');
    intros H' H'';
    try reflexivity;
    exfalso;
    first [ apply remove_nonterminal_1 in H''
          | apply remove_nonterminal_2 in H''; destruct H''; subst ];
    congruence.
  Qed.

  Lemma remove_nonterminal_4
        {ls ps ps'} (H0 : is_valid_nonterminal (remove_nonterminal ls ps) ps')
  : ps <> ps'.
  Proof.
    intro H'.
    pose proof (proj2 (remove_nonterminal_2 ls _ _) (or_intror H')).
    congruence.
  Qed.

  Lemma remove_nonterminal_5
        {ls ps ps'} (H0 : ps <> ps')
  : is_valid_nonterminal (remove_nonterminal ls ps) ps' = is_valid_nonterminal ls ps'.
  Proof.
    case_eq (is_valid_nonterminal (remove_nonterminal ls ps) ps');
    case_eq (is_valid_nonterminal ls ps');
    intros H' H'';
    try reflexivity;
    exfalso;
    first [ apply remove_nonterminal_1 in H''
          | apply remove_nonterminal_2 in H''; destruct H''; subst ];
    congruence.
  Qed.

  Lemma remove_nonterminal_6
        ls ps
  : is_valid_nonterminal (remove_nonterminal ls ps) ps = false.
  Proof.
    apply remove_nonterminal_2; right; reflexivity.
  Qed.

  Global Instance sub_nonterminals_listT_Reflexive : Reflexive sub_nonterminals_listT
    := fun x y f => f.

  Global Instance sub_nonterminals_listT_Transitive : Transitive sub_nonterminals_listT.
  Proof.
    lazy; auto.
  Defined.

  Global Add Parametric Morphism : remove_nonterminal
  with signature sub_nonterminals_listT ==> eq ==> sub_nonterminals_listT
    as remove_nonterminal_mor.
  Proof.
    intros x y H0 z w H'.
    hnf in H0.
    pose proof (remove_nonterminal_4 H').
    apply remove_nonterminal_1 in H'.
    rewrite remove_nonterminal_5 by assumption.
    auto.
  Qed.

  Lemma sub_nonterminals_listT_remove ls ps
  : sub_nonterminals_listT (remove_nonterminal ls ps) ls.
  Proof.
    intros p.
    apply remove_nonterminal_1.
  Qed.

  Lemma sub_nonterminals_listT_remove_2 {ls ls' ps} (H : sub_nonterminals_listT ls ls')
  : sub_nonterminals_listT (remove_nonterminal ls ps) ls'.
  Proof.
    etransitivity; eauto using sub_nonterminals_listT_remove.
  Qed.

  Lemma sub_nonterminals_listT_remove_3 {ls ls' p}
        (H0 : is_valid_nonterminal ls p = false)
        (H1 : sub_nonterminals_listT ls ls')
  : sub_nonterminals_listT ls (remove_nonterminal ls' p).
  Proof.
    intros p' H'.
    rewrite remove_nonterminal_5; intuition (subst; eauto; congruence).
  Qed.

  Lemma remove_nonterminal_noninc' {ls nt}
  : nonterminals_length (remove_nonterminal ls nt) <= nonterminals_length ls.
  Proof.
    apply Nat.nlt_ge.
    apply remove_nonterminal_noninc.
  Qed.

  Lemma nonempty_nonterminals {ls nt} (H : is_valid_nonterminal ls nt)
  : 0 < nonterminals_length ls.
  Proof.
    eapply Lt.le_lt_trans;
    [ apply Le.le_0_n
    | exact (remove_nonterminal_dec ls nt H) ].
  Qed.

  Lemma nonempty_nonterminals' {ls nt} (H : is_valid_nonterminal ls nt)
  : negb (EqNat.beq_nat (nonterminals_length ls) 0).
  Proof.
    pose proof (nonempty_nonterminals H).
    destruct (nonterminals_length ls); simpl; try reflexivity; try omega.
  Qed.

  Lemma nonterminal_to_production_correct'
    : forall nt,
      is_valid_nonterminal initial_nonterminals_data nt
      -> List.map to_production (nonterminal_to_production nt)
         = Lookup G (to_nonterminal nt).
  Proof.
    intros nt H.
    rewrite <- (of_to_nonterminal nt) at 1 by assumption.
    rewrite nonterminal_to_production_correct by (apply initial_nonterminals_correct'; assumption).
    reflexivity.
  Qed.

  Lemma is_valid_nonterminal_of_to_nonterminal valids nt
    : sub_nonterminals_listT valids initial_nonterminals_data
      -> is_valid_nonterminal valids (of_nonterminal (to_nonterminal nt)) = is_valid_nonterminal valids nt.
  Proof.
    intro Hvalid.
    match goal with
    | [ |- ?lhs = ?rhs ] => destruct lhs eqn:?, rhs eqn:?; first [ reflexivity | exfalso ]
    end;
      repeat match goal with
             | [ H : is_valid_nonterminal _ _ = _ |- False ]
               => rewrite of_to_nonterminal in H
             | _ => congruence
             | _ => apply Hvalid; assumption
             | _ => rewrite initial_nonterminals_correct', <- initial_nonterminals_correct; apply Hvalid; assumption
             end.
  Qed.
End recursive_descent_parser.


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


Load loadpath.
Require Import msl.base msl.sepalg.
Require Import veristar.variables.

(** Separation Logic Interface

   This module type axiomatizes the types and operators upon which our
   soundness proof depends.

   NOTE: This module type will probably be made obsolete sometime in the future
   (if we ever get back to working on this project).

   We now believe it's better to axiomatize the separation logic directly
   (i.e., its proof theory) as opposed to axiomatizing the /models/ of the
   separation logic, which is what we do here. *)

Module Type VERISTAR_LOGIC.

(** Locations and values *)

Parameters loc val : Type.
Declare Instance Join_val: Join val.
Declare Instance Perm_val: Perm_alg val.
Declare Instance Sep_val: Sep_alg val.
Declare Instance Canc_val: Canc_alg val.
Parameter val2loc : val -> option loc.
Parameter nil_val : val.
Axiom nil_not_loc : val2loc nil_val = None.

(** The empty value: read "undefined" *)

Parameter empty_val : val.
Axiom emp_empty_val : forall v, identity v <-> v = empty_val.
Definition full (v : val) := forall v2, joins v v2 -> identity v2.
Axiom val2loc_full : forall v l, val2loc v = Some l -> full v.
Axiom nil_full : full nil_val.
Axiom empty_not_full : ~full empty_val.
Axiom val2loc_inj : forall v1 v2 l,
  val2loc v1 = Some l ->  val2loc v2 = Some l -> v1=v2.
Axiom loc_eq_dec : forall l1 l2 : loc, Decidable.decidable (l1=l2).
Axiom nil_dec : forall v, Decidable.decidable (v=nil_val).

(** Variables, environments *)

Definition var : Type := Ident.t.
Parameter env : Type.
Parameter env_get : env -> var -> val.
Parameter env_set : var -> val -> env -> env.
Axiom gss_env : forall (x : var) (v : val) (s : env),
  v<>empty_val -> env_get (env_set x v s) x = v.
Axiom gso_env : forall (x y : var) (v : val) (s : env),
  x<>y -> env_get (env_set x v s) y = env_get s y.
(* For now, we assume vars are defined locations (i.e., we don't yet model
   data fields or deal with undefined vars; that is future work).
   In general, our soundness proof doesn't require the user to exhibit an
   empty environment anyway. *)
(*Parameter empty_env : env.*)
(*Axiom env_gempty : forall x, env_get empty_env x = empty_val.*)
Axiom env_reset : forall s x, env_set x (env_get s x) s = s.
Axiom env_reset2 : forall s x z, env_set x (env_get s x) (env_set x z s) = s.

(** Heaps *)

Parameter heap : Type.
Declare Instance Join_heap: Join heap.
Declare Instance Perm_heap: Perm_alg heap.
Declare Instance Sep_heap: Sep_alg heap.
Declare Instance Canc_heap: Canc_alg heap.
Parameter rawnext: forall (x: loc) (y : val) (s : heap), Prop.
Parameter emp_at : forall (l: loc) (h: heap), Prop.
Axiom heap_gempty : forall h l, identity h -> emp_at l h.
Definition nil_or_loc (v: val) := v=nil_val \/ exists l, val2loc v = Some l.
Axiom mk_heap_rawnext : forall h x0 x y, val2loc (x0) = Some x ->
  nil_or_loc y -> exists h', rawnext x y h' /\ comparable h h'.
Axiom rawnext_out : forall {x x0 x' y h},
  rawnext x y h -> val2loc x0 = Some x' -> x'<>x -> emp_at x' h.

Definition rawnext' x y h := exists h0, join_sub h0 h /\ rawnext x y h0.

Axiom rawnext_at1 : forall {x y h1 h2 h},
  rawnext' x y h1 -> join h1 h2 h -> emp_at x h2 /\ rawnext' x y h.

Axiom rawnext_at2 : forall {x y h1 h2 h},
  join h1 h2 h -> rawnext' x y h -> emp_at x h2 -> rawnext' x y h1.

Axiom  rawnext_not_emp : forall {x y h}, rawnext' x y h -> ~emp_at x h.

Axiom emp_at_join: forall {h1 h2 h},
  join h1 h2 h -> forall l, (emp_at l h1 /\ emp_at l h2) <-> emp_at l h.

Axiom rawnext_unique : forall x z z' s s' t t' r,
  rawnext x z s -> rawnext x z' s' -> join s t r -> join s' t' r ->
  z' = z /\ s'=s.

Axiom vars_defined_locs : forall z (e : env),
  exists v, env_get e z = v /\ nil_or_loc v.

End VERISTAR_LOGIC.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
From Heaps
Require Import pred prelude idynamic ordtype pcm finmap unionmap heap coding.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition Hash := [ordType of nat].

Record Block {Transaction VProof : eqType} :=
  mkB {
    prevBlockHash : Hash;
    txs : seq Transaction;
    proof : VProof;
  }.

Definition eq_block {T P : eqType} (b b' : @Block T P) :=
  match (b, b') with
  | (mkB p t pf, mkB p' t' pf') =>
    [&& p == p', t == t' & pf == pf']
  end.

Lemma eq_blockP {T P : eqType} : Equality.axiom (@eq_block T P).
Proof.
case=> p t pf; case=> p' t' pf'; rewrite /eq_block/=.
case H2: (p == p'); [move/eqP: H2=>?; subst p'| constructor 2];
  last by case=>?; subst p';rewrite eqxx in H2.
case H3: (t == t'); [move/eqP: H3=>?; subst t'| constructor 2];
  last by case=>?; subst t';rewrite eqxx in H3.
case H4: (pf == pf'); [move/eqP: H4=>?; subst pf'| constructor 2];
  last by case=>?; subst pf';rewrite eqxx in H4.
by constructor 1.
Qed.

Canonical Block_eqMixin {T P : eqType} :=
  Eval hnf in EqMixin (@eq_blockP T P).
Canonical Block_eqType {T P : eqType} :=
  Eval hnf in EqType (@Block T P) (@Block_eqMixin T P).

(* Strict version of the prefix *)
Definition is_strict_prefix {T: eqType} (bc bc' : seq T) :=
  exists b bc1, bc' = bc ++ (b :: bc1).

Notation "'[' bc1 '<<<' bc2 ']'" := (is_strict_prefix bc1 bc2).

Fixpoint sprefixb {T: eqType} (s1 s2 : seq T) :=
  if s2 is y :: s2' then
    if s1 is x :: s1' then (x == y) && (sprefixb s1' s2')
    else true
  else false.

(* Non-strict prefix *)
Definition is_prefix {T :eqType} (bc bc' : seq T) :=
  exists bc1, bc' = bc ++ bc1.

Notation "'[' bc1 '<<=' bc2 ']'" := (is_prefix bc1 bc2).

(* Decidable fork *)
Definition fork {T: eqType} (bc1 bc2 : seq T) :=
  ~~[|| sprefixb bc1 bc2, sprefixb bc2 bc1 | bc1 == bc2].

Definition Address := nat.
Definition Timestamp := nat.

Parameter VProof : eqType.
Parameter Transaction : eqType.

Definition block := @Block Transaction VProof.
Parameter GenesisBlock : block.

Definition Blockchain := seq block.

(* In fact, it's a forrest, as it also keeps orphan blocks *)
Definition BlockTree := union_map Hash block.

Parameter hashT : Transaction -> Hash.
Parameter hashB : block -> Hash.
Parameter genProof : Address -> Blockchain -> option VProof.
Parameter VAF : VProof -> Timestamp -> Blockchain -> bool.
Parameter FCR : Blockchain -> Blockchain -> bool.

(* Transaction pools *)
Definition TxPool := seq Transaction.

(* Transaction is valid and consistent with the given chain *)
Parameter txValid : Transaction -> Blockchain -> bool.
Parameter tpExtend : TxPool -> BlockTree -> Transaction -> TxPool.

Notation "A > B" := (FCR A B).
Notation "A >= B" := (A = B \/ A > B).
Notation "# b" := (hashB b) (at level 20).
Notation "## b" := (hashB b \\-> tt) (at level 80).

Definition bcLast (bc : Blockchain) := last GenesisBlock bc.

Definition subchain (bc1 bc2 : Blockchain) := exists p q, bc2 = p ++ bc1 ++ q.

(* 1.  Genesis block properties *)

Hypothesis init_hash : prevBlockHash GenesisBlock = #GenesisBlock.

Hypothesis init_tx : txs GenesisBlock = [::].

(* 2.  Transaction validation *)

Hypothesis txValid_nil : forall t, txValid t [::].

(* 3.  Hashes *)

Hypothesis hashB_inj : injective hashB.

Hypothesis hashT_inj : injective hashT.

(* 4.  VAF *)

(* This axiom seems reasonable: it shouldn't be possible
   to generate a block _from_ the chain it is supposed to tail.  *)
Hypothesis VAF_nocycle :
  forall (b : block) ts (bc : Blockchain), VAF (proof b) ts bc -> b \notin bc.

(* 2. FCR *)

Hypothesis FCR_subchain :
  forall bc1 bc2, subchain bc1 bc2 -> bc2 >= bc1.

Hypothesis FCR_ext :
  forall (bc : Blockchain) (b : block) (ext : seq block),
    bc ++ (b :: ext) > bc.

Hypothesis FCR_rel :
  forall (A B : Blockchain),
    A = B \/ A > B \/ B > A.

Hypothesis FCR_nrefl :
  forall (bc : Blockchain), bc > bc -> False.

Hypothesis FCR_trans :
  forall (A B C : Blockchain), A > B -> B > C -> A > C.

Definition btHasBlock (bt : BlockTree) (b : block) := #b \in dom bt.

Notation "b ∈ bt" := (btHasBlock bt b) (at level 70).
Notation "b ∉ bt" := (~~ btHasBlock bt b) (at level 70).

Definition valid_block b : bool :=
  prevBlockHash b != #b.

Definition has_init_block (bt : BlockTree) :=
  find (# GenesisBlock) bt = Some GenesisBlock.

Definition validH (bt : BlockTree) :=
  forall h b, find h bt = Some b -> h = hashB b.

(* We only add "fresh blocks" *)
Definition btExtend (bt : BlockTree) (b : block) :=
  if #b \in dom bt then bt else #b \\-> b \+ bt.

Definition next_of (bt : BlockTree) b : pred Block :=
  [pred b' | (hashB b == prevBlockHash b') && (hashB b' \in dom bt)].

(* All paths/chains should start with the GenesisBlock *)
Fixpoint compute_chain' (bt : BlockTree) b remaining n : Blockchain :=
  (* Preventing cycles in chains *)
  if (hashB b) \in remaining
  then
    let rest := seq.rem (hashB b) remaining in
    (* Supporting primitive inductions *)
    if n is n'.+1 then
      match find (prevBlockHash b) bt with
      (* No parent *)
      | None => [:: b]
      (* Build chain prefix recursively *)
      | Some prev =>
        rcons (nosimpl (compute_chain' (free (hashB b) bt) prev rest n')) b
      end
    else [::]
  else [::].

(* Compute chain from the block *)
Definition compute_chain bt b :=
  compute_chain' bt b (keys_of bt) (size (keys_of bt)).

(* Total get_block function *)
Definition get_block (bt : BlockTree) k : Block :=
  if find k bt is Some b then b else GenesisBlock.

(* Collect all blocks *)
Definition all_blocks (bt : BlockTree) := [seq get_block bt k | k <- keys_of bt].

Definition is_block_in (bt : BlockTree) b := exists k, find k bt = Some b.

(* All chains from the given tree *)
Definition good_chain (bc : Blockchain) :=
  if bc is h :: _ then h == GenesisBlock else false.

(* Transaction validity *)
Fixpoint tx_valid_chain' (bc prefix : seq block) :=
  if bc is b :: bc'
  then [&& all [pred t | txValid t prefix] (txs b) &
        tx_valid_chain' bc' (rcons prefix b)]
  else true.

Definition tx_valid_chain bc := tx_valid_chain' bc [::].

Definition all_chains bt := [seq compute_chain bt b | b <- all_blocks bt].

Definition good_chains bt := [seq c <- all_chains bt | good_chain c && tx_valid_chain c].

(* Get the blockchain *)
Definition take_better_bc bc2 bc1 :=
  if (good_chain bc2 && tx_valid_chain bc2) && (bc2 > bc1) then bc2 else bc1.

Definition btChain bt : Blockchain :=
  foldr take_better_bc [:: GenesisBlock] (all_chains bt).

Definition tx_valid_block bc (b : block) := all [pred t | txValid t bc] (txs b).

Definition good_bt bt :=
  forall b, b \in all_blocks bt ->
            good_chain (compute_chain bt b) && tx_valid_chain (compute_chain bt b).

(* Implementation of PoS protocol as a STS *)
Definition nid := nat.
Definition peers_t := seq nid.

Inductive Message :=
  | NullMsg
  | AddrMsg of peers_t
  | ConnectMsg
  | BlockMsg of block
  | TxMsg of Transaction
  | InvMsg of seq Hash
  | GetDataMsg of Hash.

Inductive MessageType :=
  | MNull
  | MAddr
  | MConnect
  | MBlock
  | MTx
  | MInv
  | MGetData.

Definition msg_type (msg : Message) : MessageType :=
  match msg with
  | NullMsg => MNull
  | AddrMsg _ => MAddr
  | ConnectMsg => MConnect
  | BlockMsg _ => MBlock
  | TxMsg _ => MTx
  | InvMsg _ => MInv
  | GetDataMsg _ => MGetData
  end.

Definition msg_block (msg : Message) : block :=
  match msg with
  | BlockMsg b => b
  | _ => GenesisBlock
  end.

Definition msg_hashes (msg : Message) : seq Hash :=
  match msg with
  | InvMsg sh => sh
  | GetDataMsg h => [:: h]
  | _ => [::]
  end.

Definition eq_msg a b :=
 match a, b with
  | NullMsg, NullMsg => true
  | NullMsg, _ => false
  | AddrMsg prsA, AddrMsg prsB => (prsA == prsB)
  | AddrMsg _, _ => false
  | ConnectMsg, ConnectMsg => true
  | ConnectMsg, _ => false
  | BlockMsg bA, BlockMsg bB => (bA == bB)
  | BlockMsg _, _ => false
  | TxMsg tA, TxMsg tB => (tA == tB)
  | TxMsg _, _ => false
  | InvMsg hA, InvMsg hB => (hA == hB)
  | InvMsg _, _ => false
  | GetDataMsg hA, GetDataMsg hB => (hA == hB)
  | GetDataMsg _, _ => false
 end.

Ltac simple_tactic mb n n' B :=
  (case: mb=>//[|n' p'|n'|b'|t'|p' h'|p' h']; do? [by constructor 2];
   case B: (n == n'); [by case/eqP:B=><-; constructor 1|constructor 2];
   case=>E; subst n'; rewrite eqxx in B).

Lemma eq_msgP : Equality.axiom eq_msg.
Proof.
move=> ma mb. rewrite/eq_msg.
case: ma=>[|p||b|t|h|h].
- case: mb=>//[|p'||b'|t'|h'|h']; do? [by constructor 2]; by constructor 1.
- case: mb=>//[|p'||b'|t'|h'|h']; do? [by constructor 2].
  case B: ((p == p')).
  - by move/eqP:B=><-; constructor 1.
  by constructor 2; case=>Z; subst p'; rewrite eqxx in B.
- case:mb=>////[|p'||b'|t'|h'|h']; do? [by constructor 2|by constructor 1].
- case:mb=>////[|p'||b'|t'|h'|h']; do? [by constructor 2].
  case B: (b == b'); [by case/eqP:B=><-; constructor 1|constructor 2].
  by case=>Z; subst b'; rewrite eqxx in B.
- case:mb=>////[|p'||b'|t'|h'|h']; do? [by constructor 2].
  case B: (t == t'); [by case/eqP:B=><-; constructor 1|constructor 2].
  by case=>Z; subst t'; rewrite eqxx in B.
- case:mb=>////[|p'||b'|t'|h'|h']; do? [by constructor 2].
  case B: (h == h'); [by case/eqP:B=><-; constructor 1|constructor 2].
  by case=>Z; subst h'; rewrite eqxx in B.
- case:mb=>////[|p'||b'|t'|h'|h']; do? [by constructor 2].
  case B: (h == h'); [by case/eqP:B=><-; constructor 1|constructor 2].
  by case=>Z; subst h'; rewrite eqxx in B.
Qed.

Canonical Msg_eqMixin := Eval hnf in EqMixin eq_msgP.
Canonical Msg_eqType := Eval hnf in EqType Message Msg_eqMixin.

Record Packet := mkP {src: nid; dst: nid; msg: Message}.
Definition NullPacket := mkP 0 0 NullMsg.

Definition eq_pkt a b :=
  ((src a) == (src b)) && ((dst a) == (dst b)) && ((msg a) == (msg b)).

Lemma eq_pktP : Equality.axiom eq_pkt.
Proof.
case=>sa da ma [sb] db mb; rewrite/eq_pkt/=.
case P1: (sa == sb)=>/=; last by constructor 2; case=>/eqP; rewrite P1.
case P2: (da == db)=>/=; last by constructor 2; case=> _ /eqP; rewrite P2.
case P3: (ma == mb)=>/=; last by constructor 2; case=> _ _ /eqP; rewrite P3.
by constructor 1; move/eqP: P1=><-; move/eqP: P2=><-; move/eqP: P3=><-.
Qed.

Canonical Packet_eqMixin := Eval hnf in EqMixin eq_pktP.
Canonical Packet_eqType := Eval hnf in EqType Packet Packet_eqMixin.

Record State :=
  Node {
    id : nid;
    peers : peers_t;
    blockTree : BlockTree;
    txPool : TxPool;
  }.

Definition Init (n : nid) : State :=
  Node n [:: n] (#GenesisBlock \\-> GenesisBlock) [::].

Definition ToSend := seq Packet.
Definition emitZero : ToSend := [:: NullPacket].
Definition emitOne (packet : Packet) : ToSend := [:: packet].
Definition emitMany (packets : ToSend) := packets.

Definition emitBroadcast (from : nid) (dst : seq nid) (msg : Message) :=
  [seq (mkP from to msg) | to <- dst].

Definition procMsg (st: State) (from : nid) (msg: Message) (ts: Timestamp) :=
    let: (Node n prs bt pool) := st in
    match msg with
    | ConnectMsg =>
      let: ownHashes := (keys_of bt) ++ [seq hashT t | t <- pool] in
      pair (Node n (undup (from :: prs)) bt pool)
           (emitOne(mkP n from (InvMsg ownHashes)))

    | AddrMsg knownPeers =>
      let: newP := [seq x <- knownPeers | x \notin prs] in
      let: connects := [seq mkP n p ConnectMsg | p <- newP] in
      let: updP := undup (prs ++ newP) in
      pair (Node n updP bt pool)
           (emitMany(connects) ++ emitBroadcast n prs (AddrMsg updP))

    | BlockMsg b =>
      let: newBt := (btExtend bt b) in
      let: newPool := [seq t <- pool | txValid t (btChain newBt)] in
      let: ownHashes := (keys_of newBt) ++ [seq hashT t | t <- newPool] in
      pair (Node n prs newBt newPool) (emitBroadcast n prs (InvMsg ownHashes))

    | TxMsg tx =>
      let: newPool := tpExtend pool bt tx in
      let: ownHashes := (keys_of bt) ++ [seq hashT t | t <- newPool] in
      pair (Node n prs bt newPool) (emitBroadcast n prs (InvMsg ownHashes))

    | InvMsg peerHashes =>
      let: ownHashes := (keys_of bt) ++ [seq hashT t | t <- pool] in
      let: newH := [seq h <- peerHashes | h \notin ownHashes] in
      let: gets := [seq mkP n from (GetDataMsg h) | h <- newH] in
      pair st (emitMany(gets))

    | GetDataMsg h =>
      (* Do not respond to yourself *)
      if from == n then pair st emitZero else
      let: matchingBlocks := [:: get_block bt h] in
      let: matchingTxs := [seq t <- pool | (hashT t) == h] in
      match ohead matchingBlocks with
      | Some(b) =>
        pair (Node n prs bt pool) (emitOne(mkP n from (BlockMsg b)))
      | _ =>
        match ohead matchingTxs with
        | Some (tx) =>
          pair (Node n prs bt pool) (emitOne(mkP n from (TxMsg tx)))
        | _ => pair st emitZero
        end
      end

    | NullMsg => pair st emitZero
    end.

Inductive InternalTransition :=
  | TxT of Transaction
  | MintT.

Definition procInt (st : State) (tr : InternalTransition) (ts : Timestamp) :=
    let: (Node n prs bt pool) := st in
    match tr with
    | TxT tx => pair st (emitBroadcast n prs (TxMsg tx))

    (* Assumption: nodes broadcast to themselves as well! => simplifies logic *)
    | MintT =>
      let: bc := (btChain bt) in
      let: attempt := genProof n bc in
      match attempt with
      | Some(pf) =>
          if VAF pf ts bc then
            let: allowedTxs := [seq t <- pool | txValid t bc] in
            let: prevBlock := (last GenesisBlock bc) in
            let: block := mkB (hashB prevBlock) allowedTxs pf in

            if tx_valid_block (btChain bt) block then
              let: newBt := (btExtend bt block) in
              let: newPool := [seq t <- pool | txValid t (btChain newBt)] in
              let: ownHashes := (keys_of newBt) ++ [seq hashT t | t <- newPool] in
              pair (Node n prs newBt newPool) (emitBroadcast n prs (BlockMsg block))
            else
              pair st emitZero

          else
            pair st emitZero

      | _ => pair st emitZero
      end
    end.

Definition StateMap := union_map [ordType of nid] State.

Fixpoint initState n : StateMap :=
  if n is n'.+1 then (n \\-> Init n) \+ (initState n') else Unit.

Definition PacketSoup := seq Packet.

Record World :=
  mkW {
    localState : StateMap;
    inFlightMsgs : PacketSoup;
    consumedMsgs : PacketSoup;
  }.

Definition holds (n : nid) (w : World) (cond : State -> Prop) :=
  forall (st : State),
    find n (localState w) = Some st -> cond st.

Definition Coh (w : World) :=
  [/\ valid (localState w),
     forall (n : nid),
       holds n w (fun st => id st == n),
     forall (n : nid),
       holds n w (fun st => valid (blockTree st)),
     forall (n : nid),
       holds n w (fun st => validH (blockTree st)),
     forall (n : nid),
       holds n w (fun st => has_init_block (blockTree st)) &
     forall (n : nid),
       holds n w (fun st => uniq (peers st))
  ].

Record Qualifier := Q { ts: Timestamp; allowed: nid; }.

Inductive system_step (w w' : World) (q : Qualifier) : Prop :=
| Idle of Coh w /\ w = w'
| Deliver (p : Packet) (st : State) of
      Coh w & (dst p) = allowed q &
      p \in inFlightMsgs w &
      find (dst p) (localState w) = Some st &
      let: (st', ms) := procMsg st (src p) (msg p) (ts q) in
      w' = mkW (upd (dst p) st' (localState w))
               (seq.rem p (inFlightMsgs w) ++ ms)
               (rcons (consumedMsgs w) p)
| Intern (proc : nid) (t : InternalTransition) (st : State) of
      Coh w & proc = allowed q &
      find proc (localState w) = Some st &
      let: (st', ms) := (procInt st t (ts q)) in
      w' = mkW (upd proc st' (localState w))
               (ms ++ (inFlightMsgs w))
               (consumedMsgs w).

Definition Schedule := seq Qualifier.

Fixpoint reachable' (s : Schedule) (w w' : World) : Prop :=
  if s is (ins :: insts)
  then exists via, reachable' insts w via /\ system_step via w' ins
  else w = w'.

Definition reachable (w w' : World) :=
  exists s, reachable' s w w'.

Definition initWorld N := mkW (initState N) [::] [::].


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

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

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 48;
    bitwidth := 64;
    s := 2^192;
    c := [(1, 1); (2^64, 1)];
    carry_chains := Some [[0; 3]; [1; 0; 2; 3]; [1; 0]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


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

(***
Modulus : 2^512 - 569
Base: 21 + 1/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 24%nat;
    base := 21 + 1/3;
    bitwidth := 32;
    s := 2^512;
    c := [(1, 569)];
    carry_chains := Some [seq 0 (pred 24); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


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

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import FulfillStep.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import SimThread.
Require Import Compatibility.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive split_release: forall (i1 i2:Instr.t), Prop :=
| split_release_store
    l v:
    split_release (Instr.store l v Ordering.acqrel) (Instr.store l v Ordering.strong_relaxed)
| split_release_update
    r l rmw or
    (OR: Ordering.le or Ordering.strong_relaxed):
    split_release (Instr.update r l rmw or Ordering.acqrel) (Instr.update r l rmw or Ordering.strong_relaxed)
.

Inductive sim_released: forall (st_src:(Language.state lang)) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                          (st_tgt:(Language.state lang)) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_released_intro
    i_src i_tgt rs
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    (SPLIT: split_release i_src i_tgt)
    (LOCAL: sim_local SimPromises.bot lc1_src lc1_tgt)
    (RELEASED: forall l, View.le (TView.cur (Local.tview lc1_tgt)) ((TView.rel (Local.tview lc1_tgt)) l))
    (SC: TimeMap.le sc1_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt):
    sim_released
      (State.mk rs [Stmt.instr i_src]) lc1_src sc1_src mem1_src
      (State.mk rs [Stmt.instr i_tgt]) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_released_mon
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      sc2_tgt mem2_tgt
      (SIM1: sim_released st_src lc_src sc1_src mem1_src
                          st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future_weak mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future_weak mem1_tgt mem2_tgt)
      (SC1: TimeMap.le sc2_src sc2_tgt)
      (MEM1: sim_memory mem2_src mem2_tgt)
      (WF_SRC: Local.wf lc_src mem2_src)
      (WF_TGT: Local.wf lc_tgt mem2_tgt)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt)
      (MEM_SRC: Memory.closed mem2_src)
      (MEM_TGT: Memory.closed mem2_tgt):
  sim_released st_src lc_src sc2_src mem2_src
               st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  inv SIM1. econs; eauto.
Qed.

Lemma sim_local_fulfill_released
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released Ordering.strong_relaxed lc2_tgt sc2_tgt)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (RELEASED1: View.le (TView.cur (Local.tview lc1_tgt)) (View.join ((TView.rel (Local.tview lc1_tgt)) loc) (View.singleton_ur loc to)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src released Ordering.acqrel lc2_src sc2_src>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src Ordering.acqrel)
     (TView.write_released (Local.tview lc1_tgt) sc2_tgt loc to releasedm_tgt Ordering.strong_relaxed)).
  { unfold TView.write_released, TView.write_tview. ss. viewtac;
      try econs; repeat (condtac; aggrtac); try apply WF1_TGT.
    rewrite <- View.join_r. etrans; eauto. apply LOCAL1.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src Ordering.acqrel)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove_bot; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  { econs. ss. }
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  { apply WF1_TGT. }
  i. des. esplits.
  - econs; eauto.
    inv WRITABLE. econs; ss. eapply TimeFacts.le_lt_lt; [apply LOCAL1|apply TS].
  - econs; eauto. s.
    unfold TView.write_tview, View.singleton_ur_if. repeat (condtac; aggrtac).
    econs; repeat (condtac; aggrtac);
      (try by etrans; [apply LOCAL1|aggrtac]);
      (try by rewrite <- ? View.join_r; econs; aggrtac);
      (try apply WF1_TGT).
    + ss. i. unfold LocFun.find. repeat (condtac; aggrtac).
      * etrans; eauto. apply LOCAL1.
      * apply LOCAL1.
    + ss. aggrtac; try apply WF1_TGT. rewrite <- ? View.join_l. apply LOCAL1.
    + ss. aggrtac; try apply WF1_TGT. rewrite <- ? View.join_l. apply LOCAL1.
  - ss.
Qed.

Lemma sim_local_write_released
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt Ordering.strong_relaxed lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src lc1_tgt)
      (RELEASED1: View.le (TView.cur (Local.tview lc1_tgt)) (View.join ((TView.rel (Local.tview lc1_tgt)) loc) (View.singleton_ur loc to)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src released_src Ordering.acqrel lc2_src sc2_src mem2_src kind>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src lc2_tgt>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_promise_bot; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_fulfill_released; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  { by inv STEP1. }
  i. des.
  exploit promise_fulfill_write_sim_memory; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. hexploit ORD; eauto. i. des. splits; ss.
    eapply sim_local_nonsynch_loc; eauto.
  }
  i. des. esplits; eauto. etrans; eauto.
Qed.

Lemma sim_released_step
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      (SIM: sim_released st1_src lc1_src sc1_src mem1_src
                         st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  _sim_thread_step lang lang ((sim_thread (sim_terminal eq)) \8/ sim_released)
                   st1_src lc1_src sc1_src mem1_src
                   st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  inv SIM. ii.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    right.
    exploit Local.promise_step_future; eauto. i. des.
    exploit sim_local_promise; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs. econs; eauto.
    + eauto.
    + right. econs; eauto.
      inv LOCAL0. ss.
  - (* update-load *)
    right.
    exploit sim_local_read; (try by etrans; eauto); eauto; try refl. i. des.
    esplits; eauto; ss.
    + econs 2. econs 2. econs; [|econs 2]; eauto. econs. econs. eauto.
    + eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
  - (* write *)
    right.
    hexploit sim_local_write_released; (try by etrans; eauto); eauto; try refl; try by econs.
    { by rewrite <- View.join_l. }
    i. des.
    esplits; eauto; ss.
    + econs 2. econs 2. econs; [|econs 3]; eauto. econs. econs.
    + ss.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
  - (* update *)
    right.
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read; (try by etrans; eauto); eauto; try refl; try by econs. i. des.
    exploit Local.read_step_future; eauto. i. des.
    hexploit sim_local_write_released; (try by etrans; eauto); eauto; try refl; try by econs.
    { assert (TS: Time.lt tsr tsw).
      { inv LOCAL2. eapply MemoryFacts.MemoryFacts.write_time_lt. eauto. }
      inv LOCAL1. ss. repeat (condtac; aggrtac); try by apply WF_TGT.
      destruct ordr; ss.
    }
    i. des.
    esplits; eauto; ss.
    + econs 2. econs 2. econs; [|econs 4]; eauto. econs. econs. eauto.
    + ss.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
Qed.

Lemma sim_released_sim_thread:
  sim_released <8= (sim_thread (sim_terminal eq)).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - inv TERMINAL_TGT. inv PR; ss.
  - right. esplits; eauto.
    inv PR. eapply sim_local_memory_bot; eauto.
  - exploit sim_released_mon; eauto. i.
    exploit sim_released_step; eauto. i. des; eauto.
    + right. esplits; eauto.
      left. eapply paco9_mon; eauto. ss.
    + right. esplits; eauto.
Qed.

Lemma split_release_sim_stmts
      i_src i_tgt
      (SPLIT: split_release i_src i_tgt):
  sim_stmts eq
            [Stmt.instr i_src]
            [Stmt.instr (Instr.fence Ordering.plain Ordering.acqrel); Stmt.instr i_tgt]
            eq.
Proof.
  pcofix CIH. ii. subst. pfold. ii. splits; ii.
  { inv TERMINAL_TGT. }
  { right. esplits; eauto.
    inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
  }
  right.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR); ss.
  - (* promise *)
    exploit sim_local_promise; eauto. i. des.
    esplits; try apply SC; eauto; ss.
    econs 2. econs 1; eauto. econs; eauto. eauto.
  - (* fence *)
    exploit Local.fence_step_future; eauto. i. des.
    esplits.
    + ss.
    + eauto.
    + econs 1.
    + ss.
    + inv LOCAL1. ss.
    + ss.
    + left. eapply paco9_mon; [apply sim_released_sim_thread|]; ss.
      inv LOCAL1. econs; eauto.
      * inv LOCAL. econs; ss. etrans; eauto.
      * s. i. repeat condtac; ss. refl.
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 conj5eqsynthconj3 : forall  (lv0 : natural), (@eq natural (mult lv0 Zero) (mult Zero Zero)).
Admitted.
QuickChick conj5eqsynthconj3.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L.Computability Require Import Enum.
From Undecidability.L.Functions Require Import Encoding Equality.
From Undecidability.L.Datatypes Require Import LNat Lists LProd.
Require Import Undecidability.Shared.Libs.PSL.Base Nat List Datatypes.

Set Default Proof Using "Type".
Import Nat.
(* ** Enumeratibility of L-terms *)
#[global]
Instance term_appCross : computableTime' appCross (fun A _ => (5,fun B _ => (length A * length B * 29 + length A * 46 +  4,tt))).
Proof.
  extract. solverec. fold appCross;rewrite map_time_const,map_length.
  unfold c__map, c__app. Lia.nia.
Qed.

#[global]
Instance term_exh_size : computable exh_size.
Proof.
  extract.
Qed.

Definition T_nondec_helper A x : bool
  :=  negb (inb term_eqb x A)  .

Fixpoint T_nondec (n : nat) : list term :=
  match n with
  | 0 => [# n]
  | S n0 =>
    T_nondec n0 ++
             [# (S n0)] ++
             filter (T_nondec_helper (T_nondec n0)) (map lam (T_nondec n0) ++ appCross (T_nondec n0) (T_nondec n0))
  end.

Lemma T_nondec_correct : forall n, T n = T_nondec n.
Proof.
  induction n. reflexivity.
  simpl. unfold T_nondec_helper. do 2 f_equal. rewrite <-IHn.
  generalize ((map lam (T n) ++ appCross (T n) (T n)): list term). generalize (T n).
  induction l0. simpl.  reflexivity.
  simpl.
  rewrite IHl0.
  edestruct (inb_spec term_eqb_spec a l);dec;try (exfalso;tauto);reflexivity.
Qed.

Local Instance term_T_nondec : computable T_nondec.
Proof.
  assert (computable T_nondec_helper).
  extract.
  extract.
Qed.

#[global]
Instance term_T : computable T.
Proof.
  eapply computableExt with (x:= T_nondec).  2:exact _.
  repeat intro. symmetry. apply T_nondec_correct.
Qed.

#[global]
Instance term_g_inv : computable g_inv.
Proof. unfold g_inv.
       extract.
Qed.

Definition g_nondec s :=
  match pos_nondec term_eqb s (T (exh_size s)) with
  | Some n => n
  | None => 0
  end.

Lemma g_nondec_correct : forall n, g n = g_nondec n.
Proof.
  unfold g, g_nondec.
  setoid_rewrite pos_nondec_spec. reflexivity. apply term_eqb_spec.
Qed.

Local Instance term_g_nondec : computable g_nondec.
Proof.
  unfold g_nondec.
  extract.
Qed.

#[global]
Instance term_g : computable g.
Proof.
  eapply computableExt with (x:= g_nondec).  2:exact _.
  repeat intro. symmetry. apply g_nondec_correct.
Qed.

Local Definition f_filter A x := negb (inb (prod_eqb Nat.eqb Nat.eqb) x A).
Local Definition f_map (p : nat * nat) := let (p1, p2) := p in (p1, S p2).

Fixpoint C_nondec (n : nat) : list (nat * nat) :=
  match n with
  | 0 => [(0, 0)]
  | S n0 => let C' := C_nondec n0 in
           C' ++
              (S n0, 0)
              :: filter (f_filter C')
              (map f_map C')
  end.

Lemma C_nondec_correct : forall n, C n = C_nondec n.
Proof.
  induction n. reflexivity.
  simpl. do 2 f_equal. rewrite <-IHn. fold f_map.
  generalize ((map f_map (C n))). generalize (C n).
  induction l0;cbn. reflexivity.
  rewrite IHl0. unfold f_filter at 3.
  edestruct (inb_spec (prod_eqb_spec Nat.eqb_spec Nat.eqb_spec) a l); decide (~ a el l); try (exfalso;tauto);reflexivity.
Qed.

Local Instance term_C_nondec : computable C_nondec.
Proof.
  assert (computable f_filter) by extract.
  assert (computable f_map) by extract.
  extract.
Qed.

#[global]
Instance term_C : computable C.
Proof.
  eapply computableExt with (x:= C_nondec).  2:exact _.
  repeat intro. symmetry. apply C_nondec_correct.
Qed.

#[global]
Instance term_eSize : computable eSize.
Proof.
  extract.
Qed.

#[global]
Instance term_c : computable c.
Proof.
  extract.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal82.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal82_rev_append_49_append_nil/goal82_lfind_orig.ml"  adtind.goal82.append adtind.goal82.rev.
Success.


From Minirust.def Require Import ty le.
Require Import Datatypes Coq.Init.Byte List Lia.
Import ListNotations.

Section le.

Context {memory: Memory}.

Inductive LeAbstractByte : AbstractByte -> AbstractByte -> Type :=
  | LUninit b : LeAbstractByte Uninit b
  | LNoProv x o : LeAbstractByte (Init x None) (Init x o)
  | LWithProv x p : LeAbstractByte (Init x (Some p)) (Init x (Some p)).

Lemma mk_le_abstract_byte (b1 b2 : AbstractByte) (p: le b1 b2) : LeAbstractByte b1 b2.
Proof.
destruct b1.
- apply LUninit.
- destruct b2.
-- unfold le in p. destruct o; destruct p.
-- unfold le in p.
destruct o.
--- destruct o0.
---- destruct p. rewrite H. rewrite H0. apply LWithProv.
---- destruct p.
--- rewrite p. apply LNoProv.
Qed.

Inductive LeList : list AbstractByte -> list AbstractByte -> Type :=
  | LEmpty : LeList [] []
  | LLe b1 b2 l1' l2' : LeList l1' l2' -> LeAbstractByte b1 b2 -> le (b1::l1') (b2::l2') -> LeList (b1::l1') (b2::l2').

Lemma mk_le_list (l1 : list AbstractByte) : forall l2, le l1 l2 -> LeList l1 l2.
Proof.
induction l1 as [|b1 l1' H].
- intros l2 p. destruct l2 as [|b2 l2'].
-- apply LEmpty; reflexivity.
-- destruct p.
- intros l2 p.
  destruct l2 as [|b2 l2'].
--  destruct p.
-- apply LLe.
--- apply H. destruct p. assumption.
--- destruct p. apply mk_le_abstract_byte. assumption.
--- assumption.
Qed.

(* le refl *)

Lemma le_list_gen_refl {T: Type} (l : list T) {_: DefinedRelation T} (Q: forall (t: T), le t t) : le l l.
Proof.
simpl.
induction l as [|t l IH].
- simpl. trivial.
- simpl.
  split.
-- apply Q.
-- apply IH.
Qed.

Lemma le_option_gen_refl {T: Type} (o: option T) {_: DefinedRelation T} (Q: forall (t: T), le t t) : le o o.
Proof.
destruct o.
- apply Q.
- simpl. trivial.
Qed.

Lemma le_abstract_byte_refl (x : AbstractByte) : le x x.
Proof.
destruct x.
- simpl. trivial.
- destruct o.
-- simpl. auto.
-- simpl. auto.
Qed.

Lemma le_list_abstract_byte_refl (l : list AbstractByte) : le l l.
Proof.
apply (le_list_gen_refl l le_abstract_byte_refl).
Qed.

Fixpoint le_val_refl (v : Value) : le v v.
Proof.
destruct v eqn:E.
- simpl. reflexivity.
- simpl. reflexivity.
- destruct o;
  simpl;
  split;
  auto.
  destruct (P_EQ_REFLECT p p); auto.
- generalize dependent v.
  induction l as [|t l IH].
-- simpl. trivial.
-- split.
--- apply le_val_refl.
--- eapply (IH (VTuple l)). reflexivity.

- unfold le. unfold Value_DefinedRelation.
  apply (le_list_gen_refl l (le_list_abstract_byte_refl)).
Qed.

Lemma le_option_val_refl (o: option Value) : le o o.
Proof.
apply le_option_gen_refl.
apply le_val_refl.
Qed.

Lemma le_list_step {T} {x1 x2 : T} {_: DefinedRelation T} {l1 l2} : le (x1 :: l1) (x2 :: l2) = (le x1 x2 /\ le l1 l2).
Proof.
auto.
Qed.

Lemma le_len [T] {l1 l2 : list T} {_: DefinedRelation T} (H: le l1 l2)
  : length l1 = length l2.
Proof.
generalize dependent l2.

induction l1 as [|x1 l1 IH].
{ intros. simpl in H. destruct l2; auto. contradict H. }

intros.
destruct l2.
{ contradict H. }

simpl.
f_equal.
apply IH.
inversion H.
auto.
Qed.

Lemma le_nth [T] {l1 l2 : list T} {_: DefinedRelation T}
  (default: T)
  (Hlen : length l1 = length l2)
  (H : forall i, i < length l1 -> le (nth i l1 default) (nth i l2 default)) :
le l1 l2.
Proof.
generalize dependent l2.
induction l1 as [|x1 l1 IH].
{ intros. destruct l2; try discriminate Hlen. simpl. auto. }

intros.
destruct l2 as [|x2 l2].
{ simpl in Hlen. discriminate Hlen. }

simpl.
split.
{ apply (H 0). simpl. lia. }

apply IH.
{ simpl in Hlen. inversion Hlen. auto. }

intros.
apply (H (S i)).
simpl. lia.
Qed.

Lemma le_nth_rev {T j} {l1 l2: list T} {_: DefinedRelation T}
  (default: T)
  {refl: forall (x: T), le x x}
  (H: le l1 l2)
  : le (nth j l1 default) (nth j l2 default).
Proof.
generalize dependent l2.
generalize dependent j.
induction l1 as [|x1 l1 IH].
{ intros. destruct l2; try contradiction H. apply refl. }

intros.
destruct l2 as [|x2 l2].
{ simpl in H. contradict H. }

destruct j.
{ inversion H. simpl. auto. }

simpl.
apply IH.
inversion H.
auto.
Qed.

End le.