Require Import Common.exceptionMonad.
Require Import Common.AstCommon.
Require Import Common.certiClasses.
Require Import Common.certiClasses2.
Require Import Common.certiClasses3.
Require Import Coq.Unicode.Utf8.
Require Import SquiggleEq.tactics.
Require Import SquiggleEq.LibTactics.
Require Import Morphisms.

Class MkApply (Term:Type) := mkApp : Term -> Term -> Term.

Class CerticoqLinkableLanguage (Term:Type)
  `{BigStepOpSem Term} `{GoodTerm Term}
  `{QuestionHead Term} `{ObserveNthSubterm Term}
  `{MkApply Term}
:=
{
}.

Definition mkAppEx {Term:Type}  {mka: MkApply Term} (f:Term) (arg : exception Term):
  exception Term:=
  match arg with
  | Ret arg => Ret (mkApp f arg)
  | _ => arg
  end.

Section CompObsPreserving.

Context (Src Dst: Type)
  (* {SrcValue DstValue: Type} having a seperate type for values becomes awkward in this setup.
     If really needed, one can always use sum types to combine the term and value types.*)
          `{QuestionHead Src} `{ObserveNthSubterm Src}
   `{QuestionHead Dst} `{ObserveNthSubterm Dst}
   `{BigStepOpSem Src} `{BigStepOpSem Dst} `{GoodTerm Src}
   `{CerticoqTranslation Src Dst}  `{MkApply Src}  `{MkApply Dst}.

CoInductive compObsLeLink : Src -> Dst -> Prop :=
| sameObsLink : forall (s : Src) (d : Dst),
    (forall (o:Opt) (sv:Src),
        s ⇓ sv
        -> (exists (dv : Dst),
              d ⇓ dv /\
              yesPreserved sv dv
              /\ (forall n:nat, liftLe compObsLeLink (observeNthSubterm n sv) (observeNthSubterm n dv))
              /\ (questionHead  Abs sv = true -> forall svArg, goodTerm svArg ->
                   liftLe compObsLeLink
                      (Some (mkApp sv svArg))
                      (exception_option (mkAppEx dv (translate Src Dst o svArg))))
          ))
    -> compObsLeLink s d.

Inductive compObsLeLinkN : nat -> Src -> Dst -> Prop :=
| sameObsLinkS : forall m (s : Src) (d : Dst),
    (forall (o:Opt) (sv:Src),
        s ⇓ sv
        -> (exists (dv:Dst),
              d ⇓ dv /\
              yesPreserved sv dv
              /\ (forall n:nat, liftLe (compObsLeLinkN m) (observeNthSubterm n sv) (observeNthSubterm n dv))
              /\ (questionHead  Abs sv = true -> forall svArg, goodTerm svArg ->
                   liftLe (compObsLeLinkN m)
                      (Some (mkApp sv svArg))
                      (exception_option (mkAppEx dv (translate Src Dst o svArg))))
          ))
    -> compObsLeLinkN (S m) s d
| sameObsLinkO : forall (s : Src) (d : Dst), compObsLeLinkN 0 s d.

(** this part is generally easy and unconditional *)
Lemma fromCoInd s d:
  compObsLeLink s d -> forall m, compObsLeLinkN m s d.
Proof using.
  intros Hc m. revert Hc. revert d. revert s.
  induction m as [ | m Hind]; intros ? ? Hc;
    [ constructor; fail | ].
  destruct Hc as [? ? Hc].
  constructor.
  intros o1 sv Hev. specialize (Hc o1 sv Hev).
  destruct Hc as [dv Hc]. repnd.
  exists dv. dands; eauto with certiclasses.
Qed.

Lemma toCoInd {dstDet: deterministicBigStep Dst}s d:
  (forall m, compObsLeLinkN m s d) -> compObsLeLink s d.
Proof using.
  revert d. revert s.
  cofix toCoInd.
  intros ? ? Hi.
  constructor.
  intros o ? Hev. pose proof Hi as Hib.
  specialize (Hi 1); inversion Hi as [ ? ? ? Hc | ]; subst. clear Hi.
  specialize (Hc o sv Hev).
  destruct Hc as [dv Hc]. repnd.
  exists dv.
  dands; auto.
  - clear Hc. intros n.
    apply liftLeRimpl with (R1:= fun a b => forall m, compObsLeLinkN m a b); eauto.

    specialize (Hc2 n). invertsna Hc2 H0c;[ | constructor].
    rename s0 into svn.
    rename d0 into dvn.
    constructor.
    intros m.
    specialize (Hib (S m)).
    invertsna Hib Hib.
    specialize (Hib o sv Hev).
    destruct Hib as [dvv Hib]. repnd.
    specialize (dstDet _ _ _ Hib0 Hc0). subst. clear Hib0 Hib.
    specialize (Hib2 n).
    rewrite <- H0c1, <- H0c0 in Hib2.
    inverts Hib2. assumption.

  - clear Hc2. intros Hq ? Hg.
    specialize (Hc Hq _ Hg).
    apply liftLeRimpl with (R1:= fun a b => forall m, compObsLeLinkN m a b); eauto.
    invertsna Hc H0c.
    constructor.
    intros m.
    specialize (Hib (S m)).
    invertsna Hib Hib.
    specialize (Hib o sv Hev).
    destruct Hib as [dvv Hib]. repnd.
    specialize (dstDet _ _ _ Hib0 Hc0). subst. clear Hib0 Hib2.
    specialize (Hib Hq _ Hg).
    rewrite  <- H0c0 in Hib.
    inverts Hib. assumption.
Qed.

Definition compObsPreservingLinkable :=
   ∀ (o: Opt) (s:Src),
    goodTerm s
    -> liftLe compObsLeLink (Some s) (exception_option (translate Src Dst o s)).

End CompObsPreserving.

Class CerticoqLinkableTranslationCorrect {Src Dst : Type}
  `{CerticoqLinkableLanguage Src}
  `{CerticoqLinkableLanguage Dst}
  `{CerticoqTranslation Src Dst}
  :=
{
  certiGoodPresLink : goodPreserving Src Dst;
  obsePresLink : compObsPreservingLinkable Src Dst;
}.

Global Arguments CerticoqLinkableTranslationCorrect
  {Src} {Dst} {H} {H0} {H1} {H2} {H3}  H4 {H5} {H6} {H7} {H8} {H9} H10 {H11}.

Notation "s ⊑ t" := (compObsLeLink _ _ s t) (at level 65).

