Require Export WellFormedness.
Require Import SyntaxProp.
Require Import TypesProp.
Require Import Shared.

(*
========================
Field and method lookup
========================
*)

Lemma wfProgram_wfMethodDecl :
  forall P t' c ms m mtd,
    wfProgram P t' ->
    methods P (TClass c) = Some ms ->
    methodLookup ms m = Some mtd ->
    wfMethodDecl P c mtd.
Proof with auto.
  introv wfP Hmethods mLookup.
  inv wfP.
  unfold methods in Hmethods.
  remember (classLookup (cds, ids, e) c) as cLookup.
  symmetry in HeqcLookup.
  destruct cLookup as [[c' i fs ms'] |]...
  inv_eq.
  assert (Heq : c = c') by
      (unfold classLookup in HeqcLookup;
       apply find_true in HeqcLookup;
       apply beq_nat_eq; auto).
  subst.
  lookup_forall as wfCls.
  inv wfCls.
  lookup_forall mtd as wfMtd...
Qed.

Corollary dyn_wfFieldLookup :
  forall P Gamma c F fs f t r,
    wfFields P Gamma c F ->
    fields P (TClass c) = Some fs ->
    fieldLookup fs f = Some (Field f t r) ->
    exists v, F f = Some v /\ P; Gamma |- (EVal v) \in t.
Proof with eauto.
  introv wfF Hfields fLookup.
  inv wfF. rewrite_and_invert...
Qed.

Hint Immediate dyn_wfFieldLookup.

(*
------------
Method sigs
------------
*)

Hint Constructors methodSigs.

Lemma extractSigs_sound :
  forall mtds m x t t',
    (exists e, methodLookup mtds m = Some (Method m (x, t) t' e)) <->
    methodSigLookup (extractSigs mtds) m = Some (MethodSig m (x, t) t').
Proof with eauto.
  intros. split.
  + gen t t' m x.
    induction mtds as [|[m [x t] t' e]]; simpl;
    introv H; inv H as [e' Hsigs]...
    cases_if... inv_eq.
  + gen t t' m x.
    induction mtds as [|[m [x t] t' e]]; simpl;
    introv mLookup; inv mLookup...
    cases_if; crush...
Qed.

Lemma methodSigs_deterministic :
  forall P t msigs1 msigs2,
    methodSigs P t msigs1 ->
    methodSigs P t msigs2 ->
    msigs1 = msigs2.
Proof with eauto.
  introv Hsigs1 Hsigs2.
  gen msigs2.
  induction Hsigs1; introv Hsigs2;
  inv Hsigs2; try(rewrite_and_invert)...
  rewrite IHHsigs1_1 with msigs3...
  rewrite IHHsigs1_2 with msigs4...
Qed.

Lemma methodSigs_wfType_exists :
  forall P t' t,
    wfProgram P t' ->
    (wfType P t <->
     exists msigs, methodSigs P t msigs).
Proof with eauto.
  introv [? ? ? wfCds wfIds wfExpr].
  split.
  + intros wfT.
    inv wfT as [c cLookup|i iLookup|]...
    - apply classLookup_not_none in cLookup as [i [fs [ms]]]...
    - apply interfaceLookup_not_none in iLookup.
      inv iLookup as [[msigs]|[i1 [i2]]]...
      * intros. lookup_forall as wfId. inv wfId...
  + intros Hex. destruct Hex as [msigs Hsigs].
    destruct t; inv Hsigs; constructor; crush.
Qed.

Lemma methodSigs_sub :
  forall P t t1 t2 m msigs1 msigs2 msig,
    wfProgram P t ->
    subtypeOf P t1 t2 ->
    methodSigs P t1 msigs1 ->
    methodSigs P t2 msigs2 ->
    methodSigLookup msigs2 m = Some msig ->
    methodSigLookup msigs1 m = Some msig.
Proof with eauto using
                 methodSigs_deterministic,
                 methodSigs_wfType_exists,
                 subtypeOf_wfTypeSub,
                 subtypeOf_wfTypeSup.
  introv [? ? ? ? wfCds wfIds wfExpr] Hsub
         Hsigs1 Hsigs2 Hsig.
  gen msigs1 msigs2 msig.
  subtypeOf_cases(induction Hsub) Case; intros.
  + Case "Sub_Class".
    lookup_forall as wfCd. inv wfCd.
    assert (msigs2 = (extractSigs ms))...
    subst. inv Hsigs1; rewrite_and_invert.
  + Case "Sub_InterfaceLeft".
    inv Hsigs1; rewrite_and_invert.
    assert (msigs0 = msigs2)...
    subst. apply find_app...
  + inv Hsigs1; rewrite_and_invert.
    assert (msigs2 = msigs3)...
    subst. apply find_app2...
    lookup_forall as wfId.
    inverts wfId as Hsigs3 Hsigs4 sigsDisjoint1 sigsDisjoint2.
    assert (msigs0 = msigs1)...
    assert (msigs2 = msigs3)...
    subst. fold (methodSigLookup msigs1 m).
    eapply sigsDisjoint2...
  + asserts_rewrite (msigs1 = msigs2)...
  + rename msigs2 into msigs3.
    rename Hsigs2 into Hsigs3.
    assert (wfT1: wfType (cds, ids, e) t1)...
    assert (wfT2: wfType (cds, ids, e) t2)...
    eapply methodSigs_wfType_exists in wfT2 as []...
(*  + inv Hsigs2. inv Hsig.*)
Qed.

(*
==============
Configuration
==============
*)

(*
---------
wfFields
---------
*)

Lemma wfFields_declsToFields :
  forall P t' c i fs ms Gamma,
    wfProgram P t' ->
    wfEnv P Gamma ->
    classLookup P c = Some (Cls c i fs ms) ->
    wfFields P Gamma c (declsToFields fs).
Proof with eauto using
                 fields_wfFieldDecl,
                 declsToFields_null.
  introv wfProgram wfEnv Hlookup.
  assert (fields P (TClass c) = Some fs)
    by (unfolds; rewrite Hlookup; auto).
  assert (Forall (wfFieldDecl P) fs)...
  econstructor...
  intros.
  lookup_forall as wfF. inv wfF...
Qed.

Lemma wfFields_extend :
  forall P Gamma c fs f t r F v,
    fields P (TClass c) = Some fs ->
    fieldLookup fs f = Some (Field f t r) ->
    wfFields P Gamma c F ->
    P; Gamma |- EVal v \in t ->
    wfFields P Gamma c (extend F f v).
Proof with eauto with env.
  introv Hfields fLookup wfF hasType.
  econstructor...
  introv fLookup'.
  inv wfF.
  case_extend; repeat rewrite_and_invert...
Qed.

Lemma wfFields_envExtend :
  forall P t' Gamma c F l c',
    wfProgram P t' ->
    wfFields P Gamma c F ->
    wfEnv P Gamma ->
    fresh Gamma (env_loc l) ->
    wfType P (TClass c') ->
    wfFields P (extend Gamma (env_loc l) (TClass c')) c F.
Proof with eauto using hasType_extend_loc.
  introv wfP wfF wfGamma Hfresh wfT.
  inverts wfF as Hfields wfFlds.
  econstructor...
  introv Hlookup.
  apply wfFlds in Hlookup as (v & Heq & hasType)...
Qed.

Lemma wfFields_invariance :
  forall P t' c Gamma Gamma' F,
    wfProgram P t' ->
    (forall l, Gamma (env_loc l) = Gamma' (env_loc l)) ->
    wfEnv P Gamma' ->
    wfFields P Gamma c F ->
    wfFields P Gamma' c F.
Proof with eauto using hasType_wfType.
  introv wfP envSub wfGamma' wfF.
  inverts wfF as Hfields wfFld.
  econstructor...
  introv fLookup.
  apply wfFld in fLookup as (v & Ff & hasType).
  exists v. split...
  destruct v...
  + inv hasType.
    econstructor...
    rewrite <- envSub...
Qed.

Lemma wfHeap_wfObject :
  forall P Gamma H l c F RL,
    wfHeap P Gamma H ->
    heapLookup H l = Some (c, F, RL) ->
    wfFields P Gamma c F /\ wfRegionLocks P c RL.
Proof with eauto.
  introv wfH Hlookup.
  inverts wfH as _ envModelsHeap heapMirrorsEnv.
  assert (Hl: heapLookup H l <> None) by crush.
  apply heapMirrorsEnv in Hl.
  destruct Hl as [c' envLookup].
  apply envModelsHeap in envLookup as (F' & RL' & ? & ? & ?).
  rewrite_and_invert.
Qed.

Lemma wfHeap_wfFields :
  forall P Gamma H l c F RL,
    wfHeap P Gamma H ->
    heapLookup H l = Some (c, F, RL) ->
    wfFields P Gamma c F.
Proof with eauto.
  introv wfH Hlookup.
  eapply wfHeap_wfObject in Hlookup as []...
Qed.

Lemma wfHeap_wfRegionLocks :
  forall P Gamma H l c F RL,
    wfHeap P Gamma H ->
    heapLookup H l = Some (c, F, RL) ->
    wfRegionLocks P c RL.
Proof with eauto.
  introv wfH Hlookup.
  eapply wfHeap_wfObject in Hlookup as []...
Qed.

Lemma wfRegionLocks_declsToRegionLocks :
  forall P c fs RL,
    fields P (TClass c) = Some fs ->
    declsToRegionLocks fs RL ->
    wfRegionLocks P c RL.
Proof with eauto.
  introv fLookup HRL.
  inv HRL.
  econstructor...
Qed.

(*
-------
wfHeap
-------
*)

Hint Constructors wfHeap.

Lemma wfHeap_fresh :
  forall P Gamma H l,
    wfHeap P Gamma H ->
    heapLookup H l = None ->
    fresh Gamma (env_loc l).
Proof with eauto.
  introv wfH Hlookup.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  unfold fresh. remember (Gamma (env_loc l)) as t...
  destruct t...
  symmetry in Heqt.
  assert (tClass: exists c, t = TClass c) by (inv wfGamma; eauto).
  inv tClass as [c''].
  apply envModelsHeap in Heqt.
  inv Heqt as [F' [RL [contra]]]. rewrite_and_invert.
Qed.

Lemma wfHeap_extend :
  forall P t' Gamma H c F RL,
    wfProgram P t' ->
    wfHeap P Gamma H ->
    wfType P (TClass c) ->
    wfFields P Gamma c F ->
    wfRegionLocks P c RL ->
    wfHeap P (extend Gamma (env_loc (length H)) (TClass c)) (heapExtend H (c, F, RL)).
Proof with eauto using wfHeap_wfRegionLocks with env.
  introv wfP wfH wfT wfF wfRL.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  constructor...
  + introv envLookup.
    destruct (id_eq_dec l (length H)).
    - subst. simpl_extend_hyp. inv_eq.
      rewrite heapExtend_lookup_len.
      eexists; eexists; split; split...
      eapply wfFields_envExtend...
      eapply wfHeap_fresh...
      apply heapLookup_ge...
    - rewrite extend_neq in envLookup...
      rewrite heapExtend_lookup_nlen...
      apply envModelsHeap in envLookup as (F' & RL' & Hlookup & wfF' & wfRL')...
      eexists; eexists; split...
      split...
      eapply wfFields_envExtend...
      eapply wfHeap_fresh...
      apply heapLookup_ge...
  + introv Hlookup.
    destruct (id_eq_dec l (length H))...
    rewrite heapExtend_lookup_nlen in Hlookup...
Qed.

Lemma wfHeap_update :
  forall P Gamma H l c F RL RL' F',
    wfHeap P Gamma H ->
    heapLookup H l = Some (c, F, RL) ->
    wfFields P Gamma c F' ->
    wfRegionLocks P c RL' ->
    wfHeap P Gamma (heapUpdate H l (c, F', RL')).
Proof with eauto.
  introv wfH Hlookup wfF' wfRL'.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  constructor...
  + introv envLookup.
    destruct (id_eq_dec l l0).
    - subst.
      rewrite lookup_heapUpdate_eq
        by (apply heapLookup_lt; eauto).
      apply envModelsHeap in envLookup as (F'' & RL'' & Hlookup' & wfF'' & wfRL'').
      rewrite_and_invert...
    - rewrite lookup_heapUpdate_neq...
  + introv Hlookup'.
    apply heapMirrorsEnv.
    destruct (id_eq_dec l l0).
    - subst.
      rewrite heapLookup_not_none...
    - rewrite lookup_heapUpdate_neq in Hlookup'...
Qed.

Lemma wfHeap_invariance :
  forall P t' Gamma Gamma' H,
    wfProgram P t' ->
    (forall l, Gamma (env_loc l) = Gamma' (env_loc l)) ->
    wfEnv P Gamma' ->
    wfHeap P Gamma H ->
    wfHeap P Gamma' H.
Proof with eauto using wfFields_invariance.
  introv wfP envEquiv wfGamma' wfH.
  inverts wfH as wfGamma envModelsHeap heapMirrorsEnv.
  constructor...
  + introv envLookup. rewrite <- envEquiv in envLookup.
    apply envModelsHeap in envLookup.
    inv envLookup as (F & RL & Hlookup & wfF & wfRL)...
    exists F RL...
  + introv Hlookup. rewrite <- envEquiv...
Qed.

(*
--------
wfVars
--------
*)

Hint Constructors wfVars.

Lemma wfVars_invariance :
  forall P t' Gamma Gamma' fsyms V,
    wfProgram P t' ->
    (forall x, Gamma x = Gamma' x) ->
    wfEnv P Gamma' ->
    wfVars P Gamma fsyms V ->
    wfVars P Gamma' fsyms V.
Proof with eauto.
  introv wfP envEquiv wfGamma' wfV.
  inverts wfV as wfGamma envModelsVars varsMirrorEnv Hfresh.
  constructor...
  + introv Vlookup.
    rewrite <- envEquiv in Vlookup.
    apply envModelsVars in Vlookup as (v & Vlookup & hasType).
    eapply hasType_subsumption with (Gamma' := Gamma') in hasType; crush...
  + introv. rewrite <- envEquiv...
Qed.

Lemma wfVars_extend :
  forall P t' Gamma n m V v t,
    wfProgram P t' ->
    wfVars P Gamma n V ->
    P; Gamma |- EVal v \in t ->
    m < n ->
    wfVars P (extend Gamma (env_var (DV (DVar m))) t)
           n (extend V (DVar m) v).
Proof with eauto with env.
  introv wfP wfV hasType Hlt.
  inverts wfV as wfGamma envModelsVars varsMirrorEnv Hfresh.
  constructor; eauto 3 with env.
  + introv envLookup.
    destruct (id_eq_dec (DVar m) x).
    - subst. simpl_extend_hyp.
      inv_eq.
      exists v.
      split...
      inv hasType...
    - rewrite extend_neq in envLookup...
      apply envModelsVars in envLookup as (v' & Vlookup & hasType').
      exists v'.
      split...
      inv hasType'...
  + introv Hle. unfold fresh.
    assert (m < n')
        by omega.
    case_extend; [inv_eq | apply Hfresh]; omega.
Qed.

Lemma wfVars_heapExtend :
  forall Gamma P t' n V l c,
    wfProgram P t' ->
    wfVars P Gamma n V ->
    fresh Gamma (env_loc l) ->
    wfType P (TClass c) ->
    wfVars P (extend Gamma (env_loc l) (TClass c)) n V.
Proof with eauto with env.
  introv wfP wfV Hfresh wfT.
  inverts wfV as wfGamma envModelsVars varsMirrorEnv freshVars.
  constructor...
  + introv envLookup.
    simpl_extend_hyp.
    apply envModelsVars in envLookup as (v & Vlookup & hasType).
    exists v.
    split...
    inv hasType...
Qed.

Lemma wfVars_ge :
  forall P Gamma n V m,
    wfVars P Gamma n V ->
    n <= m ->
    wfVars P Gamma m V.
Proof with eauto.
  introv wfV Hge.
  inverts wfV as wfGamma envModels varsMirror Hfresh.
  econstructor...
  introv Hle.
  assert (n <= n') by omega...
Qed.

(*
----------
wfLocking
----------
*)

Hint Constructors wfHeldLocks.
Hint Constructors wfLocks.
Hint Constructors disjointLocks.
Hint Constructors wfLocking.

Lemma wfHeldLocks_heapExtend :
  forall H Ls c F RL,
    wfHeldLocks H Ls ->
    wfHeldLocks (heapExtend H (c, F, RL)) Ls.
Proof with eauto.
  introv wfLs.
  constructor.
  induction wfLs as [wfLs]...
  rewrite Forall_forall in wfLs.
  apply Forall_forall.
  introv HIn.
  apply wfLs in HIn as [].
  assert (Hlt: l < length H) by
      (eapply heapLookup_lt; eauto)...
  econstructor...
  rewrite heapExtend_lookup_nlen...
  omega.
Qed.

Lemma wfLocking_heapExtend :
  forall H T c F RL,
    wfLocking H T ->
    wfLocking (heapExtend H (c, F, RL)) T.
Proof with eauto using wfHeldLocks_heapExtend.
  introv wfL.
  induction wfL...
Qed.

Lemma wfHeldLocks_heapUpdate :
  forall H Ls l c F F' RL RL',
    wfHeldLocks H Ls ->
    heapLookup H l = Some (c, F, RL) ->
    (forall r, In (l, r) Ls -> RL' r = Some LLocked) ->
    wfHeldLocks (heapUpdate H l (c, F', RL')) Ls.
Proof with eauto.
  introv wfLs Hlookup HRL'.
  induction wfLs as [wfLs]...
  rewrite Forall_forall in wfLs.
  constructors.
  apply Forall_forall.
  introv HIn.
  assert(wfL: wfLock H x)...
  inverts wfL as Hlookup' HRL.
  destruct (id_eq_dec l l1).
  + subst. rewrite_and_invert.
    apply HRL' in HIn. subst.
    apply WF_Lock with c0 F' RL'...
    rewrite lookup_heapUpdate_eq...
    apply heapLookup_lt...
  + econstructor...
    rewrite lookup_heapUpdate_neq...
Qed.

Lemma wfLocking_heapUpdate :
  forall H T l c F F' RL RL',
    wfLocking H T ->
    heapLookup H l = Some (c, F, RL) ->
    (forall r, In (l, r) (heldLocks T) -> RL' r = Some LLocked) ->
    wfLocking (heapUpdate H l (c, F', RL')) T.
Proof with eauto using wfHeldLocks_heapUpdate.
  introv wfL Hlookup HL.
  induction wfL; simpls...
  econstructor...
  + apply IHwfL1...
    - introv HIn.
      apply HL. apply in_or_app...
  + apply IHwfL2...
    - introv HIn.
      apply HL. apply in_or_app...
Qed.

Lemma wfHeldLocks_taken :
  forall H Ls l r c RL F,
    wfHeldLocks H Ls ->
    In (l, r) Ls ->
    heapLookup H l = Some (c, F, RL) ->
    RL r = Some LLocked.
Proof with eauto.
  introv wfLs HIn Hlookup.
  induction wfLs as [wfLs]...
  rewrite Forall_forall in wfLs.
  apply wfLs in HIn. inv HIn.
  rewrite_and_invert...
Qed.

Lemma wfLocks_econtext :
  forall Ls e ctx,
    is_econtext ctx ->
    wfLocks Ls (ctx e) ->
    wfLocks Ls e.
Proof with eauto using in_or_app.
  introv Hctx wfL.
  inv Hctx;
    inverts wfL as Hlocks Hdup;
    simpl in *...
  + eapply NoDup_app in Hdup as []...
  + inv Hdup...
Qed.

Lemma wfLocking_econtext :
  forall ctx H Ls e,
    is_econtext ctx ->
    wfLocking H (T_Thread Ls (ctx e)) ->
    wfLocking H (T_Thread Ls e).
Proof with eauto using wfLocks_econtext.
  introv Hctx wfL.
  inv wfL...
Qed.

Lemma wfLocking_subst :
  forall H Ls e x y,
    wfLocking H (T_Thread Ls e) ->
    wfLocking H (T_Thread Ls (subst x y e)).
Proof with eauto.
  introv wfL.
  inverts wfL as wfLs Hdup wfL wfRl.
  econstructor...
  econstructor...
  + rewrite <- locks_subst...
    inv wfL...
  + rewrite <- locks_subst...
    inv wfL...
Qed.

Lemma locks_static :
  forall e,
    exprStatic e ->
    locks e = nil.
Proof with eauto using app_eq_nil.
  introv Hstatic.
  induction Hstatic; simpl...
  apply app_eq_nil...
Qed.

Lemma wfLocking_static :
  forall H Ls e,
    wfHeldLocks H Ls ->
    NoDup Ls ->
    exprStatic e ->
    wfLocking H (T_Thread Ls e).
Proof with eauto using locks_static.
  introv wfLs Hdup Hstatic.
  assert (HL: locks e = nil)...
  econstructor...
  econstructor; rewrite HL...
  introv HIn... inv HIn.
Qed.

Lemma disjointLocks_commutative :
  forall T1 T2,
    disjointLocks T1 T2 ->
    disjointLocks T2 T1.
Proof with eauto.
  introv Hdisj.
  inv Hdisj. constructors...
Qed.

Lemma disjointLocks_async :
  forall T T1 T2 e,
    disjointLocks T1 T /\
    disjointLocks T2 T
     <->
    disjointLocks (T_Async T1 T2 e) T.
Proof with eauto using in_or_app.
  split.
  + introv Hdisj.
    inverts Hdisj as Hdisj1 Hdisj2.
    inverts Hdisj1. inverts Hdisj2.
    constructor; simpl.
    - introv HIn.
      apply in_app_or in HIn as [|HIn]...
    - introv HIn.
      apply not_in_app...
  + introv Hdisj.
    inverts Hdisj as Hdisj1 Hdisj2.
    simpls.
    splits.
    - constructor...
      introv HIn.
      apply Hdisj2 in HIn...
    - constructor...
      introv HIn.
      apply Hdisj2 in HIn.
      eapply not_in_app in HIn as []...
Qed.

Lemma disjointLocks_leftmost :
  forall T1 T2,
    disjointLocks T1 T2 ->
    disjointLocks (T_EXN (leftmost_locks T1)) T2.
Proof with eauto using in_or_app.
  introv Hdisj.
  induction T1; simpls; inv Hdisj...
  apply IHT1_1.
  econstructor; crush...
Qed.

Lemma wfHeldLocks_app :
  forall H Ls1 Ls2,
    (wfHeldLocks H Ls1 /\ wfHeldLocks H Ls2 <-> wfHeldLocks H (Ls1 ++ Ls2)).
Proof with eauto using in_eq, in_cons.
  split.
  + introv wfLs.
    inverts wfLs as wfLs1 wfLs2.
    constructor.
    apply Forall_app...
    inv wfLs1...
    inv wfLs2...
  + introv wfLs.
    induction Ls1 as [|l]; simpls...
    inverts wfLs as wfLs.
    inverts wfLs as wfL wfLs'.
    assert(wfLs: wfHeldLocks H (Ls1 ++ Ls2))...
    apply IHLs1 in wfLs as [wfLs1 wfLs2]...
    split...
    econstructor...
    econstructor...
    apply Forall_forall.
    rewrite Forall_forall in wfLs'.
    introv HIn.
    assert (HIn': In x (Ls1 ++ Ls2))
      by eauto using in_or_app...
Qed.

Lemma wfHeldLocks_cons :
  forall H Ls l,
    wfHeldLocks H Ls ->
    wfLock H l ->
    wfHeldLocks H (l :: Ls).
Proof with eauto.
  introv wfLs wfL.
  inv wfLs...
Qed.

Lemma wfHeldLocks_leftmost :
  forall H T,
    wfLocking H T ->
    wfHeldLocks H (leftmost_locks T).
Proof with eauto.
  introv wfL.
  induction T; inv wfL...
Qed.

Lemma wfHeldLocks_remove :
  forall H Ls L eq_dec,
    wfHeldLocks H Ls ->
    wfHeldLocks H (remove eq_dec L Ls).
Proof with eauto using wfHeldLocks_cons.
  introv wfLs.
  induction Ls as [| l]...
  inverts wfLs as wfLs.
  inverts wfLs.
  simpl. cases_if...
Qed.

Corollary wfLocking_wfHeldLocks :
  forall H T,
    wfLocking H T ->
    wfHeldLocks H (heldLocks T).
Proof with eauto.
  introv wfL.
  induction T; simpls; inv wfL...
  apply wfHeldLocks_app...
Qed.

(*
----------
wfThreads
----------
*)

Hint Constructors wfThreads.

Corollary wfThreads_wfEnv :
  forall P t' Gamma T t,
    wfProgram P t' ->
    wfThreads P Gamma T t ->
    wfEnv P Gamma.
Proof with eauto with env.
  introv wfP wfT. inv wfT...
Qed.

Hint Immediate wfThreads_wfEnv.

Lemma wfThreads_invariance :
  forall P t' Gamma Gamma' T t,
    wfProgram P t' ->
    (forall x, Gamma x = Gamma' x) ->
    wfThreads P Gamma T t ->
    wfThreads P Gamma' T t.
Proof with eauto using hasType_subsumption,
                       wfEnv_equiv with env.
  introv wfP Hequiv wfT.
  induction wfT...
Qed.

Lemma wfThreads_subsumption :
  forall P t' Gamma Gamma' T t,
    wfProgram P t' ->
    wfSubsumption Gamma Gamma' ->
    wfEnv P Gamma' ->
    wfThreads P Gamma T t ->
    wfThreads P Gamma' T t.
Proof with eauto using hasType_subsumption with env.
  introv wfP wfEnv' Hsub wfT.
  induction wfT...
Qed.

Lemma wfThreads_heapExtend :
  forall P t' Gamma T t c l,
    wfProgram P t' ->
    wfType P (TClass c) ->
    fresh Gamma (env_loc l) ->
    wfThreads P Gamma T t ->
    wfThreads P (extend Gamma (env_loc l) (TClass c)) T t.
Proof with eauto using hasType_extend_loc with env.
  introv wfP wfTy Hfresh wfT.
  generalize dependent t.
  induction T; intros; inv wfT...
Qed.

(*
----------------
wfConfiguration
----------------
*)

Hint Constructors wfConfiguration.

Lemma wfConfiguration_substitution :
  forall P Gamma H V n Ls e e' t,
    freeVars e' = nil ->
    P; Gamma |- e' \in t ->
    wfLocking H (T_Thread Ls e') ->
    wfConfiguration P Gamma (H, V, n, T_Thread Ls e) t ->
    wfConfiguration P Gamma (H, V, n, T_Thread Ls e') t.
Proof with eauto.
  introv Hfree hasType wfL wfCfg.
  inverts wfCfg...
Qed.

Lemma wfConfiguration_heapExtend :
  forall P t' Gamma H V n T t c F RL,
    wfProgram P t' ->
    wfConfiguration P Gamma (H, V, n, T) t ->
    wfType P (TClass c) ->
    wfFields P Gamma c F ->
    wfRegionLocks P c RL ->
    wfConfiguration P (extend Gamma (env_loc (length H)) (TClass c))
                    ((heapExtend H (c, F, RL)), V, n, T) t.
Proof with eauto 6 using
                 wfHeap_extend,
                 wfVars_heapExtend,
                 wfThreads_heapExtend,
                 wfLocking_heapExtend with env.
  introv wfP wfCfg wfTy wfF wfRL.
  inverts wfCfg.
  assert(fresh Gamma (env_loc (length H)))
    by eauto using wfHeap_fresh, heapLookup_ge...
Qed.

Lemma wfConfiguration_heapUpdate :
  forall P t' Gamma H V n T t l c F RL RL' F',
    wfProgram P t' ->
    wfConfiguration P Gamma (H, V, n, T) t ->
    heapLookup H l = Some (c, F, RL) ->
    wfFields P Gamma c F' ->
    wfRegionLocks P c RL' ->
    (forall r, In (l, r) (heldLocks T) -> RL' r = Some LLocked) ->
    wfConfiguration P Gamma
                    ((heapUpdate H l (c, F', RL')), V, n, T) t.
Proof with eauto using
                 wfHeap_update,
                 wfLocking_heapUpdate.
  introv wfP wfCfg HLookup wfF' wfRL' HL.
  inverts wfCfg...
Qed.


Require Import VST.floyd.proofauto.
(* Require Export VST.floyd.Funspec_old_Notation. *)

Require Import listfree2.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Fixpoint lseg (x: val) (s: list val) (size: nat) : mpred :=
  match size with
  | S size'  =>
    EX nxt:val, EX v:val, EX s': list val,
    !!not(x = nullval) &&
     !! (s = v :: s') &&
      data_at Tsh (tarray (tptr tvoid) 2) (v :: nxt :: []) x *
      lseg nxt s' size'
  (*data_at Tsh (tptr tint) v x * data_at Tsh (tptr tint) nxt (offset_val 4 x) * lseg nxt s' size*)
  | O  => !!(x = nullval) && !!(s = nil)  && emp
  end.

(* helper obvious facts *)
Lemma lseg_lenP x s size :
  lseg x s size |-- !!(size = length s).
Proof.
  revert s x.
  induction size.
  - simpl. entailer!.
  - {
      simpl. intros s x. Intros nxt v s'.
      revert H0; case s.
      - simpl; intro H1; case (@nil_cons _ v s' H1).
      - {
          intros v_2 s'_2 H1; pose proof (@cons_inv _ _ _ _ _ H1) as H2.
          destruct H2 as [H3 H4].
          rewrite H3; rewrite H4; clear H3 H4 H1 v_2 s'_2; simpl.
          pose proof (@cancel_left (data_at Tsh (tarray (tptr tint) 2) [v; nxt] x) _  _ (IHsize s' nxt) ).
          entailer!.
        }
    }
Qed.

Lemma lseg_valid_pointer_or_nullP p s size:
  lseg p s size |-- !! is_pointer_or_null p.
Proof.
  destruct size as [|size]; simpl.
  - entailer!.
  - Intros nxt v s'. entailer!.
Qed.

Lemma lseg_valid_pointerP p s size:
  lseg p s size |--  valid_pointer p.
Proof.
  destruct size as [|size]; simpl.
  - entailer!.
  - Intros nxt v s'. entailer!.
Qed.

Lemma lseg_pointer_contentsP p s size:
  lseg p s size |-- !!(p=nullval <-> s=nil).
Proof.
  destruct size as [|size]; simpl.
  - entailer!; intuition.
  - {
      Intros nxt v s'.
      entailer!.
      split.
      - intro H3; case (H H3).
      - intro H3.
        case (@nil_cons _ _ _ (@eq_sym _ _ _ H3 )).
    }
Qed.

Lemma lseg_size_negP p s size:
  lseg p s size |-- !! ((p <> nullval) <-> (gt size 0)).
Proof.
  destruct size as [| size]; simpl.
  - entailer!.
    split.
    intro H; case (H (eq_refl nullval)).
    intro H; case (gt_irrefl 0 H).
  -
    Intros nxt v s'.
    entailer!.
    split.
    intro; apply gt_Sn_O.
    auto.
Qed.

Lemma lseg_local_factsP p s size :
  lseg p s size |-- !!( (size = length s) /\ ((p=nullval -> s=nil) /\
                                              ((is_pointer_or_null p) /\
                                               (((p <> nullval) -> (gt size 0)))))).
Proof.
  rewrite prop_and.
  apply andp_right.
  apply lseg_lenP.
  rewrite prop_and.
  apply andp_right.
  pose proof lseg_pointer_contentsP; entailer!; try destruct H0; entailer!.
  rewrite prop_and.
  apply andp_right.
  apply lseg_valid_pointer_or_nullP.
  pose proof lseg_size_negP; entailer!; try destruct H0; entailer!.
Qed.

Lemma is_pointer_or_null_not_null:
 forall x, is_pointer_or_null x -> x <> nullval -> isptr x.
Proof.
intros.
 destruct x; try contradiction. hnf in H; subst i. contradiction H0; reflexivity.
 apply I.
Qed.

Definition listfree_spec :=
  DECLARE _listfree
          WITH s: list val, x: val
                                 PRE  [ (tptr tvoid) ]
                                 PROP()
                                 PARAMS(x)
                                 SEP (lseg x s (length s))
                                 POST [ Tvoid ]
                                 PROP()
                                 LOCAL()
                                 SEP (emp).

Definition free_spec :=
  DECLARE _free
          WITH x: val, s: list val
                              PRE  [ (tptr tvoid) ]
                              PROP()
                              PARAMS(x)
                              SEP (data_at Tsh (tarray (tptr tvoid) 2) s x)
                              POST [ Tvoid ]
                              PROP()
                              LOCAL()
                              SEP (emp).

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
  ltac:(with_library prog [listfree_spec; free_spec]).

(** Proof that f_listfree, the body of the listfree() function,
 ** satisfies listfree_spec, in the global context (Vprog,Gprog).
 **)
From mathcomp Require Import ssreflect.
Hint Resolve lseg_valid_pointerP: valid_pointer.
Hint Resolve lseg_local_factsP : saturate_local.

Lemma body_listfree : semax_body Vprog Gprog f_listfree listfree_spec.
Proof.
  start_function.
  forward_if.
  - forward.
    (* x = null *)
    move: (H0 (eq_refl nullval)) => ->; (* lseg (x, nil, 0) *) simpl.
    entailer!.
  - assert_PROP ((Datatypes.length s) > 0)%nat. { entailer!. }
    case: s H0; first by simpl=>/gt_irrefl.
    simpl lseg => y ys _.
    Intros nxt v s'.
    forward. (* _t = x[1] *)
    forward_call (s', nxt).
    * entailer!; rewrite H3; entailer!.
    * forward_call (x, [v; nxt]).
      entailer!.
Qed.


From Coq Require Import Reals Psatz.
From iris.prelude Require Import options.
From iris.algebra Require Import ofe.
From iris.bi Require Export weakestpre.
From self.prelude Require Import classical.
From self.prob Require Import distribution.

Section language_mixin.
  Context {expr val state state_idx : Type}.
  Context `{Countable expr, Countable val, Countable state, Countable state_idx}.

  Context (of_val : val → expr).
  Context (to_val : expr → option val).

  Context (prim_step  : expr → state → distr (expr * state)).
  Context (state_step : state → state_idx → distr state).
  (* For [prob_lang] this will just be [λ σ, elements (dom σ.(tapes))] - it'll
     be nicer with just a set but there's no set-big_op for disjunction in Iris
     at the moment, so lets stick to a list for now *)
  Context (get_active : state → list state_idx).

  Record LanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_stuck e σ ρ : prim_step e σ ρ > 0 → to_val e = None;
    (** [state_step] preserves reducibility *)
    mixin_state_step_not_stuck e σ σ' α :
      state_step σ α σ' > 0 → (∃ ρ, prim_step e σ ρ > 0) ↔ (∃ ρ', prim_step e σ' ρ' > 0);
    (** The mass of active [state_step]s is 1 *)
    mixin_state_step_mass σ α :
      α ∈ get_active σ → SeriesC (state_step σ α) = 1;
    (** The mass of reducible [prim_step]s is 1 *)
    mixin_prim_step_mass e σ :
      (∃ ρ, prim_step e σ ρ > 0) → SeriesC (prim_step e σ) = 1;
  }.
End language_mixin.

Structure language := Language {
  expr : Type;
  val : Type;
  state : Type;
  state_idx : Type;

  expr_eqdec : EqDecision expr;
  val_eqdec : EqDecision val;
  state_eqdec : EqDecision state;
  state_idx_eqdec : EqDecision state_idx;
  expr_countable : Countable expr;
  val_countable : Countable val;
  state_countable : Countable state;
  state_idx_countable : Countable state_idx;

  of_val : val → expr;
  to_val : expr → option val;
  prim_step : expr → state → distr (expr * state);
  state_step : state → state_idx → distr state;
  get_active : state → list state_idx;

  language_mixin : LanguageMixin of_val to_val prim_step state_step get_active
}.

Bind Scope expr_scope with expr.
Bind Scope val_scope with val.

Global Arguments Language {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ } _.
Global Arguments of_val {_} _.
Global Arguments to_val {_} _.
Global Arguments state_step {_}.
Global Arguments prim_step {_} _ _.
Global Arguments get_active {_} _.

#[global] Existing Instance expr_eqdec.
#[global] Existing Instance val_eqdec.
#[global] Existing Instance state_eqdec.
#[global] Existing Instance expr_countable.
#[global] Existing Instance val_countable.
#[global] Existing Instance state_countable.
#[global] Existing Instance state_idx_countable.

Canonical Structure stateO Λ := leibnizO (state Λ).
Canonical Structure valO Λ := leibnizO (val Λ).
Canonical Structure exprO Λ := leibnizO (expr Λ).

Definition cfg (Λ : language) := (expr Λ * state Λ)%type.

Definition fill_lift {Λ} (K : expr Λ → expr Λ) : (expr Λ * state Λ) → (expr Λ * state Λ) :=
  λ '(e, σ), (K e, σ).

Global Instance inj_fill_lift {Λ : language} (K : expr Λ → expr Λ) :
  Inj (=) (=) K →
  Inj (=) (=) (fill_lift K).
Proof. by intros ? [] [] [=->%(inj _) ->]. Qed.

Class LanguageCtx {Λ : language} (K : expr Λ → expr Λ) := {
  fill_not_val e :
    to_val e = None → to_val (K e) = None;
  fill_inj : Inj (=) (=) K;
  fill_dmap e1 σ1 :
    to_val e1 = None →
    prim_step (K e1) σ1 = dmap (fill_lift K) (prim_step e1 σ1)
}.

#[global] Existing Instance fill_inj.

Inductive atomicity := StronglyAtomic | WeaklyAtomic.

(* Definition stuckness_to_atomicity (s : stuckness) : atomicity := *)
(*   if s is MaybeStuck then StronglyAtomic else WeaklyAtomic. *)

Section language.
  Context {Λ : language}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.
  Implicit Types σ : state Λ.

  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. apply language_mixin. Qed.
  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof. apply language_mixin. Qed.
  Lemma val_stuck e σ ρ : prim_step e σ ρ > 0 → to_val e = None.
  Proof. apply language_mixin. Qed.
  Lemma state_step_not_stuck e σ σ' α :
    state_step σ α σ' > 0 → (∃ ρ, prim_step e σ ρ > 0) ↔ (∃ ρ', prim_step e σ' ρ' > 0).
  Proof. apply language_mixin. Qed.
  Lemma state_step_mass σ α : α ∈ get_active σ → SeriesC (state_step σ α) = 1.
  Proof. apply language_mixin. Qed.
  Lemma prim_step_mass e σ :
    (∃ ρ, prim_step e σ ρ > 0) → SeriesC (prim_step e σ) = 1.
  Proof. apply language_mixin. Qed.

  Definition reducible (e : expr Λ) (σ : state Λ) :=
    ∃ ρ, prim_step e σ ρ > 0.
  Definition irreducible (e : expr Λ) (σ : state Λ) :=
    ∀ ρ, prim_step e σ ρ = 0.
  Definition stuck (e : expr Λ) (σ : state Λ) :=
    to_val e = None ∧ irreducible e σ.
  Definition not_stuck (e : expr Λ) (σ : state Λ) :=
    is_Some (to_val e) ∨ reducible e σ.

  Class Atomic (a : atomicity) (e : expr Λ) : Prop :=
    atomic σ e' σ' :
      prim_step e σ (e', σ') > 0 →
      if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').

  Inductive step (ρ1 : cfg Λ) (ρ2 : cfg Λ) : Prop :=
  | step_atomic e1 σ1 :
    ρ1 = (e1, σ1) →
    prim_step e1 σ1 ρ2 > 0 →
    step ρ1 ρ2
  | step_state e α σ1 σ2 :
    ρ1 = (e, σ1) →
    ρ2 = (e, σ2) →
    state_step σ1 α σ2 > 0 →
    step ρ1 ρ2.
  Local Hint Constructors step : core.

  Lemma of_to_val_flip v e : of_val v = e → to_val e = Some v.
  Proof. intros <-. by rewrite to_of_val. Qed.
  Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ.
  Proof.
    unfold reducible, irreducible. split.
    - move=> /not_exists_forall_not Hneg ρ.
      specialize (Hneg ρ). apply Rnot_gt_ge in Hneg.
      pose proof (pmf_pos (prim_step e σ) ρ). lra.
    - intros Hall [ρ ?]. specialize (Hall ρ). lra.
  Qed.
  Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
  Proof. intros ([] & ?). eauto using val_stuck. Qed.
  Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ.
  Proof.
    intros [??] ?.
    destruct (pmf_pos (prim_step e σ) ρ) as [Hs%val_stuck|]; [|done].
    simplify_eq.
  Qed.
  Global Instance of_val_inj : Inj (=) (=) (@of_val Λ).
  Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.
  Lemma not_not_stuck e σ : ¬not_stuck e σ ↔ stuck e σ.
  Proof.
    rewrite /stuck /not_stuck -not_eq_None_Some -not_reducible.
    destruct (decide (to_val e = None)); naive_solver.
  Qed.
  Lemma val_stuck_dzero e σ :
    is_Some (to_val e) → prim_step e σ = dzero.
  Proof.
    intros []. apply distr_ext=>ρ.
    destruct (decide (prim_step e σ ρ > 0)) as
      [?%val_stuck | ->%pmf_eq_0_not_gt_0]; [|done].
    simplify_eq.
  Qed.
  Lemma irreducible_dzero e σ :
    irreducible e σ → prim_step e σ = dzero.
  Proof.
    intros Hirr%not_reducible. apply dzero_ext=> ρ.
    destruct (Req_dec (prim_step e σ ρ)0); [done|].
    exfalso. eapply Hirr.
    exists ρ.
    pose proof (pmf_le_1 (prim_step e σ) ρ).
    pose proof (pmf_pos (prim_step e σ) ρ).
    lra.
  Qed.

  Lemma strongly_atomic_atomic e a :
    Atomic StronglyAtomic e → Atomic a e.
  Proof. unfold Atomic. destruct a; eauto using val_irreducible. Qed.

  Lemma fill_step e1 σ1 e2 σ2 `{!LanguageCtx K} :
    prim_step e1 σ1 (e2, σ2) > 0 →
    prim_step (K e1) σ1 (K e2, σ2) > 0.
  Proof.
    intros Hs.
    rewrite fill_dmap; [|by eapply val_stuck].
    apply dbind_pos_support. eexists (_,_). split; [|done].
    rewrite dret_1_1 //. lra.
  Qed.

  Lemma fill_step_inv e1' σ1 e2 σ2 `{!LanguageCtx K} :
    to_val e1' = None → prim_step (K e1') σ1 (e2, σ2) > 0 →
    ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 (e2', σ2) > 0.
  Proof.
    intros Hv. rewrite fill_dmap //.
    intros ([e1 σ1'] & [=]%dret_pos & Hstep)%dbind_pos_support.
    subst. eauto.
  Qed.

  Lemma fill_step_prob e1 σ1 e2 σ2 `{!LanguageCtx K} :
    to_val e1 = None →
    prim_step e1 σ1 (e2, σ2) = prim_step (K e1) σ1 (K e2, σ2).
  Proof.
    intros Hv. rewrite fill_dmap //.
    by erewrite (dmap_elem_eq _ (e2, σ2) _ (λ '(e0, σ0), (K e0, σ0))).
  Qed.

  Lemma reducible_fill `{!@LanguageCtx Λ K} e σ :
    reducible e σ → reducible (K e) σ.
  Proof.
    unfold reducible in *. intros [[] ?]. eexists; by apply fill_step.
  Qed.
  Lemma reducible_fill_inv `{!@LanguageCtx Λ K} e σ :
    to_val e = None → reducible (K e) σ → reducible e σ.
  Proof.
    intros ? [[e1 σ1] Hstep]; unfold reducible.
    rewrite fill_dmap // in Hstep.
    apply dmap_pos in Hstep as ([e1' σ2] & ? & Hstep).
    eauto.
  Qed.
  Lemma state_step_reducible e σ σ' α :
    state_step σ α σ' > 0 → reducible e σ ↔ reducible e σ'.
  Proof. apply state_step_not_stuck. Qed.

  Lemma irreducible_fill `{!@LanguageCtx Λ K} e σ :
    to_val e = None → irreducible e σ → irreducible (K e) σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill_inv. Qed.
  Lemma irreducible_fill_inv `{!@LanguageCtx Λ K} e σ :
    irreducible (K e) σ → irreducible e σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill. Qed.

  Lemma not_stuck_fill_inv K `{!@LanguageCtx Λ K} e σ :
    not_stuck (K e) σ → not_stuck e σ.
  Proof.
    rewrite /not_stuck -!not_eq_None_Some. intros [?|?].
    - auto using fill_not_val.
    - destruct (decide (to_val e = None)); eauto using reducible_fill_inv.
  Qed.

  Lemma stuck_fill `{!@LanguageCtx Λ K} e σ :
    stuck e σ → stuck (K e) σ.
  Proof. rewrite -!not_not_stuck. eauto using not_stuck_fill_inv. Qed.

  Record pure_step (e1 e2 : expr Λ)  := {
    pure_step_safe σ1 : reducible e1 σ1;
    pure_step_det σ : prim_step e1 σ (e2, σ) = 1;
  }.

  Class PureExec (φ : Prop) (n : nat) (e1 e2 : expr Λ) :=
    pure_exec : φ → relations.nsteps pure_step n e1 e2.

  Lemma pure_step_ctx K `{!@LanguageCtx Λ K} e1 e2 :
    pure_step e1 e2 → pure_step (K e1) (K e2).
  Proof.
    intros [Hred Hstep]. split.
    - unfold reducible in *. intros σ1.
      destruct (Hred σ1) as [[]].
      eexists. by eapply fill_step.
    - intros σ.
      rewrite -fill_step_prob //; eauto using (reducible_not_val _ σ).
  Qed.

  Lemma pure_step_nsteps_ctx K `{!@LanguageCtx Λ K} n e1 e2 :
    relations.nsteps pure_step n e1 e2 →
    relations.nsteps pure_step n (K e1) (K e2).
  Proof. eauto using nsteps_congruence, pure_step_ctx. Qed.

  Lemma rtc_pure_step_ctx K `{!@LanguageCtx Λ K} e1 e2 :
    rtc pure_step e1 e2 → rtc pure_step (K e1) (K e2).
  Proof. eauto using rtc_congruence, pure_step_ctx. Qed.

  (* We do not make this an instance because it is awfully general. *)
  Lemma pure_exec_ctx K `{!@LanguageCtx Λ K} φ n e1 e2 :
    PureExec φ n e1 e2 →
    PureExec φ n (K e1) (K e2).
  Proof. rewrite /PureExec; eauto using pure_step_nsteps_ctx. Qed.

  (* This is a family of frequent assumptions for PureExec *)
  Class IntoVal (e : expr Λ) (v : val Λ) :=
    into_val : of_val v = e.

  Class AsVal (e : expr Λ) := as_val : ∃ v, of_val v = e.
  (* There is no instance [IntoVal → AsVal] as often one can solve [AsVal] more *)
  (* efficiently since no witness has to be computed. *)
  Global Instance as_vals_of_val vs : TCForall AsVal (of_val <$> vs).
  Proof.
    apply TCForall_Forall, Forall_fmap, Forall_true=> v.
    rewrite /AsVal /=; eauto.
  Qed.

  Lemma as_val_is_Some e :
    (∃ v, of_val v = e) → is_Some (to_val e).
  Proof. intros [v <-]. rewrite to_of_val. eauto. Qed.

  Lemma fill_is_val e K `{@LanguageCtx Λ K} :
    is_Some (to_val (K e)) → is_Some (to_val e).
  Proof. rewrite -!not_eq_None_Some. eauto using fill_not_val. Qed.

  Lemma prim_step_not_stuck e σ e' σ' :
    prim_step e σ (e', σ') > 0 → not_stuck e σ.
  Proof. rewrite /not_stuck /reducible. eauto 10. Qed.

  Lemma rtc_pure_step_val `{!Inhabited (state Λ)} v e :
    rtc pure_step (of_val v) e → to_val e = Some v.
  Proof.
    intros ?; rewrite <- to_of_val.
    f_equal; symmetry; eapply rtc_nf; first done.
    intros [e' [Hstep _]].
    specialize (Hstep inhabitant) as [? Hval%val_stuck].
    by rewrite to_of_val in Hval.
  Qed.
End language.

Global Hint Mode PureExec + - - ! - : typeclass_instances.

Global Arguments step_atomic {Λ ρ1 ρ2}.
Global Arguments step_state {Λ ρ1 ρ2}.


(** Construction of actegory morphisms

Part Generalization of pointed distributivity laws to lifted distributivity laws in general monads
- definition
- construction of actegory morphism from it
- composition

Part Closure of the notion of actegory morphisms under
- the pointwise binary product of functors
- the pointwise binary coproduct of functors

author: Ralph Matthes 2022
 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
Require Import UniMath.CategoryTheory.coslicecat.
Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.Actegories.CoproductsInActegories.
Require Import UniMath.CategoryTheory.Actegories.ProductsInActegories.
Require Import UniMath.CategoryTheory.Actegories.ProductActegory.

Local Open Scope cat.

Import BifunctorNotations.
Import MonoidalNotations.
Import ActegoryNotations.

Section LiftedLineatorAndLiftedDistributivity.

  Context {V : category} (Mon_V : monoidal V)
          {W : category} (Mon_W : monoidal W)
          {F : W ⟶ V} (U : fmonoidal Mon_W Mon_V F).

Section LiftedLaxLineator.

  Context {C D : category} (ActC : actegory Mon_V C) (ActD : actegory Mon_V D).

Section OnFunctors.

  Context {H : functor C D} (ll : lineator_lax Mon_V ActC ActD H).

  Definition lifted_lax_lineator_data : lineator_data Mon_W (lifted_actegory Mon_V ActC Mon_W U)
                                                            (lifted_actegory Mon_V ActD Mon_W U) H.
  Proof.
    intros w c. exact (ll (F w) c).
  Defined.

  Lemma lifted_lax_lineator_laws : lineator_laxlaws Mon_W (lifted_actegory Mon_V ActC Mon_W U)
                                     (lifted_actegory Mon_V ActD Mon_W U) H lifted_lax_lineator_data.
  Proof.
    split4.
    - intro; intros. apply (lineator_linnatleft _ _ _ _ ll).
    - intro; intros. apply (lineator_linnatright _ _ _ _ ll).
    - intro; intros. cbn. unfold lifted_lax_lineator_data, lifted_actor_data.
      etrans.
      2: { repeat rewrite assoc'. apply maponpaths.
           rewrite assoc.
           apply (lineator_preservesactor _ _ _ _ ll). }
      etrans.
      2: { rewrite assoc.
           apply cancel_postcomposition.
           apply pathsinv0, lineator_linnatright. }
      etrans.
      2: { rewrite assoc'.
           apply maponpaths.
           apply functor_comp. }
      apply idpath.
    - intro; intros. cbn. unfold lifted_lax_lineator_data, lifted_action_unitor_data.
      etrans.
      2: { apply maponpaths.
           apply (lineator_preservesunitor _ _ _ _ ll). }
      etrans.
      2: { rewrite assoc.
           apply cancel_postcomposition.
           apply pathsinv0, lineator_linnatright. }
      etrans.
      2: { rewrite assoc'.
           apply maponpaths.
           apply functor_comp. }
      apply idpath.
  Qed.

  Definition lifted_lax_lineator : lineator_lax Mon_W (lifted_actegory Mon_V ActC Mon_W U)
                                                      (lifted_actegory Mon_V ActD Mon_W U) H :=
    _,,lifted_lax_lineator_laws.

End OnFunctors.

Section OnNaturalTransformations.

  Context {H : functor C D} (Hl : lineator_lax Mon_V ActC ActD H)
    {K : functor C D} (Kl : lineator_lax Mon_V ActC ActD K)
    {ξ : H ⟹ K} (islntξ : is_linear_nat_trans Hl Kl ξ).

  Lemma preserves_linearity_lifted_lax_lineator :
    is_linear_nat_trans (lifted_lax_lineator Hl) (lifted_lax_lineator Kl) ξ.
  Proof.
    intros w c.
    apply islntξ.
  Qed.

End OnNaturalTransformations.

End LiftedLaxLineator.

Section LiftedDistributivity.

Section FixAnObject.

  Context {v0 : V}.

  Definition lifteddistributivity_data: UU := ∏ (w: W), F w ⊗_{Mon_V} v0 --> v0 ⊗_{Mon_V} F w.

  Identity Coercion lifteddistributivity_data_funclass: lifteddistributivity_data >-> Funclass.

Section δ_laws.

  Context (δ : lifteddistributivity_data).

  Definition lifteddistributivity_nat: UU := is_nat_trans (functor_composite F (rightwhiskering_functor Mon_V v0))
                                                           (functor_composite F (leftwhiskering_functor Mon_V v0)) δ.

  Definition lifteddistributivity_tensor_body (w w' : W): UU :=
    δ (w ⊗_{Mon_W} w') = pr1 (fmonoidal_preservestensorstrongly U w w') ⊗^{Mon_V}_{r} v0 · α_{Mon_V} _ _ _ ·
                           F w ⊗^{Mon_V}_{l} δ w' · αinv_{Mon_V} _ _ _ · δ w ⊗^{Mon_V}_{r} F w' ·
                           α_{Mon_V} _ _ _ · v0 ⊗^{Mon_V}_{l} fmonoidal_preservestensordata U w w'.

  Definition lifteddistributivity_tensor: UU := ∏ (w w' : W), lifteddistributivity_tensor_body w w'.

  Definition lifteddistributivity_unit: UU :=
    δ I_{Mon_W} = pr1 (fmonoidal_preservesunitstrongly U) ⊗^{Mon_V}_{r} v0 · lu_{Mon_V} v0 ·
                  ruinv_{Mon_V} v0 · v0 ⊗^{Mon_V}_{l} fmonoidal_preservesunit U.

End δ_laws.

Definition lifteddistributivity: UU := ∑ δ : lifteddistributivity_data,
      lifteddistributivity_nat δ × lifteddistributivity_tensor δ × lifteddistributivity_unit δ.

Definition lifteddistributivity_lddata (δ : lifteddistributivity): lifteddistributivity_data := pr1 δ.
Coercion lifteddistributivity_lddata : lifteddistributivity >-> lifteddistributivity_data.

Definition lifteddistributivity_ldnat (δ : lifteddistributivity): lifteddistributivity_nat δ := pr12 δ.
Definition lifteddistributivity_ldtensor (δ : lifteddistributivity): lifteddistributivity_tensor δ := pr122 δ.
Definition lifteddistributivity_ldunit (δ : lifteddistributivity): lifteddistributivity_unit δ := pr222 δ.

Section ActegoryMorphismFromLiftedDistributivity.

  Context (δ : lifteddistributivity) {C : category} (ActV : actegory Mon_V C).

  Local Definition FF: C ⟶ C := leftwhiskering_functor ActV v0.
  Local Definition ActW: actegory Mon_W C := lifted_actegory Mon_V ActV Mon_W U.

  Definition lineator_data_from_δ: lineator_data Mon_W ActW ActW FF.
  Proof.
    intros w x. unfold FF. cbn.
    exact (aαinv^{ActV}_{F w, v0, x} · δ w ⊗^{ActV}_{r} x · aα^{ActV}_{v0, F w, x}).
  Defined.

  Lemma lineator_laxlaws_from_δ: lineator_laxlaws Mon_W ActW ActW FF lineator_data_from_δ.
  Proof.
    assert (δ_nat := lifteddistributivity_ldnat δ).
    do 2 red in δ_nat. cbn in δ_nat.
    repeat split; red; intros; unfold lineator_data_from_δ; try unfold lifted_actor_data; try unfold lifted_action_unitor_data; cbn;
      try unfold lifted_actor_data; try unfold lifted_action_unitor_data; cbn.
    - etrans.
      { repeat rewrite assoc.
        do 2 apply cancel_postcomposition.
        apply actorinv_nat_leftwhisker. }
      etrans.
      2: { repeat rewrite assoc'.
           do 2 apply maponpaths.
           apply pathsinv0, actegory_actornatleft.
      }
      repeat rewrite assoc'.
      apply maponpaths.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply pathsinv0, (bifunctor_equalwhiskers ActV).
    - etrans.
      { repeat rewrite assoc.
        do 2 apply cancel_postcomposition.
        apply actorinv_nat_rightwhisker. }
      etrans.
      2: { repeat rewrite assoc'.
           do 2 apply maponpaths.
           apply pathsinv0, actegory_actornatleftright.
      }
      repeat rewrite assoc'.
      apply maponpaths.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      etrans.
      { apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)). }
      etrans.
      2: { apply (functor_comp (rightwhiskering_functor ActV x)). }
      apply maponpaths.
      apply δ_nat.
    - etrans.
      { apply maponpaths.
        apply (functor_comp (leftwhiskering_functor ActV v0)). }
      cbn.
      etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        repeat rewrite assoc'.
        do 2 apply maponpaths.
        apply actegory_actornatleftright.
      }
      etrans.
      { repeat rewrite assoc.
        do 2 apply cancel_postcomposition.
        repeat rewrite assoc'.
        apply maponpaths.
        apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)).
      }
      cbn.
      etrans.
      { do 2 apply cancel_postcomposition.
        do 2 apply maponpaths.
        rewrite (lifteddistributivity_ldtensor δ).
        repeat rewrite assoc'.
        do 6 apply maponpaths.
        etrans.
        { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v0)). }
        apply (functor_id_id _ _ (leftwhiskering_functor Mon_V v0)).
        apply (pr2 (fmonoidal_preservestensorstrongly U v w)).
      }
      rewrite id_right.
      etrans.
      { do 2 apply cancel_postcomposition.
        etrans.
        { apply maponpaths.
          apply (functor_comp (rightwhiskering_functor ActV x)). }
        cbn.
        rewrite assoc.
        apply cancel_postcomposition.
        apply pathsinv0, actorinv_nat_rightwhisker.
      }
      repeat rewrite assoc'.
      apply maponpaths.
      (* the extra effort for having an abstract strong monoidal functor has now been accomplished *)
      apply (z_iso_inv_on_right _ _ _ (z_iso_from_actor_iso Mon_V ActV _ _ _)).
      etrans.
      { apply cancel_postcomposition.
        repeat rewrite assoc.
        apply (functor_comp (rightwhiskering_functor ActV x)). }
      cbn.
      etrans.
      { rewrite assoc'.
        apply maponpaths.
        rewrite assoc.
        apply actegory_pentagonidentity.
      }
      repeat rewrite assoc.
      apply cancel_postcomposition.
      rewrite <- actegory_pentagonidentity.
      etrans.
      { apply cancel_postcomposition.
        repeat rewrite assoc'.
        apply (functor_comp (rightwhiskering_functor ActV x)). }
      cbn.
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      2: { apply maponpaths.
           etrans.
           2: { apply maponpaths.
                apply cancel_postcomposition.
                apply pathsinv0, (functor_comp (leftwhiskering_functor ActV (F v))). }
           cbn.
           repeat rewrite assoc.
           do 3 apply cancel_postcomposition.
           etrans.
           2: { apply (functor_comp (leftwhiskering_functor ActV (F v))). }
           apply pathsinv0, (functor_id_id _ _ (leftwhiskering_functor ActV (F v))).
           apply (pr1 (actegory_actorisolaw Mon_V ActV _ _ _)).
      }
      rewrite id_left.
      etrans.
      2: { apply maponpaths.
           rewrite assoc'.
           apply cancel_postcomposition.
           apply pathsinv0, (functor_comp (leftwhiskering_functor ActV (F v))).
      }
      cbn.
      etrans.
      2: { repeat rewrite assoc.
           do 3 apply cancel_postcomposition.
           apply pathsinv0, actegory_actornatleftright. }
      etrans.
      { apply cancel_postcomposition.
        apply (functor_comp (rightwhiskering_functor ActV x)). }
      cbn.
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply cancel_postcomposition.
        apply (functor_comp (rightwhiskering_functor ActV x)). }
      cbn.
      etrans.
      { rewrite assoc'.
        apply maponpaths.
        apply pathsinv0, actegory_actornatright. }
      repeat rewrite assoc.
      apply cancel_postcomposition.
      (* only a variant of the pentagon law with some inverses is missing here *)
      apply (z_iso_inv_on_left _ _ _ _ (z_iso_from_actor_iso Mon_V ActV _ _ _)).
      cbn.
      rewrite assoc'.
      rewrite <- actegory_pentagonidentity.
      etrans.
      2: { repeat rewrite assoc.
           do 2 apply cancel_postcomposition.
           etrans.
           2: { apply (functor_comp (rightwhiskering_functor ActV x)). }
           apply pathsinv0, (functor_id_id  _ _ (rightwhiskering_functor ActV x)).
           apply (pr2 (monoidal_associatorisolaw Mon_V _ _ _)).
      }
      rewrite id_left.
      apply idpath.
    - etrans.
      { apply maponpaths.
        apply (functor_comp (leftwhiskering_functor ActV v0)). }
      cbn.
      etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        repeat rewrite assoc'.
        do 2 apply maponpaths.
        apply actegory_actornatleftright.
      }
      etrans.
      { repeat rewrite assoc.
        do 2 apply cancel_postcomposition.
        repeat rewrite assoc'.
        apply maponpaths.
        apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)).
      }
      cbn.
      etrans.
      { do 2 apply cancel_postcomposition.
        do 2 apply maponpaths.
        rewrite (lifteddistributivity_ldunit δ).
        repeat rewrite assoc'.
        do 3 apply maponpaths.
        etrans.
        { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v0)). }
        apply (functor_id_id _ _ (leftwhiskering_functor Mon_V v0)).
        apply (pr2 (fmonoidal_preservesunitstrongly U)).
      }
      rewrite id_right.
      etrans.
      { do 2 apply cancel_postcomposition.
        etrans.
        { apply maponpaths.
          apply (functor_comp (rightwhiskering_functor ActV x)). }
        cbn.
        rewrite assoc.
        apply cancel_postcomposition.
        apply pathsinv0, actorinv_nat_rightwhisker.
      }
      repeat rewrite assoc'.
      apply maponpaths.
      (* the extra effort for having an abstract strong monoidal functor has now been accomplished *)
      etrans.
      { repeat rewrite assoc'.
        do 2 apply maponpaths.
        apply actegory_triangleidentity. }
      etrans.
      { apply maponpaths.
        apply pathsinv0, (functor_comp (rightwhiskering_functor ActV x)). }
      cbn.
      rewrite assoc'.
      rewrite (pr2 (monoidal_rightunitorisolaw Mon_V v0)).
      rewrite id_right.
      rewrite <- actegory_triangleidentity'.
      rewrite assoc.
      rewrite (pr2 (actegory_actorisolaw Mon_V ActV _ _ _)).
      apply id_left.
  Qed.

  Definition liftedstrength_from_δ: liftedstrength Mon_V Mon_W U ActV ActV FF :=
    lineator_data_from_δ,,lineator_laxlaws_from_δ.

End ActegoryMorphismFromLiftedDistributivity.

End FixAnObject.

Arguments liftedstrength_from_δ _ _ {_} _.
Arguments lifteddistributivity _ : clear implicits.
Arguments lifteddistributivity_data _ : clear implicits.

  Definition unit_lifteddistributivity_data: lifteddistributivity_data I_{Mon_V}.
  Proof.
    intro w.
    exact (ru^{Mon_V}_{F w} · luinv^{Mon_V}_{F w}).
  Defined.

  Lemma unit_lifteddistributivity_nat: lifteddistributivity_nat unit_lifteddistributivity_data.
  Proof.
    intro; intros. unfold unit_lifteddistributivity_data.
    cbn.
    etrans.
    { rewrite assoc.
      apply cancel_postcomposition.
      apply monoidal_rightunitornat. }
    repeat rewrite assoc'.
    apply maponpaths.
    apply pathsinv0, monoidal_leftunitorinvnat.
  Qed.

  Lemma unit_lifteddistributivity_tensor: lifteddistributivity_tensor unit_lifteddistributivity_data.
  Proof.
    intro; intros. unfold lifteddistributivity_tensor_body, unit_lifteddistributivity_data.
    etrans.
    2: { do 2 apply cancel_postcomposition.
         etrans.
         2: { do 2 apply cancel_postcomposition.
              rewrite assoc'.
              do 2 apply maponpaths.
              apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V _)). }
         apply maponpaths.
         apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V _)).
    }
    cbn.
    etrans.
    2: { repeat rewrite assoc'.
         apply maponpaths.
         repeat rewrite assoc.
         do 6 apply cancel_postcomposition.
         apply pathsinv0, left_whisker_with_runitor. }
    etrans.
    2: { repeat rewrite assoc.
         do 4 apply cancel_postcomposition.
         repeat rewrite assoc'.
         do 2 apply maponpaths.
         apply pathsinv0, monoidal_triangle_identity_inv. }
    etrans.
    2: { repeat rewrite assoc'.
         do 2 apply maponpaths.
         repeat rewrite assoc.
         do 3 apply cancel_postcomposition.
         etrans.
         2: { apply (functor_comp (rightwhiskering_functor Mon_V _)). }
         apply maponpaths.
         apply pathsinv0, monoidal_rightunitorisolaw.
    }
    rewrite functor_id, id_left.
    etrans.
    2: { do 2 apply maponpaths.
         apply cancel_postcomposition.
         rewrite <- monoidal_triangle_identity'_inv.
         rewrite assoc'.
         apply maponpaths.
         apply pathsinv0, monoidal_associatorisolaw.
    }
    rewrite id_right.
    etrans.
    2: { repeat rewrite assoc'.
         do 2 apply maponpaths.
         apply pathsinv0, monoidal_leftunitorinvnat. }
    do 2 rewrite assoc.
    apply cancel_postcomposition.
    etrans.
    2: { apply cancel_postcomposition.
         apply pathsinv0, monoidal_rightunitornat. }
    etrans.
    2: { rewrite assoc'.
         apply maponpaths.
         apply pathsinv0, fmonoidal_preservestensorstrongly.
    }
    apply pathsinv0, id_right.
  Qed.

  Lemma unit_lifteddistributivity_unit: lifteddistributivity_unit unit_lifteddistributivity_data.
  Proof.
    unfold lifteddistributivity_unit, unit_lifteddistributivity_data.
    etrans.
    2: { do 2 apply cancel_postcomposition.
         rewrite unitors_coincide_on_unit.
         apply pathsinv0, monoidal_rightunitornat. }
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    2: { apply maponpaths.
         rewrite <- unitorsinv_coincide_on_unit.
         apply pathsinv0, monoidal_leftunitorinvnat. }
    rewrite assoc.
    etrans.
    2: {apply cancel_postcomposition.
        apply pathsinv0, (pr22 (fmonoidal_preservesunitstrongly U)). }
    apply pathsinv0, id_left.
  Qed.

  Definition unit_lifteddistributivity: lifteddistributivity I_{Mon_V}.
  Proof.
    use tpair.
    - exact  unit_lifteddistributivity_data.
    - split3.
      + exact unit_lifteddistributivity_nat.
      + exact unit_lifteddistributivity_tensor.
      + exact unit_lifteddistributivity_unit.
  Defined.

Section CompositionOfLiftedDistributivities.

  Context (v1 v2 : V) (δ1 : lifteddistributivity v1) (δ2 : lifteddistributivity v2).

  Definition composedlifteddistributivity_data: lifteddistributivity_data (v1 ⊗_{Mon_V} v2).
  Proof.
    red; intros.
    exact (αinv_{Mon_V} _ _ _ · δ1 w ⊗^{Mon_V}_{r} v2 · α_{Mon_V} _ _ _
             · v1 ⊗^{Mon_V}_{l} δ2 w · αinv_{Mon_V} _ _ _).
  Defined.

  Lemma composedlifteddistributivity_nat: lifteddistributivity_nat composedlifteddistributivity_data.
  Proof.
    do 2 red; intros; unfold composedlifteddistributivity_data; cbn.
    assert (δ1_nat := lifteddistributivity_ldnat δ1).
    assert (δ2_nat := lifteddistributivity_ldnat δ2).
    do 2 red in δ1_nat, δ2_nat; cbn in δ1_nat, δ2_nat.
    etrans.
    { repeat rewrite assoc.
      do 4 apply cancel_postcomposition.
      apply monoidal_associatorinvnatright. }
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    { rewrite assoc.
      apply cancel_postcomposition.
      apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). }
    cbn.
    rewrite δ1_nat.
    etrans.
    { rewrite assoc.
      do 2 apply cancel_postcomposition.
      apply (functor_comp (rightwhiskering_functor Mon_V v2)). }
    cbn.
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    2: { do 2 apply maponpaths.
         apply monoidal_associatorinvnatleft. }
    repeat rewrite assoc.
    apply cancel_postcomposition.
    etrans.
    2: { rewrite assoc'.
         apply maponpaths.
         apply (functor_comp (leftwhiskering_functor Mon_V v1)). }
    cbn.
    rewrite <- δ2_nat.
    etrans.
    2: { apply maponpaths.
         apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v1)). }
    cbn.
    repeat rewrite assoc.
    apply cancel_postcomposition.
    apply pathsinv0, monoidal_associatornatleftright.
  Qed.

  Lemma composedlifteddistributivity_tensor: lifteddistributivity_tensor composedlifteddistributivity_data.
  Proof.
    do 2 red; intros; unfold composedlifteddistributivity_data; cbn.
    rewrite (lifteddistributivity_ldtensor δ1).
    rewrite (lifteddistributivity_ldtensor δ2).
    etrans.
    { do 3 apply cancel_postcomposition.
      apply maponpaths.
      etrans.
      { apply (functor_comp (rightwhiskering_functor Mon_V v2)). }
      do 5 rewrite functor_comp.
      cbn.
      apply idpath.
    }
    etrans.
    { apply cancel_postcomposition.
      repeat rewrite assoc'.
      do 9 apply maponpaths.
      etrans.
      { apply (functor_comp (leftwhiskering_functor Mon_V v1)). }
      do 5 rewrite functor_comp.
      cbn.
      apply idpath.
    }
    etrans.
    { repeat rewrite assoc.
      do 15 apply cancel_postcomposition.
      apply pathsinv0, monoidal_associatorinvnatright. }
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    { do 14 apply maponpaths.
      apply monoidal_associatorinvnatleft. }
    repeat rewrite assoc.
    apply cancel_postcomposition.
    etrans.
    2: { do 3 apply cancel_postcomposition.
         apply maponpaths.
         etrans.
         2: { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V (F w))). }
      do 3 rewrite functor_comp.
      cbn.
      apply idpath.
    }
    etrans.
    2: { apply cancel_postcomposition.
         repeat rewrite assoc'.
         do 7 apply maponpaths.
         etrans.
         2: { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V (F w'))). }
      do 3 rewrite functor_comp.
      cbn.
      apply idpath.
    }
    etrans.
    { do 6 apply cancel_postcomposition.
      repeat rewrite assoc'.
      do 6 apply maponpaths.
      etrans.
      { apply maponpaths.
        apply monoidal_associatornatleftright. }
      rewrite assoc.
      apply cancel_postcomposition.
      etrans.
      { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). }
      apply maponpaths.
      etrans.
      { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v1)). }
      apply (functor_id_id _ _ (leftwhiskering_functor Mon_V v1)).
      apply (pr2 (fmonoidal_preservestensorstrongly U w w')).
    }
    rewrite functor_id.
    rewrite id_left.
    etrans.
    { repeat rewrite assoc'. apply idpath. }
    apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso Mon_V _ _ _)).
    cbn.
    etrans.
    2: { repeat rewrite assoc.
         do 11 apply cancel_postcomposition.
         etrans.
         2: { apply cancel_postcomposition.
              apply monoidal_pentagonidentity. }
         repeat rewrite assoc'.
         do 2 apply maponpaths.
         etrans.
         2: { apply (functor_comp (leftwhiskering_functor Mon_V (F w))). }
         apply pathsinv0, (functor_id_id _ _ (leftwhiskering_functor Mon_V (F w))).
         apply (pr1 (monoidal_associatorisolaw Mon_V _ _ _)).
    }
    rewrite id_right.
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    2: { repeat rewrite assoc.
         do 10 apply cancel_postcomposition.
         apply pathsinv0, monoidal_associatornatleftright. }
    repeat rewrite assoc'.
    apply maponpaths.
    apply (z_iso_inv_on_right _ _ _ (functor_on_z_iso (rightwhiskering_functor Mon_V v2) (z_iso_from_associator_iso Mon_V _ _ _))).
    cbn.
    etrans.
    2: { repeat rewrite assoc.
         do 9 apply cancel_postcomposition.
         apply pathsinv0, monoidal_pentagonidentity. }
    etrans.
    { repeat rewrite assoc. apply idpath. }
    apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (z_iso_from_associator_iso Mon_V _ _ _)).
    cbn.
    etrans.
    2: { repeat rewrite assoc'.
         do 9 apply maponpaths.
         etrans.
         2: { apply maponpaths.
              apply monoidal_pentagonidentity. }
         repeat rewrite assoc.
         do 2 apply cancel_postcomposition.
         etrans.
         2: { apply (functor_comp (rightwhiskering_functor Mon_V _)). }
         apply pathsinv0, (functor_id_id _ _ (rightwhiskering_functor Mon_V (F w'))).
         apply (pr2 (monoidal_associatorisolaw Mon_V _ _ _)).
    }
    rewrite id_left.
    repeat rewrite assoc.
    apply cancel_postcomposition.
    etrans.
    { do 3 apply cancel_postcomposition.
      repeat rewrite assoc'.
      apply maponpaths.
      rewrite assoc.
      apply monoidal_pentagonidentity. }
    etrans.
    { repeat rewrite assoc.
      do 4 apply cancel_postcomposition.
      apply pathsinv0, monoidal_associatornatright. }
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    { apply maponpaths.
      repeat rewrite assoc.
      do 2 apply cancel_postcomposition.
      apply monoidal_associatornatleft. }
    etrans.
    { repeat rewrite assoc.
      do 3 apply cancel_postcomposition.
      apply (bifunctor_equalwhiskers Mon_V). }
    unfold functoronmorphisms2.
    etrans.
    2: { repeat rewrite assoc.
         do 7 apply cancel_postcomposition.
         apply pathsinv0, monoidal_associatornatleft. }
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    2: { repeat rewrite assoc.
         do 4 apply cancel_postcomposition.
         etrans.
         2: { repeat rewrite assoc'.
              apply maponpaths.
              rewrite assoc.
              apply pathsinv0, monoidal_pentagon_identity_inv. }
         rewrite assoc.
         apply cancel_postcomposition.
         apply pathsinv0, (pr1 (monoidal_associatorisolaw Mon_V _ _ _)).
    }
    rewrite id_left.
    etrans.
    2: { repeat rewrite assoc'.
         do 3 apply maponpaths.
         apply monoidal_associatornatleftright. }
    repeat rewrite assoc.
    apply cancel_postcomposition.
    repeat rewrite assoc'.
    apply pathsinv0, (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso Mon_V _ _ _)).
    cbn.
    etrans.
    2: { repeat rewrite assoc.
         do 2 apply cancel_postcomposition.
         apply pathsinv0, monoidal_associatornatright. }
    repeat rewrite assoc'.
    apply maponpaths.
    rewrite assoc.
    apply (z_iso_inv_on_left _ _ _ _ (functor_on_z_iso (leftwhiskering_functor Mon_V v1) (z_iso_from_associator_iso Mon_V _ _ _))).
    cbn.
    apply pathsinv0, monoidal_pentagonidentity.
  Qed.

  Lemma composedlifteddistributivity_unit: lifteddistributivity_unit composedlifteddistributivity_data.
  Proof.
    red; unfold composedlifteddistributivity_data; cbn.
    rewrite (lifteddistributivity_ldunit δ1).
    rewrite (lifteddistributivity_ldunit δ2).
    etrans.
    { do 3 apply cancel_postcomposition.
      apply maponpaths.
      etrans.
      { apply (functor_comp (rightwhiskering_functor Mon_V v2)). }
      do 2 rewrite functor_comp.
      cbn.
      apply idpath.
    }
    etrans.
    { apply cancel_postcomposition.
      repeat rewrite assoc'.
      do 6 apply maponpaths.
      etrans.
      { apply (functor_comp (leftwhiskering_functor Mon_V v1)). }
      do 2 rewrite functor_comp.
      cbn.
      apply idpath.
    }
    etrans.
    { repeat rewrite assoc.
      do 9 apply cancel_postcomposition.
      apply pathsinv0, monoidal_associatorinvnatright. }
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    { repeat rewrite assoc.
      do 8 apply cancel_postcomposition.
      rewrite <- monoidal_triangleidentity'.
      rewrite assoc.
      apply cancel_postcomposition.
      apply (pr2 (monoidal_associatorisolaw Mon_V _ _ _)).
    }
    rewrite id_left.
    repeat rewrite assoc'.
    apply maponpaths.
    etrans.
    { do 6 apply maponpaths.
      apply monoidal_associatorinvnatleft. }
    repeat rewrite assoc.
    apply cancel_postcomposition.
    etrans.
    { do 4 apply cancel_postcomposition.
      rewrite assoc'.
      apply maponpaths.
      apply pathsinv0, monoidal_associatornatleftright.
    }
    etrans.
    { do 3 apply cancel_postcomposition.
      repeat rewrite assoc'.
      do 2 apply maponpaths.
      etrans.
      { apply pathsinv0, (functor_comp (leftwhiskering_functor Mon_V v1)). }
      apply maponpaths.
      etrans.
      { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). }
      apply (functor_id_id _ _ (rightwhiskering_functor Mon_V v2)).
      apply (pr2 (fmonoidal_preservesunitstrongly U)).
    }
    rewrite functor_id.
    rewrite id_right.
    etrans.
    { repeat rewrite assoc'.
      do 3 apply maponpaths.
      apply monoidal_triangle_identity''_inv. }
    etrans.
    { apply maponpaths.
      rewrite assoc.
      apply cancel_postcomposition.
      apply monoidal_triangleidentity. }
    rewrite assoc.
    etrans.
    { apply cancel_postcomposition.
      etrans.
      { apply pathsinv0, (functor_comp (rightwhiskering_functor Mon_V v2)). }
      apply (functor_id_id _ _ (rightwhiskering_functor Mon_V v2)).
      apply (monoidal_rightunitorisolaw Mon_V).
    }
    apply id_left.
  Qed.

  Definition composedlifteddistributivity: lifteddistributivity (v1 ⊗_{Mon_V} v2).
  Proof.
    exists composedlifteddistributivity_data.
    exact (composedlifteddistributivity_nat,,
           composedlifteddistributivity_tensor,,
           composedlifteddistributivity_unit).
  Defined.

End CompositionOfLiftedDistributivities.

End LiftedDistributivity.

End LiftedLineatorAndLiftedDistributivity.

Arguments lifteddistributivity {_} _ {_} _ {_} _ _.
Arguments lifteddistributivity_data {_} _ {_ _} _.

Section PointwiseOperationsOnLinearFunctors.

  Context {V : category} (Mon_V : monoidal V)
    {C D : category}
    (ActC : actegory Mon_V C) (ActD : actegory Mon_V D).

Section PointwiseBinaryOperationsOnLinearFunctors.

  Context {F1 F2 : functor C D}
    (ll1 : lineator_lax Mon_V ActC ActD F1)
    (ll2 : lineator_lax Mon_V ActC ActD F2).

Section PointwiseBinaryProductOfLinearFunctors.

  Context (BPD : BinProducts D).

  Let FF : functor C D := BinProduct_of_functors _ _ BPD F1 F2.
  Let FF' : functor C D := BinProduct_of_functors_alt BPD F1 F2.

  Definition lax_lineator_binprod_aux: lineator_lax Mon_V ActC ActD FF'.
  Proof.
    use comp_lineator_lax.
    - apply actegory_binprod; assumption.
    - apply actegory_binprod_delta_lineator.
    - use comp_lineator_lax.
      + apply actegory_binprod; assumption.
      + apply actegory_pair_functor_lineator; assumption.
      + apply binprod_functor_lax_lineator.
  Defined.

  Definition lax_lineator_binprod_indirect: lineator_lax Mon_V ActC ActD FF.
  Proof.
    unfold FF.
    rewrite <- BinProduct_of_functors_alt_eq_BinProduct_of_functors.
    apply lax_lineator_binprod_aux.
  Defined.

  Lemma lax_lineator_binprod_indirect_data_ok (v : V) (c : C):
    lax_lineator_binprod_indirect v c =
      binprod_collector_data Mon_V BPD ActD v (F1 c) (F2 c) ·
        BinProductOfArrows _ (BPD _ _) (BPD _ _) (ll1 v c) (ll2 v c).
  Proof.
    unfold lax_lineator_binprod_indirect.
  Abort.
  (* how could one use the equality proof? *)

  (** now an alternative concrete construction *)
  Definition lineator_data_binprod: lineator_data Mon_V ActC ActD FF.
  Proof.
    intros v c.
    exact (binprod_collector_data Mon_V BPD ActD v (F1 c) (F2 c) ·
        BinProductOfArrows _ (BPD _ _) (BPD _ _) (ll1 v c) (ll2 v c)).
  Defined.

  Let cll : lineator_lax Mon_V (actegory_binprod Mon_V ActD ActD) ActD (binproduct_functor BPD)
      := binprod_functor_lax_lineator Mon_V BPD ActD.

  Lemma lineator_laxlaws_binprod: lineator_laxlaws Mon_V ActC ActD FF lineator_data_binprod.
  Proof.
    repeat split; red; intros; unfold lineator_data_binprod.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_linnatleft _ _ _ _ cll v (_,,_) (_,,_) (_,,_)). }
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply BinProductOfArrows_comp. }
      etrans.
      2: { apply pathsinv0, BinProductOfArrows_comp. }
      apply maponpaths_12; apply lineator_linnatleft.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_linnatright _ _ _ _ cll v1 v2 (_,,_) f). }
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply BinProductOfArrows_comp. }
      etrans.
      2: { apply pathsinv0, BinProductOfArrows_comp. }
      apply maponpaths_12; apply lineator_linnatright.
    - etrans.
      { rewrite assoc'.
        apply maponpaths.
        etrans.
        { apply BinProductOfArrows_comp. }
        apply maponpaths_12; apply lineator_preservesactor.
      }
      etrans.
      { apply maponpaths.
        repeat rewrite assoc'.
        apply pathsinv0, BinProductOfArrows_comp. }
      etrans.
      { rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_preservesactor _ _ _ _ cll v w (_,,_)). }
      etrans.
      2: { apply cancel_postcomposition.
           apply maponpaths.
           apply pathsinv0, (functor_comp (leftwhiskering_functor ActD v)). }
      repeat rewrite assoc'.
      do 2 apply maponpaths.
      repeat rewrite assoc.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (lineator_linnatleft _ _ _ _ cll v (_,,_) (_,,_) (_,,_)). }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      2: { apply pathsinv0, BinProductOfArrows_comp. }
      apply idpath.
    - etrans.
      2: { apply (lineator_preservesunitor _ _ _ _ cll (_,,_)). }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply BinProductOfArrows_comp. }
      cbn.
      apply maponpaths_12; apply lineator_preservesunitor.
  Qed.

  Definition lax_lineator_binprod: lineator_lax Mon_V ActC ActD FF :=
    lineator_data_binprod,,lineator_laxlaws_binprod.

End PointwiseBinaryProductOfLinearFunctors.

Section PointwiseBinaryCoproductOfLinearFunctors.

  Context (BCD : BinCoproducts D) (δ : actegory_bincoprod_distributor Mon_V BCD ActD).

  Let FF : functor C D := BinCoproduct_of_functors _ _ BCD F1 F2.
  Let FF' : functor C D := BinCoproduct_of_functors_alt2 BCD F1 F2.

  Definition lax_lineator_bincoprod_aux : lineator_lax Mon_V ActC ActD FF'.
  Proof.
    use comp_lineator_lax.
    - apply actegory_binprod; assumption.
    - apply actegory_binprod_delta_lineator.
    - use comp_lineator_lax.
      + apply actegory_binprod; assumption.
      + apply actegory_pair_functor_lineator; assumption.
      + apply (bincoprod_functor_lineator Mon_V BCD ActD δ).
  Defined.

  Definition lax_lineator_bincoprod_indirect : lineator_lax Mon_V ActC ActD FF.
  Proof.
    unfold FF.
    rewrite <- BinCoproduct_of_functors_alt_eq_BinCoproduct_of_functors.
    apply lax_lineator_bincoprod_aux.
  Defined.

  Lemma lax_lineator_bincoprod_data_ok (v : V) (c : C) : lax_lineator_bincoprod_indirect v c =
    δ v (F1 c) (F2 c) · (BinCoproductOfArrows _ (BCD _ _) (BCD _ _) (ll1 v c) (ll2 v c)).
  Proof.
    unfold lax_lineator_bincoprod_indirect.
  Abort.
  (* how could one use the equality proof? *)

  (** now an alternative concrete construction *)
  Definition lineator_data_bincoprod: lineator_data Mon_V ActC ActD FF.
  Proof.
    intros v c.
    exact (δ v (F1 c) (F2 c) · (BinCoproductOfArrows _ (BCD _ _) (BCD _ _) (ll1 v c) (ll2 v c))).
  Defined.

  Let δll : lineator Mon_V (actegory_binprod Mon_V ActD ActD) ActD (bincoproduct_functor BCD)
      := bincoprod_functor_lineator Mon_V BCD ActD δ.

  Lemma lineator_laxlaws_bincoprod
    : lineator_laxlaws Mon_V ActC ActD FF lineator_data_bincoprod.
  Proof.
    repeat split; red; intros; unfold lineator_data_bincoprod.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_linnatleft _ _ _ _ δll v (_,,_) (_,,_) (_,,_)). }
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply BinCoproductOfArrows_comp. }
      etrans.
      2: { apply pathsinv0, BinCoproductOfArrows_comp. }
      apply maponpaths_12; apply lineator_linnatleft.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_linnatright _ _ _ _ δll v1 v2 (_,,_) f). }
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply BinCoproductOfArrows_comp. }
      etrans.
      2: { apply pathsinv0, BinCoproductOfArrows_comp. }
      apply maponpaths_12; apply lineator_linnatright.
    - etrans.
      { rewrite assoc'.
        apply maponpaths.
        etrans.
        { apply BinCoproductOfArrows_comp. }
        apply maponpaths_12; apply lineator_preservesactor.
      }
      etrans.
      { apply maponpaths.
        repeat rewrite assoc'.
        apply pathsinv0, BinCoproductOfArrows_comp. }
      etrans.
      { rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_preservesactor _ _ _ _ δll v w (_,,_)). }
      etrans.
      2: { apply cancel_postcomposition.
           apply maponpaths.
           apply pathsinv0, (functor_comp (leftwhiskering_functor ActD v)). }
      repeat rewrite assoc'.
      do 2 apply maponpaths.
      repeat rewrite assoc.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (lineator_linnatleft _ _ _ _ δll v (_,,_) (_,,_) (_,,_)). }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      2: { apply pathsinv0, BinCoproductOfArrows_comp. }
      apply idpath.
    - etrans.
      2: { apply (lineator_preservesunitor _ _ _ _ δll (_,,_)). }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply BinCoproductOfArrows_comp. }
      cbn.
      apply maponpaths_12; apply lineator_preservesunitor.
  Qed.

  Definition lax_lineator_bincoprod: lineator_lax Mon_V ActC ActD FF :=
    lineator_data_bincoprod,,lineator_laxlaws_bincoprod.

End PointwiseBinaryCoproductOfLinearFunctors.

End PointwiseBinaryOperationsOnLinearFunctors.

Section PointwiseCoproductOfLinearFunctors.

  Context {I : UU} {F : I -> functor C D}
    (ll : ∏ (i: I), lineator_lax Mon_V ActC ActD (F i))
    (CD : Coproducts I D) (δ : actegory_coprod_distributor Mon_V CD ActD).

  Let FF : functor C D := coproduct_of_functors _ _ _ CD F.
  Let FF' : functor C D := coproduct_of_functors_alt_old _ CD F.

  Definition lax_lineator_coprod_aux : lineator_lax Mon_V ActC ActD FF'.
  Proof.
    use comp_lineator_lax.
    - apply actegory_power; assumption.
    - apply actegory_prod_delta_lineator.
    - use comp_lineator_lax.
      + apply actegory_power; assumption.
      + apply actegory_family_functor_lineator; assumption.
      + apply (coprod_functor_lineator Mon_V CD ActD δ).
  Defined.

  Definition lax_lineator_coprod_indirect : lineator_lax Mon_V ActC ActD FF.
  Proof.
    unfold FF.
    rewrite <- coproduct_of_functors_alt_old_eq_coproduct_of_functors.
    apply lax_lineator_coprod_aux.
  Defined.

  Lemma lax_lineator_coprod_data_ok (v : V) (c : C) : lax_lineator_coprod_indirect v c =
    δ v (fun i => F i c) · (CoproductOfArrows I _ (CD _) (CD _) (fun i => ll i v c)).
  Proof.
    unfold lax_lineator_coprod_indirect.
  Abort.
  (* how could one use the equality proof? *)

  (** now an alternative concrete construction *)
  Definition lineator_data_coprod: lineator_data Mon_V ActC ActD FF.
  Proof.
    intros v c.
    exact (δ v (fun i => F i c) · (CoproductOfArrows I _ (CD _) (CD _) (fun i => ll i v c))).
  Defined.

  Let δll : lineator Mon_V (actegory_power Mon_V I ActD) ActD (coproduct_functor I CD)
      := coprod_functor_lineator Mon_V CD ActD δ.

  Lemma lineator_laxlaws_coprod
    : lineator_laxlaws Mon_V ActC ActD FF lineator_data_coprod.
  Proof.
    repeat split; red; intros; unfold lineator_data_coprod.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_linnatleft _ _ _ _ δll v). }
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply CoproductOfArrows_comp. }
      etrans.
      2: { apply pathsinv0, CoproductOfArrows_comp. }
      apply maponpaths, funextsec; intro i; apply lineator_linnatleft.
    - etrans.
      { repeat rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_linnatright _ _ _ _ δll v1 v2 _ f). }
      repeat rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply CoproductOfArrows_comp. }
      etrans.
      2: { apply pathsinv0, CoproductOfArrows_comp. }
      apply maponpaths, funextsec; intro i; apply lineator_linnatright.
    - etrans.
      { rewrite assoc'.
        apply maponpaths.
        etrans.
        { apply CoproductOfArrows_comp. }
        cbn.
        apply maponpaths, funextsec; intro i; apply lineator_preservesactor.
      }
      etrans.
      { apply maponpaths.
        assert (aux : (fun i => aα^{ ActD }_{ v, w, F i x} · v ⊗^{ ActD}_{l} ll i w x · ll i v (w ⊗_{ ActC} x))
                      = (fun i => aα^{ ActD }_{ v, w, F i x} · (v ⊗^{ ActD}_{l} ll i w x · ll i v (w ⊗_{ ActC} x)))).
        { apply funextsec; intro i; apply assoc'. }
        rewrite aux.
        apply pathsinv0, CoproductOfArrows_comp. }
      etrans.
      { rewrite assoc.
        apply cancel_postcomposition.
        apply (lineator_preservesactor _ _ _ _ δll v w).
      }
      etrans.
      2: { apply cancel_postcomposition.
           apply maponpaths.
           apply pathsinv0, (functor_comp (leftwhiskering_functor ActD v)). }
      repeat rewrite assoc'.
      do 2 apply maponpaths.
      repeat rewrite assoc.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (lineator_linnatleft _ _ _ _ δll v). }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      2: { apply pathsinv0, CoproductOfArrows_comp. }
      apply idpath.
    - etrans.
      2: { apply (lineator_preservesunitor _ _ _ _ δll). }
      rewrite assoc'.
      apply maponpaths.
      etrans.
      { apply CoproductOfArrows_comp. }
      cbn.
      apply maponpaths, funextsec; intro i; apply lineator_preservesunitor.
  Qed.

  Definition lax_lineator_coprod: lineator_lax Mon_V ActC ActD FF :=
    lineator_data_coprod,,lineator_laxlaws_coprod.

End PointwiseCoproductOfLinearFunctors.

End PointwiseOperationsOnLinearFunctors.


Require Import Verdi.Verdi.
Require Import Verdi.HandlerMonad.
Require Import Verdi.NameOverlay.

Require Import NameAdjacency.

Require Import Sumbool.

Require Import mathcomp.ssreflect.ssreflect.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Set Implicit Arguments.

Module FailureRecorder (Import NT : NameType)
 (NOT : NameOrderedType NT) (NSet : MSetInterface.S with Module E := NOT)
 (Import ANT : AdjacentNameType NT) (Import A : Adjacency NT NOT NSet ANT).

Inductive Msg : Set :=
| Fail : Msg.

Definition Msg_eq_dec : forall x y : Msg, {x = y} + {x <> y}.
by case; case; left.
Defined.

Inductive Input : Set := .

Definition Input_eq_dec : forall x y : Input, {x = y} + {x <> y}.
decide equality.
Defined.

Inductive Output : Set := .

Definition Output_eq_dec : forall x y : Output, {x = y} + {x <> y}.
decide equality.
Defined.

Record Data := mkData { adjacent : NS }.

Definition InitData (n : name) := mkData (adjacency n nodes).

Definition Handler (S : Type) := GenHandler (name * Msg) S Output unit.

Definition NetHandler (me src: name) (msg : Msg) : Handler Data :=
st <- get ;;
match msg with
| Fail =>
  put {| adjacent := NSet.remove src st.(adjacent) |}
end.

Definition IOHandler (me : name) (i : Input) : Handler Data := nop.

Instance FailureRecorder_BaseParams : BaseParams :=
  {
    data := Data;
    input := Input;
    output := Output
  }.

Instance FailureRecorder_MultiParams : MultiParams FailureRecorder_BaseParams :=
  {
    name := name ;
    msg  := Msg ;
    msg_eq_dec := Msg_eq_dec ;
    name_eq_dec := name_eq_dec ;
    nodes := nodes ;
    all_names_nodes := all_names_nodes ;
    no_dup_nodes := no_dup_nodes ;
    init_handlers := InitData ;
    net_handlers := fun dst src msg s =>
                      runGenHandler_ignore s (NetHandler dst src msg) ;
    input_handlers := fun nm msg s =>
                        runGenHandler_ignore s (IOHandler nm msg)
  }.

Instance FailureRecorder_NameOverlayParams : NameOverlayParams FailureRecorder_MultiParams :=
  {
    adjacent_to := adjacent_to ;
    adjacent_to_dec := adjacent_to_dec ;
    adjacent_to_symmetric := adjacent_to_symmetric ;
    adjacent_to_irreflexive := adjacent_to_irreflexive
  }.

Instance FailureRecorder_FailMsgParams : FailMsgParams FailureRecorder_MultiParams :=
  {
    msg_fail := Fail
  }.

Lemma net_handlers_NetHandler :
  forall dst src m st os st' ms,
    net_handlers dst src m st = (os, st', ms) ->
    NetHandler dst src m st = (tt, os, st', ms).
Proof.
intros.
simpl in *.
monad_unfold.
repeat break_let.
find_inversion.
destruct u. auto.
Qed.

Lemma input_handlers_IOHandler :
  forall h i d os d' ms,
    input_handlers h i d = (os, d', ms) ->
    IOHandler h i d = (tt, os, d', ms).
Proof.
intros.
simpl in *.
monad_unfold.
repeat break_let.
find_inversion.
destruct u. auto.
Qed.

Lemma IOHandler_cases :
  forall h i st u out st' ms,
      IOHandler h i st = (u, out, st', ms) -> False.
Proof. by move => h; case. Qed.

Lemma NetHandler_cases :
  forall dst src msg st out st' ms,
    NetHandler dst src msg st = (tt, out, st', ms) ->
    msg = Fail /\ out = [] /\ ms = [] /\
    st'.(adjacent) = NSet.remove src st.(adjacent).
Proof.
move => dst src msg st out st' ms.
rewrite /NetHandler.
case: msg; monad_unfold.
rewrite /=.
move => H_eq.
by inversion H_eq.
Qed.

Ltac net_handler_cases :=
  find_apply_lem_hyp NetHandler_cases;
  intuition idtac; subst;
  repeat find_rewrite.

Ltac io_handler_cases :=
  find_apply_lem_hyp IOHandler_cases.

End FailureRecorder.