From ExtLib Require Import
     Structures.Functor
     Structures.Monad.

From ITree Require Import
     Events.State
     CategoryOps.
Import Basics.Monads.

From CTree Require Import
     CTree
     Fold
     Eq
     Eq.Epsilon.

Import SBisimNotations.
Import MonadNotation.
Open Scope monad_scope.

Set Implicit Arguments.

#[global] Instance MonadBr_stateT {S M C} {MM : Monad M} {AM : MonadBr C M}: MonadBr C (stateT S M) :=
  fun b X c s => f <- mbr b c;; ret (s,f).

#[global] Instance MonadTrigger_stateT {E S M} {MM : Monad M} {MT: MonadTrigger E M} :
  MonadTrigger E (stateT S M) :=
  fun _ e s => v <- mtrigger e;; ret (s, v).

Definition fold_state {E C M} S
  {FM : Functor M} {MM : Monad M} {IM : MonadIter M}
  (h : E ~> stateT S M) (g : bool -> C ~> stateT S M) :
  ctree E C ~> stateT S M := fold h g.

Definition interp_state {E C M} S
  {FM : Functor M} {MM : Monad M} {IM : MonadIter M} {BM : MonadBr C M}
  (h : E ~> stateT S M) :
  ctree E C ~> stateT S M := interp h.

Definition refine_state {E C M} S
  {FM : Functor M} {MM : Monad M} {IM : MonadIter M} {TM : MonadTrigger E M}
  (g : bool -> C ~> stateT S M) :
  ctree E C ~> stateT S M := refine g.

#[global] Typeclasses Opaque fold_state interp_state refine_state.

Section State.
  Variable (S : Type).
  Variant stateE : Type -> Type :=
    | Get : stateE S
    | Put : S -> stateE unit.

  Definition get {E C} `{stateE -< E} : ctree E C S := trigger Get.
  Definition put {E C} `{stateE -< E} : S -> ctree E C unit := fun s => trigger (Put s).

  Definition h_state {E C} : stateE ~> stateT S (ctree E C) :=
    fun _ e s =>
      match e with
      | Get => Ret (s, s)
      | Put s' => Ret (s', tt)
      end.

  Definition pure_state {E C} : E ~> stateT S (ctree E C)
    := fun _ e s => Vis e (fun x => Ret (s, x)).

  Definition pure_state_choice {E C} b : C ~> stateT S (ctree E C)
    := fun _ c s => br b c (fun x => Ret (s, x)).

  Definition run_state {E C} `{B1 -< C}
    : ctree (stateE +' E) C ~> stateT S (ctree E C) :=
    fold_state (case_ h_state pure_state) pure_state_choice.

End State.

Ltac break :=
  match goal with
  | v: _ * _ |- _ => destruct v
  end.

(* Stateful handlers [E ~> stateT S (itree F)] and morphisms
   [E ~> state S] define stateful itree morphisms
   [itree E ~> stateT S (itree F)]. *)
Section State.

  Variable (S : Type).
  Context {E F C D : Type -> Type}
          `{B1 -< D}
          {R : Type}
          (h : E ~> stateT S (ctree F D))
          (g : bool -> C ~> stateT S (ctree F D)).

  (** Unfolding of [fold]. *)
  Notation fold_state_ h g t s :=
    (match observe t with
     | RetF r => Ret (s, r)
     | VisF e k => bind (h _ e s) (fun xs => Guard (fold_state h g (k (snd xs)) (fst xs)))
     | BrF b c k => bind (g b _ c s) (fun xs => Guard (fold_state h g (k (snd xs)) (fst xs)))
     end)%function.

  Lemma unfold_fold_state (t : ctree E C R) (s : S) :
    fold_state h g t s ≅ fold_state_ h g t s.
  Proof.
    unfold fold_state, fold, Basics.iter, MonadIter_stateT0, iter, MonadIter_ctree.
    rewrite unfold_iter at 1.
    cbn.
    rewrite bind_bind.
    destruct (observe t); cbn.
    - now repeat (cbn; rewrite ?bind_ret_l).
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
  Qed.

  #[global] Instance equ_fold_state:
    Proper (equ eq ==> eq ==> equ eq)
           (fold_state h g (T := R)).
  Proof.
    unfold Proper, respectful.
    coinduction ? IH; intros * EQ1 * <-.
    rewrite !unfold_fold_state.
    step in EQ1; inv EQ1; auto.
    - cbn. upto_bind_eq.
      constructor; intros; auto.
    - simpl bind. upto_bind_eq.
      constructor; auto.
  Qed.

  Lemma fold_state_ret
        (s : S) (r : R) :
    (fold_state h g (Ret r) s) ≅ (Ret (s, r)).
  Proof.
    rewrite ctree_eta. reflexivity.
  Qed.

  Lemma fold_state_vis {T : Type}
    (e : E T) (k : T -> ctree E C R) (s : S) :
    fold_state h g (Vis e k) s ≅ h e s >>= fun sx => Guard (fold_state h g (k (snd sx)) (fst sx)).
  Proof.
    rewrite unfold_fold_state; reflexivity.
  Qed.

  Lemma fold_state_br {T: Type} `{C -< D}
    (b : bool) (c : C T) (k : T -> ctree E C R) (s : S) :
    fold_state h g (br b c k) s ≅ g b c s >>= fun sx => Guard (fold_state h g (k (snd sx)) (fst sx)).
  Proof.
    rewrite !unfold_fold_state; reflexivity.
  Qed.

  (* TODO move *)
  #[global] Instance equ_Guard:
    forall {E B : Type -> Type} {R : Type} `{B1 -< B},
      Proper (equ eq ==> equ eq) (@Guard E B R _).
  Proof.
    repeat intro.
    unfold Guard; now setoid_rewrite H1.
  Qed.

  Lemma fold_state_trigger (e : E R) (s : S) :
    fold_state h g (CTree.trigger e) s ≅
    h e s >>= fun x => Guard (Ret x).
  Proof.
    unfold CTree.trigger.
    rewrite fold_state_vis; cbn.
    upto_bind_eq; cbn.
    rewrite fold_state_ret.
    now break.
  Qed.

  Lemma fold_state_trigger_sb `{B0 -< D} (e : E R) (s : S)
    : fold_state h g (CTree.trigger e) s ~ h e s.
  Proof.
    unfold CTree.trigger. rewrite fold_state_vis.
    rewrite <- (bind_ret_r (h e s)) at 2.
    cbn.
    upto_bind_eq.
    rewrite sb_guard, fold_state_ret.
    now break.
  Qed.

  (** Unfolding of [interp]. *)
  Notation interp_state_ h t s :=
    (match observe t with
     | RetF r => Ret (s, r)
	   | VisF e k => bind (h _ e s) (fun xs => Guard (interp_state h (k (snd xs)) (fst xs)))
	   | BrF b c k => bind (mbr (M := stateT _ _) b c s) (fun xs => Guard (interp_state h (k (snd xs)) (fst xs)))
     end)%function.

  Lemma unfold_interp_state `{C-<D} (t : ctree E C R) (s : S) :
    interp_state h t s ≅ interp_state_ h t s.
  Proof.
    unfold interp_state, interp, Basics.iter, MonadIter_stateT0, fold, MonadIter_ctree, iter.
    rewrite unfold_iter at 1.
    cbn.
    rewrite bind_bind.
    destruct (observe t); cbn.
    - now repeat (cbn; rewrite ?bind_ret_l).
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
  Qed.

  #[global] Instance equ_interp_state `{C-<D}:
    Proper (equ eq ==> eq ==> equ eq)
           (interp_state (C := C) h (T := R)).
  Proof.
    unfold Proper, respectful.
    coinduction ? IH; intros * EQ1 * <-.
    rewrite !unfold_interp_state.
    step in EQ1; inv EQ1; auto.
    - cbn. upto_bind_eq.
      constructor; intros; auto.
    - simpl bind. upto_bind_eq.
      constructor; auto.
  Qed.

  Lemma interp_state_ret `{C-<D}
        (s : S) (r : R) :
    (interp_state (C := C) h (Ret r) s) ≅ (Ret (s, r)).
  Proof.
    rewrite ctree_eta. reflexivity.
  Qed.

  Lemma interp_state_vis `{C-<D} {T : Type}
    (e : E T) (k : T -> ctree E C R) (s : S) :
    interp_state h (Vis e k) s ≅ h e s >>= fun sx => Guard (interp_state h (k (snd sx)) (fst sx)).
  Proof.
    rewrite unfold_interp_state; reflexivity.
  Qed.

  Lemma interp_state_br {T: Type} `{C -< D}
    (b : bool) (c : C T) (k : T -> ctree E C R) (s : S) :
    interp_state h (Br b c k) s ≅ branch b c >>= fun x => Guard (interp_state h (k x) s).
  Proof.
    rewrite !unfold_interp_state; cbn.
    rewrite bind_bind.
    upto_bind_eq.
    rewrite bind_ret_l.
    reflexivity.
  Qed.

  Lemma interp_state_guard `{B1 -< C} `{C -< D}
    (t : ctree E C R) (s : S) :
    interp_state h (Guard t) s ≅
    brD (▷ branch1: C _) (fun _ => (Guard (interp_state h t s))).
  Proof.
    unfold Guard at 1.
    rewrite interp_state_br.
    cbn.
    unfold branch; rewrite bind_br.
    step; constructor; intros [].
    rewrite bind_ret_l.
    reflexivity.
  Qed.

  (** Unfolding of [refine]. *)
  Notation refine_state_ g t s :=
    (match observe t with
     | RetF r => Ret (s, r)
	   | VisF e k => bind (mtrigger e) (fun x => Guard (refine_state g (k x) s))
	   | BrF b c k => bind (g b _ c s) (fun xs => Guard (refine_state g (k (snd xs)) (fst xs)))
     end)%function.

  Lemma unfold_refine_state `{E-<F} (t : ctree E C R) (s : S) :
    refine_state g t s ≅ refine_state_ g t s.
  Proof.
    unfold refine_state, refine, Basics.iter, MonadIter_stateT0, fold, MonadIter_ctree, iter.
    rewrite unfold_iter at 1.
    cbn.
    rewrite !bind_bind.
    destruct (observe t); cbn.
    - now repeat (cbn; rewrite ?bind_ret_l).
    - rewrite bind_map. cbn.
      rewrite !bind_bind.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
    - rewrite bind_map. cbn.
      upto_bind_eq.
      now cbn; rewrite ?bind_ret_l.
  Qed.

  #[global] Instance equ_refine_state `{E-<F}:
    Proper (equ eq ==> eq ==> equ eq)
           (refine_state (E := E) g (T := R)).
  Proof.
    unfold Proper, respectful.
    coinduction ? IH; intros * EQ1 * <-.
    rewrite !unfold_refine_state.
    step in EQ1; inv EQ1; auto.
    - cbn. upto_bind_eq.
      constructor; intros; auto.
    - simpl bind. upto_bind_eq.
      constructor; auto.
  Qed.

  Lemma refine_state_ret `{E-<F}
        (s : S) (r : R) :
    (refine_state (E := E) g (Ret r) s) ≅ (Ret (s, r)).
  Proof.
    rewrite ctree_eta. reflexivity.
  Qed.

  Lemma refine_state_vis `{E-<F} {T : Type}
    (e : E T) (k : T -> ctree E C R) (s : S) :
    refine_state g (Vis e k) s ≅
      trigger e >>= fun x => Guard (refine_state g (k x) s).
  Proof.
    rewrite unfold_refine_state; reflexivity.
  Qed.

  Lemma refine_state_br {T: Type} `{E -< F}
    (b : bool) (c : C T) (k : T -> ctree E C R) (s : S) :
    refine_state g (Br b c k) s ≅
    g b c s >>= fun xs => Guard (refine_state g (k (snd xs)) (fst xs)).
  Proof.
    rewrite !unfold_refine_state; cbn.
    now upto_bind_eq.
  Qed.

End State.

Section FoldBind.
  Variable (S : Type).
  Context {E F C D : Type -> Type}
    `{B1 -< D}.

  Lemma fold_state_bind
    (h : E ~> stateT S (ctree F D))
    (g : bool -> C ~> stateT S (ctree F D))
    {A B}
    (t : ctree E C A) (k : A -> ctree E C B)
    (s : S) :
    fold_state h g (t >>= k) s
      ≅ fold_state h g t s >>= fun st => fold_state h g (k (snd st)) (fst st).
  Proof.
    revert s t.
    coinduction ? IH; intros.
    rewrite (ctree_eta t).
    cbn.
    rewrite unfold_bind.
    rewrite unfold_fold_state.
    destruct (observe t) eqn:Hobs; cbn.
    - rewrite fold_state_ret. rewrite bind_ret_l. cbn.
      rewrite unfold_fold_state. reflexivity.
    - rewrite fold_state_vis.
      cbn.
      rewrite bind_bind. cbn.
      upto_bind_eq.
      rewrite bind_guard.
      constructor; intros ?; apply IH.
    - rewrite unfold_fold_state.
      cbn.

      rewrite bind_bind.
      upto_bind_eq.
      rewrite bind_guard.
      constructor; intros ?; apply IH.
  Qed.

  Lemma interp_state_bind `{C -< D}
    (h : E ~> stateT S (ctree F D))
    {A B}
    (t : ctree E C A) (k : A -> ctree E C B)
    (s : S) :
    interp_state h (t >>= k) s ≅ interp_state h t s >>= fun xs => interp_state h (k (snd xs)) (fst xs).
  Proof.
    eapply fold_state_bind.
  Qed.

  Lemma refine_state_bind `{E -< F}
    (g : bool -> C ~> stateT S (ctree F D))
    {A B}
    (t : ctree E C A) (k : A -> ctree E C B)
    (s : S) :
    refine_state g (t >>= k) s ≅ refine_state g t s >>= fun xs => refine_state g (k (snd xs)) (fst xs).
  Proof.
    eapply fold_state_bind.
  Qed.

