(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

(**

  Extracts the unguessable tokens from canonical operators, opids, and
  terms.

*)

Require Export terms2.
Require Export sovar.

Definition oatom o := @OList (get_patom_set o).
Definition oatomv {o} a : oatom o := OLO a.
Definition oatoml {o} l : oatom o := OLL l.
Definition oatoms {o} f : oatom o := OLS f.

Definition oatomvs {o} (l : list (get_patom_set o)) : list (oatom o) :=
  map oatomv l.

Fixpoint get_cutokens {p} (t : @NTerm p) : oatom p :=
  match t with
    | vterm _ => oatoml []
    | sterm f => oatoms (fun n => get_cutokens (f n))
    | oterm o bterms =>
      oappl ((oatomvs (get_utokens_o o))
               ++ (map get_cutokens_b bterms))
  end
with get_cutokens_b {p} (bt : @BTerm p) : oatom p :=
       match bt with
         | bterm _ t => get_cutokens t
       end.

Fixpoint get_utokens_so {p} (t : @SOTerm p) : list (get_patom_set p) :=
  match t with
  | sovar _ ts => flat_map get_utokens_so ts
  | soseq s => []
  | soterm op bs => (get_utokens_o op) ++ (flat_map get_utokens_b_so bs)
  end
with get_utokens_b_so {p} (bt : @SOBTerm p) : list (get_patom_set p) :=
       match bt with
       | sobterm _ t => get_utokens_so t
       end.

Fixpoint get_cutokens_so {p} (t : @SOTerm p) : oatom p :=
  match t with
  | sovar _ ts => oappl (map get_cutokens_so ts)
  | soseq s => oatoms (fun n => get_cutokens (s n))
  | soterm op bs => oappl ((oatomvs (get_utokens_o op))
                             ++ (map get_cutokens_b_so bs))
  end
with get_cutokens_b_so {p} (bt : @SOBTerm p) : oatom p :=
       match bt with
       | sobterm _ t => get_cutokens_so t
       end.

Definition get_utokens_bs {p} (bts : list (@BTerm p)) : list (get_patom_set p) :=
  flat_map get_utokens_b bts.

Definition get_cutokens_bs {p} (bts : list (@BTerm p)) : oatom p :=
  oatoml (map get_cutokens_b bts).

Definition getc_utokens {p} (t : @CTerm p) : list (get_patom_set p) :=
  get_utokens (get_cterm t).

Definition getc_cutokens {p} (t : @CTerm p) : oatom p :=
  get_cutokens (get_cterm t).

Definition is_free_from_atom {o} (a : get_patom_set o) (t : @NTerm o) :=
  !LIn a (get_utokens t).

Definition is_free_from_oatom {o} (a : get_patom_set o) (t : @NTerm o) :=
  !in_olist a (get_cutokens t).

Lemma nt_wf_utoken {o} : forall a : @get_patom_set o, nt_wf (mk_utoken a).
Proof.
  sp; repeat constructor; simpl; sp.
Qed.


Require Import Coq.omega.Omega.
Require Import Bedrock.DepList Bedrock.Platform.AutoSep Bedrock.Platform.Malloc.

Set Implicit Arguments.

Lemma hlist_eta' : forall A (B : A -> Type) b (h : hlist B b),
  match b return hlist B b -> Prop with
    | nil => fun _ => True
    | a :: b => fun h => h = HCons (hlist_hd h) (hlist_tl h)
  end h.
  destruct h; auto.
Qed.

Theorem hlist_eta : forall A (B : A -> Type) a b (h : hlist B (a :: b)),
  h = HCons (hlist_hd h) (hlist_tl h).
  intros; apply (hlist_eta' h).
Qed.

Lemma smem_eta : forall ls (sm sm' : smem' ls),
  NoDup ls
  -> List.Forall (fun w => smem_get' ls w sm = smem_get' ls w sm') ls
  -> sm = sm'.
  induction sm; simpl; intuition.
  rewrite hlist_nil; auto.
  inversion H0; clear H0; subst.
  inversion H; clear H; subst.
  destruct (H.addr_dec x x); intuition idtac; subst.
  rewrite (hlist_eta sm'); f_equal.
  apply IHsm; auto.
  eapply Forall_weaken'; eauto.
  simpl; intros.
  destruct (H.addr_dec x x0); subst; tauto.
Qed.

Lemma get_emp' : forall w ls,
  smem_get' ls w (smem_emp' ls) = None.
  induction ls; simpl; intuition.
  destruct (H.addr_dec a w); auto.
Qed.

Lemma get_emp : forall w,
  smem_get w smem_emp = None.
  intros.
  apply get_emp'.
Qed.

Lemma empty_mem : forall (sm : smem),
  (forall w, smem_get w sm = None)
  -> sm = smem_emp.
  intros.
  apply smem_eta.
  apply NoDup_allWords.
  apply Forall_forall; intros.
  rewrite H.
  symmetry; apply get_emp.
Qed.

Fixpoint smem_clear ls (sm : smem' ls) (w : W) : smem' ls :=
  match sm with
    | HNil => HNil
    | HCons w' _ v sm' =>
      HCons (if H.addr_dec w w' then None else v) (smem_clear sm' w)
  end.

Fixpoint smem_put ls (sm : smem' ls) (w : W) (v : B) : smem' ls :=
  match sm with
    | HNil => HNil
    | HCons w' _ v' sm' =>
      HCons (if H.addr_dec w w' then Some v else v') (smem_put sm' w v)
  end.

Lemma disjoint_get' : forall ls sm1 sm2,
  NoDup ls
  -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls
  -> disjoint' ls sm1 sm2.
  induction sm1; simpl; intuition; rewrite (hlist_eta sm2) in *; simpl in *.
  inversion H; clear H; subst.
  inversion H0; clear H0; subst.
  destruct (H.addr_dec x x); try tauto.
  destruct b; auto.
  destruct (hlist_hd sm2); auto.
  intuition discriminate.
  inversion H; clear H; subst.
  inversion H0; clear H0; subst.
  apply IHsm1; intros; auto.
  eapply Forall_weaken'; eauto.
  simpl; intros.
  destruct (H.addr_dec x x0); subst; tauto.
Qed.

Lemma disjoint_get : forall sm1 sm2,
  (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False)
  -> disjoint sm1 sm2.
  intros; apply disjoint_get'.
  apply BedrockHeap.NoDup_all_addr.
  apply Forall_forall; intros.
  eauto.
Qed.

Lemma disjoint_get_fwd' : forall ls sm1 sm2,
  disjoint' ls sm1 sm2
  -> NoDup ls
  -> List.Forall (fun w => smem_get' ls w sm1 <> None -> smem_get' ls w sm2 <> None -> False) ls.
  induction sm1; simpl; intuition; rewrite (hlist_eta sm2) in *; simpl in *;
    subst; constructor; simpl.
  destruct (H.addr_dec x x); tauto.
  inversion H0; clear H0; subst.
  eapply Forall_weaken'; try apply IHsm1.
  eauto.
  auto.
  simpl; intros.
  destruct (H.addr_dec x x0); subst; tauto.
  destruct (H.addr_dec x x); tauto.
  inversion H0; clear H0; subst.
  eapply Forall_weaken'; try apply IHsm1.
  eauto.
  auto.
  simpl; intros.
  destruct (H.addr_dec x x0); subst; tauto.
Qed.

Lemma allWordsUpto_universal : forall width init w,
  (wordToNat w < init)%nat
  -> (init <= pow2 width)%nat
  -> In w (allWordsUpto width init).
  induction init; simpl; intuition.
  destruct (weq w $ (init)); subst; auto; right.
  assert (wordToNat w <> init).
  intro; apply n.
  subst.
  symmetry; apply natToWord_wordToNat.
  auto.
Qed.

Lemma allWords_universal : forall sz w,
  In w (allWords sz).
  rewrite allWords_eq; intros; apply allWordsUpto_universal.
  apply wordToNat_bound.
  auto.
Qed.

Lemma disjoint_get_fwd : forall sm1 sm2,
  disjoint sm1 sm2
  -> (forall w, smem_get w sm1 <> None -> smem_get w sm2 <> None -> False).
  intros; eapply disjoint_get_fwd' in H; try apply BedrockHeap.NoDup_all_addr.
  assert (In w H.all_addr) by apply allWords_universal.
  generalize (proj1 (Forall_forall _ _) H _ H2); tauto.
Qed.

Lemma get_clear_ne' : forall a a' ls (sm : smem' ls),
  a <> a'
  -> smem_get' ls a (smem_clear sm a') = smem_get' ls a sm.
  induction sm; simpl; intuition.
  destruct (H.addr_dec x a); auto.
  destruct (H.addr_dec a' x); congruence.
Qed.

Lemma get_clear_ne : forall a a' sm,
  a <> a'
  -> smem_get a (smem_clear sm a') = smem_get a sm.
  intros; apply get_clear_ne'; auto.
Qed.

Lemma get_clear_eq' : forall a ls (sm : smem' ls),
  smem_get' ls a (smem_clear sm a) = None.
  induction sm; simpl; intuition.
  destruct (H.addr_dec x a); auto.
  destruct (H.addr_dec a x); congruence.
Qed.

Lemma get_clear_eq : forall a sm,
  smem_get a (smem_clear sm a) = None.
  intros; apply get_clear_eq'.
Qed.

Hint Rewrite get_clear_eq get_clear_ne
  using solve [ assumption | W_neq ] : get.

Lemma get_put_eq' : forall a v ls (sm : smem' ls),
  In a ls
  -> smem_get' ls a (smem_put sm a v) = Some v.
  induction sm; simpl; intuition.
  subst.
  destruct (H.addr_dec a a); intuition idtac.
  destruct (H.addr_dec x a); intuition idtac.
  subst.
  destruct (H.addr_dec a a); intuition idtac.
Qed.

Lemma get_put_eq : forall a v sm,
  smem_get a (smem_put sm a v) = Some v.
  intros; apply get_put_eq'.
  apply allWords_universal.
Qed.

Lemma get_put_ne' : forall a a' v ls (sm : smem' ls),
  a <> a'
  -> smem_get' ls a (smem_put sm a' v) = smem_get' ls a sm.
  induction sm; simpl; intuition.
  destruct (H.addr_dec a' x); intuition idtac.
  destruct (H.addr_dec x a); intuition idtac.
  congruence.
  destruct (H.addr_dec x a); intuition idtac.
Qed.

Lemma get_put_ne : forall a a' v sm,
  a <> a'
  -> smem_get a (smem_put sm a' v) = smem_get a sm.
  intros; apply get_put_ne'; auto.
Qed.

Hint Rewrite get_emp get_put_eq get_put_ne
  using solve [ assumption | W_neq ] : get.

Lemma join_None' : forall a ls sm1 sm2,
  smem_get' ls a sm1 = None
  -> smem_get' ls a (join' ls sm1 sm2) = smem_get' ls a sm2.
  induction sm1; simpl; intuition.
  destruct (H.addr_dec x a); subst; auto.
Qed.

Lemma join_None : forall a sm1 sm2,
  smem_get a sm1 = None
  -> smem_get a (join sm1 sm2) = smem_get a sm2.
  intros; apply join_None'; auto.
Qed.

Lemma join_Some' : forall a v ls sm1 sm2,
  smem_get' ls a sm1 = Some v
  -> smem_get' ls a (join' ls sm1 sm2) = Some v.
  induction sm1; simpl; intuition.
  destruct (H.addr_dec x a); subst; auto.
Qed.

Lemma join_Some : forall a v sm1 sm2,
  smem_get a sm1 = Some v
  -> smem_get a (join sm1 sm2) = Some v.
  intros; apply join_Some'; auto.
Qed.

Lemma split_put_clear : forall sm sm1 sm2 a v,
  split sm sm1 sm2
  -> smem_get a sm2 = Some v
  -> split sm (smem_put sm1 a v) (smem_clear sm2 a).
  unfold split; intuition subst.
  apply disjoint_get; intros.
  destruct (weq w a); subst.
  autorewrite with get in *; tauto.
  autorewrite with get in *.
  eapply disjoint_get_fwd in H1; eassumption.

  apply smem_eta; try apply BedrockHeap.NoDup_all_addr.
  apply Forall_forall; intros.
  destruct (weq x a); subst.
  rewrite join_None.
  erewrite join_Some.
  eauto.
  autorewrite with get; reflexivity.
  case_eq (smem_get a sm1); auto; intros.
  eapply disjoint_get_fwd in H1; try eassumption.
  tauto.
  instantiate (1 := a); congruence.
  congruence.

  case_eq (smem_get x sm1); intros.
  erewrite join_Some.
  erewrite join_Some.
  2: autorewrite with get; eassumption.
  2: eassumption.
  reflexivity.

  rewrite join_None.
  rewrite join_None.
  autorewrite with get; reflexivity.
  autorewrite with get; assumption.
  assumption.
Qed.

Lemma wordToNat_ninj : forall sz (u v : word sz),
  u <> v
  -> wordToNat u <> wordToNat v.
  intros; intro; apply H.
  assert (natToWord sz (wordToNat u) = natToWord sz (wordToNat v)) by congruence.
  repeat rewrite natToWord_wordToNat in H1.
  assumption.
Qed.

Lemma wordToNat_ninj' : forall sz (u v : word sz),
  wordToNat u <> wordToNat v
  -> u <> v.
  congruence.
Qed.

Theorem materialize_allocated' : forall specs stn size base sm,
  (forall w, w < base -> smem_get w sm = None)
  -> (forall n, (n < 4 * size)%nat -> smem_get (base ^+ $ (n)) sm <> None)
  -> (forall w, base ^+ $ (4 * size) <= w -> smem_get w sm = None)
  -> goodSize (wordToNat base + 4 * size)%nat
  -> interp specs ((base =?> size)%Sep stn sm).
  induction size.

  propxFo.
  apply empty_mem; intros.
  destruct (wlt_dec w base); auto.
  replace w with (base ^+ $ (wordToNat (w ^- base))); auto.
  rewrite natToWord_wordToNat.
  replace (base ^+ (w ^- base)) with w.
  apply H1.
  intros.
  replace (base ^+ $ (4 * 0)) with base in H3.
  tauto.
  simpl.
  W_eq.
  rewrite wminus_def.
  rewrite wplus_comm.
  rewrite <- wplus_assoc.
  rewrite (wplus_comm (^~ base)).
  rewrite wminus_inv.
  rewrite wplus_comm.
  rewrite wplus_unit.
  reflexivity.
  rewrite natToWord_wordToNat.
  W_eq.

  intros.
  generalize (H0 0).
  generalize (H0 1).
  generalize (H0 2).
  generalize (H0 3).
  intros.
  case_eq (smem_get (base ^+ $0) sm); intros.
  2: elimtype False; apply H6; eauto.
  case_eq (smem_get (base ^+ $1) sm); intros.
  2: elimtype False; apply H5; eauto.
  case_eq (smem_get (base ^+ $2) sm); intros.
  2: elimtype False; apply H4; eauto.
  case_eq (smem_get (base ^+ $3) sm); intros.
  2: elimtype False; apply H3; eauto.

  propxFo.

  exists (smem_put (smem_put (smem_put (smem_put smem_emp base b)
    (base ^+ $1) b0) (base ^+ $2) b1) (base ^+ $3) b2).
  exists (smem_clear (smem_clear (smem_clear (smem_clear sm base)
    (base ^+ $1)) (base ^+ $2)) (base ^+ $3)).
  split.

  repeat apply split_put_clear.
  apply split_a_semp_a.
  replace (base ^+ $0) with base in H7 by words.
  congruence.

  autorewrite with get; assumption.
  autorewrite with get; assumption.
  autorewrite with get; assumption.

  split.
  exists (implode stn (b, b0, b1, b2)).
  split.
  unfold smem_get_word.

  unfold H.footprint_w.
  autorewrite with get.
  reflexivity.

  intuition idtac.
  autorewrite with get.
  reflexivity.

  apply simplify_fwd.
  eapply Imply_sound; [ apply allocated_shift_base | ].
  instantiate (1 := 0).
  instantiate (1 := base ^+ $4).
  W_eq.
  eauto.
  apply IHsize.

  intros.
  destruct (weq w base); subst.
  autorewrite with get; reflexivity.
  destruct (weq w (base ^+ $1)); subst.
  autorewrite with get; reflexivity.
  destruct (weq w (base ^+ $2)); subst.
  autorewrite with get; reflexivity.
  destruct (weq w (base ^+ $3)); subst.
  autorewrite with get; reflexivity.
  autorewrite with get.
  apply H.
  pre_nomega.
  rewrite wordToNat_wplus in H11;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).

  repeat match goal with
           | [ H : _ |- _ ] => apply wordToNat_ninj in H
         end.
  rewrite wordToNat_wplus in n0;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).
  rewrite wordToNat_wplus in n1;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).
  rewrite wordToNat_wplus in n2;
    rewrite wordToNat_natToWord_idempotent in * by reflexivity;
      try (eapply goodSize_weaken; [ eassumption | omega ]).
  omega.

  intros.
  rewrite get_clear_ne in H12.
  rewrite get_clear_ne in H12.
  rewrite get_clear_ne in H12.
  rewrite get_clear_ne in H12.
  apply H0 with (4 + n).
  omega.
  rewrite natToW_plus.
  etransitivity; try apply H12.
  f_equal.
  unfold natToW.
  W_eq.

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.

  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  omega.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  omega.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  apply wordToNat_ninj'.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  omega.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + n)).
  eapply goodSize_weaken; [ eassumption | omega ].

  intros.
  rewrite get_clear_ne.
  rewrite get_clear_ne.
  rewrite get_clear_ne.
  rewrite get_clear_ne.
  apply H1.
  Opaque mult.
  pre_nomega.
  rewrite <- wplus_assoc in H11.
  rewrite <- natToW_plus in H11.
  rewrite wordToNat_wplus in H11.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent in H11.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 * S size)); eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  assumption.
  change (goodSize (4 * S size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].

  intro; apply H11; subst.
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  pre_nomega.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent.
  omega.
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent.
  eapply goodSize_weaken; [ eassumption | omega ].
  change (goodSize (4 + 4 * size)); eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].

  rewrite wordToNat_wplus.
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
  rewrite wordToNat_natToWord_idempotent by reflexivity.
  eapply goodSize_weaken; [ eassumption | omega ].
Qed.

Definition goodSize' (n : nat) := (N.of_nat n < 1 + Npow2 32)%N.

Lemma get_memoryIn' : forall m w init,
  (wordToNat w < init)%nat
  -> goodSize' init
  -> smem_get' (allWordsUpto 32 init) w (memoryIn' m _) = m w.
  induction init; simpl; intuition.
  destruct (H.addr_dec $ (init) w).
  unfold H.mem_get, ReadByte.
  congruence.
  apply IHinit.
  apply wordToNat_ninj in n.
  rewrite wordToNat_natToWord_idempotent in n.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32); intros.
  apply Nlt_out in H0.
  rewrite N2Nat.inj_add in H0.
  autorewrite with N in *.
  pre_nomega.
  simpl in *.
  omega.
  generalize H0; clear.
  unfold goodSize'.
  generalize (Npow2 32).
  intros.
  nomega.
