(* (c) Copyright Christian Doczkal and Joachim Bard                       *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations Lia Setoid Morphisms.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs
 Require Import edone bcase fset base modular_hilbert sltype rewrite_inequality fset_tac.

Set Default Proof Using "Type".

(* add this globally in fset.v ? *)
#[export] Hint Resolve subxx : core.

Lemma sizes1 (T : choiceType) (x : T) : size [fset x] = 1.
Proof. by rewrite fset1Es. Qed.

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

(** * PDL in Coq  *)

(** ** Formulas *)

Definition var := nat.
Definition pvar := nat.

Inductive prog :=
  pV    of pvar
| pCh   of prog & prog
| pSeq  of prog & prog
| pStar of prog
| pTest of form

with form :=
| fF
| fV   of var
| fImp of form & form
| fAX  of prog & form.

Notation "[ p ] s" := (fAX p s) (right associativity, at level 0, format "[ p ] s").
Notation "p ^*" := (pStar p) (at level 30, format "p ^*").
Notation "p0 ;; p1" := (pSeq p0 p1) (at level 45, right associativity, format "p0  ;;  p1").
Notation "p0 + p1" := (pCh p0 p1) (at level 50, left associativity, format "p0  +  p1").
Notation "a ??" := (pTest a) (at level 1,format "a ??").

Scheme form_mind := Induction for form Sort Prop
with prog_mind := Induction for prog Sort Prop.

Combined Scheme form_prog_ind from form_mind,prog_mind.

Scheme form_mrect := Induction for form Sort Type
with prog_mrect := Induction for prog Sort Type.

Combined Scheme form_prog_rect from form_mrect,prog_mrect.

Module Eq.
Fixpoint eqf (s t : form) :=
  match s, t with
  | fV p,fV q => p == q
  | fF,fF => true
  | fImp s1 t1,fImp s2 t2 => eqf s1 s2 && eqf t1 t2
  | [a]s, [b]t => eqp a b && eqf s t
  | _,_ => false
  end
with eqp (p q : prog) :=
  match p,q with
  | pV a,pV b => a == b
  | a1 ;; b1, a2 ;; b2 => eqp a1 a2 && eqp b1 b2
  | a1 + b1, a2 + b2 => eqp a1 a2 && eqp b1 b2
  | a^*,b^* => eqp a b
  | s??,t?? => eqf s t
  | _,_ => false
  end.

Lemma form_prog_dec :
  (forall s t, reflect (s = t) (eqf s t)) *
  (forall a b, reflect (a = b) (eqp a b)).
Proof with case => /=; try (constructor; discriminate).
  apply:form_prog_rect.
  - move... by constructor.
  - move => p... move => q. apply: (iffP eqP); congruence.
  - move => s IHs t IHt... move => s' t'.
    by apply: (iffP andP) => [[/IHs -> /IHt ->]|[/IHs ? /IHt ?]].
  - move => s IHs t IHt... move => s' t'.
    by apply: (iffP andP) => [[/IHs -> /IHt ->]|[/IHs ? /IHt ?]].
  - move => p... move => q. apply: (iffP eqP); congruence.
  - move => a IHa b IHb... move => a' b'.
    by apply: (iffP andP) => [[/IHa -> /IHb ->]|[/IHa ? /IHb ?]].
  - move => a IHa s IHs... move => a' s'.
    by apply: (iffP andP) => [[/IHa -> /IHs ->]|[/IHa ? /IHs ?]].
  - move => p IHp... move => q. apply: (iffP (IHp _)); congruence.
  - move => s IHs... move => t. apply: (iffP (IHs _)); congruence.
Qed.
End Eq.

Definition form_eqMixin := EqMixin (fst Eq.form_prog_dec).
Canonical Structure form_eqType := Eval hnf in @EqType form form_eqMixin.

Definition prog_eqMixin := EqMixin (snd Eq.form_prog_dec).
Canonical Structure prog_eqType := Eval hnf in @EqType prog prog_eqMixin.

(** To use formulas and other types built around formulas as base type
for the finite set libaray, we need to show that formulas are
countable. We do this by embedding formulas into the Ssreflect's
generic trees *)

Module formChoice.
  Import GenTree.

  Fixpoint picklef (s : form) :=
    match s with
      | fV v => Leaf v
      | fF => Node 0 [::]
      | fImp s t => Node 1 [:: picklef s ; picklef t]
      | fAX p s => Node 2 [:: picklep p ; picklef s]
    end
  with picklep (p : prog) :=
    match p with
    | pV v => Leaf v
    | pSeq p1 p2 => Node 0 [:: picklep p1 ; picklep p2]
    | pCh p1 p2 => Node 1 [:: picklep p1 ; picklep p2]
    | pStar p => Node 2 [:: picklep p]
    | pTest s => Node 3 [:: picklef s]
    end.

  Fixpoint unpicklef t :=
    match t with
      | Leaf v  => Some (fV v)
      | Node 0 [::]  => Some (fF)
      | Node 1 [:: t ; t' ] =>
          obind (fun s => obind (fun s' => Some (fImp s s')) (unpicklef t')) (unpicklef t)
      | Node 2 [:: p ; t ] =>
          obind (fun q => obind (fun s => Some (fAX q s)) (unpicklef t)) (unpicklep p)
      | _ => None
    end
  with unpicklep t :=
    match t with
    | Leaf v => Some (pV v)
    | Node 0 [:: t ; t'] =>
      obind (fun p => obind (fun p' => Some (pSeq p p')) (unpicklep t')) (unpicklep t)
    | Node 1 [:: t ; t'] =>
      obind (fun p => obind (fun p' => Some (pCh p p')) (unpicklep t')) (unpicklep t)
    | Node 2 [:: t] => obind (fun p => Some (pStar p)) (unpicklep t)
    | Node 3 [:: s] => obind (fun s => Some (pTest s)) (unpicklef s)
    | _ => None
    end.

  Lemma pickleP : (pcancel picklef unpicklef) /\ (pcancel picklep unpicklep).
  Proof.
    apply: form_prog_ind => //= *;
    by repeat match goal with [ H : _ = Some _ |- _] => rewrite ?H /= => {H} end.
  Qed.

  Lemma picklefP : pcancel picklef unpicklef.
  Proof. by apply pickleP. Qed.

End formChoice.

(** Note that we only need the [choiceType] and [countType] instances for formulas *)

Definition form_countMixin := PcanCountMixin formChoice.picklefP.
Definition form_choiceMixin := CountChoiceMixin form_countMixin.
Canonical Structure form_ChoiceType := Eval hnf in ChoiceType form form_choiceMixin.
Canonical Structure form_CountType := Eval hnf in CountType form form_countMixin.

(** ** Models

We distinguish three classes of models

- raw models or transition systems ([ts]): The inductive satisfaction relation
  [eval] is defined on this class

- finite models ([fmodel]): models where the type of states is finite and
  everything else is decidable

- classical models, i.e., models where [eval] is stable under double negation
  ([cmodel]): This is the largest class of models for which we can show
  soundness of the hilbert system. *)

Definition stable X Y (R : X -> Y -> Prop) := forall x y, ~ ~ R x y -> R x y.
Definition ldec X Y (R : X -> Y -> Prop) := forall x y, R x y \/ ~ R x y.

Record ts := TS {
  state  :> Type;
  trans  : var -> state -> state -> Prop;
  label  : var -> state -> Prop
}.
Prenex Implicits trans.

Record fmodel := FModel {
  fstate :> finType;
  ftrans : var -> rel fstate;
  flabel : var -> pred fstate
}.
Prenex Implicits ftrans.

(** Make ts inferable for states of fmodels *)
Canonical ts_of_fmodel (M : fmodel) : ts := TS (@ftrans M) (@flabel M).
Coercion ts_of_fmodel : fmodel >-> ts.

(** ** Satisfaction relation *)

Inductive star X (R: X -> X -> Prop) (x : X) : X -> Prop :=
| Star0 : star R x x
| StarL y z : R x z -> star R z y -> star R x y.

Section Eval.
Variables (M : ts).

Fixpoint eval (s: form) :=
  match s with
    | fF       => (fun _ => False)
    | fV x     => label x
    | fImp s t => (fun v => eval s v -> eval t v)
    | fAX p s  => (fun v => forall w, reach p v w -> eval s w)
  end
with reach (p: prog) : M -> M -> Prop :=
  match p with
  | pV a => trans a
  | pSeq p0 p1 => (fun v w => exists2 u, reach p0 v u & reach p1 u w)
  | pCh p0 p1 => (fun v w => reach p0 v w \/ reach p1 v w)
  | pStar p => star (reach p)
  | pTest s => fun v w => w = v /\ eval s v
  end.
End Eval.

Record cmodel := CModel { ts_of :> ts; modelP : stable (@eval ts_of) }.

(** Decidability of the satisfaction relation on finite models *)

Section Evalb.
Variables (M : fmodel).

Fixpoint evalb (s: form) :=
  match s with
    | fF       => xpred0
    | fV x     => flabel x
    | fImp s t => (fun v => evalb s v ==> evalb t v)
    | fAX p s  => (fun v => [forall (w | reachb p v w), evalb s w])
  end
with reachb (p: prog) : M -> M -> bool :=
  match p with
  | pV a => ftrans a
  | pSeq p0 p1 => (fun v w => [exists u, reachb p0 v u && reachb p1 u w])
  | pCh p0 p1 => (fun v w => reachb p0 v w || reachb p1 v w)
  | pStar p => connect (reachb p)
  | pTest s => fun v w => (w == v) && evalb s v
  end.
End Evalb.

Lemma eval_reachP (M : fmodel) :
  ((forall s (w:M), reflect (eval s w) (evalb s w))*
   (forall p (w v : M), reflect (reach p w v) (reachb p w v)%type)).
Proof.
  apply: form_prog_rect =>
  [?|? ?|s IHs t IHt w|p IHp s IHs w|? ? ?|p IHp q IHq w v|p IHp q IHq w v||] /=.
  - by constructor.
  - exact: idP.
  - apply: (iffP implyP); rewrite -(rwP (IHs _)) -(rwP (IHt _)); tauto.
  - apply: (iffP forall_inP); move => H v /IHp ?; apply/IHs; by auto.
  - exact: idP.
  - apply: (iffP orP); rewrite -(rwP (IHp _ _)) -(rwP (IHq _ _)); tauto.
  - apply: (iffP exists_inP); move => [u ? ?]; exists u; by [apply/IHp|apply/IHq].
  - move => p IHp w v. apply: (iffP connectP) => [[ps]|].
    + elim: ps w v => //= [? ? _ -> |u us IH w v]; first by constructor.
      case/andP => /IHp A B ->. apply: StarL A _. exact: IH.
    + elim => {w v} => [w|w v u A _ [ps B C]]; first by exists [::].
      exists (u::ps) => //=. rewrite B andbT. exact/IHp.
  - move => s IHs w v. apply: (iffP andP); rewrite (rwP eqP) (rwP (IHs _)); tauto.
Qed.

Lemma evalP (M:fmodel) (w : M) s : reflect (eval s w) (evalb s w).
Proof. by apply eval_reachP. Qed.

Lemma fin_modelP (M:fmodel) : stable (@eval M).
Proof. move => s v. case: (decP (evalP v s)); tauto. Qed.

Definition cmodel_of_fmodel (M : fmodel) := CModel (@fin_modelP M).
Coercion cmodel_of_fmodel : fmodel >-> cmodel.

(** ** Axiomatization *)

Section Hilbert.
  Local Notation "s ---> t" := (fImp s t).

  Inductive prv : form -> Prop :=
  | rMP s t : prv (s ---> t) -> prv s -> prv t
  | axK s t : prv (s ---> t ---> s)
  | axS s t u : prv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t)
  | axDN' s : prv (((s ---> fF) ---> fF)  ---> s)

  | rNec p s : prv s -> prv ([p]s)
  | axN p s t : prv ([p](s ---> t) ---> [p]s ---> [p]t)

  | axConE p0 p1 s: prv ([p0;;p1]s ---> [p0][p1]s)
  | axCon p0 p1 s: prv ([p0][p1]s ---> [p0;;p1]s)
  | axChEl p0 p1 s: prv ([p0 + p1]s ---> [p0]s)
  | axChEr p0 p1 s: prv ([p0 + p1]s ---> [p1]s)
  | axCh p0 p1 s: prv ([p0]s ---> [p1]s ---> [p0 + p1]s)
  | axStarEl p s    : prv ([p^*]s ---> s)
  | axStarEr p s    : prv ([p^*]s ---> [p][p^*]s)
  | rStar_ind' p u : prv (u ---> [p]u) -> prv (u ---> [p^*]u)

  | axTestE s t      : prv ([s??]t ---> s ---> t)
  | axTestI s t      : prv ((s ---> t) ---> [s??]t)
  .

  Canonical Structure prv_mSystem := MSystem rMP axK axS.
  Canonical Structure prv_pSystem := PSystem axDN'.
End Hilbert.

  Lemma rNorm p s t : prv (s ---> t) -> prv ([p]s ---> [p]t).
  Proof. move => H. rule axN. exact: rNec. Qed.

  Instance AX_mor (p : prog) : Proper (@mImpPrv prv_mSystem ==> @mImpPrv prv_mSystem) (fAX p).
  Proof. exact: rNorm. Qed.

  Lemma rStar_ind p u s : prv (u ---> [p]u) -> prv (u ---> s) -> prv (u ---> [p^*]s).
  Proof. move/rStar_ind' => A B. by rewrite <- B. Qed.

  Lemma axStar p s : prv (s ---> [p][p^*]s ---> [p^*]s).
  Proof.
    apply: rAIL. apply: rStar_ind; last exact: axAEl.
    rule axAcase. drop. apply: rNorm.
    ApplyH axAI; [exact: axStarEl |exact: axStarEr].
  Qed.

  Definition EX p s := (~~: [p] ~~: s).

  Lemma axnEXF p : prv (~~: EX p Bot).
  Proof. rewrite /EX. rewrite -> axDNE. apply: rNec. exact: axI. Qed.

  Lemma rEXn p s t : prv (s ---> t) -> prv (EX p s ---> EX p t).
  Proof. move => H. rule ax_contraNN. apply: rNorm. by rule ax_contraNN. Qed.

  Lemma axDBD p s t : prv (EX p s ---> [p]t ---> EX p (s :/\: t)).
  Proof.
    do 3 Intro. Apply* 2. do 2 Rev. rewrite <- axN. apply: rNorm.
    do 3 Intro. Apply* 1. ApplyH axAI.
  Qed.

  Lemma dmAX p s : prv (~~:[p]s <--> EX p (~~:s)).
  Proof. rewrite /EX. rewrite -> axDNE. exact: ax_eq_refl. Qed.

  Lemma axABBA p s t : prv ([p]s :/\: [p]t ---> [p](s :/\: t)).
  Proof.
    rule axAcase. rewrite <- axN, <- axN. apply: rNec. exact: axAI.
  Qed.

  Lemma bigABBA (T: eqType) (xs: seq T) (F: T -> form) p :
    prv ((\and_(s <- xs) [p](F s)) ---> [p](\and_(s <- xs) F s)).
  Proof.
    elim: xs => [|t xs IH].
    - drop. rewrite big_nil. apply: rNec. exact: axI.
    - rewrite !big_cons. rewrite -> IH, axABBA. exact: axI.
  Qed.

  Lemma axEOOE p s t : prv (EX p (s :\/: t) ---> EX p s :\/: EX p t).
  Proof.
    rewrite /EX. rewrite <- dmA. rewrite <- (ax_contraNN _ ([p]~~: (s:\/:t))).
    rewrite -> axABBA. apply: rNorm. rewrite <- dmO. exact: axI.
  Qed.

  Lemma bigEOOE (T: eqType) (xs: seq T) (F: T -> form) p :
    prv (EX p (\or_(s <- xs) F s) ---> \or_(s <- xs) EX p (F s)).
  Proof.
    elim: xs => [|t xs IH].
    - rewrite !big_nil. exact: axnEXF.
    - rewrite !big_cons. rewrite -> axEOOE, IH. exact: axI.
  Qed.

  (** ** Soundness *)

  Definition valid s := forall (M: cmodel) (v: M), eval s v.

  (* Theorem 2.2 (Soundness) - both directions as individual lemmas *)
  Lemma soundness s: prv s -> valid s.
  Proof.
    elim  => {s}; try by move => *; firstorder.
    - move => s t _ A _ B M w. apply: A. exact: B.
    - move => s M v /=. exact: modelP.
    - move => p s M v /=. apply. by constructor.
    - move => p s M v H u vRu w uRw /=. apply: H. exact: StarL.
    - move => p u _ IHu M v H w /= vRw.
      elim: vRw H => // {v w} - v w ? vRu _ IH H. apply: IH. exact: IHu.
    - by move => s t M v /= A w [->].
  Qed.

  Lemma soundness_classical (M:ts) :
    (forall s, prv s -> forall (w : M), eval s w) -> stable (@eval M).
  Proof. move => H s w. exact: (H _ (axDN s)). Qed.

  Corollary classical_soundness (dn: forall P , ~ ~ P -> P) s:
    prv s -> forall (M: ts) (v: M), eval s v.
  Proof.
    move => H M v.
    have stable_ts: stable (@eval M). move => t w. exact: dn.
    exact: (@soundness _ H (CModel stable_ts)).
  Qed.

  (** ** Segerberg formulation *)

  (** The essential difference between Segerberg's axiomatization and
      ours is that the former uses an axiom rather than a rule for in induction. *)

  Module SEG.
  Section Hilbert.
  Local Notation "s ---> t" := (fImp s t).

  Inductive prv : form -> Prop :=
  | rMP s t : prv (s ---> t) -> prv s -> prv t
  | axK s t : prv (s ---> t ---> s)
  | axS s t u : prv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t)
  | axDN' s : prv (((s ---> fF) ---> fF)  ---> s)

  | rNec p s : prv s -> prv ([p]s)
  | axN p s t : prv ([p](s ---> t) ---> [p]s ---> [p]t)

  | axConE p0 p1 s: prv ([p0;;p1]s ---> [p0][p1]s)
  | axCon p0 p1 s: prv ([p0][p1]s ---> [p0;;p1]s)
  | axChEl p0 p1 s: prv ([p0 + p1]s ---> [p0]s)
  | axChEr p0 p1 s: prv ([p0 + p1]s ---> [p1]s)
  | axCh p0 p1 s: prv ([p0]s ---> [p1]s ---> [p0 + p1]s)
  | axStarEl p s    : prv ([p^*]s ---> s)
  | axStarEr p s    : prv ([p^*]s ---> [p][p^*]s)
  | axStarI p s    : prv (s ---> [p][p^*]s ---> [p^*]s)
  | axSeg p s : prv ([p^*](s ---> [p]s) ---> s ---> [p^*]s)

  | axTestE s t      : prv ([s??]t ---> s ---> t)
  | axTestI s t      : prv ((s ---> t) ---> [s??]t)
  .

  End Hilbert.
  End SEG.

  (** The only nontrivial part in showing the equivalence of the two
      axiom system is to show that the induction rule (which requires
      [s ---> [p]s to be a theorem,i.e., hold everywhere) implies the
      axiom (which only requires [s ---> [p]s] to hold at reachable states *)

  Lemma segerberg p s : prv ([p^*](s ---> [p]s) ---> s ---> [p^*]s).
  Proof.
    pose u := [p^*](s ---> [p]s) :/\: s.
    suff S : prv (u ---> [p]u).
    { apply: rAIL. rewrite -/u. apply: rStar_ind S _. exact: axAEr. }
    rewrite /u.
    rule axAcase. do 2 Intro. ApplyH axABBA. ApplyH axAI.
    - Rev* 1. drop. by rewrite -> (axStarEr p (s ---> [p]s)) at 1.
    - Rev. Rev. by rewrite -> (axStarEl p (s ---> [p]s)) at 1.
  Qed.

  Fact segerberg_vs_inductive s : SEG.prv s <-> prv s.
  Proof.
    split.
    - elim; solve [by constructor| eauto using rMP,segerberg,axStar].
    - elim; try solve [by constructor| eauto using SEG.rMP].
      move => p u _ /SEG.rNec IH. apply: SEG.rMP (IH (p^*)). by constructor.
  Qed.

(** * Subformula Universes *)

(** ** Fischer Ladner Closure *)

Fixpoint FL (s : form) {struct s} : {fset form} :=
  match s with
  | fV p => [fset fV p]
  | fF => [fset fF]
  | fImp s t => fImp s t |` FL s `|` FL t
  | [a]s => FL0 a s `|` FL s
  end
with FL0 (a : prog) (s : form) {struct a} : {fset form} :=
  match a with
  | a + b => [a + b]s |` FL0 a s `|` FL0 b s
  | a ;; b => [a ;; b]s |` FL0 a [b]s `|` FL0 b s
  | t?? => [t??]s |` FL t
  | a^* =>[a^*]s |` FL0 a [a^*]s
  | pV a => [fset [pV a]s]
  end.

(* Lemma 3.3 *)
Lemma FL_refl s : s \in FL s.
Proof. case: s => [|||[]] /=; by fset_nocut. Qed.

Lemma FL0_refl p s : [p]s \in FL0 p s.
Proof. case: p => /= *; by fset_nocut. Qed.

Lemma FL_trans_mut :
  (forall s t : form, t \in FL s -> FL t `<=` FL s) *
  (forall a (s t : form), t \in FL0 a s -> FL t `<=` FL0 a s `|` FL s).
Proof.
  apply: form_prog_ind => /=.
  - fset_nocut.
  - fset_nocut.
  - move => s IHs t IHt u. rewrite !inE -orbA.
    case/or3P => [/eqP -> {t} //|/IHs|/IHt]; fset_nocut.
  - move => a IHa s IHs t /fsetUP [A|A].
    + exact: IHa.
    + exact: sub_trans (IHs t A) _.
  - move => a s t. by rewrite inE => /eqP ->.
  - move => a IHa b IHb s t. rewrite !inE -orbA.
    case/or3P => [/eqP -> {t} //|A|A].
    + move: (IHa _ _ A); fset_nocut.
    + move: (IHb _ _ A); fset_nocut.
  - move => a IHa b IHb s t. rewrite !inE -orbA.
    case/or3P => [/eqP -> {t} //|A|A].
    + move: (IHa _ _ A); fset_nocut.
    + move: (IHb _ _ A); fset_nocut.
  - move => p IHp s t. case/fsetU1P => [ -> // |A].
    move: (IHp _ _ A); fset_nocut.
  - move => u IHu s t /fsetU1P [-> // |A].
    move: (IHu _ A); fset_nocut.
Qed.

Lemma FL_trans s t u : t \in FL s -> s \in FL u -> t \in FL u.
Proof. move => A B. move: A. apply/subP. exact: FL_trans_mut.1. Qed.

Definition sf_closed' (F : {fset form}) s :=
  match s with
    | fImp s t => (s \in F) && (t \in F)
    | [pV _]s => s \in F
    | [p0;;p1]s => [&& [p0][p1]s \in F, [p1]s \in F & s \in F]
    | [p0 + p1]s => [&& [p0]s \in F, [p1]s \in F & s \in F]
    | [p^*]s => ([p][p^*]s \in F) && (s \in F)
    | [s??]t => (s \in F) && (t \in F)
    | _ => true
  end.

Arguments sf_closed' F !s.

Definition sf_closed (F :{fset form}) := forall s, s \in F -> sf_closed' F s.

(* Lemma 3.4 *)
Lemma FL_closed u : sf_closed (FL u).
Proof.
  case => //.
  - move => s t A /=. apply/andP;split; apply: FL_trans A; by rewrite !inE FL_refl.
  - case => //= [p s|p1 p2 s|p1 p2 s|p s|s t] A; repeat (apply/andP;split);
      by [apply: FL_trans A; rewrite !inE ?FL_refl ?FL0_refl ].
Qed.

Fixpoint sizef (s : form) :=
  match s with
  | fV p => 1
  | fF => 1
  | fImp s t => (1 + sizef s + sizef t)%N
  | [a]s => (1 + sizep a + sizef s)%N
  end
with sizep (a : prog) :=
  match a with
  | pV a => 1
  | a + b => (1 + sizep a + sizep b)%N
  | a ;; b => (1 + sizep a + sizep b)%N
  | a^* => (sizep a + 1)%N
  | t?? => (1 + sizef t)%N
  end.

(** Wrapper for [lia] that uses ssreflects operators on [nat] *)

Ltac norm := rewrite ?sizes1;simpl in *.
Ltac normH := match goal with [ H : is_true (_ <= _) |- _] => move/leP : H end.
Ltac ssrlia := try
                 (try (apply/andP; split); (* handle a <= b <= c *)
                  apply/leP; (* convert claim *)
                  repeat normH; (* convert assuptions *)
                  norm ; (* simplify *)
                  rewrite ?addnE /addn_rec ; (* replace addn with plus *)
                  intros; (* revert converted assumptions *)
                  lia).

(** Make arguments implicit for easier passing to leqRW *)
Arguments fsizeU {T X Y}.

(* Lemma 3.5 *)
Lemma FL_size :
  (forall s : form, size (FL s) <= sizef s) *
  (forall a s, size (FL0 a s) <= sizep a).
Proof.
  apply: form_prog_ind => /=; try solve [move => *;ssrlia].
  - move => s IHs t IHt. rewrite !(leqRW fsizeU). by ssrlia.
  - move => p IHp s IHs. rewrite (leqRW fsizeU) (leqRW IHs) (leqRW (IHp _)). by ssrlia.
  - move => a IHa b IHb s. rewrite !(leqRW fsizeU) (leqRW (IHa _)) (leqRW (IHb _)). by ssrlia.
  - move => a IHa b IHb s. rewrite !(leqRW fsizeU) (leqRW (IHa _)) (leqRW (IHb _)). by ssrlia.
  - move => p IHp s. apply: leq_trans (fsizeU1 _ _) _. by rewrite !addn1 ltnS.
  - move => s IHs t. rewrite !(leqRW fsizeU) (leqRW IHs). by ssrlia.
Qed.

(** ** Signed Formulas *)

Definition sform  := (form * bool) %type.
Notation "s ^-" := (s, false) (at level 20, format "s ^-").
Notation "s ^+" := (s, true) (at level 20, format "s ^+").

Definition body s :=
  match s with [_]t^+ => t^+ | [_]t^- => t^- | _ => s end.

Definition isBox (a: var) s :=
  match s with [pV b]t^+ => a == b | _ => false end.

Inductive isBox_spec a s : bool -> Type :=
| isBox_true t : s = [pV a]t^+ -> isBox_spec a s true
| isBox_false  : isBox_spec a s false.

Lemma isBoxP a s : isBox_spec a s (isBox a s).
Proof.
  move: s => [ [|?|? ?|[b|? ?|? ?|?|?] ?] [|]] /=; try constructor.
  case H: (a == b); try constructor.
  rewrite (eqP H). by exact: isBox_true.
Qed.

(** ** Subformula Universes *)

Definition clause := {fset sform}.

Definition flipcl F : clause := \bigcup_(s in F) [fset s^+; s^-].

Lemma flipcl_refl F s : s \in F -> forall b, (s, b) \in flipcl F.
Proof. move => inF [|]; apply/cupP; exists s; by rewrite inF /= !inE. Qed.

Definition drop_sign (s: sform) := match s with (t, _) => t end.

Lemma flip_drop_sign F s : s \in flipcl F -> drop_sign s \in F.
Proof. case/cupP => t. case/and3P => inF _. rewrite !inE. case/orP; by move/eqP => ->. Qed.

Definition flip (s : sform) := match s with t^+ => t^- | t^- => t^+ end.

Definition flip_closed (C: clause) := forall s, s \in C -> (flip s) \in C.

Lemma closed_flipcl F : flip_closed (flipcl F).
Proof.
  move => s /cupP [t] /and3P [inF _ H]. apply/cupP. exists t. move: H.
  rewrite inF /= !inE. case/orP => /eqP -> /=; by rewrite eqxx.
Qed.

(* simplify? *)
Lemma size_flipcl F : size (flipcl F) <= 2 * size F.
Proof.
  rewrite /flipcl. elim (elements F) => [|s xs IH] /=.
  - rewrite big_nil sizes0. done.
  - rewrite big_cons. apply: leq_trans; first exact: fsizeU.
    rewrite mulnS. apply: leq_add; last exact: IH.
    apply: leq_trans; first exact: fsizeU1.
    by rewrite fset1Es.
Qed.

(** ** Hintikka Sets *)

Definition lcons (L : clause) :=
  (fF^+ \notin L) && [all s in L, flip s \notin L].

Section Hintikka.
  Variable (F: {fset form}).
  Hypothesis (sfc_F: sf_closed F).

  Definition maximal (C: clause) := [all s in F, (s^+ \in C) || (s^- \in C)].

  Definition hintikka' s (L: clause) :=
  match s with
  | fImp s t^+ => (s^- \in L) || (t^+ \in L)
  | fImp s t^- => (s^+ \in L) && (t^- \in L)
  | ([p0;;p1]s, b) => ([p0][p1]s, b) \in L
  | [p0 + p1]s^+ => ([p0]s^+ \in L) && ([p1]s^+ \in L)
  | [p0 + p1]s^- => ([p0]s^- \in L) || ([p1]s^- \in L)
  | [p^*]s^+ => (s^+ \in L) && ([p][p^*]s^+ \in L)
  | [p^*]s^- => (s^- \in L) || ([p][p^*]s^- \in L)
  | [s??]t^+ => (s^- \in L) || (t^+ \in L)
  | [s??]t^- => (s^+ \in L) && (t^- \in L)
  | _ => true
  end.

  Definition hintikka L := lcons L && [all s in L, hintikka' s L].

  Variable (C: clause).
  Hypothesis (hint_C: hintikka C).
  Local Set Default Proof Using "hint_C".

  Lemma hint_imp_pos s t : fImp s t^+ \in C -> s^- \in C \/ t^+ \in C.
  Proof. case/andP: hint_C => _ /allP H inC. move: (H _ inC). case/orP; by auto. Qed.

  Lemma hint_imp_neg s t : fImp s t^- \in C -> s^+ \in C /\ t^- \in C.
  Proof. case/andP: hint_C => _ /allP H inC. move: (H _ inC). by case/andP. Qed.

  Lemma hint_box_con p0 p1 s b : ([p0;;p1]s, b) \in C -> ([p0][p1]s, b) \in C.
  Proof. case/andP: hint_C => _ /allP H inC. by move: (H _ inC). Qed.

  Lemma hint_box_ch p0 p1 s : [p0 + p1]s^+ \in C -> [p0]s^+ \in C /\ [p1]s^+ \in C.
  Proof. case/andP: hint_C => _ /allP H inC. move: (H _ inC). by case/andP. Qed.

  Lemma hint_dia_ch p0 p1 s : [p0 + p1]s^- \in C -> [p0]s^- \in C \/ [p1]s^- \in C.
  Proof. case/andP: hint_C => _ /allP H inC. move: (H _ inC). case/orP; by auto. Qed.

  Lemma hint_box_star p s : [p^*]s^+ \in C -> s^+ \in C /\ [p][p^*]s^+ \in C.
  Proof. case/andP: hint_C => _ /allP H inC. move: (H _ inC). by case/andP. Qed.

  Lemma hint_dia_star p s : [p^*]s^- \in C -> s^- \in C \/ [p][p^*]s^- \in C.
  Proof. case/andP: hint_C => _ /allP H inC. move: (H _ inC). case/orP; by auto. Qed.

End Hintikka.

(** ** Request *)

Definition R a C := [fset body s | s <- [fset t in C | isBox a t]].

Lemma RE C a s : (s^+ \in R a C) = ([pV a]s^+ \in C).
Proof.
  apply/fimsetP/idP => [ [t] | H].
  - rewrite inE andbC. by case: (isBoxP a t) => //= t' -> /= ? [->].
  - exists ([pV a]s^+) => //. by rewrite inE H /=.
Qed.

Lemma Rpos a s C : s^- \notin R a C.
Proof.
  apply/negP. case/fimsetP => t. rewrite inE andbC.
    by case (isBoxP a t) => // t' ->.
Qed.

Lemma RU a (C C' : clause) : R a (C `|` C') = (R a C `|` R a C').
Proof. by rewrite /R sepU fimsetU. Qed.

Lemma R1 a (s : sform) :
  R a [fset s] = if s is [pV b]u^+ then if (a == b) then [fset u^+] else fset0 else fset0.
Proof.
  case: s => [[|x|s t|[b|p0 p1|p0 p1|p|t] s] [|]]; rewrite /R sep1 /= ?fimset1 ?fimset0 //.
  case: (a == b); by rewrite ?fimset1 ?fimset0.
Qed.

Lemma R0 a : R a fset0 = fset0.
Proof. by rewrite /R sep0 fimset0. Qed.

Lemma RinU F a : sf_closed F ->
  forall C, C \in powerset (flipcl F) -> R a C \in powerset (flipcl F).
Proof.
  move => sfc_F C. rewrite !powersetE => /subP H. apply/subP => s.
  case: s => s [|]; last by rewrite (negbTE (Rpos _ _ _)).
  rewrite RE /flipcl => /H /flip_drop_sign /= inF. apply/cupP. exists s. rewrite !inE /= andbT.
  exact: (sfc_F [pV a]s).
Qed.

(** ** Associated Formuals *)

Definition interp (s:sform) := match s with (s, true) => s | (s, false) => Neg s end.

Notation "[ 'af' C ]" := (\and_(s <- C) interp s) (at level 0, format "[ 'af'  C ]").

Lemma box_request (C: clause) a : prv ([af C] ---> [pV a][af R a C]).
Proof.
  rewrite <- bigABBA. apply: bigAI. case => [s [|]]; last by rewrite (negbTE (Rpos _ _ _)).
  rewrite RE. exact: bigAE.
Qed.


Require Import Rupicola.Lib.Core.
Require Import Rupicola.Lib.Notations.
Require Import Rupicola.Lib.Tactics.
Require Import Rupicola.Lib.Invariants.
Require Import Rupicola.Lib.Gensym.

Local Open Scope nat_scope.

Section Gallina.
  Context {A: Type}.
  Implicit Type a : A.
  Implicit Type step : A -> nat -> A.

  Definition downto' a0 start count step : A :=
    fold_left step (rev (skipn start (seq 0 count))) a0.

  Definition downto a0 count step : A :=
    downto' a0 0 count step.

  Open Scope nat_scope.

  Lemma downto'_step start count step a0 :
    0 < start <= count ->
    step (downto' a0 start count step) (start - 1) =
    downto' a0 (start - 1) count step.
  Proof. cbv [downto']; apply fold_left_skipn_seq. Qed.

  Lemma Nat_iter_as_downto' n (f: A -> A) : forall a i,
      Nat.iter n f a = downto' a i (i + n) (fun a _ => f a).
  Proof.
    unfold downto'.
    setoid_rewrite skipn_seq_step; setoid_rewrite minus_plus.
    simpl; induction n; simpl; intros.
    - reflexivity.
    - rewrite fold_left_app.
      auto using f_equal.
  Qed.

  Lemma Nat_iter_as_downto'_sub n (f: A -> A) a i:
    i <= n ->
    Nat.iter (n - i) f a = downto' a i n (fun a _ => f a).
  Proof.
    intros; replace n with (i + (n - i)) at 2 by lia.
    apply Nat_iter_as_downto'.
  Qed.

  Lemma Nat_iter_as_downto n (f: A -> A) a :
    Nat.iter n f a = downto a n (fun a _ => f a).
  Proof. apply (Nat_iter_as_downto' n f a 0). Qed.
End Gallina.

Definition cmd_downto i_var step_impl :=
  (* while (i > 0) { i--; step i } *)
  (cmd.while
     (expr.op bopname.ltu (expr.literal 0) (expr.var i_var))
     (cmd.seq (cmd.set i_var (expr.op bopname.sub (expr.var i_var) (expr.literal 1)))
              step_impl)).

Definition cmd_downto_fresh i_var i_expr step_impl k_impl :=
  cmd.seq (cmd.set i_var i_expr)
          (cmd.seq (cmd_downto i_var step_impl)
                   k_impl).

Section Compilation.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Implicit Types (x : word).

  (* helper lemma for subtracting one from the loop counter *)
  Lemma word_to_nat_sub_1 x n :
    (0 < word.unsigned x)%Z ->
    word.unsigned x = Z.of_nat n ->
    word.unsigned (word.sub x (word.of_Z 1)) = Z.of_nat (n - 1).
  Proof.
    intros. pose proof (word.unsigned_range x).
    rewrite Nat2Z.inj_sub by lia.
    rewrite word.unsigned_sub, word.unsigned_of_Z_1.
    rewrite word.wrap_small by lia.
    f_equal. congruence.
  Qed.

  (* helper lemma for continuation case *)
  Lemma word_to_nat_0 x n :
    (word.unsigned x <= 0)%Z ->
    word.unsigned x = Z.of_nat n ->
    x = word.of_Z 0.
  Proof.
    intros. pose proof (word.unsigned_range x).
    rewrite <- (word.of_Z_unsigned x).
    assert (n = 0) by lia; subst.
    change (Z.of_nat 0) with 0%Z in *.
    congruence.
  Qed.

  Lemma word_of_Z_sub_1 n:
    n > 0 ->
    word.of_Z (Z.of_nat (n - 1)) =
    word.sub (word := word)
             (word.of_Z (Z.of_nat n)) (word.of_Z 1).
  Proof.
    intros; rewrite <- word.ring_morph_sub.
    f_equal; lia.
  Qed.

  Lemma compile_downto_continued : forall {tr mem locals functions} {A} (a0: A) count step,
      let v := downto a0 count step in
      forall {P} {pred: P v -> predicate} {k: nlet_eq_k P v} {k_impl step_impl}
        (loop_pred : nat -> A -> predicate)
        i_var vars,

        (Z.of_nat count < 2 ^ width)%Z ->
        loop_pred count a0 tr mem locals ->

        (forall i st tr mem locals,
            loop_pred i st tr mem locals ->
            map.get locals i_var = Some (word.of_Z (Z.of_nat i))) ->

        ((* loop body *)
         forall tr l m i,
           let st := downto' a0 (S i) count step in
           let wi := word.of_Z (Z.of_nat i) in
           loop_pred (S i) st tr m l ->
           i < count ->
           <{ Trace := tr;
              Memory := m;
              Locals := map.put l i_var wi;
              Functions := functions }>
           step_impl
           <{ loop_pred i (step st i) }>) ->

        (let v := v in
         (* continuation *)
         forall tr l m,
           loop_pred 0 v tr m l ->
           <{ Trace := tr;
              Memory := m;
              Locals := l;
              Functions := functions }>
           k_impl
           <{ pred (k v eq_refl) }>) ->

        <{ Trace := tr;
           Memory := mem;
           Locals := locals;
           Functions := functions }>
        cmd.seq (cmd_downto i_var step_impl) k_impl
        <{ pred (nlet_eq vars v k) }>.
  Proof.
    repeat straightline.

    (* handle while *)
    WeakestPrecondition.unfold1_cmd_goal; (cbv beta match delta [WeakestPrecondition.cmd_body]).

    exists nat, lt.
    exists (fun i t m l =>
         let st := downto' a0 i count step in
         loop_pred i st t m l /\ i <= count).
    ssplit; eauto using lt_wf; [ | ].

    { cbv zeta. subst.
      exists count; split.
      - unfold downto'; rewrite skipn_all2 by (rewrite seq_length; lia); eauto.
      - eauto using Zle_0_nat. }

    { repeat straightline'.
      repeat (eexists; split; repeat straightline; eauto).
      rewrite word.unsigned_ltu, word.unsigned_of_Z_0.
      rewrite word.unsigned_of_Z_nowrap by lia.
      destruct_one_match;
        rewrite ?word.unsigned_of_Z_0, ?word.unsigned_of_Z_1;
        ssplit; try lia; [ | ].
      { repeat straightline'.
        repeat (eexists; split; repeat straightline; eauto).
        subst_lets_in_goal.
        lazymatch goal with
        | [ Hcmd : context [WeakestPrecondition.cmd _ ?impl ],
            Hinv : context [loop_pred ?i ?st]
          |- WeakestPrecondition.cmd
              _ ?impl ?tr ?mem
              (map.put ?locals ?i_var (word.sub ?wi (word.of_Z 1)))
              ?post ] =>
          specialize (Hcmd tr locals mem (i - 1));
            replace (S (i-1)) with i in Hcmd by lia;
            unshelve epose proof (Hcmd _ _); clear Hcmd
        end; [ eauto; lia .. | ].

        rewrite <- word_of_Z_sub_1 by lia.
        use_hyp_with_matching_cmd; [ ].
        cbv [postcondition_cmd] in *; sepsimpl; cleanup; subst.
        repeat match goal with
               | |- exists _, _ => eexists; ssplit
               | _ => erewrite <- downto'_step; [ cbn [fst snd]; ecancel_assumption | ]
               | _ => lia || solve [eauto using word_to_nat_sub_1]
               end. }
      { repeat straightline'.
        match goal with
        | [ H: (Z.of_nat ?n <= 0)%Z |- _ ] => replace n with 0 in * by lia
        end.
        use_hyp_with_matching_cmd; subst_lets_in_goal; eauto. } }
  Qed.

  Lemma compile_downto : forall {tr mem locals functions} {A} (a0: A) count step,
      let v := downto a0 count step in
      forall {P} {pred: P v -> predicate} {k: nlet_eq_k P v} {k_impl step_impl}
        (loop_pred : nat -> A -> predicate)
        i_var i_expr vars,

        let zcount := Z.of_nat count in
        let wcount := word.of_Z zcount in

        (zcount < 2 ^ width)%Z ->
        WeakestPrecondition.dexpr mem locals i_expr wcount ->

        let locals0 := map.put locals i_var wcount in
        loop_pred count a0 tr mem locals0 ->

        (forall i st tr mem locals,
            loop_pred i st tr mem locals ->
            map.get locals i_var = Some (word.of_Z (Z.of_nat i))) ->

        (let lp := loop_pred in
         (* loop body *)
         forall tr l m i,
           let st := downto' a0 (S i) count step in
           let wi := word.of_Z (Z.of_nat i) in
           loop_pred (S i) st tr m l ->
           i < count ->
           <{ Trace := tr;
              Memory := m;
              Locals := map.put l i_var wi;
              Functions := functions }>
           step_impl
           <{ lp i (step st i) }>) ->

        (let v := v in
         (* continuation *)
         forall tr l m,
           loop_pred 0 v tr m l ->
           <{ Trace := tr;
              Memory := m;
              Locals := l;
              Functions := functions }>
           k_impl
           <{ pred (k v eq_refl) }>) ->

        <{ Trace := tr;
           Memory := mem;
           Locals := locals;
           Functions := functions }>
        cmd_downto_fresh i_var i_expr step_impl k_impl
        <{ pred (nlet_eq vars v k) }>.
  Proof.
      intros.
      unfold cmd_downto_fresh.
      repeat straightline; eexists; split; eauto.
      eapply compile_downto_continued; eauto.
  Qed.

  Lemma compile_Nat_iter : forall [tr mem locals functions] n {A} f (a: A),
      let v := Nat.iter n f a in
      forall {P} {pred: P v -> predicate} {k: nlet_eq_k P v} {k_impl f_impl}
        (loop_pred : nat -> A -> predicate)
        i_var i_expr vars,

        let zn := Z.of_nat n in
        let wn := word.of_Z zn in

        (zn < 2 ^ width)%Z ->
        WeakestPrecondition.dexpr mem locals i_expr wn ->

        let locals0 := map.put locals i_var wn in
        loop_pred n a tr mem locals0 ->

        (forall i st tr mem locals,
            loop_pred i st tr mem locals ->
            map.get locals i_var = Some (word.of_Z (Z.of_nat i))) ->

        (let lp := loop_pred in
         (* loop body *)
         forall tr l m i,
           let st := Nat.iter (n - S i) f a in
           let wi := word.of_Z (Z.of_nat i) in
           loop_pred (S i) st tr m l ->
           i < n ->
           <{ Trace := tr;
              Memory := m;
              Locals := map.put l i_var wi;
              Functions := functions }>
           f_impl
           <{ lp i (f st) }>) ->

        (let v := v in
         (* continuation *)
         forall tr l m,
           loop_pred 0 v tr m l ->
           <{ Trace := tr;
              Memory := m;
              Locals := l;
              Functions := functions }>
           k_impl
           <{ pred (k v eq_refl) }>) ->

        <{ Trace := tr;
           Memory := mem;
           Locals := locals;
           Functions := functions }>
        cmd_downto_fresh i_var i_expr f_impl k_impl
        <{ pred (nlet_eq vars v k) }>.
  Proof.
    cbv zeta; intros until a.
    rewrite Nat_iter_as_downto; intros * ???? Hf Hk.
    eapply compile_downto; eauto; [].
    cbv zeta; intros.
    rewrite <- Nat_iter_as_downto'_sub by lia;
      eapply Hf; [ | lia]; rewrite Nat_iter_as_downto'_sub by lia.
    eassumption.
  Qed.
End Compilation.

Ltac make_downto_predicate i_var i_arg vars args tr pred locals :=
  lazymatch substitute_target i_var i_arg pred locals with
  | (?pred, ?locals) =>
    make_predicate vars args tr pred locals
  end.

Ltac infer_downto_predicate' i_var argstype vars tr pred locals :=
  let val_pred :=
      constr:(fun (idx: nat) (args: argstype) =>
                ltac:(let f := make_downto_predicate
                                i_var idx vars args tr pred locals in
                      exact f)) in
  eval cbv beta in val_pred.

Ltac infer_downto_predicate i_var :=
  _infer_predicate_from_context
    ltac:(infer_downto_predicate' i_var).

Ltac _compile_downto locals lemma :=
  let i_v := gensym locals "i" in
  let lp := infer_downto_predicate i_v in
  eapply lemma with (i_var := i_v) (loop_pred := lp).

Ltac compile_downto :=
  lazymatch goal with
  | [ |- WeakestPrecondition.cmd _ _ _ _ ?locals (_ (nlet_eq _ ?v _)) ] =>
    lazymatch v with
    | downto _ _ _ => _compile_downto locals compile_downto
    | Nat.iter _ _ _ => _compile_downto locals compile_Nat_iter
    end
  end.

Module DownToCompiler.
  #[export] Hint Extern 1 (WP_nlet_eq (downto _ _ _)) =>
    compile_downto; shelve : compiler.
  #[export] Hint Extern 1 (WP_nlet_eq (Nat.iter _ _ _)) =>
    compile_downto; shelve : compiler.
End DownToCompiler.

Section GhostCompilation.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Implicit Types (x : word).

  (* helper definition *)
  Definition downto'_dependent
             {A B} initA initB start count
             (stepA : A -> nat -> A) (stepB : A -> B -> nat -> B) :=
    fold_left_dependent stepA stepB
                        (rev (skipn start (seq 0 count))) initA initB.

  Lemma downto'_dependent_fst {A B} initA initB stepA stepB i count :
      fst (@downto'_dependent A B initA initB i count stepA stepB) =
      downto' initA i count stepA.
  Proof. apply fold_left_dependent_fst. Qed.

  Open Scope nat_scope.

  Lemma downto'_dependent_step
        {A B} i count stepA stepB (initA : A) (initB : B) :
    0 < i <= count ->
    (fun ab c =>
       (stepA (fst ab) c, stepB (fst ab) (snd ab) c))
      (downto'_dependent initA initB i count stepA stepB) (i-1)
    = downto'_dependent initA initB (i-1) count stepA stepB.
  Proof. apply fold_left_skipn_seq. Qed.

  (* In this lemma, state refers to the accumulator type for the Gallina downto
     loop, and ghost_state is any extra information that locals/memory invariants
     need access to. *)
  (* FIXME Do we actually need ghost state? *)
  (* TODO: consider taking in range of count instead of providing word? *)
  Lemma compile_downto_with_ghost_state :
    forall {tr mem locals functions} {state} (init : state) count step,
    let v := downto init count step in
    forall {P} {pred: P v -> predicate} {k: nlet_eq_k P v} {k_impl step_impl}
      wcount {ghost_state} (ginit : ghost_state)
      (ghost_step : state -> ghost_state -> nat -> ghost_state)
      (Inv : nat -> ghost_state -> state -> predicate) (* loop invariant *)
      i_var vars,

      Inv count ginit init tr mem (map.remove locals i_var) ->

      map.get locals i_var = Some wcount ->
      word.unsigned wcount = Z.of_nat count ->

      (let v := v in
       (* loop iteration case *)
       forall tr l m i wi,
         let stgst := downto'_dependent init ginit (S i) count step ghost_step in
         let st := fst stgst in let gst := snd stgst in
         let inv' v tr' mem' locals :=
             map.get locals i_var = Some wi /\
             Inv i (ghost_step st gst i) v tr' mem' (map.remove locals i_var) in
         let gst' := ghost_step st gst i in
         Inv (S i) gst st tr m (map.remove l i_var) ->
         word.unsigned wi = Z.of_nat i ->
         i < count ->
         <{ Trace := tr;
            Memory := m;
            Locals := map.put l i_var wi;
            Functions := functions }>
         step_impl
         <{ inv' (step st i)}>) ->
      (let v := v in
       (* continuation *)
       forall tr l m gst,
         Inv 0 gst v tr m (map.remove l i_var) ->
         map.get l i_var = Some (word.of_Z 0) ->
         <{ Trace := tr;
            Memory := m;
            Locals := l;
            Functions := functions }>
         k_impl
         <{ pred (k v eq_refl) }>) ->

      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.seq (cmd_downto i_var step_impl) k_impl
      <{ pred (nlet_eq vars v k) }>.
  Proof.
    repeat straightline'.

    (* handle while *)
    WeakestPrecondition.unfold1_cmd_goal;
      (cbv beta match delta [WeakestPrecondition.cmd_body]).
    exists nat, lt.
    exists (fun i t m l =>
              let stgst :=
                  downto'_dependent init ginit i count
                                    step ghost_step in
              let st := fst stgst in
              let gst := snd stgst in
              Inv i gst st t m (map.remove l i_var)
              /\ i <= count
              /\ (exists wi,
                     word.unsigned wi = Z.of_nat i
                     /\ map.get l i_var = Some wi)).
    ssplit; eauto using lt_wf; [ | ].

    { cbv zeta. subst.
      exists count; split.
      - unfold downto'_dependent;
          rewrite skipn_all2 by (rewrite seq_length; lia); eauto.
      - eauto using Zle_0_nat. }

    { intros. cleanup; subst.
      repeat straightline'.
      lazymatch goal with x := context [word.ltu] |- _ => subst x end.
      rewrite word.unsigned_ltu, word.unsigned_of_Z_0.
      destruct_one_match;
        rewrite ?word.unsigned_of_Z_0, ?word.unsigned_of_Z_1;
        ssplit; try lia; [ | ].
      { repeat straightline'.
        subst_lets_in_goal.
        lazymatch goal with
        | Hcmd:context [ WeakestPrecondition.cmd _ ?impl ],
               Hinv : context [Inv _ (snd ?stgst) (fst ?stgst)],
                      Hi : word.unsigned ?wi = Z.of_nat ?i
          |- WeakestPrecondition.cmd
               _ ?impl ?tr ?mem
               (map.put ?locals ?i_var (word.sub ?wi (word.of_Z 1)))
               ?post =>
          specialize (Hcmd tr locals mem (i-1) (word.sub wi (word.of_Z 1)));
            replace (S (i-1)) with i in Hcmd by lia;
            unshelve epose proof (Hcmd _ _ _); clear Hcmd
        end;
          [ eauto using word_to_nat_sub_1; lia .. | ].
        use_hyp_with_matching_cmd; [ ].
        cbv [postcondition_cmd] in *; sepsimpl; cleanup; subst.
        repeat match goal with
               | |- exists _, _ => eexists; ssplit
               | _ => erewrite <-downto'_dependent_step; [ cbn [fst snd]; ecancel_assumption | ]
               | _ => lia || solve [eauto using word_to_nat_sub_1]
               end. }
      { repeat straightline'.
        rewrite @downto'_dependent_fst in *.
        match goal with
        | H : (word.unsigned ?x <= 0)%Z |- _ =>
          eapply word_to_nat_0 in H; [ | solve [eauto] .. ]; subst
        end.
        match goal with
          H : word.unsigned (word.of_Z 0) = Z.of_nat ?n |- _ =>
          assert (n = 0) by (rewrite word.unsigned_of_Z_0 in H; lia)
        end; subst.
        use_hyp_with_matching_cmd; subst_lets_in_goal; eauto. } }
  Qed.
End GhostCompilation.


Require Import Terms.
Require Import LBracketSyntax.

(** * Equivalences *)

(** Low-equivalence judgments. *)
Inductive eq_atom : Atom -> Atom -> Lab -> Prop :=
| eq_a : forall v1 l1 v2 l2 l,
  l1 = l2 ->
  ((l1 <: l \/ l2 <: l) -> eq_val v1 v2 l) ->
  eq_atom (v1,l1) (v2,l2) l
with eq_val : Val -> Val -> Lab -> Prop :=
| eq_vconst : forall c' l, eq_val (VConst c') (VConst c') l
| eq_vinx : forall d a a' l,
  eq_atom a a' l ->
  eq_val (VInx d a) (VInx d a') l
| eq_vclos : forall r1 r2 x t l,
  eq_env r1 r2 l ->
  eq_val (VClos r1 x t) (VClos r2 x t) l
with eq_env : Env -> Env -> Lab -> Prop :=
| eq_e_nil : forall l, eq_env nil nil l
| eq_e_cons : forall x a1 a2 r1 r2 l,
  eq_atom a1 a2 l -> eq_env r1 r2 l -> eq_env ((x,a1)::r1) ((x,a2)::r2) l.
Hint Constructors eq_atom eq_val eq_env.
Scheme eq_atom_ind' := Minimality for eq_atom Sort Prop
with eq_val_ind' := Minimality for eq_val Sort Prop
with eq_env_ind' := Minimality for eq_env Sort Prop.

Combined Scheme eq_mutind from eq_val_ind', eq_atom_ind', eq_env_ind'.

(** Low-equivalence judgments, that take the pc label into account. *)
Definition eq_atom' a1 pc1 a2 pc2 l :=
  (pc1 <: l \/ pc2 <: l) ->
  (pc1 = pc2 /\ eq_atom a1 a2 l).
Definition eq_env' r1 pc1 r2 pc2 l :=
  (pc1 <: l \/ pc2 <: l) ->
  (pc1 = pc2 /\ eq_env r1 r2 l).

(** * Preliminary lemmas. *)

Lemma maps_eq_env : forall x a1 a2 r1 r2 l,
  eq_env r1 r2 l ->
  maps r1 x a1 ->
  maps r2 x a2 ->
  eq_atom a1 a2 l.
Proof.
  intros x a1 a2 r1 r2 l Heq_env Hmaps1 Hmaps2.
  induction Heq_env. invs Hmaps1.
  invs Hmaps1; invs Hmaps2. destruct (beq_nat x x0).
  congruence. auto.
Qed.

Lemma maps_eq_env' : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_env' r1 pc1 r2 pc2 l ->
  maps r1 x a1 ->
  maps r2 x a2 ->
  eq_atom' a1 pc1 a2 pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l Heq_env' Hmaps1 Hmaps2 Hflows.
  apply Heq_env' in Hflows. intuition eauto using maps_eq_env.
Qed.

Lemma eq_env'_cons_inv_env : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_env' ((x,a1) :: r1) pc1 ((x,a2) :: r2) pc2 l ->
  eq_env' r1 pc1 r2 pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l H Hflows. apply H in Hflows as [? Henv].
  invsc Henv. auto.
Qed.

Lemma eq_env'_cons_inv_atom : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_env' ((x,a1) :: r1) pc1 ((x,a2) :: r2) pc2 l ->
  eq_atom' a1 pc1 a2 pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l H Hflows. apply H in Hflows as [? Henv].
  invsc Henv. auto.
Qed.

Lemma cons_eq_env' : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_atom' a1 pc1 a2 pc2 l ->
  eq_env' r1 pc1 r2 pc2 l ->
  eq_env' ((x,a1) :: r1) pc1 ((x,a2) :: r2) pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l Hatom Henv Hflows.
  specialize (Hatom Hflows). specialize (Henv Hflows).
  intuition auto.
Qed.

(** Reflexivity of low-equivalence. Later, we prove this is actually an
    equivalence relation. *)
Lemma eq_refl :
  (forall v l, eq_val v v l) /\
  (forall a l, eq_atom a a l) /\
  (forall r l, eq_env r r l).
Proof. apply val_atom_env_mutind; eauto. Qed.

Lemma eq_val_refl : forall v l, eq_val v v l.
Proof. pose proof eq_refl. intuition. Qed.

Lemma eq_atom_refl : forall a l, eq_atom a a l.
Proof. pose proof eq_refl. intuition. Qed.

Lemma eq_env_refl : forall r l, eq_env r r l.
Proof. pose proof eq_refl. intuition. Qed.

Lemma intro_and2 : forall (P P1 P2: Prop),
  (P -> (P1 /\ P2)) ->
  (P -> P1) /\ (P -> P2).
Proof. tauto. Qed.

Lemma eq_val_eq_tag : forall v1 v2 l,
  eq_val v1 v2 l ->
  tag_of v1 = tag_of v2.
Proof.
  intros v1 v2 l Heq.
  inversion Heq; eauto.
Qed.

Lemma or_introrefl : forall (P : Prop),
  P -> P \/ P.
Proof. left. assumption. Qed.

Lemma or_elimrefl : forall (P : Prop),
  P \/ P -> P.
Proof. intros P H. destruct H; assumption. Qed.


Require Export generic synt_and_sos main_defs prog_reductions.

(** Monotony of [whithin] w.r.t. program reductions without
interference. This means that if a command [x] guarantees something,
then doing a program reduction, the guarantee remains intact. *)
Section WithinSimpleProperties.

  Lemma within_cstep_red_step :
    forall R G x x0 x1 x2,
      (x, x0) ⇒ (x1, x2) ->
      << R , G , x  , x0 >> ->
      << R , G , x1 , x2 >>.
  Proof.
    intros.
    unfold within.
    intros until c''.
    do_star2starn H1.
    revert n y c' c'' H1.
    induction n;intros.
    inv H1.
    eapply H0.
    constructor 2 with (c',y).
    left;auto.
    constructor.
    apply H2.
    inv H1.
    destruct y0;destruct H4;simpl in *.

    eapply H0.
    constructor 2 with (x1,x2).
    left;auto.
    do_starn2star H1.
    apply H4.
    apply H2.
    destruct H3.
    simpl in *.
    subst.

    eapply H0.
    constructor 2 with (s,x2).
    left;auto.
    eapply starn2star with (S n).
    apply H1.
    apply H2.
  Qed.

  (** Monotony of [whithin] w.r.t. one step of inteference. The guarantees remain intact since the interference of the environment is not accounted. Only the state of execution is possibly changed. *)

  Lemma within_R_interf_step :
    forall (R G:Env) x x0 x2,
      R x0 x2 ->
      within R G x x0 ->
      within R G x x2.
  Proof.
    intros.
    unfold within.
    intros until c''.
    do_star2starn H1.
    revert n y c' c'' H1.
    induction n;intros.
    inv H1.
    eapply H0.
    constructor 2 with (c',y).
    right;split;auto.
    do_starn2star H1.
    apply H3.
    apply H2.

    inv H1.
    destruct y0;destruct H4;simpl in *.
    eapply H0.
    constructor 2 with (x,x2).
    right;split;auto.
    do_starn2star H1.
    apply H4.
    apply H2.

    eapply H0.
    constructor 2 with (x,x2).
    right;split;auto.
    do_starn2star H1.
    apply H4.
    apply H2.
  Qed.

  (** Monotony of [whithin] w.r.t. both program reduction and interference. This lemma incoorporates the two previous lemmas. *)

  Lemma within_interf_step :
    forall R G x x0 x1 x2,
      interf R (x, x0) (x1, x2) ->
      <<R,G,x,x0>> ->
      <<R,G,x1,x2>>.
  Proof.
    intros.
    unfold within.
    intros until c''.
    do_star2starn H1.
    revert n y c' c'' H1.
    induction n;intros.
    inv H1.
    eapply H0.
    constructor 2 with (c',y).
    right;auto.
    constructor.
    apply H2.

    inv H1.
    destruct y0;destruct H4;simpl in *.
    eapply H0.
    constructor 2 with (x1,x2).
    right;auto.
    do_starn2star H1.
    apply H4.
    apply H2.

    eapply H0.
    constructor 2 with (x1,x2).
    right;auto.
    destruct H3;simpl in *;subst.
    do_starn2star H1.
    apply H3.
    apply H2.
  Qed.

  (** Monotony of [within] w.r.t. one step reduction with interference. *)

  Lemma within_prog_red :
    forall R G x x0 x1 x2,
      prog_red R (x, x0) (x1, x2) ->
      <<R,G,x,x0>> ->
      <<R,G,x1,x2>>.
  Proof.
    intros.
    destruct H;
      [eapply within_cstep_red_step |
       eapply within_interf_step];
    eauto.
  Qed.

  Lemma within_prog_red_star :
    forall R G x x0 x1 x2,
      star _ (prog_red R) (x, x0) (x1, x2) ->
      << R , G , x  , x0 >> ->
      << R , G , x1 , x2 >>.
  Proof.
    intros.
    dependent induction H.
    assumption.

    destruct y.
    eapply IHstar.
    reflexivity.
    reflexivity.
    eapply within_prog_red.
    apply H.
    assumption.
  Qed.

End WithinSimpleProperties.

(** One step of computation with intereference is in [R \/ G]. If a step of computation is carried out, it may be due to program reduction or due to the interference. This implies that the states may be related by the union of the interference and the effect of the program reduction. *)

Section WithinAndClosures.

  Lemma correct_reduction_wrt_guarantee_one_step :
    forall R G c c' s s',
      prog_red R (c,s) (c',s') -> <<R,G,c,s>> -> rstOr R G s s'.
  Proof.
    intros.
    destruct H.
    red in H0.
    assert(star _ (prog_red R) (c,s) (c,s)).
    constructor.
    pose proof H0 _ _ H1.
    apply H2 in H.
    right;auto.
    red in H.
    destruct H;simpl in *.
    left;auto.
  Qed.

  (** One step of computation without interference is in
  [G]. Obviously, if a reduction is performed then the states must be
  related by the guarantee, since it subsumes the program
  reduction. *)

  Lemma correct_reduction_step_guarantee :
    forall R G c c' s s',
      (c,s) ⇒ (c',s') ->
      <<R,G,c,s>> -> G s s'.
  Proof.
    intros.
    red in H0.
    assert(star _ (prog_red R) (c,s) (c,s)) by constructor.
    pose proof H0 _ _ H1.
    apply H2 in H.
    assumption.
  Qed.

  Lemma correct_reduction_wrt_guarantee_one_step_within :
    forall R G c c' s s',
      star _ (prog_red R) (c,s) (c',s') -> <<R,G,c,s>> -> <<R,G,c',s'>>.
  Proof.
    intros.
    dependent induction H.
    assumption.
    red;intros.
    destruct y;destruct H.
    pose proof correct_reduction_step_guarantee R G c s0 s s1 H H0.
    pose proof IHstar s0 c' s1 s' refl_equal refl_equal.
    eapply H5.
    2:apply H2.
    2:apply H3.
    eapply within_cstep_red_step.
    apply H.
    assumption.
    destruct H.
    simpl in *.
    subst.
    eapply H0.
    2:apply H3.
    eapply star_trans.
    constructor 2 with (s0,s1).
    right;red;auto.
    apply H1.
    assumption.
  Qed.

  (** Computation of a program from a state [s] to a state [s'] can be
   described by the reflexive-transitive closure of [R \/ G]. *)

  Lemma correct_reduction_wrt_rely_and_guarante :
    forall R G c c' s s',
    star _ (prog_red R) (c,s) (c',s') -> <<R,G,c,s>> -> star _ (rstOr R G) s s'.
  Proof.
    intros.
    do_star2starn H.
    revert n c c' s s' H H0.
    induction n;intros.
    inv H.
    constructor.

    inv H.
    destruct H2.
    destruct y.
    constructor 2 with s1.
    right;auto.
    eapply H0.
    constructor.
    apply H1.
    eapply IHn.
    apply H3.
    eapply within_cstep_red_step;eauto.

    destruct y.
    destruct H1;simpl in *;subst.
    constructor 2 with s1.
    left;auto.
    eapply IHn.
    apply H3.
    eapply within_interf_step;eauto.
    red;auto.
  Qed.

  (** Guarantee containment. *)

  Lemma guarantee_impl :
    forall R1 R2,
      rstImp R2 R1 ->
      forall G c s, <<R1,G,c,s>> -> <<R2,G,c,s>>.
  Proof.
    intros.
    unfold within.
    intros until c''.
    do_star2starn H1.
    intros.
    eapply H0 with c' c''.
    2:apply H2.
    clear H2 z.
    revert n y c s H0 c' c'' H1.
    induction n;intros.

    inv H1.
    constructor.

    inv H1.
    destruct y0;destruct H3.
    constructor 2 with (s0,s1).
    left;auto.
    eapply IHn.
    eapply within_cstep_red_step.
    apply H2.
    assumption.
    apply c'.
    assumption.
    destruct H2.
    simpl in *;subst.
    constructor 2 with (s0,s1).
    right.
    split;auto.
    apply IHn.
    eapply within_R_interf_step.
    apply H.
    apply H3.
    assumption.
    exact c'.
    assumption.
  Qed.

End WithinAndClosures.

Section WithinSkip.

  Lemma guarantee_SKIP_aux :
    forall R c1 c2 s s1 s2,
      star _ (prog_red R) (c1,s) (c2,s1) ->
      R s1 s2 ->
      star _ (prog_red R) (c1,s) (c2,s2).
  Proof.
    intros.
    dependent induction H.
    constructor 2 with (c2,s2);auto.
    right;split;auto.
    destruct H.
    destruct y.
    constructor 2 with (s0,s3);auto.
    left;auto.
    eapply IHstar;eauto.
    destruct y;destruct H;simpl in *.
    subst.
    constructor 2 with (s0,s3).
    right;split;auto.
    eapply IHstar;eauto.
  Qed.

  (** [SKIP] always respect the guarantee *)

  Lemma guarantee_SKIP :
    forall R G s,
      << R, G, skip , s >>.
  Proof.
    red.
    intros.
    dependent induction H.
    inv H0.

    destruct y0;destruct H.
    inv H.
    destruct H;simpl in *.
    symmetry in H.
    subst.
    eapply IHstar.
    reflexivity.
    reflexivity.
    apply H0.
  Qed.

End WithinSkip.

Section WithinIf.

  Lemma within_if_true :
    forall R G (b:bexp) s,
      stable R (assrtT b) ->
      Reflexive G ->
      forall ct,
        <<R,G,ct,s>> ->  b2assrt b s ->
                 forall cf,
                   <<R,G,ifb b then ct else cf fi,s>>.
  Proof.
    unfold within at 2.
    intros.
    dependent induction H3.
    inv H4.
    eapply H0.

    destruct H5.
    inv H5.
    eapply H1.
    apply H3.
    eapply H4.
    red in H5.
    simpl in H5.
    destruct H5.
    eapply IHstar.
    apply H0.
    Focus 5.
    reflexivity.
    Focus 4.
    rewrite surjective_pairing at 1.
    rewrite <- H5.
    reflexivity.
    eapply  within_R_interf_step.
    apply H6.
    apply H1.
    apply H.
    eapply H.
    split.
    apply H2.
    apply H6.
    apply H4.
  Qed.

  Lemma within_if_false :
    forall R G (b:bexp) s,
      stable R (assrtF b) ->
      Reflexive G ->
      forall cf,
        <<R,G,cf,s>> -> assrtF b s ->
                 forall ct,
                   <<R,G,ifb b then ct else cf fi,s>>.
  Proof.
    unfold within at 2.
    intros.
    dependent induction H3.
    inv H4.
    eapply H0.

    destruct H5.
    inv H5.
    eapply H1.
    apply H3.
    eapply H4.
    red in H5.
    simpl in H5.
    destruct H5.
    eapply IHstar.
    apply H0.
    Focus 5.
    reflexivity.
    Focus 4.
    rewrite surjective_pairing at 1.
    rewrite <- H5.
    reflexivity.
    eapply  within_R_interf_step.
    apply H6.
    apply H1.
    apply H.
    eapply H.
    split.
    apply H2.
    apply H6.
    apply H4.
  Qed.

End WithinIf.

Section WithinSequence.

  Lemma within_seq_fst :
    forall  R G cl s s',
      Reflexive G ->
      star _ (prog_red R) (cl,s) (skip,s') ->
      forall cr,
        <<R,G,cr,s'>> -> <<R,G,skip;cr,s'>>.
  Proof.
    unfold within at 2.
    intros.
    dependent induction H2.
    inv H3.
    inv H4.
    apply H.

    destruct H4.
    inv H4.
    inv H9.
    inv H4.
    inv H6.
    eapply H1.
    apply H2.
    apply H3.
    destruct H4.
    simpl in *.
    eapply IHstar.
    apply H.
    Focus 4.
    reflexivity.
    Focus 3.
    rewrite surjective_pairing at 1.
    rewrite <- H4.
    reflexivity.
    Focus 3.
    apply H3.
    simpl in *.
    Focus 2.
    eapply  within_R_interf_step.
    apply H5.
    simpl.
    assumption.
    eapply star_trans.
    apply H0.
    constructor 2 with (skip,snd y0).
    red.
    right.
    red.
    simpl.
    split;auto.
    constructor.
  Qed.

  Lemma within_seq_skip :
    forall R G c s,
      Reflexive G ->
      <<R,G,skip;c,s>> -> <<R,G,c,s>>.
  Proof.
    intros.
    red;intros.
    dependent induction H1.
    eapply H0.
    constructor 2 with (c',y).
    left;auto.
    constructor.
    apply  H2.

    destruct y0;destruct H3.
    eapply H0.
    constructor 2 with (c,s).
    left;auto.
    constructor 2 with (s0,s1).
    left;auto.
    apply H1.
    apply H2.

    destruct H3;simpl in *.
    subst.
    eapply H0.
    constructor 2 with (s0,s).
    left;auto.
    constructor 2 with (s0,s1).
    right;split;auto.
    apply H1.
    apply H2.
  Qed.

  (** If a sequence [c1;c2] verifies a given guarante [G] then its parts must also verify [G]. *)

  Lemma within_seq_inv :
    forall R G c1 c2 s,
      Reflexive G ->
      <<R,G,c1;c2,s>> ->
                  <<R,G,c1,s>> /\
                            forall s', star _ (prog_red R) (c1,s) (skip,s') ->
                                            <<R,G,c2,s'>>.
  Proof.
    intros.
    split;intros.
    red;intros.
    dependent induction H1.
    eapply H0.
    constructor.
    constructor.
    apply H2.
    destruct y0;destruct H3.
    assert((c1;c2,s) ⇒ (s0;c2,s1)).
    constructor;auto.
    pose proof within_cstep_red_step _ _ _ _ _ _ H4 H0.
    pose proof IHstar _ _ H H5 y c' refl_equal refl_equal _ _ H2.
    assumption.
    destruct H3.
    simpl in *.
    pose proof within_R_interf_step _ _ _ _ _ H4 H0.
    subst.
    pose proof IHstar _ _ H H5 _ _ refl_equal refl_equal _ _ H2.
    assumption.

    dependent induction H1.
    apply within_seq_skip;auto.
    destruct2 y H2.
    assert((c1;c2,s) ⇒ (s0;c2,s1)).
    constructor;auto.
    pose proof within_cstep_red_step _ _ _ _ _ _ H3 H0.
    pose proof IHstar _ _ H H4 _ refl_equal refl_equal.
    assumption.
    destruct H2;simpl in *;subst.
    pose proof within_R_interf_step _ _ _ _ _ H3 H0.
    pose proof IHstar _ _ H H2 _ refl_equal refl_equal.
    assumption.
  Qed.

  (** The following lemma ensures how to construct a proof of the guarantee of a sequence. Basically, if [c1] ensures a guarantee and, in all possible states where it terminates is execution, if the execution of [c2] also ensures guarantee, then the sequence [c1;c2] ensures a full coverage of the guarantee. *)

  Lemma within_seq :
    forall R G c1 c2 s,
      Reflexive G ->
      <<R,G,c1,s>> ->
               (forall n s', starn _ (prog_red R) n (c1,s) (skip,s') ->
                             <<R,G,c2,s'>>) ->
               <<R,G,c1;c2,s>>.
  Proof.
    intros.
    red;intros.
    do_star2starn H2.
    revert n s c1 c2 y c' c'' z H0 H1 H3 H2.
    induction n;intros.
    inv H2.
    inv H3.
    eapply H0.
    constructor.
    apply H5.
    apply H.

    inv H2.
    destruct2 y0 H5.
    inv H4.
    cut(<<R,G,c1',s1>>).
    intro.
    pose proof IHn s1 _ c2 y c' c'' z H5.
    eapply H8.
    intros.
    red;intros.
    eapply H1.
    constructor 2 with (c1',s1).
    left;auto.
    apply H9.
    apply H10.
    apply H11.
    apply H3.
    apply H6.
    eapply within_cstep_red_step.
    apply H7.
    assumption.
    eapply H1.
    constructor.
    eapply starn2star with n.
    apply H6.
    apply H3.
    destruct H4.
    simpl in *.
    subst.
    cut(<< R, G, c1, s1 >>).
    intro.
    pose proof IHn s1 c1 c2 y c' c'' z H4.
    eapply H7.
    intros;red;intros.
    eapply H1.
    constructor 2 with (c1,s1).
    right;split;auto.
    apply H8.
    apply H9.
    apply H10.
    apply H3.
    apply H6.
    eapply within_R_interf_step.
    apply H5.
    assumption.
  Qed.

End WithinSequence.

Section WithinWhile.

  Lemma while_middle :
    forall R G b c s,
      Reflexive G ->
      stable R ([⊤]b) ->
      b2assrt b s ->
      <<R,G,ifb b then c;while b do c end else skip fi,s>> -> <<R,G,while b do c end,s>>.
  Proof.
    intros.
    red;intros.
    dependent induction H3.
    inv H4.
    apply H.

    destruct2 y0 H5.
    inv H5.
    eapply H2.
    apply H3.
    apply H4.
    destruct H5.
    simpl in *.
    symmetry in H5.
    subst.
    eapply IHstar.
    7:apply H4.
    apply H.
    4:reflexivity.
    4:reflexivity.
    apply H0.
    eapply H0;eauto.
    red;intros.
    eapply H2.
    constructor 2 with (ifb b then c; while b do c end else skip fi, s1).
    right;split;auto.
    apply H5.
    apply H7.
  Qed.

  Lemma while_middle_false :
    forall R G b c s,
      Reflexive G ->
      stable R ([⊥]b) ->
      ~b2assrt b s ->
      <<R,G,ifb b then c;while b do c end else skip fi,s>> ->
      <<R,G,while b do c end,s>>.
  Proof.
    red;intros.
    dependent induction H3.
    inv H4.
    apply H.

    destruct2 y0 H5.
    inv H5.
    eapply H2.
    apply H3.
    apply H4.
    destruct H5.
    symmetry in H5;simpl in *;subst.
    eapply IHstar.
    apply H.
    apply H0.
    3:reflexivity.
    3:reflexivity.
    3:apply H4.
    eapply H0;eauto.
    eapply within_R_interf_step;eauto.
  Qed.

  (* Section yu. *)
  (*   Variables R G : Env. *)
  (*   Hypothesis Gr : Reflexive G. *)

  (*   Check RT_ind_gen. *)

  (*   Axiom RT_ind_gen_2 *)
  (*    : ∀X : Type, *)
  (*      ∀R : X → X → Prop, *)
  (*      ∀P : X -> Prop, *)
  (*      (∀x : X, P x) *)
  (*      → (∀x y z : X, *)
  (*         ∀n : nat, *)
  (*         R x y *)
  (*         → starn X R n y z *)
  (*           → (∀y1 : X, ∀k : nat, k ≤ n → starn X R k y1 z → P y1) → P x) *)
  (*        → (∀x y : X, star X R x y → P x). *)

    (* Lemma guarantee_ind_while : *)
  (*   forall R G b c s s',  *)
  (*     stable R ([⊤]b) -> *)
  (*     stable R ([⊥]b) -> *)
  (*     (forall c' s', star _ (prog_red R) (while b do c end,s) (c',s') -> <<R,G,c',s'>>) -> *)
  (*             star _ (prog_red R) (while b do c end,s) (skip,s') ->  *)
  (*             <<R,G,while b do c end,s>>. *)
  (*  Proof. *)
  (*    intros. *)
  (*    dependent induction H2;intros. *)

  (*    destruct2 y H3. *)
  (*    inv H3. *)
  (*    destruct(b2assrt_dec b s1). *)
  (*    pose proof star_if_inv_true_n _ _ _ _ _ _ _ H H2. *)
  (*    eapply IHn with (S n). *)
  (*    apply H. *)
  (*    apply H. *)
  (*    inv H3. *)
  (*    red;intros. *)

  Lemma while_guarantee :
    forall (R : Env)(G : Env)(P : assrt) c b,
    Reflexive G ->
    stable R ([⊤]b) ->
    stable R ([⊥]b) ->
    stable R P ->
    {{ R , G }} ⊧ {{ ([⊤]b)[∧]P }} c {{ P }} ->
    forall s,
      P s ->
      forall s', star _ (prog_red R) (while b do c end,s) (skip,s') ->
                 <<R,G,while b do c end,s>>.
  Proof.
    intros.
    pose proof hoare_while R G P c b H H0 H1 H2 H3 _ H4 _ H5.
    destruct(b2assrt_dec b s).
    eapply while_middle;auto.
    eapply within_if_true;auto.
    eapply within_seq;auto.
    assert((([⊤]b)[∧]P) s).
    split;auto.
    pose proof H3 _ H7.
    destruct H8.
    assumption.
    intros.
    red;intros.
    admit.
    eapply while_middle_false;eauto.
    eapply within_if_false;auto.
    apply guarantee_SKIP.
  Qed.

End WithinWhile.

  Lemma within_par_skip_left :
    forall R G cr s,
      Reflexive G ->
      <<R,G,cr,s>> ->
      <<R,G,(par skip with cr end),s>>.
  Proof.
    unfold within at 2.
    intros.
    dependent induction H1.
    inv H2.
    inv H3.
    eapply H0.
    constructor.
    apply H3.
    apply H.

    destruct y0;destruct H3.
    inv H3.
    inv H5.
    cut(<<R,G,c2',s1>>).
    intro.
    pose proof IHstar c2' s1.
    clear IHstar.
    eapply H6.
    assumption.
    assumption.
    reflexivity.
    reflexivity.
    apply H2.
    exact(within_cstep_red_step R G _ _ _ _ H5 H0).
    eapply H0.
    apply H1.
    apply H2.

    destruct H3.
    simpl in *.
    symmetry in H3.
    subst.
    eapply IHstar.
    assumption.
    Focus 2.
    reflexivity.
    Focus 2.
    reflexivity.
    exact(within_R_interf_step R G cr _ _ H4 H0).
    apply H2.
  Qed.

  Lemma within_par_skip_right :
    forall R G cl s,
      Reflexive G ->
      <<R,G,cl,s>> ->
      <<R,G,(par cl with skip end),s>>.
  Proof.
    unfold within at 2.
    intros.
    dependent induction H1.
    inv H2.
    eapply H0.
    constructor.
    apply H3.
    inv H3.
    apply H.

    destruct y0;destruct H3.
    inv H3.
    cut(<<R,G,c1',s1>>).
    intro.
    pose proof IHstar c1' s1.
    clear IHstar.
    eapply H6.
    assumption.
    assumption.
    reflexivity.
    reflexivity.
    apply H2.
    exact(within_cstep_red_step R G _ _ _ _ H5 H0).
    inv H5.
    eapply H0.
    apply H1.
    apply H2.

    destruct H3.
    simpl in *.
    symmetry in H3.
    subst.
    eapply IHstar.
    assumption.
    Focus 2.
    reflexivity.
    Focus 2.
    reflexivity.
    exact(within_R_interf_step R G cl _ _ H4 H0).
    apply H2.
  Qed.

 (** Within and parallel composition. *)

  Lemma within_par_both:
    forall R G Gr Gl cl cr s,
      Reflexive G ->
      <<(rstOr R Gr),Gl,cl,s>> ->
      <<(rstOr R Gl),Gr,cr,s>> ->
      rstImp (rstOr Gl Gr) G ->
      <<R,G,par cl with cr end,s>>.
  Proof.
    intros.
    red;intros.
    dependent induction H3.

    inv H4.
    apply H2.
    left.
    eapply H0.
    constructor.
    apply H5.
    apply H2.
    right.
    eapply H1.
    constructor.
    apply H5.
    apply H.

    destruct y0.
    destruct H5.
    inv H5.

    assert(Gl s s1).
    eapply H0.
    constructor.
    apply H7.
    assert((rstOr R Gl) s s1).
    right;auto.
    pose proof within_R_interf_step (rstOr R Gl) Gr cr _ _ H8 H1.
    assert(<<rstOr R Gr,Gl,c1',s1>>).
    pose proof within_cstep_red_step (rstOr R Gr) Gl _ _ _ _ H7.
    apply H10.
    assumption.
    pose proof IHstar c1' cr s1 H H10 H9 H2 y c' refl_equal refl_equal c'' _ H4.
    assumption.

    assert(Gr s s1).
    eapply H1.
    constructor.
    apply H7.
    assert((rstOr R Gr) s s1).
    right;auto.
    pose proof within_R_interf_step (rstOr R Gr) Gl cl _ _ H8 H0.
    assert(<<rstOr R Gl,Gr,c2',s1>>).
    eapply within_cstep_red_step.
    apply H7.
    assumption.
    pose proof IHstar cl c2' s1 H H9 H10 H2 _ _ refl_equal refl_equal c'' _ H4.
    assumption.

    apply H2.
    right.
    eapply H1.
    2:apply H4.
    pose proof star_R_star_incl _ (prog_red R) (prog_red (rstOr R Gl)).
    eapply H6.

    intros.
    destruct H7.
    left;auto.
    right.
    destruct H7.
    red.
    split;auto.
    left;auto.
    apply H3.

    destruct H5.
    simpl in *.
    symmetry in H5.
    subst.
    eapply IHstar.
    5:reflexivity.
    5:reflexivity.
    4:apply H2.
    4:apply H4.
    apply H.
    assert((rstOr R Gr) s s1).
    left;auto.
    pose proof within_R_interf_step (rstOr R Gr) Gl cl s s1 H5 H0.
    assumption.
    assert((rstOr R Gl) s s1).
    left;auto.
    pose proof within_R_interf_step (rstOr R Gl) Gr cr s s1 H5 H1.
    assumption.
  Qed.

  Lemma par_reduces_to_skip_left :
    forall Rl Rr Gl Gr cl cr x s',
      rstImp (rstOr Rl Gl) Rr ->
      rstImp (rstOr Rr Gr) Rl ->
      <<Rl,Gl,cl,x>> -> <<Rr,Gr,cr,x>> ->
      star (stmt * st) (prog_red (rstAnd Rl Rr))
           (par cl with cr end, x) (skip, s') ->
      (exists cr',exists x',
                   star _ (prog_red Rl) (cl,x) (skip,x') /\
                   star _ (prog_red (rstAnd Rl Rr)) (par skip with cr' end,x')
                                       (skip,s') /\
                     star _ (prog_red Rr) (cr,x) (cr',x')).
  Proof.
    intros.
    do_star2starn H3.
    revert n cl cr x s' H1 H2 H3.
    induction n;intros.
    inv H3.

    inv H3.
    destruct2 y H5.
    inv H4.
    assert(<< Rl, Gl, c1', s0 >>) by (eapply within_cstep_red_step;eauto).
    assert((prog_red Rl) (cl,x) (c1',s0)).
    left;auto.
    pose proof correct_reduction_wrt_guarantee_one_step _ _ _ _ _ _ H8 H1.
    assert(Rr x s0).
    apply H.
    assumption.
    assert(<< Rr, Gr, cr, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn _ cr _ s' H5 H11 H6.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H13.
    exists x0.
    exists x1.
    split;auto.
    constructor 2 with (c1',s0).
    left;auto.
    assumption.
    split;auto.
    constructor 2 with (cr,s0).
    right;split;auto.
    assumption.

    assert(<< Rr, Gr, c2', s0 >>) by (eapply within_cstep_red_step;eauto).
    assert((prog_red Rr) (cr,x) (c2',s0)).
    left;auto.
    pose proof correct_reduction_wrt_guarantee_one_step _ _ _ _ _ _ H8 H2.
    assert(Rl x s0).
    apply H0.
    assumption.
    assert(<< Rl, Gl, cl, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn cl c2' _ s' H11 H5 H6.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H13.
    exists x0.
    exists x1.
    split;auto.
    constructor 2 with (cl,s0).
    right;split;auto.
    assumption.
    split;auto.
    constructor 2 with (c2',s0).
    left;auto.
    assumption.

    do_starn2star H6.
    apply star_skip_means_R_star  in H5.
    exists skip.
    exists s'.
    split;auto.
    apply star_and_l in H5.
    assumption.
    split.
    constructor 2 with (skip,s').
    left.
    constructor.
    constructor.

    apply star_and_r in H5.
    assumption.

    destruct H4.
    simpl in *.
    symmetry in H4.
    subst.
    destruct H5.
    assert(<< Rl, Gl, cl, s0 >>) by (eapply within_R_interf_step;eauto).
    assert(<< Rr, Gr, cr, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn _ _ _ _ H7 H8 H6.
    destruct H9.
    destruct H9.
    destruct H9.
    destruct H10.
    exists x0 x1.
    split;auto.
    constructor 2 with (cl,s0).
    right;split;auto.
    assumption.
    split;auto.
    constructor 2 with (cr,s0).
    right;split;auto.
    assumption.
  Qed.

  Lemma par_reduces_to_skip_right :
    forall Rl Rr Gl Gr cl cr x s',
      rstImp (rstOr Rl Gl) Rr ->
      rstImp (rstOr Rr Gr) Rl ->
      <<Rl,Gl,cl,x>> -> <<Rr,Gr,cr,x>> ->
      star (stmt * st) (prog_red (rstAnd Rl Rr))
           (par cl with cr end, x) (skip, s') ->
      (exists cl',exists x',
                   star _ (prog_red Rr) (cr,x) (skip,x') /\
                   star _ (prog_red (rstAnd Rl Rr)) (par cl' with skip end,x')
                                       (skip,s') /\
                     star _ (prog_red Rl) (cl,x) (cl',x')).
  Proof.
    intros.
    do_star2starn H3.
    revert n cl cr x s' H1 H2 H3.
    induction n;intros.
    inv H3.

    inv H3.
    destruct2 y H5.
    inv H4.
    assert(<< Rl, Gl, c1', s0 >>) by (eapply within_cstep_red_step;eauto).
    assert((prog_red Rl) (cl,x) (c1',s0)).
    left;auto.
    pose proof correct_reduction_wrt_guarantee_one_step _ _ _ _ _ _ H8 H1.
    assert(Rr x s0).
    apply H.
    assumption.
    assert(<< Rr, Gr, cr, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn _ cr _ s' H5 H11 H6.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H13.
    exists x0.
    exists x1.
    split;auto.
    constructor 2 with (cr,s0).
    right;split;auto.
    assumption.
    split;auto.
    constructor 2 with (c1',s0).
    left;auto.
    assumption.

    assert(<< Rr, Gr, c2', s0 >>) by (eapply within_cstep_red_step;eauto).
    assert((prog_red Rr) (cr,x) (c2',s0)).
    left;auto.
    pose proof correct_reduction_wrt_guarantee_one_step _ _ _ _ _ _ H8 H2.
    assert(Rl x s0).
    apply H0.
    assumption.
    assert(<< Rl, Gl, cl, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn cl c2' _ s' H11 H5 H6.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H13.
    exists x0.
    exists x1.
    split;auto.
    constructor 2 with (c2',s0).
    left;auto.
    assumption.
    split;auto.
    constructor 2 with (cl,s0).
    right;split;auto.
    assumption.

    do_starn2star H6.
    apply star_skip_means_R_star  in H5.
    exists skip.
    exists s'.
    split;auto.
    apply star_and_r in H5.
    assumption.
    split.
    constructor 2 with (skip,s').
    left.
    constructor.
    constructor.

    apply star_and_l in H5.
    assumption.

    destruct H4.
    simpl in *.
    symmetry in H4.
    subst.
    destruct H5.
    assert(<< Rl, Gl, cl, s0 >>) by (eapply within_R_interf_step;eauto).
    assert(<< Rr, Gr, cr, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn _ _ _ _ H7 H8 H6.
    destruct H9.
    destruct H9.
    destruct H9.
    destruct H10.
    exists x0 x1.
    split;auto.
    constructor 2 with (cr,s0).
    right;split;auto.
    assumption.
    split;auto.
    constructor 2 with (cl,s0).
    right;split;auto.
    assumption.
  Qed.

  Lemma par_reduces_to_skip_and :
    forall Rl Rr Gl Gr cl cr x s',
      rstImp (rstOr Rl Gl) Rr ->
      rstImp (rstOr Rr Gr) Rl ->
      <<Rl,Gl,cl,x>> -> <<Rr,Gr,cr,x>> ->
      star (stmt * st) (prog_red (rstAnd Rl Rr))
           (par cl with cr end, x) (skip, s') ->
      (exists cr',exists x',
                   star _ (prog_red Rl) (cl,x) (skip,x') /\
                   star _ (prog_red (rstAnd Rl Rr)) (par skip with cr' end,x')
                                       (skip,s')) /\
      (exists cl',exists x',
                   star _ (prog_red Rr) (cr,x) (skip,x') /\
                   star _ (prog_red (rstAnd Rl Rr)) (par cl' with skip end,x')
                   (skip,s')).
  Proof.
    intros.
    do_star2starn H3.
    revert n cl cr x s' H1 H2 H3.
    induction n;intros.
    inv H3.

    inv H3.
    destruct2 y H5.
    inv H4.
    assert(<< Rl, Gl, c1', s0 >>) by (eapply within_cstep_red_step;eauto).
    assert((prog_red Rl) (cl,x) (c1',s0)).
    left;auto.
    pose proof correct_reduction_wrt_guarantee_one_step _ _ _ _ _ _ H8 H1.
    assert(Rr x s0).
    apply H.
    assumption.
    assert(<< Rr, Gr, cr, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn _ cr _ s' H5 H11 H6.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H13.
    destruct H13.
    destruct H13.
    split.
    exists x0.
    exists x1.
    split;auto.
    constructor 2 with (c1',s0).
    left;auto.
    assumption.

    exists x2.
    exists x3.
    split;auto.
    constructor 2 with (cr,s0).
    right;split;auto.
    assumption.

    assert(<< Rr, Gr, c2', s0 >>) by (eapply within_cstep_red_step;eauto).
    assert((prog_red Rr) (cr,x) (c2',s0)).
    left;auto.
    pose proof correct_reduction_wrt_guarantee_one_step _ _ _ _ _ _ H8 H2.
    assert(Rl x s0).
    apply H0.
    assumption.
    assert(<< Rl, Gl, cl, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn cl c2' _ s' H11 H5 H6.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H12.
    destruct H13.
    destruct H13.
    destruct H13.
    split.
    exists x0.
    exists x1.
    split;auto.
    constructor 2 with (cl,s0).
    right;split;auto.
    assumption.
    exists x2.
    exists x3.
    split;auto.
    constructor 2 with (c2',s0).
    left;auto.
    assumption.

    do_starn2star H6.
    apply star_skip_means_R_star  in H5.
    split.
    exists skip.
    exists s'.
    split;auto.
    apply star_and_l in H5.
    assumption.
    constructor 2 with (skip,s').
    left.
    constructor.
    constructor.
    exists skip.
    exists s'.
    split;auto.
    apply star_and_r in H5.
    assumption.
    constructor 2 with (skip,s').
    left.
    constructor.
    constructor.

    destruct H4.
    simpl in *.
    symmetry in H4.
    subst.
    destruct H5.
    assert(<< Rl, Gl, cl, s0 >>) by (eapply within_R_interf_step;eauto).
    assert(<< Rr, Gr, cr, s0 >>) by (eapply within_R_interf_step;eauto).
    pose proof IHn _ _ _ _ H7 H8 H6.
    destruct H9.
    destruct H9.
    destruct H9.
    destruct H9.
    destruct H10.
    destruct H10.
    destruct H10.
    split.
    exists x0 x1.
    split;auto.
    constructor 2 with (cl,s0).
    right;split;auto.
    assumption.
    exists x2 x3.
    split;auto.
    constructor 2 with (cr,s0).
    right;split;auto.
    assumption.
  Qed.


Require Import
  Coq.Logic.Decidable Coq.Relations.Relations
  Coq.Strings.String Coq.Program.Basics Coq.Program.Equality
  Ssreflect.ssreflect Ssreflect.ssrnat Ssreflect.seq
  FormalPS.stdlib_ext.

Set Implicit Arguments.

(*
inst:
  命令の定義。命令は値も兼ねる。
*)
Inductive inst : Set :=
  | instpop | instcopy | instswap | instcons | instquote | instexec
  | instpush of inst
  | instpair of inst & inst.

(*
inst_to_pscode:
  inst 型の命令を PostScript のプログラムに変換する。
*)
Fixpoint pscode_of_inst (i : inst) : string :=
  match i with
    | instpop        => "pop"
    | instcopy       => "dup"
    | instswap       => "exch"
    | instcons       => "cons"
    | instquote      => "quote"
    | instexec       => "exec"
    | instpush i     => "{" ++ pscode_of_inst i ++ "}"
    | instpair i1 i2 => pscode_of_inst i1 ++ " " ++ pscode_of_inst i2
  end%string.

(*
inst_size:
  命令を構成するコンストラクタの数を計算する。
*)
Fixpoint inst_size i : nat :=
  match i with
    | instpush i => (inst_size i).+1
    | instpair i1 i2 => (inst_size i1 + inst_size i2).+1
    | _ => 1
  end.

(*
state:
  状態は2つの命令列の組。前者はスタック、後者は継続である。
*)
Notation state := (seq inst * seq inst)%type.

(*
eval:
  計算は状態上の二項関係(書換系)である。
  evalpop (instpop):
    値のスタックの先頭を捨てる。
  evalcopy (instcopy):
    値のスタックの先頭を複製する。
  evalswap (instswap):
    値のスタックの先頭の2つの値を入れ替える。
  evalcons (instcons):
    値のスタックの先頭の2つの値を取り出し、そのペアを instpair で作成し、値のス
    タックの先頭に積む。
  evalquote (instquote):
    値のスタックの先頭にある値を取り出し、クオートした値をスタックに積む。クオー
    トされた値は実行すると元の値が取り出せる。
  evalexec (instexec):
    値のスタックの先頭にある値を取り出し、継続のスタックの先頭に積む。
  evalpush (instpush):
    instpush のパラメータの値を値のスタックに積む。
  evalpair (instpair):
    instpair のパラメータの2つの命令を継続のスタックに積む。
*)
Inductive eval : relation state :=
  | evalpop   : forall i vs cs, eval (i :: vs, instpop :: cs) (vs, cs)
  | evalcopy  : forall i vs cs,
      eval (i :: vs, instcopy :: cs) (i :: i :: vs, cs)
  | evalswap  : forall i1 i2 vs cs,
      eval (i2 :: i1 :: vs, instswap :: cs) (i1 :: i2 :: vs, cs)
  | evalcons  : forall i1 i2 vs cs,
      eval (i2 :: i1 :: vs, instcons :: cs) (instpair i1 i2 :: vs, cs)
  | evalquote : forall i vs cs,
      eval (i :: vs, instquote :: cs) (instpush i :: vs, cs)
  | evalexec  : forall i vs cs, eval (i :: vs, instexec :: cs) (vs, i :: cs)
  | evalpush  : forall i vs cs, eval (vs, instpush i :: cs) (i :: vs, cs)
  | evalpair  : forall i1 i2 vs cs,
      eval (vs, instpair i1 i2 :: cs) (vs, i1 :: i2 :: cs).

(*
evalrtc:
  eval の反射推移閉包。
*)
Notation evalrtc := (clos_refl_trans_1n state eval).

(*
|=>, |=>*:
  eval, evalrtc の中置演算子。
*)
Infix "|=>" := eval (at level 50, no associativity).
Infix "|=>*" := evalrtc (at level 50, no associativity).

Lemma evalrtc_refl s : s |=>* s.
Proof. constructor. Qed.

Lemma evalrtc_refl' s1 s2 : s1 = s2 -> s1 |=>* s2.
Proof. move => ->; constructor. Qed.

Lemma evalrtc_step s1 s2 : s1 |=> s2 -> s1 |=>* s2.
Proof. do !econstructor; eauto. Qed.

Lemma evalrtc_cons s1 s2 s3 : s1 |=> s2 -> s2 |=>* s3 -> s1 |=>* s3.
Proof. econstructor; eauto. Qed.

Lemma evalrtc_trans s1 s2 s3 : s1 |=>* s2 -> s2 |=>* s3 -> s1 |=>* s3.
Proof. by apply rt1n_trans'. Qed.

(*
decide_eval:
  状態 s1 から eval によって書き換えられる状態 s2 の有無を決定する。
*)
Lemma decide_eval s1 : decidable (exists s2 : state, s1 |=> s2).
Proof.
  move: s1 => [vs [ | [ | | | | | | | ]]];
  [| case: vs |
     case: vs |
     case: vs => [ | v []] |
     case: vs => [ | v []] |
     case: vs |
     case: vs | |];
  (by right => H; do 2 inversion 0) ||
  (by left; eexists; constructor).
Defined.

(*
eval_uniqueness:
  状態 s1 から eval によって書き換えられる状態 s2, s3 は同値である。
*)
Lemma eval_uniqueness s1 s2 s3 : s1 |=> s2 -> s1 |=> s3 -> s2 = s3.
Proof.
  case: s1 => [[ | v vs] [ | [ | | | | | | c | c1 c2 ] cs]] => H H0;
    inversion H; inversion H0; congruence.
Qed.

(*
eval_semi_uniqueness:
  s1 |=>* s2 かつ s1 |=>* s3 ならば s2 |=>* s3 もしくは s3 |=>* s2 が成り立つ。
*)
Lemma eval_semi_uniqueness s1 s2 s3 :
  s1 |=>* s2 -> s1 |=>* s3 -> s2 |=>* s3 \/ s3 |=>* s2.
Proof.
  elim; auto => x y z H H0 IH H1.
  inversion H1; subst.
  - right; econstructor; eauto.
  - move: IH; rewrite (eval_uniqueness H H2); auto.
Qed.

(*
eval_apptail, evalrtc_apptail:
  ある計算が正しければ、その両辺の値スタックや継続スタックの末尾にリストを足した
  としても正しい計算となる。
*)
Lemma eval_apptail vs ps vs' ps' vs'' ps'' :
  (vs, ps) |=> (vs', ps') ->
  (vs ++ vs'', ps ++ ps'') |=> (vs' ++ vs'', ps' ++ ps'').
Proof. move => H; inversion H; constructor. Qed.

Lemma evalrtc_apptail vs ps vs' ps' vs'' ps'' :
  (vs, ps) |=>* (vs', ps') ->
  (vs ++ vs'', ps ++ ps'') |=>* (vs' ++ vs'', ps' ++ ps'').
Proof.
  move => H; dependent induction H.
  - constructor.
  - destruct y.
    by apply evalrtc_cons with (l ++ vs'', l0 ++ ps'');
      [ apply eval_apptail | apply IHclos_refl_trans_1n].
Qed.

(*
evalstep:
  ゴールが s1 |=>* s2 の形である場合に、s1 から書き換え可能な状態 s3 を計算し、
  ゴールを s3 |=>* s2 で置き換えるタクティク。計算を自動的に1段階進める。
*)
Lemma exists_and_right_map (P Q R : inst -> Prop) :
  (forall i, Q i -> R i) ->
  (exists i : inst, P i /\ Q i) -> (exists i : inst, P i /\ R i).
Proof. by firstorder. Qed.

Ltac evalstep_0 s :=
  apply evalrtc_refl ||
  match eval hnf in (decide_eval s) with
    | or_introl _ (ex_intro _ _ ?p) => apply (@evalrtc_cons _ _ _ p)
  end.

Ltac evalstep_1 s :=
  (eexists; split; last apply evalrtc_refl) ||
  match eval hnf in (decide_eval s) with
    | or_introl _ (ex_intro _ _ ?p) =>
      apply (@exists_and_right_map _ _ _ (fun _ => @evalrtc_cons _ _ _ p))
  end.

Ltac evalstep_2 s :=
  (eexists; split; last (eexists; split; last apply evalrtc_refl)) ||
  match eval hnf in (decide_eval s) with
    | or_introl _ (ex_intro _ _ ?p) =>
      apply (@exists_and_right_map _ _ _ (fun _ =>
             @exists_and_right_map _ _ _ (fun _ => @evalrtc_cons _ _ _ p)))
  end.

Ltac evalstep :=
  match goal with
    | |- ?s |=>* _ => evalstep_0 s
    | |- exists i1 : inst, _ /\ ?s |=>* _ => evalstep_1 s
    | |- exists i1 : inst, _ /\ exists i2 : inst, _ /\ ?s |=>* _ =>
      evalstep_2 s
  end.

(*
evalauto:
  evalstep を適用できなくなるまで繰り返す。
*)
Ltac evalauto := do !evalstep.

(*
evalpartial:
  指定した関数を適用することで計算を途中まで進める。
*)
Tactic Notation "evalpartial" constr(H) "by" tactic(tac) :=
  (
    eapply evalrtc_trans ||
    refine (@exists_and_right_map _ _ _ (fun _ => @evalrtc_trans _ _ _ _) _) ||
    refine (@exists_and_right_map _ _ _ (fun _ =>
            @exists_and_right_map _ _ _ (fun _ => @evalrtc_trans _ _ _ _)) _)
  ); [ by (apply evalrtc_step; eapply H) || eapply H; tac | ]; subst_evars.

Tactic Notation "evalpartial" constr(H) := evalpartial H by idtac.

Tactic Notation "evalpartial'" constr(H) "by" tactic(tac) :=
  evalpartial evalpair; evalpartial H by tac.

Tactic Notation "evalpartial'" constr(H) := evalpartial' H by idtac.

(*
rtcrefl:
  ゴール s1 |=>* s2 を s1 = s2 で置き換え、f_equal を繰り返し適用する。
*)
Ltac rtcrefl := apply evalrtc_refl'; do ?f_equal.

(*
exists_nop:
  何もしない(NOP)命令。
*)
Lemma exists_nop :
  { instnop : inst | forall vs cs, (vs, instnop :: cs) |=>* (vs, cs) }.
Proof.
  eexists => vs cs.
  evalpartial' (evalpush instpop).
  evalpartial evalpop.
  evalauto.
Defined.

Notation instnop := (proj1_sig exists_nop).
Notation evalnop := (proj2_sig exists_nop).

(*
exists_snoc:
  instswap, instcons を順番に実行する。パラメータの順番が反転した instcons。
*)
Lemma exists_snoc :
  { instsnoc : inst | forall i1 i2 vs cs,
    (i1 :: i2 :: vs, instsnoc :: cs) |=>* (instpair i1 i2 :: vs, cs) }.
Proof.
  eexists => i1 i2 vs cs.
  evalpartial' evalswap.
  evalpartial evalcons.
  evalauto.
Defined.

Notation instsnoc := (proj1_sig exists_snoc).
Notation evalsnoc := (proj2_sig exists_snoc).

(*
instseqc', instseqc:
  命令列を素直に記述するためのもの。命令のリストを instpair で畳み込むと、それが
  継続のスタックの先頭にあった場合に、元のリストの通りに展開される。
*)
Notation instseqc' := (foldl instpair).
Notation instseqc := (instseqc' instnop).
Notation instnseqc' n i1 i2 := (iter n (flip instpair i1) i2).
Notation instnseqc n i := (instnseqc' n i instnop).

Lemma evalseqc' il i vs cs : (vs, instseqc' i il :: cs) |=>* (vs, i :: il ++ cs).
Proof.
  elim: il i => [ | i il IH] i'.
  - evalauto.
  - evalpartial IH; evalauto.
Qed.

Lemma evalseqc il vs cs : (vs, instseqc il :: cs) |=>* (vs, il ++ cs).
Proof. evalpartial evalseqc'. evalauto. Qed.

Lemma app_instseqc' il1 il2 i :
  instseqc' i (il1 ++ il2) = instseqc' (instseqc' i il1) il2.
Proof. apply foldl_cat. Qed.

Lemma app_instseqc il1 il2 :
  instseqc (il1 ++ il2) = instseqc' (instseqc il1) il2.
Proof. apply app_instseqc'. Qed.

Lemma instnseqc_eq n i1 i2 :
  instseqc' i2 (nseq n i1) = instnseqc' n i1 i2.
Proof. by elim: n i2 => // n IH i2; rewrite iterSr /= IH. Qed.

Lemma evalnseqc' n i1 i2 vs cs :
  (vs, instnseqc' n i1 i2 :: cs) |=>* (vs, i2 :: nseq n i1 ++ cs).
Proof. rewrite -instnseqc_eq; apply evalseqc'. Qed.

Lemma evalnseqc n i vs cs :
  (vs, instnseqc n i :: cs) |=>* (vs, nseq n i ++ cs).
Proof. evalpartial evalnseqc'. evalauto. Qed.

(*
instseqv', instseqv:
  スタックに展開される命令の並びを記述するためのもの。
*)
Notation instseqv' := (foldl (fun a b => instpair (instpush b) a)).

Lemma evalseqv' il i vs cs : (vs, instseqv' i il :: cs) |=>* (il ++ vs, i :: cs).
Proof.
  elim: il i => [ | i' il IH ] i.
  - evalauto.
  - evalpartial IH; evalauto.
Qed.

Notation instseqv := (instseqv' instnop).

Lemma evalseqv il vs cs : (vs, instseqv il :: cs) |=>* (il ++ vs, cs).
Proof. evalpartial evalseqv'. evalauto. Qed.

Lemma app_instseqv' il1 il2 i :
  instseqv' i (il1 ++ il2) = instseqv' (instseqv' i il1) il2.
Proof. apply foldl_cat. Qed.

Lemma app_instseqv il1 il2 :
  instseqv (il1 ++ il2) = instseqv' (instseqv il1) il2.
Proof. apply app_instseqv'. Qed.


(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import fcf.Crypto.
Require Import fcf.Encryption.
Require Import fcf.CompFold.
Require Import fcf.FCF.

Section EncryptClassify.

  Variable Plaintext Ciphertext Key : Set.
  Variable KeyGen : Comp Key.
  Variable Encrypt : Key -> Plaintext -> Comp Ciphertext.
  Variable Decrypt : Key -> Ciphertext -> Plaintext.

  Hypothesis Ciphertext_EqDec : EqDec Ciphertext.

  Variable A_State : Set.
  Variable A1 : (Plaintext -> Comp Ciphertext) -> Comp (list (Plaintext * Plaintext) * (Plaintext * Plaintext) * A_State).
  Variable A2 : A_State -> (Plaintext -> Comp Ciphertext) -> list (Ciphertext * bool) -> Ciphertext -> Comp bool.

  Definition IND_CPA_SecretKey_Class_G :=
    key <-$ KeyGen ;
    [lsP, p, s_A] <-$3 A1 (Encrypt key);
    [p0, p1] <-2 p;
    lsC <-$ compMap _ (fun p => b <-$ {0, 1}; p_b <- if b then (snd p) else (fst p); c_b <-$ Encrypt key p_b; ret (c_b, b)) lsP;
    b <-$ {0, 1};
    pb <- if b then p1 else p0;
    c <-$ Encrypt key pb;
    b' <-$ A2 s_A (Encrypt key) lsC c;
    ret (eqb b b').

End EncryptClassify.


From Coq Require Import Morphisms.
Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect.
Set Warnings "notation-overridden,ambiguous-paths".
From Mon Require Import SPropBase.
From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples.
From Crypt Require Import OrderEnrichedRelativeAdjunctions OrderEnrichedRelativeAdjunctionsExamples ChoiceAsOrd.

Import SPropNotations.

Section AuxLemmas.
  Context {A : Type} {P : A -> Prop}.

  Lemma myBetaRed : forall x e, (exist P x e)∙1 = x.
  Proof.
    move=> x e. simpl. reflexivity.
  Qed.

  Context {B : Type}.
  Context (f g : A -> B).
  Lemma funRewrite : f = g -> forall a , f a = g a.
  Proof.
    move=> H. rewrite H. move=> a. reflexivity.
  Qed.

End AuxLemmas.

Section MonotonicBind.
  Notation η := ord_relmon_unit.
  Notation dnib := ord_relmon_bind.

  Let J :=
  (ord_functor_comp F_choice_prod SubDistr.chDiscr).
  Context {W : ord_relativeMonad J}.

  Import OrderEnrichedRelativeMonadExamplesNotation.
  Open Scope SPropMonadicStructures_scope.

  Context {AA BB : prod_cat ord_choiceType ord_choiceType}.
  Context (w w' : dfst (W AA)).
  Context (Hw : w ≤ w').
  Context (f : OrdCat⦅ J AA ; W BB⦆).

  Lemma monotonic_bind :
  ((dnib W) f )∙1 w ≤ ((dnib W) f )∙1 w'.
  Proof.
    destruct (dnib W f) as [gg ggmon].
    apply ggmon. assumption.
  Qed.

  Lemma noMoreLets :
  forall f1 f2 : OrdCat⦅ J AA ; W BB ⦆,
  f1 = f2 -> (let (a,_) := dnib W f1 in a) = (let (a,_) := dnib W f2 in a).
  Proof.
    move=> f1 f2. move=> Hf. rewrite Hf. reflexivity.
  Qed.

End MonotonicBind.

Section ComputationalAuxiliary.
  Notation η := ord_relmon_unit.
  Notation dnib := ord_relmon_bind.

  (*applied relmon laws for monad I → TypeCat*)
  Context {I : ord_category}.
  Context {J : ord_functor I TypeCat}.
  Context {M : ord_relativeMonad J}.

  Lemma applied_ord_relmon_law1 :
  forall (A : I) x, dnib M (η M A) x = x.
  Proof.
    move=> A. move=> x. rewrite ord_relmon_law1. simpl. reflexivity.
  Qed.

  Lemma applied_ord_relmon_law2 :
  forall (A B : I) (f : TypeCat ⦅ J A; M B ⦆) x, dnib M f ( η M A x ) = f x.
  Proof.
    move=> A B f x.
    unshelve epose (aux := (ord_relmon_law2 M) _ _ _).
      shelve. shelve. exact f.
    unshelve eapply equal_f in aux. exact x. simpl in aux.
    assumption.
  Qed.

  Lemma applied_ord_relmon_law3 :
  forall (A B C : I) (f : TypeCat ⦅ J B; M C ⦆) (g : TypeCat ⦅ J A; M B ⦆) x,
       dnib M (dnib M f ∙ g) x = dnib M f ( dnib M g x).
  Proof.
    move=> A B C f g x.
    epose (aux := (ord_relmon_law3 M) A B C f g).
    unshelve eapply equal_f in aux. exact x.
    assumption.
  Qed.

End ComputationalAuxiliary.

Section ComputationalStatefulLiftDef.
  Notation η := ord_relmon_unit.
  Notation dnib := ord_relmon_bind.

  (*The semantic relational framework we are using assumes that there is a relational
    computational monad which is a product of two unary computational monads M1 and M2.
    Here we have Mi : choiceType → Type two choiceType relative unary computational
    monads.
  *)
  Context {M1 M2 : ord_relativeMonad choice_incl}.
  Let M := product_rmon M1 M2. (*relational computational monad*)

  (*The transforming state adjunction*)
  Context {S1 S2 : ord_choiceType}.
  Let TingAdj := Chi_DomainStateAdj S1 S2.

  (*The state transformed computational monad*)
  Let StT_M := AdjTransform M _ _ TingAdj.

  (*We wish to build the lift morphism M → StT_M*)
  Definition StatefulCompLift0 :
  forall A : prod_cat ord_choiceType ord_choiceType,
                   prod_cat TypeCat TypeCat ⦅ ord_functor_id (prod_cat TypeCat TypeCat) (M A);
                   StT_M A ⦆.
  move=> [A1 A2]. simpl. rewrite /F_choice_prod_obj. constructor.
  - move=> m s. eapply (dnib M1).
    move=> a. apply (η M1). simpl. exact (a,s). exact m.
  - move=> m s. eapply (dnib M2).
    move=> a. apply (η M2). simpl. exact (a,s). exact m.
  Defined.

  Let J := prod_functor choice_incl choice_incl.
  Let myChi := natIso_sym (ord_functor_unit_right J).
  Program Definition StatefulCompLift :=
    mkRelMonMorph _ myChi M StT_M StatefulCompLift0 _ _.
  Next Obligation.
    move=> [A1 A2]. f_equal.
    - apply boolp.funext. move=> a. apply boolp.funext. move=> s.
      rewrite /F_choice_prod_obj. simpl.
      epose (bla :=
      (ord_relmon_law2 M1) _ _ (fun a0 : choice.Choice.sort A1 => η M1 (choice.prod_choiceType A1 S1) (a0, s)) ). simpl in bla.
      unshelve eapply equal_f in bla.  exact a.
      assumption.
    - apply boolp.funext. move=> a. apply boolp.funext. move=> s.
      rewrite /F_choice_prod_obj. simpl.
      epose (bla :=
      (ord_relmon_law2 M2) _ _ (fun a0 : choice.Choice.sort A2 => η M2 (choice.prod_choiceType A2 S2) (a0, s)) ). simpl in bla.
      unshelve eapply equal_f in bla.  exact a.
      assumption.
  Qed.
  Next Obligation.
    move=> [A1 A2] [B1 B2]. simpl.
    move=> [k1 k2].
    rewrite /OrderEnrichedRelativeAdjunctionsExamples.ToTheS_obligation_1.
    simpl. f_equal.
    - apply boolp.funext. move=> m. apply boolp.funext. move=> s.
      (*nice proof technique here*)
      pose (bindbindM1 := (ord_relmon_law3 M1)).
      eapply equal_f in bindbindM1. simpl in bindbindM1.
      erewrite <- bindbindM1. clear bindbindM1.
      (*ends here. We do a similar rewriting in the righthandside*)
      pose (bindbindM1 := (ord_relmon_law3 M1)).
      eapply equal_f in bindbindM1. simpl in bindbindM1.
      erewrite <- bindbindM1. clear bindbindM1.
      (*ends here. The two erewritings are equivalent to the following:*)
      (* rewrite -!applied_ord_relmon_law3. simpl. *)
      f_equal.
      apply boolp.funext. move=> a.
      rewrite ! applied_ord_relmon_law2. reflexivity.
    - apply boolp.funext. move=> m. apply boolp.funext. move=> s.
      rewrite - !applied_ord_relmon_law3. simpl.
      f_equal.
      apply boolp.funext. move=> a.
      rewrite ! applied_ord_relmon_law2. reflexivity.
  Qed.

End ComputationalStatefulLiftDef.

Section SpecificationAuxiliary.

  Notation η := ord_relmon_unit.
  Notation dnib := ord_relmon_bind.

  (*applied relmon laws for monad I → TypeCat*)
  Context {I : ord_category}.
  Context {J : ord_functor I OrdCat}.
  Context {M : ord_relativeMonad J}.

  Lemma spec_applied_ord_relmon_law1 :
  forall (A : I) x, (dnib M (η M A))∙1 x = x.
  Proof.
    move=> A. move=> x. rewrite ord_relmon_law1. simpl. reflexivity.
  Qed.

  Lemma spec_applied_ord_relmon_law2 :
  forall (A B : I) (f : OrdCat ⦅ J A; M B ⦆) x, (dnib M f)∙1 ( (η M A)∙1 x ) = f∙1 x.
  Proof.
    move=> A B f x.
    unshelve epose (aux := (ord_relmon_law2 M) _ _ _).
      shelve. shelve. exact f.
    apply (f_equal sval) in aux. simpl in aux.
    unshelve eapply equal_f in aux. exact x. simpl in aux.
    assumption.
  Qed.

  Lemma spec_applied_ord_relmon_law3 :
  forall (A B C : I) (f : OrdCat ⦅ J B; M C ⦆) (g : OrdCat ⦅ J A; M B ⦆) x,
       (dnib M (dnib M f ∙ g))∙1 x = (dnib M f)∙1 ( (dnib M g)∙1 x).
  Proof.
    move=> A B C f g x.
    simpl.
    epose (aux := (ord_relmon_law3 M) A B C f g).
    apply (f_equal sval) in aux. simpl in aux.
    unshelve eapply equal_f in aux. exact x.
    assumption.
  Qed.

End SpecificationAuxiliary.

Section SpecficationStatefulLiftDef.
  Notation η := ord_relmon_unit.
  Notation dnib := ord_relmon_bind.

  (*
  A relational specification monad W is a monad relative to
  the product;discrete functor J : choiceType² → Preorder
   *)
  Context {S1 S2 : ord_choiceType}.
  Let J :=
  (ord_functor_comp F_choice_prod SubDistr.chDiscr).
  Context {W : ord_relativeMonad J}.

  (*the state , transforming,  adjunction*)
  Let TingAdj := Chi_CodomainStateAdj S1 S2.

  (*The state transformed spec monad*)
  Let StT_W := AdjTransform W _ _ TingAdj.

  (* We wish to build a rmm morphism lift : W -> StT_W *)

  Program  Definition StatefulSpecLift0 (A : prod_cat ord_choiceType ord_choiceType) :
  OrdCat ⦅ ord_functor_id OrdCat (W A); StT_W A ⦆ := exist _ _ _.
  Next Obligation.
  move=> [A1 A2]. move=> w. unshelve econstructor.
  rewrite /F_choice_prod_obj. cbn.
  move=> [s1 s2].
  unshelve eapply (dnib W). exact ⟨A1,A2⟩.
  unshelve econstructor.
    cbn. move=> [a1 a2]. eapply (η W). exact ((a1,s1),(a2,s2)).
    move=> [a1 a2] [a1' a2']. cbn.
    move=> Ha. inversion Ha. reflexivity.
  exact w.
  move=> [s1 s2] [s1' s2'] Hs. inversion Hs ; reflexivity.
  Defined.
  Next Obligation.
    move=> [A1 A2]. move=> w w'. move=> Hw. move=> [s1 s2].
    cbn.
    eapply monotonic_bind. assumption.
  Qed.

  Let myChi := natIso_sym (ord_functor_unit_right J).
  Program Definition StatefulSpecLift :=
    mkRelMonMorph _ myChi W StT_W StatefulSpecLift0 _ _.
  Next Obligation.
    move=> [A1 A2]. apply sig_eq. cbn.
    apply boolp.funext. move=> [a1 a2]. cbn.
    rewrite /OrderEnrichedRelativeAdjunctions.relKleisli_obligation_1.
    rewrite /F_choice_prod_obj.
    rewrite /StatefulSpecLift0_obligation_1.
    cbn.
    apply sig_eq. cbn. apply boolp.funext.
    move=> [s1 s2].
    pose (bindretW := @spec_applied_ord_relmon_law2 _ _ W).
    cbv in bindretW. rewrite bindretW.
    destruct (η W ⟨prod_choiceType A1 S1, prod_choiceType A2 S2⟩).
    cbn. reflexivity.
  Qed.
  Next Obligation.
    move=> [A1 A2] [B1 B2] [ff ffmon].
    apply sig_eq. cbn. apply boolp.funext. move=> w.
    rewrite /StatefulSpecLift0_obligation_1. cbn.
    apply sig_eq. cbn. apply boolp.funext.
    move=> [s1 s2].
    cbn.
    pose (bindbindW := (@spec_applied_ord_relmon_law3 _ _ W)).
    cbv in bindbindW. rewrite -bindbindW.
    unfold "∙1". cbn. rewrite -bindbindW.
    (* destruct ( η W ⟨ prod_choiceType A1 S1, prod_choiceType A2 S2 ⟩ ) *)
    (*     as [eta_as eta_as1_mon]. *)
    (* destruct ( η W ⟨ prod_choiceType B1 S1, prod_choiceType B2 S2 ⟩ ) *)
    (*     as [eta_bs eta_bs_mon]. *)
    cbn.
    move: w. apply funRewrite. apply noMoreLets. apply sig_eq.
    cbn. apply boolp.funext. move=> [a1 a2].
    pose (bindretW := (@spec_applied_ord_relmon_law2 _ _ W)).
    cbv in bindretW. rewrite bindretW. reflexivity.
  Qed.

End SpecficationStatefulLiftDef.