End FoldBind.

(* Stateful handlers [E ~> stateT S (itree F)] and morphisms
   [E ~> state S] define stateful itree morphisms
   [itree E ~> stateT S (itree F)]. *)
From CTree Require Import FoldCTree.

(* TODO MOVE *)
Lemma trans_branch :
  forall {E B : Type -> Type} {X : Type} {H : B0 -< B} {Y : Type}
    [l : label] [t t' : ctree E B X] (c : B Y) (k : Y -> ctree E B X) (x : Y),
    trans l t t' -> k x ≅ t -> trans l (CTree.branch false c >>= k) t'.
Proof.
  intros.
  setoid_rewrite bind_branch.
  eapply trans_brD; eauto.
Qed.

Section transi_state.

  Variable S : Type.
  Context {E F C D : Type -> Type}
    `{CST1 : B0 -< C} {CST2 : C -< D} `{CST3 : B1 -< D} `{CST4 : E -< F}.
  Context {X : Type}.
  Variable (h : E ~> stateT S (ctree F D)).

  Lemma epsilon_interp_state : forall (t t' : ctree E C X) s,
      epsilon t t' ->
      epsilon (interp_state h t s) (interp_state h t' s).
  Proof.
    intros; red in H.
    rewrite (ctree_eta t), (ctree_eta t').
    genobs t ot. genobs t' ot'. clear t Heqot t' Heqot'.
    induction H.
    - constructor. rewrite H. reflexivity.
    - rewrite unfold_interp_state. cbn.
      rewrite bind_bind.
      unfold mbr, MonadBr_ctree, CTree.branch.
      rewrite bind_br.
      eapply EpsilonBr with (x := x).
      rewrite !bind_ret_l.
      cbn.
      eapply EpsilonBr with (x := tt).
      apply IHepsilon_.
  Qed.

  (* transi *)

  Instance foo : B0 -< D.
  intros ? ?; now apply CST2, CST1.
  Defined.

  Inductive transi_state : @label F -> S -> S -> ctree E C X -> ctree E C X -> Prop :=
  | transis_val : forall (x : X) t t' s,
      trans (val x) t t' ->
      transi_state (val (s, x)) s s t t'
  | transis_tau : forall t t' s,
      trans tau t t' ->
      transi_state tau s s t t'
  | transis_obs : forall Y (e : E Y) x l t t' t'' s s',
      trans (obs e x) t t' ->
      epsilon_det t'' (Ret (s', x)) ->
      trans l (h e s) t'' ->
      transi_state l s s' t t'
  | transis_obs0 : forall Y (e : E Y) l x t t' t'' s s' s'',
      trans (obs e x) t t' ->
      transi_state l s' s'' t' t'' ->
      trans (val (s', x)) (h e s) stuckD ->
      transi_state l s s'' t t''
  .

  #[global] Instance transis_equ :
    forall l s s',
      Proper (equ eq ==> equ eq ==> flip impl) (@transi_state l s s').
  Proof.
    cbn. intros.
    revert x x0 H H0. induction H1; intros.
    - apply transis_val. rewrite H0, H1. apply H.
    - apply transis_tau. rewrite H0, H1. apply H.
    - rewrite <- H2, <- H3 in *. eapply transis_obs; eauto.
    - rewrite <- H2 in *. eapply transis_obs0; eauto.
  Qed.

  #[global] Instance transis_equ' :
    forall l s s',
      Proper (equ eq ==> equ eq ==> impl) (@transi_state l s s').
  Proof.
    cbn. intros. rewrite <- H, <- H0. apply H1.
  Qed.

  Lemma transis_brD : forall Y l s s' (t' : ctree E C X) (c : C Y) k x,
      transi_state l s s' (k x) t' ->
      transi_state l s s' (BrD c k) t'.
  Proof.
    intros. inv H.
    - apply transis_val. etrans.
    - apply transis_tau. etrans.
    - eapply transis_obs; etrans.
    - eapply transis_obs0; etrans.
  Qed.

  Lemma epsilon_transi :
    forall l s s' (t t' t'' : ctree E C X),
      epsilon t t' ->
      transi_state l s s' t' t'' ->
      transi_state l s s' t t''.
  Proof.
    intros.
    red in H. rewrite (ctree_eta t). rewrite (ctree_eta t') in H0.
    genobs t ot. genobs t' ot'. clear t Heqot. clear t' Heqot'.
    revert l t'' H0. induction H; intros.
    - rewrite H. apply H0.
    - eapply transis_brD. setoid_rewrite <- ctree_eta in IHepsilon_. apply IHepsilon_. apply H0.
  Qed.

  Lemma transis_sbisim :
    forall l s s' (t t' u : ctree E C X),
      transi_state l s s' t t' ->
      t ~ u ->
      exists u', transi_state l s s' u u' /\ t' ~ u'.
  Proof.
    intros. revert u H0.
    induction H; intros.
    - step in H0. destruct H0 as [? _]. apply H0 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      eexists. split. eapply transis_val; eauto. apply H1.
    - step in H0. destruct H0 as [? _]. apply H0 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      eexists. split. eapply transis_tau; eauto. apply H1.
    - step in H2. destruct H2 as [? _]. apply H2 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      eexists. split. eapply transis_obs; eauto. apply H3.
    - step in H2. destruct H2 as [? _]. apply H2 in H.
      destruct H as (? & ? & ? & ? & ?); subst.
      apply IHtransi_state in H3 as (? & ? & ?).
      eexists; split. eapply transis_obs0; eauto. apply H4.
  Qed.

  Lemma transis_trans (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall l s s' (t t' : ctree E C X),
      transi_state l s s' t t' ->
      exists t0, trans l (interp_state h t s) t0 /\ epsilon_det t0 (interp_state h t' s').
  Proof.
    intros. induction H.
    - exists stuckD. apply trans_val_inv in H as ?.
      apply trans_val_epsilon in H as [].
      eapply epsilon_interp_state in H. rewrite interp_state_ret in H. setoid_rewrite H0.
      setoid_rewrite interp_state_br.
      split.
      eapply epsilon_trans in H; etrans.
      left.
      setoid_rewrite bind_branch.
      step.
      constructor; intros [].

    - exists (Guard (interp_state h t' s)). split; [| eright; eauto; now left ].
      apply trans_tau_epsilon in H as (? & ? & ? & ? & ? & ?).
      eapply epsilon_interp_state in H. setoid_rewrite H0. eapply epsilon_trans; etrans.
      rewrite interp_state_br. setoid_rewrite bind_branch.
      econstructor. reflexivity.
    - exists (x <- t'';; Guard (interp_state h t' s')).
      split.
      2: { eapply epsilon_det_bind_ret_l; eauto. eright; eauto. }
      apply trans_obs_epsilon in H as (? & ? & ?).
      eapply epsilon_interp_state in H. setoid_rewrite H2. eapply epsilon_trans; etrans.
      setoid_rewrite interp_state_vis.
      eapply trans_bind_l with (k := fun sx => Guard (interp_state h (x0 (snd sx)) (fst sx))) in H1.
      setoid_rewrite epsilon_det_bind_ret_l_equ in H1 at 2; eauto. cbn in *. eapply H1.
      { intro. inv H3. apply trans_val_inv in H1. rewrite H1 in H0. inv H0. step in H3. inv H3. step in H4. inv H4. auto using void_unit_elim. }
    - destruct IHtransi_state as (? & ? & ?).
      destruct (Hh Y e s).
      2: { destruct H4. rewrite H4 in H1. apply trans_vis_inv in H1 as (? & ? & ?). step in H1. inv H1. }
      destruct H4. rewrite H4 in H1. inv_trans. subst.
      exists x0. split. 2: auto.
      apply trans_obs_epsilon in H as (? & ? & ?). eapply epsilon_interp_state in H.
      setoid_rewrite interp_state_vis in H. setoid_rewrite H4 in H. setoid_rewrite bind_ret_l in H.
      eapply epsilon_trans; etrans. setoid_rewrite <- H1. etrans.
  Qed.

  Lemma interp_state_ret_inv :
    forall s (t : ctree E C X) r,
      interp_state h t s ≅ Ret r -> t ≅ Ret (snd r) /\ s = fst r.
  Proof.
    intros. setoid_rewrite (ctree_eta t) in H. setoid_rewrite (ctree_eta t).
    destruct (observe t) eqn:?.
    - rewrite interp_state_ret in H. step in H. inv H. split; reflexivity.
    - rewrite interp_state_vis in H. apply ret_equ_bind in H as (? & ? & ?). step in H0. inv H0.
    - rewrite interp_state_br in H. step in H. inv H.
  Qed.

  Lemma trans_interp_state_inv_gen (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall Y l s (k : Y -> ctree E C X) t' (pre : ctree F D Y),
      is_simple pre ->
      trans l (x <- pre;; interp_state h (k x) s) t' ->
      exists t0 s', epsilon_det t' (interp_state h t0 s') /\
                 ((exists l t1 x, trans l pre t1 /\ epsilon_det t1 (Ret x : ctree F D Y) /\ t0 ≅ k x) \/
                    exists (x : Y), trans (val x) pre stuckD /\ trans l (interp_state h (k x) s) t' /\ transi_state l s s' (k x) t0).
  Proof.
    intros * Hpre H.
    do 3 red in H. remember (observe (x <- pre;; interp_state h (k x) s)) as oi.
    setoid_rewrite (ctree_eta t') at 1.
    setoid_rewrite (ctree_eta t') at 2.
    genobs t' ot'. clear t' Heqot'.
    assert (go oi ≅ x <- pre;; interp_state h (k x) s).
    { rewrite Heqoi, <- ctree_eta. reflexivity. } clear Heqoi.
    revert Y s k pre Hpre H0. induction H; intros.
    - symmetry in H0. apply br_equ_bind in H0 as ?.
      destruct H1 as [[] | (? & ? & ?)].
      + rewrite H1 in H0. setoid_rewrite bind_ret_l in H0. setoid_rewrite H1. clear pre Hpre H1.
        rewrite (ctree_eta (k0 x0)) in H0. destruct (observe (k0 x0)) eqn:?.
        * rewrite interp_state_ret in H0. step in H0. inv H0.
        * rewrite interp_state_vis in H0. apply br_equ_bind in H0 as ?. destruct H1 as [[] | (? & ? & ?)].
          --setoid_rewrite H1 in H0. setoid_rewrite bind_ret_l in H0.
            inv_equ.
            rewrite <- EQ in H.
            specialize (IHtrans_ _ (fst x1) (fun (_ : unit) => k1 (snd x1)) (Ret tt)).
            edestruct IHtrans_ as (? & ? & ?).
            { apply is_simple_ret. }
            { rewrite <- ctree_eta. setoid_rewrite bind_ret_l. setoid_rewrite EQ. reflexivity. }
            destruct H0. exists x2, x3. split; auto. right. destruct H2.
            { destruct H2 as (? & ? & ? & ? & ? & ?). inv_trans. subst.
              inv H3. step in H2. inv H2. step in H5. inv H5.
              exfalso; now apply void_unit_elim.
            }
            destruct H2 as (_ & _ & ? & ?). exists x0. split. etrans. split.
            ++setoid_rewrite (ctree_eta (k0 x0)). rewrite Heqc0.
              setoid_rewrite interp_state_vis. setoid_rewrite H1. setoid_rewrite bind_ret_l. apply trans_guard. apply H2.
            ++setoid_rewrite (ctree_eta (k0 x0)). rewrite Heqc0. destruct x1.
              eapply transis_obs0. etrans. 2: { rewrite H1. etrans. } cbn in H3. cbn in *. etrans.
          -- destruct (Hh _ e s).
             destruct H3. rewrite H3 in H1. step in H1. inv H1.
             destruct H3. rewrite H3 in H1. step in H1. inv H1.
        * rewrite interp_state_br in H0.
          setoid_rewrite bind_branch in H0.
          inv_equ.
          specialize (IHtrans_ _ s (fun _ : unit => k1 x) (Guard (Ret tt))).
          edestruct IHtrans_ as (? & ? & ? & ?).
          { apply is_simple_guard_ret. }
          { rewrite <- ctree_eta. setoid_rewrite bind_br. setoid_rewrite bind_ret_l. now rewrite <- EQ. }
          destruct H1.
          { destruct H1 as (? & ? & ? & ? & ? & ?). inv_trans. subst.
            inv H2. step in H1. inv H1. step in H3. inv H3.
            exfalso; now apply void_unit_elim.
          }
          destruct H1 as (? & ? & ? & ?).
          exists x1, x2. split; auto. right. exists x0. split; etrans. split.
          rewrite (ctree_eta (k0 x0)), Heqc0, interp_state_br.
          eapply trans_branch.
          2: reflexivity. apply trans_guard. apply H2.
          rewrite (ctree_eta (k0 x0)), Heqc0. eapply transis_brD; etrans.
      + specialize (IHtrans_ _ s k0 (x0 x)).
        edestruct IHtrans_ as (? & ? & ? & ?).
        { eapply is_simple_brD. red. setoid_rewrite <- H1. apply Hpre. }
        rewrite <- ctree_eta. apply H2. destruct H4 as [(? & ? & ? & ? & ? & ?) | (? & ? & ? & ?)].
        exists (k0 x5), x2. split. { now rewrite H6 in H3. }
        left. eapply trans_brD in H4. 2: reflexivity. rewrite <- H1 in H4. eauto 6.
        * exists x1, x2. split; auto. right. exists x3. rewrite H1. etrans.
    - symmetry in H0. apply br_equ_bind in H0 as ?. destruct H1 as [[] | (? & ? & ?)].
      + rewrite H1 in H0. setoid_rewrite bind_ret_l in H0.
        rewrite (ctree_eta (k0 x0)) in H0. destruct (observe (k0 x0)) eqn:?.
        * rewrite interp_state_ret in H0. step in H0. inv H0.
        * rewrite interp_state_vis in H0. apply br_equ_bind in H0 as ?.
          destruct H2 as [[] | (? & ? & ?)].
          { rewrite H2 in H0. setoid_rewrite bind_ret_l in H0. step in H0. inv H0. }
          pose proof (trans_brS c x1 x). rewrite <- H2 in H4.
          edestruct Hh. { destruct H5. rewrite H5 in H4. inv_trans. }
          destruct H5. rewrite H5 in H4. apply trans_vis_inv in H4 as (? & ? & ?). discriminate.
        * rewrite interp_state_br in H0.
          setoid_rewrite bind_branch in H0.
          inv_equ.
          specialize (EQ x). rewrite H in EQ.
          exists (k1 x), s. symmetry in EQ. split.
          { rewrite <- ctree_eta. rewrite EQ. eapply epsilon_det_tau; auto. }
          right. exists x0. rewrite H1. split; etrans.
          split; setoid_rewrite (ctree_eta (k0 x0)); setoid_rewrite Heqc0.
          { setoid_rewrite interp_state_br. rewrite EQ.
            setoid_rewrite bind_branch.
            econstructor. now rewrite <- ctree_eta. }
          econstructor; etrans.
      + pose proof (trans_brS c x0 x).
        rewrite <- H1 in H3. edestruct Hpre.
        { apply H4 in H3. inv H3. }
        apply H4 in H3 as [].
        specialize (H2 x).
        exists (k0 x1), s. rewrite H in H2. split.
        { rewrite <- ctree_eta, H2. eapply epsilon_det_bind_ret_l; eauto. }
        left. exists tau, (x0 x), x1. split; auto. rewrite H1. etrans.
    - symmetry in H0. apply vis_equ_bind in H0 as ?. destruct H1 as [[] | (? & ? & ?)].
      + rewrite H1 in H0. setoid_rewrite bind_ret_l in H0.
        rewrite (ctree_eta (k0 x0)) in H0. destruct (observe (k0 x0)) eqn:?.
        * rewrite interp_state_ret in H0. step in H0. inv H0.
        * rewrite interp_state_vis in H0. apply vis_equ_bind in H0 as ?.
          destruct H2 as [[] | (? & ? & ?)].
          { rewrite H2 in H0. setoid_rewrite bind_ret_l in H0. step in H0. inv H0. }
          pose proof (trans_vis e x x1). rewrite <- H2 in H4.
          edestruct Hh. { destruct H5. rewrite H5 in H4. inv H4. }
          destruct H5. rewrite H5 in H4.
          specialize (H3 x). rewrite H5 in H2.
          inv_equ.
          rewrite <- EQ in *. rewrite bind_ret_l in H3.
          exists (k1 (snd x)), (fst x).
          rewrite H in H3. split. { rewrite <- ctree_eta, H3. eright; eauto. }
          right.
          exists x0. rewrite H1. split; etrans.
          split; setoid_rewrite (ctree_eta (k0 x0)); setoid_rewrite Heqc.
          { setoid_rewrite interp_state_vis. rewrite H5. setoid_rewrite bind_vis.
            econstructor. rewrite bind_ret_l. rewrite <- H3, <- ctree_eta. reflexivity. }
          eapply transis_obs; etrans. rewrite H5. destruct x. etrans.
        * rewrite interp_state_br in H0. step in H0. inv H0.
      + pose proof (trans_vis e x x0).
        rewrite <- H1 in H3. edestruct Hpre.
        { apply H4 in H3. inv H3. }
        apply H4 in H3 as [].
        specialize (H2 x).
        exists (k0 x1), s. rewrite H in H2. split.
        { rewrite <- ctree_eta, H2. eapply epsilon_det_bind_ret_l; eauto. }
        left. exists (obs e x), (x0 x), x1. split; auto. rewrite H1. etrans.
    - exists stuckD, (fst r). split.
      + left. unfold stuck. rewrite interp_state_br.
        rewrite !br0_always_stuck.
        setoid_rewrite bind_branch.
        step.
        constructor; intros [].
      + right. symmetry in H0. apply ret_equ_bind in H0 as (? & ? & ?).
        exists x. rewrite H. split; etrans. split.
        rewrite H0. rewrite br0_always_stuck. etrans.
        apply interp_state_ret_inv in H0 as []. subst. rewrite H0. destruct r. cbn. apply transis_val. econstructor; etrans.
  Qed.

  Lemma trans_interp_state_inv (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall l (t : ctree E C X) t' s,
      trans l (interp_state h t s) t' ->
      exists l t0 s', epsilon_det t' (interp_state h t0 s') /\ transi_state l s s' t t0.
  Proof.
    intros.
    assert (trans l (Guard (Ret tt);; interp_state h t s) t').
    { cbn. etrans. }
    eapply trans_interp_state_inv_gen in H0; eauto. destruct H0 as (? & ? & ? & ?).
    destruct H1 as [(? & ? & ? & ? & ? & ?) | (? & ? & ? & ?)].
    - inv_trans. subst. inv H2. step in H1. inv H1. step in H3. inv H3.
      exfalso; now apply void_unit_elim.
    - inv_trans. subst. eauto.
    - left. intros. inv_trans. subst. constructor.
  Qed.

(** The main theorem stating that fold_state preserves sbisim. *)

  Theorem interp_state_sbisim_gen {Y} (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    forall s (k k' : Y -> ctree E C X) (pre pre' : ctree F D Y),
      (forall x, sbisim eq (k x) (k' x)) ->
      pre ≅ pre' ->
      vsimple pre ->
      sbisim eq (a <- pre;; Guard (interp_state h (k a) s)) (a <- pre';; Guard (interp_state h (k' a) s)).
  Proof.
    revert Y. coinduction R CH.
    (* We would like to use a symmetry argument here, as is done in the 0.1 branch *)
    symmetric using idtac.
    { intros. apply H. now symmetry. now symmetry. red. now setoid_rewrite <- H1. }
    assert (CH' : forall (t t' : ctree E C X) s, t ~ t' -> st eq R (interp_state h t s) (interp_state h t' s)).
    {
      intros.
      assert (st eq R (a <- Ret tt;; Guard (interp_state h ((fun _ => t) a) s))
                (a <- Ret tt;; Guard (interp_state h ((fun _ => t') a) s))).
      { apply CH; eauto. left; eauto. }
      setoid_rewrite bind_ret_l in H0.
      rewrite !sb_guard in H0.
      apply H0.
    }
    intros. setoid_rewrite <- H0. clear pre' H0. cbn.
    cbn; intros.
    copy H0. rewrite bind_guard_r in H0.
    eapply trans_interp_state_inv_gen in H0 as (? & ? & ? & ?); auto.
    2: { destruct H1 as [[] | []]; rewrite H1.
         rewrite bind_ret_l. apply is_simple_guard_ret.
         rewrite bind_trigger. right. intros. inv_trans. subst.
         exists x0. rewrite EQ. eright. left. reflexivity. reflexivity.
    }
    destruct H2.
    + destruct H2 as (? & ? & ? & ? & ? & ?). rewrite H4 in H0. clear x H4.
      destruct H1 as [[] | []].
      * rewrite H1, bind_ret_l in H2. rewrite H1, bind_ret_l in cpy. inv_trans. subst.
        inv H3. step in H2. inv H2. step in H4. inv H4.
        exfalso; now apply void_unit_elim.
      * rewrite H1 in *. rewrite bind_trigger in H2. apply trans_vis_inv in H2 as (? & ? & ?). subst.
        rewrite H2 in H3. inv H3. step in H4. inv H4.
        apply equ_br_invE in H5 as [_ ?].
        rewrite <- H3 in H4; auto. inv H4.
        2: { step in H6. inv H6. }
        step in H5. inv H5.
        rewrite bind_trigger in cpy. apply trans_vis_inv in cpy. destruct cpy as (? & ? & ?). subst.
        eexists. exists (Guard (interp_state h (k' x1) s)). rewrite H1. rewrite bind_trigger. split.
        now constructor.
        split; auto.
        rewrite H4, !sb_guard. apply CH'. apply H.
    + destruct H2 as (? & ? & ? & ?).
      destruct H1 as [[] | []].
      2: { rewrite H1 in H2. setoid_rewrite bind_trigger in H2. inv_trans. }
      rewrite H1 in *. rewrite bind_ret_l in H2. inv_trans. subst. clear EQ.
      eapply transis_sbisim in H4; eauto. destruct H4 as (? & ? & ?).
      apply transis_trans in H2 as (? & ? & ?); auto.
      eexists; exists x3. rewrite H1, bind_ret_l. split.
      etrans.
      assert (st eq R (interp_state h x x0) (interp_state h x1 x0)).
      { apply CH'. apply H4. }
      split; auto.
      rewrite sbisim_epsilon_det. 2: apply H0.
      apply sbisim_epsilon_det in H5; rewrite H5.
      apply H6.
  Qed.

  #[global] Instance interp_state_sbisim (Hh : forall X (e : _ X) s, vsimple (h e s)) :
    Proper (sbisim eq ==> eq ==> sbisim eq) (interp_state h (C := C) (T := X)).
  Proof.
    cbn. intros. subst.
    assert (a <- Ret tt;; Guard (interp_state h ((fun _ => x) a) y0) ~
                           a <- Ret tt;; Guard (interp_state h ((fun _ => y) a) y0)).
    apply interp_state_sbisim_gen; auto.
    red; eauto.
    setoid_rewrite bind_ret_l in H0. rewrite !sb_guard in H0. apply H0.
  Qed.

End transi_state.

Arguments get {S E C _}.
Arguments put {S E C _}.
Arguments run_state {S E C} [_] _ _.
Arguments fold_state {E C M S FM MM IM} h g [T].
Arguments interp_state {E C M S FM MM IM BM} h [T].
Arguments refine_state {E C M S FM MM IM TM} g [T].


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q C0 : Universe, ((wd_ C0 A /\ (wd_ A B /\ (wd_ C0 B /\ (wd_ C D /\ (wd_ D P /\ (wd_ C P /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ P C0 /\ (wd_ C A /\ (wd_ C B /\ (wd_ D A /\ (wd_ D B /\ (col_ A B P /\ (col_ C D C0 /\ (col_ C0 P A /\ col_ C0 P B)))))))))))))))) -> col_ C0 A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Coq Require Import ZArith.
From Coq Require Import List. Import ListNotations.
From ConCert.Utils Require Import Extras.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Examples.FA2 Require Import FA2LegacyInterface.

Section FA2Token.
  Context {BaseTypes : ChainBase}.
  Set Primitive Projections.
  Set Nonrecursive Elimination Schemes.
  Open Scope N_scope.

  (* Any contract that wants to receive callback messages from the FA2 contract
    should have this type as its Msg type. The contract may have other endpoints,
    as composed in the 'other_msg' constructor *)
  Inductive FA2ReceiverMsg {Msg' : Type} :=
  | receive_balance_of_param : list balance_of_response -> FA2ReceiverMsg
  | receive_total_supply_param : list total_supply_response -> FA2ReceiverMsg
  | receive_metadata_callback : list token_metadata -> FA2ReceiverMsg
  | receive_is_operator : is_operator_response -> FA2ReceiverMsg
  | receive_permissions_descriptor : permissions_descriptor -> FA2ReceiverMsg
  | other_msg : Msg' -> FA2ReceiverMsg.

  (* Transfer hook contracts of the FA2 Contract should use this type as their Msg type *)
  Inductive FA2TransferHook {Msg : Type} :=
  | transfer_hook : transfer_descriptor_param -> FA2TransferHook
  | hook_other_msg : Msg -> FA2TransferHook.

  (* The FA2 Endpoints. *)
  Inductive Msg :=
  | msg_transfer : list transfer -> Msg
  | msg_set_transfer_hook : set_hook_param -> Msg
  | msg_receive_hook_transfer : transfer_descriptor_param -> Msg
  | msg_balance_of : balance_of_param -> Msg
  | msg_total_supply : total_supply_param -> Msg
  | msg_token_metadata : token_metadata_param -> Msg
  | msg_permissions_descriptor : callback permissions_descriptor -> Msg
  | msg_update_operators : list update_operator -> Msg
  | msg_is_operator : is_operator_param -> Msg
  | msg_create_tokens : token_id -> Msg.

  Record TokenLedger :=
    build_token_ledger {
      fungible : bool;
      balances : FMap Address N
    }.

  Record State :=
    build_state {
      fa2_owner          : Address;
      assets             : FMap token_id TokenLedger;
      operators          : FMap Address (FMap Address operator_tokens);
      permission_policy  : permissions_descriptor;
      tokens             : FMap token_id token_metadata;
      transfer_hook_addr : option Address;
    }.

  Record Setup :=
    build_setup {
      setup_total_supply        : list (token_id * N);
      setup_tokens              : FMap token_id token_metadata;
      initial_permission_policy : permissions_descriptor;
      transfer_hook_addr_       : option Address;
    }.

  Definition Error : Type := nat.
  Definition default_error : Error := 1%nat.

  MetaCoq Run (make_setters TokenLedger).
  MetaCoq Run (make_setters State).
  MetaCoq Run (make_setters Setup).

  Section Serialization.

    Global Instance setup_serializable : Serializable Setup :=
      Derive Serializable Setup_rect <build_setup>.

    Global Instance FA2ReceiverMsg_serializable {Msg : Type}
                                                `{Serializable Msg}
                                                : Serializable (@FA2ReceiverMsg Msg) :=
      Derive Serializable (@FA2ReceiverMsg_rect Msg) <
        (@receive_balance_of_param Msg),
        (@receive_total_supply_param Msg),
        (@receive_metadata_callback Msg),
        (@receive_is_operator Msg),
        (@receive_permissions_descriptor Msg),
        (@other_msg Msg)>.

    Global Instance FA2TransferHook_serializable {Msg : Type}
                                                `{Serializable Msg}
                                                : Serializable (@FA2TransferHook Msg) :=
      Derive Serializable (@FA2TransferHook_rect Msg) <
        (@transfer_hook Msg),
        (@hook_other_msg Msg)>.

    Global Instance callback_permissions_descriptor_serializable : Serializable (callback permissions_descriptor) :=
      callback_serializable.

    Global Instance msg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <
        msg_transfer,
        msg_set_transfer_hook,
        msg_receive_hook_transfer,
        msg_balance_of,
        msg_total_supply,
        msg_token_metadata,
        msg_permissions_descriptor,
        msg_update_operators,
        msg_is_operator,
        msg_create_tokens>.

    Global Instance TokenLedger_serializable : Serializable TokenLedger :=
      Derive Serializable TokenLedger_rect <build_token_ledger>.

    Global Instance state_serializable : Serializable State :=
      Derive Serializable State_rect <build_state>.

  End Serialization.

  Definition address_balance (token_id : token_id)
                             (addr : Address)
                             (state : State)
                             : N :=
    match FMap.find token_id state.(assets) with
    | Some ledger => with_default 0%N (FMap.find addr ledger.(balances))
    | None => 0%N
    end.

  Definition address_has_sufficient_asset_balance (token_id : token_id)
                                                  (owner : Address)
                                                  (transaction_amount : N)
                                                  (state : State)
                                                  : result unit Error :=
    if transaction_amount <=? address_balance token_id owner state
    then Ok tt
    else Err default_error.

  Definition policy_disallows_operator_transfer (policy : permissions_descriptor) : bool :=
    match policy.(descr_operator) with
    | operator_transfer_permitted => false
    | operator_transfer_denied => true
    end.

  Definition policy_disallows_self_transfer (policy : permissions_descriptor) : bool :=
    match policy.(descr_self) with
    | self_transfer_permitted => false
    | self_transfer_denied => true
    end.

  Definition get_owner_operator_tokens (owner operator : Address)
                                       (state : State)
                                       : option operator_tokens :=
    do operator_tokens <- FMap.find owner state.(operators) ;
    FMap.find operator operator_tokens.

  (* Executes a single transfer by returning a new state, if successful. *)
  Definition try_single_transfer (caller : Address)
                                 (params : transfer)
                                 (state : State)
                                 : result State Error :=
    do _ <- throwIf (negb (1 =? N.of_nat (length params.(txs)))) default_error;
    do transfer_dst <- result_of_option (hd_error (params.(txs))) default_error;
    do ledger <- result_of_option (FMap.find transfer_dst.(dst_token_id) state.(assets)) default_error;
    let current_owner_balance := address_balance transfer_dst.(dst_token_id) params.(from_) state in
    let new_balances := FMap.add params.(from_) (current_owner_balance - transfer_dst.(amount)) ledger.(balances) in
    let new_balances := FMap.partial_alter (fun balance =>
      Some ((with_default 0 balance) + transfer_dst.(amount))) transfer_dst.(to_) new_balances in
    let new_ledger := ledger<|balances := new_balances|> in
      Ok (state<|assets ::= FMap.add transfer_dst.(dst_token_id) new_ledger|>).

  Definition transfer_check_permissions (caller : Address)
                                        (params : transfer)
                                        (policy : permissions_descriptor)
                                        (state : State)
                                        : result unit Error :=
    do _ <- throwIf (negb (1 =? N.of_nat (length params.(txs)))) default_error;
    do transfer_dst <- result_of_option (hd_error (params.(txs))) default_error;
    (* check for sufficient permissions *)
    do _ <- address_has_sufficient_asset_balance transfer_dst.(dst_token_id) params.(from_) transfer_dst.(amount) state ;
    (* only allow transfers of known token_ids *)
    do _ <- result_of_option (FMap.find transfer_dst.(dst_token_id) state.(tokens)) default_error;
    (* if caller is owner of transfer, then check policy if self_transfer is allowed *)
    if (address_eqb caller params.(from_))
    then
      throwIf (policy_disallows_self_transfer policy) default_error
    else
      (* check if policy allows operator transfer *)
      do _ <- throwIf (policy_disallows_operator_transfer policy) default_error;
      do operators_map <- result_of_option (FMap.find params.(from_) state.(operators)) default_error;
      do op_tokens <- result_of_option (FMap.find caller operators_map) default_error;
      (* check if operator has permission to transfer the given token_id type *)
      match op_tokens with
      | all_tokens => Ok tt
      | some_tokens token_ids => if (existsb (fun id => id =? transfer_dst.(dst_token_id)) token_ids)
                                then Ok tt
                                else Err default_error
      end.

  (* Executes all transfers in a batch operation and returns a new state if *all*
    transfers were successful. *)
  Definition try_transfer (caller : Address)
                          (transfers : list transfer)
                          (state : State)
                          : result State Error :=
    let check_transfer_iterator state_opt params :=
      do state <- state_opt ;
      do _ <- transfer_check_permissions caller params state.(permission_policy) state;
      try_single_transfer caller params state in
    (* returns the new state if all transfers *can* succeed, otherwise returns None *)
    fold_left check_transfer_iterator transfers (Ok state).

  (* Forwards the transfer to the hook to approve/reject *)
  Definition call_transfer_hook (caller : Address)
                                (caddr : Address)
                                (transfer_hook_addr : Address)
                                (transfers : list transfer)
                                (state : State)
                                : ActionBody :=
    let mk_transfer_dst_descr tr_dst := {|
      transfer_dst_descr_to_ := Some tr_dst.(to_);
      transfer_dst_descr_token_id := tr_dst.(dst_token_id);
      transfer_dst_descr_amount := tr_dst.(amount)
      |} in
    let mk_transfer_descr tr := {|
      transfer_descr_from_ := Some (tr.(from_));
      transfer_descr_txs := map mk_transfer_dst_descr tr.(txs)
      |} in
    let transfer_decr_param := {|
      transfer_descr_fa2 := caddr;
      transfer_descr_batch := map mk_transfer_descr transfers;
      transfer_descr_operator := caller;
      |} in
    act_call transfer_hook_addr 0%Z (serialize (transfer_hook transfer_decr_param)).

  Definition group_transfer_descriptors (params : list transfer_descriptor)
                                        : list (list transfer_descriptor) :=
    let trx_map := fold_right (fun trx trx_map =>
    match FMap.find trx.(transfer_descr_from_) trx_map with
    | Some trxs => FMap.add trx.(transfer_descr_from_) (trx :: trxs) trx_map
    | None => FMap.add trx.(transfer_descr_from_) [trx] trx_map
    end
    ) FMap.empty params in
    FMap.values trx_map.

  (* Handles incoming transfers:
    - if the contract has a transfer_hook, then it uses the hook
    - otherwise it checks & performs the transfers now *)
  Definition handle_transfer (caller : Address)
                             (caddr : Address)
                             (transfers : list transfer)
                             (state : State)
                             : result (State * list ActionBody) Error :=
    match state.(transfer_hook_addr) with
    (* send call transfer hook (approved transfers will be received in the msg_receive_hook_transfer endpoint) *)
    | Some transfer_hook_addr =>
      let call_hook_act := call_transfer_hook caller caddr transfer_hook_addr transfers state in
      Ok (state, [call_hook_act])
    (* if no hook is attached, send transfer message to self, and notify senders of transfer *)
    | None =>
    let mk_transfer_dst_descr tr_dst := {|
      transfer_dst_descr_to_ := Some tr_dst.(to_);
      transfer_dst_descr_token_id := tr_dst.(dst_token_id);
      transfer_dst_descr_amount := tr_dst.(amount)
      |} in
    let mk_transfer_descr tr := {|
      transfer_descr_from_ := Some (tr.(from_));
      transfer_descr_txs := map mk_transfer_dst_descr tr.(txs)
      |} in
      let mk_transfer_decr_param batch := {|
        transfer_descr_fa2 := caddr;
        transfer_descr_batch := batch;
        transfer_descr_operator := caller;
      |} in
      let transfer_decr_param := mk_transfer_decr_param (map mk_transfer_descr transfers) in
      let is_from_contract descriptors := existsb (fun descr =>
        match descr.(transfer_descr_from_) with
        | Some addr => address_is_contract addr
        | None => false
        end) descriptors in
      let trx_descriptors_grouped := (group_transfer_descriptors (map mk_transfer_descr transfers)) in
      let self_transfer_act := act_call caddr 0%Z (serialize (msg_receive_hook_transfer transfer_decr_param)) in

      let mk_sender_hook_act trx :=
        match trx.(sender_callback_addr) with
        | Some callback_addr =>
          let descr := mk_transfer_decr_param [mk_transfer_descr trx] in
          Some (act_call callback_addr 0%Z (@serialize fa2_token_sender _ (tokens_sent descr)))
        | None => None
        end in
      let sender_hook_acts := fold_right (fun act_opt acc =>
        match act_opt with
        | Some act => act :: acc
        | None => acc
        end
      ) [] (map mk_sender_hook_act transfers) in
      (* If no sender callbacks need to be made, just perform transfers now *)
      if Nat.eqb (length sender_hook_acts) 0%nat then
        (try_transfer caller transfers state) >>= (fun new_state => Ok (new_state, []))
      else
        (* Notice that sender hooks are invoked before the transfer *)
        Ok (state, sender_hook_acts ++ [self_transfer_act])
    end.

  Open Scope bool_scope.
  Definition mk_transfer_destination_from_descr (dst_descr: transfer_destination_descriptor)
                                                : option transfer_destination :=
    do to <- dst_descr.(transfer_dst_descr_to_) ;
    Some {|
      to_ := to;
      dst_token_id := dst_descr.(transfer_dst_descr_token_id);
      amount := dst_descr.(transfer_dst_descr_amount)
    |}.

  Definition mk_transfer_from_descr (descr: transfer_descriptor) : option transfer :=
    do from <- descr.(transfer_descr_from_) ;
    let iter := (fun dst_descr acc_opt =>
      do acc <- acc_opt;
      do tx_dst <- mk_transfer_destination_from_descr dst_descr;
      Some (tx_dst :: acc)) in
    do txs_list <- fold_right iter (Some []) descr.(transfer_descr_txs);
    Some {|
      from_ := from;
      txs := txs_list;
      sender_callback_addr := None
    |}.

  Definition handle_transfer_hook_receive (caller : Address)
                                          (param : transfer_descriptor_param)
                                          (self_addr : Address)
                                          (state : State)
                                          : result State Error :=
    (* check if caller is current hook or self - only hook or self is allowed to call this endpoint *)
    do _ <- if (match state.(transfer_hook_addr) with
            | Some hook_addr => ((address_eqb caller hook_addr) || (address_eqb caller self_addr))
            | None => (address_eqb caller self_addr)
            end)
            then Ok tt
            else Err default_error;
    let iter := (fun descr acc_opt =>
      do acc <- acc_opt;
      do trans <- result_of_option (mk_transfer_from_descr descr) default_error;
      Ok (trans :: acc)) in
    do transfers <- fold_right iter (Ok []) param.(transfer_descr_batch) ;
    try_transfer param.(transfer_descr_operator) transfers state.
  Close Scope bool_scope.

  (* create a 'balance_of' action to send to the callback address *)
  Definition get_balance_of_callback (param : balance_of_param)
                                     (state : State)
                                     : ActionBody :=
    let bal_req_iterator (bal_req : balance_of_request) :=
      let owner_bal := address_balance bal_req.(bal_req_token_id) bal_req.(owner) state in
      Build_balance_of_response bal_req owner_bal in
    let responses := map bal_req_iterator param.(bal_requests) in
    let response_msg := serialize (receive_balance_of_param responses) in
    act_call param.(bal_callback) 0%Z response_msg.

  (* create a 'total_supply' action to send to the callback address *)
  Definition get_total_supply_callback (param : total_supply_param)
                                       (state : State)
                                       : ActionBody :=
    let token_id_balance (token_id : token_id) : N :=
      match FMap.find token_id state.(assets) with
      | Some ledger => fold_left N.add (FMap.values ledger.(balances)) 0%N
      | None => 0%N
      end in
    let mk_response (token_id : token_id) : total_supply_response :=
      Build_total_supply_response token_id (token_id_balance token_id) in
    let responses := map mk_response param.(supply_param_token_ids) in
    let response_msg := serialize (receive_total_supply_param responses) in
    act_call param.(supply_param_callback) 0%Z response_msg.

  (* Updates operators if policy allows it, and if the caller is the owner. *)
  Definition update_operators (caller : Address)
                              (updates : list update_operator)
                              (state : State)
                              : result State Error :=
    (* If policy doesn't allow operator transfer, then this operation fails *)
    do _ <- throwIf (policy_disallows_operator_transfer state.(permission_policy)) default_error;
    let exec_add params (state_opt : result State Error) : result State Error :=
      do state_ <- state_opt ;
      (* only the owner of the token is allowed to update their operators *)
      if (address_neqb caller params.(op_param_owner))
      then Err default_error
      else
        let operator_tokens : FMap Address operator_tokens :=
          with_default FMap.empty (FMap.find caller state_.(operators)) in
        (* Add new operator *)
        let operator_tokens :=
          FMap.add params.(op_param_operator) params.(op_param_tokens) operator_tokens in
        Ok (state_<| operators ::= FMap.add caller operator_tokens |>) in
    let exec_update state_ op := match op with
                                | add_operator params => exec_add params state_
                                | remove_operator params => exec_add params state_
                                end in
    (fold_left exec_update updates (Ok state)).

  Definition operator_tokens_eqb (a b : operator_tokens) : bool :=
    match (a, b) with
    | (all_tokens, all_tokens) => true
    | (some_tokens a', some_tokens b') =>
      let fix my_list_eqb l1 l2 :=
        match (l1, l2) with
        | (x :: l1, y :: l2) => if x =? y
                                then my_list_eqb l1 l2
                                else false
        | ([], []) => true
        | _ => false
        end in my_list_eqb a' b'
    | _ => false
    end.

  Definition get_is_operator_response_callback (params : is_operator_param)
                                               (state : State)
                                               : result (State * list ActionBody) Error :=
    (* if policy doesn't allow operator transfers, then this operation will fail *)
    do _ <- throwIf (policy_disallows_operator_transfer state.(permission_policy)) default_error;
    let operator_params := params.(is_operator_operator) in
    let operator_tokens_opt := get_owner_operator_tokens operator_params.(op_param_owner)
                                                         operator_params.(op_param_operator) in
    let is_operator_result := match operator_tokens_opt state with
                              (* check if operator_tokens from the params and from the state are equal *)
                              | Some op_tokens => operator_tokens_eqb op_tokens operator_params.(op_param_tokens)
                              | None => false
                              end in
    let response : is_operator_response := {| operator := operator_params; is_operator := is_operator_result |} in
    let act := act_call params.(is_operator_callback) 0%Z (serialize (receive_is_operator response)) in
      Ok (state, [act]).

  Definition get_permissions_descriptor_callback (caller : Address)
                                                 (state : State)
                                                 : ActionBody :=
    let response := serialize (receive_permissions_descriptor state.(permission_policy)) in
    act_call caller 0%Z response.

  Definition try_set_transfer_hook (caller : Address)
                                   (params : set_hook_param)
                                   (state : State)
                                   : result State Error :=
    (* only owner can set transfer hook *)
    do _ <- throwIf (address_neqb caller state.(fa2_owner)) default_error;
    Ok (state<| transfer_hook_addr := Some params.(hook_addr)|>
              <| permission_policy := params.(hook_permissions_descriptor) |>).

  Definition get_token_metadata_callback (param : token_metadata_param)
                                         (state : State)
                                         : ActionBody :=
    let token_ids := param.(metadata_token_ids) in
    let state_tokens := state.(tokens) in
    let metadata_list : list token_metadata := fold_right (fun id acc =>
        match FMap.find id state_tokens with
        | Some metadata => metadata :: acc
        | None => acc
        end
      ) [] token_ids in
    let response := serialize (receive_metadata_callback metadata_list) in
    act_call param.(metadata_callback) 0%Z response.

  (* creates some tokens with a fixed exchange ratio of 1:100 *)
  Definition try_create_tokens (caller : Address)
                               (amount : Amount)
                               (tokenid : token_id)
                               (state : State)
                               : result State Error :=
    let exchange_rate := 100%Z in
    do ledger <- result_of_option (FMap.find tokenid state.(assets)) default_error;
    (* only allow amounts > 0 *)
    do _ <- throwIf (Z.leb amount 0%Z) default_error;
    let amount := Z.to_N (amount * exchange_rate) in
    let caller_bal := with_default 0 (FMap.find caller ledger.(balances)) in
    let new_balances := FMap.add caller (caller_bal + amount) ledger.(balances) in
    let new_ledger := ledger<| balances := new_balances |> in
    Ok (state<| assets ::= FMap.add tokenid new_ledger |>).

  Open Scope Z_scope.
  Definition receive (chain : Chain)
                     (ctx : ContractCallContext)
                     (state : State)
                     (maybe_msg : option Msg)
                     : result (State * list ActionBody) Error :=
    let sender := ctx.(ctx_from) in
    let caddr := ctx.(ctx_contract_address) in
    let without_statechange acts := Ok (state, acts) in
    (* Only 'create_token' messages are allowed to carry money *)
    if ctx.(ctx_amount) >? 0
    then match maybe_msg with
    | Some (msg_create_tokens tokenid) =>
        without_actions (try_create_tokens sender ctx.(ctx_amount) tokenid state)
    | _ => Err default_error
    end
    else match maybe_msg with
    | Some (msg_transfer transfers) =>
        handle_transfer sender caddr transfers state
    | Some (msg_receive_hook_transfer param) =>
        without_actions (handle_transfer_hook_receive sender param caddr state)
    | Some (msg_is_operator params) =>
        get_is_operator_response_callback params state
    | Some (msg_balance_of params) =>
        without_statechange [get_balance_of_callback params state]
    | Some (msg_total_supply params) =>
        without_statechange [get_total_supply_callback params state]
    | Some (msg_permissions_descriptor _) =>
        without_statechange [get_permissions_descriptor_callback sender state]
    | Some (msg_token_metadata param) =>
        without_statechange [get_token_metadata_callback param state]
    | Some (msg_update_operators updates) =>
        without_actions (update_operators sender updates state)
    | Some (msg_set_transfer_hook params) =>
        without_actions (try_set_transfer_hook sender params state)
    | _ => Err default_error
    end.

  Definition map_values_FMap {A B C: Type}
                            `{countable.Countable A}
                            `{base.EqDecision A}
                             (f : B -> C)
                             (m : FMap A B)
                             : FMap A C :=
    let l := FMap.elements m in
    let mapped_l := List.map (fun '(a, b) => (a, f b)) l in
    FMap.of_list mapped_l.

  Definition init (chain : Chain)
                  (ctx : ContractCallContext)
                  (setup : Setup)
                  : result State Error :=
    (* setup ledgers with empty balance for each initial token id *)
    let assets' := map_values_FMap (fun _ =>
      build_token_ledger false FMap.empty
    ) setup.(setup_tokens) in
    Ok {| permission_policy := setup.(initial_permission_policy);
            fa2_owner := ctx.(ctx_from);
            transfer_hook_addr := setup.(transfer_hook_addr_);
            assets := assets';
            operators := FMap.empty;
            tokens := setup.(setup_tokens)
      |}.

  Definition contract : Contract Setup Msg State Error :=
    build_contract init receive.

End FA2Token.


Require Export VST.concurrency.paco.src.paconotation VST.concurrency.paco.src.pacotac VST.concurrency.paco.src.pacodef VST.concurrency.paco.src.pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 6
*)

(** 1 Mutual Coinduction *)

Section Arg6_1.

Definition monotone6 T0 T1 T2 T3 T4 T5 (gf: rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5) :=
  forall x0 x1 x2 x3 x4 x5 r r' (IN: gf r x0 x1 x2 x3 x4 x5) (LE: r <6= r'), gf r' x0 x1 x2 x3 x4 x5.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable gf : rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5.
Arguments gf : clear implicits.

Theorem paco6_acc: forall
  l r (OBG: forall rr (INC: r <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6 gf rr),
  l <6= paco6 gf r.
Proof.
  intros; assert (SIM: paco6 gf (r \6/ l) x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_mon: monotone6 (paco6 gf).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_mult_strong: forall r,
  paco6 gf (upaco6 gf r) <6= paco6 gf r.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Corollary paco6_mult: forall r,
  paco6 gf (paco6 gf r) <6= paco6 gf r.
Proof. intros; eapply paco6_mult_strong, paco6_mon; eauto. Qed.

Theorem paco6_fold: forall r,
  gf (upaco6 gf r) <6= paco6 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco6_unfold: forall (MON: monotone6 gf) r,
  paco6 gf r <6= gf (upaco6 gf r).
Proof. unfold monotone6; intros; destruct PR; eauto. Qed.

End Arg6_1.

Hint Unfold monotone6.
Hint Resolve paco6_fold.

Arguments paco6_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_unfold         [ T0 T1 T2 T3 T4 T5 ].

Instance paco6_inst  T0 T1 T2 T3 T4 T5 (gf : rel6 T0 T1 T2 T3 T4 T5->_) r x0 x1 x2 x3 x4 x5 : paco_class (paco6 gf r x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_acc gf;
  pacomult   := paco6_mult gf;
  pacofold   := paco6_fold gf;
  pacounfold := paco6_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg6_2.

Definition monotone6_2 T0 T1 T2 T3 T4 T5 (gf: rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5) :=
  forall x0 x1 x2 x3 x4 x5 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2 x3 x4 x5) (LE_0: r_0 <6= r'_0)(LE_1: r_1 <6= r'_1), gf r'_0 r'_1 x0 x1 x2 x3 x4 x5.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable gf_0 gf_1 : rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.

Theorem paco6_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_2_0 gf_0 gf_1 rr r_1),
  l <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco6_2_0 gf_0 gf_1 (r_0 \6/ l) r_1 x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_2_1 gf_0 gf_1 r_0 rr),
  l <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco6_2_1 gf_0 gf_1 r_0 (r_1 \6/ l) x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_2_0_mon: monotone6_2 (paco6_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_2_1_mon: monotone6_2 (paco6_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_2_0_mult_strong: forall r_0 r_1,
  paco6_2_0 gf_0 gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_2_1_mult_strong: forall r_0 r_1,
  paco6_2_1 gf_0 gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Corollary paco6_2_0_mult: forall r_0 r_1,
  paco6_2_0 gf_0 gf_1 (paco6_2_0 gf_0 gf_1 r_0 r_1) (paco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco6_2_0_mult_strong, paco6_2_0_mon; eauto. Qed.

Corollary paco6_2_1_mult: forall r_0 r_1,
  paco6_2_1 gf_0 gf_1 (paco6_2_0 gf_0 gf_1 r_0 r_1) (paco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco6_2_1_mult_strong, paco6_2_1_mon; eauto. Qed.

Theorem paco6_2_0_fold: forall r_0 r_1,
  gf_0 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco6_2_1_fold: forall r_0 r_1,
  gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco6_2_0_unfold: forall (MON: monotone6_2 gf_0) (MON: monotone6_2 gf_1) r_0 r_1,
  paco6_2_0 gf_0 gf_1 r_0 r_1 <6= gf_0 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone6_2; intros; destruct PR; eauto. Qed.

Theorem paco6_2_1_unfold: forall (MON: monotone6_2 gf_0) (MON: monotone6_2 gf_1) r_0 r_1,
  paco6_2_1 gf_0 gf_1 r_0 r_1 <6= gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone6_2; intros; destruct PR; eauto. Qed.

End Arg6_2.

Hint Unfold monotone6_2.
Hint Resolve paco6_2_0_fold.
Hint Resolve paco6_2_1_fold.

Arguments paco6_2_0_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_unfold         [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_unfold         [ T0 T1 T2 T3 T4 T5 ].

Instance paco6_2_0_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 x0 x1 x2 x3 x4 x5 : paco_class (paco6_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_2_0_acc gf_0 gf_1;
  pacomult   := paco6_2_0_mult gf_0 gf_1;
  pacofold   := paco6_2_0_fold gf_0 gf_1;
  pacounfold := paco6_2_0_unfold gf_0 gf_1 }.

Instance paco6_2_1_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 x0 x1 x2 x3 x4 x5 : paco_class (paco6_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_2_1_acc gf_0 gf_1;
  pacomult   := paco6_2_1_mult gf_0 gf_1;
  pacofold   := paco6_2_1_fold gf_0 gf_1;
  pacounfold := paco6_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg6_3.

Definition monotone6_3 T0 T1 T2 T3 T4 T5 (gf: rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5) :=
  forall x0 x1 x2 x3 x4 x5 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) (LE_0: r_0 <6= r'_0)(LE_1: r_1 <6= r'_1)(LE_2: r_2 <6= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2 x3 x4 x5.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.
Arguments gf_2 : clear implicits.

Theorem paco6_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco6_3_0 gf_0 gf_1 gf_2 (r_0 \6/ l) r_1 r_2 x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco6_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \6/ l) r_2 x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \6/ l) x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_3_0_mon: monotone6_3 (paco6_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_1_mon: monotone6_3 (paco6_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_2_mon: monotone6_3 (paco6_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_0_mult_strong: forall r_0 r_1 r_2,
  paco6_3_0 gf_0 gf_1 gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_1_mult_strong: forall r_0 r_1 r_2,
  paco6_3_1 gf_0 gf_1 gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_2_mult_strong: forall r_0 r_1 r_2,
  paco6_3_2 gf_0 gf_1 gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Corollary paco6_3_0_mult: forall r_0 r_1 r_2,
  paco6_3_0 gf_0 gf_1 gf_2 (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco6_3_0_mult_strong, paco6_3_0_mon; eauto. Qed.

Corollary paco6_3_1_mult: forall r_0 r_1 r_2,
  paco6_3_1 gf_0 gf_1 gf_2 (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco6_3_1_mult_strong, paco6_3_1_mon; eauto. Qed.

Corollary paco6_3_2_mult: forall r_0 r_1 r_2,
  paco6_3_2 gf_0 gf_1 gf_2 (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco6_3_2_mult_strong, paco6_3_2_mon; eauto. Qed.

Theorem paco6_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco6_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco6_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco6_3_0_unfold: forall (MON: monotone6_3 gf_0) (MON: monotone6_3 gf_1) (MON: monotone6_3 gf_2) r_0 r_1 r_2,
  paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <6= gf_0 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone6_3; intros; destruct PR; eauto. Qed.

Theorem paco6_3_1_unfold: forall (MON: monotone6_3 gf_0) (MON: monotone6_3 gf_1) (MON: monotone6_3 gf_2) r_0 r_1 r_2,
  paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <6= gf_1 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone6_3; intros; destruct PR; eauto. Qed.

Theorem paco6_3_2_unfold: forall (MON: monotone6_3 gf_0) (MON: monotone6_3 gf_1) (MON: monotone6_3 gf_2) r_0 r_1 r_2,
  paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <6= gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone6_3; intros; destruct PR; eauto. Qed.

End Arg6_3.

Hint Unfold monotone6_3.
Hint Resolve paco6_3_0_fold.
Hint Resolve paco6_3_1_fold.
Hint Resolve paco6_3_2_fold.

Arguments paco6_3_0_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_unfold         [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_unfold         [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_unfold         [ T0 T1 T2 T3 T4 T5 ].

Instance paco6_3_0_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 : paco_class (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco6_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco6_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco6_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco6_3_1_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 : paco_class (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco6_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco6_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco6_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco6_3_2_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 : paco_class (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco6_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco6_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco6_3_2_unfold gf_0 gf_1 gf_2 }.