Qed.

Lemma pow2_N : forall n,
  N.of_nat (pow2 n) = Npow2 n.
  intros.
  assert (N.to_nat (N.of_nat (pow2 n)) = N.to_nat (Npow2 n)).
  autorewrite with N.
  symmetry; apply Npow2_nat.
  assert (N.of_nat (N.to_nat (N.of_nat (pow2 n))) = N.of_nat (N.to_nat (Npow2 n))) by congruence.
  autorewrite with N in *.
  assumption.
Qed.

Lemma get_memoryIn : forall m w,
  smem_get w (memoryIn m) = m w.
  intros.
  unfold smem_get, memoryIn, HT.memoryIn, H.all_addr.
  rewrite allWords_eq.
  apply get_memoryIn'.
  apply wordToNat_bound.
  hnf.
  rewrite pow2_N.
  reflexivity.
Qed.
Require Import Coq.Arith.Arith.

Theorem materialize_allocated : forall stn st size specs,
  (forall n, (n < size * 4)%nat -> st.(Mem) n <> None)
  -> (forall w, $ (size * 4) <= w -> st.(Mem) w = None)
  -> goodSize (size * 4)%nat
  -> interp specs (![ 0 =?> size ] (stn, st)).
  rewrite sepFormula_eq; intros.
  apply materialize_allocated'; simpl.
  intros.
  pre_nomega.
  rewrite roundTrip_0 in H2.
  omega.
  intros.
  rewrite <- natToW_plus; simpl.
  rewrite get_memoryIn.
  auto.
  intros.
  rewrite wplus_unit in H2.
  rewrite get_memoryIn.
  apply H0.
  rewrite mult_comm; assumption.
  rewrite mult_comm; assumption.
