(** * Vminus: A Simple SSA Intermediate Representation *)

(** This file defines the syntax and semantics for Vminus, an
    intermediate representation that is intended to capture the
    essence of LLVM's IR.  In particular, this language represents
    code as a _control flow graph_ whose blocks contain instructions
    in _static single assignment_ form.  This means that each
    instruction _defines_ (at most) one local identifier and that
    those identifiers are _immutable_.  To make this work in practice,
    SSA representations introduce the notation of _phi functions_,
    whose value is determined by the run-time control flow of the
    program.

    To support mutable state, Vminus also has Imp-style global
    identifiers.
*)

Require Import Arith List.
Import ListNotations.

Require Import Vminus.Classes Vminus.Atom Vminus.Util.

Instance eq_dec_atom : eq_dec Atom.t := Atom.eq_dec.
Hint Resolve eq_dec_atom.
Hint Resolve Atom.eq_dec.
Hint Resolve eq_nat_dec.

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Vminus labels, identifiers, and addresses.  *)

(** Basic block labels *)

Module Lbl := Atom.
Notation lbl := Lbl.t.

(** Local unique identifiers *)

Module Uid := Atom.
Notation uid := Uid.t.

(** Addresses of mutable state *)

Module Addr := Atom.
Notation addr := Addr.t.

(** All come equipped with decidable equality. *)

Definition eq_dec_lbl : forall l1 l2, {l1 = l2} + {l1 <> l2} := Atom.eq_dec.
Hint Resolve eq_dec_lbl.

Definition eq_dec_uid : forall u1 u2, {u1 = u2} + {u1 <> u2} := Atom.eq_dec.
Hint Resolve eq_dec_uid.

Definition eq_dec_addr : forall a1 a2, {a1 = a2} + {a1 <> a2} := Atom.eq_dec.
Hint Resolve eq_dec_addr.

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Values and Binary Operations *)

(** Values are just local identifiers or natural numbers *)

Inductive val : Set :=
 | val_uid  : uid -> val
 | val_nat : nat -> val.

Definition eq_dec_val : forall (v1 v2:val) , {v1 = v2} + {v1 <> v2}.
Proof.
  decide equality.
Defined.
Instance eq_val : eq_dec val := eq_dec_val.
Hint Resolve eq_dec_val.

(** All Vminus operations are binary arithmetic forms.  There are no unary
    operations, nor are there assembly-language-like [move] instructions.  *)

Inductive bop : Set :=
 | bop_add   (* addition *)
 | bop_sub   (* subtraction *)
 | bop_mul   (* multiplication *)
 | bop_eq    (* equality *)
 | bop_le    (* less-than-or-equal *)
 | bop_and   (* both non-zero *)
.

Definition eq_dec_bop : forall (b1 b2:bop), {b1 = b2} + {b1 <> b2}.
Proof.
  decide equality.
Defined.
Instance eq_bop : eq_dec bop := eq_dec_bop.
Hint Resolve eq_dec_bop.

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Basic block terminators *)

(** Each basic block is a sequence of commands (defined next) ending in a
    _terminator_, which is just a control flow operation.  Terminators cannot
    appear in the middle of a well-formed basic block.  (We will define
    well-formed Vminus programs later.)  *)

Inductive tmn : Set :=
| tmn_jmp : lbl -> tmn                  (* unconditional jump *)
| tmn_cbr : val -> lbl -> lbl -> tmn    (* conditional branch *)
| tmn_ret : tmn.                        (* return *)

Definition eq_dec_tmn : forall (t1 t2:tmn), {t1 = t2} + {t1 <> t2}.
Proof.
  decide equality.
Defined.
Instance eq_tmn : eq_dec tmn := eq_dec_tmn.
Hint Resolve eq_dec_tmn.

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Commands *)

(** Vminus has only a few commands: binary operations,
    terminators, phi nodes, and [load] and [store] operations. *)

(** Each [phiarg] associates a value with a predessor block, given by
    a [lbl]. *)

Definition phiarg := (lbl * val)%type.

Definition eq_dec_phiarg:
  forall phiarg1 phiarg2: phiarg, {phiarg1 = phiarg2} + {phiarg1 <> phiarg2}.
Proof.
  decide equality.
Defined.
Instance eq_phiarg : eq_dec phiarg := eq_dec_phiarg.
Hint Resolve eq_dec_phiarg.

Definition eq_dec_list_phiarg:
  forall l1 l2 : list phiarg, {l1 = l2} + {~(l1 = l2)}.
Proof.
  decide equality.
Defined.
Hint Resolve eq_dec_list_phiarg.

(** Vminus Commands *)

Inductive cmd : Set :=
| cmd_bop   : bop -> val -> val -> cmd
| cmd_phi   : list phiarg -> cmd
| cmd_tmn   : tmn -> cmd
| cmd_load  : addr -> cmd
| cmd_store : addr -> val -> cmd.

Definition eq_dec_cmd: forall cmd1 cmd2: cmd, {cmd1 = cmd2} + {~(cmd1 = cmd2)}.
Proof.
  decide equality.
Defined.
Instance eq_cmd : eq_dec cmd := eq_dec_cmd.
Hint Resolve eq_dec_cmd.

(** An instruction associates a unique local identifier with one of the
    above commands. The local identifier serves two purposes:

    - it uniquely identifies this occurrence of the command
    - it serves as the value

*)

Definition insn := (uid * cmd)%type.

Definition eq_dec_insn:
  forall insn1 insn2: insn, {insn1 = insn2} + {~(insn1 = insn2)}.
Proof.
  decide equality.
Defined.
Instance eq_insn : eq_dec insn := eq_dec_insn.
Hint Resolve eq_dec_insn.

(**  ------------------------------------------------------------------------- *)
(* ----------------------------------------------------------------- *)
(** *** Useful predicates about instructions *)

(** Which values are used by an instruction? *)
Definition insn_uses (i:insn) : list val :=
  match i with
    | (_, cmd_bop _ v1 v2) => [v1; v2]
    | (_, cmd_phi pas) => map (@snd _ _) pas
    | (_, cmd_tmn (tmn_cbr v _ _)) => [v]
    | (_, cmd_store _ v) => [v]
    | (_, _) => []
  end.

(** Which labels appear in an instruction? *)
Definition insn_lbls (i:insn) : list lbl :=
  match i with
    | (_, cmd_tmn (tmn_jmp l)) => [l]
    | (_, cmd_tmn (tmn_cbr _ l1 l2)) => [l1; l2]
    | _ => []
  end.

(** Which phi arguments appear in an instruction? *)
Definition insn_phis (i:insn) : list phiarg :=
  match i with
    | (_, cmd_phi pas) => pas
    | _ => []
  end.

(** Is it a terminator? *)
Definition is_tmn (i:insn) : Prop :=
  match i with (_, cmd_tmn _) => True | _ => False end.

(** Is is a phi node? *)
Definition is_phi (i:insn) : Prop :=
  match i with (_, cmd_phi _) => True | _ => False end.

Lemma is_phi_decidable : forall i, {is_phi i} + {~is_phi i}.
Proof.
  intros [? c].
  destruct c; simpl; tauto.
Qed.

(** Does it define its uid? *)
Definition defs_uid (i:insn) : Prop :=
  match i with
    | (_, cmd_tmn _) | (_, cmd_store _ _) => False | _ => True
  end.


(* * FOL Reductions *)

From Undecidability.PCP Require Import PCP Util.PCP_facts.
From Undecidability.FOL Require Import Deduction.FragmentNDFacts Semantics.Tarski.FragmentFacts Semantics.Tarski.FragmentSoundness Syntax.Core Syntax.Facts.
From Undecidability.FOL.Undecidability Require Import FOL.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ReducibilityFacts.
Require Import Undecidability.PCP.Reductions.PCPb_iff_dPCPb.

Set Default Proof Using "Type".

(* ** Validity *)

Local Definition BSRS := list(card bool).
Local Notation "x / y" := (x, y).

Notation t_f b t := (func (s_f b) (Vector.cons _ t _ (Vector.nil _))).
Notation t_e := (func s_e (Vector.nil _)).
Notation Pr t t' := (@atom _ sig_pred _ _ sPr (Vector.cons _ t _ (Vector.cons _ t' _ (Vector.nil _)))).
Notation Q := (atom sQ (Vector.nil _)).

Notation i_f b i :=
  (@i_func _ _ _ _ (s_f b) (Vector.cons _ i _ (Vector.nil _))).

