Require Import Bedrock.Platform.tests.Thread0 Bedrock.Platform.tests.Connect Bedrock.Platform.Bootstrap.

Module Type S.
  Parameter heapSize : nat.
End S.

Module Make(M : S).
Import M.

Module M'.
  Definition globalSched : W := ((heapSize + 50) * 4)%nat.

  Definition inbuf_size := 40.

  Theorem inbuf_size_lower : (inbuf_size >= 2)%nat.
    unfold inbuf_size; auto.
  Qed.

  Theorem inbuf_size_upper : (N_of_nat (inbuf_size * 4) < Npow2 32)%N.
    reflexivity.
  Qed.
End M'.

Import M'.

Module E := Connect.Make(M').
Import E.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 1.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 1.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "connect"!"main" @ [E.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREmain[_] globalSched =?> 1 * 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSched =?> 1 * mallocHeap 0];;

        Goto "connect"!"main"
      end
    }}.

  Ltac t := unfold globalSched, localsInvariantMain, M'.globalSched; genesis.

  Theorem ok0 : moduleOk boot.
    vcgen; abstract t.
  Qed.

  Definition m1 := link Buffers.m boot.
  Definition m2 := link E.m m1.
  Definition m := link m2 E.T.T.m.

  Lemma ok1 : moduleOk m1.
    link Buffers.ok ok0.
  Qed.

  Lemma ok2 : moduleOk m2.
    link E.ok ok1.
  Qed.

  Theorem ok : moduleOk m.
    link ok2 E.T.T.ok.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $ (size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok.
  Qed.
End boot.

End Make.


(* TLC in Coq
 *
 * Module: tlc.component.perfect_link_1
 * Purpose: Contains the local specification of the perfect link PL_1 property.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrnat.
Require Import tlc.component.component.
Require Import tlc.component.perfect_link.
Require Import tlc.logic.all_logic.
Require Import tlc.semantics.all_semantics.
Require Import tlc.syntax.all_syntax.
Require Import tlc.utility.all_utility.

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

Lemma L37_1 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: forall: forall: (* n, n', c, m, m' *)
  $$4 \in UCorrect /\ $$3 \in UCorrect ->
  self-event /\ (on $$4, (0, CSLSend ' $$3 ' ($$2, $$1)) \in Fors) =>>
  always^ ~(self-event /\ on $$4, (0, CSLSend ' $$3 ' ($$2, $$0)) \in Fors)
-}.
Proof.
  dforall n; dforall n'; dforall c; dforall m; dforall m'; dif; dsplitp.

  (* By InvL *)
  dhave {-A
    self-event /\ (on n, (0, CSLSend ' n' ' (c, m)) \in Fors) =>>
    (Fs' ' n).1 = c
  -}.
  {
    repeat dclear.
    eapply DSCut; first by apply DPInvL with (A := {-A
      on n, (0, CSLSend ' n' ' (c, m)) \in Fors ->
      (Fs' ' n).1 = c -});
      [dautoclosed | repeat constructor].

    (* request *)
    difp.
      dforall e; dif; dsplitp; dswap; dsimplp; dsimpl; simpl.
      dcase {-t ? e -}; dexistsp e_m; dexistsp e_n'; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dtinjectionp; repeat dsplitp.

      dif; dsplitp.
      dtgenp; dxchg 1 2; dtsubstep_l; dswap; dclear.
      dtgenp; dtsubste_l; dclear; dsimpl.
      dswap; dtgenp; dtsubstep_l; dswap; dclear.

      duse DPMemberCons;
        dforallp {-t (0, CSLSend ' n' ' (c, m)) -};
        dforallp {-t (0, CSLSend ' e_n' ' (CSucc ' s_c, e_m)) -};
        dforallp {-t [] -};
        dsplitp; dswap; dclear; difp; first by [].
      dorp; last by duse DPMemberNil;
        dforallp {-t (0, CSLSend ' n' ' (c, m)) -}; dnotp.
      dtinjectionp; dsplitp; dclear.
      dsplitp; dclear; dsplitp; dtgenp; dtsubste_l; dautoeq.
      by repeat dclear; exact: DPEqual.

    (* indication *)
    difp.
      dforall i; dforall e; dif; dsplitp; dswap; dsimplp; dsimpl; simpl.
      dcase {-t (? i, ? e) -}; dexistsp e_m; dexistsp e_c; dexistsp e_n; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t FCount ' (? e_n, ? e_c) ' ? s_r == 0 -}; dorp;
        dtgenp; dtsubstep_l; dswap; dclear; dsimplp;
        dtinjectionp; repeat dsplitp;
        dclear; dtgenp; dif; dsplitp; dclear; dswap; dtsubstep_l; dswap; dclear;
        by duse DPMemberNil; dforallp {-t (0, CSLSend ' n' ' (c, m)) -}; dnotp.

    (* periodic *)
    difp.
      dif; dsplitp; dswap; dsimplp; dsimpl; simpl.
      dtinjectionp; repeat dsplitp;
      dclear; dtgenp; dif; dsplitp; dclear; dswap; dtsubstep_l; dswap; dclear;
      by duse DPMemberNil; dforallp {-t (0, CSLSend ' n' ' (c, m)) -}; dnotp.

    by dtmergeentailsifp.
  }

  (* By InvS *)
  dhave {-A
    self-event /\ (Fs ' n).1 >= c =>>
    (self-event =>> (Fs ' n).1 >= c)
  -}.
  {
    repeat dclear.
    eapply DSCut; first by apply DPInvS with
      (S0 := {-A forall: (* s *) ($$0).1 >= c -});
      [| dautoclosed | repeat constructor].
    dforallp n.

    (* request *)
    difp.
      dforall s; dforall e; dsimpl; dif.
      dcase {-t ? s -}; dexistsp s_r; dexistsp s_c;
        dtgenp; dtsubste_l; dtsubstep_l; dswap; dclear;
        dautoeq; dsimpl; dsimplp.
      dcase {-t ? e -}; dexistsp e_n'; dexistsp e_m;
        dtgenp; dtsubste_l; dclear; dautoeq; dsimpl.
      by duse DPSuccGreaterEqual; dforallp s_c; dforallp c; difp.

    (* indication *)
    difp.
      dforall s; dforall i; dforall e; dsimpl; dif.
      dcase {-t ? s -}; dexistsp s_r; dexistsp s_c;
        dtgenp; dtsubste_l; dtsubstep_l; dswap; dclear;
        dautoeq; dsimpl; dsimplp.
      dcase {-t (? i, ? e) -}; dexistsp e_m; dexistsp e_c; dexistsp e_n;
        dtgenp; dtsubste_l; dclear; dautoeq; dsimpl.
      by dcase {-t FCount ' (? e_n, ? e_c) ' ? s_r == 0 -}; dorp;
        dtgenp; dtsubste_l; dclear; dsimpl.

    (* periodic *)
    difp.
      by dforall s; dsimpl; dif.

    by dsimplp.
  }

  (* By ASA on (1) and (2) *)
  dhave {-A
    on n, self-event /\ ((0, CSLSend ' n' ' (c, m)) \in Fors) =>>
    always^ (self-event -> (Fs ' n).1 >= c)
  -}.
  {
    eapply DSCut; first (by repeat dclear; apply DPASA with
      (S := {-A forall: (* s *) ($$0).1 >= c -})
      (A := {-A on n, (0, CSLSend ' n' ' (c, m)) \in Fors -})
      (A' := {-A (Fs ' n).1 >= c -});
      [| dautoclosed | dautoclosed | dautoclosed
        | repeat constructor | repeat constructor]).
    dforallp n; dsimplp.

    (* post *)
    difp.
      duse DPEqualGreaterEqual; dforallp {-t (Fs' ' n).1 -}; dforallp c.
      by dtgenp; dclean; dxchg 1 2; dtsubstposp.

    (* pre *)
    difp.
      by dassumption.

    eapply DSCut; first (by repeat dclear; apply DSAndAssoc with
      (A1 := {-A self-event -})
      (A2 := {-A Fn = n -})
      (A3 := {-A (0, CSLSend ' n' ' (c, m)) \in Fors -}));
      dtgenp; dclean; dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DSAndComm with
      (A1 := {-A self-event -})
      (A2 := {-A Fn = n -}));
      dtgenp; dclean; dtsubstp_l.
    eapply DSCut; first (by repeat dclear; apply DSAndAssoc with
      (A1 := {-A Fn = n -})
      (A2 := {-A self-event -})
      (A3 := {-A (0, CSLSend ' n' ' (c, m)) \in Fors -}));
      dtgenp; dclean; dtsubstp_l.
    by [].
  }

  (* By InvL *)
  dhave {-A
    self-event /\ (Fs ' n).1 >= c =>>
    ~(on n, (0, CSLSend ' n' ' (c, m')) \in Fors)
  -}.
  {
    repeat dclear.
    eapply DSCut; first by apply DPInvL with (A := {-A
      (Fs ' n).1 >= c ->
      ~(on n, (0, CSLSend ' n' ' (c, m')) \in Fors)
    -}); [dautoclosed | repeat constructor].

    (* request *)
    difp.
      dforall e; dif; dsplitp; dswap; dsimplp.
      dcase {-t ? e -}; dexistsp e_m; dexistsp e_n'; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dsimplp.
      dtinjectionp; repeat dsplitp.

      dswap; dtgenp; dtsubste_l; dclear.
      dif; dnot.
      dsplitp; dtgenp.
      dxchg 1 3; dtsubstep_l; dswap.
      dxchg 1 5; dtsubstep_l; dswap; dclear.
      dtsubstep_l; dswap; dclear; dsimplp.

      duse DPMemberCons;
        dforallp {-t (0, CSLSend ' n' ' (c, m')) -};
        dforallp {-t (0, CSLSend ' e_n' ' (CSucc ' s_c, e_m)) -};
        dforallp {-t [] -};
        dsplitp; dswap; dclear; difp; first by dassumption.
      dorp; last by duse DPMemberNil;
        dforallp {-t (0, CSLSend ' n' ' (c, m')) -}; dnotp.
      dtinjectionp; dsplitp; dclear.
      dsplitp; dclear; dsplitp; dswap; dclear; dtgenp;
        dtsubstep_l; dautoeq; dswap; dclear.

      duse DPGreaterEqual; dforallp s_c; dforallp {-t s_c.+1 -}.
      dsplitp; dswap; dclear; difp; first (by []); dswap; dclear; dorp.
      - (* equal *)
        eapply DSCut; first by eapply DSubInjection with
          (t1 := {-t s_c -}) (t2 := {-t s_c.+1 -}); [by [] | auto_mem].
        by dnotp.
      - (* not equal *)
        duse DPNotLessThanIfGreaterThan; dforallp s_c; dforallp {-t s_c.+1 -}.
        difp; last by dnotp.
        by duse DPLessThanSucc; dforallp s_c.

    (* indication *)
    difp.
      dforall i; dforall e; dif; dsplitp; dswap; dsimplp.
      dcase {-t (? i, ? e) -}; dexistsp e_m; dexistsp e_c; dexistsp e_n;
        dtgenp; dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dsimplp.
      by dcase {-t FCount ' (? e_n, ? e_c) ' ? s_r == 0 -}; dorp;
        dtgenp; dtsubstep_l; dswap; dclear; dsimplp;
        dtinjectionp; repeat dsplitp;
        dif; dclear; dnot; dsplitp; dclear;
        dswap; dxchg 0 2; dtgenp; dtsubstep_l; dswap; dclear;
        duse DPMemberNil; dforallp {-t (0, CSLSend ' n' ' (c, m')) -}; dnotp.

    (* periodic *)
    difp.
      dif; dsplitp; dclear; dsimplp.
      by dtinjectionp; repeat dsplitp;
        dif; dclear; dnot; dsplitp; dclear;
        dswap; dxchg 0 2; dtgenp; dtsubstep_l; dswap; dclear;
        duse DPMemberNil; dforallp {-t (0, CSLSend ' n' ' (c, m')) -}; dnotp.

    by dtmergeentailsifp.
  }

  (* From (3) and (4) *)
  dhave {-A
    (self-event -> (Fs ' n).1 >= c) ->
    (self-event -> (self-event /\ (Fs ' n).1 >= c))
  -}; first by repeat dif; dsplit; [| dswap; difp].
  dtgenp; dclean.
  dxchg 1 2; dtsubstposp.
  dswap; dtsubstposp.
  dhave {-A
    (self-event -> ~ on n, (0, CSLSend ' n' ' (c, m')) \in Fors) ->
    ~ (self-event /\ on n, (0, CSLSend ' n' ' (c, m')) \in Fors)
  -}; first by dif; dnot; dsplitp; dxchg 1 2; dswap; difp; [| dnotp; dassumption].
  dtgenp; dclean.
  dtsubstposp.

  eapply DSCut; first (by repeat dclear; apply DSAndAssoc with
    (A1 := {-A Fn = n -})
    (A2 := {-A self-event -})
    (A3 := {-A (0, CSLSend ' n' ' (c, m)) \in Fors -}));
    dtgenp; dclean; dtsubstp_r.
  eapply DSCut; first (by repeat dclear; apply DSAndComm with
    (A1 := {-A Fn = n -})
    (A2 := {-A self-event -}));
    dtgenp; dclean; dtsubstp_l.
  eapply DSCut; first (by repeat dclear; apply DSAndAssoc with
    (A1 := {-A self-event -})
    (A2 := {-A Fn = n -})
    (A3 := {-A (0, CSLSend ' n' ' (c, m)) \in Fors -}));
    dtgenp; dclean; dtsubstp_l.
  by [].
Qed.

Lemma L37_2 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: forall: forall: (* n, n', c, m, m' *)
  $$4 \in UCorrect /\ $$3 \in UCorrect ->
  self-event /\ (on $$4, (0, CSLSend ' $$3 ' ($$2, $$1)) \in Fors) =>>
  alwaysp^ ~(self-event /\ on $$4, (0, CSLSend ' $$3 ' ($$2, $$0)) \in Fors)
-}.
Proof.
  dforall n; dforall n'; dforall c; dforall m; dforall m'; dif.

  (* By L37_1 *)
  duse L37_1; dforallp n; dforallp n'; dforallp c; dforallp m; dforallp m';
    difp; first by [].

  eapply DSCut; first (by repeat dclear; apply DTL105_1 with
    (H := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, m)) \in Fors -})
    (A := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, m')) \in Fors -})).
  by dtsubstposp.
Qed.

Lemma L39 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: forall: (* n, n', m, c *)
  $$3 \in UCorrect /\ $$2 \in UCorrect ->
  on $$2, event[0]<- CSLDeliver ' $$3 ' ($$0, $$1) /\
    ($$3, $$0) \notin (Fs ' $$2).2 ~>
  on $$2, event[]<- CPLDeliver ' $$3 ' $$1
 -}.
Proof.
  dforall n; dforall n'; dforall m; dforall c.
  dif; dsplitp.

  duse DPOI; dforallp n'; dforallp {-t CPLDeliver ' n ' m -}; dsimplp.
  eapply DSCut; first (by repeat dclear; apply DTL121 with
    (A := {-A on n', event[]<- CPLDeliver ' n ' m -}));
    dtsubstposp.

  dhave {-A
    on n', event[0]<- CSLDeliver ' n ' (c, m) /\ (n, c) \notin (Fs ' n').2 ->
    on n', self-event /\ CPLDeliver ' n ' m \in Fois
  -}.
  {
    repeat dclear.
    dif; dsplitp; dswap; dsplitp.
    dsplit; first by dassumption.
    dsplit; first by dleft; dexists {-t 0 -};
      dsplit; dsplitp; [| dclear; dsplitp].
    duse DPII; dforallp {-t 0 -}; dforallp {-t CSLDeliver ' n ' (c, m) -};
      dsimplp; dsplitp; dswap; dclear; difp; first by dassumption.
    dswap; dxchg 0 3; dtgenp; dtsubstep_l; dswap; dclear.
    dcase {-t ? Fs ' ? n' -}; dexistsp s_r; dexistsp s_c;
      dtgenp; dtsubstep_l; dsimplp.
    dswap; dxchg 1 2; dtsubstep_l; dswap; dclear; dswap.
    dcase {-t FCount ' (? n, ? c) ' ? s_r == 0 -}; dorp;
      dtgenp; dtsubstep_l; dsimplp.
    - dswap; dclear; dtinjectionp; repeat dsplitp.
      dxchg 0 2; dtgenp; dtsubste_l.
      by duse DPMemberSingleton; dforallp {-t CPLDeliver ' n ' m -}.
    - dclear; dswap; dsimplp.
      duse DPMemberReflect; dforallp {-t (n, c) -}; dforallp s_r.
      dxchg 1 2; dswap; dtsubstep_l; dsimplp; dswap; dclear;
        dsplitp; dswap; dclear; difp; first by repeat dclear; exact: DPEqual.
      by dswap; dnotp.
  }
  dtgenp; dclean.

  by rewrite /AFollowedBy; dswap; dttransp.
Qed.

Lemma L41 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: (* n, n', c *)
  $$2 \in UCorrect /\ $$1 \in UCorrect ->
  self-event /\ ($$2, $$0) \in (Fs ' $$1).2 =>>
  exists: (* m *)
    eventuallyp (on $$2, event[0]<- CSLDeliver ' $$3 ' ($$1, $$0) /\
      CPLDeliver ' $$3 ' $$0 \in Fois)
 -}.
Proof.
  dforall n; dforall n'; dforall c; dif; dsplitp.

  (* Instantiate InvSA *)
  eapply DSCut; first (by repeat dclear; apply DPInvSA with
    (S0 := {-A forall: (* s *) (n, c) \in ($$0).2 -})
    (A := {-A exists: (* m *)
      (on n', event[0]<- CSLDeliver ' n ' (c, $$0) /\
        CPLDeliver ' n ' $$0 \in Fois) -});
    [| dautoclosed | dautoclosed | repeat constructor | repeat constructor]);
  dforallp n'.

  (* initialize *)
  difp.
    repeat dsimpl.
    by duse DPMemberNil; dforallp {-t (n, c) -}.

  (* request *)
  difp.
    dforall e; dif; dsplitp; dswap; dsplitp; dswap; dsplitp; dsimplp.
    dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp; dtsubstep_l;
      dsimplp.
    dcase {-t ? e -}; dexistsp e_m; dexistsp e_n; dtgenp; dtsubstep_l;
      dautoeq; dsimplp.
    dtinjectionp; repeat dsplitp.

    dxchg 1 5; dtgenp; dtsubstep_l.
    dxchg 1 4; dswap; dtsubstep_l; dautoeq.
    repeat dsimplp; dsplitp.
    by dnotp.

  (* indication *)
  difp.
    dforall i; dforall e; dif; dsplitp; dswap; dsplitp; dswap; dsplitp; dsimplp.
    dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp; dtsubstep_l;
      dsimplp.
    dcase {-t (? i, ? e) -}; dexistsp e_m; dexistsp e_c; dexistsp e_n;
      dtinjectionp; dsplitp;
      dtgenp; dxchg 1 2; dtsubstep_l;
        dswap; dxchg 1 5; dtsubstep_l;
        dswap; dclear; dswap; dautoeq;
      dtgenp; dtsubstep_l;
        dswap; dxchg 1 4; dtsubstep_l;
        dswap; dclear; dautoeq;
      dsimplp.
    dcase {-t FCount ' (? e_n, ? e_c) ' ? s_r == 0 -}; dorp;
      dtgenp; dtsubstep_l; dswap; dclear; dsimplp;
      dtinjectionp; repeat dsplitp;
      dxchg 1 4; dtgenp; dtsubstep_l; dswap; dclear;
      dxchg 1 2; dswap; dtsubstep_l; dswap; dclear;
      repeat dsimplp; dsplitp;
      try by dnotp.
    dexists e_m; dswap.
    duse DPMemberSetUnion;
      dforallp s_r; dforallp {-t [(e_n, e_c)] -}; dforallp {-t (n, c ) -};
      dsplitp; dclear; difp; [by [] |]; dswap; dclear; dorp;
      first by dswap; dnotp.
    duse DPMemberCons;
      dforallp {-t (n, c ) -}; dforallp {-t (e_n, e_c) -}; dforallp {-t [] -};
      dsplitp; dswap; dclear; difp; [by [] |]; dswap; dclear; dorp;
      last by duse DPMemberNil; dforallp {-t (n, c) -}; dnotp.
    dswap; dclear; dxchg 0 2; dclear.
    dsplit; first by dassumption.
    dtgenp; dtsubste_l; dclear.
    dtinjectionp; dsplitp; repeat (dtgenp; dtsubste_l; dautoeq; dclear).
    dsplit; [by [] | dclear].
    by duse DPMemberSingleton; dforallp {-t CPLDeliver ' e_n ' e_m -}.

  (* periodic *)
  difp.
    dsimpl; repeat dclear; dif; repeat (dsplitp; dswap).
    dxchg 0 2; dtinjectionp; repeat dsplitp.
    do 2 (dswap; dclear); dtgenp; dxchg 1 2; dtsubstep_l; dswap; dclear.
    by dswap; dnotp.

  dsimplp.
  rewrite /AOn; dexistsandclosed_l; dtgenp; dclean; dtsubstp_l.
  rewrite /AOn; dtandelimselfap.
  rewrite /AOn; dexistsandclosed_r; dtgenp; dclean; dtsubstp_r.
  dteventuallyp'p.

  set A := {-A on n', event[0]<- CSLDeliver ' n ' (c, $$0) /\
    CPLDeliver ' n ' $$0 \in Fois -}.
  dhave {-A
    (eventuallyp exists: A) <=> (exists: eventuallyp A)
  -}; first by apply DTL127_3.
  by dtsubstp_l.
Qed.

Lemma L40 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: (* n, n', c *)
  $$2 \in UCorrect /\ $$1 \in UCorrect ->
  self-event /\ (on $$1, ($$2, $$0) \in (Fs ' $$1).2) =>>
  exists: (* m *)
    eventuallyp (on $$3, (0, CSLSend ' $$2 ' ($$1, $$0)) \in Fors /\
      self-event /\
      eventually on $$2, event[]<- CPLDeliver ' $$3 ' $$0)
 -}.
Proof.
  dforall n; dforall n'; dforall c; dif.

  (* By Lemma 41 *)
  duse L41; dforallp n; dforallp n'; dforallp c; difp; first by [].

  (* By SL_2 *)
  duse PL_SL_2; dforallp n'; dforallp n.

  (* By OR' *)
  dhave {-A
    forall: (* m *)
    on n, event[0]-> CSLSend ' n' ' (c, $$0) =>>
    eventuallyp (self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors)
  -}.
  {
    dforall m.
    duse DPOR'; dforallp n; dforallp {-t 0 -}; dforallp {-t CSLSend ' n' ' (c, m) -}.
    by eapply DSCut; first (by repeat dclear; apply DTL123 with
      (A := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, m)) \in Fors -}));
      dtsubstposp.
  }

  (* By Lemma 85 on (2) and (3) *)
  dhave {-A
    forall: (* m *)
    on n', event[0]<- CSLDeliver ' n ' (c, $$0) =>>
    eventuallyp (self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors)
  -}.
  {
    dforall m; dswap; dforallp {-t (c, m) -}.
    eapply DTL85; first by dhead.
    by dswap; dforallp m.
  }
  do 2 (dswap; dclear).

  (* By OI *)
  dhave {-A
    forall: (* m *)
    on n', self-event /\ CPLDeliver ' n ' $$0 \in Fois =>>
    eventually (on n', event[]<- CPLDeliver ' n ' $$0)
  -}.
  {
    dforall m.
    duse DPOI; dforallp n'; dforallp {-t CPLDeliver ' n ' m -}.
    by eapply DSCut; first (by repeat dclear; apply DTL121 with
      (A := {-A on n', event[]<- CPLDeliver ' n ' m -}));
      dtsubstposp.
  }

  (* By (1), (4), and (5) *)
  dhave {-A
    self-event /\ (n, c) \in (Fs ' n').2 =>>
    exists: (* m *)
      eventuallyp (eventuallyp (self-event /\
        (on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors)) /\
        eventually on n', event []<- CPLDeliver ' n ' $$0)
  -}.
  {
    dswap; dxchg 1 2; dswap.
    eapply DSCut; first (by repeat dclear; apply DSAndElimSelf with
      (A := {-A Fn = n' -}));
      dtgenp; dclean; dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n' -})
      (A2 := {-A Fn = n' -})
      (A3 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) /\
        CPLDeliver ' n ' $$0 \in Fois -}));
      dtsubstp_l.
    eapply DSCut; first (by apply DSAndComm with
      (A1 := {-A Fn = n' -})
      (A2 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) /\
        CPLDeliver ' n ' $$0 \in Fois -}));
      dtgenp; dclean; dtsubstp_l.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A2 := {-A CPLDeliver ' n ' $$0 \in Fois -})
      (A3 := {-A Fn = n' -}));
      dtsubstp_l.
    eapply DSCut; first (by apply DSAndComm with
      (A1 := {-A CPLDeliver ' n ' $$0 \in Fois -})
      (A2 := {-A Fn = n' -}));
      dtgenp; dclean; dtsubstp_l.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n' -})
      (A2 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A3 := {-A on n', CPLDeliver ' n ' $$0 \in Fois -}));
      dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DSAndElimSelf with
      (A := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -}));
      dtgenp; dclean; dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n' -})
      (A2 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A3 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -}));
      dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A on n', event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A2 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A3 := {-A on n', CPLDeliver ' n ' $$0 \in Fois -}));
      dtsubstp_l.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A2 := {-A Fn = n' -})
      (A3 := {-A CPLDeliver ' n ' $$0 \in Fois -}));
      dtsubstp_r.
    eapply DSCut; first (by apply DSAndComm with
      (A1 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A2 := {-A Fn = n' -}));
      dtgenp; dclean; dtsubstp_l.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n' -})
      (A2 := {-A event[0]<- CSLDeliver ' n ' (c, $$0) -})
      (A3 := {-A CPLDeliver ' n ' $$0 \in Fois -}));
      dtsubstp_l.
    dswap; dtsubstposp.
    duse DPSubIndicationSelf; dtsubstposp.
    by dswap; dtsubstposp.
  }
  do 3 (dswap; dclear).

  eapply DSCut; first (by repeat dclear; apply DTL126 with
    (A1 := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
    (A2 := {-A on n', event[]<- CPLDeliver ' n ' $$0 -}));
    dtsubstposp.
  eapply DSCut; first (by apply DSAndComm with
    (A1 := {-A self-event -})
    (A2 := {-A on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -}));
    dtgenp; dclean; dtsubstp_l.
  eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
    (A1 := {-A on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
    (A2 := {-A self-event -})
    (A3 := {-A eventually (on n', event[]<- CPLDeliver ' n ' $$0) -}));
    dtsubstp_l.
  eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
    (A1 := {-A Fn = n -})
    (A2 := {-A (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
    (A3 := {-A self-event /\ eventually (on n', event[]<- CPLDeliver ' n ' $$0) -}));
    dtsubstp_l.

  dhave {-A on n', (n, c) \in (Fs ' n').2 =>> (n, c) \in (Fs ' n').2 -};
    first by dtgen; dif; dsplitp; dassumption.
  by dtsubstnegp.
Qed.

Lemma L38 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: forall: (* n, n', m, c *)
  $$3 \in UCorrect /\ $$2 \in UCorrect ->
  on $$2, event[0]<- CSLDeliver ' $$3 ' ($$0, $$1) =>>
  eventually (on $$2, event[]<- CPLDeliver ' $$3 ' $$1) \/
  exists: (* m' *)
    eventuallyp (on $$4, (0, CSLSend ' $$3 ' ($$1, $$0)) \in Fors /\ self-event /\
      eventually on $$3, event[]<- CPLDeliver ' $$4 ' $$0)
 -}.
Proof.
  dforall n; dforall n'; dforall m; dforall c; dif.

  dhave {-A (n, c) \notin (Fs ' n').2 \/ (n, c) \in (Fs ' n').2 -}.
  {
    duse DPMemberReflect; dforallp {-t (n, c) -}; dforallp {-t (Fs ' n').2 -};
      dtgenp; dclean; dtsubst_l; dclear.
    dcase {-t FCount ' (? n, ? c) ' (? Fs ' ? n').2 == 0 -}; dorp;
      dtgenp; dtsubste_l; dclear; dsimpl; repeat dclear;
      by dif.
  }

  eapply DSCut; first (by eapply DTEntailsAlwaysC with
    (H := {-A on n', event[0]<- CSLDeliver ' n ' (c, m) -});
    dtgenp; dhead); dswap; dclear.
  eapply DSCut; first (by apply DTEntailsTautology with
    (A := {-A on n', event[0]<- CSLDeliver ' n ' (c, m) -}));
    rewrite -DTEntailsAndSplitP.
  eapply DSCut; first (by apply DSOrDistribAnd2 with
    (A := {-A on n', event[0]<- CSLDeliver ' n ' (c, m) -})
    (A1 := {-A (n, c) \notin (Fs ' n').2 -})
    (A2 := {-A (n, c) \in (Fs ' n').2 -}));
    dtgenp; dclean; dtsubstp_l.

  (* Align false case with L39 precondition *)
  dhave {-A
    (on n', event[0]<- CSLDeliver ' n ' (c, m)) /\ (n, c) \notin (Fs ' n').2 =>>
    on n', event[0]<- CSLDeliver ' n ' (c, m) /\ (n, c) \notin (Fs ' n').2
  -}.
  {
    repeat dclear; dtgen; dif; repeat dsplitp.
    by dsplit; [| dsplit]; dassumption.
  }
  dtsubstposp.

  (* Align true case with L40 precondition *)
  dhave {-A
    (on n', event[0]<- CSLDeliver ' n ' (c, m)) /\ (n, c) \in (Fs ' n').2 =>>
    self-event /\ (on n', (n, c) \in (Fs ' n').2)
  -}.
  {
    repeat dclear; dtgen; dif; repeat dsplitp.
    dsplit; last by dsplit; dassumption.
    by dswap; duse DPSubIndicationSelf; dtsubstposp.
  }
  dtsubstposp.

  (* By Lemma 39 *)
  duse L39; dforallp n; dforallp n'; dforallp m; dforallp c; difp; first by dassumption.
  dtsubstposp.

  (* By Lemma 40 *)
  duse L40; dforallp n; dforallp n'; dforallp c; difp; first by dassumption.
  dtsubstposp.

  by [].
Qed.

(* Reliable delivery
 * If a correct node n sends a message m to a correct node n', then n' will
 * eventually deliver m.
 *)
Theorem PL_1 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: (* n, n', m *)
  $$2 \in UCorrect /\ $$1 \in UCorrect ->
  on $$2, event[]-> CPLSend ' $$1 ' $$0 ~>
  on $$1, event[]<- CPLDeliver ' $$2 ' $$0
 -}.
Proof.
  dforall n; dforall n'; dforall m; dif; dsplitp.

  (* By IR *)
  dhave {-A
    exists: (* c *)
    on n, event[]-> CPLSend ' n' ' m =>>
    self-event /\ on n, (0, CSLSend ' n' ' ($$0, m)) \in Fors
  -}.
  {
    duse DPIR; dforallp {-t CPLSend ' n' ' m -}; dsimplp.
    dcase {-t ? Fs ' ? Fn -}; dexistsp r; dexistsp c; dtgenp;
      dtsubstep_l; dswap; dclear; dsimplp; dtinjectionp.
    dexists {-t c.+1 -}; dtgen; dsplitp; dswap; dclear.
    dif; dsplitp; dxchg 0 2; difp; first by dassumption.
    repeat dsplitp.
    dsplit; first by dxchg 0 3; duse DPTopRequestSelf; dtsubstposp.
    dsplit; first by dassumption.
    dclear; dtgenp; dtsubste_l; dclear.
    by duse DPMemberSingleton; dforallp {-t (0, CSLSend ' n' ' (c.+1, m)) -}.
  }
  dexistsp c.

  (* By OR *)
  dhave {-A
    (self-event /\ on n, ((0, CSLSend ' n' ' (c, m)) \in Fors)) =>>
    eventually (on n, event[0]-> CSLSend ' n' ' (c, m))
  -}.
  {
    repeat dclear.

    duse DPOR; dforallp n; dforallp {-t 0 -}; dforallp {-t CSLSend ' n' ' (c, m) -}.
    eapply DSCut; first (by apply DTEventually' with
      (A := {-A on n, event[0]-> CSLSend ' n' ' (c, m) -}));
      dtsubstposp.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n -})
      (A2 := {-A self-event -})
      (A3 := {-A (0, CSLSend ' n' ' (c, m)) \in Fors -}));
      dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DSAndComm with
      (A1 := {-A Fn = n -})
      (A2 := {-A self-event -}));
      dtgenp; dclean; dtsubstp_l.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A self-event -})
      (A2 := {-A Fn = n -})
      (A3 := {-A (0, CSLSend ' n' ' (c, m)) \in Fors -}));
      dtsubstp_l.

    by [].
  }
  dtsubstposp_keep; dswap; dclear; dswap; rewrite -DTEntailsAndSplitP.
  eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
    (A1 := {-A self-event -})
    (A2 := {-A on n, (0, CSLSend ' n' ' (c, m)) \in Fors -})
    (A3 := {-A eventually on n, event[0]-> CSLSend ' n' ' (c, m) -}));
    dtsubstp_l.

  (* By SL_1 and Axiom 1 *)
  dhave {-A
    on n, event[0]-> CSLSend ' n' ' (c, m) ~>
    on n', event[0]<- CSLDeliver ' n ' (c, m)
  -}.
  {
    duse PL_SL_1; dforallp n; dforallp n'; dforallp {-t (c, m) -};
      difp; first by dsplit; dassumption.
    by rewrite DTEntailsAndSplitP.
  }

  (* By Lemma 86 on (1) and (2) *)
  (* It is quicker to rewrite (2) into (1) and use Lemma 120 *)
  dtsubstposp; eapply DSCut; first (by apply DTL120_1 with
    (A := {-A on n', event[0]<- CSLDeliver ' n ' (c, m) -}));
    dtsubstp_r.

  (* By Lemma 96 on (3) and Lemma 38 *)
  dhave {-A
    on n, event[]-> CPLSend ' n' ' m =>>
    self-event /\ (on n, (0, CSLSend ' n' ' (c, m)) \in Fors) /\
    eventually (eventually (on n', event[]<- CPLDeliver ' n ' m) \/
      exists: (* m *) eventuallyp ((self-event /\
        on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors) /\
        eventually on n', event[]<- CPLDeliver ' n ' $$0))
  -}.
  {
    duse L38; dforallp n; dforallp n'; dforallp m; dforallp c; difp;
      first by dsplit; dassumption.
    (* It is quicker to rewrite L38 into (3) *)
    dtsubstposp.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n -})
      (A2 := {-A (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
      (A3 := {-A self-event /\ eventually (on n', event[]<- CPLDeliver ' n ' $$0) -}));
      dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
      (A2 := {-A self-event -})
      (A3 := {-A eventually (on n', event[]<- CPLDeliver ' n ' $$0) -}));
      dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DSAndComm with
      (A1 := {-A on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
      (A2 := {-A self-event -}));
      dtgenp; dtsubstp_l.
    by [].
  }
  dswap; dclear.

  (* That is *)
  dteventuallyorcomm; dtsubstp_l.
  dteventuallyexistscomm; dtsubstp_l.
  dteventuallyidemp; dtsubstp_r.
  match goal with
  | |- context[ {-A eventually eventuallyp ?A_ -} ] =>
    eapply DSCut; first (by repeat dclear; apply DTL109_3 with (A := A_))
  end; dtsubstposp.

  (* By Lemma 37 *)
  dhave {-A
    on n, event[]-> CPLSend ' n' ' m =>>
    self-event /\ (on n, (0, CSLSend ' n' ' (c, m)) \in Fors) /\
    (eventually (on n', event[]<- CPLDeliver ' n ' m) \/
      exists: (* m *) (self-event /\
        (on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors) /\
        eventually on n', event[]<- CPLDeliver ' n ' $$0))
  -}.
  {
    match goal with
    | |- context[ {-A self-event /\ ?A2_ /\ ?A3_ -} ] =>
      eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
        (A1 := {-A self-event -}) (A2 := A2_) (A3 := A3_))
    end; dtsubstp_r.

    eapply DSCut; first (by repeat dclear; apply DTAndElimSelf with
      (A := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, m)) \in Fors -}));
      dtsubstp_r.
    match goal with
    | |- context[ {-A (?A1_ /\ ?A1_) /\ ?A3_ -} ] =>
      eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
        (A1 := A1_) (A2 := A1_) (A3 := A3_))
    end; repeat dautoeq; dtsubstp_l.
    dtordistrib2_2.

    dtandintoexists; dtsubstposp.
    match goal with
    | |- context[ {-A exists: ?A1_ /\ (?A2_ \/ ?A3_) -} ] =>
      set A1 := A1_; set A2 := A2_; set A3 := A3_
    end.

    dhave {-A
      A1 /\ (A2 \/ A3) <=>
      A1 /\ A2 \/ A1 /\ A3
    -}; first (by repeat dclear; apply DTOrDistrib2); dtsubstp_l.
    eapply DSCut; first (by repeat dclear; eapply DTAndComm with
      (A1 := A1) (A2 := A2)); dtsubstp_l.
    eapply DSCut; first (by repeat dclear; eapply DTAndComm with
      (A1 := A1) (A2 := A3)); dtsubstp_l.

    (* Future case *)
    set A1' := {-A always^ ~(self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors) -}.
    rewrite -/A1 -/A2 -/A3.
    dhave {-A
      forall:
      (A2 /\ A1) =>>
      (A2 /\ A1')
    -}; first (by dforall m'; dtandha_l; dsplitp; dswap; dclear; dsplitp; dclear; difp;
      first by duse L37_1; dforallp n; dforallp n'; dforallp c; dforallp m; dforallp m'; difp;
      first by dsplit; dassumption); dtsubstposp.
    eapply DSCut; first (by repeat dclear; apply DTL103_1 with
      (A1 := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
      (A2 := {-A eventually on n', event[]<- CPLDeliver ' n ' $$0 -}));
      dtsubstposp.
    clear A1'.

    (* Past case *)
    set A1' := {-A alwaysp^ ~(self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors) -}.
    rewrite -/A1 -/A2 -/A3.
    dhave {-A
      forall:
      (A3 /\ A1) =>>
      (A3 /\ A1')
    -}; first (by dforall m'; dtandha_l; dsplitp; dswap; dclear; dsplitp; dclear; difp;
      first by duse L37_2; dforallp n; dforallp n'; dforallp c; dforallp m; dforallp m'; difp;
      first by dsplit; dassumption); dtsubstposp.
    eapply DSCut; first (by repeat dclear; apply DTL103_2 with
      (A1 := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
      (A2 := {-A eventually on n', event[]<- CPLDeliver ' n ' $$0 -}));
      dtsubstposp.
    clear A1'.

    clear A1 A2 A3.
    set A1 := {-A self-event /\ (on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors) -}.
    set A2 := {-A eventually on n', event[]<- CPLDeliver ' n ' $$0 -}.
    eapply DSCut; first (by repeat dclear; apply DTOrDistrib2 with
      (A1 := A1) (A2 := A2) (A3 := A2)); dtsubstp_r.
    eapply DSCut; first (by repeat dclear; apply DTOrElimSelf with
      (A := A2)); dtsubstp_l.

    by repeat (match goal with
    | |- context[ {-A (self-event /\ ?A2_) /\ ?A3_ -} ] =>
      eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
        (A1 := {-A self-event -}) (A2 := A2_) (A3 := A3_))
    end; dtsubstp_l).
  }

  (* Thus *)
  eapply DSCut; first (repeat dclear; by apply DTOrComm with
    (H1 := {-A eventually on n', event[]<- CPLDeliver ' n ' m -})
    (H2 := {-A exists: (* m *) self-event /\
      (on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors) /\
      eventually on n', event[]<- CPLDeliver ' n ' $$0 -}));
    dtsubstp_l.
  eapply DSCut; first (repeat dclear; by apply DTAndAssoc with
    (A1 := {-A self-event -})
    (A2 := {-A on n, (0, CSLSend ' n' ' (c, m)) \in Fors -})
    (A3 := {-A (exists: (* m *) self-event /\
      (on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors) /\
      eventually on n', event[]<- CPLDeliver ' n ' $$0) \/
      eventually on n', event[]<- CPLDeliver ' n ' m -}));
    dtsubstp_r.
  eapply DSCut; first (repeat dclear; by apply DTAndAssoc with
    (A1 := {-A self-event -})
    (A2 := {-A on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
    (A3 := {-A eventually on n', event[]<- CPLDeliver ' n ' $$0 -}));
    dtsubstp_r.
  eapply DSCut; first (repeat dclear; by apply DTOrDistrib2 with
    (A1 := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, m)) \in Fors -})
    (A2 := {-A exists: (* m *) (self-event /\
      (on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors)) /\
      eventually on n', event[]<- CPLDeliver ' n ' $$0 -})
    (A3 := {-A eventually on n', event[]<- CPLDeliver ' n ' m -}));
    dtsubstp_l.
  eapply DSCut; first (by repeat dclear; eapply DTAndExampleExists with
    (H1 := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, $$0)) \in Fors -})
    (H2 := {-A eventually on n', event[]<- CPLDeliver ' n ' $$0 -})
    (x := {-t m -})); dsimplp; dtsubstposp.
  eapply DSCut; first (by repeat dclear; apply DTEntailsAndDropLeft with
    (A1 := {-A self-event /\ on n, (0, CSLSend ' n' ' (c, m)) \in Fors -})
    (A2 := {-A eventually on n', event[]<- CPLDeliver ' n ' m -}));
    dtsubstposp.
  by eapply DSCut; first (by repeat dclear; apply DTOrElimSelf with
    (A := {-A eventually on n', event[]<- CPLDeliver ' n ' m -}));
    dtsubstp_l.
Qed.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome.Theory Require Import Core.
Import Core.Notations.

Section WithVar.
  Context (V : Type)
          {V_Eqb : Eqb V}
          {V_default : WithDefault V}.

  Notation named_list := (@named_list V).
  Notation named_map := (@named_map V).
  Notation term := (@term V).
  Notation ctx := (@ctx V).
  Notation sort := (@sort V).
  Notation subst := (@subst V).
  Notation rule := (@rule V).
  Notation lang := (@lang V).

  Notation eq_subst l :=
    (eq_subst (Model:= core_model l)).
  Notation eq_args l :=
    (eq_args (Model:= core_model l)).
  Notation wf_subst l :=
    (wf_subst (Model:= core_model l)).
  Notation wf_args l :=
    (wf_args (Model:= core_model l)).
  Notation wf_ctx l :=
    (wf_ctx (Model:= core_model l)).

  (* Compilers can target an arbitrary model.
     They do not have to target syntax.
   *)

  Section WithPreModel.
    Context {tgt_term tgt_sort : Type}
            {tgt_Model : @PreModel V tgt_term tgt_sort}
            (*TODO: should I make it so that these aren't necessary?*)
            `{WithDefault tgt_term}
            `{WithDefault tgt_sort}.

(* each element is the image for that constructor or axiom*)
Variant compiler_case :=
 | term_case (args : list V) (e:tgt_term)
 | sort_case (args : list V) (t:tgt_sort).
Definition compiler := named_list compiler_case.

Lemma invert_eq_term_case_term_case args args' e e'
  : term_case args e = term_case args' e' <-> args = args' /\ e = e'.
Proof using. solve_invert_constr_eq_lemma. Qed.
Hint Rewrite invert_eq_term_case_term_case : lang_core.

Lemma invert_eq_term_case_sort_case args args' e e'
  : term_case args e = sort_case args' e' <-> False.
Proof using. solve_invert_constr_eq_lemma. Qed.
Hint Rewrite invert_eq_term_case_sort_case : lang_core.

Lemma invert_eq_sort_case_term_case args args' e e'
  : sort_case args e = term_case args' e' <-> False.
Proof using. solve_invert_constr_eq_lemma. Qed.
Hint Rewrite invert_eq_sort_case_term_case : lang_core.

Lemma invert_eq_sort_case_sort_case args args' e e'
  : sort_case args e = sort_case args' e' <-> args = args' /\ e = e'.
Proof using. solve_invert_constr_eq_lemma. Qed.
Hint Rewrite invert_eq_sort_case_sort_case : lang_core.

Section CompileFn.
  Context (cmp : compiler).

  (*TODO: move to Term.v*)
  Existing Instance term_default.
  Existing Instance sort_default.

  (*TODO: is this the right choice?
    It's the same as combine for wf terms,
    but it makes some theorems easier
    at the expense of requiring a default instance for V
   *)
  Fixpoint combine_r_padded {A B : Type} `{WithDefault B}
           (l : list A) (l' : list B) {struct l} : list (A * B) :=
  match l, l' with
  | [],_ => []
  | x :: tl, [] => (x, default) :: combine_r_padded tl []
  | x :: tl, y :: tl' => (x, y) :: combine_r_padded tl tl'
  end.

Arguments combine_r_padded [A B]%type_scope {_} (_ _)%list_scope.

  (*TODO: notations do a poor job of spacing this*)
  Fixpoint compile (e : term) : tgt_term :=
    match e with
    | var x => inj_var x
    | con n s =>
      let arg_terms := map compile s in
      match named_list_lookup_err cmp n with
      | Some (term_case args e) => e[/combine_r_padded args arg_terms/]
      | _ => default
      end
    end.

  Definition compile_sort (t : sort) : tgt_sort :=
    match t with
    | scon n s =>
      let arg_terms := map compile s in
      match named_list_lookup_err cmp n with
      | Some (sort_case args t) => t[/combine_r_padded args arg_terms/]
      | _ => default
      end
    end.

  Definition compile_args := map compile.

  Definition compile_subst (s : named_list term) := named_map compile s.

  Definition compile_ctx (c:named_list sort) := named_map compile_sort c.

End CompileFn.
End WithPreModel.

  Section WithModel.
    Context {tgt_term tgt_sort : Type}
      {tgt_Model : @Model V tgt_term tgt_sort}
      (*TODO: should I make it so that these aren't necessary?*)
      `{WithDefault tgt_term}
      `{WithDefault tgt_sort}.

    Existing Instance tgt_Model.

    Notation compiler :=
      (compiler (tgt_term:=tgt_term)
         (tgt_sort:=tgt_sort)).

Section CompileJudgment.
  Context (cmp : compiler)
    (src : lang).

  Notation compile := (compile cmp).
  Notation compile_sort := (compile_sort cmp).
  Notation compile_ctx := (compile_ctx cmp).
  Notation compile_args := (compile_args cmp).
  Notation compile_subst := (compile_subst cmp).

   (* First we specify the properties semantically,
     then inductively on the compiler. TODO: prove equivalent
   *)
  Definition sort_wf_preserving_sem :=
    forall c t,
      wf_sort src c t ->
      wf_ctx src c ->
      Model.wf_sort (compile_ctx c) (compile_sort t).

  Definition term_wf_preserving_sem :=
    forall c e t,
      wf_term src c e t ->
      wf_ctx src c ->
      Model.wf_term (compile_ctx c) (compile e) (compile_sort t).

  Definition sort_eq_preserving_sem :=
    forall c t1 t2,
      eq_sort src c t1 t2 ->
      wf_ctx src c ->
      Model.eq_sort (compile_ctx c) (compile_sort t1) (compile_sort t2).

  Definition term_eq_preserving_sem :=
    forall c t e1 e2,
      eq_term src c t e1 e2 ->
      wf_ctx src c ->
      Model.eq_term (compile_ctx c) (compile_sort t) (compile e1) (compile e2).

  Definition args_wf_preserving_sem :=
    forall c s c',
      wf_args src c s c' ->
      wf_ctx src c ->
      wf_ctx src c' ->
      Model.wf_args (compile_ctx c) (compile_args s) (compile_ctx c').

  Definition subst_eq_preserving_sem :=
    forall c c' s1 s2,
      eq_subst src c c' s1 s2 ->
      wf_ctx src c ->
      wf_ctx src c' ->
      Model.eq_subst (compile_ctx c) (compile_ctx c') (compile_subst s1) (compile_subst s2).

  Definition ctx_wf_preserving_sem :=
    forall c, wf_ctx src c -> Model.wf_ctx (compile_ctx c).

  (*Set up to match the combined scheme for the judgment inductives *)
  Definition semantics_preserving :=
    sort_eq_preserving_sem /\ term_eq_preserving_sem /\ subst_eq_preserving_sem
    /\ sort_wf_preserving_sem /\ term_wf_preserving_sem /\ args_wf_preserving_sem
    /\ ctx_wf_preserving_sem.

End CompileJudgment.

(*
First we define an inductively provable (and in fact decidable) property
of elaborated compilers.
*)

Section Extension.
  Context (cmp_pre : compiler).
  (*TODO: this is an equal or stronger property (which?); includes le principles;
  formalize the relationship to those above and le semantic statements *)
  Inductive preserving_compiler_ext : compiler -> lang -> Prop :=
  | preserving_compiler_nil : preserving_compiler_ext [] []
  | preserving_compiler_sort : forall cmp l n c args t,
      preserving_compiler_ext cmp l ->
      (* Notable: only uses the previous parts of the compiler on c *)
      Model.wf_sort (compile_ctx (cmp ++ cmp_pre) c) t ->
      preserving_compiler_ext ((n,sort_case (map fst c) t)::cmp)
                              ((n,sort_rule c args) :: l)
  | preserving_compiler_term : forall cmp l n c args e t,
      preserving_compiler_ext cmp l ->
      (* Notable: only uses the previous parts of the compiler on c, t *)
      Model.wf_term (compile_ctx (cmp ++ cmp_pre) c) e (compile_sort (cmp ++ cmp_pre) t) ->
      preserving_compiler_ext ((n, term_case (map fst c) e)::cmp)
                              ((n,term_rule c args t) :: l)
  | preserving_compiler_sort_eq : forall cmp l n c t1 t2,
      preserving_compiler_ext cmp l ->
      (* Notable: only uses the previous parts of the compiler on c *)
      Model.eq_sort (compile_ctx (cmp ++ cmp_pre) c)
              (compile_sort (cmp ++ cmp_pre) t1)
              (compile_sort (cmp ++ cmp_pre) t2) ->
      preserving_compiler_ext cmp ((n,sort_eq_rule c t1 t2) :: l)
  | preserving_compiler_term_eq : forall cmp l n c e1 e2 t,
      preserving_compiler_ext cmp l ->
      (* Notable: only uses the previous parts of the compiler on c *)
      Model.eq_term (compile_ctx (cmp ++ cmp_pre) c)
              (compile_sort (cmp ++ cmp_pre) t)
              (compile (cmp ++ cmp_pre) e1)
              (compile (cmp ++ cmp_pre) e2) ->
      preserving_compiler_ext cmp ((n,term_eq_rule c e1 e2 t) :: l).

End Extension.

End WithModel.

End WithVar.
#[export] Hint Rewrite invert_eq_term_case_term_case : lang_core.
#[export] Hint Rewrite invert_eq_term_case_sort_case : lang_core.
#[export] Hint Rewrite invert_eq_sort_case_term_case : lang_core.
#[export] Hint Rewrite invert_eq_sort_case_sort_case : lang_core.
#[export] Hint Constructors preserving_compiler_ext : lang_core.

(*TODO: add preserving_compiler notation once other files are updated *)
(*TODO: shouth the RHS be in the constr entry?
  Probably not now that compilers are more general.
*)

Declare Custom Entry comp_case.

Module Notations.

  Notation "| '{{s' # constr }} => t " :=
    (constr, sort_case nil t)
      (in custom comp_case at level 50,
          left associativity,
          constr constr at level 0,
          t constr,
          format "|  '{{s' # constr }}  =>  t").

  Notation "| '{{e' # constr }} => e " :=
    (constr, term_case nil e)
      (in custom comp_case at level 50,
          left associativity,
          constr constr at level 0,
          e constr,
          format "|  '{{e' # constr }}  =>  e").

  Notation "| '{{s' # constr x .. y }} => t" :=
    (constr, sort_case (cons y .. (cons x nil) ..) t)
      (in custom comp_case at level 50,
          left associativity,
          constr constr at level 0,
          x constr at level 0,
          y constr at level 0,
          t constr,
          format "|  '{{s' # constr  x  ..  y }}  =>  t").

  Notation "| '{{e' # constr x .. y }} => e " :=
    (constr, term_case (cons y .. (cons x nil) ..) e)
      (in custom comp_case at level 50,
          left associativity,
          constr constr at level 0,
          x constr at level 0,
          y constr at level 0,
          e constr,
          format "|  '{{e' # constr  x  ..  y }}  =>  e").

  (* Cases must be given in the order of the source language,
     and argument names must match the context of the related source rule.
     All cases must be defined.
   *)
  Notation "'match' # 'with' case_1 .. case_n 'end'" :=
    (cons case_n .. (cons case_1 nil) ..)
      (left associativity, at level 50,
       case_1 custom comp_case,
       case_n custom comp_case,
       format "'[' 'match'  #  'with' '//' '[v' case_1 '//' .. '//' case_n ']'  '//' 'end' ']'").

  (*TODO: specialized to strings. Generalize.*)
  Definition gen_rule (cmp : compiler string) (p : string * rule string) : named_list string (compiler_case string) :=
    let (n,r) := p in
    match r with
    | sort_rule c args =>
      match named_list_lookup (sort_case (map fst c) (scon n (map (@var string) args))) cmp n with
      | sort_case args' t =>
        [(n,sort_case (map fst c) t[/combine args' (map (@var string) (map fst c))/])]
      | _ => [(n,sort_case [] {{s#"ERR: expected sort case"}})]
      end
    | term_rule c args t =>
      match named_list_lookup (term_case (map fst c) (con n (map (@var string) args))) cmp n with
      | term_case args' e =>
        [(n,term_case (map fst c) e[/combine args' (map (@var string) (map fst c))/])]
      | _ => [(n,sort_case [] {{s#"ERR: expected term case"}})]
      end
    | sort_eq_rule _ _ _
    | term_eq_rule _ _ _ _ => []
    end.

  (* accepts rules unordered and handles renaming to match language.
     Defaults to an identity rule for anything unspecified.
   *)
  Notation "'match' # 'from' l 'with' case_1 .. case_n 'end'" :=
    (flat_map (gen_rule (cons case_n .. (cons case_1 nil) ..)) l)
      (left associativity, at level 50,
       case_1 custom comp_case,
       case_n custom comp_case,
       format "'[' 'match'  #  'from'  l  'with' '//' '[v' case_1 '//' .. '//' case_n ']' '//' 'end' ']'").
End Notations.


Require Import List.
Import ListNotations.
Require Import BirkStar.birk_star.
Require Import Utf8.
Require Import Coq.Program.Equality.

Definition x := t_Var 0.
Definition y := t_Var 1.
Definition z := t_Var 2.

Definition x' := 0.
Definition y' := 1.
Definition z' := 2.

(* Let A B C represent arbitrary well-formed types. *)
Context {A B C : type}.
Context (hA : forall ctx, type_form ctx A).
Context (hB : forall ctx, type_form ctx B).
Context (hC : forall ctx, type_form ctx C).

Lemma example_typing: type_of_term [Some (x', A)] x A.
Proof.
apply term_var.
{ apply ctx_var. apply ctx_emp. apply hA.
}
unfold C_in.
exists C_nil.
exists C_nil.
simpl.
split.
{ auto. }
split.
{ intro. destruct H. exact H. }
{ auto. }
Qed.

Lemma example_typing2: type_of_term []
  (t_Lam x' (t_Lam y' (t_Var y'))) (T_Fun x' A (T_Fun y' B B)).
Proof.
apply pi_intro.
apply hA.
apply pi_intro.
apply hB.
apply term_var.
{ apply ctx_var. apply ctx_var. apply ctx_emp. apply hA. apply hB. }
unfold C_in.
exists C_nil.
exists [Some (x', A)].
simpl.
split.
{ auto. }
split.
{ intro. destruct H. exact H. }
{ auto. }
Qed.

Lemma axiom_T: type_of_term [] (t_Lam x' (t_Open x)) (T_Fun x' (T_Box A) A).
Proof.
apply pi_intro.
{ apply box_form. apply hA. }
apply box_elim.
{ apply hA. }
apply term_var.
unfold C_unlock.
unfold C_in.
simpl.
{ apply ctx_var. apply ctx_emp. apply box_form. apply hA. }
exists C_nil.
exists C_nil.
split.
{ auto. }
split.
{ intro. destruct H. exact H. }
{ auto. }
Qed.

Locate "~=".

(* Lemma ctx_form_cong_app {ctx1 ctx2 : context}
: ctx_form (ctx1 ++ ctx2) <-> ctx_form ctx1 /\ ctx_form ctx2.
Proof.
  induction ctx1.
  { unfold app.
    split.
    { intro h. split. apply ctx_emp. apply h. }
    { intros (_, h). apply h. }
  }
  { simpl.
    destruct a.
    split.
    { intro h. inversion h. rewrite IHctx1 in H1.
      destruct H1 as (Hctx1, Hctx2). split. apply ctx_var. }
  }

Admitted. *)

Theorem subst {ctx1 ctx2 : context} {t} {x} (h : type_of_term (ctx2 ++ ctx1) t B)
: type_of_term (ctx2 ++ (C_var (x, A) :: ctx1)) t B.
Proof.
remember (ctx2 ++ ctx1) as ctx.
induction h.
{ apply nat_zero.
  rewrite Heqctx in H.
  generalize dependent ctx1.
  induction ctx2.
  { intro ctx1. unfold app in H. unfold app. apply ctx_var. apply H. apply hA. }
  { simpl in H. simpl. destruct a.
    { destruct p. apply ctx_var. apply IHctx2.  }
  }
  admit. (* Too lazy to prove, its obvious *) }
{ rewrite <-x. apply nat_succ. rewrite x. apply IHh. apply JMeq_refl. apply x. }
{ admit. }
{ apply term_var. admit. admit. (* Too lazy *) }
{ rewrite <-x. apply pi_intro. admit. admit. (* ??? genuinely can't do *) }
{ admit. (* pi_elim doesn't work for some reason *) }
{ rewrite <-x. apply box_intro. admit. (* too lazy *) }
{ apply box_elim. admit. (* Too lazy*) admit. (* not sure if I can do *) }
Admitted.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import msl.base.
Local Open Scope nat_scope.

Require Import msl.ageable.
Require Import msl.functors.
Require Import msl.predicates_hered.

Import CovariantFunctor.
Import CovariantFunctorLemmas.
Import CovariantFunctorGenerator.

Module Type TY_FUNCTOR_PROP.
  Parameter F : functor.
  Parameter other : Type.
End TY_FUNCTOR_PROP.

Module Type KNOT_HERED.
  Declare Module TF:TY_FUNCTOR_PROP.
  Import TF.

  Parameter knot:Type.
  Parameter ag_knot : ageable knot.
  Existing Instance ag_knot.
  Existing Instance ag_prod.

  Definition predicate := pred (knot * other).

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Parameter approx : nat -> predicate -> predicate.

  Axiom squash_unsquash : forall k:knot, squash (unsquash k) = k.
  Axiom unsquash_squash : forall (n:nat) (f:F predicate),
    unsquash (squash (n,f)) = (n, fmap F (approx n) f).

  Axiom approx_spec : forall n p k,
    proj1_sig (approx n p) k = (level k < n /\ proj1_sig p k).

  Axiom knot_level : forall k:knot, level k = fst (unsquash k).

  Axiom knot_age1 : forall k,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

End KNOT_HERED.

Module KnotHered (TF':TY_FUNCTOR_PROP) : KNOT_HERED with Module TF:=TF'.
  Module TF:=TF'.
  Import TF.

  Definition sinv_prod X := prod X (F X * other -> Prop).

  Definition guppy_sig := (fun T:Type => T * (F T * other -> Prop) -> Prop).
  Definition guppy_ty := sigT guppy_sig.

  Definition guppy_step_ty (Z:guppy_ty) : Type :=
    (sig (fun (x:sinv_prod (projT1 Z)) => projT2 Z x)).

  Definition guppy_step_prop (Z:guppy_ty) (xf:sinv_prod (guppy_step_ty Z)) :=
    forall (k:F (guppy_step_ty Z)) (o:other),
      snd xf (k,o) -> snd (proj1_sig (fst xf)) (fmap F (@fst _ _ oo @proj1_sig _ _) k,o).

  Definition guppy_step (Z:guppy_ty) : guppy_ty :=
    existT guppy_sig (guppy_step_ty Z) (guppy_step_prop Z).

  Definition guppy_base : guppy_ty :=
    existT guppy_sig unit (fun _ => True).

  Fixpoint guppy (n:nat) : guppy_ty :=
    match n with
    | 0    => guppy_base
    | S n' => guppy_step (guppy n')
    end.

  Definition sinv (n:nat) : Type := projT1 (guppy n).
  Definition sinv_prop (n:nat) : prod (sinv n) (F (sinv n) * other -> Prop) -> Prop := projT2 (guppy n).

  Fixpoint floor (m:nat) (n:nat) (p:sinv (m+n)) : sinv n :=
    match m as m' return forall (p : sinv (m'+n)), sinv n with
    | O => fun p => p
    | S m' => fun p => floor m' n (fst (proj1_sig p))
    end p.

  Definition knot := { n:nat & F (sinv n) }.

  Definition k_age1 (k:knot) : option (knot) :=
    match k with
      | (existT _ 0 f) => None
      | (existT _ (S m) f) => Some
          (existT (F oo sinv) m (fmap F (@fst _ _ oo @proj1_sig _ _) f))
    end.

  Definition k_age (k1 k2:knot) := k_age1 k1 = Some k2.

  Definition ko_age1 (x:knot * other) :=
    match k_age1 (fst x) with
    | None => None
    | Some a' => Some (a',snd x)
    end.
  Definition ko_age x y := ko_age1 x = Some y.

  Definition predicate := { p:knot * other -> Prop | hereditary ko_age p }.

  Definition app_sinv (n:nat) (p:sinv (S n)) (x:F (sinv n) * other) :=
    snd (proj1_sig p) x.

  Lemma app_sinv_age : forall n (p:sinv (S (S n))) (f:F (sinv (S n)) * other),
    app_sinv (S n) p f ->
    app_sinv n (fst (proj1_sig p)) (fmap F (@fst _ _ oo @proj1_sig _ _) (fst f), snd f).
  Proof.
    intros.
    unfold app_sinv in *.
    destruct p; simpl in *; fold guppy in *.
    apply p; auto.
    destruct f; auto.
  Qed.

  Section stratifies.
    Variable Q:knot * other -> Prop.
    Variable HQ:hereditary ko_age Q.

    Fixpoint stratifies (n:nat) : sinv n -> Prop :=
    match n as n' return sinv n' -> Prop with
    | 0 => fun _ => True
    | S n' => fun (p:sinv (S n')) =>
          stratifies n' (fst (proj1_sig p)) /\
          forall (k:F (sinv n')) (o:other), snd (proj1_sig p) (k,o) <-> Q (existT (F oo sinv) n' k,o)
    end.

    Lemma stratifies_unique : forall n p1 p2,
      stratifies n p1 ->
      stratifies n p2 ->
      p1 = p2.
    Proof.
      induction n; simpl; intuition.
      destruct p1; destruct p2; auto.
      destruct p1; destruct p2.
      simpl in *; fold guppy in *.
      cut (x = x0).
      intros.
      revert p p0 H2 H3.
      rewrite <- H0.
      intros.
      replace p0 with p by (apply proof_irr); auto.
      destruct x; destruct x0; simpl in *.
      apply injective_projections; simpl.
      apply IHn; auto.
      extensionality; intros.
      simpl in *.
      destruct (H2 (fst x) (snd x)); destruct (H3 (fst x) (snd x)).
      apply prop_ext; destruct x; intuition.
    Qed.

    Definition stratify (n:nat) : { x:sinv n | stratifies n x }.
    Proof.
      induction n.
      exists tt; simpl; exact I.
      assert (HX:
        projT2 (guppy n)
        (proj1_sig IHn, fun v : F (sinv n) * other => Q (existT (F oo sinv) n (fst v),snd v))).
      destruct n.
      simpl; exact I.
      simpl; intros.
      destruct IHn; simpl.
      simpl in s; destruct s.
      destruct x; simpl in *; fold guppy in *.
      destruct x; simpl in *.
      hnf; simpl; intros.
      rewrite H0.
      eapply HQ.
      2: apply H1.
      simpl; reflexivity.
      exists ((exist (fun x => projT2 (guppy n) x) ( proj1_sig IHn, fun v:F (sinv n) * other => Q (existT (F oo sinv) n (fst v),snd v) ) HX)).
      simpl; split.
      destruct IHn; auto.
      unfold app_sinv; simpl; intros.
      split; trivial.
    Qed.
  End stratifies.

  Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
  Proof.
    intros x y; revert x; induction y; simpl; intros.
    right; auto with arith.
    destruct (IHy x) as [[m H]|H].
    left; exists (S m); omega.
    destruct (eq_nat_dec x y).
    left; exists O; omega.
    right; omega.
  Qed.

  Definition unstratify (n:nat) (p:sinv n) : knot * other -> Prop := fun w =>
    match w with (existT _ nw w',o) =>
      match decompose_nat nw n with
        | inleft (existT _ m Hm) => snd (proj1_sig (floor m (S nw) (eq_rect  n _ p (m + S nw) Hm))) (w',o)
        | inright H => False
      end
    end.

  Lemma floor_shuffle:
    forall (m1 n : nat)
      (p1 : sinv (m1 + S n)) (H1 : (m1 + S n) = (S m1 + n)),
      floor (S m1) n (eq_rect (m1 + S n) sinv p1 (S m1 + n) H1) = fst (proj1_sig (floor m1 (S n) p1)).
  Proof.
    intros.
    remember (fst (proj1_sig (floor m1 (S n) p1))) as p.
    fold guppy in *.
    revert n p1 H1 p Heqp.
    induction m1; simpl; intros.
    replace H1 with (refl_equal (S n)) by (apply proof_irr); simpl; auto.
    assert (m1 + S n = S m1 + n) by omega.
    destruct p1 as [[p1 f'] Hp1]; simpl in *; fold guppy in *.
    generalize (IHm1 n p1 H p Heqp).
    clear.
    revert Hp1 H1; generalize H.
    revert p1 f'.
    rewrite H.
    simpl; intros.
    replace H1 with (refl_equal (S (S (m1 + n)))) by (apply proof_irr).
    simpl.
    replace H0 with (refl_equal (S (m1+n))) in H2 by (apply proof_irr).
    simpl in H2.
    trivial.
  Qed.

  Lemma unstratify_hered : forall n p,
    hereditary ko_age (unstratify n p).
  Proof.
    intros.
    hnf; intros k k'; intros.
    simpl in H.
    destruct k.
    destruct k as [x f]. destruct x.
    discriminate.
    destruct k' as [k' o'].
    assert (o = o').
    hnf in H.
    simpl in H.
    inv H. auto.
    subst o'.
    replace k' with
      (existT (F oo sinv) x (fmap F (@fst _ _ oo @proj1_sig _ _ ) f)).
    2: inversion H; auto.
    clear H.
    case_eq (decompose_nat x n); intros.
    destruct s.
    case_eq (decompose_nat (S x) n); intros.
    destruct s.
    destruct n.
    elimtype False; omega.
    assert (S x1 = x0) by omega; subst x0.
    revert H0.
    unfold unstratify.
    rewrite H; rewrite H1.
    generalize e e0; revert p; rewrite e0; intros.
    rewrite floor_shuffle.
    replace e2 with (refl_equal (x1 + S (S x))) in H0;
      simpl eq_rect in H0.
    2: apply proof_irr.
    change f with (fst (f,o)).
    change o with (snd (f,o)).
    eapply app_sinv_age; apply H0.

    revert H0.
    unfold unstratify.
    rewrite H; rewrite H1.
    intuition.

    case_eq (decompose_nat (S x) n); intros.
    destruct s.
    elimtype False; omega.
    revert H0.
    unfold unstratify.
    rewrite H; rewrite H1; auto.
  Qed.

  Lemma unstratify_Q : forall n (p:sinv n) Q,
    stratifies Q n p ->
    forall (k:knot) o,
      projT1 k < n ->
      (unstratify n p (k,o) <-> Q (k,o)).
  Proof.
    intros.
    unfold unstratify.
    destruct k.
    destruct (decompose_nat x n).
    destruct s.
    simpl in H0.
    2: simpl in *; elimtype False; omega.
    clear H0.
    revert p H.
    generalize e.
    rewrite e.
    intros.
    replace e0 with (refl_equal (x0 + S x)) by apply proof_irr.
    simpl.
    clear e e0.
    revert p H.
    induction x0; simpl; intros.
    destruct H.
    auto.
    destruct H.
    apply IHx0.
    auto.
  Qed.

  Lemma stratifies_unstratify_more :
    forall (n m1 m2:nat) (p1:sinv (m1+n)) (p2:sinv (m2+n)),
      floor m1 n p1 = floor m2 n p2 ->
      (stratifies (unstratify (m1+n) p1) n (floor m1 n p1) ->
       stratifies (unstratify (m2+n) p2) n (floor m2 n p2)).
  Proof.
    induction n; intuition.
    split.
    assert (m2 + S n = S m2 + n) by omega.
    erewrite <- floor_shuffle.
    instantiate (1:=H1).
    replace (unstratify (m2 + S n) p2)
      with (unstratify (S m2 + n) (eq_rect (m2 + S n) sinv p2 (S m2 + n) H1)).
    assert (m1 + S n = S m1 + n) by omega.
    eapply (IHn (S m1) (S m2)
      (eq_rect (m1 + S n) sinv p1 (S m1 + n) H2)).
    rewrite floor_shuffle.
    rewrite floor_shuffle.
    rewrite H; auto.
    clear - H0.
    rewrite floor_shuffle.
    simpl in H0.
    destruct H0.
    clear H0.
    revert p1 H.
    generalize H2.
    rewrite <- H2.
    intros.
    replace H0 with (refl_equal (m1 + S n)) by apply proof_irr; auto.
    clear.
    revert p2.
    generalize H1.
    rewrite H1.
    intros.
    replace H0 with (refl_equal (S m2 + n)) by apply proof_irr; auto.

    intros.
    simpl.
    destruct (decompose_nat n (m2 + S n)).
    destruct s.
    assert (m2 = x).
    omega.
    subst x.
    replace e with (refl_equal (m2 + S n)).
    simpl; tauto.
    apply proof_irr.
    elimtype False; omega.
  Qed.

  Lemma stratify_unstratify : forall n p H,
    proj1_sig (stratify (unstratify n p) H n) = p.
  Proof.
    intros.
    apply stratifies_unique with (unstratify n p).
    destruct (stratify _ H n).
    simpl; auto.
    clear H.
    revert p; induction n.
    simpl; intros; auto.
    intros.
    simpl; split.

    assert (stratifies (unstratify n (fst (proj1_sig p))) n (fst (proj1_sig p))).
    apply IHn.
    apply (stratifies_unstratify_more n 0 1 (fst (proj1_sig p)) p).
    simpl; auto.
    auto.

    intros.
    destruct (decompose_nat n (S n)).
    destruct s.
    assert (x = 0) by omega.
    subst x.
    simpl.
    simpl in e.
    replace e with (refl_equal (S n)) by apply proof_irr.
    simpl.
    split; auto.
    elimtype False; omega.
  Qed.

  Definition strat (n:nat) (p:predicate) : sinv n :=
    proj1_sig (stratify (proj1_sig p) (proj2_sig p) n).

  Definition unstrat (n:nat) (p:sinv n) : predicate :=
    exist (hereditary ko_age) (unstratify n p) (unstratify_hered n p).

  Definition squash (x:nat * F predicate) : knot :=
    match x with (n,f) => existT (F oo sinv) n (fmap F (strat n) f) end.

  Definition unsquash (k:knot) : nat * F predicate :=
    match k with existT _ n f => (n, fmap F (unstrat n) f) end.

  Definition level (x:knot) : nat := fst (unsquash x).
  Program Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => level (fst w) < n /\ p w.
  Next Obligation.
    hnf; simpl; intros.
    intuition.
    unfold level in *.
    unfold unsquash in *.
    destruct a0; simpl in H.
    destruct x; try discriminate.
    inv H.
    simpl in *; omega.
    destruct p; simpl in *.
    eapply h; eauto.
  Qed.

  Lemma strat_unstrat : forall n,
    strat n oo unstrat n = id (sinv n).
  Proof.
    intros; extensionality p.
    unfold compose, id.
    unfold strat, unstrat.
    simpl.
    rewrite stratify_unstratify.
    auto.
  Qed.

  Lemma predicate_eq : forall (p1 p2:predicate),
    proj1_sig p1 = proj1_sig p2 ->
    p1 = p2.
  Proof.
    intros; destruct p1; destruct p2; simpl in H.
    subst x0.
    replace h0 with h by apply proof_irr.
    auto.
  Qed.

  Lemma unstrat_strat : forall n,
    unstrat n oo strat n = approx n.
  Proof.
    intros.
    extensionality.
    unfold compose.
    unfold unstrat, strat.
    unfold approx.
    apply predicate_eq.
    simpl.
    extensionality k.
    apply prop_ext; intuition.
    unfold unstratify in H.
    destruct a.
    destruct (decompose_nat x0 n).
    unfold level.
    simpl.
    destruct s.
    omega.
    elim H.
    rewrite <- unstratify_Q.
    apply H.
    destruct (stratify (proj1_sig x) (proj2_sig x) n); auto.
    unfold unstratify in H.
    destruct a; simpl.
    destruct (decompose_nat x0 n).
    destruct s; omega.
    elim H.
    rewrite unstratify_Q.
    apply H1.
    destruct (stratify (proj1_sig x) (proj2_sig x) n); auto.
    unfold level in H0.
    destruct a; simpl in *.
    auto.
  Qed.

  Lemma squash_unsquash : forall k, squash (unsquash k) = k.
  Proof.
    intros.
    destruct k as [x f]; simpl.
    f_equal.
    change ((fmap F (strat x) oo fmap F (unstrat x)) f = f).
    rewrite fmap_comp.
    rewrite strat_unstrat.
    rewrite fmap_id.
    auto.
  Qed.

  Lemma unsquash_squash : forall n f,
    unsquash (squash (n,f)) = (n, fmap F (approx n) f).
  Proof.
    intros.
    unfold unsquash, squash.
    f_equal.
    change ((fmap F (unstrat n) oo fmap F (strat n)) f = fmap F (approx n) f).
    rewrite fmap_comp.
    rewrite unstrat_strat.
    auto.
  Qed.

  Lemma strat_unstrat_Sx : forall x,
    @fst _ _ oo @proj1_sig _ _ = strat x oo unstrat (S x).
  Proof.
    intros.
    extensionality k.
    change (sinv (S x)) in k.
    unfold compose.
    unfold strat, unstrat.
    simpl.
    apply stratifies_unique with (unstratify x (fst (proj1_sig k))).
    revert k; induction x; simpl; auto.
    intros.
    split.
    eapply (stratifies_unstratify_more x 0 1 ).
    simpl; reflexivity.
    simpl.
    apply IHx.
    intros.
    destruct (decompose_nat x (S x)).
    destruct s.
    assert (x0 = 0) by omega; subst x0.
    simpl in *.
    replace e with (refl_equal (S x)) by apply proof_irr; simpl.
    tauto.
    elimtype False; omega.
    destruct (stratify (unstratify (S x) k)
      (unstratify_hered (S x) k) x).
    simpl; auto.
    cut (x0 = (fst (proj1_sig k))); intros.
    subst x0.
    eapply (stratifies_unstratify_more x 1 0).
    simpl; reflexivity.
    simpl; auto.
    eapply stratifies_unique.
    apply s.
    eapply (stratifies_unstratify_more x 0 1).
    simpl; reflexivity.
    simpl.
    generalize (fst (proj1_sig k) : sinv x).
    clear.
    induction x; simpl; intuition.
    eapply (stratifies_unstratify_more x 0 1).
    simpl; reflexivity.
    simpl.
    apply IHx.
    destruct (decompose_nat x (S x)).
    destruct s0.
    assert (x0 = 0) by omega; subst.
    simpl in *.
    replace e with (refl_equal (S x)); simpl; auto.
    apply proof_irr.
    omega.
    destruct (decompose_nat x (S x)).
    destruct s0.
    assert (x0 = 0) by omega; subst.
    simpl in *.
    replace e with (refl_equal (S x)) in H; simpl; auto.
    apply proof_irr.
    elim H.
  Qed.

  Lemma unsquash_inj : forall k k',
    unsquash k = unsquash k' -> k = k'.
  Proof.
    intros.
    rewrite <- (squash_unsquash k).
    rewrite <- (squash_unsquash k').
    congruence.
  Qed.

  Lemma knot_age_age1 : forall k k',
    k_age1 k = Some k' <->
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end = Some k'.
  Proof.
    split; intros.
    unfold k_age1 in H.
    unfold unsquash in H.
    destruct k as [x f].
    destruct x; auto.
    inv H.
    simpl.
    f_equal.
    f_equal.
    change (fmap F (strat x) (fmap F (unstrat (S x)) f))
      with ((fmap F (strat x) oo fmap F (unstrat (S x))) f).
    rewrite fmap_comp.
    simpl.
    f_equal.
    symmetry.
    apply (strat_unstrat_Sx x).

    simpl in H.
    destruct k.
    destruct x.
    discriminate.
    inv H.
    hnf; simpl.
    unfold k_age1.
    f_equal.
    f_equal.
    rewrite strat_unstrat_Sx.
    rewrite <- fmap_comp.
    auto.
  Qed.

  Program Instance ag_knot : ageable knot :=
  { age1 := k_age1
  ; level := level
  }.
  Next Obligation.
    econstructor.
    (* unage *)
    intros.
    destruct (unsquash x') as [n f] eqn:?H; intros.
    exists (squash (S n, f)).
    rewrite knot_age_age1.
    rewrite unsquash_squash.
    f_equal.
    apply unsquash_inj.
    rewrite unsquash_squash.
    rewrite H.
    f_equal.
    cut (f = fmap F (approx n) f).
    intros.
    rewrite fmap_app.
    pattern f at 2. rewrite H0.
    f_equal.
    extensionality p.
    apply predicate_eq.
    extensionality w.
    simpl. apply prop_ext.
    intuition.
    generalize H; intro.
    rewrite <- (squash_unsquash x') in H.
    rewrite H0 in H.
    rewrite unsquash_squash in H.
    congruence.

    (* level 0 *)
    intro x. destruct x; simpl.
    destruct x; intuition; discriminate.

    (* level S *)
    intros. destruct x; simpl in *.
    destruct x. discriminate.
    inv H. simpl. auto.
  Qed.

  Existing Instance ag_prod.

  Lemma approx_spec : forall n p (k:knot * other),
    proj1_sig (approx n p) k = (ageable.level k < n /\ proj1_sig p k).
  Proof.
    intros.
    apply prop_ext.
    unfold approx; simpl.
    intuition; simpl in *; auto.
  Qed.

  Lemma knot_level : forall k:knot, level k = fst (unsquash k).
  Proof. reflexivity. Qed.

  Lemma knot_age1 : forall k,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.
  Proof.
    intros. simpl.
    case_eq (k_age1 k). intros.
    rewrite knot_age_age1 in H.
    auto.
    destruct k; simpl. destruct x. auto.
    intros. discriminate.
  Qed.

End KnotHered.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.
Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Import ListNotations. (* from List *)

Require Import Coq.Bool.Bool.
Require Import Coq.Classes.SetoidClass.
Open Scope equiv_scope.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Logic.Decidable.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Set Implicit Arguments.
Set Strict Implicit.

Require Import Oqarina.CoqExt.all.
Require Import Oqarina.formalisms.Contracts.Specification.
Require Import Oqarina.formalisms.Contracts.MetaTheory.

Section Assume_Guarantee_Contracts.
(*| .. coq:: |*)

(*|

A/G Contracts
=============

In this section, we define the notion of Assume/Guarantee contracts (or A/G contract). A :coq:`AG_Contract` refines the notion of contract from the meta-theory to components.

Without loss of generality, we define a component as a set of variables (:coq:`V`) that validates a specific assertion, i.e. a function whose signature is :coq:`list V -> Prop`. For instance, the set of static configuration parameters of a component, or a trace generated by some behavioral description.

For an A/G contract, an assumption (A) states assumptions made on the environment by a model and a guarantee (G) states guarantees offered by a model. They are both assertions on the same set of variables.

A/G contracts trivially meet all the meta-theory lemmas proved above.
We only prove a subset of them. Proofs follow the same schema: we map
an A/G contract to a general contract and conclude.

|*)

Import Contract_Notations.

Variable V : Type.
Context `{spec : Specification V}.

Definition Assertion: Type := V -> Prop.
Definition Component := Assertion.
Definition Environment := Assertion.

Record AG_Contract := {
    A: Assertion ;
    G: Assertion ;
}.

Definition AG_Contract_to_Contract (AG : AG_Contract) := {|
    Ec := AG.(A) ;
    Mc := AG.(G) ;
|}.

Notation "@ c" := (AG_Contract_to_Contract c)
    (at level 70 , no associativity).

(*| A saturated contract is an A/G contract defines by the following rule predicate. It is an idemptotent function. |*)

Definition Saturate (AG : AG_Contract) := {|
    A := AG.(A);
    G := fun x => (AG.(A) x -> AG.(G) x);
|}.

Lemma Saturate_idempotent: forall ag,
    (@Saturate ag) == (@ Saturate (Saturate ag)).
Proof.
    intros.
    unfold AG_Contract_to_Contract.
    simpl.

    assert (
        (fun x => A ag x -> G ag x) =
        (fun x => A ag x -> A ag x -> G ag x)
    ).
    apply functional_extensionality. intros.
    apply propositional_extensionality.
    firstorder.

    rewrite H. reflexivity.
Qed.

(*| A saturated contract is equivalent to the original contract if
the environment is compatible with the contract.

Note: :cite:`benvenisteContractsSystemsDesign`, p36 introduces this lemma without proof. It misses the hypothesis on the environment. |*)

Lemma Saturate_equiv: forall ag,
    (forall v, v ⊢e (@ ag)) ->
        (@ Saturate ag) == (@ ag).
Proof.
    intros. unfold Saturate.
    unfold AG_Contract_to_Contract.
    simpl. firstorder.
Qed.

(*| The notion of contract refinement and composition is directly inherited from the meta-theory.

We demonstrate that a saturated contract preserves some initial properties, e.g. equivalence, compatibility, etc. |*)

Theorem contract_extensionality : forall (c1 c2 : AG_Contract),
    (@c1) == (@c2) -> Saturate c1 = Saturate c2.
Proof.
    simpl.
    intros. firstorder.
    unfold refines in *.
    simpl in *.
    unfold Saturate.

    assert (
        (fun x : V => A c1 x -> G c1 x) =
        (fun x : V => A c2 x -> G c2 x)
    ).
    apply functional_extensionality. intros.
    specialize (H x).
    specialize (H0 x).
    apply propositional_extensionality. firstorder.

    assert (forall m, A c1 m = A c2 m).
    intros.
    specialize (H m).
    specialize (H0 m).
    apply propositional_extensionality. firstorder.

    assert (A c1 = A c2).
    apply functional_extensionality. apply H2.

    rewrite H1. rewrite H3. reflexivity.
Qed.

Lemma implements_implements_saturate: forall c v,
    v ⊢m (@c) -> v ⊢m (@(Saturate c)).
Proof.
    simpl. firstorder.
Qed.

Lemma implements_saturate_implements: forall c v,
    (forall v, v ⊢e (@ c)) ->
        v ⊢m (@(Saturate c)) -> v ⊢m (@c).
Proof.
    simpl. firstorder.
Qed.

(*| .. coq:: none |*)
End Assume_Guarantee_Contracts.
(*| .. coq:: |*)

Module AG_Contract_Notations.

Export Contract_Notations.

Notation "@ c" := (AG_Contract_to_Contract c)
    (at level 70 , no associativity).

End AG_Contract_Notations.


(*
 * © 2019 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     String
     Sumbool
     Morphisms.

From SPICY Require Import
     MyPrelude
     Maps
     Keys
     Messages.

Set Implicit Arguments.

Module RW_message <: GRANT_ACCESS.
  Definition access := key_permission.
End RW_message.

Module message := Messages(RW_message).
Import message.
Export message.

Definition cipher_id := nat.

Inductive crypto : type -> Type :=
| Content {t} (c : message t) : crypto t
| SignedCiphertext {t} (c_id : cipher_id) : crypto t
.

(* We need to handle non-deterministic message  -- external choice on ordering *)
Inductive msg_pat :=
| Accept
| Signed (k : key_identifier) (chk_replay : bool)
| SignedEncrypted (k__sign k__enc : key_identifier) (chk_replay : bool)
.

Definition msg_seq : Set := (option user_id) * nat.

Definition msg_seq_eq (s1 s2 : msg_seq) : {s1 = s2} + {s1 <> s2}.
  repeat (decide equality).
Defined.

Inductive cipher : Type :=
| SigCipher {t} (k__sign : key_identifier) (msg_to : user_id) (c_nonce : msg_seq) (msg : message t) : cipher
| SigEncCipher {t} (k__sign k__enc : key_identifier) (msg_to : user_id) (c_nonce : msg_seq) (msg : message t) : cipher
.

Definition cipher_signing_key (c : cipher) :=
  match c with
  | SigCipher k _ _ _      => k
  | SigEncCipher k _ _ _ _ => k
  end.

Definition cipher_to_user (c : cipher) :=
  match c with
  | SigCipher _ to _ _      => to
  | SigEncCipher _ _ to _ _ => to
  end.

Definition cipher_nonce (c : cipher) :=
  match c with
  | SigCipher _ _ n _      => n
  | SigEncCipher _ _ _ n _ => n
  end.

Definition queued_messages := list (sigT crypto).
Definition ciphers         := NatMap.t cipher.
Definition my_ciphers      := list cipher_id.
Definition recv_nonces     := list msg_seq.
Definition sent_nonces     := list msg_seq.

Inductive msg_accepted_by_pattern (cs : ciphers) (opt_uid_to : option user_id) (froms : recv_nonces)
  : forall {t : type}, msg_pat -> crypto t -> Prop :=
| MsgAccept : forall {t} (m : crypto t),
    msg_accepted_by_pattern cs opt_uid_to froms Accept m
| ProperlySigned : forall {t t'} c_id k (m : message t) msg_to nonce (chk : bool),
    cs $? c_id = Some (SigCipher k msg_to nonce m)
    -> (if chk then (count_occ msg_seq_eq froms nonce = 0) else True)
    -> opt_uid_to = Some msg_to
    -> msg_accepted_by_pattern cs opt_uid_to froms (Signed k chk) (@SignedCiphertext t' c_id)
| ProperlyEncrypted : forall {t t'} c_id k__sign k__enc (m : message t) msg_to nonce (chk : bool),
    cs $? c_id = Some (SigEncCipher k__sign k__enc msg_to nonce m)
    -> (if chk then (count_occ msg_seq_eq froms nonce = 0) else True)
    -> opt_uid_to = Some msg_to
    -> msg_accepted_by_pattern cs opt_uid_to froms (SignedEncrypted k__sign k__enc chk) (@SignedCiphertext t' c_id).

#[export] Hint Extern 1 (~ In _ _) => rewrite not_find_in_iff : core.

Notation honest_key honk kid := (honk $? kid = Some true).

Section SafeMessages.
  Variable all_keys : keys.
  Variable honestk advk : key_perms.

  Definition honest_keyb (k_id : key_identifier) : bool :=
    match honestk $? k_id with
    | Some true => true
    | _ => false
    end.

  Definition msg_cipher_id {t} (msg : crypto t) : option cipher_id :=
    match msg with
    | SignedCiphertext c_id => Some c_id
    | _ => None
    end.

  Definition msg_signing_key {t} (cs : ciphers) (msg : crypto t) : option key_identifier :=
    match msg with
    | Content _ => None
    | SignedCiphertext c_id =>
      match cs $? c_id with
      | Some c => Some (cipher_signing_key c)
      | None   => None
      end
    end.

  Definition msg_destination_user {t} (cs : ciphers) (msg : crypto t) : option user_id :=
    match msg with
    | Content _ => None
    | SignedCiphertext c_id =>
      match cs $? c_id with
      | Some c => Some (cipher_to_user c)
      | None   => None
      end
    end.

  Definition msg_honestly_signed {t} (cs : ciphers) (msg : crypto t) : bool :=
    match msg_signing_key cs msg with
    | Some k => honest_keyb k
    | _ => false
    end.

  Definition msg_to_this_user {t} (cs : ciphers) (to_usr : option user_id) (msg : crypto t) : bool :=
    match msg_destination_user cs msg with
    | Some to_usr' => match to_usr with
                     | None => true
                     | Some to_hon_user => if to_usr' ==n to_hon_user then true else false
                     end
    | _ => false
    end.

  Definition msg_signed_addressed (cs : ciphers) (to_user_id : option user_id) {t} (msg : crypto t) :=
    msg_honestly_signed cs msg && msg_to_this_user cs to_user_id msg.

  Definition keys_mine (my_perms key_perms: key_perms) : Prop :=
    forall k_id kp,
      key_perms $? k_id = Some kp
    ->  my_perms $? k_id = Some kp
    \/ (my_perms $? k_id = Some true /\ kp = false).

  Definition cipher_honestly_signed (c : cipher) : bool :=
    match c with
    | SigCipher k_id _ _ _              => honest_keyb k_id
    | SigEncCipher k__signid k__encid _ _ _ => honest_keyb k__signid
    end.

  Definition ciphers_honestly_signed :=
    Forall_natmap (fun c => cipher_honestly_signed c = true).

  Inductive msg_pattern_safe : msg_pat -> Prop :=
  | HonestlySignedSafe : forall k,
        honest_key honestk k
      -> msg_pattern_safe (Signed k true)
  | HonestlySignedEncryptedSafe : forall k__sign k__enc,
        honest_key honestk k__sign
      -> msg_pattern_safe (SignedEncrypted k__sign k__enc true)
  .

End SafeMessages.

Inductive user_cmd_type :=
| Base (t : type)
| Message (t : type)
| Crypto (t : type)
| UPair (t1 t2 : user_cmd_type)
.

Fixpoint denote (t : user_cmd_type) :=
  match t with
  | Base t' => message.typeDenote t'
  | Message t' => message t'
  | Crypto t' => crypto t'
  | UPair t1 t2 => (denote t1 * denote t2)%type
  end
.

Declare Scope realworld_scope.
Notation "<< t >>" := (denote t) (at level 75) : realworld_scope.
Delimit Scope realworld_scope with realworld.
Open Scope realworld_scope.

Inductive user_cmd : user_cmd_type -> Type :=
(* Plumbing *)
| Return {A} (res : <<A>>%realworld) : user_cmd A
| Bind {A A'} (cmd1 : user_cmd A') (cmd2 : <<A'>>%realworld -> user_cmd A) : user_cmd A

| Gen : user_cmd (Base Nat)

(* Messaging *)
| Send {t} (uid : user_id) (msg : crypto t) : user_cmd (Base Unit)
| Recv {t} (pat : msg_pat) : user_cmd (Crypto t)

(* Crypto!! *)
| SignEncrypt {t} (k__sign k__enc : key_identifier) (msg_to : user_id) (msg : message t) : user_cmd (Crypto t)
| Decrypt {t} (c : crypto t) : user_cmd (Message t)

| Sign    {t} (k : key_identifier) (msg_to : user_id) (msg : message t) : user_cmd (Crypto t)
| Verify  {t} (k : key_identifier) (c : crypto t) : user_cmd (UPair (Base Bool) (Message t))

| GenerateKey (kt : key_type) (usage : key_usage) : user_cmd (Base Access)
.

Module RealWorldNotations.
  Ltac denoteInvert T :=
    match T with
      | key_permission => exact (Base Access)
      | bool => exact (Base Bool)
      | nat => exact (Base Nat)
      | unit => exact (Base Unit)
      | (?T1 * ?T2)%type =>
        exact (UPair ltac:(denoteInvert T1) ltac:(denoteInvert T2))
      end
  .
  Ltac typeOf x :=
    match type of x with
    | ?T => denoteInvert T
    end
  .
  Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 75) : realworld_scope.
  Notation "'ret' x" := (@Return ltac:(typeOf x) x) (at level 75, only parsing) : realworld_scope.
End RealWorldNotations.
Import  RealWorldNotations.

Record user_data (A : type) :=
  mkUserData {
      key_heap  : key_perms
    ; protocol  : user_cmd (Base A)
    ; msg_heap  : queued_messages
    ; c_heap    : my_ciphers
    ; from_nons : recv_nonces
    ; sent_nons : sent_nonces
    ; cur_nonce : nat
    }.

Definition honest_users A := NatMap.t (user_data A).

Record simpl_universe A :=
  mkSimplUniverse {
      s_users       : honest_users A
    ; s_all_ciphers : ciphers
    ; s_all_keys    : keys
    }.

Record universe A B :=
  mkUniverse {
      users       : honest_users A
    ; adversary   : user_data B
    ; all_ciphers : ciphers
    ; all_keys    : keys
    }.

Definition peel_adv {A B} (U : universe A B) : simpl_universe A :=
   {| s_users       := U.(users)
    ; s_all_ciphers := U.(all_ciphers)
    ; s_all_keys    := U.(all_keys) |}.

Definition findUserKeys {A} (us : NatMap.t (user_data A)) : key_perms :=
  fold (fun u_id u ks => ks $k++ u.(key_heap)) us $0.

Definition addUserKeys {A} (ks : key_perms) (u : user_data A) : user_data A :=
  {| key_heap  := u.(key_heap) $k++ ks
   ; protocol  := u.(protocol)
   ; msg_heap  := u.(msg_heap)
   ; c_heap    := u.(c_heap)
   ; from_nons := u.(from_nons)
   ; sent_nons := u.(sent_nons)
   ; cur_nonce := u.(cur_nonce)
  |}.

Definition addUsersKeys {A} (us : NatMap.t (user_data A)) (ks : key_perms) :=
  map (addUserKeys ks) us.

Fixpoint findKeysMessage {t} (msg : message t) : key_perms :=
  match msg with
  | message.Permission k => $0 $+ (fst k, snd k)
  | message.Content _ => $0
  | message.MsgPair m1 m2 => findKeysMessage m1 $k++ findKeysMessage m2
  end.

Definition findKeysCrypto {t} (cs : ciphers) (msg : crypto t) : key_perms :=
  match msg with
  | Content  m          => findKeysMessage m
  | SignedCiphertext c_id  =>
    match cs $? c_id with
    | Some (SigCipher _ _ _ m) => findKeysMessage m
    | _ => $0
    end
  end.

Definition findCiphers {t} (msg : crypto t) : my_ciphers :=
  match msg with
  | Content _          => []
  | SignedCiphertext c => [c]
  end.

Definition findMsgCiphers {t} (msg : crypto t) : queued_messages :=
  match msg with
  | Content _          => []
  | SignedCiphertext _ => [existT _ _ msg]
  end.

Definition user_keys {A} (usrs : honest_users A) (u_id : user_id) : option key_perms :=
  match usrs $? u_id with
  | Some u_d => Some u_d.(key_heap)
  | None     => None
  end.

Definition user_queue {A} (usrs : honest_users A) (u_id : user_id) : option queued_messages :=
  match usrs $? u_id with
  | Some u_d => Some u_d.(msg_heap)
  | None     => None
  end.

Definition user_cipher_queue {A} (usrs : honest_users A) (u_id : user_id) : option my_ciphers :=
  match usrs $? u_id with
  | Some u_d => Some u_d.(c_heap)
  | None     => None
  end.

Definition buildUniverse {A B}
           (usrs : honest_users A) (adv : user_data B) (cs : ciphers) (ks : keys)
           (u_id : user_id) (userData : user_data A) : universe A B :=
  {| users        := usrs $+ (u_id, userData)
   ; adversary    := adv
   ; all_ciphers  := cs
   ; all_keys     := ks
   |}.

Definition buildUniverseAdv {A B}
           (usrs : honest_users A) (cs : ciphers) (ks : keys)
           (userData : user_data B) : universe A B :=
  {| users        := usrs
   ; adversary    := userData
   ; all_ciphers  := cs
   ; all_keys     := ks
   |}.

Definition updateTrackedNonce {t} (to_usr : option user_id) (froms : recv_nonces) (cs : ciphers) (msg : crypto t) :=
  match msg with
  | Content _ => froms
  | SignedCiphertext c_id =>
    match cs $? c_id with
    | None => froms
    | Some c =>
      match to_usr with
      | None => froms
      | Some to_uid =>
        if to_uid ==n cipher_to_user c
        then match count_occ msg_seq_eq froms (cipher_nonce c) with
             | 0 => cipher_nonce c :: froms
             | _ => froms
             end
        else froms
      end
    end
  end.

Definition updateSentNonce {t} (to_usr : option user_id) (sents : sent_nonces) (cs : ciphers) (msg : crypto t) :=
  match msg with
  | Content _ => sents
  | SignedCiphertext c_id =>
    match cs $? c_id with
    | None => sents
    | Some c =>
      match to_usr with
      | None => sents
      | Some to_uid =>
        if to_uid ==n cipher_to_user c
        then cipher_nonce c :: sents
        else sents
      end
    end
  end.

Definition msg_nonce_not_same (new_cipher : cipher) (cs : ciphers) {t} (msg : crypto t) : Prop :=
  forall c_id c,
    msg = SignedCiphertext c_id
    -> cs $? c_id = Some c
    -> cipher_nonce new_cipher <> cipher_nonce c.

Definition msg_nonce_same (new_cipher : cipher) (cs : ciphers) {t} (msg : crypto t) : Prop :=
  forall c_id c,
      msg = SignedCiphertext c_id
    -> cs $? c_id = Some c
    -> cipher_nonce new_cipher = cipher_nonce c.

Definition msg_not_replayed {t} (to_usr : option user_id) (cs : ciphers) (froms : recv_nonces) (msg : crypto t) (msgs : queued_messages) : Prop :=
  exists c_id c,
      msg = SignedCiphertext c_id
    /\ cs $? c_id = Some c
    /\ ~ List.In (cipher_nonce c) froms
    /\ Forall (fun sigM => match sigM with
                       | (existT _ _ m) => msg_to_this_user cs to_usr m = true
                                        -> msg_nonce_not_same c cs m
                       end) msgs.

Inductive action : Type :=
| Input  t (msg : crypto t) (pat : msg_pat) (froms : recv_nonces)
| Output t (msg : crypto t) (from_user : option user_id) (to_user : option user_id) (sents : sent_nonces)
.

Definition rlabel := @label action.
Definition uaction := (user_id * action)%type.
Definition ulabel := @label uaction.
Definition mkULbl (lbl : rlabel) (uid : user_id) : ulabel :=
  match lbl with
  | Silent => Silent
  | Action a => Action (uid, a)
  end.

Definition data_step0 A B C : Type :=
  honest_users A * user_data B * ciphers * keys * key_perms * queued_messages * my_ciphers * recv_nonces * sent_nonces * nat * user_cmd C.

Definition build_data_step {A B C} (U : universe A B) (u_data : user_data C) : data_step0 A B (Base C) :=
  (U.(users), U.(adversary), U.(all_ciphers), U.(all_keys),
   u_data.(key_heap), u_data.(msg_heap), u_data.(c_heap), u_data.(from_nons), u_data.(sent_nons), u_data.(cur_nonce), u_data.(protocol)).

Inductive step_user : forall A B C, rlabel -> option user_id -> data_step0 A B C -> data_step0 A B C -> Prop :=

(* Plumbing *)
| StepBindRecur : forall {A B r r'} (usrs usrs' : honest_users A) (adv adv' : user_data B)
                    lbl u_id cs cs' qmsgs qmsgs' gks gks' ks ks' mycs mycs' froms froms' sents sents' cur_n cur_n'
                    (cmd1 cmd1' : user_cmd r) (cmd2 : <<r>> -> user_cmd r'),
    step_user lbl u_id (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd1)
                       (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', cmd1')
    -> step_user lbl u_id (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Bind cmd1 cmd2)
                         (usrs', adv', cs', gks', ks', qmsgs', mycs', froms', sents', cur_n', Bind cmd1' cmd2)
| StepBindProceed : forall {A B r r'} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks qmsgs mycs froms sents cur_n
                      (v : <<r'>>) (cmd : <<r'>> -> user_cmd r),
    step_user Silent u_id
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Bind (@Return r' v) cmd)
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd v)

| StepGen : forall {A B} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks qmsgs mycs froms sents cur_n n,
    step_user Silent u_id (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Gen)
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Return n)

(* Comms  *)
| StepRecv : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks ks' qmsgs qmsgs' mycs mycs' froms froms'
               sents cur_n (msg : crypto t) msgs__front msgs__back pat newkeys newcs,
      qmsgs = msgs__front ++ (existT _ _ msg) :: msgs__back (* we have a message waiting for us! *)
    -> qmsgs' = msgs__front ++ msgs__back
    -> findKeysCrypto cs msg = newkeys
    -> newcs = findCiphers msg
    -> ks' = ks $k++ newkeys
    -> mycs' = newcs ++ mycs
    -> froms' = updateTrackedNonce u_id froms cs msg
    -> msg_accepted_by_pattern cs u_id froms pat msg
    -> Forall (fun '(existT _ _ msg')  => ~ msg_accepted_by_pattern cs u_id froms pat msg') msgs__front
    -> step_user (Action (Input msg pat froms)) u_id
                (usrs, adv, cs, gks, ks , qmsgs , mycs, froms, sents, cur_n,  Recv pat)
                (usrs, adv, cs, gks, ks', qmsgs', mycs', froms', sents, cur_n, @Return (Crypto t) msg)

(* Augment attacker's keys with those available through messages sent, *)
(*  * including traversing through ciphers already known by attacker, etc. *)
(*  *)
| StepSend : forall {A B} {t} (usrs usrs' : honest_users A) (adv adv' : user_data B)
               cs suid gks ks qmsgs mycs froms sents sents' cur_n rec_u_id rec_u newkeys (msg : crypto t),
    findKeysCrypto cs msg = newkeys
    -> keys_mine ks newkeys
    -> incl (findCiphers msg) mycs
    -> usrs $? rec_u_id = Some rec_u
    -> Some rec_u_id <> suid
    -> sents' = updateSentNonce (Some rec_u_id) sents cs msg
    -> usrs' = usrs $+ (rec_u_id, {| key_heap  := rec_u.(key_heap)
                                  ; protocol  := rec_u.(protocol)
                                  ; msg_heap  := rec_u.(msg_heap) ++ [existT _ _ msg]
                                  ; c_heap    := rec_u.(c_heap)
                                  ; from_nons := rec_u.(from_nons)
                                  ; sent_nons := rec_u.(sent_nons)
                                  ; cur_nonce := rec_u.(cur_nonce) |})
    -> adv' =
      {| key_heap  := adv.(key_heap) $k++ newkeys
       ; protocol  := adv.(protocol)
       ; msg_heap  := adv.(msg_heap) ++ [existT _ _ msg]
       ; c_heap    := adv.(c_heap)
       ; from_nons := adv.(from_nons)
       ; sent_nons := adv.(sent_nons)
       ; cur_nonce := adv.(cur_nonce) |}
    -> step_user (Action (Output msg suid (Some rec_u_id) sents)) suid
                (usrs , adv , cs, gks, ks, qmsgs, mycs, froms, sents,  cur_n, Send rec_u_id msg)
                (usrs', adv', cs, gks, ks, qmsgs, mycs, froms, sents', cur_n, @Return (Base Unit) tt)

(* Encryption / Decryption *)
| StepEncrypt : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs cs' u_id gks ks qmsgs mycs mycs' froms sents
                  cur_n cur_n' (msg : message t) k__signid k__encid kp__enc kt__enc kt__sign c_id cipherMsg msg_to msg_nonce,
      gks $? k__encid  = Some (MkCryptoKey k__encid Encryption kt__enc)
    -> gks $? k__signid = Some (MkCryptoKey k__signid Signing kt__sign)
    -> ks $? k__encid   = Some kp__enc
    -> ks $? k__signid  = Some true
    -> ~ In c_id cs
    -> keys_mine ks (findKeysMessage msg)
    -> cur_n' = 1 + cur_n
    -> (u_id <> None -> msg_nonce = (u_id, cur_n))
    -> cipherMsg = SigEncCipher k__signid k__encid msg_to msg_nonce msg
    -> cs' = cs $+ (c_id, cipherMsg)
    -> mycs' = c_id :: mycs
    -> step_user Silent u_id
                (usrs, adv, cs , gks, ks, qmsgs, mycs,  froms, sents, cur_n,  SignEncrypt k__signid k__encid msg_to msg)
                (usrs, adv, cs', gks, ks, qmsgs, mycs', froms, sents, cur_n', @Return (Crypto t) (SignedCiphertext c_id))

| StepDecrypt : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks ks' qmsgs mycs mycs'
                  (msg : message t) k__signid kp__sign k__encid c_id nonce newkeys kt__sign kt__enc msg_to froms sents cur_n,
      cs $? c_id     = Some (SigEncCipher k__signid k__encid msg_to nonce msg)
    -> gks $? k__encid  = Some (MkCryptoKey k__encid Encryption kt__enc)
    -> gks $? k__signid = Some (MkCryptoKey k__signid Signing kt__sign)
    -> ks  $? k__encid  = Some true
    -> ks  $? k__signid = Some kp__sign
    -> findKeysMessage msg = newkeys
    -> ks' = ks $k++ newkeys
    -> mycs' = (* newcs ++  *)mycs
    -> List.In c_id mycs
    -> step_user Silent u_id
                (usrs, adv, cs, gks, ks , qmsgs, mycs,  froms, sents, cur_n, Decrypt (SignedCiphertext c_id))
                (usrs, adv, cs, gks, ks', qmsgs, mycs', froms, sents, cur_n, @Return (Message t) msg)

(* Signing / Verification *)
| StepSign : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs cs' u_id gks ks qmsgs mycs mycs'
               froms sents cur_n cur_n' msg_nonce (msg : message t) k_id kt c_id cipherMsg msg_to,
      gks $? k_id = Some (MkCryptoKey k_id Signing kt)
    -> ks  $? k_id = Some true
    -> ~ In c_id cs
    -> keys_mine ks (findKeysMessage msg)
    -> cur_n' = 1 + cur_n
    -> (u_id <> None -> msg_nonce = (u_id, cur_n))
    -> cipherMsg = SigCipher k_id msg_to msg_nonce msg
    -> cs' = cs $+ (c_id, cipherMsg)
    -> mycs' = c_id :: mycs
    -> step_user Silent u_id
                (usrs, adv, cs , gks, ks, qmsgs, mycs,  froms, sents, cur_n,  Sign k_id msg_to msg)
                (usrs, adv, cs', gks, ks, qmsgs, mycs', froms, sents, cur_n', @Return (Crypto t) (SignedCiphertext c_id))

| StepVerify : forall {A B} {t} (usrs : honest_users A) (adv : user_data B) cs u_id gks ks qmsgs mycs froms sents cur_n
                 (msg : message t) k_id kp kt c_id nonce msg_to,
      gks $? k_id = Some (MkCryptoKey k_id Signing kt)
    -> ks  $? k_id = Some kp
    -> cs $? c_id = Some (SigCipher k_id msg_to nonce msg)
    -> List.In c_id mycs
    -> step_user Silent u_id
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, Verify k_id (SignedCiphertext c_id))
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, @Return (UPair (Base Bool) (Message t))(true, msg))

| StepGenerateKey: forall {A B} (usrs : honest_users A) (adv : user_data B)
                     cs u_id gks gks' ks ks' qmsgs mycs froms sents cur_n
                     (k_id : key_identifier) k kt usage,
    gks $? k_id = None
    -> k = MkCryptoKey k_id usage kt
    -> gks' = gks $+ (k_id, k)
    -> ks' = add_key_perm k_id true ks
    -> step_user Silent u_id
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, GenerateKey kt usage)
                (usrs, adv, cs, gks', ks', qmsgs, mycs, froms, sents, cur_n, @Return (Base Access) (k_id, true))

.

Inductive step_universe {A B} : option user_id -> universe A B -> ulabel -> universe A B -> Prop :=
| StepUser : forall U U' (u_id : user_id) userData usrs adv cs gks ks qmsgs mycs froms sents cur_n lbl lbl' (cmd : user_cmd (Base A)),
    U.(users) $? u_id = Some userData
    -> step_user lbl (Some u_id)
                (build_data_step U userData)
                (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
    -> U' = buildUniverse usrs adv cs gks u_id {| key_heap  := ks
                                               ; msg_heap  := qmsgs
                                               ; protocol  := cmd
                                               ; c_heap    := mycs
                                               ; from_nons := froms
                                               ; sent_nons := sents
                                               ; cur_nonce := cur_n |}
    -> lbl' = mkULbl lbl u_id
    -> step_universe (Some u_id) U lbl' U'
| StepAdversary : forall U U' usrs adv cs gks ks qmsgs mycs froms sents cur_n lbl (cmd : user_cmd (Base B)),
    step_user lbl None
              (build_data_step U U.(adversary))
              (usrs, adv, cs, gks, ks, qmsgs, mycs, froms, sents, cur_n, cmd)
    -> U' = buildUniverseAdv usrs cs gks {| key_heap  := ks
                                         ; msg_heap  := qmsgs
                                         ; protocol  := cmd
                                         ; c_heap    := mycs
                                         ; from_nons := froms
                                         ; sent_nons := sents
                                         ; cur_nonce := cur_n |}
    -> step_universe None U Silent U'
.