Section ComposeLink.
Context (Src Inter Dst : Type)
        `{Ls: CerticoqLinkableLanguage Src}
        `{Li: CerticoqLinkableLanguage Inter}
        `{Ld: CerticoqLinkableLanguage Dst}
  {t1 : CerticoqTranslation Src Inter}
  {t2 : CerticoqTranslation Inter Dst}.

Lemma compObsLeLinkTransitive
      {Hgpsi : goodPreserving Src Inter}
      {Hgpid : goodPreserving Inter Dst}:
   forall   (s : Src) (i : Inter) (d : Dst),
  s ⊑ i
  -> i ⊑ d
  -> s ⊑ d.
Proof.
  cofix compObsLeLinkTransitive.
  intros ? ? ? Ha Hb.
  inverts Ha as Hah.
  inverts Hb as Hbh.
  constructor; auto.
  intros o ? Hevs.
  destruct (Hah o _ Hevs) as [iv  Hci]. clear Hah.
  destruct Hci as [Hevi Hci].
  destruct Hci as [Hyesi Hsubi].
  destruct (Hbh o _ Hevi) as [dv  Hcd]. clear Hbh.
  destruct Hcd as [Hevd Hcd].
  destruct Hcd as [Hyesd Hsubd].
  exists dv. split;[ assumption|].
  assert (forall (A B: Prop), A -> (A-> B) -> A/\B) as Hp by (intros; tauto).
  apply Hp;[|intros Hyessd; split]; clear Hp;
    [eauto using (@yesPreservedTransitive Src Inter Dst) | | ];[|].
- clear Hyesi Hyesd.
  intros n.
  apply proj1 in Hsubi.
  apply proj1 in Hsubd.
  specialize (Hsubi n).
  specialize (Hsubd n).
  destruct Hsubi;[| constructor ].
  inversion Hsubd. subst. clear Hsubd.
  constructor. eauto.
- intros Habs.
  apply proj2 in Hsubi.
  apply proj2 in Hsubd.
  intros ? Hgsv.
  specialize (Hsubi Habs svArg Hgsv).
  unfold yesPreserved in Hyesi.
  specialize (Hyesi Abs).
  rewrite Habs in Hyesi.
  simpl in Hyesi.
  specialize (Hsubd Hyesi).
  inverts Hsubi as Hsub Heq.
  unfold goodPreserving in *.
  eapply Hgpsi with (o:=o) in Hgsv.
  unfold composeTranslation, translate in *.
  destruct (t1 o svArg) as [| ivArg];[inverts Heq|].
  simpl in *. inverts Heq.
  specialize (Hsubd ivArg Hgsv).
  inverts Hsubd as Hsubd Heq.
  destruct (t2 o ivArg) as [|dvArg ];[inverts Heq|].
  simpl in *. inverts Heq.
  constructor. eauto.
Qed.

Section obsLeN.
Variable n:nat.
Notation "s ⊑ t" := (compObsLeLinkN _ _  n s t) (at level 65).

(** same as as [compObsLeLinkTransitive] above *)
Lemma compObsLeLinkNTransitive
      {Hgpsi : goodPreserving Src Inter}
      {Hgpid : goodPreserving Inter Dst}:
   forall   (s : Src) (i : Inter) (d : Dst),
  s ⊑ i
  -> i ⊑ d
  -> s ⊑ d.
Proof.
  induction n as [| m Hind];[ constructor |].
  intros ? ? ? Ha Hb.
  clear n. rename m into n.
  inverts Ha as Hah.
  inverts Hb as Hbh.
  constructor; auto.
  intros o ? Hevs.
  destruct (Hah o _ Hevs) as [iv  Hci]. clear Hah.
  destruct Hci as [Hevi Hci].
  destruct Hci as [Hyesi Hsubi].
  destruct (Hbh o _ Hevi) as [dv  Hcd]. clear Hbh.
  destruct Hcd as [Hevd Hcd].
  destruct Hcd as [Hyesd Hsubd].
  exists dv. split;[ assumption|].
  assert (forall (A B: Prop), A -> (A-> B) -> A/\B) as Hp by (intros; tauto).
  apply Hp;[|intros Hyessd; split]; clear Hp;
    [eauto using (@yesPreservedTransitive Src Inter Dst) | | ];[|].
- clear Hyesi Hyesd.
  intros m.
  apply proj1 in Hsubi.
  apply proj1 in Hsubd.
  specialize (Hsubi m).
  specialize (Hsubd m).
  destruct Hsubi;[| constructor ].
  inversion Hsubd. subst. clear Hsubd.
  constructor. eauto.
- intros Habs.
  apply proj2 in Hsubi.
  apply proj2 in Hsubd.
  intros ? Hgsv.
  specialize (Hsubi Habs svArg Hgsv).
  unfold yesPreserved in Hyesi.
  specialize (Hyesi Abs).
  rewrite Habs in Hyesi.
  simpl in Hyesi.
  specialize (Hsubd Hyesi).
  inverts Hsubi as Hsub Heq.
  unfold goodPreserving in *.
  eapply Hgpsi with (o:=o) in Hgsv.
  unfold composeTranslation, translate in *.
  destruct (t1 o svArg) as [| ivArg];[inverts Heq|].
  simpl in *. inverts Heq.
  specialize (Hsubd ivArg Hgsv).
  inverts Hsubd as Hsubd Heq.
  destruct (t2 o ivArg) as [|dvArg ];[inverts Heq|].
  simpl in *. inverts Heq.
  constructor. eauto.
Qed.

End obsLeN.
Global Instance composeCerticoqLinkableTranslationCorrect
(* we don't need a translation for the value type, although typically Src=SrcValue*)
  {Ht1: CerticoqLinkableTranslationCorrect Ls Li}
  {Ht2: CerticoqLinkableTranslationCorrect Li Ld}
    : CerticoqLinkableTranslationCorrect Ls Ld.
Proof.
  destruct Ht1, Ht2.
  constructor; [eapply composePreservesGood; eauto; fail |].
  intros o ? Hgoods.
  specialize (obsePresLink0 o _ Hgoods).
  inverts obsePresLink0 as Hle Heq.
  unfold goodPreserving in *.
  eapply certiGoodPresLink0 with (o:=o) in Hgoods.
  unfold composeTranslation, translate in *.
  destruct (t1 o s); compute in Hgoods; try contradiction.
  compute in Heq. inverts Heq.
  specialize (obsePresLink1 o _ Hgoods).
  inverts obsePresLink1 as Hlei Heqi.
  eapply certiGoodPresLink1 with (o:=o) in Hgoods.
  unfold composeTranslation, translate in *. simpl.
  destruct (t2 o i); compute in Hgoods; try contradiction.
  simpl.
  constructor.
  inverts Heqi.
  eapply compObsLeLinkTransitive; eauto.
  Unshelve. eauto. eauto.
Qed.

(* Outside this section, this definition should not depend at all on Src and Dst.*)
Definition leObsId : Inter -> Inter -> Prop :=  ((@compObsLeLink Inter Inter _ _ _ _ _ _ _ (fun o x => Ret x) _ _ )).

Definition eqObsId (a b : Inter) := leObsId a b /\ leObsId b a.

Lemma sameValuesImpliesLeObsId a b: sameValues a b -> leObsId a b.
Proof using.
  revert a b. cofix sameValuesImpliesLeObsId.
  intros ? ? Hs. constructor. intros o sv Hsv.
  specialize (proj1 (Hs _) Hsv). intros Hsvb.
  exists sv. dands; auto; try reflexivity.
- intros. apply liftLeRimpl with (R1:= sameValues); auto.
  apply liftLeRefl. unfold Reflexive, sameValues. reflexivity.
- intros. simpl. constructor. apply sameValuesImpliesLeObsId.
  unfold Reflexive, sameValues. reflexivity.
Qed.

Lemma sameValuesImpliesEqObsId a b: sameValues a b -> eqObsId a b.
Proof using Dst H4 H5 H6 H7 H8 Inter Src t1 t2.
  intros Hs. split; apply sameValuesImpliesLeObsId; auto.
  unfold Reflexive, sameValues in *. firstorder.
Qed.

Local Instance compObsLeLinkRespectsEval:
  Proper (eq ==> bigStepEval  ==> Basics.impl) (@compObsLeLink Src Inter _ _ _ _ _ _ _ _ _ _ ).
Proof using.
  intros s1 s2 Heqs d1 d2 Hsvd Hs1. subst.
  constructor.
  intros ? Heval.
  (* need that the second arg of bigStepeval is terminal *)
Abort.

End ComposeLink.

Arguments eqObsId {Inter} {H4} {H5} {H6} {H7} {H8}.
Arguments leObsId {Inter} {H4} {H5} {H6} {H7} {H8}.

Section LinkObsProper.
Context {Src Dst : Type}
        `{Ls: CerticoqLinkableLanguage Src}
        `{Ld: CerticoqLinkableLanguage Dst}.
Lemma compObsLeLink_proper_Feq t1 t2:
  (forall o s, t1 o s =  t2 o s) -> forall a b,
  (@compObsLeLink Src Dst _ _ _ _ _ _ _ t1 _ _ ) a b
  -> (@compObsLeLink Src Dst _ _ _ _ _ _ _ t2 _ _ ) a b.
Proof using.
  intros feq.
  cofix compObsLeLink_proper_Feq.
  intros ? ? Hl.
  constructor. invertsn Hl.
  intros o sv Hev. specialize (Hl o sv Hev). exrepnd.
  exists dv. dands; eauto using  liftLeRimpl;[].
  intros Hq sva Hga. specialize (Hl0 Hq sva Hga). unfold translate in *.
  rewrite <- feq. simpl in *.
  eauto using liftLeRimpl.
Qed.

(* proof same as above *)
Lemma compObsLeLinkN_proper_Feq t1 t2:
  (forall o s, t1 o s =  t2 o s) -> forall n a b,
  (@compObsLeLinkN Src Dst _ _ _ _ _ _ _ t1  _ _ n) a b
  -> (@compObsLeLinkN Src Dst _ _ _ _ _ _ _ t2  _ _ n) a b.
Proof using.
  intros feq n.  induction n;[ constructor |].
  intros ? ? Hl.
  constructor. invertsn Hl.
  intros o sv Hev. specialize (Hl o sv Hev). exrepnd.
  exists dv. dands; eauto using  liftLeRimpl;[].
  intros Hq sva Hga. specialize (Hl0 Hq sva Hga). unfold translate in *.
  rewrite <- feq. simpl in *.
  eauto using liftLeRimpl.
Qed.

Context {t : CerticoqTranslation Src Dst}
        {tg: goodPreserving Src Dst}.

Lemma compObsLeLinkRespectsLe:
  Proper ((Basics.flip leObsId) ==> leObsId ==> Basics.impl) (@compObsLeLink Src Dst _ _ _ _ _ _ _ _ _ _  ).
Proof using tg.
  intros l1 l2 Heql r1 r2 Heqr Hc.
  unfold leObsId, Basics.flip in *.
  eapply compObsLeLinkTransitive with (t1:= fun o x => Ret x); eauto;
    [apply goodPreservingId| ].
  eapply compObsLeLinkTransitive with (t2:= fun o x => Ret x) in Hc; eauto; try assumption;
    [|apply goodPreservingId];[].
  eapply compObsLeLink_proper_Feq;[| exact Hc].
  intros o s. unfold composeTranslation, translate.
  destruct (t o s); reflexivity.
Qed.

Lemma compObsLeLinkNRespectsLe n:
  Proper ((Basics.flip leObsId) ==> leObsId ==> Basics.impl) (@compObsLeLinkN  Src Dst _ _ _ _ _ _ _ _ _ _ n ).
Proof using tg.
  intros l1 l2 Heql r1 r2 Heqr Hc.
  unfold leObsId, Basics.flip in *.
  apply fromCoInd with (m:=n)in Heql.
  apply fromCoInd with (m:=n)in Heqr.
  eapply compObsLeLinkNTransitive with (t1:= fun s x => Ret x); eauto;
    [apply goodPreservingId|].
  eapply compObsLeLinkNTransitive with (t2:= fun s x => Ret x) in Hc; eauto; try assumption;
    [|apply goodPreservingId];[].
  eapply compObsLeLinkN_proper_Feq;[| exact Hc].
  intros o s. unfold composeTranslation, translate. destruct (t o s); reflexivity.
Qed.

Global Instance compObsLeLinkRespectsEqObs:
  Proper (eqObsId ==> eqObsId ==> iff) (@compObsLeLink Src Dst _ _ _ _ _ _ _ _ _ _  ).
Proof using tg.
  intros  ? ? Hleq ? ? Hreq. unfold eqObsId in *. repnd.
  split; apply compObsLeLinkRespectsLe; auto.
Qed.

Global Instance compObsLeLinkNRespectsEqObs n :
  Proper (eqObsId ==> eqObsId ==> iff) (@compObsLeLinkN Src Dst _ _ _ _ _ _ _ _ _ _ n).
Proof using tg.
  intros  ? ? Hleq ? ? Hreq. unfold eqObsId in *. repnd.
  split; apply compObsLeLinkNRespectsLe; auto.
Qed.

Global Instance  compObsLeLinkRespectsSameVal:
  Proper (sameValues ==> sameValues ==> iff) (@compObsLeLink Src Dst _ _ _ _ _ _ _ _ _ _  ).
Proof using H5 tg.
  intros ? ? ? ? ? ?.
  apply compObsLeLinkRespectsEqObs.
  eapply sameValuesImpliesEqObsId; try eassumption.
  exact (fun o x => Ret x).
  eapply sameValuesImpliesEqObsId; try eassumption.
  exact (fun o x => Ret x).
Qed.

Global Instance  compObsLeLinkNRespectsSameVal n:
  Proper (sameValues ==> sameValues ==> iff) (@compObsLeLinkN Src Dst _ _ _ _ _ _ _ _ _ _ n).
Proof using H5 tg.
  intros ? ? ? ? ? ?.
  apply compObsLeLinkNRespectsEqObs; eapply sameValuesImpliesEqObsId; try eassumption;
  exact (fun o x => Ret x).
Qed.

End LinkObsProper.

Section EqObsEquiv.
Context {Src Dst : Type}
        `{Ls: CerticoqLinkableLanguage Src}.

Global Instance compObsLeLinkSymm:
  Symmetric eqObsId.
Proof using.
  intros x y. unfold eqObsId. tauto.
Qed.

Global Instance sameValuesEquiv:
  Equivalence sameValues.
Proof using.
  constructor; unfold sameValues;
    intros x; firstorder.
Qed.

Global Instance compObsLeLinkRefl:
  Reflexive leObsId.
Proof using.
  intros x. apply sameValuesImpliesLeObsId. reflexivity.
Qed.

Global Instance compObsEqLinkRefl:
  Reflexive eqObsId.
Proof using.
  intros x. split; reflexivity.
Qed.

Global Instance compObsLeLinkEquiv:
  Equivalence eqObsId.
Proof using.
  constructor; eauto with typeclass_instances.
  intros ? ? ? H1eq  H2eq. unfold eqObsId, leObsId.
  split.
- eapply compObsLeLinkRespectsEqObs;[apply compObsEqLinkRefl| symmetry; eauto
                                       | unfold eqObsId in *; tauto].
- eapply compObsLeLinkRespectsEqObs; [apply compObsEqLinkRefl|  eauto
                                      | unfold eqObsId in *; tauto].
Unshelve.
  apply goodPreservingId.
  apply goodPreservingId.
Qed.

End EqObsEquiv.

Section LinkingIllustration.
Context {Src Dst : Type}
        `{Ls: CerticoqLinkableLanguage Src}
        `{Ld: CerticoqLinkableLanguage Dst}
        {comp1 : CerticoqTranslation Src Dst}
        {Ht1: CerticoqLinkableTranslationCorrect Ls Ld}.

(** Suppose [f] computes to a function (lambda) [fv] in the [Src] language *)
Variable (o:Opt).
Variable f:Src.
Variable fv:Src.
Hypothesis fcomputes: f ⇓ fv.
Hypothesis flam : questionHead Abs fv = true. (** [fv] may say yes to other questions as well *)

(** [f] compiles to [fd] *)
Variable fd:Dst.
Hypothesis compilef : translate Src Dst o f = Ret fd.

(** [fd] computes to [fdv] *)
Variable fdv:Dst.
Hypothesis compilefd : fd ⇓ fdv.

(** Now consider an argument [t] to [f] in Src. *)
Variable t:Src.

Notation "s ⊑ t" := (compObsLeLink _ _ s t) (at level 65).