Qed.

(** * Now put it all together to prove [genesis]. *)

Section boot.
  Variables heapSize globalsSize : nat.

  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.
  Hypothesis heapSizeUpperBound : goodSize (heapSize * 4).

  Lemma goodSize_heapSize : goodSize heapSize.
    eapply goodSize_weaken; [ eassumption | omega ].
  Qed.

  Hint Immediate goodSize_heapSize.

  Theorem heapSizeLowerBound' : natToW heapSize < natToW 3 -> False.
    change (natToW 3 <= natToW heapSize).
    intro; pre_nomega.
    rewrite wordToNat_natToWord_idempotent in *.
    rewrite wordToNat_natToWord_idempotent in *.
    omega.
    reflexivity.
    change (goodSize heapSize); eapply goodSize_weaken; [ eassumption | omega ].
  Qed.

  Hint Immediate heapSizeLowerBound'.

  Theorem noWrap : noWrapAround (natToW 4) (heapSize - 1).
    simpl; hnf; intros.
    intro.
    rewrite <- natToW_plus in H0.
    apply natToW_inj in H0.
    omega.
    2: reflexivity.
    eapply goodSize_weaken; [ eassumption | omega ].
  Qed.

  Theorem heapSize_roundTrip : wordToNat (natToW heapSize) = heapSize.
    intros; apply wordToNat_natToWord_idempotent;
      change (goodSize heapSize); eauto.
  Qed.

  Hint Rewrite heapSize_roundTrip : sepFormula.

  Definition bootS := {|
    Reserved := 49;
    Formals := nil;
    Precondition := fun _ => st ~> ![ 0 =?> (heapSize + 50 + globalsSize) ] st
  |}.
  Require Import Coq.Arith.Arith.

  Lemma wiggle : forall P Q R,
    P * (Q * R) ===> Q * P * R.
    sepLemma.
  Qed.

  Theorem genesis :
    0 =?> (heapSize + 50 + globalsSize)
    ===> (Ex vs, locals ("rp" :: nil) vs 49 (heapSize * 4)%nat) * 0 =?> heapSize * ((heapSize + 50) * 4)%nat =?> globalsSize.
    descend; intros; eapply Himp_trans; [ apply allocated_split | ].
    instantiate (1 := heapSize); auto.
    apply Himp_trans with (0 =?> heapSize *
      ((heapSize * 4)%nat =?> 50 * ((heapSize + 50) * 4)%nat =?> globalsSize))%Sep.
    apply Himp_star_frame.
    apply Himp_refl.
    intros; eapply Himp_trans; [ apply allocated_split | ].
    instantiate (1 := 50); auto.
    apply Himp_star_frame.
    apply allocated_shift_base.
    rewrite mult_comm.
    simpl.
    unfold natToW.
    words.
    reflexivity.
    apply allocated_shift_base.
    simpl.
    rewrite <- mult_plus_distr_l.
    rewrite mult_comm.
    unfold natToW.
    words.
    omega.

    eapply Himp_trans; [ apply wiggle | ].
    repeat (apply Himp_star_frame; try apply Himp_refl).
    change 50 with (length ("rp" :: nil) + 49).
    apply create_stack.
    NoDup.
  Qed.

  Transparent mult.

  Lemma bootstrap_Sp_nonzero : forall sp : W,
    sp = 0
    -> sp = heapSize * 4
    -> goodSize (heapSize * 4)
    -> False.
    intros; subst; apply natToW_inj in H0; auto; omega.
  Qed.

  Hypothesis globals : nat.
  Hypothesis mem_size : goodSize ((heapSize + 50 + globals) * 4)%nat.

  Lemma bootstrap_Sp_freeable : forall sp : W,
    sp = heapSize * 4
    -> freeable sp 50.
    intros; subst; constructor; auto.
    hnf; intros.
    rewrite <- natToW_plus.
    intro.
    apply natToW_inj in H0.
    omega.
    unfold size in *.
    eapply goodSize_weaken; [ apply mem_size | ].
    omega.
    auto.
  Qed.
End boot.

Definition genesisHints : TacPackage.
  prepare genesis tt.
Defined.

Ltac genesis := post; evaluate genesisHints; simpl in *; sep genesisHints; eauto.

Require Import Bedrock.Platform.Safety.

Ltac safety ok :=
  eapply safety; try eassumption; [
    link_simp; unfold labelSys, labelSys'; simpl; tauto
    | apply ok
    | apply LabelMap.find_2; link_simp; reflexivity
    | propxFo; apply materialize_allocated; assumption ].

Hint Immediate goodSize_heapSize heapSizeLowerBound' bootstrap_Sp_nonzero bootstrap_Sp_freeable.
Hint Rewrite heapSize_roundTrip using assumption : sepFormula.
Hint Extern 1 (noWrapAround _ _) => apply noWrap.

Ltac goodSize :=
  match goal with
    | [ H : goodSize (?size * 4)%nat |- _ ] => unfold size in *
  end; eapply goodSize_weaken; [ eassumption | omega ].