Notation i_Pr i i' :=
  (@i_atom _ _ _ _ sPr (Vector.cons _ i _ (Vector.cons _ i' _ (Vector.nil _)))).

Section validity.

  Context {ff : falsity_flag}.
  Variable R : BSRS.

  Fixpoint prep (x : string bool) (t : term) : term :=
    match x with
    | nil => t
    | b::x => t_f b (prep x t)
    end.

  Definition enc s := (prep s t_e).

  Lemma prep_app x y t :
    prep (x ++ y) t = prep x (prep y t).
  Proof.
    induction x; cbn; trivial. now rewrite <- IHx.
  Qed.

  Fixpoint iprep {domain} {I : interp domain} (x : list bool) (y : domain) :=
    match x with
    | nil => y
    | b::x => i_f b (iprep x y)
    end.

  Definition F1 := map (fun '(x,y) => Pr (enc x) (enc y)) R.
  Definition F2 := map (fun '(x, y) => ∀ ∀ Pr $1 $0 → Pr (prep x $1) (prep y $0)) R.
  Definition F3 := (∀ Pr $0 $0 → Q).

  Definition F : form := F1 ==> F2 ==> F3 → Q.

  Lemma iprep_eval domain (I : interp domain) rho x s :
    eval rho (prep x s) = iprep x (eval rho s).
  Proof.
    induction x; cbn; trivial. now rewrite <- IHx.
  Qed.

  Lemma iprep_app domain (I : interp domain) x y d :
    iprep (x ++ y) d = iprep x (iprep y d).
  Proof.
    induction x; cbn; trivial. now rewrite <- IHx.
  Qed.

  Global Instance IB : interp (string bool).
  Proof using R.
    split; intros [] v.
    - exact (b :: Vector.hd v).
    - exact nil.
    - exact (derivable R (Vector.hd v) (Vector.hd (Vector.tl v))).
    - exact (dPCPb R).
  Defined.

  Lemma IB_prep rho s t :
    eval rho (prep s t) = s ++ eval rho t.
  Proof.
    induction s; cbn; trivial.
    rewrite <- IHs. reflexivity.
  Qed.

  Lemma IB_enc rho s :
    eval rho (enc s) = s.
  Proof.
    unfold enc. rewrite IB_prep.
    cbn. apply app_nil_r.
  Qed.

  Lemma IB_drv rho t1 t2 :
    rho ⊨ (Pr t1 t2) <-> derivable R (eval rho t1) (eval rho t2).
  Proof.
    cbn. reflexivity.
  Qed.

  Lemma IB_F1 rho :
    rho ⊫ F1.
  Proof.
    unfold F1.
    intros ? ([x y] & <- & ?) % in_map_iff.
    cbn. econstructor. now rewrite !IB_enc.
  Qed.

  Lemma IB_F2 rho :
    rho ⊫ F2.
  Proof.
    unfold F2. intros ? ([x y] & <- & ?) % in_map_iff u v ?. cbn.
    rewrite !IB_prep. cbn in *. eauto using der_sing, der_cons.
  Qed.

  Lemma IB_F3 rho :
    rho ⊨ F3.
  Proof.
    cbn. unfold dPCPb, dPCP. eauto.
  Qed.

  Lemma IB_F rho :
    rho ⊨ F -> dPCPb R.
  Proof.
    intros H. unfold F in H. rewrite !impl_sat in H. eapply H.
    - eapply IB_F1.
    - eapply IB_F2.
    - apply IB_F3.
  Qed.

  Lemma drv_val domain (I : interp domain) rho u v :
    derivable R u v -> rho ⊨ (F1 ==> F2 ==> Pr (enc u) (enc v)).
  Proof.
    rewrite !impl_sat. intros. induction H.
    - eapply H0. eapply in_map_iff. exists (x/y). eauto.
    - eapply (H1 (∀ ∀ Pr $1 $0 → Pr (prep x $1) (prep y $0))) in IHderivable.
      + cbn in *. unfold enc in *. rewrite !iprep_eval in *. cbn in *.
        rewrite <- !iprep_app in IHderivable. eapply IHderivable.
      + eapply in_map_iff. exists (x/y). eauto.
  Qed.

  Theorem BPCP_valid :
    PCPb R <-> valid F.
  Proof.
    rewrite PCPb_iff_dPCPb. split.
    - intros [u H] D I rho.
      eapply (@drv_val _ I) in H. unfold F. cbn in *.
      rewrite !impl_sat in *. cbn in *.
      intros. eapply (H2 (eval rho (enc u))). eauto.
    - intros H. apply IB_F with (rho := fun _ => nil), H.
  Qed.

  (* ** Provability *)

  Definition ctx_S :=
    F3 :: rev F2 ++ rev F1.

  Lemma prep_subst sigma t x :
    subst_term sigma (prep x t) = prep x (subst_term sigma t).
  Proof.
    induction x; cbn; congruence.
  Qed.

  Lemma drv_prv (s : peirce) u v :
    derivable R u v -> ctx_S ⊢ Pr (enc u) (enc v).
  Proof.
    induction 1.
    - apply Ctx. right. eapply in_app_iff. right.
      rewrite <- in_rev. eapply in_map_iff. exists (x/y). eauto.
    - assert (ctx_S ⊢ ∀ ∀ Pr $1 $0 → Pr (prep x $1) (prep y $0)).
      + apply Ctx. right. eapply in_app_iff. left.
        rewrite <- in_rev. eapply in_map_iff. exists (x/y). eauto.
      + eapply AllE with (t := enc u) in H1; eauto.
        cbn in H1. rewrite !prep_subst in H1. cbn in H1.
        eapply AllE with (t := enc v) in H1; eauto. cbn in H1.
        unfold enc in H1. rewrite !prep_subst in H1. cbn in H1.
        unfold enc. rewrite !prep_app.
        eapply (IE H1). eassumption.
  Qed.

  Lemma BPCP_prv' (s : peirce) :
    dPCPb R -> [] ⊢ F.
  Proof.
    intros [u H].
    apply drv_prv with (s:=s) in H. unfold F.
    repeat eapply impl_prv. simpl_list. eapply II.
    assert (ctx_S ⊢ (∀ Pr $0 $0 → Q)).
    apply Ctx. now unfold ctx_S. eapply AllE with  (t := enc u) in H0.
    cbn in H0. now eapply (IE H0).
  Qed.

End validity.

Theorem BPCP_prv R :
  PCPb R <-> nil ⊢M (F R).
Proof.
  rewrite PCPb_iff_dPCPb. split.
  - apply BPCP_prv'.
  - intros H % soundness'. eapply PCPb_iff_dPCPb. now apply (@BPCP_valid falsity_off R).
Qed.

(* ** Satisfiability *)

Lemma valid_satis phi :
  valid phi -> ~ satis (¬ phi).
Proof.
  intros H1 (D & I & rho & H2).
  apply H2, (H1 D I rho).
Qed.

Theorem BPCP_satis R :
  ~ PCPb R <-> satis (¬ F R).
Proof.
  rewrite PCPb_iff_dPCPb. split.
  - intros H. exists (list bool), (IB R), (fun _ => nil).
    intros H'. cbn. apply H, (IB_F H').
  - rewrite <- PCPb_iff_dPCPb. intros H1 H2 % (BPCP_valid R (ff:=falsity_on)).
    apply (valid_satis H2), H1.
Qed.

(* ** Reduction theorems *)

Corollary valid_star_red :
  PCPb ⪯ FOL*_valid.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_valid R).
Qed.

Theorem prv_red :
  PCPb ⪯ FOL*_prv_intu.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_prv R).
Qed.

Corollary valid_red :
  PCPb ⪯ FOL_valid.
Proof.
  exists (fun R => F R). intros R. apply (BPCP_valid R).
Qed.

Theorem satis_red :
  complement PCPb ⪯ FOL_satis.
Proof.
  exists (fun R => ¬ F R). intros R. apply (BPCP_satis R).
Qed.

(* ** Corollaries *)

Lemma form_discrete {ff : falsity_flag} :
  discrete (form ff).
Proof.
  apply discrete_iff. constructor. apply dec_form.
  - intros ? ?. unfold dec. repeat decide equality.
  - intros ? ?. unfold dec. repeat decide equality.
  - intros [] []. now left.
  - intros [] []. now left.
Qed.

#[export] Hint Resolve stack_enum form_discrete : core.

Definition UA :=
  ~ enumerable (complement PCPb).

Corollary valid_undec :
  UA -> ~ decidable (@valid _ _ falsity_off).
Proof.
  intros H. now apply (not_decidable valid_star_red).
Qed.

Corollary valid_unenum :
  UA -> ~ enumerable (complement (@valid _ _ falsity_off)).
Proof.
  intros H. now apply (not_coenumerable valid_star_red).
Qed.

Corollary prv_undec :
  UA -> ~ decidable (@prv _ _ falsity_off intu nil).
Proof.
  intros H. now apply (not_decidable prv_red).
Qed.

Corollary prv_unenum :
  UA -> ~ enumerable (complement (@prv _ _ falsity_off intu nil)).
Proof.
  intros H. apply (not_coenumerable prv_red); trivial.
Qed.

Corollary satis_undec :
  UA -> ~ decidable (@satis _ _ falsity_on).
Proof.
  intros H1 H2 % (dec_red satis_red).
  now apply H1, dec_count_enum.
Qed.

Corollary satis_enum :
  UA -> ~ enumerable (@satis _ _ falsity_on).
Proof.
  intros H1 H2 % (enumerable_red satis_red); auto.
Qed.

(* ** Non-Standard Model *)

Module NonStan. Section Nonstan.

  Variable R : BSRS.
  Context {ff : falsity_flag}.

  Instance IB : interp (option (string bool)).
  Proof using R.
    split; intros [] v.
    - exact (match Vector.hd v with Some u => Some (b :: u) | None => None end).
    - exact (Some nil).
    - exact (match Vector.hd v, Vector.hd (Vector.tl v) with Some u, Some v => derivable R u v | _, _ => True end).
    - exact False.
  Defined.

  Lemma IB_eval_Some rho t u v :
    eval rho t = Some v -> eval rho (prep u t) = Some (u ++ v).
  Proof.
    intros H. induction u; cbn; trivial.
    unfold prep in IHu. fold prep in IHu. now rewrite IHu.
  Qed.

  Lemma IB_eval_None rho t u :
    eval rho t = None -> eval rho (prep u t) = None.
  Proof.
    intros H. induction u; cbn; trivial.
    unfold prep in IHu. fold prep in IHu. now rewrite IHu.
  Qed.

  Lemma IB_enc rho u :
    eval rho (enc u) = Some u.
  Proof.
    unfold enc. rewrite <- (app_nil_r u) at 2.
    now apply IB_eval_Some.
  Qed.

  Lemma IB_deriv rho u v :
    rho ⊨ (Pr (enc u) (enc v)) <-> derivable R u v.
  Proof.
    cbn. rewrite !IB_enc. reflexivity.
  Qed.

  Lemma IB_deriv' rho t1 t2 u v :
    eval rho t1 = Some u -> eval rho t2 = Some v ->
    rho ⊨ (Pr t1 t2) <-> derivable R u v.
  Proof.
    intros H1 H2. cbn. rewrite H1, H2. reflexivity.
  Qed.

  Lemma IB_F1 rho :
    rho ⊫ F1 R.
  Proof.
    unfold F1.
    intros ? ([x y] & <- & ?) % in_map_iff.
    cbn. rewrite !IB_enc. now constructor.
  Qed.

  Lemma IB_F2 rho :
    rho ⊫ F2 R.
  Proof.
    unfold F2. intros ? ([x y] & <- & ?) % in_map_iff [u|] [v|] ?; cbn in *.
    - erewrite !IB_eval_Some; cbn; auto. now constructor 2.
    - erewrite IB_eval_Some, IB_eval_None; cbn; auto.
    - erewrite IB_eval_None; cbn; auto.
    - erewrite !IB_eval_None; cbn; auto.
  Qed.

  Lemma IB_F rho :
    rho ⊨ F R.
  Proof.
    unfold F. rewrite !impl_sat. intros _ _ H.
    apply (H None). cbn. auto.
  Qed.

  Lemma IB_nonstandard rho :
    rho ⊨ ¬ ∀ ¬ Pr $0 $0.
  Proof.
    intros H. apply (H None). cbn. auto.
  Qed.

End Nonstan. End NonStan.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import Epsilon.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext machine_int multi_int encode_decode.
Require Import ssrnat_ext.
Require Import integral_type uniq_tac.
Import MachineInt.
Require Import mips_bipl mips_tactics mips_syntax.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.

Require Import multi_zero_s_prg multi_zero_s_simu multi_zero_s_safe_termination.
Require Import multi_one_s_prg multi_one_s_simu multi_one_s_safe_termination.
Require Import multi_negate_prg multi_negate_simu multi_negate_safe_termination.
Require Import multi_is_even_u_prg multi_is_even_u_simu.
Require Import multi_sub_s_u_prg multi_sub_s_u_simu multi_sub_s_u_safe_termination.
Require Import copy_s_u_prg copy_s_u_simu copy_s_u_safe_termination.
Require Import begcd begcd_mips0.

Local Open Scope machine_int_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope heap_scope.
Local Open Scope uniq_scope.
Local Open Scope assoc_scope.

Definition init_mips rk ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3
  a0 a1 a2 a3 a4 a5 a6 :=
  ((multi_one_s ru1 rk a0 a1 a2 a3 ;
    multi_zero_s ru2 ;
    copy_s_u rk ru3 ru a0 a1 a2 a3 ;
    copy_s_u rk rv1 rv a0 a1 a2 a3 ;
    (multi_one_s rv2 rk a0 a1 a2 a3 ;
     multi_sub_s_u rk rv2 ru a0 a1 a2 a3 a4 a5 a6) ;
    copy_s_u rk rv3 rv a0 a1 a2 a3) ;
   multi_is_even_u rk ru a0 ;
   If_beq a0 , r0 Then
    multi_zero_s rt1 ;
    (multi_one_s rt2 rk a0 a1 a2 a3 ;
     multi_negate rt2 a0) ;
    (copy_s_u rk rt3 rv a0 a1 a2 a3 ;
      multi_negate rt3 a0)
   Else
    (multi_one_s rt1 rk a0 a1 a2 a3 ;
     multi_zero_s rt2 ;
     copy_s_u rk rt3 ru a0 a1 a2 a3))%asm_cmd.

Local Open Scope simu_scope.

Lemma fwd_sim_begcd_init vu vv g u v u1 u2 u3 v1 v2 v3 t1 t2 t3 k
  rk rg ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 a4 a5 a6 :
  uniq(g,u,v,u1,u2,u3,v1,v2,v3,t1,t2,t3) ->
  uniq(rk,rg,ru,rv,ru1,ru2,ru3,rv1,rv2,rv3,rt1,rt2,rt3,a0,a1,a2,a3,a4,a5,a6,r0) ->
  0 < vu -> 0 < vv ->
  EGCD.BEGCD_TAOCP.init u v u1 u2 u3 v1 v2 v3 t1 t2 t3
    <=( state_mint
          (g |=> unsign rk rg \U+ (u |=> unsign rk ru \U+ (v |=> unsign rk rv \U+
          (u1 |=> signed k ru1 \U+ (u2 |=> signed k ru2 \U+ (u3 |=> signed k ru3 \U+
          (v1 |=> signed k rv1 \U+ (v2 |=> signed k rv2 \U+ (v3 |=> signed k rv3 \U+
          (t1 |=> signed k rt1 \U+ (t2 |=> signed k rt2 \U+ t3 |=> signed k rt3))))))))))),
        fun st s _ => (EGCD.C2 vu vv u v g st /\ EGCD.C3 vu vv u v g st) /\ uv_bound rk s u v st k)
  init_mips rk ru rv ru1 ru2 ru3 rv1 rv2 rv3 rt1 rt2 rt3 a0 a1 a2 a3 a4 a5 a6.
Proof.
move=> Hvars Hregs Hvu Hvv.
rewrite /EGCD.BEGCD_TAOCP.init /init_mips.
apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\ EGCD.C3 vu vv u v g st /\
    EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st) /\ uv_bound rk s u v st k) => //.
- rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
  + move/syntax_m.seplog_m.hoare_prop_m.soundness:
      (EGCD.BEGCD_TAOCP_FUN_COR.triple_init0 _ _ _ _ _ _ _ _ _ _ _ _ _ _ Hvars Hvu Hvv).
    rewrite /while.hoare_semantics.
    case/( _ _ syntax_m.seplog_m.assert_m.heap.emp (proj1 Hcond)) => _.
    by move/(_ _ _ exec_pseudo).
  + rewrite /uv_bound.
    Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
- apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
    EGCD.C3 vu vv u v g st) /\ uv_bound rk s u v st k) => //.
  + rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
    * rewrite /EGCD.C2 /EGCD.C3 /= in Hcond *.
      Rewrite_var u st. Rewrite_var v st. Rewrite_var g st. tauto.
    * rewrite /uv_bound.
      Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
  + assoc_tac_m.put_in_front u1.
    apply (fwd_sim_stren _ (fun st s _ => 0 < u2Z ([ rk ]_s)%asm_expr < 2 ^^ 31 /\
      k = '|u2Z ([ rk ]_ s)%asm_expr|)); last first.
      apply pfwd_sim_fwd_sim; last first.
        set st_s_h := state_mint _.
        apply safe_termination_stren with (fun st s h => st_s_h st s h /\
          (0 < Z_of_nat k < 2 ^^ 31) /\ k = '|u2Z ([ rk ]_ s)%asm_expr|).
          move=> st s h [] H_st_s_h [] [Hrk1 Hrk2] Hk.
          split; first by [].
          split; last by [].
          rewrite Hk Z_of_nat_Zabs_nat //; by apply min_u2Z.
        by apply multi_one_s_safe_termination; Uniq_uniq r0.
      rewrite /pfwd_sim => st s h st_s_h Hcond.
      apply pfwd_sim_one_s; last exact st_s_h.
      - by Uniq_uniq r0.
      - by Disj_mints_regs.
      - by Notin_dom.
      - by Notin_cdom.
    move=> st s _ [] _ []; tauto.
  + apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
      EGCD.C3 vu vv u v g st) /\ uv_bound rk s u v st k) => //.
    * rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
      - rewrite /EGCD.C2 / EGCD.C3 in Hcond *.
        rewrite /=.
        Rewrite_var u st. Rewrite_var v st. Rewrite_var g st. tauto.
      - rewrite /uv_bound.
        Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
    * assoc_tac_m.put_in_front u2.
      apply pfwd_sim_fwd_sim_spec; last by apply multi_zero_s_safe_termination; Uniq_uniq r0.
      apply pfwd_sim_zero_s.
      - by Uniq_uniq r0.
      - by Notin_dom.
      - by Notin_cdom.
    * apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
        EGCD.C3 vu vv u v g st) /\ uv_bound rk s u v st k) => //.
      - rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
        + rewrite /EGCD.C2 / EGCD.C3 in Hcond *.
          rewrite /=.
          Rewrite_var u st. Rewrite_var v st. Rewrite_var g st. tauto.
        + rewrite /uv_bound.
          Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
      - assoc_tac_m.put_in_front u.
        assoc_tac_m.put_in_front u3.
        apply (fwd_sim_stren _ (fun st s _ => 0 < (u2Z [rk ]_ s)%asm_expr < 2 ^^ 31 /\
          k = '|u2Z ([rk ]_ s)%asm_expr| /\ 0 <= ([u ]_ st)%pseudo_expr < \B^k)).
          move=> st s _ [] _ [] Hrk [] Hk [] [Hu1 Hu2] _.
          repeat (split; first by []).
          split; first exact: ltZW.
          apply/(ltZ_trans Hu2)/Zbeta_lt.
          rewrite minusE subn1 prednK // Hk.
          apply O_lt_Zabs_nat; by case: Hrk.
        apply pfwd_sim_fwd_sim; last first.
          move=> st s h [] st_s_h [] _ [] Hk _; subst k.
          move: st s h st_s_h.
          apply copy_s_u_safe_termination.
          by rewrite [Equality.sort _]/= in Hvars *; Uniq_uniq O.
          by Uniq_uniq r0.
        apply pfwd_sim_copy_s_u.
        + rewrite [Equality.sort _]/= in Hvars *. by Uniq_uniq O.
        + by Uniq_uniq r0.
        + by Disj_mints_regs.
        + by Notin_dom.
        + by Notin_dom.
        + by Notin_cdom.
        + by Notin_cdom.
      - apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
          EGCD.C3 vu vv u v g st) /\ uv_bound rk s u v st k) => //.
        + rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
          * rewrite /EGCD.C2 / EGCD.C3 in Hcond *.
            rewrite /=.
            Rewrite_var u st. Rewrite_var v st. Rewrite_var g st. tauto.
          * rewrite /uv_bound.
            Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
        + assoc_tac_m.put_in_front v.
          assoc_tac_m.put_in_front v1.
          apply (fwd_sim_stren _ (fun st s _ => 0 < u2Z [rk ]_ s < 2 ^^ 31 /\
            k = '|u2Z ([ rk ]_ s)| /\
            0 <= ([v ]_ st)%pseudo_expr < \B^k))%asm_expr.
            move=> st s _ [] _ [] Hrk [] Hk [] _ [Hv1 Hv2].
            repeat (split; first by []).
            split; first exact: ltZW.
            apply/(ltZ_trans Hv2)/Zbeta_lt.
            rewrite minusE subn1 prednK // Hk.
            apply O_lt_Zabs_nat; by case: Hrk.
          apply pfwd_sim_fwd_sim; last first.
            move=> st s h [] st_s_h [] _ [] Hk _; subst k.
            move: st s h st_s_h.
            apply copy_s_u_safe_termination.
            by rewrite [Equality.sort _]/= in Hvars *; Uniq_uniq O.
            by Uniq_uniq r0.
          apply pfwd_sim_copy_s_u.
          - rewrite [Equality.sort _]/= in Hvars *. by Uniq_uniq O.
          - by Uniq_uniq r0.
          - by Disj_mints_regs.
          - by Notin_dom.
          - by Notin_dom.
          - by Notin_cdom.
          - by Notin_cdom.
        + apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
            EGCD.C3 vu vv u v g st) /\ uv_bound rk s u v st k) => //.
          - rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm; split.
            + rewrite /EGCD.C2 / EGCD.C3 in Hcond *.
              rewrite /=.
              Rewrite_var u st. Rewrite_var v st. Rewrite_var g st. tauto.
            + rewrite /uv_bound.
              Rewrite_reg rk s. Rewrite_var u st. Rewrite_var v st. tauto.
          - apply fwd_sim_pcode_equiv with (v2 <- nat_e 1 ; v2 <- var_e v2 \- var_e u)%pseudo_expr%pseudo_cmd;
              last by apply equiv_pcode_example2; Uniq_neq.
            apply fwd_sim_seq with (fun st s _ => [ rk ]_ s <> zero32 /\
              u2Z ([ rk ]_ s) < 2 ^^ 31 /\ k = '|u2Z ([ rk ]_ s)| /\
              `| ([ v2 ]_ st)%pseudo_expr | < \B^(k - 1) /\
              0 <= ([ u ]_ st)%pseudo_expr < \B^(k - 1))%asm_expr => //.
            + rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
              rewrite /uv_bound in Hcond.
              Rewrite_reg rk s. Rewrite_var u st.
              move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
              case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
              repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
              split; first by move=> abs; rewrite abs Z2uK // in Hcond; lia.
              repeat (split; first by tauto).
              split; first by move: (Zbeta_ge0 k) => /= ?; ssromega.
              ssromega.
            + assoc_tac_m.put_in_front v2.
              apply (fwd_sim_stren _ (fun st s _ => 0 < u2Z ([ rk ]_ s)%asm_expr < 2 ^^ 31 /\
                k = '|u2Z ([ rk ]_ s)%asm_expr|)).
                move=> st s _ [] _ []; tauto.
              apply pfwd_sim_fwd_sim; last first.
                set st_s_h := state_mint _.
                apply safe_termination_stren with (fun st s h => st_s_h st s h /\
                  (0 < Z_of_nat k < 2 ^^ 31) /\ k = '|u2Z ([ rk ]_ s)%asm_expr|).
                  move=> st s h [] st_s_h' [] [Hrk1 Hrk2] Hk.
                  split; first by [].
                  split; last by [].
                  rewrite Hk Z_of_nat_Zabs_nat //; exact: min_u2Z.
                by apply multi_one_s_safe_termination ; Uniq_uniq r0.
              rewrite /pfwd_sim => st s h st_s_h Hcond.
              apply pfwd_sim_one_s; last exact st_s_h.
              - by Uniq_uniq r0.
              - by Disj_mints_regs.
              - by Notin_dom.
              - by Notin_cdom.
            + assoc_tac_m.put_in_front u.
              assoc_tac_m.put_in_front v2.
              apply pfwd_sim_fwd_sim; last first.
                eapply safe_termination_stren; last first.
                  apply (safe_termination_multi_sub_s_u u v2 k).
                  - rewrite [Equality.sort _]/= /bipl.var.v in Hvars *. by Uniq_uniq O.
                  - by Uniq_uniq r0.
                move=> st s h [] st_s_h H.
                split; first by apply st_s_h.
                case: H => rk0 [rk231 [HL [Hv2 Hu]]].
                split; first by [].
                rewrite HL Z_of_nat_Zabs_nat; last by apply min_u2Z.
                split; last by [].
                rewrite ltZ_neqAle; split; last by apply min_u2Z.
                contradict rk0.
                rewrite (_ : 0 = u2Z zero32) in rk0; last by rewrite Z2uK.
                by move/u2Z_inj in rk0.
              apply pfwd_sim_multi_sub_s_u_wo_overflow.
              - rewrite [Equality.sort _]/= in Hvars *. by Uniq_uniq O.
              - by Uniq_uniq r0.
              - by Disj_mints_regs.
              - by Notin_dom.
              - by Notin_dom.
              - by Notin_cdom.
              - by Notin_cdom.
          - assoc_tac_m.put_in_front v.
            assoc_tac_m.put_in_front v3.
            apply (fwd_sim_stren _ (fun st s _ => 0 < u2Z ([ rk ]_s)%asm_expr < 2 ^^ 31 /\
              k = '|u2Z ([ rk ]_ s)%asm_expr| /\
              0 <= ([ v ]_ st)%pseudo_expr < \B^k)%asm_expr).
              move=> st s _ [] _ [] Hrk [] Hk [] _ [Hv1 Hv2].
              repeat (split; first by []).
              split; first exact/ltZW.
              apply/(ltZ_trans Hv2)/Zbeta_lt.
              rewrite minusE subn1 prednK // Hk.
              apply O_lt_Zabs_nat; by case: Hrk.
            apply pfwd_sim_fwd_sim; last first.
              move=> st s h [] st_s_h [] _ [] Hk _; subst k.
              move: st s h st_s_h.
              apply copy_s_u_safe_termination.
              by rewrite [Equality.sort _]/= in Hvars *; Uniq_uniq O.
              by Uniq_uniq r0.
            apply pfwd_sim_copy_s_u.
            - rewrite [Equality.sort _]/= in Hvars *. by Uniq_uniq O.
            - by Uniq_uniq r0.
            - by Disj_mints_regs.
            - by Notin_dom.
            - by Notin_dom.
            - by Notin_cdom.
            - by Notin_cdom.
- apply fwd_sim_ifte_spec => //.
  + rewrite /invariant => st s h [st_s_h Hcond] s' h' exec_asm; split.
    * eapply state_mint_invariant; [idtac | idtac | apply st_s_h | apply exec_asm] => //.
      rewrite [mips_frame.modified_regs _]/=.
      by Disj_mints_regs.
    * rewrite /uv_bound.
      Rewrite_reg rk s. tauto.
  + assoc_tac_m.put_in_front u.
    apply fwd_sim_b_multi_is_even_u.
    + by Uniq_uniq r0.
    + by Disj_mints_regs.
    + by Notin_dom.
    + by Notin_cdom.
  + apply fwd_sim_seq with (fun st s _ => ((EGCD.C2 vu vv u v g st /\
      EGCD.C3 vu vv u v g st /\ EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st) /\
      uv_bound rk s u v st k) /\
      ([var_e u \% nat_e 2 \= nat_e 1 ]b_ st)%pseudo_expr) => //.
    * rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
      case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
      rewrite /EGCD.C2 /EGCD.C3 /EGCD.uivi_init /uv_bound in Hcond *.
      simpl.
      repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
      Rewrite_reg rk s. tauto.
    * assoc_tac_m.put_in_front t1.
      apply pfwd_sim_fwd_sim_spec; last by apply multi_zero_s_safe_termination; Uniq_uniq r0.
      apply pfwd_sim_zero_s.
      - by Uniq_uniq r0.
      - by Notin_dom.
      - by Notin_cdom.
  + apply fwd_sim_seq with (fun st s _ => ((EGCD.C2 vu vv u v g st /\
      EGCD.C3 vu vv u v g st /\ EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st) /\
      uv_bound rk s u v st k) /\
      ([var_e u \% nat_e 2 \= nat_e 1 ]b_ st)%pseudo_expr) => //.
    * rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
      case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
      rewrite /EGCD.C2 /EGCD.C3 /EGCD.uivi_init /uv_bound in Hcond *.
      simpl.
      repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
      Rewrite_reg rk s. tauto.
    * apply fwd_sim_pcode_equiv with (t2 <- nat_e 1 ; t2 <- .--e (var_e t2))%pseudo_expr%pseudo_cmd; last first.
        eapply equiv_pcode_trans; by [apply equiv_pcode_example3 | apply equiv_pcode_example_assign].
      apply fwd_sim_seq with (fun st s _ => ((EGCD.C2 vu vv u v g st /\
        EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st) /\ uv_bound rk s u v st k)) => //.
      - rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
        move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
        case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
        rewrite /EGCD.C2 /EGCD.uivi_init /uv_bound in Hcond *.
        repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
        Rewrite_reg rk s. tauto.
      - assoc_tac_m.put_in_front t2.
        apply (fwd_sim_stren _ (fun st s _ => 0 < u2Z ([ rk ]_ s)%asm_expr < 2 ^^ 31 /\
          k = '|u2Z ([ rk ]_ s)%asm_expr|)).
          move=> st s _ [] [] _ []; tauto.
        apply pfwd_sim_fwd_sim; last first.
          set st_s_h := state_mint _.
          apply safe_termination_stren with (fun st s h => st_s_h st s h /\
            0 < Z_of_nat k < 2 ^^ 31 /\ k = '|u2Z ([ rk ]_s)%asm_expr|).
            move=> st s h [] Hst_s_h [] Hrk Hk.
            split; first by [].
            split; last by [].
            rewrite Hk Z_of_nat_Zabs_nat //; exact: min_u2Z.
          by apply multi_one_s_safe_termination; Uniq_uniq r0.
        rewrite /pfwd_sim => st s h st_s_h Hcond.
        apply pfwd_sim_one_s; last by exact st_s_h.
        + by Uniq_uniq r0.
        + by Disj_mints_regs.
        + by Notin_dom.
        + by Notin_cdom.
     - assoc_tac_m.put_in_front t2.
       apply (fwd_sim_stren _ (fun st s h => 0 < Z_of_nat k < 2 ^^ 31)).
         move=> st s _ [] _ [] H [] -> _.
         rewrite Z_of_nat_Zabs_nat //; exact: min_u2Z.
       apply pfwd_sim_fwd_sim_spec; last by apply multi_negate_safe_termination; Uniq_uniq r0.
       apply pfwd_sim_multi_negate.
       + by Uniq_uniq r0.
       + by Disj_mints_regs.
       + by Notin_dom.
       + by Notin_cdom.
     - apply fwd_sim_pcode_equiv with (t3 <- var_e v ; t3 <- .--e (var_e t3))%pseudo_expr%pseudo_cmd; last first.
         eapply equiv_pcode_trans; by [apply equiv_pcode_example3 | apply equiv_pcode_example_assign].
       apply fwd_sim_seq with (fun st s _ =>
         ((EGCD.C2 vu vv u v g st /\ EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st) /\
         uv_bound rk s u v st k)) => //.
       + rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
         move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
         case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
         rewrite /EGCD.C2 /EGCD.uivi_init /uv_bound in Hcond *.
         repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
         Rewrite_reg rk s. tauto.
       + assoc_tac_m.put_in_front v.
         assoc_tac_m.put_in_front t3.
         apply (fwd_sim_stren _ (fun st s h => 0 < u2Z ([ rk ]_ s)%asm_expr < 2 ^^ 31 /\
           k = '|u2Z ([ rk ]_ s)%asm_expr| /\ 0 <= ([ v ]_ st)%pseudo_expr < \B^k)%asm_expr).
           move=> st s _ [] [] _ [] Hrk [] Hk [] _ [Hv1 Hv2] _.
           repeat (split; first by []).
           split; first exact/ltZW.
           apply/(ltZ_trans Hv2)/Zbeta_lt.
           rewrite minusE subn1 prednK // Hk.
           apply O_lt_Zabs_nat; by case: Hrk.
         apply pfwd_sim_fwd_sim; last first.
           move=> st s h [] st_s_h [] _ [] Hk _; subst k.
           move: st s h st_s_h.
           apply copy_s_u_safe_termination.
           by rewrite [Equality.sort _]/= in Hvars *; Uniq_uniq O.
           by Uniq_uniq r0.
         apply pfwd_sim_copy_s_u.
         * rewrite [Equality.sort _]/= in Hvars *. by Uniq_uniq O.
         * by Uniq_uniq r0.
         * by Disj_mints_regs.
         * by Notin_dom.
         * by Notin_dom.
         * by Notin_cdom.
         * by Notin_cdom.
       + assoc_tac_m.put_in_front t3.
        apply (fwd_sim_stren _ (fun st s _ => 0 < Z_of_nat k < 2 ^^ 31)).
          move=> st s _ [] _ [] H [] -> _.
          rewrite Z_of_nat_Zabs_nat //; exact: min_u2Z.
        apply pfwd_sim_fwd_sim_spec; last by apply multi_negate_safe_termination; Uniq_uniq r0.
        apply pfwd_sim_multi_negate.
        * by Uniq_uniq r0.
        * by Disj_mints_regs.
        * by Notin_dom.
        * by Notin_cdom.
- apply fwd_sim_seq with (fun st s _ => ((EGCD.C2 vu vv u v g st /\
     EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st) /\ uv_bound rk s u v st k) ) => //.
  + rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
    move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
    case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
    rewrite /EGCD.C2 /EGCD.uivi_init /uv_bound in Hcond *.
    repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
    Rewrite_reg rk s; tauto.
  + assoc_tac_m.put_in_front t1.
    apply (fwd_sim_stren _ (fun st s h => 0 < (u2Z ([ rk ]_s)%asm_expr) < 2 ^^ 31 /\
      k = '|u2Z ([ rk ]_ s)%asm_expr|)).
      move=> st s _ [] [] _ []; tauto.
    apply pfwd_sim_fwd_sim; last first.
      set st_s_h := state_mint _.
      apply safe_termination_stren with (fun st s h => st_s_h st s h /\
        0 < Z_of_nat k < 2 ^^ 31 /\ k = '|u2Z ([ rk ]_ s)%asm_expr|).
        move=> st s h [] Hst_s_h [] Hrk Hk.
        split; first by [].
        split; last by [].
        rewrite Hk Z_of_nat_Zabs_nat //; exact: min_u2Z.
      by apply multi_one_s_safe_termination; Uniq_uniq r0.
    rewrite /pfwd_sim => st s h Hst_s_h Hcond.
    apply pfwd_sim_one_s; last exact Hst_s_h.
    * by Uniq_uniq r0.
    * by Disj_mints_regs.
    * by Notin_dom.
    * by Notin_cdom.
  + apply fwd_sim_seq with (fun st s _ => (EGCD.C2 vu vv u v g st /\
      EGCD.uivi_init u v u1 u2 u3 v1 v2 v3 st) /\ uv_bound rk s u v st k) => //.
    * rewrite /rela_hoare => st s h Hcond st' exec_pseudo s' h' exec_asm.
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
      case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
      rewrite /EGCD.C2 /EGCD.uivi_init /uv_bound in Hcond *.
      repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
      Rewrite_reg rk s. tauto.
    * assoc_tac_m.put_in_front t2.
      apply pfwd_sim_fwd_sim_spec; last by apply multi_zero_s_safe_termination; Uniq_uniq r0.
      apply pfwd_sim_zero_s.
      - by Uniq_uniq r0.
      - by Notin_dom.
      - by Notin_cdom.
    * assoc_tac_m.put_in_front u.
      assoc_tac_m.put_in_front t3.
      apply (fwd_sim_stren _ (fun st s h => 0 < u2Z ([ rk ]_s)%asm_expr < 2 ^^ 31 /\
        k = '|u2Z ([ rk ]_ s)%asm_expr| /\ 0 <= ([ u ]_ st)%pseudo_expr < \B^k)%asm_expr).
        move=> st s _ [] _ [] Hrk [] Hk [] [Hu1 Hu2] _.
        repeat (split; first by []).
        split; first exact/ltZW.
        apply/(ltZ_trans Hu2)/Zbeta_lt.
        rewrite minusE subn1 prednK // Hk.
        apply O_lt_Zabs_nat; by case: Hrk.
      apply pfwd_sim_fwd_sim; last first.
        move=> st s h [] st_s_h [] _ [] Hk _; subst k.
        move: st s h st_s_h.
        apply copy_s_u_safe_termination.
        by rewrite [Equality.sort _]/= in Hvars *; Uniq_uniq O.
        by Uniq_uniq r0.
      apply pfwd_sim_copy_s_u.
      - rewrite [Equality.sort _]/= in Hvars *. by Uniq_uniq O.
      - by Uniq_uniq r0.
      - by Disj_mints_regs.
      - by Notin_dom.
      - by Notin_dom.
      - by Notin_cdom.
      - by Notin_cdom.
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 Path Extension
*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Dynamic_Semantics.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_WFC_Lemmas.
Require Export Cyclone_WFU_Lemmas.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_Substitutions_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Get_Lemmas.
Require Export Cyclone_Admit_Environment.
Open Scope list_scope.

(* Dan is probably thinking like this but not saying it in the text of the proof. *)
(* Thesis difference, using getd. *)
Lemma get'_path_extension_r:
  forall v p v' v'' pe,
    Value v ->
    Value v' ->
    Value v'' ->
    get' v p v' ->
    get' v' (cons pe nil) v'' ->
    get' v (app p (cons pe nil)) v''.
Proof.
  introv vv vv' vv'' getd.
  induction getd; intros.
  simpl; auto.
  apply IHgetd in H2; auto.
  constructor*.
  apply IHgetd in H2; auto.
  constructor*.
  apply IHgetd in H1; auto.
  constructor*.
Qed.

Ltac invert_exists :=
  repeat
    match goal with
    | H : exists _ _, _ |- _ => inversions H
    | H : exists _, _ |- _ => inversions H
    | H : Value (cpair _ _) |- _ => inversions H
   end.

Lemma A_10_Path_Extension_1_A_pair:
  forall v p v',
    get' v p v' ->
    (forall v0 v1,
        v' = (cpair v0 v1) ->
        get' v (app p (cons (i_pe zero_pe) nil)) v0 /\
        get' v (app p (cons (i_pe one_pe)  nil)) v1) .
Proof.
  introv getd.
  induction getd; intros; split; subst; inversions* H;
  try solve[constructor*];
  try solve[ apply get'_path_extension_r with (v':= (cpair v2 v3)); auto];
  try solve[apply get'_path_extension_r with (v':= (cpair v0 v2)); auto].
Qed.

Ltac invert_pathed_get :=
  match goal with
   | H : get' _ (app _ _) _ |- _ => inversions* H
  end.

Lemma A_10_Path_Extension_1_A_no_pair:
  forall v p v',
    get' v p v' ->
    ( ~(exists v0 v1,  v' = (cpair v0 v1)) ->
      ~(exists i p' v'', get' v (app p (cons (i_pe i) p')) v'')).
Proof.
  introv getd.
  induction getd; intros; unfolds; intros;
    invert_exists;
    invert_pathed_get.
Qed.

Lemma A_10_Path_Extension_1_A_pack:
  forall v p v',
    get' v p v' ->
   forall t' v0 t k,
     v' = (pack t' v0 (etype aliases k t)) ->
     get' v (app p (cons u_pe nil)) v0.
Proof.
  introv getd.
  induction getd; intros; subst; inversions* H;
  simpl;
  try solve[constructor*].
Qed.

Lemma A_10_Path_Extension_1_A_no_pack:
  forall v p v',
    get' v p v' ->
    ~(exists t' v0 t k, v' = (pack t' v0 (etype aliases k t))) ->
    ~(exists p' v'',  get' v (app p (cons u_pe p')) v'').
Proof.
  introv getd.
  induction getd; intros; unfolds; intros;
  try solve[invert_exists; invert_pathed_get].
  invert_exists.
  simpl in H1.
  inversions* H1.
  unfolds in H0.
  contradict H0.
  exists* tau' v1 tau k.
Qed.

(* ? Extend both ps? *)
Lemma gettype_path_extension_r:
  forall u x p t p' t',
    gettype u x p t p' t' ->
    forall pe t'',
      gettype u x (app p (cons pe nil)) t' (app (cons pe nil) p') t'' ->
      gettype u x (app p (cons pe nil)) t p' t''.
Proof.
  introv gettyped.
  induction gettyped; intros; simpl; auto.
  destruct pe. destruct i.
Admitted.

Lemma A_10_Path_Extension_2_cross:
  forall u x p t p' t',
    gettype u x p t p' t' ->
    forall t0 t1,
      t' = (cross t0 t1) ->
      (gettype u x p t (app p' (cons (i_pe zero_pe) nil)) t0 /\
       gettype u x p t (app p' (cons (i_pe one_pe ) nil)) t1).
Proof.
  introv gettyped.
  induction gettyped; intros; try solve[split; subst; simpl; constructor*];
  try solve[intros; split; subst; simpl; constructor*; try apply* IHgettyped].
  try solve[intros; split; subst; simpl; apply gettype_etype with (tau'':= tau''); auto;
  apply* IHgettyped].
Qed.

Lemma fix_path:
  forall (a :PE),
    (a :: nil) = (app (a :: nil) nil).
Proof.
  auto.
Qed.

Lemma gettype_nil_agreement:
  forall u x p t t',
    gettype u x p t nil t' ->
    t = t'.
Admitted.

Lemma gettype_nil_get_agreement:
  forall u x p t t' t'',
    gettype u x p t nil t' ->
    LVPE.V.get (x, p) u = Some t'' ->
    (t = t' /\ t = t'').
Admitted.

Lemma intermediate_type:
  forall u x t p p' t',
    gettype u x p t p' t' ->
    exists t'' pe,
      gettype u x p t (pe :: p') t'' ->
      gettype u x (p & pe) t'' p' t'.
Admitted.

(* this is a weak version of an intermediate type theorem. *)
Lemma punt:
  forall x p u tau0 k t0 t2 p',
   LVPE.V.get (x, p) u = Some tau0 ->
   forall pe,
     gettype u x (p ++ pe :: nil) t0 p' (etype aliases k t2) ->
     LVPE.V.get (x, p ++ pe :: nil) u = Some tau0.
Admitted.

Lemma A_10_Path_Extension_2_etype:
  forall p',
   forall u x p t t',
    gettype u x p t p' t' ->
    forall k t0,
      t' = (etype aliases k t0) ->
      forall tau,
        LVPE.V.get (x,p) u = Some tau ->
        (gettype u x p t (app p' (cons u_pe nil)) (T.open_rec 0 tau t0)).
Proof.
  introv gettyped.
  induction gettyped; intros; simpl; subst.
  apply gettype_etype with (tau'':= tau0); auto.

  constructor.
  apply IHgettyped with (k0:=k); auto.
  lets P: punt x p u tau0 k.
  specialize (P t0 t2 p' H0 (i_pe zero_pe)).
  admit. (* fucking append again *)

  constructor.
  apply IHgettyped with (k0:=k); auto.
  lets P: punt x p u tau0 k.
  specialize (P t0 t2 p' H0 (i_pe one_pe)).
  admit. (*   LVPE.V.get (x, p ++ i_pe zero_pe :: nil) u = Some tau0 *)

  apply gettype_etype with (tau'':= tau''); auto.
  apply IHgettyped with (k:=k0); auto.
  lets P: punt x p u tau0 k.
  specialize (P t0 t0 p' H1 u_pe).
  (* No, fails on etype vs open rec. *)
  admit.

(* breaks at the induction unless I find some way to radically change the types/paths.
  intros p'.
  induction p'; intros.
  apply gettype_nil_get_agreement with (t'':= tau) in H; auto.
  inversions H; subst.
  simpl.
  apply gettype_etype with (tau'':= (etype aliases k t0)); auto.

  destruct a; try destruct i; subst; inversion H; subst.
  admit.
  admit.

  simpl.
  constructor.
  assert(BROKEN:
           gettype u x (append p (cons (i_pe zero_pe) nil)) t1 p'
                   (etype aliases k t0)). admit.
  assert(TE: etype aliases k t0 = etype aliases k t0); auto.
  (*(p ++ i_pe zero_pe :: nil) *)
  specialize (IHp' u x).
  (* BROKEN k t0 TE *)
  (* LVPE get goal wrong *)
  admit.
  admit.
  specialize (IHp' u x p).

*)

(*
  (* Dan does it by p then left most in p'. *)
  induction p; intros; induction p'; intros; subst.
  apply gettype_nil_get_agreement with (t'':= tau) in H; auto.
  inversions* H; simpl.
  apply gettype_etype with (tau'':= tau); auto.

  destruct a; try destruct i.
  inversions* H; simpl.
(* Stuck.
  inversion H6; subst; simpl; auto.

  admit.
  simpl; subst.
  apply gettype_nil_get_agreement with (t'':= tau) in H; auto.
  inversions* H; subst.
  apply gettype_etype with (tau'':= (etype aliases k t0)); auto.
  admit.
*)

(* by gettyped
  introv gettyped.
  induction gettyped; intros; subst.
  simpl.
  rewrite fix_path.
  apply gettype_etype with (tau'':= tau0); auto.

  intros; subst; simpl; constructor*.
(*  inversions gettyped. *)
  apply IHgettyped with (k0:=k); auto.
  admit.

  intros; subst; simpl; constructor*.
(*  inversions gettyped. *)
  apply IHgettyped with (k0:=k); auto.
  admit.

  simpl.
  apply gettype_etype with (tau'':=tau''); auto.
  apply IHgettyped with (k:=k0); auto.
  admit.
Qed.
 *)
Admitted.
*)


Definition kf0 := Q2Fp 0.
Definition kf1 := Q2Fp (1#1).
Definition kfp5 := Q2Fp (1#2).
Definition visc := Q2Fp (316#100).

Fixpoint getNewPart ( f_tin f_tout part1 part2 dtt : fp_num ) :fp_num*fp_num :=
let tmp3 := diffFp f_tin part1 in
let newPart1 := multFp dtt tmp3 in
let tmp4 := diffFp f_tout part2 in
let newPart2 := multFp dtt tmp4 in
( newPart1 , newPart2 ) .

(* part1 , part2 , nf *)
Fixpoint ysparg ( p_out p_in_out p_in_in d1 d2 dtt part1 part2 : fp_num ) :
(fp_num*fp_num ) *fp_num:=
let nf := kf1 in
let f_8 := multFp visc (sqrtFp d1) in
let f_9 := multFp visc (sqrtFp d2) in
let compare_1 := compare p_in_out p_out in
let compare_2 := compare p_in_in p_out in
if ( isGt compare_1 && isGE compare_2 ) then
 let tmp1 := diffFp p_in_out p_out in
 let tmp2 := sumFp tmp1 f_8 in
 let f_tin := divideFp tmp1 tmp2 in
 let f_tout := kf0 in
 ( getNewPart f_tin f_tout part1 part2 dtt , nf )
else
 if ( isLt compare_1 && isLE compare_2 ) then
  let f_tin := kf0 in
  let tmp1 := diffFp p_out p_in_in in
  let tmp2 := sumFp tmp1 f_9 in
  let f_tout := divideFp tmp1 tmp2 in
  ( getNewPart f_tin f_tout part1 part2 dtt , nf )
 else
  let tmp0 := diffFp p_in_out p_in_in in
  match compare tmp0 kf0 with
  | Lt =>
   let f_tin := kfp5 in
   let f_tout := kfp5 in
   ( getNewPart f_tin f_tout part1 part2 dtt , kf0 )
  |_ =>
   let tmp1 := diffFp p_in_out p_out in
   let tmp2 := diffFp p_in_out p_in_in in
   let tmp3 := sumFp tmp2 f_8 in
   let f_tin := divideFp tmp1 tmp3 in
   let tmp4 := diffFp p_out p_in_in in
   let tmp5 := sumFp tmp2 f_9 in
   let f_tout := divideFp tmp4 tmp5 in
   ( getNewPart f_tin f_tout part1 part2 dtt , nf )
end .


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

(***
Modulus : 2^383 - 31
Base: 23 + 15/16
***)

Definition curve : CurveParameters :=
  {|
    sz := 16%nat;
    base := 23 + 15/16;
    bitwidth := 32;
    s := 2^383;
    c := [(1, 31)];
    carry_chains := Some [seq 0 (pred 16); [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.


Definition ignore (n:nat) := tt.
Lemma ignore_S x : ignore (S x) = ignore x. exact eq_refl. Qed.
Create HintDb ignore.
Hint Rewrite ignore_S : ignore.

Goal ignore  125 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.
Goal ignore  250 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.
Goal ignore  500 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.
Goal ignore 1000 = tt. Time autorewrite with ignore. exact eq_refl. Time Qed.

(* same as rewrite_ignore.v *)
(* Finished transaction in 0.106 secs (0.078u,0.026s) (successful)
Finished transaction in 0.067 secs (0.051u,0.016s) (successful)
Finished transaction in 0.2 secs (0.199u,0.s) (successful)
Finished transaction in 0.172 secs (0.17u,0.s) (successful)
Finished transaction in 0.743 secs (0.733u,0.006s) (successful)
Finished transaction in 0.669 secs (0.663u,0.003s) (successful)
Finished transaction in 2.938 secs (2.904u,0.019s) (successful)
Finished transaction in 2.659 secs (2.648u,0.s) (successful) *)


From Coq Require Export Morphisms RelationClasses Setoid Program.Equality.
From ITree Require Export ITree ITreeFacts Eq.Rutt Props.Finite.
From Paco Require Import paco.
From Coq Require Export Eqdep EqdepFacts Logic.Classical.
Require Import Lia.
Require Export HeterogeneousEventRelations Refinement ConcreteRefinement ConvergentRefinement.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.
Locate MonadNotation.
Open Scope list_scope.

(** * rec_fix_spec *)

Definition call_spec {E A B} (a : A) : itree_spec (callE A B +' E) B :=
  ITree.trigger (Spec_vis (inl1 (Call a))).

Definition rec_spec {E A B} (body : A -> itree_spec (callE A B +' E) B) (a : A) :
  itree_spec E B :=
  mrec_spec (calling' body) (Call a).

Definition rec_fix_spec {E A B}
(body : (A -> itree_spec (callE A B +' E) B) ->
        A -> itree_spec (callE A B +' E) B)  :
  A -> itree_spec E B := rec_spec (body call_spec).

(** * assert_spec, assume_spec, exists_spec, forall_spec *)

Definition assert_spec {E} (P : Type) : itree_spec E unit :=
  trigger (@Spec_exists E P);; Ret tt.

Lemma padded_assert_pad_elim {E1 E2} RPre RPost R1 R2 RR P
      (phi : itree_spec E1 R1) (kphi : unit -> itree_spec E2 R2) :
  P -> padded_refines RPre RPost RR phi (kphi tt) ->
  padded_refines RPre RPost RR phi (ITree.bind (assert_spec P) kphi).
Proof.
  intros. setoid_rewrite bind_trigger.
  unfold padded_refines in *. rewrite pad_bind, pad_vis.
  setoid_rewrite pad_ret. rewrite bind_vis. setoid_rewrite bind_tau.
  setoid_rewrite bind_ret_l. pstep. constructor. auto. constructor. pstep_reverse.
Qed.

Lemma padded_assert_pad_eliml {E1 E2} RPre RPost R1 R2 RR P
      (phi : itree_spec E1 R1) (kphi : unit -> itree_spec E2 R2) :
  (P -> padded_refines RPre RPost RR (kphi tt) phi) ->
  padded_refines RPre RPost RR (ITree.bind (assert_spec P) kphi) phi.
Proof.
  intros. setoid_rewrite bind_trigger.
  unfold padded_refines in *. rewrite pad_bind, pad_vis.
  setoid_rewrite pad_ret. rewrite bind_vis. setoid_rewrite bind_tau.
  setoid_rewrite bind_ret_l. pstep. constructor.
  intros HP. specialize (H HP). constructor. pstep_reverse.
Qed.

Definition assume_spec {E} (P : Type) : itree_spec E unit :=
  trigger (@Spec_forall E P);; Ret tt.

Lemma padded_assume_pad_elim {E1 E2} RPre RPost R1 R2 RR P
      (phi : itree_spec E1 R1) (kphi : unit -> itree_spec E2 R2) :
  (P -> padded_refines RPre RPost RR phi (kphi tt)) ->
  padded_refines RPre RPost RR phi (ITree.bind (assume_spec P) kphi).
Proof.
  intros. setoid_rewrite bind_trigger.
  unfold padded_refines in *. rewrite pad_bind, pad_vis.
  setoid_rewrite pad_ret. rewrite bind_vis. setoid_rewrite bind_tau.
  setoid_rewrite bind_ret_l. pstep. constructor.
  intros HP. specialize (H HP). constructor. pstep_reverse.
Qed.

Lemma padded_assume_pad_eliml {E1 E2} RPre RPost R1 R2 RR P
      (phi : itree_spec E1 R1) (kphi : unit -> itree_spec E2 R2) :
  P -> padded_refines RPre RPost RR (kphi tt) phi ->
  padded_refines RPre RPost RR (ITree.bind (assume_spec P) kphi) phi.
Proof.
  intros. setoid_rewrite bind_trigger.
  unfold padded_refines in *. rewrite pad_bind, pad_vis.
  setoid_rewrite pad_ret. rewrite bind_vis. setoid_rewrite bind_tau.
  setoid_rewrite bind_ret_l. pstep. constructor. auto. constructor. pstep_reverse.
Qed.

Definition exists_spec {E} (T : Type) : itree_spec E T :=
  trigger (@Spec_exists E T).

(**)
Lemma exists_spec_elim {E1 E2} S1 R2 S2 RPre RPost RR (phi : itree_spec E1 S1)
      (kphi : R2 -> itree_spec E2 S2) r :
  refines RPre RPost RR phi (kphi r) ->
  refines RPre RPost RR phi (ITree.bind (exists_spec R2) kphi).
Proof.
  intros. unfold exists_spec. setoid_rewrite bind_trigger.
  pstep. econstructor. pstep_reverse.
Qed.

(*maybe there is a simpler way to derive this proof from the previous one*)
Lemma padded_exists_spec_elim {E1 E2} S1 R2 S2 RPre RPost RR (phi : itree_spec E1 S1)
      (kphi : R2 -> itree_spec E2 S2) r :
  padded_refines RPre RPost RR phi (kphi r) ->
  padded_refines RPre RPost RR phi (ITree.bind (exists_spec R2) kphi).
Proof.
  intros.  unfold padded_refines in *. rewrite pad_bind. setoid_rewrite pad_vis.
  rewrite bind_vis.
  setoid_rewrite pad_ret. setoid_rewrite bind_tau. setoid_rewrite bind_ret_l.
  pstep. econstructor. Unshelve. all : auto. constructor. pstep_reverse.
Qed.

Lemma padded_exists_spec_eliml {E1 E2} S1 R2 S2 RPre RPost RR (phi : itree_spec E1 S1)
      (kphi : R2 -> itree_spec E2 S2) :
  (forall r, padded_refines RPre RPost RR (kphi r) phi) ->
  padded_refines RPre RPost RR (ITree.bind (exists_spec R2) kphi) phi .
Proof.
  intros.  unfold padded_refines in *. rewrite pad_bind. setoid_rewrite pad_vis.
  rewrite bind_vis.
  setoid_rewrite pad_ret. setoid_rewrite bind_tau. setoid_rewrite bind_ret_l.
  pstep. econstructor. intros. constructor. pstep_reverse. apply H.
Qed.

Ltac existssr a := apply padded_exists_spec_elim with (r := a).

Ltac eexistssr := eapply padded_exists_spec_elim.

Ltac existssl := apply padded_exists_spec_eliml.

Ltac assumesr := apply padded_assume_pad_elim.
Ltac assumesl := apply padded_assume_pad_eliml.
Ltac assertsr := apply padded_assert_pad_elim.
Ltac assertsl := apply padded_assert_pad_eliml.

Lemma conv_ref_exists_spec E R :
  @conv_ref E R (exists_spec R).
Proof.
  pstep. red. cbn. constructor.
  intros. left. pstep. constructor.
Qed.

Definition forall_spec {E} (T : Type) : itree_spec E T :=
  trigger (@Spec_forall E T).

Lemma forall_spec_elim {E1 E2} S1 R2 S2 RPre RPost RR (phi : itree_spec E1 S1)
      (kphi : R2 -> itree_spec E2 S2) :
  (forall r, refines RPre RPost RR phi (kphi r)) ->
  refines RPre RPost RR phi (ITree.bind (forall_spec R2) kphi).
Proof.
  intros. unfold forall_spec. rewrite bind_trigger.
  pstep. constructor. intros. pstep_reverse. apply H.
Qed.

Lemma padded_forall_spec_elim {E1 E2} S1 R2 S2 RPre RPost RR (phi : itree_spec E1 S1)
      (kphi : R2 -> itree_spec E2 S2):
  (forall r, padded_refines RPre RPost RR phi (kphi r)) ->
  padded_refines RPre RPost RR phi (ITree.bind (forall_spec R2) kphi).
Proof.
  intros.  unfold padded_refines in *. rewrite pad_bind. setoid_rewrite pad_vis.
  rewrite bind_vis.
  setoid_rewrite pad_ret. setoid_rewrite bind_tau. setoid_rewrite bind_ret_l.
  pstep. constructor. intros.  constructor. pstep_reverse.
  apply H.
Qed.

Lemma padded_forall_spec_eliml {E1 E2} S1 R2 S2 RPre RPost RR (phi : itree_spec E1 S1)
      (kphi : R2 -> itree_spec E2 S2) r:
  padded_refines RPre RPost RR (kphi r) phi ->
  padded_refines RPre RPost RR (ITree.bind (forall_spec R2) kphi) phi.
Proof.
  intros.  unfold padded_refines in *. rewrite pad_bind. setoid_rewrite pad_vis.
  rewrite bind_vis.
  setoid_rewrite pad_ret. setoid_rewrite bind_tau. setoid_rewrite bind_ret_l.
  pstep. econstructor. constructor. pstep_reverse.
Qed.

(** * padded_refines_eq *)

Definition padded_refines_eq {E R1 R2} RR (phi1 : itree_spec E R1) (phi2 : itree_spec E R2) :=
  padded_refines eqPreRel eqPostRel RR phi1 phi2.

Global Instance padded_refines_eq_refl {E R} : Reflexive (@padded_refines_eq E R R eq).
Proof.
  red. intros. unfold padded_refines_eq, padded_refines. apply refl_refines; auto.
  - red. intros. constructor.
  - red. intros. inv H. inj_existT. subst. auto.
  - apply pad_is_padded.
Qed.

Global Instance refines_proper_bind E R S :
  Proper (@padded_refines_eq E R R eq ==> pointwise_relation _ (padded_refines_eq eq) ==> @padded_refines_eq E S S eq) ITree.bind.
Proof.
  repeat intro. subst. unfold padded_refines_eq in *. eapply padded_refines_bind; eauto.
  intros; subst. auto.
Qed.

Global Instance refines_proper_subst E R S (k : R -> itree_spec E S) :
  Proper (@padded_refines_eq E R R eq ==> padded_refines_eq eq) (ITree.subst k).
Proof.
  repeat intro. eapply refines_proper_bind. auto. intro. reflexivity.
Qed.

Global Instance refines_proper_bind_eq E R S :
  Proper (@padded_refines_eq E R R eq ==> eq ==> @padded_refines_eq E S S eq) ITree.bind.
Proof.
  repeat intro. eapply refines_proper_bind. auto. subst. intro. reflexivity.
Qed.

Global Instance  padded_refines_eq_gen E1 E2 R1 R2 RPre RPost RR :
  Proper (padded_refines_eq eq ==> flip (padded_refines_eq eq) ==> flip impl)
         (@padded_refines E1 E2 R1 R2 RPre RPost RR).
Proof.
  intros t1 t2 Ht12 t3 t4 Ht43. red in Ht43. intro.
  unfold padded_refines_eq, padded_refines in *. rename H into H24.
  specialize @refinesTrans with (E1 := E1) (E2 := E1) (E3 := E2) (RPre1 := eqPreRel) (RPre2 := RPre) as Htrans.
  eapply Htrans in Ht12; eauto; try apply pad_is_padded. clear Htrans.
  specialize @refinesTrans with (E1 := E1) (E2 := E2) (E3 := E2) (RPre1 := rcomposePreRel eqPreRel RPre) (RPre2 := eqPreRel) as Htrans.
  eapply Htrans in Ht12; eauto; try apply pad_is_padded. eapply refines_monot; try eapply Ht12.
  { intros. destruct PR. destruct H. eqPreRel_inv H. eqPreRel_inv H0. auto. }
  { intros. econstructor. intros. destruct H. eqPreRel_inv H0.
    inv H. inj_existT. subst. eqPreRel_inv H4. exists x1. split. 2 : constructor.
    constructor. intros. destruct H. eqPreRel_inv H. exists x0. split; auto. constructor.
  }
  { intros. inv PR. inv REL1. auto. }
Qed.

Global Instance padded_refines_eq_trans {E R} : Transitive (@padded_refines_eq E R R eq).
Proof.
  intros phi1 phi2 phi3 Hphi12 Hphi23. unfold padded_refines_eq, padded_refines in *.
  eapply refines_monot; try eapply refinesTrans; eauto with solve_padded; try apply pad_is_padded.
  - intros A B ea eb PR. assert (A = B). inv PR. inv H3. inv H4. auto. subst.
    assert (ea = eb). inv PR. inj_existT.
    subst. assert (B = B0). inv H3. auto. subst. inv H4. inj_existT. subst. inv H3. inj_existT.
    subst. auto. subst. constructor.
  - intros.
    assert (A = B). inv PR. auto. subst. assert (ea = eb). inv PR. inj_existT. subst. auto.
    subst. constructor. intros. destruct H. assert (x0 = x1). inv PR. inj_existT. subst. auto.
    subst. assert (B = B0). inv H. auto. subst. exists x1.
    assert (e2 = eb). inv H. inj_existT. subst. auto. subst. repeat constructor.
  - intros. inv PR. auto.
Qed.

Global Instance refines_proper_interp_mrec_spec E D R :
  Proper ((fun ctx1 ctx2 => forall T d, padded_refines_eq  eq (ctx1 T d) (ctx2 T d)) ==> @padded_refines_eq (D +' E) R R eq ==> @padded_refines_eq E R R eq)
         (fun ctx => @interp_mrec_spec D E ctx R).
Proof.
  repeat intro. subst. unfold padded_refines_eq in *.
  eapply padded_refines_interp_mrec with (RPreInv := eqPreRel) (RPostInv := eqPostRel) ; eauto.
  - intros.
    eqPreRel_inv H1.
    eapply refines_monot; try eapply H.
    + intros.  eqPreRel_inv PR. destruct x2; repeat constructor.
    + intros. inv PR; inj_existT; subst; eqPostRel_inv H7; constructor.
    + intros. subst. constructor.
  - eapply refines_monot; try eapply H0.
    + intros. eqPreRel_inv PR. destruct x2; repeat constructor.
    + intros. inv PR; inj_existT; subst; eqPostRel_inv H7; constructor.
    + auto.
Qed.

Global Instance refines_proper_interp_mrec_spec_eq E D R :
  Proper (eq ==> @padded_refines_eq (D +' E) R R eq ==> @padded_refines_eq E R R eq)
         (fun ctx => @interp_mrec_spec D E ctx R).
Proof.
  repeat intro.
  apply refines_proper_interp_mrec_spec; auto.
  intros. subst. reflexivity.
Qed.

(*
Global Instance padded_refines_eq_bind_proper  E1 E2 RPre RPost R1 R2 RR :
  Proper (padded_refines_eq eq ==> eq ==> @padded_refines E1 E2 R1 R2 RPre RPost RR) ITree.bind.
*)
(*from there there is a bit more *)

(*need at least bind and ret rules for interp_mrec_spec *)

(** * more lemmas about interp_mrec *)

Lemma interp_mrec_ret :
  forall {D E : Type -> Type} (ctx : forall T : Type, D T -> itree (D +' E) T) R (r :R),
    interp_mrec ctx (Ret r) ≅ Ret r.
Proof.
  intros. setoid_rewrite unfold_iter. cbn. rewrite bind_ret_l. reflexivity.
Qed.

Lemma interp_mrec_exists_spec E D T (ctx : forall T, D T -> itree_spec (D +' E) T) :
  interp_mrec_spec ctx (exists_spec T) ≈ exists_spec T.
Proof.
  setoid_rewrite interp_mrec_spec'_exists.
  cbn. apply eqit_Vis. intros.  pstep. red. cbn. constructor. auto.
Qed.

Lemma interp_mrec_forall_spec E D T (ctx : forall T, D T -> itree_spec (D +' E) T) :
  interp_mrec_spec ctx (forall_spec T) ≈ forall_spec T.
Proof.
  setoid_rewrite interp_mrec_spec'_forall.
  cbn. apply eqit_Vis. intros.  pstep. red. cbn. constructor. auto.
Qed.

Lemma interp_mrec_spec_assume E D T (ctx : forall T, D T -> itree_spec (D +' E) T) :
  interp_mrec_spec ctx (assume_spec T) ≈ assume_spec T.
Proof.
  cbn. setoid_rewrite interp_mrec_spec_bind.
  setoid_rewrite interp_mrec_spec'_forall. rewrite bind_vis, bind_trigger.
  apply eqit_Vis. intros. setoid_rewrite interp_mrec_spec_ret. rewrite bind_ret_l.
  reflexivity.
Qed.

Lemma interp_mrec_spec_assert E D T (ctx : forall T, D T -> itree_spec (D +' E) T) :
  interp_mrec_spec ctx (assert_spec T) ≈ assert_spec T.
Proof.
  cbn. setoid_rewrite interp_mrec_spec_bind.
  setoid_rewrite interp_mrec_spec'_exists. rewrite bind_vis, bind_trigger.
  apply eqit_Vis. intros. setoid_rewrite interp_mrec_spec_ret. rewrite bind_ret_l.
  reflexivity.
Qed.

Ltac normalize_interp_mrec_spec :=
  match goal with
  | |- context [ITree.bind (ITree.bind ?t ?k1) ?k2 ] => setoid_rewrite bind_bind
  | |- context [interp_mrec_spec ?ctx (ITree.bind ?t ?k) ] => setoid_rewrite interp_mrec_spec_bind
  | |- context [interp_mrec_spec ?ctx (exists_spec ?T) ] => setoid_rewrite interp_mrec_exists_spec
  | |- context [interp_mrec_spec ?ctx (forall_spec ?T) ] => setoid_rewrite interp_mrec_forall_spec
  | |- context [interp_mrec_spec ?ctx (assert_spec ?T) ] => setoid_rewrite interp_mrec_spec_assert
  | |- context [interp_mrec_spec ?ctx (assume_spec ?T) ] => setoid_rewrite interp_mrec_spec_assume
  end.

(** * or_spec, and_spec *)

Lemma or_spec_l E1 E2 RPre RPost R1 R2 RR (t1 t2 : itree_spec E1 R1) (t3 : itree_spec E2 R2) :
  @padded_refines E1 E2 R1 R2 RPre RPost RR t1 t3 ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR t2 t3 ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR (or_spec t1 t2) t3.
Proof.
  intros. unfold or_spec. unfold padded_refines in *.
  rewrite pad_vis. pstep. constructor. intros [ | ]; constructor; pstep_reverse.
Qed.

Lemma or_spec_r E1 E2 RPre RPost R1 R2 RR (t1 : itree_spec E1 R1) (t2 t3: itree_spec E2 R2) :
  (@padded_refines E1 E2 R1 R2 RPre RPost RR t1 t2 \/
  @padded_refines E1 E2 R1 R2 RPre RPost RR t1 t3) ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR t1 (or_spec t2 t3).
Proof.
  intros. unfold or_spec. unfold padded_refines in *.
  rewrite pad_vis. pstep.
  destruct H.
  - econstructor. constructor. Unshelve. all : try (apply true). pstep_reverse.
  - econstructor. constructor. Unshelve. all : try (apply false). pstep_reverse.
Qed.

Lemma interp_mrec_spec_or  (E : Type -> Type) (R : Type) (D : Type -> Type) (ctx : forall T : Type, D T -> itree_spec (D +' E) T)
  (t1 t2 : itree_spec _ R)
  : interp_mrec_spec ctx (or_spec t1 t2) ≅ or_spec (interp_mrec_spec ctx t1) (interp_mrec_spec ctx t2).
Proof.
  setoid_rewrite interp_mrec_spec'_exists. apply eqit_Vis. intros [ | ]; reflexivity.
Qed.

(*should be able to generalize this to cany concrete tree *)
Lemma or_spec_r_Ret_inv E1 E2 R1 R2 RPre RPost RR r t2 t3 :
  @padded_refines E1 E2 R1 R2 RPre RPost RR (Ret r) (or_spec t2 t3) ->
  padded_refines RPre RPost RR (Ret r) t2 \/ padded_refines RPre RPost RR (Ret r) t3.
Proof.
  intros Hor. unfold padded_refines in *. setoid_rewrite pad_ret in Hor.
  setoid_rewrite pad_ret. setoid_rewrite pad_vis in Hor.
  pinversion Hor. inj_existT. subst. inv H1. destruct a.
  - left. pstep. auto.
  - right. pstep. auto.
Qed.

Lemma or_spec_bind_l  E1 E2 R1 S R2 RPre RPost RR (t1 t2 : itree_spec E1 S) (k : S -> itree_spec E1 R1) (t3 : itree_spec E2 R2) :
  padded_refines RPre RPost RR (ITree.bind t1 k) t3 ->
  padded_refines RPre RPost RR (ITree.bind t2 k) t3 ->
  padded_refines RPre RPost RR (ITree.bind (or_spec t1 t2) k) t3.
Proof.
  unfold padded_refines. intros. setoid_rewrite bind_vis. setoid_rewrite pad_vis.
  pstep. constructor. intros [ | ]; constructor; pstep_reverse.
Qed.

(** * spin *)

Lemma spin_bind E R S k : (@ITree.spin E R) >>= k ≅ @ITree.spin E S.
Proof.
  ginit. gcofix CIH. gstep. red. cbn. constructor.
  gfinal. eauto.
Qed.

Lemma interp_mrec_spec_spin (E : Type -> Type) (R : Type) (D : Type -> Type) (ctx : forall T : Type, D T -> itree_spec (D +' E) T) :
  interp_mrec_spec ctx ITree.spin ≅ @ITree.spin _ R.
Proof.
  pcofix CIH. pstep. red. cbn. constructor.
  right. eauto.
Qed.

(** * total_spec, partial_spec *)

Lemma padded_refines_ret E1 E2 R1 R2 RPre RPost RR r1 r2 :
  (RR r1 r2 : Prop) ->
  @padded_refines E1 E2 R1 R2 RPre RPost RR (Ret r1) (Ret r2).
Proof.
  intros Hr. red. repeat rewrite pad_ret. pstep. constructor. auto.
Qed.

Fixpoint trepeat {E R} (n : nat) (t : itree E R) : itree E unit :=
  match n with
  | 0 => Ret tt
  | S m => t;; trepeat m t end.

Lemma trepeat_Sn E R (n : nat) (t : itree E R) :
  trepeat (S n) t ≅ t;; trepeat n t.
Proof.
  apply eqit_bind; reflexivity.
Qed.

Lemma trepeat_0 E R (t : itree E R) :
  trepeat 0 t ≅ Ret tt.
Proof. reflexivity. Qed.

Section SpecFix.
  Context {A B: Type} {E : Type -> Type}.
  Context (Pre : A -> Prop) (Post : A -> B -> Prop).
  Context (prog : A -> itree_spec E B).

  Context (Rdec : A -> A -> Prop).
  Context (HRdec : well_founded Rdec).

  Context (Hprog : forall a, isConcrete (prog a)).
  Variant pre_call : forall C, callE A B C -> Prop :=
    | pre_call_intro (a : A) : Pre a -> pre_call B (Call a).
  Variant post_call : forall C, callE A B C -> C -> Prop :=
    | post_call_intro a b : Post a b -> post_call B (Call a) b.

  Definition total_spec (a : A) : itree_spec E B :=
    assume_spec (Pre a);;
    b <- exists_spec B;;
    assert_spec (Post a b);;
    Ret b.

  (* better for using as a final spec *)
  Definition partial_spec (a : A) : itree_spec E B :=
    or_spec (total_spec a) ITree.spin.
  (* better for syntax driven solving *)
  (**)

  Definition partial_spec_fix : A -> itree_spec E B :=
    rec_fix_spec (fun rec a =>
                    assume_spec (Pre a);;
                    (
                      n <- exists_spec nat;;
                      trepeat n (a' <- exists_spec A;; assert_spec (Pre a');; rec a')
                    );;
                    b <- exists_spec B;;
                    assert_spec (Post a b);;
                    Ret b
                 ).

  Definition partial_spec_fix' : A -> itree_spec E B :=
    rec_fix_spec (fun rec a =>
                        assume_spec (Pre a);;
                        (
                          n <- exists_spec nat;;
                          trepeat n (a' <- exists_spec A;; assert_spec (Pre a');; rec a')
                        );;
                        or_spec (
                            b <- exists_spec B;;
                            assert_spec (Post a b);;
                            Ret b)
                        ITree.spin
                 ).

  Definition total_spec_fix : A -> itree_spec E B :=
    rec_fix_spec (fun rec a =>
                    assume_spec (Pre a);;
                    (
                      n <- exists_spec nat;;
                      trepeat n (a' <- exists_spec A;; assert_spec (Pre a' /\ Rdec a' a);; rec a')
                    );;
                    b <- exists_spec B;;
                    assert_spec (Post a b);;
                    Ret b
                 ).

  (* here would be a good place for proofs that partial_spec_fix' is greater than any of these
     from there I should be able to prove that total_spec_fix
   *)

  Lemma total_spec_fix_total a : padded_refines_eq eq (total_spec_fix a) (total_spec a).
  Proof.
    revert a.
    apply well_founded_ind with (R := Rdec). auto.
    intros a Hind. unfold total_spec_fix. simpl.
    setoid_rewrite interp_mrec_spec_bind.
    match goal with |- context [ interp_mrec_spec ?k _ ] => set k as body end.
    unfold total_spec. assumesr. intros Ha. setoid_rewrite interp_mrec_spec_assume.
    assumesl. auto. rewrite bind_bind.  setoid_rewrite interp_mrec_spec_bind.
    setoid_rewrite interp_mrec_exists_spec. existssl. intros n.
    induction n.
    - simpl. rewrite bind_ret_l. setoid_rewrite interp_mrec_spec_bind.
      setoid_rewrite interp_mrec_exists_spec.
      setoid_rewrite interp_mrec_spec_bind. setoid_rewrite interp_mrec_spec_assert.
      setoid_rewrite interp_mrec_spec_ret. reflexivity.
    - simpl. rewrite bind_bind. setoid_rewrite interp_mrec_spec_bind.
      setoid_rewrite IHn. setoid_rewrite interp_mrec_spec_bind.
      setoid_rewrite interp_mrec_exists_spec. rewrite bind_bind. existssl.
      intros a'. setoid_rewrite interp_mrec_spec_bind.
      setoid_rewrite interp_mrec_spec_assert. rewrite bind_bind. assertsl.
      intros [Hprea' Hdec]. simpl.
      assert (Htot : interp_mrec_spec body (call_spec a') ≈ total_spec_fix a').
      { unfold total_spec_fix, rec_fix_spec, rec_spec, mrec_spec .
        setoid_rewrite interp_mrec_spec_inl. rewrite tau_eutt. rewrite bind_ret_r.
        reflexivity. }
      rewrite Htot, Hind; auto. unfold total_spec.
      setoid_rewrite bind_bind at 1. assumesl. auto.
      setoid_rewrite bind_bind at 1. existssl. intros b.
      setoid_rewrite bind_bind at 1. assertsl. intros. rewrite bind_ret_l. reflexivity.
   Qed.

    Lemma partial_spec_fix_conv_ref :
    forall a, Pre a -> conv_ref (partial_spec_fix' a).
  Proof.
    intros a Ha.
    eapply conv_ref_mrec_conv_ref with (Pre := pre_call).
    constructor. auto.
    intros. inv H. inj_existT. subst.
    clear a Ha.
    rename a0 into a. rename H2 into Ha. clear H0. cbn.
    apply conv_ref_mrec_bind.  rewrite bind_trigger. apply conv_ref_mrec_forall.
    auto. intros. apply conv_ref_mrec_ret.
    intros []. rewrite bind_bind. apply conv_ref_mrec_bind.
    apply conv_ref_mrec_exists. intros. apply conv_ref_mrec_ret.
    intros n. induction n; cbn.
    - rewrite bind_ret_l. apply conv_ref_mrec_exists. intros [ | ].
      2 : apply conv_ref_mrec_spin. apply conv_ref_mrec_bind.
      + apply conv_ref_mrec_exists. intros. apply conv_ref_mrec_ret.
      + intros. rewrite bind_bind. setoid_rewrite bind_vis.
        apply conv_ref_mrec_exists. intros. repeat rewrite bind_ret_l.
        apply conv_ref_mrec_ret.
    - rewrite bind_bind. apply conv_ref_mrec_bind; intros; auto.
      apply conv_ref_mrec_bind.
      + apply conv_ref_mrec_exists. intros. apply conv_ref_mrec_ret.
      + intros. rewrite bind_bind. setoid_rewrite bind_vis.
        apply conv_ref_mrec_exists.
        intros. repeat rewrite bind_ret_l. pstep. red. cbn.
        constructor. constructor. auto. left.
        apply conv_ref_mrec_ret.
  Qed.

  Lemma prog_ret_spin : forall a, Pre a ->
                             padded_refines_eq eq (prog a) (partial_spec_fix' a) ->
                             (exists b, prog a ≈ Ret b) \/ (prog a ≈ ITree.spin).
  Proof.
    intros a Href Ha. apply no_ev_to_dec.
    eapply concrete_conv_ref_padded_to_no_ev; eauto.
    apply partial_spec_fix_conv_ref. auto.
  Qed.
    (* need a padded_refines version *)

(*   Lemma partial_spec_fix_partial_spec' a :
    (Pre a -> padded_refines_eq eq (prog a) (partial_spec_fix' a)) ->
    padded_refines_eq eq (prog a) (partial_spec a). *)

  Lemma partial_spec_fix_partial_spec_assume_succeed':
    forall (a : A) (b : B),
      Pre a ->
      padded_refines_eq eq (Ret b) (partial_spec_fix' a) ->
      padded_refines_eq eq (Ret b) (partial_spec a).
  Proof.
    intros a b Ha Hfix. unfold partial_spec_fix' in Hfix. cbn in Hfix.
    repeat setoid_rewrite interp_mrec_spec_or in Hfix.

    (*need an inversion principle for or spec *)
    (*could use rewrite for interp_mrec_spec and or_spec *)
    do 2 setoid_rewrite interp_mrec_spec_bind in Hfix. revert Hfix.
    match goal with | |- context [ interp_mrec_spec ?f _ ] => set f as body end.
    intro Hfix.
    assert (
        padded_refines_eq eq (interp_mrec_spec body (or_spec (b <- exists_spec B;; _ <- assert_spec (Post a b);; Ret b) ITree.spin)) (partial_spec a)).
    {
      rewrite interp_mrec_spec_or. unfold partial_spec.
      apply or_spec_l.
      - apply or_spec_r. left. unfold total_spec.
        assumesr. intros. repeat setoid_rewrite interp_mrec_spec_bind.
        normalize_interp_mrec_spec. setoid_rewrite interp_mrec_spec_ret.
        setoid_rewrite bind_bind. setoid_rewrite bind_ret_l.
        eapply padded_refines_bind. reflexivity.
        intros. subst. eapply padded_refines_bind. reflexivity.
        intros. subst. reflexivity.
      - apply or_spec_r. right. rewrite interp_mrec_spec_spin. reflexivity.
    } setoid_rewrite H in Hfix.
    setoid_rewrite interp_mrec_spec_ret in Hfix.
    match type of Hfix with padded_refines_eq eq _ ?t => set t as t1 end.
    fold t1 in Hfix.

    assert (t1 ≈ (interp_mrec_spec body (trigger (@Spec_forall _ (Pre a))) >>
                 Ret tt >>
                  (interp_mrec_spec body
           (ITree.bind (exists_spec nat)
              (fun n : nat => trepeat n (ITree.bind (exists_spec A) (fun a' : A =>
                       trigger (@Spec_exists _ (Pre a')) >> Ret tt >> call_spec a'))))) >> partial_spec a)
                 ).
    {
      unfold t1. repeat rewrite bind_bind.
      apply eqit_bind. reflexivity. intro.
      reflexivity.
    }
    rewrite H0 in Hfix. clear H0.
    (*might have dropped an important assumption *)
    eapply padded_conv_ref_ret_bind; eauto.
    normalize_interp_mrec_spec. cbn.
    apply conv_ref_bind.
    { pstep. red. cbn. constructor; auto. intros a0.
          left. pstep. red. cbn. constructor. }
    intros _.  setoid_rewrite bind_ret_l.
    eapply conv_ref_interp_mrec_conv_ref.
    Unshelve. 3 : { intros C c. destruct c. apply (Pre a0). }
    - cbn.
      intros. destruct d. cbn.
      clear - H0 Ha. setoid_rewrite bind_bind.
      apply conv_ref_mrec_bind.
      { pstep. red. cbn. constructor. auto. left.
        pstep. constructor. }
      intros _. rewrite bind_ret_l.
      repeat rewrite bind_bind. unfold or_spec. setoid_rewrite bind_vis.
      apply conv_ref_mrec_exists. intros n.
      rewrite bind_ret_l.
      eapply conv_ref_mrec_bind.
      + induction n. cbn. pstep. constructor.
        cbn. apply conv_ref_mrec_bind; intros; eauto.
        apply conv_ref_mrec_bind. apply conv_ref_mrec_exists.
        intros. pstep. constructor. intros.
        rewrite bind_bind.
        setoid_rewrite bind_vis.
        apply conv_ref_mrec_exists. intros Hr.
        repeat rewrite bind_ret_l. apply conv_ref_mrec_inl.
        auto. intros. pstep. constructor.
      + intros []. apply conv_ref_mrec_exists.
        intros [ | ]; try apply conv_ref_mrec_spin.
        setoid_rewrite bind_vis. apply conv_ref_mrec_exists.
        intros. setoid_rewrite bind_ret_l. rewrite bind_bind. setoid_rewrite bind_vis.
        apply conv_ref_mrec_exists. intros.
        repeat rewrite bind_ret_l. pstep. constructor.
    - setoid_rewrite bind_vis. setoid_rewrite bind_ret_l.
      apply conv_ref_mrec_exists. intros n. clear - n Ha.
      induction n. cbn. pstep. constructor.
      cbn. eapply conv_ref_mrec_bind; eauto.
      setoid_rewrite bind_bind. setoid_rewrite bind_ret_l.
      setoid_rewrite bind_vis.
      apply conv_ref_mrec_exists. intros a0. rewrite bind_ret_l.
      setoid_rewrite bind_vis. apply conv_ref_mrec_exists. intros Ha0.
      rewrite bind_ret_l. apply conv_ref_mrec_inl. auto. intros. pstep. constructor.
  Qed.

  Lemma partial_spec_fix_partial_spec_assume_fail a :
    ~ Pre a -> padded_refines_eq eq (prog a) (partial_spec a).
  Proof.
    intros HPre. apply or_spec_r.
    left. assumesr. intros. contradiction.
  Qed.

  Lemma partial_spec_fix_partial_spec_assume_succeed:
    forall (a : A) (b : B),
      padded_refines_eq eq (Ret b) (partial_spec_fix a) ->
      padded_refines_eq eq (Ret b) (partial_spec a).
  Proof.
    intros a b Hfix.
    apply or_spec_r. left. unfold total_spec.
    assumesr. intros Ha.
    unfold partial_spec_fix in Hfix.
    do 2 setoid_rewrite interp_mrec_spec_bind in Hfix. revert Hfix.
    match goal with | |- context [ interp_mrec_spec ?f _ ] => set f as body end.
    intro Hfix.
    assert (interp_mrec_spec body (b <- exists_spec B;; _ <- assert_spec (Post a b);; Ret b) ≈
                             (b <- exists_spec B;; _ <- assert_spec (Post a b);; Ret b)).
    {
      repeat setoid_rewrite interp_mrec_spec_bind.
      normalize_interp_mrec_spec.
      setoid_rewrite interp_mrec_spec_ret. cbn. reflexivity.
    } setoid_rewrite H in Hfix.
    (* need to manage diff between padded_refines and refines *)
    cbn in Hfix. setoid_rewrite <- bind_bind in Hfix.
    eapply padded_conv_ref_ret_bind; eauto.
    setoid_rewrite interp_mrec_spec_ret.
    apply conv_ref_bind.
    { pstep. red. cbn. constructor; auto. intros a0.
          left. pstep. red. cbn. constructor. }
    intros _.
    eapply conv_ref_interp_mrec_conv_ref.
    Unshelve. 3 : { intros C c. destruct c. apply (Pre a0). }
    - cbn.
      intros. destruct d. cbn.
      clear - H0 Ha.
      repeat rewrite bind_bind. setoid_rewrite bind_ret_l.
      apply conv_ref_mrec_bind.
      apply conv_ref_mrec_forall. auto. intros. pstep. constructor.
      intros. rewrite <- bind_bind.
      apply conv_ref_mrec_bind.
      + rewrite bind_bind. apply conv_ref_mrec_bind.
        apply conv_ref_mrec_exists. intros. pstep. constructor.
        intros n.
        induction n; cbn. rewrite bind_ret_l. apply conv_ref_mrec_exists.
        intros. pstep. constructor. rewrite bind_bind.
        eapply conv_ref_mrec_bind; intros; eauto.
        setoid_rewrite bind_vis. apply conv_ref_mrec_exists.
        intros. setoid_rewrite bind_ret_l. rewrite bind_bind. setoid_rewrite bind_vis.
        apply conv_ref_mrec_exists. intros. repeat rewrite bind_ret_l.
        apply conv_ref_mrec_inl. auto. intros. pstep. constructor.
      + intros b. rewrite bind_bind. setoid_rewrite bind_vis.
        apply conv_ref_mrec_exists. intros HPost. repeat rewrite bind_ret_l.
        pstep. constructor.
    - setoid_rewrite bind_vis. setoid_rewrite bind_ret_l.
      apply conv_ref_mrec_exists. intros n. clear - n Ha.
      induction n. cbn. pstep. constructor.
      cbn. eapply conv_ref_mrec_bind; eauto.
      setoid_rewrite bind_bind. setoid_rewrite bind_ret_l.
      setoid_rewrite bind_vis.
      apply conv_ref_mrec_exists. intros a0. rewrite bind_ret_l.
      setoid_rewrite bind_vis. apply conv_ref_mrec_exists. intros Ha0.
      rewrite bind_ret_l. apply conv_ref_mrec_inl. auto. intros. pstep. constructor.
  Qed.

  Lemma partial_spec_fix_partial_spec' a :
    (Pre a -> padded_refines_eq eq (prog a) (partial_spec_fix' a)) ->
    padded_refines_eq eq (prog a) (partial_spec a).
  Proof.
    intros Hfix. destruct (classic (Pre a)).
    - specialize (Hfix H). apply prog_ret_spin in H as Hdec; auto.
      destruct Hdec as [ [b Hb] | Hspin ].
      + rewrite Hb. rewrite Hb in Hfix.
        apply partial_spec_fix_partial_spec_assume_succeed'; auto.
      + rewrite Hspin. apply or_spec_r. right. reflexivity.
    - apply or_spec_r. left. assumesr. intro. contradiction.
  Qed.

  Lemma partial_spec_fix_partial_spec a :
    (Pre a -> padded_refines_eq eq (prog a) (partial_spec_fix a)) ->
    padded_refines_eq eq (prog a) (partial_spec a).
  Proof.
    intros Hfix. apply partial_spec_fix_partial_spec'.
    intros Ha. specialize (Hfix Ha). etransitivity; eauto.
    eapply padded_refines_monot with (RPre1 := eqPreRel) (RPost1 := eqPostRel)
    (RR1 := eqPostRel _ _ (Call a) (Call a)); auto.
    { intros. eqPostRel_inv PR. auto. }
    eapply padded_refines_mrec with (RPreInv := eqPreRel).
    2 : constructor.
    intros. eqPreRel_inv H. clear Ha Hfix a. destruct d2.
    simpl. assumesr. intros Ha. assumesl. auto.
    repeat rewrite bind_bind.
    existssl. intros n. existssr n.
    apply padded_refines_bind with (RR := eq).
    + apply refl_refines. red. intros. destruct e; do 2 constructor.
      red. intros. inv H. inj_existT. subst. eqPostRel_inv  H6. auto.
      inj_existT. subst. eqPostRel_inv H6. auto.
      auto. apply pad_is_padded.
    + intros [] [] _ .
      apply or_spec_r. left. existssl. intros b.
      existssr b. assertsl. intros. assertsr. auto. apply padded_refines_ret.
      constructor.
   Qed.

  Lemma partial_spec_fix_spin' a :
    padded_refines_eq eq ITree.spin (partial_spec_fix' a).
  Proof.
    unfold partial_spec_fix'. setoid_rewrite interp_mrec_spec_bind.
    repeat normalize_interp_mrec_spec. assumesr. intros.
    setoid_rewrite interp_mrec_spec_bind.
    setoid_rewrite interp_mrec_spec_bind.
    normalize_interp_mrec_spec.
    match goal with |- context [ interp_mrec_spec ?body_ _  ] => set body_ as body end.
    setoid_rewrite interp_mrec_exists_spec. existssr 0. cbn.
    rewrite interp_mrec_spec_ret, bind_ret_l. rewrite interp_mrec_spec_or.
    apply or_spec_r. right. rewrite interp_mrec_spec_spin. reflexivity.
  Qed.

End SpecFix.