Require Import Coq.Program.Equality.
Require Import Coq.Sets.Ensembles.

Add LoadPath "." as Top0.
Require Import Top0.Tactics.
Require Import Top0.Keys.
Require Import Top0.Definitions.
Require Import Top0.Environment.
Require Import Top0.TypeSystem.
Require Import Top0.Heap.
Require Import Top0.CorrectnessLemmas.
Require Import Top0.AdditionalLemmas.
Require Import Top0.Axioms.

Module EffectSoundness.

Import TypeSoundness.

Lemma EmptyInNil:
  forall st, Epsilon_Phi_Soundness (st, Phi_Nil).
Proof.
  intros st. apply EPS. intros da HIn.
  inversion  HIn.
Qed.

Lemma sound_approx_inj :
  forall (st1 st2 : Epsilon) (dy : Phi),
    Epsilon_Phi_Soundness (st1, dy) ->
    Epsilon_Phi_Soundness (Union StaticAction st1 st2, dy) /\ Epsilon_Phi_Soundness (Union StaticAction st2 st1, dy).
Proof.
  intros st1 st2 dy HSound; split; inversion HSound as [ ? ? H' ]; subst; constructor;
  intros da HIn; apply H' in HIn; destruct HIn as [ca HIn]; exists ca; intuition.
Qed.

Lemma sound_comp :
  forall (st1 st2 : Epsilon) (dy1 dy2 : Phi),
    Epsilon_Phi_Soundness (st1, dy1) -> Epsilon_Phi_Soundness (st2, dy2) ->
    Epsilon_Phi_Soundness (Union StaticAction st1 st2, Phi_Seq dy1 dy2).
Proof.
  intros st1 st2 dy1 dy2 H1 H2.
  inversion H1 as [? ? HEps1]; inversion H2 as [? ? HEps2]; subst; constructor;
  intros eff HIn.
  inversion HIn; subst.
  destruct H3 as [HIn_1 | HIn_2].
  - apply HEps1 in HIn_1; destruct HIn_1 as [ca HIn']; exists ca; intuition.
  - apply HEps2 in HIn_2; destruct HIn_2 as [ca HIn']; exists ca; intuition.
Qed.

Lemma sound_comp_par :
  forall (st1 st2 : Epsilon) (dy1 dy2 : Phi),
    Epsilon_Phi_Soundness (st1, dy1) -> Epsilon_Phi_Soundness (st2, dy2) ->
    Epsilon_Phi_Soundness (Union StaticAction st1 st2, Phi_Par dy1 dy2).
Proof.
  intros st1 st2 dy1 dy2 H1 H2.
  inversion H1 as [? ? HEps1]; inversion H2 as [? ? HEps2]; subst; constructor;
  intros eff HIn.
  inversion HIn; subst.
  destruct H3 as [HIn_1 | HIn_2].
  - apply HEps1 in HIn_1; destruct HIn_1 as [ca HIn']; exists ca; intuition.
  - apply HEps2 in HIn_2; destruct HIn_2 as [ca HIn']; exists ca; intuition.
Qed.

Lemma fold_dist_union : forall rho (eff1 eff2 : Epsilon),
                          fold_subst_eps rho (Union_Static_Action eff1 eff2) =
                          Union_Static_Action (fold_subst_eps rho eff1) (fold_subst_eps rho eff2).
Proof.
  intros rho eff1 eff2.
  unfold fold_subst_eps.
  apply Extensionality_Ensembles.
  unfold Same_set, Included. split.
  - intros x H. unfold In in *. unfold Union_Static_Action.
    destruct H as [sa [H1 H2]]. subst.
    destruct H1.
    + apply Union_introl. unfold In in *.
      exists x. intuition.
    +  apply Union_intror. unfold In in *.
      exists x. intuition.
  - intros x H. unfold In in *. destruct H.
    + unfold In in H. destruct H as [sa ?].
      exists sa. intuition. apply Union_introl. auto.
    + unfold In in H. destruct H as [sa ?].
      exists sa. intuition. apply Union_intror. auto.
Qed.

Lemma eff_sound :
  forall e hp hp' env rho v dynamic_eff,
    (hp, env, rho, e) ⇓ (hp', v, dynamic_eff) ->
    forall stty ctxt rgns ty static_eff,
      TcEnv (stty, rho, env, ctxt) ->
      TcExp (ctxt, rgns, e, ty, static_eff) ->
      TcHeap (hp, stty) ->
      TcRho (rho, rgns) ->
      Epsilon_Phi_Soundness (fold_subst_eps rho static_eff, dynamic_eff).
Proof.
  intros e hp hp' env rho v dynamic_eff D.
  intros stty ctxt rgns ty static_eff HTcEnv HTcExp HTcHeap HTcRho.
  dynamic_cases (dependent induction D) Case; inversion HTcExp; subst.
  Case "cnt n". apply EmptyInNil.
  Case "bool b". apply EmptyInNil.
  Case "var x". apply EmptyInNil.
  Case "mu_abs". apply EmptyInNil.
  Case "rgn_abs". apply EmptyInNil.
  Case "mu_app".
    assert (clsTcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (fheap, stty')
             /\ TcVal (stty', Cls (env', rho', Mu f x ec' ee'), subst_rho rho (Ty2_Arrow tya effc ty effe Ty2_Effect)))
       by (eapply ty_sound; eauto).

    destruct clsTcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.
    assert (argTcVal : exists stty',
             (forall l t', ST.find l sttyb = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (aheap, stty')
             /\ TcVal (stty', v0, subst_rho rho tya)) by
        (eapply ty_sound; eauto using update_env, ext_stores__env).
    destruct argTcVal as [sttya [Weaka [TcHeapa TcVal_v']]]; eauto.

    assert (Sf : Epsilon_Phi_Soundness (fold_subst_eps rho efff, facts)) by (eapply IHD1; eauto).
    assert (Sa : Epsilon_Phi_Soundness (fold_subst_eps rho effa, aacts)) by
        (eapply IHD2 with (stty := sttyb);
         eauto using update_env, ext_stores__env).

    inversion TcVal_cls as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcInc' TcEnv_env' TcExp_abs | | |]; subst.
    inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ?  TcExp_eb | | | | | | | | | | | | | | | | | | | | ]; subst.

    rewrite <- H4 in TcVal_cls.
    do 2 rewrite subst_rho_arrow in H4. inversion H4.
    rewrite <- H9 in TcVal_v'.

    assert (Sb : Epsilon_Phi_Soundness (fold_subst_eps rho effc, bacts)).
    rewrite <- H10; eapply IHD3 with (stty := sttya) (rho:=rho'); eauto.
    SCase "Extended Env".
      apply update_env.
      SSCase "TcEnv". apply update_env.
        SSSCase "Extended". eapply ext_stores__env; eauto.
        SSSCase "Extended TcVal". eapply ext_stores__val; eauto.
      SSCase "TcVal".  eassumption.

    do 2 rewrite fold_dist_union.
    apply sound_comp; [| assumption].
    apply sound_comp; [|assumption].
    assumption.
  Case "rgn_app".
    assert (cls_TcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (fheap, stty')
             /\ TcVal (stty', Cls (env', rho', Lambda x eb),  subst_rho rho (Ty2_ForallRgn effr tyr)))
    by (eapply ty_sound; eauto).
    destruct cls_TcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.
    rewrite fold_dist_union.
    apply sound_comp.

    eapply IHD1; eauto.
    inversion TcVal_cls as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcInc' TcEnv_env' TcExp_abs | | |]; subst.
    inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | | | | | | | | | | | | | | ]; subst.
    do 2 rewrite subst_rho_forallrgn in H5. inversion H5. clear H5.
    unfold open_rgn_eff.
    erewrite <- subst_rho_open_close_eps; eauto.
    replace (Rgn2_Const true true v') with  (mk_rgn_type (Rgn2_Const true false v')) by (simpl; reflexivity).
    rewrite <- subst_as_close_open_eps.
    replace (subst_eps x (Rgn2_Const true false v') effr0) with (subst_in_eff x v' effr0) by (unfold subst_in_eff; reflexivity).
    rewrite <- subst_add_comm_eff; eauto.
    eapply IHD2; eauto.
    eapply extended_rho; eauto. apply update_rho; auto.  eapply not_set_elem_not_in_rho; eauto. assumption.
  Case "eff_app".
    assert (cls_TcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (hp', stty')
             /\ TcVal (stty', Cls (env', rho', Mu f x ec' ee'),  subst_rho rho (Ty2_Arrow tya effc tyc effe Ty2_Effect)))
    by (eapply ty_sound; eauto).

    destruct cls_TcVal as [sttyb [Weakb [TcHeapb TcVal_cls]]]; eauto.
    assert (argTcVal : exists stty',
             (forall l t', ST.find l sttyb = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (hp', stty')
             /\ TcVal (stty', v', subst_rho rho tya)) by
        (eapply ty_sound; eauto using update_env, ext_stores__env).
    destruct argTcVal as [sttya [Weaka [TcHeapa TcVal_v']]]; eauto.

    assert (Sf : Epsilon_Phi_Soundness (fold_subst_eps rho efff, facts)) by (eapply IHD1; eauto).
    assert (Sa : Epsilon_Phi_Soundness (fold_subst_eps rho effa, aacts)) by
        (eapply IHD2 with (stty := sttyb);
         eauto using update_env, ext_stores__env).

    inversion TcVal_cls as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcInc' TcEnv_env' TcExp_abs | | | ]; subst.
    inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | | | | | | | | | | | | | |]; subst.

    rewrite <- H4 in TcVal_cls.
    do 2 rewrite subst_rho_arrow in H4. inversion H4.
    rewrite <- H8 in TcVal_v'.

    assert (Sb : Epsilon_Phi_Soundness (fold_subst_eps rho effe, bacts)).
    rewrite <- H11.
    eapply IHD3 with (stty := sttya); eauto.
    apply update_env.
    SCase "TcEnv". apply update_env.
       SSCase "Extended". eapply ext_stores__env; eauto.
       SSCase "Extended TcVal". eapply ext_stores__val; eauto. eassumption.

    do 2 rewrite fold_dist_union.
    apply sound_comp; [| assumption].
    apply sound_comp; [|assumption].
    assumption.
  Case "par_pair".
    assert (HA : Epsilon_Phi_Soundness (fold_subst_eps rho eff1, acts_mu1)).
    eapply IHD3; eauto.
    assert (HB : Epsilon_Phi_Soundness (fold_subst_eps rho eff2, acts_mu2)).
    eapply IHD4; eauto.
    assert (HC : Epsilon_Phi_Soundness (fold_subst_eps rho eff3, acts_eff1)).
    eapply IHD1; eauto.
    assert (HD : Epsilon_Phi_Soundness (fold_subst_eps rho eff4, acts_eff2)).
    eapply IHD2; eauto.
    assert (H_ : Epsilon_Phi_Soundness (Union_Static_Action (fold_subst_eps rho eff1) (fold_subst_eps rho eff2),
                                        Phi_Seq acts_mu1 acts_mu2))
     by (apply sound_comp; auto).
    assert (H__ : Epsilon_Phi_Soundness (Union_Static_Action (fold_subst_eps rho eff3) (fold_subst_eps rho eff4),
                                         Phi_Seq acts_eff1 acts_eff2))
     by (apply sound_comp; auto).

    rewrite fold_dist_union.
    replace (fold_subst_eps rho (Union_Static_Action (Union_Static_Action eff3 eff4) eff2)) with
            (Union_Static_Action (fold_subst_eps rho (Union_Static_Action eff3 eff4)) (fold_subst_eps rho eff2))
      by (rewrite <- fold_dist_union; reflexivity).

    replace (Union_Static_Action (Union_Static_Action (fold_subst_eps rho (Union_Static_Action eff3 eff4))
                                                      (fold_subst_eps rho eff2)) (fold_subst_eps rho eff1)) with
     (Union_Static_Action (fold_subst_eps rho (Union_Static_Action eff3 eff4))
                                              (Union_Static_Action (fold_subst_eps rho eff1) (fold_subst_eps rho eff2))).
    SCase "".
     { apply sound_comp with (dy1:=Phi_Par acts_eff1 acts_eff2) (dy2:=Phi_Par acts_mu1 acts_mu2).
       - rewrite fold_dist_union. apply sound_comp_par; assumption.
       - apply sound_comp_par; assumption. }
    SCase "replace proof".
      rewrite fold_dist_union.
      unfold Union_Static_Action.
      { apply Extensionality_Ensembles;
        unfold Same_set, Included; split; intros x HUnion; unfold Ensembles.In in *.
        - inversion HUnion; subst; inversion H1; subst.
          + apply Union_introl. apply Union_introl. apply Union_introl. assumption.
          + apply Union_introl. apply Union_introl. apply Union_intror. assumption.
          + apply Union_intror. assumption.
          + apply Union_introl. apply Union_intror. assumption.
        - inversion HUnion; subst; inversion H1; subst.
          + apply Union_introl. assumption.
          + apply Union_intror. apply Union_intror. assumption.
          + apply Union_intror. apply Union_introl. assumption. }
  Case "cond_true".
    assert (boolTcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (cheap, stty')
             /\ TcVal (stty', Bit true, subst_rho rho Ty2_Boolean)) by (eapply ty_sound; eauto).
    destruct boolTcVal as [sttyb [Weakb [TcHeapb TcVal_bool]]]; eauto.

    assert (Epsilon_Phi_Soundness (fold_subst_eps rho eff, cacts)) by (eapply IHD1; eauto).
    do 2 rewrite fold_dist_union.
    assert (Epsilon_Phi_Soundness (fold_subst_eps rho eff1, tacts)) by
      (eapply IHD2 with (stty := sttyb); eauto using ext_stores__env).

    eapply sound_comp; eauto.
    replace tacts with (Phi_Seq tacts (Phi_Nil)) by (apply Phi_Seq_Nil_R).
    eapply sound_comp; [assumption | apply EmptyInNil].
  Case "cond_false".
    assert (bool_TcVal : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (cheap, stty')
             /\ TcVal (stty', Bit false, subst_rho rho Ty2_Boolean)) by (eapply ty_sound; eauto).
    destruct bool_TcVal as [sttyb [Weakb [TcHeapb TcVal_bool]]]; eauto.

    assert (Epsilon_Phi_Soundness (fold_subst_eps rho eff, cacts)) by (eapply IHD1; eauto).
    do 2 rewrite fold_dist_union.
    assert (Epsilon_Phi_Soundness (fold_subst_eps rho eff2, facts)) by
      (eapply IHD2 with (stty := sttyb);  eauto using ext_stores__env).

    eapply sound_comp; eauto.
    replace facts with (Phi_Seq (Phi_Nil) facts) by (apply Phi_Seq_Nil_L).
    eapply sound_comp; [apply EmptyInNil | assumption].
  Case "new_ref e".
    assert (Epsilon_Phi_Soundness (fold_subst_eps rho  veff, vacts)) by (eapply IHD; eauto).
    rewrite fold_dist_union.
    apply sound_comp; [assumption | ].
    econstructor. intros eff HIn.
    inversion HIn; subst.
    eexists. split. unfold In, fold_subst_eps, Singleton_Static_Action, fold_subst_sa.
    eexists. intuition.
    simpl. simpl in H; inversion H; subst. rewrite subst_rho_rgn_const. constructor.
  Case "get_ref e".
    assert (Epsilon_Phi_Soundness (fold_subst_eps rho aeff, aacts)) by (eapply IHD; eauto).
    rewrite fold_dist_union.
    apply sound_comp; [assumption | ].
    econstructor. intros eff HIn.
    inversion HIn.
    eexists. split. unfold In, fold_subst_eps, Singleton_Static_Action, fold_subst_sa.
    eexists. intuition.
    simpl. simpl in H; inversion H; subst. rewrite subst_rho_rgn_const. constructor.
  Case "set_ref e1 e2".
    assert (loc_TcVal : exists stty',
             (forall k t', ST.find k stty = Some t' -> ST.find k stty' = Some t')
             /\ TcHeap (heap', stty')
             /\ TcVal (stty', Loc (Rgn2_Const true false s) l, subst_rho rho (Ty2_Ref (mk_rgn_type (Rgn2_Const true false s)) t)))
      by (eapply ty_sound; eauto).
    destruct loc_TcVal as [sttyb [Weakb [TcHeapb TcVal_bool]]]; eauto.

    assert (Epsilon_Phi_Soundness (fold_subst_eps rho aeff, aacts)) by (eapply IHD1; eauto).
    do 2 rewrite fold_dist_union.
    assert (Epsilon_Phi_Soundness (fold_subst_eps rho veff, vacts)).
      eapply IHD2 with (stty := sttyb); eauto using ext_stores__env.

    apply sound_comp. apply sound_comp. assumption. assumption.
    econstructor. intros eff HIn.
    inversion HIn.
    eexists. split. unfold In, fold_subst_eps, Singleton_Static_Action, fold_subst_sa.
    eexists. intuition.
    simpl. simpl in H; inversion H; subst. rewrite subst_rho_rgn_const. constructor.
  Case "nat_plus x y".
    assert (H : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (lheap, stty')
             /\ TcVal (stty', Num va, subst_rho rho Ty2_Natural)) by (eapply ty_sound; eauto).
    destruct H as [sttyx [Weakx [TcHeapx TcVal_x]]]; eauto.
    rewrite fold_dist_union.
    apply sound_comp; eauto.
    eapply IHD2 with (stty := sttyx); eauto using ext_stores__env.
  Case "nat_minus x y".
    assert (H : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (lheap, stty')
             /\ TcVal (stty', Num va, subst_rho rho Ty2_Natural)) by (eapply ty_sound; eauto).
    destruct H as [sttyx [Weakx [TcHeapx TcVal_x]]]; eauto.
    rewrite fold_dist_union.
    apply sound_comp; eauto.
    eapply IHD2 with (stty := sttyx); eauto using ext_stores__env.
  Case "nat_times x y".
    assert (H : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (lheap, stty')
             /\ TcVal (stty', Num va, subst_rho rho Ty2_Natural)) by (eapply ty_sound; eauto).
    destruct H as [sttyx [Weakx [TcHeapx TcVal_x]]]; eauto.
    rewrite fold_dist_union.
    apply sound_comp; eauto.
    eapply IHD2 with (stty := sttyx); eauto using ext_stores__env.
  Case "bool_eq x y".
    assert (H : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (lheap, stty')
             /\ TcVal (stty', Num va, subst_rho rho Ty2_Natural)) by (eapply ty_sound; eauto).
    destruct H as [sttyx [Weakx [TcHeapx TcVal_x]]]; eauto.
    rewrite fold_dist_union.
    apply sound_comp; eauto.
    eapply IHD2 with (stty := sttyx); eauto using ext_stores__env.
  Case "alloc_abs". apply EmptyInNil.
  Case "read_abs". apply EmptyInNil.
  Case "write_abs". apply EmptyInNil.
  Case "read_conc". apply EmptyInNil.
  Case "write_conc". apply EmptyInNil.
  Case "eff_concat".
     assert (H : exists stty',
             (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
             /\ TcHeap (hp', stty')
             /\ TcVal (stty', Eff effa, subst_rho rho Ty2_Effect)) by (eapply ty_sound; eauto).
    destruct H as [sttyx [Weakx [TcHeapx TcVal_x]]]; eauto.
    rewrite fold_dist_union.
    apply sound_comp; eauto.
  Case "eff_top". apply EmptyInNil.
  Case "eff_empty". apply EmptyInNil.
Qed.

Lemma ReadOnlyTracePreservesHeap_2 :
  forall e hp hp' env rho v dynamic_eff,
    (hp, env, rho, e) ⇓ (hp', v, dynamic_eff) ->
    forall stty ctxt rgns ty static_eff,
      TcEnv (stty, rho, env, ctxt) ->
      TcExp (ctxt, rgns, e, ty, static_eff) ->
      TcHeap (hp, stty) ->
      TcRho (rho, rgns) ->
      ReadOnlyStatic (static_eff) ->
      hp = hp'.
Proof.
  intros.
  eapply ReadOnlyTracePreservesHeap_1; [eassumption | ].
  eapply ReadOnlyStaticImpliesReadOnlyPhi; [eapply ReadOnlyStaticImpliesReadOnlySubstStatic; eassumption | ].
  eapply eff_sound; eassumption.
Qed.

End EffectSoundness.


From ITree Require Import
     ITree
     ITreeFacts
     Events.State
     Events.StateFacts
     Events.Exception
.

From SecureExample Require Import
     LabelledImp
     Lattice
.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

Section LabelledImpHandler.

Context (Labels : Lattice).

Definition priv_io (A : Type) (e : IOE Labels A) :=
  match e with
  | LabelledPrint _ s _ => s end.

Definition priv_exc (A : Type) (e : impExcE Labels A ) :=
  match e with
  | Throw s => s end.

Definition priv_exc_io := case_ priv_exc priv_io.

Definition product_rel {R1 R2 S1 S2} (RR1: R1 -> S1 -> Prop) (RR2 : R2 -> S2 -> Prop)
           (p1 : R1 * R2) (p2 : S1 * S2) : Prop :=
  RR1 (fst p1) (fst p2) /\ RR2 (snd p1) (snd p2).

Definition handle_case {E1 E2 : Type -> Type} {M : Type -> Type} (hl : E1 ~> M) (hr : E2 ~> M) : (E1 +' E2) ~> M :=
  fun _ e => match e with
          | inl1 el => hl _ el
          | inr1 er => hr _ er end.

Definition handle_state_io : forall A, (stateE +' (IOE Labels)) A ->
                                  stateT map (itree ((impExcE Labels) +' (IOE Labels))) A :=
  fun _ e => match e with
          | inl1 el => handleState _ el
          | inr1 er => fun s => r <- ITree.trigger (inr1 er);; Ret (s, r) end.

Definition handle_imp : forall A, ((impExcE Labels) +' stateE +' (IOE Labels)) A ->
                             stateT map (itree ((impExcE Labels) +' (IOE Labels)) ) A :=
  fun _ e => match e with
          | inl1 el => fun s => r <- ITree.trigger (inl1 el);; Ret (s, r)
          | inr1 er => handle_state_io _ er end.

Definition interp_imp {R} (t : itree ((impExcE Labels) +' stateE +' (IOE Labels)) R ) : stateT map (itree ((impExcE Labels) +' (IOE Labels))) R :=
  interp_state handle_imp t.

Hint Unfold interp_imp : core.
Hint Unfold handle_state_io : core.
Hint Unfold handle_imp : core.
Hint Unfold product_rel : core.
(*
Ltac use_simpobs :=
  repeat match goal with
         | H : TauF _ = observe ?t |- _ => apply simpobs in H
         | H : RetF _ = observe ?t |- _ => apply simpobs in H
         | H : VisF _ _ = observe ?t |- _ => apply simpobs in H
  end.

Ltac destruct_imp_ev := repeat match goal with
                        | e : (?E1 +' ?E2) ?A |- _ => destruct e
                        | exc : impExcE ?A |- _ => destruct exc
                        | st : stateE ?A |- _ => destruct st
                        | io : IOE ?A |- _ => destruct io
                        end.

 (* TODO : replace with labelled equiv *)
Lemma interp_eqit_secure_imp : forall (R1 R2 : Type) (RR : R1 -> R2 -> Prop) (priv_map : privacy_map)
                                 (t1 : itree (impExcE +' stateE +' IOE) R1 )
                                 (t2 : itree (impExcE +' stateE +' IOE) R2),
    eqit_secure sense_preorder (priv_imp priv_map) RR true true Public t1 t2 ->
    low_eqit_secure_impstate true true priv_map RR (interp_imp t1 )  (interp_imp t2).
Proof.
  red. intros.
  eapply interp_eqit_secure_state; eauto.
  - constructor; red; intros; cbv; intros; auto. red in H1. rewrite H1; auto.
    rewrite H1; auto.
  - intros. destruct_imp_ev.
    + destruct s.
      * eapply respect_public'. cbv. auto. red. intros. cbn.
        setoid_rewrite bind_trigger. apply eqit_secure_public_Vis. cbv. auto.
        intros [].
      * eapply respect_private_e. cbv. auto. constructor. intros [].
        intros. setoid_rewrite bind_trigger. pfold. constructor. intros [].
        cbv. auto.
    + destruct (priv_map x) eqn : Hl.
      * apply respect_public'. cbv. rewrite Hl. auto.
        red. intros. cbn. apply secure_eqit_ret.  split; auto. cbv. rewrite H1; auto.
      * apply respect_private_ne. cbv. rewrite Hl. auto.
        constructor. exact 0. intros. cbn. apply terminates_ret. red. intros. auto.
    + destruct (priv_map x) eqn : Hl.
      * apply respect_public'. cbv. rewrite Hl. auto.
        red. intros. cbn. apply secure_eqit_ret. split; auto.
        cbn. apply low_equiv_update_public; auto.
      * apply respect_private_ne. cbv. rewrite Hl. auto.
        constructor. exact tt. intros. cbn. apply terminates_ret.
        apply low_equiv_update_private_r; auto. red; intros; auto.
    + destruct s.
      * eapply respect_public'. cbv. auto. red. intros. cbn.
        setoid_rewrite bind_trigger. apply eqit_secure_public_Vis. cbv. auto.
        intros []. apply secure_eqit_ret. split; auto.
      * eapply respect_private_ne. cbv. auto. constructor. exact tt.
        intros. cbn. setoid_rewrite bind_trigger. apply terminates_vis.
        intros []. apply terminates_ret. red; intros; auto.
         cbn. split; auto. constructor. exact tt.
Qed.
*)
End LabelledImpHandler.


Module Type T1.
  Parameter t : Type.
End T1.

Module Type T2.
  Declare Module M : T1.
  Parameter t : Type.
  Parameter test : t = M.t.
End T2.

Module M1 <: T1.
  Definition t : Type := bool.
End M1.

Module M2 <: T2.
  Module M := M1.
  Definition t : Type := nat.
  Lemma test : t = t. Proof. reflexivity. Qed.
End M2.


(** This file implements symbolic evaluation for the
 ** language defined in IL.v
 **)
Require Import Word.
Require Import PropX.
Require Import Expr SepExpr.
Require Import Prover.
Require Import Env.
Require Structured SymEval.
Import List.

Require Import IL SepIL ILEnv.

Set Implicit Arguments.
Set Strict Implicit.

(** The Symbolic Evaluation Interfaces *)
Module MEVAL := SymEval.SymbolicEvaluator SH.

Section typed.
  Variable types : list type.
  Variables pcT stT : tvar.

  (** Symbolic registers **)
  Definition SymRegType : Type :=
    (expr types * expr types * expr types)%type.

  (** Symbolic State **)
  Record SymState : Type :=
  { SymMem   : option (SH.SHeap types pcT stT)
  ; SymRegs  : SymRegType
  ; SymPures : list (expr types)
  }.

  (** Register accessor functions **)
  Definition sym_getReg (r : reg) (sr : SymRegType) : expr types :=
    match r with
      | Sp => fst (fst sr)
      | Rp => snd (fst sr)
      | Rv => snd sr
    end.

  Definition sym_setReg (r : reg) (v : expr types) (sr : SymRegType) : SymRegType :=
    match r with
      | Sp => (v, snd (fst sr), snd sr)
      | Rp => (fst (fst sr), v, snd sr)
      | Rv => (fst sr, v)
    end.

  (** These the reflected version of the IL, it essentially
   ** replaces all uses of W with expr types so that the value
   ** can be inspected.
   **)
  Inductive sym_loc :=
  | SymReg : reg -> sym_loc
  | SymImm : expr types -> sym_loc
  | SymIndir : reg -> expr types -> sym_loc.

  (* Valid targets of assignments *)
  Inductive sym_lvalue :=
  | SymLvReg : reg -> sym_lvalue
  | SymLvMem : sym_loc -> sym_lvalue
  | SymLvMem8 : sym_loc -> sym_lvalue.

  (* Operands *)
  Inductive sym_rvalue :=
  | SymRvLval : sym_lvalue -> sym_rvalue
  | SymRvImm : expr types -> sym_rvalue
  | SymRvLabel : label -> sym_rvalue.

  (* Non-control-flow instructions *)
  Inductive sym_instr :=
  | SymAssign : sym_lvalue -> sym_rvalue -> sym_instr
  | SymBinop : sym_lvalue -> sym_rvalue -> binop -> sym_rvalue -> sym_instr.

  Inductive sym_assert :=
  | SymAssertCond : sym_rvalue -> test -> sym_rvalue -> option bool -> sym_assert.

  Definition istream : Type := list ((list sym_instr * option state) + sym_assert).
End typed.

Section stateD.
  Notation pcT := (tvType 0).
  Notation tvWord := (tvType 0).
  Notation stT := (tvType 1).
  Notation tvState := (tvType 2).
  Notation tvTest := (tvType 3).
  Notation tvReg := (tvType 4).

  Variable types' : list type.
  Notation TYPES := (repr bedrock_types_r types').
  Variable funcs : functions TYPES.
  Variable sfuncs : SEP.predicates TYPES pcT stT.

  Definition stateD (uvars vars : env TYPES) cs (stn_st : IL.settings * state) (ss : SymState TYPES pcT stT) : Prop :=
    let (stn,st) := stn_st in
    match ss with
      | {| SymMem := m ; SymRegs := (sp, rp, rv) ; SymPures := pures |} =>
        match
          exprD funcs uvars vars sp tvWord ,
          exprD funcs uvars vars rp tvWord ,
          exprD funcs uvars vars rv tvWord
          with
          | Some sp , Some rp , Some rv =>
            Regs st Sp = sp /\ Regs st Rp = rp /\ Regs st Rv = rv
          | _ , _ , _ => False
        end
        /\ match m with
             | None => True
             | Some m =>
               PropX.interp cs (SepIL.SepFormula.sepFormula (SEP.sexprD funcs sfuncs uvars vars (SH.sheapD m)) stn_st)%PropX
           end
        /\ AllProvable funcs uvars vars (match m with
                                           | None => pures
                                           | Some m => pures ++ SH.pures m
                                         end)
    end.

  Definition qstateD (uvars vars : env TYPES) cs (stn_st : IL.settings * state) (qs : SymEval.Quant) (ss : SymState TYPES pcT stT) : Prop :=
    SymEval.quantD vars uvars qs (fun vars_env meta_env => stateD meta_env vars_env cs stn_st ss).

End stateD.

Implicit Arguments sym_loc [ ].
Implicit Arguments sym_lvalue [ ].
Implicit Arguments sym_rvalue [ ].
Implicit Arguments sym_instr [ ].
Implicit Arguments sym_assert [ ].

Section Denotations.
  Variable types' : list type.
  Notation TYPES := (repr bedrock_types_r types').

  Notation pcT := (tvType 0).
  Notation tvWord := (tvType 0).
  Notation stT := (tvType 1).
  Notation tvState := (tvType 2).
  Notation tvTest := (tvType 3).
  Notation tvReg := (tvType 4).

  (** Denotation/reflection functions give the meaning of the reflected syntax *)
  Variable funcs' : functions TYPES.
  Notation funcs := (repr (bedrock_funcs_r types') funcs').
  Variable sfuncs : SEP.predicates TYPES pcT stT.
  Variable uvars vars : env TYPES.

  Definition sym_regsD (rs : SymRegType TYPES) : option regs :=
    match rs with
      | (sp, rp, rv) =>
        match
          exprD funcs uvars vars sp tvWord ,
          exprD funcs uvars vars rp tvWord ,
          exprD funcs uvars vars rv tvWord
          with
          | Some sp , Some rp , Some rv =>
            Some (fun r =>
              match r with
                | Sp => sp
                | Rp => rp
                | Rv => rv
              end)
          | _ , _ , _ => None
        end
    end.

  Definition sym_locD (s : sym_loc TYPES) : option loc :=
    match s with
      | SymReg r => Some (Reg r)
      | SymImm e =>
        match exprD funcs uvars vars e tvWord with
          | Some e => Some (Imm e)
          | None => None
        end
      | SymIndir r o =>
        match exprD funcs uvars vars o tvWord with
          | Some o => Some (Indir r o)
          | None => None
        end
    end.

  Definition sym_lvalueD (s : sym_lvalue TYPES) : option lvalue :=
    match s with
      | SymLvReg r => Some (LvReg r)
      | SymLvMem l => match sym_locD l with
                        | Some l => Some (LvMem l)
                        | None => None
                      end
      | SymLvMem8 l => match sym_locD l with
                         | Some l => Some (LvMem8 l)
                         | None => None
                       end
    end.

  Definition sym_rvalueD (r : sym_rvalue TYPES) : option rvalue :=
    match r with
      | SymRvLval l => match sym_lvalueD l with
                         | Some l => Some (RvLval l)
                         | None => None
                       end
      | SymRvImm e => match exprD funcs uvars vars e tvWord with
                        | Some l => Some (RvImm l)
                        | None => None
                      end
      | SymRvLabel l => Some (RvLabel l)
    end.

  Definition sym_instrD (i : sym_instr TYPES) : option instr :=
    match i with
      | SymAssign l r =>
        match sym_lvalueD l , sym_rvalueD r with
          | Some l , Some r => Some (Assign l r)
          | _ , _ => None
        end
      | SymBinop lhs l o r =>
        match sym_lvalueD lhs , sym_rvalueD l , sym_rvalueD r with
          | Some lhs , Some l , Some r => Some (Binop lhs l o r)
          | _ , _ , _ => None
        end
    end.

  Fixpoint sym_instrsD (is : list (sym_instr TYPES)) : option (list instr) :=
    match is with
      | nil => Some nil
      | i :: is =>
        match sym_instrD i , sym_instrsD is with
          | Some i , Some is => Some (i :: is)
          | _ , _ => None
        end
    end.

  Fixpoint istreamD (is : istream TYPES) (stn : settings) (st : state) (res : option state) : Prop :=
    match is with
      | nil => Some st = res
      | inl (ins, st') :: is =>
        match sym_instrsD ins with
          | None => False
          | Some ins =>
            match st' with
              | None => evalInstrs stn st ins = None
              | Some st' => evalInstrs stn st ins = Some st' /\ istreamD is stn st' res
            end
        end
      | inr asrt :: is =>
        match asrt with
          | SymAssertCond l t r t' =>
            match sym_rvalueD l , sym_rvalueD r with
              | Some l , Some r =>
                match t' with
                  | None =>
                    Structured.evalCond l t r stn st = None
                  | Some t' =>
                    Structured.evalCond l t r stn st = Some t' /\ istreamD is stn st res
                end
              | _ , _ => False
            end
        end
    end.

  Section SymEvaluation.
    Variable Prover : ProverT TYPES.
    Variable meval : MEVAL.MemEvaluator TYPES pcT stT.

    Section with_facts.
    Variable Facts : Facts Prover.

    Definition sym_evalLoc (lv : sym_loc TYPES) (ss : SymState TYPES pcT stT) : expr TYPES :=
      match lv with
        | SymReg r => sym_getReg r (SymRegs ss)
        | SymImm l => l
        | SymIndir r w => fPlus (sym_getReg r (SymRegs ss)) w
      end.

    Definition sym_evalLval (lv : sym_lvalue TYPES) (val : expr TYPES) (ss : SymState TYPES pcT stT)
      : option (SymState TYPES pcT stT) :=
      match lv with
        | SymLvReg r =>
          Some {| SymMem := SymMem ss
                ; SymRegs := sym_setReg r val (SymRegs ss)
                ; SymPures := SymPures ss
                |}
        | SymLvMem l =>
          let l := sym_evalLoc l ss in
            match SymMem ss with
              | None => None
              | Some m =>
                match MEVAL.swrite_word meval _ Facts l val m with
                  | Some m =>
                    Some {| SymMem := Some m
                          ; SymRegs := SymRegs ss
                          ; SymPures := SymPures ss
                          |}
                  | None => None
                end
            end
        | SymLvMem8 l =>
          let l := sym_evalLoc l ss in
            match SymMem ss with
              | None => None
              | Some m =>
                match MEVAL.swrite_byte meval _ Facts l val m with
                  | Some m =>
                    Some {| SymMem := Some m
                          ; SymRegs := SymRegs ss
                          ; SymPures := SymPures ss
                          |}
                  | None => None
                end
            end
      end.

    Definition sym_evalRval (rv : sym_rvalue TYPES) (ss : SymState TYPES pcT stT) : option (expr TYPES) :=
      match rv with
        | SymRvLval (SymLvReg r) =>
          Some (sym_getReg r (SymRegs ss))
        | SymRvLval (SymLvMem l) =>
          let l := sym_evalLoc l ss in
            match SymMem ss with
              | None => None
              | Some m =>
                MEVAL.sread_word meval _ Facts l m
            end
        | SymRvLval (SymLvMem8 l) =>
          let l := sym_evalLoc l ss in
            match SymMem ss with
              | None => None
              | Some m =>
                MEVAL.sread_byte meval _ Facts l m
            end
        | SymRvImm w => Some w
        | SymRvLabel l => None (* TODO: can we use labels? it seems like we need to reflect these as words. *)
        (* an alternative would be to reflect these as a function call that does the positioning...
         * - it isn't clear that this can be done since the environment would need to depend on the settings.
         *)
        (*Some (Expr.Const (TYPES := TYPES) (t := tvType 2) l) *)
      end.

    Definition sym_assertTest (l : sym_rvalue TYPES) (t : test) (r : sym_rvalue TYPES) (ss : SymState TYPES pcT stT) (res : bool)
      : option (expr TYPES) :=
      let '(l, t, r) :=
        if res then (l, t, r)
        else match t with
               | IL.Eq => (l, IL.Ne, r)
               | IL.Ne => (l, IL.Eq, r)
               | IL.Lt => (r, IL.Le, l)
               | IL.Le => (r, IL.Lt, l)
             end
      in
      match sym_evalRval l ss , sym_evalRval r ss with
        | Some l , Some r =>
          Some match t with
                 | IL.Eq => Expr.Equal tvWord l r
                 | IL.Ne => Expr.Not (Expr.Equal tvWord l r)
                 | IL.Lt => Expr.Func 4 (l :: r :: nil)
                 | IL.Le => Expr.Not (Expr.Func 4 (r :: l :: nil))
          end
        | _ , _ => None
      end.

    Definition sym_evalInstr (i : sym_instr TYPES) (ss : SymState TYPES pcT stT) : option (SymState TYPES pcT stT) :=
      match i with
        | SymAssign lv rv =>
          match sym_evalRval rv ss with
            | None => None
            | Some rv => sym_evalLval lv rv ss
          end
        | SymBinop lv l o r =>
          match sym_evalRval l ss , sym_evalRval r ss with
            | Some l , Some r =>
              let v :=
                match o with
                  | Plus  => fPlus
                  | Minus => fMinus
                  | Times => fMult
                end _ l r
                in
                sym_evalLval lv v ss
            | _ , _ => None
          end
      end.

    Fixpoint sym_evalInstrs (is : list (sym_instr TYPES)) (ss : SymState TYPES pcT stT)
      : SymState TYPES pcT stT + (SymState TYPES pcT stT * list (sym_instr TYPES)) :=
      match is with
        | nil => inl ss
        | i :: is =>
          match sym_evalInstr i ss with
            | None => inr (ss, i :: is)
            | Some ss => sym_evalInstrs is ss
          end
      end.
    End with_facts.

    Variable learnHook : MEVAL.LearnHook TYPES (SymState TYPES pcT stT).

    Inductive SymResult : Type :=
    | Safe      : SymEval.Quant -> SymState TYPES pcT stT -> SymResult
(*    | Unsafe    : SymEval.Quant -> SymResult *)
    | SafeUntil : SymEval.Quant -> SymState TYPES pcT stT -> istream TYPES -> SymResult.

    Fixpoint sym_evalStream (facts : Facts Prover) (is : istream TYPES) (qs : SymEval.Quant) (u g : variables)
      (ss : SymState TYPES pcT stT) : SymResult :=
      match is with
        | nil => Safe qs ss
        | inl (ins, st) :: is =>
          match sym_evalInstrs facts ins ss with
            | inr (ss,rm) => SafeUntil qs ss (inl (rm, st) :: is)
            | inl ss => sym_evalStream facts is qs u g ss
          end
        | inr asrt :: is =>
          match asrt with
            | SymAssertCond l t r (Some res) =>
              match sym_assertTest facts l t r ss res with
                | Some sp =>
                  let facts' := Learn Prover facts (sp :: nil) in
                  let ss' :=
                    {| SymRegs := SymRegs ss
                     ; SymMem := SymMem ss
                     ; SymPures := sp :: SymPures ss
                     |}
                  in
                  let (ss', qs') := learnHook Prover u g ss' facts' (sp :: nil) in
                  sym_evalStream facts' is (SymEval.appendQ qs' qs) (u ++ SymEval.gatherAll qs') (g ++ SymEval.gatherEx qs') ss'
                | None => SafeUntil qs ss (inr asrt :: is)
              end
            | SymAssertCond l t r None =>
              match sym_evalRval facts l ss , sym_evalRval facts r ss with
                | None , _ => SafeUntil qs ss (inr asrt :: is)
                | _ , None => SafeUntil qs ss (inr asrt :: is)
                | Some _ , Some _ => sym_evalStream facts is qs u g ss
              end
          end
      end.
  End SymEvaluation.
End Denotations.

Definition IL_stn_st : Type := (IL.settings * IL.state)%type.

Section spec_functions.
  Variable ts : list type.
  Let types := repr core_bedrock_types_r ts.

  Local Notation "'pcT'" := (tvType 0).
  Local Notation "'tvWord'" := (tvType 0).
  Local Notation "'stT'" := (tvType 1).

  Definition IL_mem_satisfies (cs : PropX.codeSpec (tvarD types pcT) (tvarD types stT))
    (P : ST.hprop (tvarD types pcT) (tvarD types stT) nil) (stn_st : (tvarD types stT)) : Prop :=
    PropX.interp cs (SepIL.SepFormula.sepFormula P stn_st).

  Definition IL_ReadWord : IL_stn_st -> tvarD types tvWord -> option (tvarD types tvWord) :=
    (fun stn_st => IL.ReadWord (fst stn_st) (Mem (snd stn_st))).
  Definition IL_WriteWord : IL_stn_st -> tvarD types tvWord -> tvarD types tvWord -> option IL_stn_st :=
    (fun stn_st p v =>
      let (stn,st) := stn_st in
        match IL.WriteWord stn (Mem st) p v with
          | None => None
          | Some m => Some (stn, {| Regs := Regs st ; Mem := m |})
        end).

  Definition IL_ReadByte : IL_stn_st -> tvarD types tvWord -> option (tvarD types tvWord) :=
    (fun stn_st a => match IL.ReadByte (Mem (snd stn_st)) a with
                       | None => None
                       | Some b => Some (BtoW b)
                     end).
  Definition IL_WriteByte : IL_stn_st -> tvarD types tvWord -> tvarD types tvWord -> option IL_stn_st :=
    (fun stn_st p v =>
      let (stn,st) := stn_st in
        match IL.WriteByte (Mem st) p (WtoB v) with
          | None => None
          | Some m => Some (stn, {| Regs := Regs st ; Mem := m |})
        end).

  Theorem IL_mem_satisfies_himp : forall cs P Q stn_st,
    IL_mem_satisfies cs P stn_st ->
    ST.himp cs P Q ->
    IL_mem_satisfies cs Q stn_st.
  Proof.
    unfold IL_mem_satisfies; intros.
    eapply sepFormula_himp_imply in H0.
    2: eapply (refl_equal stn_st). unfold PropXRel.PropX_imply in *.
    eapply PropX.Imply_E; eauto.
  Qed.
  Theorem IL_mem_satisfies_pure : forall cs p Q stn_st,
    IL_mem_satisfies cs (ST.star (ST.inj p) Q) stn_st ->
    interp cs p.
  Proof.
    unfold IL_mem_satisfies; intros.
    rewrite sepFormula_eq in H.
    PropXTac.propxFo; auto.
  Qed.

  Section ForWord.
    Local Notation "'ptrT'" := (tvType 0) (only parsing).
    Local Notation "'valT'" := (tvType 0) (only parsing).

    Variable mep : MEVAL.PredEval.MemEvalPred types.
    Variable pred : SEP.predicate types pcT stT.
    Variable funcs : functions types.

    Hypothesis read_pred_correct : forall P (PE : ProverT_correct P funcs),
      forall args uvars vars cs facts pe p ve stn st,
        MEVAL.PredEval.pred_read_word mep P facts args pe = Some ve ->
        Valid PE uvars vars facts ->
        exprD funcs uvars vars pe ptrT = Some p ->
        match
          applyD (exprD funcs uvars vars) (SEP.SDomain pred) args _ (SEP.SDenotation pred)
          with
          | None => False
          | Some p => ST.satisfies cs p stn st
        end ->
        match exprD funcs uvars vars ve valT with
          | Some v =>
            ST.HT.smem_get_word (implode stn) p st = Some v
          | _ => False
        end.

    Hypothesis write_pred_correct : forall P (PE : ProverT_correct P funcs),
      forall args uvars vars cs facts pe p ve v stn st args',
        MEVAL.PredEval.pred_write_word mep P facts args pe ve = Some args' ->
        Valid PE uvars vars facts ->
        exprD funcs uvars vars pe ptrT = Some p ->
        exprD funcs uvars vars ve valT = Some v ->
        match
          applyD (@exprD _ funcs uvars vars) (SEP.SDomain pred) args _ (SEP.SDenotation pred)
          with
          | None => False
          | Some p => ST.satisfies cs p stn st
        end ->
        match
          applyD (@exprD _ funcs uvars vars) (SEP.SDomain pred) args' _ (SEP.SDenotation pred)
          with
          | None => False
          | Some pr =>
            match ST.HT.smem_set_word (explode stn) p v st with
              | None => False
              | Some sm' => ST.satisfies cs pr stn sm'
            end
        end.

    Hypothesis read_pred_byte_correct : forall P (PE : ProverT_correct P funcs),
      forall args uvars vars cs facts pe p ve stn st,
        MEVAL.PredEval.pred_read_byte mep P facts args pe = Some ve ->
        Valid PE uvars vars facts ->
        exprD funcs uvars vars pe ptrT = Some p ->
        match
          applyD (exprD funcs uvars vars) (SEP.SDomain pred) args _ (SEP.SDenotation pred)
          with
          | None => False
          | Some p => ST.satisfies cs p stn st
        end ->
        match ST.HT.smem_get p st with
          | Some b => exprD funcs uvars vars ve valT = Some (BtoW b)
          | _ => False
        end.

    Hypothesis write_pred_byte_correct : forall P (PE : ProverT_correct P funcs),
      forall args uvars vars cs facts pe p ve v stn st args',
        MEVAL.PredEval.pred_write_byte mep P facts args pe ve = Some args' ->
        Valid PE uvars vars facts ->
        exprD funcs uvars vars pe ptrT = Some p ->
        exprD funcs uvars vars ve valT = Some v ->
        match
          applyD (@exprD _ funcs uvars vars) (SEP.SDomain pred) args _ (SEP.SDenotation pred)
          with
          | None => False
          | Some p => ST.satisfies cs p stn st
        end ->
        match
          applyD (@exprD _ funcs uvars vars) (SEP.SDomain pred) args' _ (SEP.SDenotation pred)
          with
          | None => False
          | Some pr =>
            match ST.HT.smem_set p (WtoB v) st with
              | None => False
              | Some sm' => ST.satisfies cs pr stn sm'
            end
        end.

    Theorem interp_satisfies : forall cs P stn st,
      PropX.interp cs (SepIL.SepFormula.sepFormula P (stn,st)) <->
      (HT.satisfies (memoryIn (IL.Mem st)) (IL.Mem st) /\ ST.satisfies cs P stn (memoryIn (IL.Mem st))).
    Proof.
      clear. intros. rewrite sepFormula_eq. unfold sepFormula_def. simpl in *.
      intuition. eapply ST.HT.satisfies_memoryIn.
    Qed.

    Require Import Reflection.

    Ltac think :=
      repeat match goal with
               | [ H : exists x , _ |- _ ] => destruct H
               | [ H : _ /\ _ |- _ ] => destruct H
             end.

    (** TODO: find a better place for these! **)
    Lemma mem_set_relevant_memoryIn : forall m p v m',
      H.mem_set m p v = Some m' ->
      relevant (memoryIn m) = relevant (memoryIn m').
    Proof.
      clear. do 5 intro. unfold relevant, memoryIn, HT.memoryIn. generalize H.all_addr.
      induction l; simpl; auto; intros.
      unfold H.mem_set, WriteByte, H.mem_get, ReadByte in *.
      destruct (equiv_dec a p); unfold equiv in *; subst.
      destruct (m p); try congruence. inversion H; simpl in *. destruct (weq p p); try congruence.

      destruct (m p); try congruence. inversion H. subst.
      destruct (weq a p). subst; congruence.
      rewrite IHl. reflexivity.
    Qed.

    Lemma mem_set_word_relevant_memoryIn : forall (p v : Memory.W) x1 m p0,
      Memory.mem_set_word H.addr H.mem H.footprint_w H.mem_set p0 p v m =
      Some x1 -> relevant (memoryIn x1) = relevant (memoryIn m).
    Proof.
      clear.
      unfold Memory.mem_set_word; do 2 intro. destruct (H.footprint_w p).
      destruct p1. destruct p1. do 2 destruct p0. destruct p1.
      repeat match goal with
               | [ |- match ?X with _ => _ end = _ -> _ ] => case_eq X; try congruence; intro; intro
               | [ |- _ -> _ ] => intros
               | [ H : H.mem_set _ _ _ = Some _ |- _ ] =>
                 eapply mem_set_relevant_memoryIn in H
             end.
      congruence.
    Qed.

    Lemma mep_correct : @MEVAL.PredEval.MemEvalPred_correct types pcT stT (IL.settings * IL.state)
      (tvType 0) (tvType 0) IL_mem_satisfies IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte mep pred funcs.
    Proof.
      constructor; intros; destruct stn_st as [ stn st ];
        match goal with
          | [ H : match ?X with _ => _ end |- _ ] =>
            revert H; case_eq X; intros; try contradiction
        end.

      { eapply interp_satisfies in H3. think.
        apply satisfies_star in H4. think.
        eapply read_pred_correct in H; eauto.
        Focus 2. simpl in *.
        match goal with
          | [ H : applyD ?A ?B ?C ?D ?E = _ |- match ?X with _ => _ end ] =>
            change X with (applyD A B C D E); rewrite H
        end. eassumption.

        revert H; consider (exprD funcs uvars vars ve tvWord); intros; auto.
        unfold IL_ReadWord, ReadWord. simpl.
        eapply satisfies_get_word; eauto.
        eapply split_smem_get_word; eauto. }

      { eapply interp_satisfies in H4. think.
        apply satisfies_star in H5. think.
        eapply write_pred_correct in H; eauto.
        Focus 2. simpl in *.
        match goal with
          | [ H : applyD ?A ?B ?C ?D ?E = _ |- match ?X with _ => _ end ] =>
            change X with (applyD A B C D E); rewrite H
        end. eassumption.
        revert H.
        match goal with
          | [ |- match ?X with _ => _ end -> match ?Y with _ => _ end ] =>
            change X with Y; consider Y; intros; auto
        end.
        revert H8. consider (smem_set_word (explode stn) p v x); try contradiction; intros.
        unfold IL_WriteWord, WriteWord in *.
        unfold split in *. intuition.
        eapply split_set_word in H8; eauto. think.
        generalize H8.
        eapply satisfies_set_word in H8; eauto. think.
        simpl in *. rewrite H8. unfold IL_mem_satisfies.
        generalize satisfies_star. unfold ST.satisfies. rewrite sepFormula_eq. unfold sepFormula_def; simpl.
        intros. eapply H13; clear H13. exists s. exists x0. intuition.
        unfold split. intuition.
        eapply relevant_eq; eauto. 2: apply satisfies_memoryIn.
        eapply smem_set_word_relevant in H14. rewrite <- H14. rewrite <- H11.

        eapply mem_set_word_relevant_memoryIn; eauto.
        rewrite <- H11; apply satisfies_memoryIn. }

      { eapply interp_satisfies in H3. think.
        apply satisfies_star in H4. think.
        eapply read_pred_byte_correct in H; eauto.
        Focus 2. simpl in *.
        match goal with
          | [ H : applyD ?A ?B ?C ?D ?E = _ |- match ?X with _ => _ end ] =>
            change X with (applyD A B C D E); rewrite H
        end. eassumption.

        consider (smem_get p x); intros; auto; try tauto.
        revert H; consider (exprD funcs uvars vars ve tvWord); intros; auto; try discriminate.
        injection H7; clear H7; intros; subst.
        unfold IL_ReadByte, ReadByte. simpl.
        eapply split_smem_get in H4; eauto.
        eapply satisfies_get in H4; eauto.
        unfold H.mem_get, ReadByte in H4; rewrite H4.
        reflexivity. }

      { eapply interp_satisfies in H4. think.
        apply satisfies_star in H5. think.
        eapply write_pred_byte_correct in H; eauto.
        Focus 2. simpl in *.
        match goal with
          | [ H : applyD ?A ?B ?C ?D ?E = _ |- match ?X with _ => _ end ] =>
            change X with (applyD A B C D E); rewrite H
        end. eassumption.
        revert H.
        match goal with
          | [ |- match ?X with _ => _ end -> match ?Y with _ => _ end ] =>
            change X with Y; consider Y; intros; auto
        end.
        revert H8. consider (smem_set p (WtoB v) x); try contradiction; intros.
        unfold IL_WriteByte, WriteByte in *.

        Lemma smem_set'_present : forall p v ls m m',
          smem_set' ls p v m = Some m'
          -> exists v', smem_get' ls p m = Some v'.
          clear; induction ls; simpl; intuition.
          discriminate.
          destruct (H.addr_dec a p); subst; eauto.
          destruct (DepList.hlist_hd m); eauto; discriminate.
          specialize (IHls (DepList.hlist_tl m)).
          destruct (smem_set' ls p v (DepList.hlist_tl m)); eauto; discriminate.
        Qed.

        Lemma smem_set_present : forall p v m m',
          smem_set p v m = Some m'
          -> exists v', smem_get p m = Some v'.
          intros; eapply smem_set'_present; eauto.
        Qed.

        destruct (smem_set_present _ _ _ H8).
        generalize H5; intro Ho; eapply split_smem_get in Ho; eauto.
        eapply satisfies_get in Ho; eauto.
        unfold H.mem_get, ReadByte in Ho; rewrite Ho.
        hnf; rewrite sepFormula_eq; PropXTac.propxFo.
        exists s; exists x0; intuition.
        unfold split in *; intuition.

        Lemma smem_set'_disjoint : forall p v ls m m' m'',
          smem_set' ls p v m = Some m'
          -> disjoint' ls m m''
          -> disjoint' ls m' m''.
          clear; induction ls; simpl; intuition.
          destruct (H.addr_dec a p); subst.
          rewrite H0 in H; discriminate.
          specialize (IHls (DepList.hlist_tl m)).
          destruct (smem_set' ls p v (DepList.hlist_tl m)); try discriminate.
          injection H; clear H; intros; subst; auto.
          destruct (H.addr_dec a p); subst.
          rewrite H0 in H; discriminate.
          specialize (IHls (DepList.hlist_tl m)).
          destruct (smem_set' ls p v (DepList.hlist_tl m)); try discriminate.
          injection H; clear H; intros; subst; auto.
          destruct (H.addr_dec a p); subst.
          destruct (DepList.hlist_hd m); try discriminate.
          injection H; clear H; intros; subst; auto.
          specialize (IHls (DepList.hlist_tl m)).
          destruct (smem_set' ls p v (DepList.hlist_tl m)); try discriminate.
          injection H; clear H; intros; subst; auto.
        Qed.

        Lemma smem_set_disjoint : forall p v m m' m'',
          smem_set p v m = Some m'
          -> disjoint m m''
          -> disjoint m' m''.
          intros; eapply smem_set'_disjoint; eauto.
        Qed.

        eauto using smem_set_disjoint.

        Lemma parts : forall A (B : A -> Type) x ls (h1 h2 : B x) (t1 t2 : DepList.hlist B ls),
          DepList.HCons h1 t1 = DepList.HCons h2 t2
          -> h1 = h2 /\ t1 = t2.
          clear; intros.
          assert (DepList.hlist_hd (DepList.HCons h1 t1) = DepList.hlist_hd (DepList.HCons h2 t2)) by congruence.
          assert (DepList.hlist_tl (DepList.HCons h1 t1) = DepList.hlist_tl (DepList.HCons h2 t2)) by congruence.
          auto.
        Qed.

        Lemma memoryIn'_agree : forall ls m1 m2,
          List.Forall (fun p => m1 p = m2 p) ls
          -> memoryIn' m1 ls = memoryIn' m2 ls.
          clear; induction 1; simpl; intuition.
          f_equal; auto.
        Qed.

        Lemma memoryIn'_join : forall m p v ls, NoDup ls
          -> forall m1 m2 m1',
            memoryIn' m ls = join' ls m1 m2
            -> smem_set' ls p v m1 = Some m1'
            -> memoryIn' (fun p' => if weq p' p then Some v else m p') ls = join' ls m1' m2.
          clear; induction 1; simpl; intuition.
          apply parts in H1; destruct H1.
          destruct (H.addr_dec x p); subst.
          destruct (DepList.hlist_hd m1); try discriminate.
          injection H2; clear H2; intros; subst.
          simpl.
          f_equal.
          unfold H.mem_get, ReadByte; destruct (weq p p); tauto.
          rewrite (@memoryIn'_agree _ _ m); auto.
          apply Forall_forall; intros.
          destruct (weq x p); subst; tauto.
          specialize (IHNoDup (DepList.hlist_tl m1)).
          destruct (smem_set' l p v (DepList.hlist_tl m1)); try discriminate.
          rewrite (IHNoDup _ _ H3 eq_refl); clear IHNoDup.
          injection H2; clear H2; intros; subst; simpl.
          f_equal; auto.
          unfold H.mem_get, ReadByte.
          destruct (weq x p); intuition.
        Qed.

        Lemma memoryIn_join : forall m m1 m2 p v m1',
          memoryIn m = join m1 m2
          -> smem_set p v m1 = Some m1'
          -> memoryIn (fun p' => if weq p' p then Some v else m p') = join m1' m2.
          intros; eapply memoryIn'_join; eauto using H.NoDup_all_addr.
        Qed.

        eauto using memoryIn_join. }
    Qed.

    Variable predIndex : nat.

    Theorem MemPredEval_To_MemEvaluator_correct preds :
      nth_error preds predIndex = Some pred ->
      @MEVAL.MemEvaluator_correct types pcT stT
      (@MEVAL.PredEval.MemEvalPred_to_MemEvaluator _ pcT stT mep predIndex) funcs preds
      (IL.settings * IL.state) (tvType 0) (tvType 0) IL_mem_satisfies
      IL_ReadWord IL_WriteWord IL_ReadByte IL_WriteByte.
    Proof.
      intros.
      eapply MEVAL.PredEval.MemEvaluator_MemEvalPred_correct; simpl;
        try eauto using IL_mem_satisfies_himp, IL_mem_satisfies_pure, mep_correct.
    Qed.

  End ForWord.

End spec_functions.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** These are the notations whose level and associativity are imposed by Coq *)

(** Notations for propositional connectives *)

Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
Reserved Notation "x <-> y" (at level 95, no associativity).
Reserved Notation "x /\ y" (at level 80, right associativity).
Reserved Notation "x \/ y" (at level 85, right associativity).
Reserved Notation "x |_| y" (at level 85, right associativity).
Reserved Notation "~ x" (at level 75, right associativity).

(** Notations for equality and inequalities *)

Reserved Notation "x = y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x = y" (at level 70, no associativity).
Reserved Notation "x = y = z"
(at level 70, no associativity, y at next level).

Reserved Notation "x <> y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x <> y" (at level 70, no associativity).

Reserved Notation "x <= y" (at level 70, no associativity).
Reserved Notation "x < y" (at level 70, no associativity).
Reserved Notation "x >= y" (at level 70, no associativity).
Reserved Notation "x > y" (at level 70, no associativity).

Reserved Notation "x <= y <= z" (at level 70, y at next level).
Reserved Notation "x <= y < z" (at level 70, y at next level).
Reserved Notation "x < y < z" (at level 70, y at next level).
Reserved Notation "x < y <= z" (at level 70, y at next level).

(** Arithmetical notations (also used for type constructors) *)

Reserved Notation "x + y" (at level 50, left associativity).
Reserved Notation "x - y" (at level 50, left associativity).
Reserved Notation "x * y" (at level 40, left associativity).
Reserved Notation "x / y" (at level 40, left associativity).
Reserved Notation "- x" (at level 35, right associativity).
Reserved Notation "/ x" (at level 35, right associativity).
Reserved Notation "x ^ y" (at level 30, right associativity).

(** Notations for booleans *)

Reserved Notation "x || y" (at level 50, left associativity).
Reserved Notation "x && y" (at level 40, left associativity).

(** Notations for pairs *)

Reserved Notation "( x , y , .. , z )" (at level 0).

(** Notation "{ x }" is reserved and has a special status as component
    of other notations such as "{ A } + { B }" and "A + { B }" (which
    are at the same level as "x + y");
    "{ x }" is at level 0 to factor with "{ x : A | P }" *)

Reserved Notation "{ x }" (at level 0, x at level 99).

(** Notations for sigma-types or subsets *)

Reserved Notation "{ x  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  & P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  & P  & Q }" (at level 0, x at level 99).

Declare Scope core_scope.
Delimit Scope core_scope with core.

Declare Scope function_scope.
Delimit Scope function_scope with function.
Bind Scope function_scope with Funclass.

Declare Scope type_scope.
Delimit Scope type_scope with type.
Bind Scope type_scope with Sortclass.

Open Scope core_scope.
Open Scope function_scope.
Open Scope type_scope.

(** ML Tactic Notations *)

Declare ML Module "ltac_plugin".

Global Set Default Proof Mode "Classic".


Require Import Coq.Lists.List.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.ExtPred.
Require Import ProD3.core.Result.
Require Import ProD3.core.FuncSpec.
Require Import Hammer.Plugin.Hammer.

(* Section DisjointTest. *)

(* Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := ValueLvalue.

Notation ident := (String.string).
Notation path := (list ident).

Context `{target : @Target tags_t (@Expression tags_t)}. *)

Ltac res_list :=
  lazymatch goal with
  | |- res_list ?P ?l =>
      first [
        apply rnil
      | apply rcons;
        only 2 : res_list
      ]
  | |- _ =>
      fail "The goal is not (res_list _ _)"
  end.

(* Import String.
Open Scope string_scope. *)

Lemma disjoint_cancel : forall p q1 q2,
  disjoint q1 q2 ->
  disjoint (p ++ q1) (p ++ q2).
Proof.
  induction p; intros.
  - auto.
  - simpl.
    replace (String.eqb a a) with true by hauto use: String.eqb_eq.
    auto.
Qed.

(* This is a preliminary implementation. It only tests verbatim paths. We use this tactic to
  test the rest tactics. *)
Ltac test_disjoint :=
  refine (@id (result (disjoint _ _)) _);
  first [
    left; try apply disjoint_cancel; reflexivity
  | right; exact I
  ].

(* Axiom p : list string.
Definition x := result (disjoint (p ++ ["a"]) (p ++ ["c"])).

Goal x.
  test_disjoint.
  Show Proof.
Abort.

Goal result (disjoint [] ["c"]).
  test_disjoint.
  Show Proof.
Abort. *)

Ltac test_ext_exclude :=
  res_list;
  apply Result.forallb;
  res_list;
  apply Result.forallb;
  res_list;
  test_disjoint.


(** * Functoriality of the comma category construction *)
Require Import Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core NaturalTransformation.Composition.Core.
Require Import NaturalTransformation.Composition.Laws.
Require Import Functor.Paths.
Require Import Category.Strict.
Require Comma.Core.
Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)
Import Comma.Core.
Local Set Warnings Append "notation-overridden".
Import Functor.Identity.FunctorIdentityNotations NaturalTransformation.Identity.NaturalTransformationIdentityNotations.
Require Import HoTT.Tactics PathGroupoids Types.Forall.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.
Local Open Scope category_scope.

(** The comma category construction is functorial in its category
    arguments.  We really should be using ∏ (dependent product) here,
    but I'm lazy, and will instead expand it out. *)

Local Ltac helper_t fwd_tac bak_tac fin :=
  repeat
    first [ fin
          | rewrite <- ?Category.Core.associativity;
            progress repeat first [ bak_tac
                                  | apply ap10; apply ap ]
          | rewrite -> ?Category.Core.associativity;
            progress repeat first [ fwd_tac
                                  | apply ap ]
          | rewrite <- !composition_of ].

Local Tactic Notation "helper" tactic(fin) constr(hyp_fwd) constr(hyp_bak) :=
  let H := fresh in
  let H' := fresh in
  pose proof hyp_fwd as H;
    pose proof hyp_bak as H';
    simpl in *;
    helper_t ltac:(rewrite -> H) ltac:(rewrite <- H') fin.

Local Ltac functorial_helper_t unfold_lem :=
  repeat (apply path_forall || intro); simpl;
  rewrite !transport_forall_constant; simpl;
  transport_path_forall_hammer; simpl;
  apply CommaCategory.path_morphism; simpl;
  unfold unfold_lem; simpl;
  repeat match goal with
           | _ => exact idpath
           | [ |- context[CommaCategory.g (transport ?P ?p ?z)] ]
             => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => @CommaCategory.g _ _ _ _ _ _ _) z)
           | [ |- context[CommaCategory.h (transport ?P ?p ?z)] ]
             => simpl rewrite (@ap_transport _ P _ _ _ p (fun _ => @CommaCategory.h _ _ _ _ _ _ _) z)
           | [ |- context[transport (fun y => ?f (?g y) ?z)] ]
             => simpl rewrite (fun a b => @transport_compose _ _ a b (fun y => f y z) g)
           | [ |- context[transport (fun y => ?f (?g y))] ]
             => simpl rewrite (fun a b => @transport_compose _ _ a b (fun y => f y) g)
           | _ => rewrite !CommaCategory.ap_a_path_object'; simpl
           | _ => rewrite !CommaCategory.ap_b_path_object'; simpl
         end.

Section functorial.
  Section single_source.
    Variables A B C : PreCategory.
    Variable S : Functor A C.
    Variable T : Functor B C.

    Section morphism_of.
      Variables A' B' C' : PreCategory.
      Variable S' : Functor A' C'.
      Variable T' : Functor B' C'.

      Variable AF : Functor A A'.
      Variable BF : Functor B B'.
      Variable CF : Functor C C'.

      Variable TA : NaturalTransformation (S' o AF) (CF o S).
      Variable TB : NaturalTransformation (CF o T) (T' o BF).

      Definition functorial_morphism_of_object_of : (S / T) -> (S' / T')
        := fun x => CommaCategory.Build_object
                      S' T'
                      (AF (CommaCategory.a x))
                      (BF (CommaCategory.b x))
                      (TB (CommaCategory.b x) o CF _1 (CommaCategory.f x) o TA (CommaCategory.a x)).

      Definition functorial_morphism_of_morphism_of
                 s d (m : morphism (S / T) s d)
      : morphism (S' / T') (functorial_morphism_of_object_of s) (functorial_morphism_of_object_of d).
      Proof.
        simpl in *.
        refine (CommaCategory.Build_morphism
                  (functorial_morphism_of_object_of s)
                  (functorial_morphism_of_object_of d)
                  (AF _1 (CommaCategory.g m))
                  (BF _1 (CommaCategory.h m))
                  _).
        unfold functorial_morphism_of_object_of; simpl.
        clear.
        abstract helper (exact (CommaCategory.p m)) (commutes TA) (commutes TB).
      Defined.

      Definition functorial_morphism_of : Functor (S / T) (S' / T').
      Proof.
        refine (Build_Functor
                  (S / T) (S' / T')
                  functorial_morphism_of_object_of
                  functorial_morphism_of_morphism_of
                  _
                  _);
        abstract (
            intros;
            apply CommaCategory.path_morphism; simpl;
            auto with functor
          ).
      Defined.
    End morphism_of.

    Section identity_of.
      Definition functorial_identity_of_helper x
      : @functorial_morphism_of_object_of _ _ _ S T 1 1 1 1 1 x = x.
      Proof.
        let A := match goal with |- ?A = ?B => constr:(A) end in
        let B := match goal with |- ?A = ?B => constr:(B) end in
        refine (@CommaCategory.path_object' _ _ _ _ _ A B 1%path 1%path _).
        exact (Category.Core.right_identity _ _ _ _ @ Category.Core.left_identity _ _ _ _)%path.
      Defined.

      Definition functorial_identity_of `{Funext}
      : @functorial_morphism_of
          _ _ _ S T
          1 1 1 1 1
        = 1%functor.
      Proof.
        path_functor; simpl.
        exists (path_forall _ _ functorial_identity_of_helper).
        simpl.
        functorial_helper_t functorial_identity_of_helper.
      Qed.
    End identity_of.
  End single_source.

  Section composition_of.
    Variables A B C : PreCategory.
    Variable S : Functor A C.
    Variable T : Functor B C.

    Variables A' B' C' : PreCategory.
    Variable S' : Functor A' C'.
    Variable T' : Functor B' C'.

    Variables A'' B'' C'' : PreCategory.
    Variable S'' : Functor A'' C''.
    Variable T'' : Functor B'' C''.

    Variable AF : Functor A A'.
    Variable BF : Functor B B'.
    Variable CF : Functor C C'.

    Variable TA : NaturalTransformation (S' o AF) (CF o S).
    Variable TB : NaturalTransformation (CF o T) (T' o BF).

    Variable AF' : Functor A' A''.
    Variable BF' : Functor B' B''.
    Variable CF' : Functor C' C''.

    Variable TA' : NaturalTransformation (S'' o AF') (CF' o S').
    Variable TB' : NaturalTransformation (CF' o T') (T'' o BF').

    Let AF'' := (AF' o AF)%functor.
    Let BF'' := (BF' o BF)%functor.
    Let CF'' := (CF' o CF)%functor.

    Let TA'' : NaturalTransformation (S'' o AF'') (CF'' o S)
      := ((associator_2 _ _ _)
            o (CF' oL TA)
            o (associator_1 _ _ _)
            o (TA' oR AF)
            o associator_2 _ _ _)%natural_transformation.
    Let TB'' : NaturalTransformation (CF'' o T) (T'' o BF'')
      := ((associator_1 _ _ _)
            o (TB' oR BF)
            o (associator_2 _ _ _)
            o (CF' oL TB)
            o associator_1 _ _ _)%natural_transformation.

    Definition functorial_composition_of_helper x
    : (functorial_morphism_of TA' TB' o functorial_morphism_of TA TB)%functor x
      = functorial_morphism_of TA'' TB'' x.
    Proof.
      let A := match goal with |- ?A = ?B => constr:(A) end in
      let B := match goal with |- ?A = ?B => constr:(B) end in
      refine (@CommaCategory.path_object' _ _ _ _ _ A B 1%path 1%path _).
      subst AF'' BF'' CF'' TA'' TB''.
      simpl in *.
      abstract (
          autorewrite with morphism; simpl;
          helper (exact idpath) (commutes TA') (commutes TB')
        ).
    Defined.

    Definition functorial_composition_of `{Funext}
    : (functorial_morphism_of TA' TB' o functorial_morphism_of TA TB)%functor
      = functorial_morphism_of TA'' TB''.
    Proof.
      path_functor; simpl.
      exists (path_forall _ _ functorial_composition_of_helper).
      functorial_helper_t functorial_composition_of_helper.
    Qed.
  End composition_of.
End functorial.