(** Suppose we SEPARATELY [t] compile by the SAME compiler it to get [td] *)
Variable td:Dst.
Section SameCompiler.
Hypothesis compilet : translate Src Dst o t = Ret td.

(** The destination language has a notion of application. Consider the destination term: *)
Let fdtd := mkApp fdv td.

(** We would like [fdtd] be be observationally equal to [mkApp fv t], which is an easy
corrollary of the linkable correctness property: *)
Corollary fdtdCorrect {dd : deterministicBigStep Dst}
  : goodTerm f -> goodTerm t -> mkApp fv t  ⊑ mkApp fdv td.
Proof.
  intros Hgf Hgt.
  destruct Ht1.
  specialize (obsePresLink0 o f Hgf).
  rewrite compilef in obsePresLink0. simpl in *.
  invertsn obsePresLink0.
  invertsn obsePresLink0.
  specialize (obsePresLink0 o fv fcomputes).
  exrepnd. clear obsePresLink2 obsePresLink3.
  unfold deterministicBigStep in dd.
  apply dd with (v2:= fdv) in obsePresLink0;[ subst | assumption].
  specialize (obsePresLink1 flam t Hgt).
  rewrite compilet in obsePresLink1. simpl in obsePresLink1.
  invertsn obsePresLink1. assumption.
Qed.
End SameCompiler.

Definition appArgCongr : Prop :=
  forall (ff tt1 tt2: Dst),
    (* consider adding this:  goodTerm ff -> , which will need ⇓ to be goodpreserving*)
     goodTerm tt1
    -> goodTerm tt2
    -> leObsId tt1 tt2
    -> leObsId (mkApp ff tt1) (mkApp ff tt2).

Section ManualTargetArgTargetRel.
(** Now suppose, we use DIFFERENT compiler to compile [td]. First, we
list the needed properties for the other compiler [comp2] *)

Hypothesis mkAppCongrLe : appArgCongr.

Lemma mkAppCongr : forall (ff tt1 tt2: Dst),
    (* consider adding this:  goodTerm ff -> , which will need ⇓ to be goodpreserving*)
     goodTerm tt1
    -> goodTerm tt2
    -> eqObsId tt1 tt2
    -> eqObsId (mkApp ff tt1) (mkApp ff tt2).
Proof using mkAppCongrLe.
  intros ff ? ? H1g H2g ?.
  specialize (mkAppCongrLe ff).
  unfold eqObsId in *. repnd.
  eauto.
Qed.

Instance mkAppRW : Proper (eq ==> eqObsId ==> eqObsId) (@mkApp Dst _).
Proof using.
  intros ? ? ? ? ? ?. subst.
  apply mkAppCongr.
  (* need goodTerm *)
Abort.

Hypothesis compilet :  (@translate Src Dst comp1 o t) = Ret td.
(** Suppose that instead of td, we wish to use another term td', which we produced manually
or by magic. We also proved that it is a good term and is greater than td *)
Variable td':Dst.
Hypothesis td'good: goodTerm td'.
Hypothesis td'Le : leObsId td td'.

(** Again, consider the application term in the destination language, where the function
  and the arg are compiled by different compilers *)
Let fdtd := mkApp fdv td'.

(** Again, we would like [fdtd] be be observationally equal to [mkApp fv t], which is a
corrollary of the linkable correctness property: *)
Corollary fdtdCorrectDiff {dd : deterministicBigStep Dst}
  : goodTerm f -> goodTerm t -> mkApp fv t  ⊑ mkApp fdv td'.