(** Beginning of the file for CP mechanisation as described in

    Philip Wadler. 2012. Propositions as sessions. In Proceedings of the 17th
    ACM SIGPLAN international conference on Functional programming (ICFP '12).
    ACM, New York, NY, USA, 273-286. DOI=10.1145/2364527.2364568
    http://doi.acm.org/10.1145/2364527.2364568

*)
Require Import Metatheory.Metatheory.
Require Import Coq.Sorting.Permutation.

Set Implicit Arguments.

(** Propositional variables are represented as natural numbers (bound) or
    atoms (free).
*)
Inductive pvar :=
  | pvar_bvar : nat -> pvar
  | pvar_fvar : atom -> pvar.

Coercion pvar_bvar : nat >-> pvar.
Coercion pvar_fvar : atom >-> pvar.

(** Propositions ranged over by A, B and C.

    Note binding is de Bruijn indices with forall/exists being binders.
*)
Inductive prop : Type :=
  | pp_var : pvar -> prop
  | pp_dvar : pvar -> prop (* dual of a pvar *)
  | pp_times : prop -> prop -> prop
  | pp_par : prop -> prop -> prop
  | pp_plus : prop -> prop -> prop
  | pp_with : prop -> prop -> prop
  | pp_accept : prop -> prop (* !A *)
  | pp_request : prop -> prop (* ?A *)
  | pp_one : prop (* unit for times *)
  | pp_bot : prop (* unit for par *)
  | pp_zero : prop (* unit for plus *)
  | pp_top : prop (* unit for with *).

Hint Constructors prop.

(** Define some friendly notation. Level 48 to have higher precedence than
    the ~ notation for environments; prevents need for parens. *)
Notation "A ⨂ B" := (pp_times A B) (at level 48, left associativity)
                                         : cp_scope.
Notation "A ⅋ B" := (pp_par A B) (at level 48, left associativity)
                                     : cp_scope.
Notation "A ⨁ B" := (pp_plus A B) (at level 48, left associativity)
                                       : cp_scope.
Notation "A & B" := (pp_with A B) (at level 48, left associativity)
                                       : cp_scope.
Notation "'!' A" := (pp_accept A) (at level 48, left associativity)
                                  : cp_scope.
Notation "'?' A" := (pp_request A) (at level 48, left associativity)
                                   : cp_scope.
Reserved Notation "'¬' A" (at level 47, left associativity).

Delimit Scope cp_scope with cp.
Open Scope cp_scope.

(** Return the dual of the proposition [pp]. *)
Fixpoint prop_dual (pp : prop) : prop :=
  match pp with
  | pp_var X => pp_dvar X
  | pp_dvar X => pp_var X
  | A ⨂ B => ¬A ⅋ ¬B
  | A ⅋ B => ¬A ⨂ ¬B
  | A ⨁ B => ¬A & ¬B
  | A & B => ¬A ⨁ ¬B
  | ! A => ? ¬A
  | ? A => ! ¬A
  | pp_one => pp_bot
  | pp_bot => pp_one
  | pp_zero => pp_top
  | pp_top => pp_zero
  end
where "'¬' A" := (prop_dual A) : cp_scope.

Inductive dual_props : prop -> prop -> Prop :=
  | dual_var : forall X, dual_props (pp_var X) (pp_dvar X)
  | dual_mul : forall A B dA dB (DUA: dual_props A dA) (DUB: dual_props B dB),
                 dual_props (A ⨂ B) (dA ⅋ dB)
  | dual_add : forall A B dA dB (DUA: dual_props A dA) (DUB: dual_props B dB),
                  dual_props (A ⨁ B) (dA & dB)
  | dual_exp : forall A dA (DUA: dual_props A dA), dual_props (! A) (? dA)
  | dual_umul : dual_props pp_one pp_bot
  | dual_uadd : dual_props pp_zero pp_top
  | dual_sym : forall P dP (DP: dual_props P dP),
                 dual_props dP P.

Hint Constructors dual_props.

(** Substitution of proposition [A] for [X] in [B] is denoted by
    {{ A // X }} B -- double syntax used to get Coq to accept it. *)
Reserved Notation "'{{' A '//' X '}}' B" (at level 46, left associativity).

(** The following definition of substitution for a free propositional variable
    assumes the term to be substituted is locally closed.
*)
Fixpoint prop_subst (x: atom) (u: prop) (pp: prop) : prop :=
  match pp with
  | pp_var v
    => match v with
       | pvar_fvar y => if x == y then u else pp
       | _ => pp
       end
  | pp_dvar v
    => match v with
       | pvar_fvar y => if x == y then ¬u else pp
       | _ => pp
       end
  | A ⨂ B => {{ u // x }} A ⨂ {{ u // x }} B
  | A ⅋ B => {{ u // x }} A ⅋ {{ u // x }} B
  | A ⨁ B => {{ u // x }} A ⨁ {{ u // x }} B
  | A & B => {{ u // x }} A & {{ u // x }} B
  | ! A => ! {{ u // x }} A
  | ? A => ? {{ u // x }} A
  | _ => pp
  end
where "'{{' A '//' X '}}' B" := (prop_subst X A B) : cp_scope.

(** Opening a prop pp is replacing an unbound prop variable with index k with
    free propositional variable u.
*)
Fixpoint prop_open_rec (k: nat) (u: atom) (pp: prop) :=
  match pp with
  | pp_var v
    => match v with
       | pvar_bvar n => if k == n then pp_var u else pp
       | _ => pp
       end
  | pp_dvar v
    => match v with
       | pvar_bvar n => if k == n then pp_dvar u else pp
       | _ => pp
       end
  | A ⨂ B => (prop_open_rec k u A) ⨂ (prop_open_rec k u B)
  | A ⅋ B => (prop_open_rec k u A) ⅋ (prop_open_rec k u B)
  | A ⨁ B => (prop_open_rec k u A) ⨁ (prop_open_rec k u B)
  | A & B => (prop_open_rec k u A) & (prop_open_rec k u B)
  | ! A => ! (prop_open_rec k u A)
  | ? A => ? (prop_open_rec k u A)
  | _ => pp
  end.

Definition open_prop t u := prop_open_rec 0 u t.

Fixpoint fv_prop (pp:prop) : atoms :=
  match pp with
  | pp_var v
    => match v with
       | pvar_fvar y => singleton y
       | _ => empty
       end
  | pp_dvar v
    => match v with
       | pvar_fvar y => singleton y
       | _ => empty
       end
  | A ⨂ B => fv_prop A `union` fv_prop B
  | A ⅋ B => fv_prop A `union` fv_prop B
  | A ⨁ B => fv_prop A `union` fv_prop B
  | A & B => fv_prop A `union` fv_prop B
  | ! A => fv_prop A
  | ? A => fv_prop A
  | _ => empty
  end.

(** Names within processes; represent channel identifiers. *)
Inductive pname : Set :=
  | p_bn : nat -> pname
  | p_fn : atom -> pname.

Coercion p_bn : nat >-> pname.
Coercion p_fn : atom >-> pname.

(** Definition of a processes ranged over by P, Q and R. *)
Inductive proc : Set :=
  | p_link : pname -> pname -> proc
  | p_par : prop -> proc -> proc -> proc
  | p_output : pname -> prop -> proc -> proc -> proc
  | p_input : pname -> prop -> proc -> proc
  | p_left : pname -> proc -> proc
  | p_right : pname -> proc -> proc
  | p_choice : pname -> proc -> proc -> proc
  | p_accept : pname -> prop -> proc -> proc
  | p_request : pname -> prop -> proc -> proc
  | p_weak: pname -> proc -> proc
  | p_empout : pname -> proc
  | p_empin : pname -> proc -> proc
  | p_empcho : pname -> proc.

Hint Constructors proc.

(** Some helpful notations. *)
Notation "x ⟷ y" := (p_link x y) (at level 68) : cp_scope.
Notation "'ν' A '→' P '‖' Q" := (p_par A P Q) (at level 68, x ident,
                                               right associativity)
                                              : cp_scope.

(** Change of notation from the paper; Coq doesn't seem to like the x coming
    first. *)
Notation "'[' A ']' x '→' P '‖' Q" := (p_output x A P Q) (at level 68,
                                                          right associativity)
                                                         : cp_scope.
(** We use ⟨⟩ instead of () in the input cases. *)
Notation "'⟨' A '⟩' x '→' P" := (p_input x A P) (at level 68,
                                                right associativity)
                                                : cp_scope.

Notation "x '[inl]' → P" := (p_left x P) (at level 68,
                                          right associativity) : cp_scope.
Notation "x '[inr]' → P" := (p_right x P) (at level 68,
                                          right associativity) : cp_scope.
Notation "x 'CASE' P 'OR' Q" := (p_choice x P Q) (at level 68,
                                                  right associativity)
                                                 : cp_scope.
Notation "'!' '⟨' A '⟩' x → P" := (p_accept x A P) (at level 68,
                                                    right associativity)
                                                   : cp_scope.
Notation "'?' '[' A ']' x → P" := (p_request x A P) (at level 68,
                                                     right associativity)
                                                    : cp_scope.
Notation "'?' '[' ']' x → P" := (p_weak x P) (at level 68,
                                              right associativity)
                                             : cp_scope.
Notation "x '→' 0" := (p_empout x) (at level 68) : cp_scope.
Notation "⟨⟩ x → P" := (p_empin x P) (at level 68,
                                      right associativity) : cp_scope.
Notation "x 'CASE' 0" := (p_empcho x) (at level 68) : cp_scope.

(** The following definition of substitution for a free name
    assumes the term to be substituted is locally closed.
*)
Fixpoint proc_subst (x y: atom) (p: proc) : proc :=
  let
    sub := fun u => match u with
                    | p_fn z => if z == x then y else u
                    | _ => u
                    end
  in
    match p with
    | w ⟷ z => sub w ⟷ sub z
    | ν A → P ‖ Q => ν A → (proc_subst x y P) ‖ (proc_subst x y Q)
    | [A] z → P ‖ Q => [A] (sub z) → (proc_subst x y P) ‖ (proc_subst x y Q)
    | ⟨A⟩ z → P => ⟨A⟩ (sub z) → (proc_subst x y P)
    | z [inl] → P => (sub z) [inl] → (proc_subst x y P)
    | z [inr] → P => (sub z) [inr] → (proc_subst x y P)
    | z CASE P OR Q => (sub z) CASE (proc_subst x y P) OR (proc_subst x y Q)
    | ! ⟨A⟩ z → P => ! ⟨A⟩ (sub z) → (proc_subst x y P)
    | ? [A] z → P => ? [A] (sub z) → (proc_subst x y P)
    | ? [] z → P => ? [] (sub z) → (proc_subst x y P)
    | z → 0 => (sub z) → 0
    | ⟨⟩ z → P => ⟨⟩ (sub z) → (proc_subst x y P)
    | z CASE 0 => (sub z) CASE 0
    end.

Notation "[ x ~> y ] P" := (proc_subst x y P) (at level 68) : cp_scope.

(** Opening a proc p is replacing an unbound name with index k with
    free name x.
*)
Fixpoint proc_open_rec (k: nat) (x: atom) (p: proc) :=
  let
    sub := fun u => match u with
                    | p_bn n => if n == k then p_fn x else u
                    | _ => u
                    end
  in
    match p with
    | w ⟷ z => sub w ⟷ sub z
    | ν A → P ‖ Q
      => ν A → (proc_open_rec (S k) x P) ‖ (proc_open_rec (S k) x Q)
    | [A] z → P ‖ Q
      => [A] (sub z) → (proc_open_rec (S k) x P) ‖ (proc_open_rec k x Q)
    | ⟨A⟩ z → P => ⟨A⟩ (sub z) → (proc_open_rec (S k) x P)
    | z [inl] → P => (sub z) [inl] → (proc_open_rec k x P)
    | z [inr] → P => (sub z) [inr] → (proc_open_rec k x P)
    | z CASE P OR Q
      => (sub z) CASE (proc_open_rec k x P) OR (proc_open_rec k x Q)
    | ! ⟨A⟩ z → P => ! ⟨A⟩ (sub z) → (proc_open_rec (S k) x P)
    | ? [A] z → P => ? [A] (sub z) → (proc_open_rec (S k) x P)
    | ? [] z → P => ? [] (sub z) → (proc_open_rec k x P)
    | z → 0 => sub z → 0
    | ⟨⟩ z → P => ⟨⟩ (sub z) → (proc_open_rec k x P)
    | z CASE 0 => (sub z) CASE 0
    end.

Notation "{ k ~> u } t" := (proc_open_rec k u t) (at level 68,
                                                  right associativity).

Definition open_proc P x := proc_open_rec 0 x P.
Notation "P ^^ x" := (open_proc P x) (at level 68) : cp_scope.

Hint Unfold open_proc.

Fixpoint fv_proc (p : proc) : atoms :=
  let
    fv := fun u => match u with
                   | p_fn z => singleton z
                   | _ => empty
                   end
  in
    match p with
    | w ⟷ z => fv w `union` fv z
    | ν A → P ‖ Q => fv_proc P `union` fv_proc Q
    | [A] z → P ‖ Q => fv z `union` fv_proc P `union` fv_proc Q
    | ⟨A⟩ z → P => fv z `union` fv_proc P
    | z [inl] → P => fv z `union` fv_proc P
    | z [inr] → P => fv z `union` fv_proc P
    | z CASE P OR Q => fv z `union` fv_proc P `union` fv_proc Q
    | ! ⟨A⟩ z → P => fv z `union` fv_proc P
    | ? [A] z → P => fv z `union` fv_proc P
    | ? [] z → P => fv z `union` fv_proc P
    | z → 0 => fv z
    | ⟨⟩ z → P => fv z `union` fv_proc P
    | z CASE 0 => fv z
    end.

(* Permute binders inside process. *)
Reserved Notation "{ a <~> b } Q" (at level 68, right associativity).

Fixpoint swap_binders (a b:nat) (Q:proc) : proc :=
  let
    swap := fun x => match x with
                     | p_bn n =>
                       p_bn (if n == a then b else if n == b then a else n)
                     | _ => x
                     end
  in
    match Q with
    | w ⟷ z => swap w ⟷ swap z
    | ν A → P ‖ R
      => ν A → ({S a <~> S b} P) ‖ ({S a <~> S b} R)
    | [A] z → P ‖ R
      => [A] (swap z) → ({S a <~> S b} P) ‖ ({a <~> b}R)
    | ⟨A⟩ z → P => ⟨A⟩ (swap z) → ({S a <~> S b} P)
    | z [inl] → P => (swap z) [inl] → ({a <~> b} P)
    | z [inr] → P => (swap z) [inr] → ({a <~> b} P)
    | z CASE P OR R
      => (swap z) CASE ({a <~> b} P) OR ({a <~> b} R)
    | ! ⟨A⟩ z → P => ! ⟨A⟩ (swap z) → ({S a <~> S b} P)
    | ? [A] z → P => ? [A] (swap z) → ({S a <~> S b} P)
    | ? [] z → P => ? [] (swap z) → ({a <~> b} P)
    | z → 0 => swap z → 0
    | ⟨⟩ z → P => ⟨⟩ (swap z) → ({a <~> b} P)
    | z CASE 0 => (swap z) CASE 0
    end
where "{ a <~> b } P" := (swap_binders a b P) : cp_scope.

(** Environments for the process calculus are mappings of atoms to
    propositions. *)
Definition penv := list (atom * prop).

(** Encoding an environment as all requests; for the server accept process
    rule. *)
Inductive all_requests : penv -> Prop :=
  | all_reqs_nil : all_requests nil
  | all_reqs_cons : forall x A Γ (REQS: all_requests Γ),
                          all_requests ((x ~ ? A) ++ Γ).

Hint Constructors all_requests.

(** Locally closed processes. *)
Inductive lc_proc : proc -> Prop :=
  | lc_p_fwd : forall (w x:atom), lc_proc (w ⟷ x)
  | lc_p_cut : forall (L:atoms) P Q A
                    (COP: forall (x:atom) (NL: x `notin` L),
                            lc_proc (open_proc P x))
                    (COQ: forall (x:atom) (NL: x `notin` L),
                            lc_proc (open_proc Q x)),
               lc_proc (ν A → P ‖ Q)
  | lc_p_output : forall (L:atoms) P Q (x:atom) A
                         (COP: forall (y:atom) (NL: y `notin` L),
                                 lc_proc (open_proc P y))
                         (COQ: lc_proc Q),
                    lc_proc ([A]x → P ‖ Q)
  | lc_p_input : forall (L:atoms) P (x:atom) A
                        (COP: forall (y:atom) (NL: y `notin` L),
                                lc_proc (open_proc P y)),
                   lc_proc (⟨A⟩x → P)
  | lc_p_left : forall P (x:atom) (COP: lc_proc P),
                  lc_proc (x[inl] → P)
  | lc_p_right : forall P (x:atom) (COP: lc_proc P),
                   lc_proc (x[inr] → P)
  | lc_p_choice : forall P Q (x:atom) (COP: lc_proc P) (COQ: lc_proc Q),
                    lc_proc (x CASE P OR Q)
  | lc_p_accept : forall (L:atoms) P (x:atom) A
                         (COP: forall (y:atom) (NL: y `notin` L),
                                 lc_proc (open_proc P y)),
                    lc_proc (! ⟨A⟩ x → P)
  | lc_p_request : forall (L:atoms) P (x:atom) A
                          (COP: forall (y:atom) (NL: y `notin` L),
                                  lc_proc (open_proc P y)),
                     lc_proc (? [A] x → P)
  | lc_p_weak : forall P (x:atom) (COP: lc_proc P), lc_proc (? [] x → P)
  | lc_p_empout : forall (x:atom), lc_proc (x → 0)
  | lc_p_empin : forall P (x:atom) (COP: lc_proc P), lc_proc (⟨⟩ x → P)
  | lc_p_empcho : forall (x:atom), lc_proc (x CASE 0).

Hint Constructors lc_proc.

Reserved Notation "P '⊢cp' Γ" (at level 69).

(** The uniqueness assumption is necessary to ensure environments are only
    combined if they contain distinct names.
    Note in some cases we utilise cofinite quantification to provide a
    suitably fresh name for some channels. Some cases could be written as
    x `notin` Γ for some x, Γ but I elected to maintain uniq assumptions
    wherever possible to keep the development symmetrical (in theory, this
    could help proofs since all rules follow a similar structure).

    The proof scripts use the location of the forall quantifiers to simplify
    application of the constructors. For example, the position of L as the
    first quantified variable is essential for the "pick fresh" tactics. In
    principle, one could change this by utilising the SFLibTactics.v applys
    et al. tactics.
*)
Inductive cp_rule : proc -> penv -> Prop :=
  | cp_fwd : forall Γ (x w:atom) A
                    (PER: Permutation Γ (w ~ ¬A ++ x ~ A))
                    (UN: uniq Γ),
               w ⟷ x ⊢cp Γ
  | cp_cut : forall (L:atoms) P Q A Γ ΔP ΔQ
                    (PER: Permutation Γ (ΔP ++ ΔQ))
                    (UN: uniq Γ)
                    (CPP: forall (x:atom) (NL: x `notin` L),
                            (open_proc P x) ⊢cp (x ~ A) ++ ΔP)
                    (CPQ: forall (x:atom) (NL: x `notin` L),
                            (open_proc Q x) ⊢cp (x ~ ¬A) ++ ΔQ),
               ν A → P ‖ Q ⊢cp Γ
  | cp_output : forall (L:atoms) P Q Γ ΔP ΔQ x A B
                       (PER: Permutation Γ ((x ~ A ⨂ B) ++ ΔP ++ ΔQ))
                       (UN: uniq Γ)
                       (CPP: forall (y:atom) (NL: y `notin` L),
                               (open_proc P y) ⊢cp (y ~ A) ++ ΔP)
                       (CPQ: Q ⊢cp (x ~ B) ++ ΔQ),
                  [A]x → P ‖ Q ⊢cp Γ
  | cp_input : forall (L:atoms) P Γ ΔP x A B
                      (PER: Permutation Γ ((x ~ A ⅋ B) ++ ΔP))
                      (UN: uniq Γ)
                      (CPP: forall (y:atom) (NL: y `notin` L),
                           (open_proc P y) ⊢cp (y ~ A) ++ (x ~ B) ++ ΔP),
                 ⟨A⟩x → P ⊢cp Γ
  | cp_left : forall P Γ Δ x A B
                     (PER: Permutation Γ ((x ~ A ⨁ B) ++ Δ))
                     (CPP: P ⊢cp (x ~ A) ++ Δ),
                x[inl] → P ⊢cp Γ
  | cp_right : forall P Γ Δ x A B
                      (PER: Permutation Γ ((x ~ A ⨁ B) ++ Δ))
                      (CPP: P ⊢cp (x ~ B) ++ Δ),
                 x[inr] → P ⊢cp Γ
  | cp_choice : forall P Q Γ Δ x A B
                       (PER: Permutation Γ ((x ~ A & B) ++ Δ))
                       (CPP: P ⊢cp (x ~ A) ++ Δ)
                       (CPQ: Q ⊢cp (x ~ B) ++ Δ),
                  x CASE P OR Q ⊢cp Γ
  | cp_accept : forall (L:atoms) P Γ Δ (x:atom) A
                       (PER: Permutation Γ (x ~ ! A ++ Δ))
                       (REQSΓ: all_requests Δ)
                       (UN: uniq Γ)
                       (CPP: forall (y:atom) (NL: y `notin` L),
                               (open_proc P y) ⊢cp (y ~ A) ++ Δ),
                  ! ⟨A⟩ x → P ⊢cp Γ
  | cp_request : forall (L:atoms) P Γ Δ (x:atom) A
                        (PER: Permutation Γ (x ~ ? A ++ Δ))
                        (UN: uniq Γ)
                        (CPP: forall (y:atom) (NL: y `notin` L),
                                (open_proc P y) ⊢cp (y ~ A) ++ Δ),
                   ? [A] x → P ⊢cp Γ
  | cp_weaken : forall P Γ Δ (x:atom) A
                       (PER: Permutation Γ (x ~ ? A ++ Δ))
                       (UN: uniq Γ)
                       (CPP: P ⊢cp Δ),
                  ? [] x → P ⊢cp Γ
  | cp_empout : forall (x: atom), x → 0 ⊢cp x ~ pp_one
  | cp_empin : forall P Γ Δ (x:atom)
                      (PER: Permutation Γ (x ~ pp_bot ++ Δ))
                      (UN: uniq Γ)
                      (CPP: P ⊢cp Δ),
                 ⟨⟩ x → P ⊢cp Γ
  | cp_empcho : forall (x:atom), x CASE 0 ⊢cp x ~ pp_top
where "P '⊢cp' Γ" := (cp_rule P Γ) : cp_scope.

Hint Constructors cp_rule.

Fixpoint weakenv (xs:list atom) (P:proc) : proc :=
  match xs with
  | nil => P
  | x :: xs' => ? [] x → (weakenv xs' P)
  end.

(* Structural equivalences *)

Definition proc_equiv (P Q:proc) := forall Γ, P ⊢cp Γ <-> Q ⊢cp Γ.
Notation "P =p= Q" := (proc_equiv P Q) (at level 69) : cp_scope.

Reserved Notation "P '==>cp' Q" (at level 69, right associativity).

(** Principal cut reductions and commuting conversions. *)
Inductive proc_red : proc -> proc -> Prop :=
  (** Principal cut reductions *)
  | red_axcut :
      forall P A (w x:atom) (NF: w `notin` fv_proc P),
        ν A → w ⟷ 0 ‖ P
      ==>cp
        (open_proc P w)
  | red_multi :
      forall P Q R A dA B (DUA: dual_props A dA),
        ν A ⨂ B → ([A]0 → P ‖ Q) ‖ ⟨dA⟩ 0 → R
      ==>cp
        ν A → P ‖ (ν B → Q ‖ {0 <~> 1}R)
  | red_add_inl :
      forall P Q R A B,
        ν A ⨁ B → (0[inl] → P) ‖ 0 CASE Q OR R
      ==>cp
        ν A → P ‖ Q
  | red_add_inr :
      forall P Q R A B,
        ν A ⨁ B → (0[inr] → P) ‖ 0 CASE Q OR R
      ==>cp
        ν B → P ‖ R
  | red_spawn :
      forall P Q A dA (DUA: dual_props A dA),
        ν ! A → ! ⟨A⟩ 0 → P ‖ ? [dA]0 → Q
      ==>cp
        ν A → P ‖ Q
  | red_gc :
      forall P Q (y:atom) A
             (NF: y `notin` fv_proc P),
        ν ! A → ! ⟨A⟩0 → P ‖ ? [] 0 → Q
      ==>cp
        weakenv (elements (remove y (fv_proc (P ^^ y)))) Q
  | red_unit :
      forall P,
        ν pp_one → (0 → 0) ‖ ⟨⟩0 → P
      ==>cp
        P
  (** Commuting conversions *)
  | red_cc_multi_one:
      forall P Q R (x:atom) A B
             (LCQ: lc_proc Q),
        ν A → ([B] x → P ‖ Q) ‖ R
      ==>cp
        [B] x → (ν A → {0 <~> 1}P ‖ R) ‖ Q
  | red_cc_multi_two:
      forall P Q R (x:atom) A B
             (LCP: forall x, lc_proc (P ^^ x)),
        ν A → ([B] x → P ‖ Q) ‖ R
      ==>cp
        [B] x → P ‖ (ν A → Q ‖ R)
  | red_cc_input:
      forall P Q (x:atom) A B,
        ν A → (⟨B⟩ x → P) ‖ Q
      ==>cp
        ⟨B⟩x → ν A → ({0 <~> 1}P) ‖ Q
  | red_cc_add_inl:
      forall P Q (x:atom) A,
        ν A → (x[inl] → P) ‖ Q
      ==>cp
        x[inl] → (ν A → P ‖ Q)
  | red_cc_add_inr:
      forall P Q (x:atom) A,
        ν A → (x[inr] → P) ‖ Q
      ==>cp
        x[inr] → (ν A → P ‖ Q)
  | red_cc_choice:
      forall P Q R (x:atom) A,
        ν A → (x CASE P OR Q) ‖ R
      ==>cp
        x CASE (ν A → P ‖ R) OR (ν A → Q ‖ R)
  | red_cc_accept:
      forall P Q (x:atom) A B
             (REQS: forall Γ Δ
                           (PER: Permutation Γ (x~! B++Δ))
                           (WT: ν A → (! ⟨B⟩x → P) ‖ Q ⊢cp Γ),
                      all_requests Δ),
        ν A → (! ⟨B⟩x → P) ‖ Q
      ==>cp
        ! ⟨B⟩x → (ν A → {0 <~> 1}P ‖ Q)
  | red_cc_request:
      forall P Q (x:atom) A B,
        ν A → (? [B]x → P) ‖ Q
      ==>cp
        ? [B]x → (ν A → {0 <~> 1}P ‖ Q)
  | red_cc_weaken:
      forall P Q (x:atom) A,
        ν A → (? []x → P) ‖ Q
      ==>cp
        ? []x → (ν A → P ‖ Q)
  | red_cc_empin:
      forall P Q (x:atom) A,
        ν A → (⟨⟩x → P) ‖ Q
      ==>cp
        ⟨⟩x → (ν A → P ‖ Q)
  | red_cc_empcho:
      forall Q (x y:atom) A
           (REQS: forall Γ Δ
                         (PER: Permutation Γ (x~pp_top ++ Δ))
                         (WT: ν A → (? []0 → x CASE 0) ‖ Q ⊢cp Γ),
                    all_requests Δ)
             (NF: y `notin` fv_proc Q),
        ν A → (? []0 → x CASE 0) ‖ Q
      ==>cp
        weakenv (elements (remove y (fv_proc (Q ^^ y)))) (x CASE 0)
  | red_equiv:
      forall P Q R S
             (EQPQ: P =p= Q)
             (RED: Q ==>cp R)
             (EQRS: R =p= S),
        P
      ==>cp
        S
  | red_congr_cut_l:
      forall P Q R A
             (REDL: forall x (NFV: x `notin` fv_proc P `union` fv_proc R),
                      P ^^ x ==>cp R ^^ x),
        ν A → P ‖ Q
      ==>cp
        ν A → R ‖ Q
  | red_congr_cut_r:
      forall P Q R A
             (REDR: forall x (NFV: x `notin` fv_proc Q `union` fv_proc R),
                      Q ^^ x ==>cp R ^^ x),
        ν A → P ‖ Q
      ==>cp
        ν A → P ‖ R
where "P '==>cp' Q" := (proc_red P Q) : cp_scope.

Definition is_cut (P:proc) : Prop :=
  match P with
  | ν _ → _ ‖ _ => True
  | _ => False
  end.


Require Import Ring.

Require Export himp_steps.
Require Export himp_syntax_sugar.

Require Export fun_domains_props.

Require Export proof.
Require Export proof_automation.
Require Import patterns.
Require Import equate_map_reflection.
Require Export himp_claims.

Open Scope string_scope.
Open Scope list_scope.

Set Implicit Arguments.

(* Some lemmas used in proof automation *)

Lemma use_value_heap : forall ret krest store stack frame funs mark
           (Q : Spec kcfg) (P : kcfg -> Prop),
  (forall r' store' heap' funs' mark',
    heap' |= ret r' :* litP frame ->
    store' ~= store ->
    funs' ~= funs ->
    (mark' >= mark)%Z ->
    Q (KCfg (kra r' krest) store' stack heap' funs' mark') P
   ) ->
  (forall k', value_heap ret krest store stack frame funs mark k' -> Q k' P).
Proof. destruct k'. destruct 1. intuition. subst. auto. Qed.

Lemma use_return_heap : forall ret stack frame funs mark
           (Q : Spec kcfg) (P : kcfg -> Prop),
  (forall r' krest store' heap' funs' mark',
    heap' |= ret r' :* litP frame ->
    funs' ~= funs ->
    (mark' >= mark)%Z ->
    Q (KCfg (kra (SReturn r') krest) store' stack heap' funs' mark') P
   ) ->
  (forall k', return_heap ret stack frame funs mark k' -> Q k' P).
Proof. destruct k'. simpl.
let H := fresh in intro H;decompose record H;clear H.
subst. auto.
Qed.

Arguments stk_equiv s1 s2 : simpl nomatch.

(** Register it as an equivalence relations,
    mostly just so we can say "reflexivity" *)
Lemma stk_equiv_refl : forall s, stk_equiv s s.
Proof.
induction s;simpl;auto.
destruct a. simpl. auto using equivRefl.
Qed.

Lemma stk_equiv_sym : forall s1 s2, stk_equiv s1 s2 -> stk_equiv s2 s1.
Proof.
induction s1;destruct s2;simpl;firstorder.
destruct a;trivial.
destruct a,f;firstorder.
Qed.

Lemma stk_equiv_trans : forall s1 s2 s3,
  stk_equiv s1 s2 -> stk_equiv s2 s3 -> stk_equiv s1 s3.
Proof.
induction s1.
destruct s2;intros. assumption. destruct H.

destruct s2.
intros. destruct a. simpl in H. destruct H.
intros. destruct s3. destruct f. simpl in H0. destruct H0.
destruct a.
destruct f.
destruct f0.
simpl in * |- *.
intuition.
congruence.
equate_maps.
eauto.
Qed.

Add Relation (list Frame) stk_equiv
  reflexivity proved by stk_equiv_refl
  symmetry proved by stk_equiv_sym
  transitivity proved by stk_equiv_trans
  as stk_equiv_rel.

(** Now proof automation *)

Create HintDb step_hints discriminated.
Create HintDb done_hints discriminated.
(* f_equal ? *)
Hint Resolve stk_equiv_refl : step_hints done_hints.
Hint Extern 2 (_ ~= _) => equate_maps : step_hints done_hints.
Hint Extern 1 (@eq Z ?l ?r) =>
  (has_evar l;fail 1) || (has_evar r;fail 1) || solve[ring] : step_hints done_hints.
Ltac step_solver := econstructor (solve[simpl;try reflexivity;eauto with step_hints]);idtac.

(* The tactic trans_applies succeed if there is any claim in the set of
   claims being proved whose expectation for the kcell matches the current code
 *)
Ltac trans_applies := econstructor(
  match goal with [|- kcell _ = _] => reflexivity || fail 1 | _ => idtac end).

(* The transitivity tactic tries to apply any claim whose preconditions
   can be met as a transitivity.
   If one applies, it uses the supplied "trans_use_result" tactic to extract hypothesis
   from the conclusion, and get the goal back into the form of a simple
   "dtrans" claim for further proof search.
   (if trans_use result tactic succeeds but doesn't get things into the right form,
   execution will be paused at that point (with the transitivity already taken)
   for the user to do it, because trying to automatically take another step will fail.

   If no claim applies, it then checks for a claim that matches the current
   code but couldn't be used automatically, and pauses for the user
   (assuming that the claim should work, and the prover just failed).

   Otherwise, it returns to the main proof search tactic.
 *)
Ltac trans_solver := econstructor(simpl;
  solve [reflexivity
  |auto with zarith
  |equate_maps]).

Ltac trans_use_result := idtac.

Ltac trans_tac :=
  eapply dtrans;[solve[trans_solver] || (trans_applies;idtac "pausing for trans";fail 1)|]
  ;try trans_use_result. (* if trans_solver succeeded, we commit to the transitivity *)

(*
  We evaluation becomes stuck on a symbolic boolean constant, we need to make
  a case distinction on whether the constant is true or false so evaluation can
  proceed, but we also need to add some new hypothesis(es) recording the fact
  that the symbolic conclusion was true or false, in case the condition tested
  will be important for finishing the proof later.

  This handling might need to be refined a bit to work nicely with the predicates
  needed in a particular specification, but some basic cases corresponding to
  the boolean expressions in the language seems to work pretty well for now.
 *)
Ltac split_bool B :=
  match B with
    | (?x <? ?y)%Z => pose proof Zlt_cases x y;destruct B
    | (?x <=? ?y)%Z => pose proof Zle_cases x y;destruct B
    | (?x =? ?y)%Z =>
        first[replace B with true
          by (symmetry;apply Z.eqb_eq; (auto with zarith || ring || omega))
             |replace B with false
          by (symmetry;apply Z.eqb_neq; (auto with zarith || ring || omega))
             |destruct (Z.eqb_spec x y)]
    | (negb ?B') => split_bool B'
  end.

(*
  The positions where evaluation may be stuck on a symbolic constant
  are purely a function of the language. These could perhaps be computed
  automatically by comparing evaluation rules.
 *)
Ltac split_tac :=
  simpl;
  match goal with
  | [|- trans _ _ {| kcell := kra (KStmt (SIf (BCon ?B) _ _)) _ |} _ ] =>
    split_bool B
  | [|- trans _ _ {| kcell := kra (KExp (BAnd (BCon ?B) _)) _ |} _ ] =>
    split_bool B
  end;idtac.

Ltac done_solver := simpl;repeat split;try reflexivity;auto with done_hints zarith.

Ltac use_cfg_assumptions :=
  match goal with
    | [H : kcell ?v = _ |- _] =>
      is_var v; destruct v; simpl in * |- ;
      rewrite H in * |- *;clear H
    | [H : _ /\ _  |- _ ] => destruct H
    | [H : ?l ~= _ |- ?G] =>
         match G with
         | context [?l] => fail 1
         | _ => is_var l;rewrite H in * |- *;clear H l
         end
   end.

Ltac start_proving :=
  let get_cfg_assumptions := (intros;repeat use_cfg_assumptions) in
  get_cfg_assumptions;apply proved_sound;destruct 1;
  simpl in * |-;get_cfg_assumptions.

(* Pause execution if we ever end up with
   a map equation between two variables,
   or a non-decomposed pattern hypothesis *)
Ltac hyp_check :=
  match goal with
(*
 | [H : ?l ~= ?r |- _] => is_var l; is_var r
   We can end up with irreducible equations between map variables,
   if both are used in the goal, in places where we don't (yet)
   know how to do setoid rewriting by ~=.

   Especially happens with transitivity.

   Maybe just being able to rewrite in the current
   configuration of "trans" would allow eliminating most of these?
 *)
  | [H : (_ :* _) |= _ |- _] => idtac
  | [H : _ |= _ :* _ |- _] => idtac
  | [H : _ |= _ |-> _ |- _] => idtac
  | [H : _ |= emptyP |- _] => idtac
  end;fail 1.

Ltac generic_solver trans_tac step_solver done_solver split_stuck :=
  start_proving;(eapply sstep;[solve [step_solver]|]);
  generic_run trans_tac step_solver done_solver split_stuck.


From Tealeaves.Classes Require Export
  DT.Functor
  Kleisli.DT.Functor.

Import Kleisli.Decorated.Functor.
Import Product.Notations.
Import Comonad.Notations.
Import DT.Functor.Notations.

#[local] Generalizable Variables A B C.

Module Operations.
  Section with_kleisli.

    Context
      (E : Type)
      (T : Type -> Type)
      `{Fmapdt E T}.

    #[export] Instance Dist_Fmapdt: Dist T := fun G _ _ _ A => fmapdt T G (extract (E ×)).
    #[export] Instance Decorate_Fmapdt: Decorate E T := fun A => fmapdt T (fun A => A) (@id ((E ×) A)).

  End with_kleisli.
End Operations.

Import Operations.

Module Instances.

  Section with_functor.

    Context
      (E : Type)
      (T : Type -> Type)
      `{Kleisli.DT.Functor.DecoratedTraversableFunctor E T}.

    Import Kleisli.DT.Functor.Derived.

    Lemma dec_dec : forall (A : Type),
        dec T ∘ dec T = fmap T (cojoin (E ×)) ∘ dec T (A := A).
    Proof.
      intros.
      unfold_ops @Decorate_Fmapdt.
      change_left (fmapd T (@id (E * (E * A))) ∘ fmapd T id).
      rewrite (dfun_fmapd2 E T).
      change_right (fmap T (coμ (prod E)) ∘ fmapd T (@id (E * A))).
      rewrite (fmap_fmapd T).
      fequal. now ext [e a].
    Qed.

    Lemma dec_extract : forall (A : Type),
        fmap T (extract (E ×)) ∘ dec T = @id (T A).
    Proof.
      intros.
      unfold_ops @Decorate_Fmapdt.
      unfold_ops @Fmap_Fmapdt.
      change_left (fmapd T (extract (prod E) ∘ extract (prod E)) ∘ fmapd T (@id (E * A))).
      rewrite (dfun_fmapd2 E T).
      reassociate ->. rewrite (extract_cobind (E ×)).
      apply (dfun_fmapd1 E T).
    Qed.

    Lemma dec_natural : Natural (@dec E T _).
    Proof.
      constructor.
      - typeclasses eauto.
      - typeclasses eauto.
      - intros. unfold_ops @Fmap_compose.
        unfold_ops @Fmap_Fmapdt.
        unfold_ops @Decorate_Fmapdt.
        change
          (fmapd T (fmap (prod E) f ∘ extract (prod E)) ∘ fmapd T id =
             fmapd T id ∘ fmapd T (f ∘ extract (prod E))).
        rewrite (dfun_fmapd2 E T).
        rewrite (dfun_fmapd2 E T).
        reassociate ->. rewrite (extract_cobind (E ×)).
        now rewrite <- (fmap_to_cobind (E ×)).
    Qed.

    #[export] Instance: Classes.Decorated.Functor.DecoratedFunctor E T :=
      {| dfun_dec_natural := dec_natural;
         dfun_dec_dec := dec_dec;
         dfun_dec_extract := dec_extract;
      |}.

  (** *** Traversable functor instance *)
  (******************************************************************************)
  Lemma dist_natural_T : forall (G : Type -> Type) (H2 : Fmap G) (H3 : Pure G) (H4 : Mult G),
      Applicative G -> Natural (@dist T _ G H2 H3 H4).
  Proof.
    intros. constructor.
    - typeclasses eauto.
    - typeclasses eauto.
    - intros.
      unfold_ops @Fmap_compose @Dist_Fmapdt @Fmap_Fmapdt.
      change (@fmapdt E T _ (fun A0 : Type => A0) _ _ _)
        with (@fmapd E T _).
      rewrite (fmapd_fmapdt T G).
      rewrite (fmapdt_fmapd T G).
      rewrite (cokleisli_id_l).
      rewrite (cobind_id (E ×)).
      unfold id. fequal.
      ext [e a]. unfold compose. cbn.
      compose near a on left.
      rewrite (fun_fmap_fmap G).
      reflexivity.
  Qed.

  Lemma dist_morph_T : forall (G1 G2 : Type -> Type) (H2 : Fmap G1) (H3 : Pure G1) (H4 : Mult G1) (H5 : Fmap G2)
                         (H6 : Pure G2) (H7 : Mult G2) (ϕ : forall A : Type, G1 A -> G2 A),
      ApplicativeMorphism G1 G2 ϕ -> forall A : Type, dist T G2 ∘ fmap T (ϕ A) = ϕ (T A) ∘ dist T G1.
  Proof.
    intros. unfold_ops @Dist_Fmapdt @Fmap_Fmapdt.
      change (@fmapdt E T _ (fun A0 : Type => A0) _ _ _)
        with (@fmapd E T _).
      inversion H1.
      rewrite (fmapdt_fmapd T G2).
      rewrite <- (kdtfun_morph E T).
      rewrite (cokleisli_id_l).
      reflexivity.
  Qed.

  Lemma dist_unit_T : forall A : Type,
      dist T (fun A0 : Type => A0) = @id (T A).
  Proof.
    intros. unfold_ops @Dist_Fmapdt.
    now rewrite (kdtfun_fmapdt1 E T).
  Qed.

  Lemma dist_linear_T : forall (G1 : Type -> Type) (H2 : Fmap G1) (H3 : Pure G1) (H4 : Mult G1),
      Applicative G1 ->
      forall (G2 : Type -> Type) (H6 : Fmap G2) (H7 : Pure G2) (H8 : Mult G2),
        Applicative G2 -> forall A : Type, dist T (G1 ∘ G2) (A := A) = fmap G1 (dist T G2) ∘ dist T G1.
  Proof.
    intros. unfold_ops @Dist_Fmapdt.
    rewrite (kdtfun_fmapdt2 E T).
    fequal.
    change (extract (E ×) (A := G1 (G2 A))) with (id (A := G1 (G2 A)) ∘ extract (E ×)).
    rewrite kcompose_dt_32.
    rewrite (fun_fmap_id (E ×)).
    ext [e a]. unfold compose; cbn.
    compose near a.
    rewrite (fun_fmap_fmap G1).
    rewrite (fun_fmap_id G1).
    reflexivity.
  Qed.

  #[export] Instance: Classes.Traversable.Functor.TraversableFunctor T :=
    {| dist_natural := dist_natural_T;
       dist_morph := dist_morph_T;
       dist_unit := dist_unit_T;
       dist_linear := dist_linear_T;
    |}.

  Lemma dtfun_compat_T : forall (G : Type -> Type) (H2 : Fmap G) (H3 : Pure G) (H4 : Mult G),
      Applicative G -> forall A : Type,
        dist T G ∘ fmap T (strength G) ∘ dec (A := G A) T = fmap G (dec T) ∘ dist T G.
  Proof.
    intros. unfold_ops @Dist_Fmapdt @Fmap_Fmapdt @Decorate_Fmapdt.
      change (@fmapdt E T _ (fun A0 : Type => A0) _ _ _)
        with (@fmapd E T _).
      rewrite (fmapd_fmapdt T G).
      rewrite (fmapdt_fmapd T G).
      rewrite (fmapdt_fmapd T G).
      rewrite (cobind_id (E ×)).
      rewrite (fun_fmap_id G).
      fequal. ext [e a].
      reflexivity.
  Qed.

  #[export] Instance: Classes.DT.Functor.DecoratedTraversableFunctor E T :=
    {| dtfun_compat := dtfun_compat_T;
    |}.

  End with_functor.

End Instances.

#[local] Generalizable Variables E T.

Module AlgebraicToKleisli.

  Context
    `{fmapT : Fmap T}
    `{distT : Dist T}
    `{decorateT : Decorate E T}
    `{! DT.Functor.DecoratedTraversableFunctor E T}.

  #[local] Instance fmapdt' : Fmapdt E T := ToKleisli.Fmapdt_distdec E T.

  Definition fmap' : Fmap T := Derived.Fmap_Fmapdt T.
  Definition decorate' : Decorate E T := Operations.Decorate_Fmapdt E T.
  Definition dist' : Dist T := Operations.Dist_Fmapdt E T.

  Goal fmapT = fmap'.
  Proof.
    unfold fmap'. unfold_ops @Derived.Fmap_Fmapdt.
    unfold fmapdt, fmapdt'.
    unfold_ops @ToKleisli.Fmapdt_distdec.
    ext A B f.
    rewrite (dist_unit T).
    rewrite <- (fun_fmap_fmap T).
    reassociate -> on right.
    reassociate -> on right.
    rewrite (dfun_dec_extract E T).
    reflexivity.
  Qed.

  Goal distT = dist'.
  Proof.
    unfold dist'. unfold_ops @Operations.Dist_Fmapdt.
    unfold fmapdt, fmapdt'.
    unfold_ops @ToKleisli.Fmapdt_distdec.
    ext G Hmap Hpure Hmult. ext A.
    reassociate -> on right.
    rewrite (dfun_dec_extract E T).
    reflexivity.
  Qed.

  Goal decorateT = decorate'.
  Proof.
    unfold decorate'. unfold_ops @Operations.Decorate_Fmapdt.
    unfold fmapdt, fmapdt'.
    unfold_ops @ToKleisli.Fmapdt_distdec.
    ext A.
    rewrite (dist_unit T).
    now rewrite (fun_fmap_id T).
  Qed.

End AlgebraicToKleisli.

Module KleisliToAlgebraic.

  Context
    `{fmapdtT : Fmapdt E T}
    `{@Classes.Kleisli.DT.Functor.DecoratedTraversableFunctor E T _}.

  #[local] Instance fmap' : Fmap T := Derived.Fmap_Fmapdt T.
  #[local] Instance dist' : Dist T := Operations.Dist_Fmapdt E T.
  #[local] Instance decorate' : Decorate E T := Operations.Decorate_Fmapdt E T.

  Definition fmapdt' : Fmapdt E T := ToKleisli.Fmapdt_distdec E T.

  Import Derived.

  Goal forall G `{Applicative G}, @fmapdtT G _ _ _ = @fmapdt' G _ _ _.
  Proof.
    intros.
    unfold fmapdt'. unfold_ops @ToKleisli.Fmapdt_distdec.
    unfold fmap, fmap', dist, dist', dec, decorate'.
    ext A B f.
    unfold_ops @Operations.Dist_Fmapdt.
    unfold_ops @Derived.Fmap_Fmapdt.
    unfold_ops @Operations.Decorate_Fmapdt.
    change_right (fmapdt T G (extract (prod E)) ∘
                    fmap T f ∘
                    fmapd T id).
    unfold fmap'.
    change (@Derived.Fmap_Fmapdt T) with (@Derived.Fmap_Fmapdt T).
    rewrite (fmapdt_fmap T G).
    rewrite (fmapdt_fmapd T G).
    fequal. ext [e a]. reflexivity.
  Qed.

End KleisliToAlgebraic.