Proof.
  intros Hgf Hgt.
  destruct Ht1.
  specialize (obsePresLink0 o f Hgf).
  rewrite compilef in obsePresLink0. simpl in *.
  invertsn obsePresLink0.
  invertsn obsePresLink0.
  specialize (obsePresLink0 o fv fcomputes).
  exrepnd. clear obsePresLink2 obsePresLink3.
  unfold deterministicBigStep in dd.
  apply dd with (v2:= fdv) in obsePresLink0;[ subst | assumption].
  specialize (obsePresLink1 flam t Hgt).
  pose proof certiGoodPresLink0 as Hgpb.
  specialize (certiGoodPresLink0 t o Hgt).
  rewrite compilet in *. simpl in *.
  invertsna obsePresLink1 Hinvf.
  apply (mkAppCongrLe fdv) in td'Le; eauto;[].
  eapply compObsLeLinkRespectsLe; [reflexivity | apply td'Le |].
  exact Hinvf.
  Unshelve. assumption.
Qed.

End ManualTargetArgTargetRel.

(**
Similar to the above section, except that the manually produced target argument [td']
has to be proved to be related to the corresponding [Src] term [t] instead of the
compilation result [td]. This was requested by Andrew Appel.
*)
Section ManualTargetArgSrcRel.

  (** In this section, this is all we know about [td]. We dont anymore have the hypothesis
  that [td] was obtained from compiling [t] *)
  Hypothesis argRelated :  t ⊑ td.
  Hypothesis tdGood :  goodTerm td.

  Hypothesis mkAppCongrLe : appArgCongr.

Corollary fdtdCorrectDiff {dd : deterministicBigStep Dst}
  : goodTerm f -> goodTerm t -> mkApp fv t  ⊑ mkApp fdv td.
Proof.
  intros Hgf Hgt.
  destruct Ht1.
  specialize (obsePresLink0 o f Hgf).
  rewrite compilef in obsePresLink0. simpl in *.
  invertsn obsePresLink0.
  invertsn obsePresLink0.
  specialize (obsePresLink0 o fv fcomputes).
  exrepnd. clear obsePresLink2 obsePresLink3.
  unfold deterministicBigStep in dd.
  apply dd with (v2:= fdv) in obsePresLink0;[ subst | assumption].
  specialize (obsePresLink1 flam t Hgt).
  pose proof certiGoodPresLink0 as Hgpb.
  specialize (certiGoodPresLink0 t o Hgt).
  destruct Ht1.
  specialize (obsePresLink0 o t Hgt).
  destruct (@translate Src Dst comp1 o t) as [| tdc]; try contradiction.
  simpl in *.
  invertsna obsePresLink1 Hinvf.
  invertsna obsePresLink0 Hinvt.
  (**
   [Hinvf] is what we get from using the correctness property of the compiler, instantiated
   for the function [f]. We have to somehow replace [tdc] by [td] there.
   Recall that [tdc] is the result of compiling [td].

   The only way to use [mkAppCongr], which is congruence in [Dst],
   is to show that [tdc ⊑ td].
   We may, however, choose to have a different assumption instead of [mkAppCongr].
 *)

  eapply compObsLeLinkRespectsLe; [reflexivity | apply (mkAppCongrLe _ tdc _) | ]; auto.

(**
This goal seems unprovable. We have both [t ⊑ tdc] and [t ⊑ td].
That says nothing about the ordering between [tdc] and [td].
*)

Abort.

End ManualTargetArgSrcRel.

End LinkingIllustration.


From ITree Require Import ITree.
From Paco Require Import paco.
From compcert Require Import Integers.

Require Import sflib.

Require Import StdlibExt.
Require Import IntegersExt.
Require Import SyncSysModel.

Require Import Executable.
Require Import PALSSystem.

Require Import ConvC2ITree.

Require Import AcStSystem.
Require Import SpecConsole SpecController SpecDevice.
Require Import AcStRefinement.

From Coq Require Extraction ExtrOcamlBasic ExtrOcamlString.

Require Import ZArith List Lia.

Definition max_num_tasks: nat := 16.
Definition msg_size_k: Z := 1.
Definition msg_size: Z := 8.

Definition resize_bytes: bytes -> bytes? :=
  (fun bs => Some (RTSysEnv.resize_bytes 8 bs)).

Definition oapp_con: AppMod.t ? :=
  cprog2app console.prog max_num_tasks msg_size_k msg_size.
Definition oapp_ctrl1: AppMod.t ? :=
  cprog2app (ctrl.prog 1) max_num_tasks msg_size_k msg_size.
Definition oapp_ctrl2: AppMod.t ? :=
  cprog2app (ctrl.prog 2) max_num_tasks msg_size_k msg_size.
Definition oapp_dev1: AppMod.t ? :=
  cprog2app (dev.prog 3) max_num_tasks msg_size_k msg_size.
Definition oapp_dev2: AppMod.t ? :=
  cprog2app (dev.prog 4) max_num_tasks msg_size_k msg_size.
Definition oapp_dev3: AppMod.t ? :=
  cprog2app (dev.prog 5) max_num_tasks msg_size_k msg_size.

Definition app_system : ExecutableSpec.t :=
  let apps :=
      match deopt_list [oapp_con; oapp_ctrl1; oapp_ctrl2; oapp_dev1; oapp_dev2; oapp_dev3] with
      | None => []
      | Some apps => apps
      end
  in
  ExecutableSpec.mk _ _ ActiveStandby.period
                    apps [[1; 2]]
                    resize_bytes.

Definition app_system_itree: Z -> option Z -> itree _ unit :=
  @ExecutableSpec.sys_itree _ _ app_system.

Cd "./extr/active_standby_c2itree".
Extraction "AppSystem.ml" app_system app_system_itree.
Cd "../..".


Require Import Coq.Sets.Ensembles Bedrock.Platform.AutoSep Bedrock.Platform.Malloc.

Section adt.
  Variable P : list W -> W -> HProp.
  Variable res : nat.

  Definition newS := SPEC("extra_stack", "len") reserving res
    PRE[V] [| V "len" >= $2 |] * mallocHeap 0
    POST[R] Ex ls, P ls R * [| length ls = wordToNat (V "len") |] * mallocHeap 0.

  Definition deleteS := SPEC("extra_stack", "self", "len") reserving res
    Al ls,
    PRE[V] P ls (V "self") * [| length ls = wordToNat (V "len") |] * mallocHeap 0
    POST[R] [| R = $0 |] * mallocHeap 0.

  Definition copyS := SPEC("extra_stack", "self", "len") reserving res
    Al ls,
    PRE[V] P ls (V "self") * [| length ls = wordToNat (V "len") |] * [| $2 <= V "len" |] * mallocHeap 0
    POST[R] P ls (V "self") * P ls R * mallocHeap 0.

  Definition getS := SPEC("extra_stack", "self", "pos") reserving res
    Al ls,
    PRE[V] P ls (V "self") * [| V "pos" < natToW (length ls) |] * mallocHeap 0
    POST[R] [| R = Array.sel ls (V "pos") |] * P ls (V "self") * mallocHeap 0.

  Definition setS := SPEC("extra_stack", "self", "pos", "val") reserving res
    Al ls,
    PRE[V] P ls (V "self") * [| V "pos" < natToW (length ls) |] * mallocHeap 0
    POST[R] [| R = $0 |] * P (Array.upd ls (V "pos") (V "val")) (V "self") * mallocHeap 0.
End adt.


(* Default settings (from HsToCoq.Coq.Preamble) *)

(* Archivo que contiene la extension de las definiciones para eliminar elementos de un arbol rojinegro.

En varias funciones se agregaron casos extras para volver a las funciones totales, se cree que en las demostraciones esto
va causar ruido y se tengan que eliminar esos casos haciendo uso de admits, ya que aunque por construccion NO se puede caer
en esos casos, Coq pide que se demuestren, es posible que algo asi pase en el script de insercion con los dos casos que no se han podido demostrar.
 *)

(*
Se entiende que esta es una estrucutura un tanto compleja y que la herramienta todavia esta en su infancia y no genere
codigo 100% proof ready *)
Generalizable All Variables.

Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.
Require Import ARNDefiniciones.

Print ARNDefiniciones.
(* Converted imports: *)

Require GHC.Base.
Require GHC.Err.
Require GHC.Types.
Import GHC.Base.Notations.

(* Pinta de rojo la raiz de un arbol
 *)
Definition red {a} `{GHC.Base.Ord a}: RB a -> RB a :=
  fun arg_0__ =>
    match arg_0__ with
    | T _ a x b => T R a x b
    | _ => E
    end.

Definition balance {a} `{GHC.Base.Ord a}
   : RB a -> a -> RB a -> RB a :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | T R a x b, y, T R c z d => T R (T B a x b) y (T B c z d)
    | T R (T R a x b) y c, z, d => T R (T B a x b) y (T B c z d)
    | T R a x (T R b y c), z, d => T R (T B a x b) y (T B c z d)
    | a, x, T R b y (T R c z d) => T R (T B a x b) y (T B c z d)
    | a, x, T R (T R b y c) z d => T R (T B a x b) y (T B c z d)
    | a, x, b => T B a x b
    end.

Definition balleft {a} `{GHC.Base.Ord a}
   : RB a -> a -> RB a -> RB a :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | T R a x b, y, c => T R (T B a x b) y c
    | bl, x, T B a y b => balance bl x (T R a y b)
    | bl, x, T R (T B a y b) z c => T R (T B bl x a) y (balance b z (red c))
    | ti, x, tr => T R ti x tr (*caso extra para hacerlo total...*)
    end.

Definition balright {a} `{GHC.Base.Ord a}
   : RB a -> a -> RB a -> RB a :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | a, x, T R b y c => T R a x (T B b y c)
    | T B a x b, y, bl => balance (T R a x b) y bl
    | T R a x (T B b y c), z, bl => T R (balance (red a) x b) y (T B c z bl)
    | ti, x, tr => T R ti x tr (*caso extra para hacerlo total...*)
    end.

(* Fixpoint appaux {a} `{GHC.Base.Ord a} (a: RB a) (b: RB a) :=
match a, b with  *)

(* maybe separating this function making an auxiliar fn(?)
 *)
Definition app {a} `{GHC.Base.Ord a}: RB a -> RB a -> RB a :=
  fix app arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | E, x => x
           | x, E => x
           | T R a x b, T R c y d =>
               match app b c with
               | T R b' z c' => T R (T R a x b') z (T R c' y d)
               | bc => T R a x (T R bc y d)
               end
           | T B a x b, T B c y d =>
               match app b c with
               | T R b' z c' => T R (T B a x b') z (T B c' y d)
               | bc => balleft a x (T B bc y d)
               end
           | a, T R b x c => T R (app a b) x c
           | T R a x b, c => T R a x (app b c)
           end.

Definition delete : a -> RB a -> RB a :=
  fun x t =>
    let del :=
      fix del arg_0__
            := match arg_0__ with
               | E => E
               | T _ a y b =>
                   if x GHC.Base.< y : bool then delfromLeft a y b else
                   if x GHC.Base.> y : bool then delfromRight a y b else
                   app a b
               end with delfromLeft arg_5__ arg_6__ arg_7__
                          := match arg_5__, arg_6__, arg_7__ with
                             | (T B _ _ _ as a), y, b => balleft (del a) y b
                             | a, y, b => T R (del a) y b
                             end with delfromRight arg_11__ arg_12__ arg_13__
                                        := match arg_11__, arg_12__, arg_13__ with
                                           | a, y, (T B _ _ _ as b) => balright a y (del b)
                                           | a, y, b => T R a y (del b)
                                           end for del in
    let delfromLeft :=
      fix del arg_0__
            := match arg_0__ with
               | E => E
               | T _ a y b =>
                   if x GHC.Base.< y : bool then delfromLeft a y b else
                   if x GHC.Base.> y : bool then delfromRight a y b else
                   app a b
               end with delfromLeft arg_5__ arg_6__ arg_7__
                          := match arg_5__, arg_6__, arg_7__ with
                             | (T B _ _ _ as a), y, b => balleft (del a) y b
                             | a, y, b => T R (del a) y b
                             end with delfromRight arg_11__ arg_12__ arg_13__
                                        := match arg_11__, arg_12__, arg_13__ with
                                           | a, y, (T B _ _ _ as b) => balright a y (del b)
                                           | a, y, b => T R a y (del b)
                                           end for delfromLeft in
    let delfromRight :=
      fix del arg_0__
            := match arg_0__ with
               | E => E
               | T _ a y b =>
                   if x GHC.Base.< y : bool then delfromLeft a y b else
                   if x GHC.Base.> y : bool then delfromRight a y b else
                   app a b
               end with delfromLeft arg_5__ arg_6__ arg_7__
                          := match arg_5__, arg_6__, arg_7__ with
                             | (T B _ _ _ as a), y, b => balleft (del a) y b
                             | a, y, b => T R (del a) y b
                             end with delfromRight arg_11__ arg_12__ arg_13__
                                        := match arg_11__, arg_12__, arg_13__ with
                                           | a, y, (T B _ _ _ as b) => balright a y (del b)
                                           | a, y, b => T R a y (del b)
                                           end for delfromRight in
    match del t with
    | T _ a y b => T B a y b
    | _ => E
    end.

(* External variables:
     bool GHC.Base.op_zg__ GHC.Base.op_zl__ GHC.Err.Build_Default
     GHC.Err.Default GHC.Err.error GHC.Err.patternFailure GHC.Types.Bool
     GHC.Types.False a GHC.Types.True
*)


From Coq Require Import FinFun Bool List Streams Logic.Epsilon Arith.Compare_dec Lia.
Import ListNotations.

From CasperCBC
  Require Import
    Lib.Preamble Lib.ListExtras Lib.ListSetExtras Lib.RealsExtras
    VLSM.Common VLSM.Composition VLSM.ProjectionTraces.

(** * VLSM Decisions on Consensus Values *)

(* Need to add consensus values (and decision functions) to VLSM definitions? *)
Class consensus_values :=
  { C : Type;
    about_C : exists (c1 c2 : C), c1 <> c2;
  }.

Definition decision {message} (T : VLSM_type message) {CV : consensus_values}
  := @state _ T -> option C.

Definition vdecision {message} (V : VLSM message) {CV : consensus_values}
  := decision (type V).

Section CommuteSingleton.

  Context
    {message : Type}
    {CV : consensus_values}
    (V : VLSM message).

  (* 3.2.1 Decision finality *)

  (* Definition of finality per document. *)
  Definition final_original : vdecision V -> Prop :=
    fun (D : vdecision V) => forall (tr : protocol_trace V),
        forall (n1 n2 : nat) (s1 s2 : state) (c1 c2 : C),
          (trace_nth (proj1_sig tr) n1 = Some s1) ->
          (trace_nth (proj1_sig tr) n2 = Some s2) ->
          (D s1 = (Some c1)) ->
          (D s2 = (Some c2)) ->
          c1 = c2.

  (* Definition of finality using in_futures, which plays better with the estimator property *)
  Definition final: vdecision V -> Prop :=
  fun (D : vdecision V) => forall (s1 s2 : vstate V) (c1 c2 : C),
        in_futures V s1 s2 ->
        (D s1 = (Some c1)) ->
        (D s2 = (Some c2)) ->
        c1 = c2.

  (* 3.3.1 Initial protocol state bivalence *)
  Definition bivalent : vdecision V -> Prop :=
    fun (D : vdecision V) =>
      (* All initial states decide on None *)
      (forall (s0 : state),
        vinitial_state_prop V s0 ->
        D s0 = None) /\
      (* Every protocol trace (already beginning from an initial state) contains a state deciding on each consensus value *)
      (forall (c : C) ,
          exists (tr : protocol_trace V) (s : state) (n : nat),
            (trace_nth (proj1_sig tr) n) = Some s /\ D s = (Some c)).

  (* 3.3.2 No stuck states *)

  Definition stuck_free : vdecision V -> Prop :=
    fun (D : vdecision V) =>
      (forall (s : state),
          exists (tr : protocol_trace V)
                 (decided_state : state)
                 (n_s n_decided : nat)
                 (c : C),
         trace_nth (proj1_sig tr) n_s = Some s /\
         trace_nth (proj1_sig tr) n_decided = Some decided_state /\
         n_decided >= n_s /\
         D decided_state = Some c).

  (* 3.3.3 Protocol definition symmetry *)
  (* How do we formalize this property set-theoretically? *)

  Definition behavior : vdecision V -> Prop :=
    fun _ => True.

  Definition symmetric : vdecision V -> Prop :=
    fun (D : vdecision V) =>
    exists (f : vdecision V -> vdecision V),
      behavior D = behavior (f D).

End CommuteSingleton.

Section CommuteIndexed.

  Context
    {CV : consensus_values}
    {message : Type}
    {index : Type}
    {Heqd : EqDecision index}
    (IM : index -> VLSM message)
    {Hi : Inhabited index}
    (constraint : composite_label IM -> composite_state IM * option message -> Prop)
    (X := composite_vlsm IM constraint)
    (ID : forall i : index, vdecision (IM i)).

  (* ** Decision consistency

  First, let us introduce a definition of consistency which
  looks at states as belonging to a trace.
  *)

  Definition consistent_original :=
      forall (tr : protocol_trace X),
      forall (n1 n2 : nat),
      forall (j k : index),
      forall (s1 s2 : vstate X),
      forall (c1 c2 : C),
      j <> k ->
      trace_nth (proj1_sig tr) n1 = (Some s1) ->
      trace_nth (proj1_sig tr) n2 = (Some s2) ->
      (ID j) (s1 j) = (Some c1) ->
      (ID k) (s2 k) = (Some c2) ->
      c1 = c2.

  (**

  Now let us give an alternative definition based on [in_futures]:
  *)

  Definition consistent :=
      forall
        (s1 s2 : vstate X)
        (Hfuture : in_futures X s1 s2)
        (j k : index)
        (Hneq : j <> k)
        (c1 c2 : C)
        (HDecided1 : (ID j) (s1 j) = Some c1)
        (HDecided2 : (ID k) (s2 k) = Some c2)
        , c1 = c2.

  (**
  Next two results show that the two definitions above are equivalent.
  *)

  Lemma consistent_to_original
    (Hconsistent : consistent)
    : consistent_original.
  Proof.
    intros tr n1 n2 j k s1 s2 c1 c2 Hneq Hs1 Hs2 HD1 HD2.
    destruct (le_lt_dec n1 n2).
    - specialize (in_futures_witness_reverse X s1 s2 tr n1 n2 l Hs1 Hs2)
      ; intros Hfutures.
      specialize (Hconsistent s1 s2 Hfutures j k Hneq c1 c2 HD1 HD2).
      assumption.
    - assert (Hle : n2 <= n1) by lia.
      clear l.
      specialize (in_futures_witness_reverse X s2 s1 tr n2 n1 Hle Hs2 Hs1)
      ; intros Hfutures.
      assert (Hneq' : k <> j)
        by (intro Heq; elim Hneq; symmetry; assumption).
      specialize (Hconsistent s2 s1 Hfutures k j Hneq' c2 c1 HD2 HD1).
      symmetry.
      assumption.
    Qed.

  Lemma original_to_consistent
    (Horiginal : consistent_original)
    : consistent.
  Proof.
    unfold consistent; intros.
    specialize (in_futures_witness X s1 s2 Hfuture)
    ; intros [tr [n1 [n2 [Hle [Hs1 Hs2]]]]].
    specialize (Horiginal tr n1 n2 j k s1 s2 c1 c2 Hneq Hs1 Hs2 HDecided1 HDecided2).
    assumption.
  Qed.

  (** The following is an attempt to include finality in the definition of consistency by dropping the requirement
      that (j <> k). **)

  Definition final_and_consistent :=
      forall
        (s1 s2 : vstate X)
        (Hfuture : in_futures X s1 s2)
        (j k : index)
        (c1 c2 : C)
        (HDecided1 : (ID j) (s1 j) = Some c1)
        (HDecided2 : (ID k) (s2 k) = Some c2)
        , c1 = c2.

  Lemma final_and_consistent_implies_final
      (Hcons : final_and_consistent)
      (i : index)
      (Hfr : finite_projection_friendly IM constraint i)
      : final (composite_vlsm_constrained_projection IM constraint i) (ID i).
  Proof.
    intros s1 s2 c1 c2 Hfuturesi HD1 HD2.
    specialize (projection_friendly_in_futures IM constraint i Hfr s1 s2 Hfuturesi)
    ; intros [sX1 [sX2 [Hs1 [Hs2 HfuturesX]]]].
    subst.
    apply (Hcons sX1 sX2 HfuturesX i i c1 c2 HD1 HD2).
  Qed.

  Lemma final_and_consistent_implies_consistent
      (Hcons : final_and_consistent)
      : consistent.
  Proof.
    unfold consistent; intros.
    apply (Hcons s1 s2 Hfuture j k c1 c2 HDecided1 HDecided2).
  Qed.

  Definition live :=
    forall (tr : @Trace _ (type X)),
      complete_trace_prop X tr ->
      exists (s : vstate X) (n : nat) (i : index) (c : C),
        trace_nth tr n = Some s /\
        (ID i) (s i) = Some c.

End CommuteIndexed.

(* Section 5 *)

Section Estimators.

  (* Defining the estimator function as a relation *)
  Class Estimator state C :=
    { estimator : state -> C -> Prop
    ; estimator_total : forall s : state, exists c : C, estimator s c
    }.

  Context
    {CV : consensus_values}
    {message : Type}
    (X : VLSM message)
    (D : vdecision X)
    (E : Estimator (vstate X) C)
    (estimates := @estimator _ _ E)
    .

  Definition decision_estimator_property
    := forall
      (sigma : vstate X)
      (c : C)
      (HD : D sigma = Some c)
      (sigma' : vstate X)
      (Hreach : in_futures X sigma sigma')
      (c' : C)
      (Hc' : estimates sigma' c'),
      c' = c.

  Lemma estimator_only_has_decision
    (Hde : decision_estimator_property)
    (s : protocol_state X)
    (c c_other : C)
    (Hc  : D (proj1_sig s) = (Some c))
    (Hc_other : estimates (proj1_sig s) c_other)
    : c_other = c.
  Proof.
    intros.
    destruct s as [s Hs].
    apply Hde with (sigma := s) (sigma':= s); try assumption.
    apply in_futures_refl.
    assumption.
  Qed.

  Lemma estimator_surely_has_decision
    (Hde : decision_estimator_property)
    (s : protocol_state X)
    (c : C)
    (Hc  : D (proj1_sig s) = (Some c))
    : estimates (proj1_sig s) c.
   Proof.
    intros.
    assert(Hc_other : exists (c_other : C), (estimates (proj1_sig s) c_other)). {
      apply estimator_total.
    }
    destruct Hc_other as [c_other Hc_other].
    destruct s as [s Hs].
    assert (Heq : c_other = c). {
      apply Hde with (sigma := s) (sigma' := s); try assumption.
      apply in_futures_refl.
      assumption.
    }
    rewrite <- Heq.
    assumption.
   Qed.

  (* We use the following intermediate result,
     proven above (in two steps) via the estimator property:
     (1) If D(state) = Some c then Estimator(state) = {c}.

     We then fix s1 and s2, such that (in_futures s1 s2) and both are decided and note the following:
     (2) Estimator(s2) = {Decision(s2)}, by (1)
     (3) Estimator(s2) = {Decision(s1)}, by the estimator property.

     Thus Decision(s2) = Decision(s1).
   *)

  Theorem decision_estimator_finality
    : decision_estimator_property -> final X D.
  Proof.
    intros.
    unfold final.
    intros.
    specialize (in_futures_protocol_snd X s1 s2 H0); intro Hps2.
    apply estimator_only_has_decision with (s := (exist _ s2 Hps2)).
    assumption.
    assumption.
    unfold decision_estimator_property in H.
    assert(c2 = c1). {
      apply H with (sigma := s1) (sigma' := s2).
      assumption.
      assumption.
      apply (estimator_surely_has_decision H (exist _ s2 Hps2)).
      assumption.
    }
    rewrite <- H3.
    apply estimator_surely_has_decision.
    assumption.
    assumption.
   Qed.
End Estimators.

Section composite_estimators.

  Context
    {CV : consensus_values}
    {message : Type}
    {index : Type}
    {Heqd : EqDecision index}
    (IM : index -> VLSM message)
    {Hi : Inhabited index}
    (constraint : composite_label IM -> composite_state IM * option message -> Prop)
    (X := composite_vlsm IM constraint)
    (ID : forall i : index, vdecision (IM i))
    (IE : forall i : index, Estimator (vstate (IM i)) C).

  Definition composite_projection_decision_estimator_property
    (i : index)
    (Xi := composite_vlsm_constrained_projection IM constraint i)
    := decision_estimator_property Xi (ID i) (IE i).

End composite_estimators.


(** * Compiler Example *)
(** This example illustrates the use of path-dependent types of length
    greater than one which allows us to encode recursion between types in
    nested modules *)

Require Import ExampleTactics.
Require Import String.

Section CompilerExample.

Variables DottyCore Tpe Symbol : typ_label.
Variables dottyCore types typeRef symbols symbol symb tpe denotation srcPos : trm_label.

Notation TpeImpl := (μ(typ_rcd {denotation ⦂ Id})).
Notation SymbolImpl := (μ(typ_rcd {srcPos ⦂ Id})).

Hypothesis TS: types <> symbols.
Hypothesis ST: symb <> denotation.
Hypothesis TS': tpe <> srcPos.

Notation typesType tpe_lower tpe_upper :=
  (typ_rcd {Tpe >: tpe_lower <: tpe_upper} ∧
     typ_rcd {typeRef ⦂ ∀(super•symbols↓Symbol)
                         (super↓Tpe ∧ (typ_rcd {symb ⦂ ssuper•symbols↓Symbol}))}).
Notation symbolsType symb_lower symb_upper :=
  (typ_rcd {Symbol >: symb_lower <: symb_upper} ∧
   typ_rcd {symbol ⦂ ∀(super•types↓Tpe)
                      (super↓Symbol ∧ (typ_rcd {tpe ⦂ ssuper•types↓Tpe}))}).
Notation DottyCorePackage tpe_lower tpe_upper symb_lower symb_upper :=
  (typ_rcd {types ⦂ μ(typesType tpe_lower tpe_upper)} ∧
   typ_rcd {symbols ⦂ μ(symbolsType symb_lower symb_upper)}).

Notation DottyCoreAbstract := (DottyCorePackage ⊥ ⊤ ⊥ ⊤).
Notation DottyCoreTight := (DottyCorePackage TpeImpl TpeImpl SymbolImpl SymbolImpl).

Definition t := (trm_val
(ν(typ_rcd {DottyCore >: μ DottyCoreAbstract <: μ DottyCoreAbstract} ∧
   typ_rcd {dottyCore ⦂ Lazy (super ↓ DottyCore)})
  defs_nil Λ
  {DottyCore ⦂= μ DottyCoreAbstract} Λ
  {dottyCore :=
     lazy (let_trm (trm_val (ν(DottyCoreTight)
                              defs_nil Λ
                              {types :=
                                 defv (ν(typesType TpeImpl TpeImpl)
                                        defs_nil Λ
                                        {Tpe ⦂= TpeImpl} Λ
                                        {typeRef :=
                                           defv (λ(super•symbols↓Symbol)
                                                  (let_trm (trm_val (ν(typ_rcd {symb ⦂ ({{ super }}) } ∧
                                                                       typ_rcd {denotation ⦂ Id})
                                                                      defs_nil Λ
                                                                      {symb := defp super} Λ
                                                                      {denotation := defv id})))) }) } Λ
                              {symbols :=
                                 defv (ν(symbolsType SymbolImpl SymbolImpl)
                                        defs_nil Λ
                                        {Symbol ⦂= SymbolImpl} Λ
                                        {symbol :=
                                           defv (λ(super•types↓Tpe)
                                                  (let_trm (trm_val (ν(typ_rcd {tpe ⦂ {{ super }}} ∧
                                                                       typ_rcd {srcPos ⦂ Id})
                                                                      defs_nil Λ
                                                                      {tpe := defp super} Λ
                                                                      {srcPos := defv id}))))})})))})).

Notation T :=
  (μ(typ_rcd {DottyCore >: μ DottyCoreAbstract <: μ DottyCoreAbstract} ∧
     typ_rcd {dottyCore ⦂ Lazy (super ↓ DottyCore)})).

Lemma compiler_typecheck :
  empty ⊢ t : T.
Proof.
  fresh_constructor. repeat apply ty_defs_cons; crush.
  - Case "dottyCore"%string.
    constructor. fresh_constructor. crush.
    fresh_constructor.
    + fresh_constructor. crush.
      apply ty_defs_cons; crush.
      * SCase "types"%string.
        apply ty_defs_one. eapply ty_def_new; eauto.
        { econstructor. constructor*. simpl. auto. }
        crush. apply ty_defs_cons; crush.

        constructor. fresh_constructor. crush. fresh_constructor.
        *** remember_ctx G.
            fresh_constructor. crush.
            apply ty_defs_cons; crush.
            **** apply ty_defs_one.
                 econstructor.
                 eapply ty_sub.
                 ***** rewrite HeqG. constructor*.
                 ***** eapply subtyp_sel1. rewrite proj_rewrite.
                 constructor. apply ty_rcd_intro.
                 eapply ty_sub. apply ty_rec_elim. constructor.
                 eapply ty_sub. rewrite HeqG. constructor*. eauto.
                 crush.
            **** constructor. fresh_constructor. crush.
        *** match goal with
            | H: _ |- _ & ?y0 ~ ?T0' & ?y1 ~ ?T1' & ?y2 ~ ?T2' ⊢ _ : _ =>
              remember T0' as T0; remember T1' as T1; remember T2' as T2
            end.
            remember_ctx G.
            assert (binds y2 T2 G) as Hb%ty_var by rewrite* HeqG. crush.
            apply ty_and_intro.
            **** rewrite proj_rewrite. eapply ty_sub.
                 2: {
                   eapply subtyp_sel2. eapply ty_sub. apply ty_rec_elim. constructor.
                   assert (binds y0 T0 G) as Hb'%ty_var by rewrite* HeqG.
                   rewrite HeqT0 in Hb'. eapply ty_sub; eauto.
                   unfold open_typ_p. rewrite HeqT1. simpl. eauto.
                 }
                 apply ty_rec_intro. crush.
                 rewrite HeqT2 in Hb. apply ty_rec_elim in Hb.
                 eapply ty_sub. eauto. crush.
            **** assert (binds y0 T0 G) as Hb' by rewrite* HeqG.
                 rewrite HeqT0 in Hb'. apply ty_var in Hb'.
                 match goal with
                 | H: _ ⊢ tvar y0 : ?T0''' ∧ ?T0'' |- _ =>
                   remember T0'' as T0'; remember T0''' as T01
                 end.
                 rewrite HeqT2 in Hb.
                 apply ty_rec_elim in Hb. unfold open_typ_p in Hb.
                 simpl in *. rewrite HeqT1. rewrite proj_rewrite.
                 apply ty_rcd_intro.
                 eapply ty_sub.
                 2: {
                   eapply subtyp_sel2.
                   assert (G ⊢ tvar y0 : T0') as Hy0 by eauto.
                   rewrite HeqT0' in Hy0. apply ty_new_elim in Hy0.
                   apply ty_rec_elim in Hy0. unfold open_typ_p in Hy0. simpl in *.
                   eapply ty_sub. apply Hy0. crush.
                 }
                 eapply ty_sub. eapply ty_sngl. constructor. eapply ty_sub. apply Hb.
                 eauto. rewrite HeqG. constructor*. rewrite HeqT1.
                 eapply subtyp_sel1.
                 assert (G ⊢ tvar y0 : T0') as Hy0 by eauto.
                 rewrite HeqT0' in Hy0. apply ty_new_elim, ty_rec_elim in Hy0.
                 unfold open_typ_p in Hy0. simpl in *. eapply ty_sub.
                 apply Hy0. eauto.
      * eapply ty_def_new; eauto.
        { repeat econstructor. }
        crush. apply ty_defs_cons; crush.
        constructor. fresh_constructor. crush.
        fresh_constructor.
        *** remember_ctx G.
            fresh_constructor. crush.
            apply ty_defs_cons; crush.
            **** apply ty_defs_one.
                 econstructor.
                 eapply ty_sub.
                 ***** rewrite HeqG. constructor*.
                 ***** eapply subtyp_sel1. rewrite proj_rewrite.
                 constructor. apply ty_rcd_intro.
                 eapply ty_sub. apply ty_rec_elim. constructor.
                 eapply ty_sub. rewrite HeqG. constructor*. eauto. crush.
            **** constructor. fresh_constructor. crush.
        *** match goal with
            | H: _ |- _ & ?y0 ~ ?T0' & ?y1 ~ ?T1' & ?y2 ~ ?T2' ⊢ _ : _ =>
              remember T0' as T0; remember T1' as T1; remember T2' as T2
            end.
            remember_ctx G.
            assert (binds y2 T2 G) as Hb%ty_var by rewrite* HeqG. crush.
            apply ty_and_intro.
            **** rewrite proj_rewrite. eapply ty_sub.
                 2: {
                   eapply subtyp_sel2. eapply ty_sub. apply ty_rec_elim. constructor.
                   assert (binds y0 T0 G) as Hb'%ty_var by rewrite* HeqG.
                   rewrite HeqT0 in Hb'. eapply ty_sub; eauto. crush.
                 }
                 apply ty_rec_intro. crush.
                 rewrite HeqT2 in Hb. apply ty_rec_elim in Hb.
                 eapply ty_sub. eauto. crush.
            **** assert (binds y0 T0 G) as Hb' by rewrite* HeqG.
                 rewrite HeqT0 in Hb'. apply ty_var in Hb'.
                 match goal with
                 | H: _ ⊢ tvar y0 : ?T0''' ∧ ?T0'' |- _ =>
                   remember T0'' as T01; remember T0''' as T0'
                 end.
                 rewrite HeqT2 in Hb.
                 apply ty_rec_elim in Hb. unfold open_typ_p in Hb.
                 simpl in *. rewrite HeqT1. rewrite proj_rewrite.
                 apply ty_rcd_intro.
                 eapply ty_sub.
                 2: {
                   eapply subtyp_sel2.
                   assert (G ⊢ tvar y0 : T0') as Hy0 by eauto.
                   rewrite HeqT0' in Hy0. apply ty_new_elim in Hy0.
                   apply ty_rec_elim in Hy0. unfold open_typ_p in Hy0. simpl in *.
                   eapply ty_sub. apply Hy0. case_if. eauto.
                 }
                 eapply ty_sub. eapply ty_sngl. constructor. eapply ty_sub. apply Hb.
                 eauto. rewrite HeqG. constructor*. rewrite HeqT1.
                 eapply subtyp_sel1.
                 assert (G ⊢ tvar y0 : T0') as Hy0 by eauto.
                 rewrite HeqT0' in Hy0. apply ty_new_elim, ty_rec_elim in Hy0.
                 unfold open_typ_p in Hy0. simpl in *. eapply ty_sub.
                 apply Hy0. eauto.
    + unfold open_trm. simpl. case_if.
      match goal with
      | H: _ |- ?G' & _ ~ ?T0' ⊢ _ : _ =>
        remember G' as G; remember T0' as T0
      end.
      assert (binds y0 T0 (G & y0 ~ T0)) as Hb%ty_var by auto.
      rewrite HeqT0 in Hb. apply ty_rec_elim in Hb.
      eapply ty_sub. 2: {
        repeat rewrite <- concat_assoc in HeqG.
        rewrite concat_empty_l in HeqG.
        match goal with
        | H: G = z ~ ?Tz' & _ |- _ =>
          remember Tz' as Tz
        end.
        assert (binds z Tz (G & y0 ~ T0)) as Hz%ty_var. {
          rewrite HeqG. repeat eapply binds_concat_left; auto. apply binds_single_eq.
        }
        eapply subtyp_sel2. rewrite HeqTz in Hz.
        eapply ty_sub. apply Hz. eauto.
      }
      apply ty_rec_intro.
      unfold open_typ_p in *. simpl in *. repeat case_if.
      match goal with
      | H: _ ⊢ trm_path (pvar y0) : ?U' ∧ ?U'' |- _ =>
        remember U' as S; remember U'' as U
      end.
      apply ty_and_intro.
      * assert (G & y0 ~ T0 ⊢ tvar y0 : S) as Ht. {
          rewrite HeqS, HeqT0. eapply ty_sub. apply Hb. rewrite HeqS. eauto.
        }
        rewrite HeqS in Ht. apply ty_rcd_intro.
        apply ty_new_elim in Ht. apply ty_rec_intro. apply ty_rec_elim in Ht.
        unfold open_typ_p in *. simpl in *. case_if.
        apply ty_and_intro.
        ** eapply ty_sub.
           2: {
             apply subtyp_typ. apply subtyp_bot. apply subtyp_top.
           }
           eapply ty_sub. apply Ht. eauto.
        ** eapply ty_sub. apply Ht. eauto.
      * assert (G & y0 ~ T0 ⊢ tvar y0 : U) as Ht. {
          rewrite HeqU, HeqT0. eapply ty_sub. apply Hb. rewrite HeqU. eauto.
        }
        rewrite HeqU in Ht. apply ty_rcd_intro.
        apply ty_new_elim in Ht. apply ty_rec_intro. apply ty_rec_elim in Ht.
        unfold open_typ_p in *. simpl in *. case_if.
        apply ty_and_intro.
        ** eapply ty_sub.
           2: {
             apply subtyp_typ. apply subtyp_bot. apply subtyp_top.
           }
           eapply ty_sub. apply Ht. eauto.
        ** eapply ty_sub. apply Ht. eauto.
Qed.

End CompilerExample.


(** This file proves the basic laws of the HeapLang program logic by applying
the Iris lifting lemmas. *)

From iris.proofmode Require Import proofmode.
From iris.bi.lib Require Import fractional.
From transfinite.base_logic.lib Require Export gen_heap proph_map gen_inv_heap.
From melocoton.language Require Export weakestpre lifting.
From melocoton.c_interface Require Export resources.
From melocoton.c_lang Require Export class_instances.
From melocoton.c_lang Require Import tactics notation.
From iris.prelude Require Import options.

Global Program Instance heapG_langG_C {SI:indexT} `{heapG_C Σ}
      : langG val C_lang Σ := {
  state_interp σ := public_state_interp σ
}.

Section lifting.
Context {SI:indexT}.
Context `{!heapG_C Σ, !invG Σ}.
Context {p:prog_environ C_lang Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ Ψ : val → iProp Σ.
Implicit Types efs : list expr.
Implicit Types σ : gmap loc heap_cell.
Implicit Types v : val.
Implicit Types l : loc.

(*
#[global] Instance wp'': Wp (iProp Σ) expr val stuckness := (@wp' (C_lang p) Σ _).
#[global] Instance twp'': Twp (iProp Σ) expr val stuckness := (@twp' (C_lang p) Σ _).
*)

(** Recursive functions: we do not use this lemmas as it is easier to use Löb
induction directly, but this demonstrates that we can state the expected
reasoning principle for recursive functions, without any visible ▷. *)
Lemma wp_rec_löb s E f e args Φ (Ψ : list val → iProp Σ) :
   ⌜penv_prog s !! f = Some (Fun args e)⌝ -∗
  □ ( □ (∀ vs res, Ψ vs -∗ ⌜zip_args args vs = Some res⌝ -∗ WP (FunCall ((&f)%V) (map Val vs)) @ s; E {{ Φ }}) -∗
     ∀ vs res, Ψ vs -∗ ⌜zip_args args vs = Some res⌝ -∗ WP (subst_all res e) @ s; E {{ Φ }}) -∗
  ∀ vs res , Ψ vs -∗ ⌜zip_args args vs = Some res⌝ -∗ WP (FunCall ((&f)%V) (map Val vs)) @ s; E {{ Φ }}.
Proof.
  iIntros "%Hp #Hrec". iLöb as "IH". iIntros (v res) "HΨ %Hres".
  iApply lifting.wp_pure_step_later. 1: eauto.
  iIntros "!>". iApply ("Hrec" with "[] HΨ"). 2:done. iIntros "!>" (w res') "HΨ %Hres'".
  iApply ("IH" with "HΨ"). iPureIntro. apply Hres'.
Qed.

Lemma wp_Malloc_seq E n :
  (0 < n)%Z →
  {{{ True }}} Malloc (Val $ LitV $ LitInt $ n) @ p; E
  {{{ l, RET LitV (LitLoc l); [∗ list] i ∈ seq 0 (Z.to_nat n),
      (l +ₗ (i : nat)) ↦C ? ∗ meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (Hn Φ) "_ HΦ". iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ". iModIntro. iSplit; first (destruct n; eauto with lia head_step).
  iIntros (e2 σ2 Hstep). inv_head_step. iModIntro.
  iMod (gen_heap_alloc_big _ (heap_array _ (replicate (Z.to_nat n) Uninitialized)) with "Hσ")
    as "(Hσ & Hl & Hm)".
  { apply heap_array_map_disjoint.
    rewrite replicate_length Z2Nat.id; auto with lia. }
  iModIntro. iFrame. iApply "HΦ".
  iApply big_sepL_sep. iSplitL "Hl".
  - by iApply heap_array_to_seq_mapsto.
  - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed.

Lemma wp_free s E l (v:option val) :
  {{{ ▷ l O↦C (Some v) }}} Free (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt 1) @ s; E
  {{{ RET LitV LitUnit; True }}}.
Proof.
  iIntros (Φ) "> Hl HΦ". iApply (wp_step with "HΦ"). iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ". iDestruct (gen_heap_valid with "Hσ Hl") as "%HH". iModIntro.
  iSplitR; first ( iPureIntro ).
  1: { do 2 eexists. econstructor.
       intros i H1 H2. exists v. rewrite <- HH. f_equal.
       destruct l; cbn. unfold loc_add. f_equal. cbn. lia. }
  iIntros (e2 σ2 Hstep); inv_head_step. iModIntro.
  rewrite state_init_heap_singleton.
  iMod (gen_heap_update (σ1) l (Some v) Deallocated with "Hσ Hl") as "[$ Hl]".
  iModIntro. iFrame. iIntros "HΦ". iModIntro. by iApply "HΦ".
Qed.

Lemma wp_load s E l dq v :
  {{{ ▷ l ↦C{dq} v }}} Load (Val $ LitV $ LitLoc l) @ s; E {{{ RET v; l ↦C{dq} v }}}.
Proof.
  iIntros (Φ) "> Hl HΦ". iApply (wp_step with "HΦ"). iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ". iDestruct (gen_heap_valid with "Hσ Hl") as "%HH". iModIntro.
  iSplitR; first ( iPureIntro; eauto with head_step).
  iIntros (e2 σ2 Hstep); inv_head_step. iModIntro.
  iModIntro. iFrame. iIntros "HΦ". iModIntro.
  by iApply "HΦ".
Qed.

Lemma wp_store s E l (v':option val) v :
  {{{ ▷ l O↦C Some v' }}} Store (Val $ LitV $ LitLoc l) (Val v) @ s; E
  {{{ RET LitV LitUnit; l ↦C v }}}.
Proof.
  iIntros (Φ) "> Hl HΦ". iApply (wp_step with "HΦ"). iApply wp_lift_atomic_head_step; first done.
  iIntros (σ1) "Hσ !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (e2 σ2 Hstep); inv_head_step. iModIntro.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iModIntro. iFrame. iIntros "HΦ". iModIntro. by iApply "HΦ".
Qed.

Lemma wp_call' (s:prog_environ C_lang Σ) n args body body' vv E Φ :
     ⌜(penv_prog s) !! n = Some (Fun args body)⌝
  -∗ ⌜apply_function (Fun args body) vv = Some body'⌝
  -∗ (|={E}=> ▷ |={E}=> WP body' @ s ; E {{v, Φ v}})
  -∗ WP (FunCall ((&n)) (map Val vv)) @ s ; E {{v, Φ v}}.
Proof.
  iIntros (Hlookup Happly) "Hcont". iApply wp_lift_step_fupd.
  { cbv -[map unmap_val]. now rewrite map_unmap_val. }
  iIntros (σ1) "Hσ !>".
  iSplit.
  { iPureIntro. eexists _,_. apply head_prim_step. econstructor; done. }
  iIntros (v2 σ2 Hstep).
  apply head_reducible_prim_step in Hstep; last by eauto with head_step.
  inv_head_step. iMod "Hcont". do 2 iModIntro.
  iMod "Hcont".
  do 2 iModIntro. iFrame.
Qed.

Lemma wp_call (s:prog_environ C_lang Σ) n args body body' vv E Φ :
     ⌜penv_prog s !! n = Some (Fun args body)⌝
  -∗ ⌜apply_function (Fun args body) vv = Some body'⌝
  -∗ (WP body' @ s ; E {{v, Φ v}})
  -∗ WP (FunCall ((&n)) (map Val vv)) @ s ; E {{v, Φ v}}.
Proof.
  iIntros (Hlookup Happly) "Hcont".
  iApply wp_call'. 1-2: done. do 3 iModIntro. done.
Qed.

End lifting.


(* Standard library imports *)
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bool.
Require Import Coq.omega.Omega.
Require Import Coq.Program.Equality.
Import ListNotations.
(* Project related imports *)
Require Import GenericLemmas.
Require Import Names.
Require Import AST.
Require Import UtilsProgram.
Require Import UtilsSkeleton.
Require Import Skeleton.
Require Import Typechecker.
Require Import CtorizeI.
Require Import LiftComatch.
Require Import Subterm.
(*Require Import FunInd.*)

(**************************************************************************************************)
(** * Constructorization Part II:                                                                *)
(**                                                                                *)
(** In the second part of the algorithm we compute the new function bodies.                       *)
(**************************************************************************************************)

Fixpoint constructorize_expr (tn : TypeName) (e : expr) : expr :=
  match e with
  | E_Var n => E_Var n
  | E_Constr sn es => E_Constr sn (map (constructorize_expr tn) es)
  | E_DestrCall sn e es =>
      if eq_TypeName tn (fst (unscope sn))
      then E_ConsFunCall sn (constructorize_expr tn e) (map (constructorize_expr tn) es)
      else E_DestrCall sn (constructorize_expr tn e) (map (constructorize_expr tn) es)
  | E_FunCall n es => E_FunCall n (map (constructorize_expr tn) es)
  | E_GenFunCall sn es =>
      if eq_TypeName tn (fst (unscope sn))
      then E_Constr sn (map (constructorize_expr tn) es)
      else E_GenFunCall sn (map (constructorize_expr tn) es)
  | E_ConsFunCall sn e es => E_ConsFunCall sn (constructorize_expr tn e) (map (constructorize_expr tn) es)
  | E_Match qn e bs cases t =>
      E_Match qn (constructorize_expr tn e)
              (map (fun x => (constructorize_expr tn (fst x), snd x)) bs)
              (map (fun x => (fst x, constructorize_expr tn (snd x))) cases) t
  | E_CoMatch qn bs cocases =>
      (* Without lift/inline, we would have a case distinction... *)
      (*
      if eq_TypeName tn (fst qn)
      (* ...but this case may actually never occur (and will not, thanks to comatch lifting) *)
      then E_Constr (local qn) (map (fun x => constructorize_expr tn (fst x)) bs)
      else *)
      E_CoMatch qn (map (fun x => (constructorize_expr tn (fst x), snd x)) bs)
                   (map (fun x => (fst x, constructorize_expr tn (snd x))) cocases)
  | E_Let e1 e2 => E_Let (constructorize_expr tn e1) (constructorize_expr tn e2)
  end.

Lemma filter_compose : forall {A} (l : list A) f g,
  filter f (filter g l) = filter (fun x => andb (f x) (g x)) l.
Proof with auto.
intros. induction l... simpl. case_eq (g a); intros.
- case_eq (f a); intros.
  + simpl. rewrite H0. f_equal...
  + simpl. rewrite H0...
- case_eq (f a); intros...
Qed.

Lemma constructorize_expr_preserves_typing : forall p tn e ctx t,
  (forall e' n bs cocases, subterm e' e -> e' <> E_CoMatch (tn,n) bs cocases) ->
  (program_skeleton p) / ctx |- e : t ->
  (constructorize_to_skeleton p tn) / ctx |- (constructorize_expr tn e) : t.
Proof with try apply in_eq; try apply in_cons; eauto.
intros. generalize dependent ctx. generalize dependent t. generalize H. clear H.
induction e using expr_strong_ind; intros.
- inversion H0; subst. apply T_Var...
- inversion H1; subst. simpl. apply T_Constr with (cargs:=cargs)...
  + simpl. apply in_or_app. right...
  + clear - H H0 H7.
    assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
    { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_Constr... }
    clear H0. induction H7; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
    * inversion H; subst. apply H4... intros. apply H1 with (x:=e)...
    * apply IHListTypeDeriv; try inversion H... intros. apply H1 with (x:=x0)...
- simpl. case_eq (eq_TypeName tn (fst (unscope n))); intros.
  + inversion H1; subst. destruct n.
    * apply T_LocalConsFunCall with (argts:=dargs).
      -- simpl. unfold new_cfunsigs_l. apply in_or_app. left.
         rewrite in_map_iff. unfold cfunsigs_mapfun. exists (local q, dargs, t).
         split... rewrite filter_In. split...
      -- apply IHe... intros. unfold not in *. intros. eapply H0...
         eapply Sub_Trans... apply Sub_DestrCall_e0...
      -- assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
         { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_DestrCall_es... }
         clear - H H11 H3. induction H11; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
         ++ inversion H; subst. apply H4... intros. apply H3 with (x:=e)...
         ++ apply IHListTypeDeriv; try inversion H... intros. apply H3 with (x:=x0)...
    * apply T_GlobalConsFunCall with (argts:=dargs).
      -- simpl. unfold new_cfunsigs_g. apply in_or_app. left.
         rewrite in_map_iff. unfold cfunsigs_mapfun. exists (global q, dargs, t).
         split... rewrite filter_In. split...
      -- apply IHe... intros. unfold not in *. intros. eapply H0...
         eapply Sub_Trans... apply Sub_DestrCall_e0...
      -- assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
         { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_DestrCall_es... }
         clear - H H11 H3. induction H11; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
         ++ inversion H; subst. apply H4... intros. apply H3 with (x:=e)...
         ++ apply IHListTypeDeriv; try inversion H... intros. apply H3 with (x:=x0)...
  + inversion H1; subst. apply T_DestrCall with (dargs:=dargs).
    * simpl. unfold new_dtors. rewrite filter_In. split... rewrite H2...
    * apply IHe... intros. unfold not in *. intros. eapply H0...
      eapply Sub_Trans... apply Sub_DestrCall_e0...
    * assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
      { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_DestrCall_es... }
      clear - H H11 H3. induction H11; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
      ++ inversion H; subst. apply H4... intros. apply H3 with (x:=e)...
      ++ apply IHListTypeDeriv; try inversion H... intros. apply H3 with (x:=x0)...
- inversion H1; subst. simpl. apply T_FunCall with (argts:=argts)...
  clear - H H0 H8.
  assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
  { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_FunCall... }
  clear H0. induction H8; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
  * inversion H; subst. apply H4... intros. apply H1 with (x:=e)...
  * apply IHListTypeDeriv; try inversion H... intros. apply H1 with (x:=x0)...
- inversion H1; subst.
  + simpl. apply T_GlobalConsFunCall with (argts:=argts).
    * simpl. unfold new_cfunsigs_g. apply in_or_app...
    * apply IHe... intros. unfold not in *. intros. eapply H0...
      eapply Sub_Trans... apply Sub_ConsFunCall_e0...
    * assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
      { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_ConsFunCall_es... }
      clear - H H10 H2. induction H10; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
      -- inversion H; subst. apply H4... intros. apply H2 with (x:=e)...
      -- apply IHListTypeDeriv; try inversion H... intros. apply H2 with (x:=x0)...
  + simpl. apply T_LocalConsFunCall with (argts:=argts).
    * simpl. unfold new_cfunsigs_g. apply in_or_app...
    * apply IHe... intros. unfold not in *. intros. eapply H0...
      eapply Sub_Trans... apply Sub_ConsFunCall_e0...
    * assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
      { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_ConsFunCall_es... }
      clear - H H10 H2. induction H10; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
      -- inversion H; subst. apply H4... intros. apply H2 with (x:=e)...
      -- apply IHListTypeDeriv; try inversion H... intros. apply H2 with (x:=x0)...
- simpl. case_eq (eq_TypeName tn (fst (unscope sn))); intros.
  + inversion H1; subst.
    * apply T_Constr with (cargs:=argts)...
      -- simpl. unfold computeNewDatatype. apply in_or_app. left. apply in_or_app. left.
         rewrite in_map_iff. exists (qn, argts). split... rewrite filter_In. split...
         simpl in *. rewrite eq_TypeName_symm...
      -- assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
         { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_GenFunCall... }
         clear - H H9 H3. induction H9; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
         ++ inversion H; subst. apply H4... intros. apply H3 with (x:=e)...
         ++ apply IHListTypeDeriv; try inversion H... intros. apply H3 with (x:=x0)...
    * apply T_Constr with (cargs:=argts)...
      -- simpl. unfold computeNewDatatype. apply in_or_app. left. apply in_or_app. right.
         rewrite in_map_iff. exists (qn, argts). split... rewrite filter_In. split...
         simpl in *. rewrite eq_TypeName_symm...
      -- assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
         { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_GenFunCall... }
         clear - H H9 H3. induction H9; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
         ++ inversion H; subst. apply H4... intros. apply H3 with (x:=e)...
         ++ apply IHListTypeDeriv; try inversion H... intros. apply H3 with (x:=x0)...
  + inversion H1; subst.
    * apply T_GlobalGenFunCall with (argts:=argts).
      -- simpl. unfold new_gfunsigs_g. rewrite filter_In. split... simpl in *. rewrite H2...
      -- assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
         { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_GenFunCall... }
         clear - H H9 H3. induction H9; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
         ++ inversion H; subst. apply H4... intros. apply H3 with (x:=e)...
         ++ apply IHListTypeDeriv; try inversion H... intros. apply H3 with (x:=x0)...
    * apply T_LocalGenFunCall with (argts:=argts).
      -- simpl. unfold new_gfunsigs_l. rewrite filter_In. split... simpl in *. rewrite H2...
      -- assert (forall x y n bs cocases, In x ls -> subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
         { clear - H0. intros. apply H0. eapply Sub_Trans... apply Sub_GenFunCall... }
         clear - H H9 H3. induction H9; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
         ++ inversion H; subst. apply H4... intros. apply H3 with (x:=e)...
         ++ apply IHListTypeDeriv; try inversion H... intros. apply H3 with (x:=x0)...
- simpl. inversion H2; subst.
  apply T_Match with (bindings_exprs := map (constructorize_expr tn) bindings_exprs)
    (bindings_types := bindings_types) (ctorlist := ctorlist).
  + apply IHe... intros. unfold not in *. apply H1. eapply Sub_Trans... apply Sub_Match_e0.
  + rewrite map_fst_f_combine...
  + assert (forall x y n bs cocases,
      In x (map fst (combine bindings_exprs bindings_types)) ->
      subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
    { clear - H1. intros. apply H1. eapply Sub_Trans... apply Sub_Match_bs... }
    clear - H0 H13 H3. induction H13; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
    * inversion H0; subst. apply H4... intros. unfold not in *. eapply H3...
    * apply IHListTypeDeriv; try inversion H0... intros. apply H3 with (x:=x0)...
  + unfold lookup_ctors. unfold lookup_ctors in *.
    remember (filter (eq_TypeName (fst n)) (skeleton_dts (constructorize_to_skeleton p tn))) as fl.
    simpl. clear - H14 Heqfl.
    destruct (filter (eq_TypeName (fst n)) (skeleton_dts (program_skeleton p))) eqn:E; try discriminate.
    inversion H14. subst ctorlist. clear H14. pose proof (in_eq t l). rewrite <- E in H.
    rewrite filter_In in H. destruct H.
    assert (exists t l, fl = t :: l) as flEq.
    { case_eq (eq_TypeName (fst n) tn); intros.
      - simpl in Heqfl. rewrite H1 in Heqfl. exists tn. eexists...
      - simpl in Heqfl. rewrite H1 in Heqfl. rewrite E in Heqfl. exists t. exists l...
    }
    destruct flEq as [t' [l' flEq]]. rewrite flEq. clear t' l' flEq.
    unfold computeNewDatatype.
    rewrite filter_app. rewrite filter_app. f_equal. rewrite <- app_nil_l. f_equal.
    case_eq (eq_TypeName t tn); intros.
    * rewrite eq_TypeName_eq in H1. subst.
      pose proof (skeleton_dts_cdts_disjoint (program_skeleton p)).
      unfold dts_cdts_disjoint in H1.
      pose proof (skeleton_gfun_sigs_in_cdts_l (program_skeleton p)) as H2.
      unfold gfun_sigs_in_cdts in H2.
      pose proof (skeleton_gfun_sigs_in_cdts_g (program_skeleton p)) as H2'.
      unfold gfun_sigs_in_cdts in H2'.
      case_eq ((filter (fun x => eq_TypeName (fst (fst x)) tn)
        (skeleton_gfun_sigs_l (program_skeleton p)))); intros;
      case_eq ((filter (fun x => eq_TypeName (fst (fst x)) tn)
        (skeleton_gfun_sigs_g (program_skeleton p)))); intros; auto; exfalso.
      -- pose proof (in_eq p0 l0). rewrite <- H4 in H5. rewrite filter_In in H5.
         destruct H5. rewrite eq_TypeName_eq in H6. subst.
         rewrite Forall_forall in H2'. pose proof (H2' _ H5). unfold not in H1.
         apply H1 with (t:=fst (fst p0))...
      -- pose proof (in_eq p0 l0). rewrite <- H3 in H5. rewrite filter_In in H5.
         destruct H5. rewrite eq_TypeName_eq in H6. subst.
         rewrite Forall_forall in H2. pose proof (H2 _ H5). unfold not in H1.
         apply H1 with (t:=fst (fst p0))...
      -- pose proof (in_eq p0 l0). rewrite <- H3 in H5. rewrite filter_In in H5.
         destruct H5. rewrite eq_TypeName_eq in H6. subst.
         rewrite Forall_forall in H2. pose proof (H2 _ H5). unfold not in H1.
         apply H1 with (t:=fst (fst p0))...
    * rewrite <- app_nil_l. f_equal;
      match goal with |- ?l = [] => case_eq l; intros; auto;
        exfalso; pose proof (in_eq p0 l0); rewrite <- H2 in H3; rewrite filter_In in H3;
        destruct H3; rewrite in_map_iff in H3; do 2 (destruct H3); rewrite filter_In in H5;
        destruct H5; destruct p0; inversion H3; subst; simpl in *;
        rewrite eq_TypeName_eq in H0; rewrite H0 in H4;
        rewrite eq_TypeName_eq in H6; rewrite eq_TypeName_eq in H4; subst;
        unfold QName in *; rewrite H4 in H1; rewrite eq_TypeName_refl in H1; discriminate
      end.
  + rewrite Forall_forall in *. intros. rewrite <- map_fst_f_combine in H3.
    rewrite in_map_iff in H3. do 2 (destruct H3). pose proof (H15 _ H4).
    destruct x. destruct p0. destruct p1. destruct x0. destruct p0. destruct p1. subst.
    inversion H3...
  + assert (forall x, In x ls -> In x ls)...
    generalize H3. generalize H16.
    generalize (map (fun ctor => snd ctor ++ bindings_types) ctorlist).
    generalize ls at - 4. clear - H H1. induction ls0; intros.
    * inversion H16. subst. apply ListTypeDeriv'_Nil.
    * inversion H16. subst. simpl. apply ListTypeDeriv'_Cons.
      -- rewrite Forall_forall in H. destruct a. simpl. apply H...
         ++ rewrite in_map_iff. exists (s,e0). split... apply H3...
         ++ intros. apply H1. apply Sub_Trans with (e2:=e0)... apply Sub_Match_cases.
            rewrite in_map_iff. exists (s,e0). split... apply H3...
      -- apply IHls0... intros. apply H3...
- simpl. case_eq (eq_TypeName tn (fst n)); intros.
  + exfalso. unfold not in H1. rewrite eq_TypeName_eq in H3. subst. destruct n.
    eapply H1; try eapply Sub_Refl...
  + simpl. inversion H2. subst.
    apply T_CoMatch with (bindings_exprs := map (constructorize_expr tn) bindings_exprs)
    (bindings_types := bindings_types) (dtorlist := dtorlist).
    * rewrite map_fst_f_combine...
    * assert (forall x y n bs cocases,
      In x (map fst (combine bindings_exprs bindings_types)) ->
      subterm y x -> y <> E_CoMatch (tn,n) bs cocases).
      { clear - H1. intros. apply H1. eapply Sub_Trans... apply Sub_CoMatch_bs... }
      clear - H0 H8 H4. induction H8; try apply ListTypeDeriv_Nil. simpl. apply ListTypeDeriv_Cons.
      -- inversion H0; subst. apply H3... intros. unfold not in *. eapply H4...
      -- apply IHListTypeDeriv; try inversion H0... intros. apply H4 with (x:=x0)...
    * unfold lookup_dtors. rewrite <- H11. f_equal. simpl. unfold new_cdts.
      unfold lookup_dtors. unfold new_dtors.
      generalize (skeleton_cdts (program_skeleton p)).
      generalize (skeleton_dtors (program_skeleton p)). intros c c0.
      repeat (rewrite filter_compose).
      rewrite filter_ext with (g:=eq_TypeName (fst n)).
      2 : { clear - H3. intros. case_eq (eq_TypeName (fst n) a); intros...
            rewrite eq_TypeName_eq in H. subst. rewrite H3... }
      rewrite filter_ext with
        (g:=(fun x : ScopedName * list TypeName * TypeName =>
          let (y, _) := x in let (n0, _) := y in eq_TypeName (fst (unscope n0)) (fst n)))...
      clear - H3. intros. destruct a. destruct p.
      case_eq (eq_TypeName (fst (unscope s)) (fst n)); intros...
      rewrite eq_TypeName_eq in H. rewrite H. rewrite H3...
    * rewrite Forall_forall in *. intros. rewrite <- map_fst_f_combine in H4.
      rewrite in_map_iff in H4. do 2 (destruct H4). pose proof (H13 _ H5).
      destruct x. destruct p0. destruct p1. destruct x0. destruct p0. destruct p1.
      destruct p2. destruct p0. subst. inversion H4...
    * assert (forall x, In x ls -> In x ls)...
      generalize H4. generalize H14.
      generalize (map (fun dtor => snd (fst dtor) ++ bindings_types) dtorlist).
      generalize (map snd dtorlist).
      generalize ls at - 3. clear - H H1. induction ls0; intros.
      -- inversion H14. subst. apply ListTypeDeriv'_Nil.
      -- inversion H14. subst. simpl. apply ListTypeDeriv'_Cons.
         ++ rewrite Forall_forall in H. destruct a. simpl. apply H...
            ** rewrite in_map_iff. exists (s,e). split... apply H4...
            ** intros. apply H1. apply Sub_Trans with (e2:=e)... apply Sub_CoMatch_cocases.
               rewrite in_map_iff. exists (s,e). split... apply H4...
         ++ apply IHls0... intros. apply H4...
- inversion H0. subst. simpl. apply T_Let with (t1:=t1).
  + apply IHe1... intros. apply H. apply Sub_Trans with (e2:=e1)... apply Sub_Let_e1...
  + apply IHe2... intros. apply H. apply Sub_Trans with (e2:=e2)... apply Sub_Let_e2...
Qed.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import CtxtSwitch.Specs.restore_hcr_el2.
Require Import CtxtSwitch.LowSpecs.restore_hcr_el2.
Require Import CtxtSwitch.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       get_rec_common_sysregs_spec
       sysreg_write_spec
    .

  Lemma restore_hcr_el2_spec_exists:
    forall habd habd'  labd rec
      (Hspec: restore_hcr_el2_spec rec habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', restore_hcr_el2_spec0 rec labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. destruct rec.
    unfold restore_hcr_el2_spec, restore_hcr_el2_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * ).
    destruct regs_is_int64_dec in *. autounfold in e. repeat rewrite e.
    repeat simpl_update_reg.
    eexists; split. reflexivity. constructor. reflexivity.
    inv C3.
  Qed.

End Refine.