From trancert.lib Require Decidability Tac.

Import Decidability Tac.

Section Decidability.

  Variable A: Type.
  Hypothesis Hdec: eq_dec A.

  Definition option_eq_dec :
     eq_dec (option A).
  Proof.
    decide_equality ; eauto  with decidable_prop.
  Defined.
End Decidability.

Hint Resolve option_eq_dec : decidable_prop.

(** Extracts information from matches in hypotheses and tries to solve the trivial branch *)
Ltac option_cases := match goal with
                     | [ H : match ?x with | _ => _ end = Some _ |- _ ] =>
                       let Hfresh := fresh "Heq" in
                       destruct x eqn: Hfresh; try discriminate
                     | [ H : match ?x with | _ => _ end = None |- _ ] =>
                       let Hfresh := fresh "Heq" in
                       destruct x eqn: Hfresh; try discriminate
                     end; repeat clean.


Require Import FunctionalExtensionality.
Require Import Reasoning.
Require Import Hask.Prelude.
Require Import Data.Either.
Require Import Data.Monoid.
Require Import Hask.Data.Functor.
Require Import Hask.Data.Functor.Const.
Require Import Hask.Control.Applicative.
Require Import Hask.Control.Selective.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.

Import FunctorLaws.
Import ApplicativeLaws.
Import SelectiveLaws.

Reserved Notation "m >>= f" (at level 42, right associativity).
Reserved Notation "m >>[ F ]= f" (at level 42, right associativity).

Class Monad (F : Set -> Set) := {
  (* is_applicative :> Applicative F; *)
  ret : forall A : Set, A -> F A;
  bind : forall (A B : Set), (A -> F B) -> F A -> F B
}.

Arguments ret {_ _ _} _.
Arguments bind {_ _ _ _} _ _.

Declare Scope monad_scope.
Notation "m >>= f" := (bind f m) (at level 42, right associativity) : monad_scope.
Notation "m >>[ F ]= f" := (bind (F:=F) f m)
  (at level 42, right associativity) : monad_scope.
Open Scope monad_scope.

Global Instance Monad_Functor (F : Set -> Set) (HM : Monad F) :
  Functor F := {
    fmap _ _ f x := x >>= (ret ∘ f)
  }.

Definition apM {A B : Set} {F : Set -> Set} {HM : Monad F}
           (f : F (A -> B)) (x : F A) : F B :=
  f >>= fun k => k <$> x.

Global Instance Monad_Applicative (F : Set -> Set) (HM : Monad F) :
  Applicative F := {
    pure x := @ret F _ x;
    ap _ _ f x := apM f x
  }.

Class MonadLaws (F : Set -> Set) (HM : Monad F) := {
  (* has_applicative_laws :> ApplicativeLaws F; *)
  left_id : forall (A B : Set) (x : A) (f : A -> F B),
            ret x >>= f = f x;
  right_id : forall (A : Set) (m : F A), m >>= ret = m;
  assoc: forall (A B C : Set) (m : F A) (f : A -> F B) (g : B -> F C),
      (m >>= f) >>= g = m >>= (fun x => f x >>= g)
}.

Global Program Instance Monal_FunctorLaws (F : Set -> Set)
       (HM : Monad F) (HML : MonadLaws F HM) : FunctorLaws F.
Obligation 1.
  extensionality x.
  unfold comp.
  now rewrite right_id.
Defined.
Obligation 2.
  extensionality x.
  unfold comp.
  rewrite assoc.
  f_equal.
  extensionality z.
  now rewrite left_id.
Defined.

Definition selectM {A B : Set} {F : Set -> Set} {HM : Monad F}
           (x : F (A + B)) (y : F (A -> B)) : F B :=
  x >>[F]= fun i => match i with
              | Left a => rev_f_ap a <$> y
              | Right b => pure b
              end.

Global Instance Monad_Selective (F : Set -> Set) (HM : Monad F) :
  Selective F := {
    select _ _ x f := selectM x f
  }.

Program Instance MonadLaws_SelectiveLaws (F : Set -> Set)
  (HM : Monad F)
  (HML : MonadLaws F HM) :
  (@SelectiveLaws F (Monad_Selective F HM)).
Admit Obligations.

Lemma fmap_left_bind : forall (A B C : Set) (F : Set -> Set) (HM : Monad F) (HML : MonadLaws F HM)
            (f : F A) (g : (A + C) -> F B),
      fmap[F] Left f >>[F]= g = f >>= (g ∘ Left).
Proof.
  intros. unfold comp.
  simpl.
  rewrite assoc.
  f_equal.
  extensionality x.
  simpl.
  now setoid_rewrite left_id.
Qed.

Lemma Monad_ap_is_apS
      (A B : Set) (F : Set -> Set)
      (HM : Monad F) (HML : MonadLaws F HM) :
      forall (f : F (A -> B)) (x : F A), f <*> x = apS f x.
Proof.
  intros.
  `Begin
   (f <*> x).
  ≡⟨ reflexivity ⟩
   (apM f x).
  ≡⟨ now unfold apM ⟩
   (f >>= (fun k : A -> B => fmap k x)).
  ≡⟨ f_equal ⟩
   (f >>= ((fun i : (A -> B) + B =>
      match i with
      | Left k => fmap k x
      | Right b => pure b
      end) ∘ Left)).
  ≡⟨ now rewrite fmap_left_bind ⟩
   (fmap Left f >>= fun i : (A -> B) + B =>
      match i with
      | Left k => fmap k x
      | Right b => pure b
      end).
  ≡⟨ f_equal; extensionality i; destruct i; functor_laws ⟩
   (fmap Left f >>= fun i : (A -> B) + B =>
      match i with
      | Left k => fmap (rev_f_ap k) (fmap rev_f_ap x)
      | Right b => pure b
      end).
  ≡⟨ now unfold selectM ⟩
   (selectM (fmap Left f) (fmap rev_f_ap x)).
  unfold selectM.
  ≡⟨ reflexivity ⟩
   (fmap Left f <*? fmap rev_f_ap x).
  ≡⟨ now unfold apS ⟩
   (apS f x)
  `End.
Qed.


Require Import bft.
Require Import Maps.

Require Import Arith Bool List ZArith. Import ListNotations.
From QuickChick Require Import QuickChick. Import QcNotation.

(* Suppress some annoying warnings: *)
Set Warnings "-extraction-opaque-accessed,-extraction".

Require Export ExtLib.Structures.Monads.
Export MonadNotation. Open Scope monad_scope.

Require Import String. Local Open Scope string.

Instance showReplica : Show Replica :=
{
  show := fun r:Replica =>
            match r with
            | NFReplica id => "NF_" ++ id
            | FaultyReplica id => "F_" ++ id
            end
}.

Definition genFaultyReplica (id : nat) : G Replica :=
  elems [(FaultyReplica (show id))].

Definition genNFReplica (id : nat) : G Replica :=
  elems [(NFReplica (show id))].

Fixpoint genSystemSized (sz : nat) (F NFR nOf_nfr nOf_f : nat) : G (System) :=
  match sz with
    | O => ret []
    | S sz' =>
        if nOf_f =? F then
          (liftM2 cons (genNFReplica sz') (genSystemSized sz'  F NFR (S nOf_nfr) nOf_f))
        else
          if nOf_nfr =? NFR then
            (liftM2 cons (genFaultyReplica sz') (genSystemSized sz' F NFR nOf_nfr (S nOf_f)))
          else
          oneOf [ (liftM2 cons (genNFReplica sz') (genSystemSized sz' F NFR (S nOf_nfr) nOf_f)) ;
                 (liftM2 cons (genFaultyReplica sz') (genSystemSized sz' F NFR nOf_nfr (S nOf_f)))
               ]
  end.

Definition newSysGen F := genSystemSized (3*F+1) F (2*F+1) 0 0.

Sample (newSysGen 10).

Definition CorrectSystem (F : nat) (sys:System) :=
   andb (count_system sys =? 3*F+1) (countNFR_system sys =? 2*F+1).

Definition CorrectState (F : nat) (st:bft.State) :=
   andb (count_state st =? 3*F+1) (countNFR_state st =? 2*F+1).

QuickChick ( forAll (newSysGen 10) (CorrectSystem 10)).

Definition CorrectInitState (F : nat) (sys:System) :=
  CorrectSystem F sys ==>
    let st := initState sys in
      andb (count_state st =? 3*F+1) (countNFR_state st =? 2*F+1).

QuickChick ( forAll (newSysGen 10) (CorrectInitState 10)).

Definition CorrectReplicateReqState (F : nat) (sys:System) :=
  CorrectSystem F sys ==>
    let st := ReplicateRequest sys (prePrep sys) (initState sys) in
      andb (count_state st =? 3*F+1) (countNFR_state st =? 2*F+1).

QuickChick ( forAll (newSysGen 10) (CorrectReplicateReqState 10)).

Instance ledgerAgreement_dec (st : bft.State) : Dec (LedgerAgreement st) := {}.
Proof. dec_eq. unfold LedgerAgreement. apply Forall_dec.
unfold quorumCertified. destruct x. apply ge_dec.
Defined.

Definition LedgerAgreementReplicateReqState (F : nat) (sys:System) :=
  CorrectSystem F sys ==>
    let st := ReplicateRequest sys (prePrep sys) (initState sys) in
      (LedgerAgreement st)?.

QuickChick ( forAll (newSysGen 10) (LedgerAgreementReplicateReqState 10)).

Definition newPrePrep' (r: Replica) (n : nat) (msgs : total_map nat) :=
    match r with
    | NFReplica id => msgs & {id --> nfrValue}
    | FaultyReplica id => msgs & {id --> nfrValue}
    end.

Fixpoint newPrePrepL (sys:list Replica) (vals : list nat) : (total_map nat):=
  match sys, vals with
  | nil, nil => t_empty 0
  | (NFReplica id)::sys', v::vals' => (newPrePrepL sys' vals')&{id --> v}
  | (FaultyReplica id)::sys', v::vals' => (newPrePrepL sys' vals')&{id --> v}
  | _, _ => t_empty 0
  end.

Instance showState : Show (list (Replica * (list nat))) :=
{
  show := fun st:bft.State =>
            match st with
            | nil => show nil
            | (r, msgs)::t => "{ " ++ (show r) ++ " : " ++ (show msgs) ++ " }"
            end
}.

Definition ReplicateFaultyPrimary :=
    let size := 10 in
    let sys := (newSysGen size) in
    let vals := (vectorOf size (choose(0,100))) in
       liftM3 ReplicateRequest sys (liftM2 newPrePrepL sys vals) (liftM initState sys).

(* Fails as expected. The primary is faulty so the system does not reach ledger agreement *)
(* *** Failed after 1 tests and 0 shrinks. (0 discards)*)
QuickChick (forAll ReplicateFaultyPrimary (fun st => (LedgerAgreement st)?)).


From Coq Require Import Morphisms.

From ITree Require Import
     Axioms
     ITree
     ITreeFacts.

From ITree.Extra Require Import
     Secure.SecureEqHalt
.

From Paco Require Import paco.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

(* will need more propositional constraints on Preorders *)

Section SecureProgInsens.
  Context {E : Type -> Type} {R1 R2 : Type}.
  Context (Label : Preorder).
  Context (priv : forall A, E A -> L).
  Context (RR : R1 -> R2 -> Prop).

  (*
  Context (RE : forall A, E A -> E A -> A -> A -> Prop).
  want it to be an equivalence
  *)

  Variant pi_secure_eqitF (b1 b2 : bool) (l : L) vclo (sim : itree E R1 -> itree E R2 -> Prop) : itree' E R1 -> itree' E R2 -> Prop :=

    (* eqitF constructors *)
    | pisecEqRet r1 r2 : RR r1 r2 -> pi_secure_eqitF b1 b2 l vclo sim (RetF r1) (RetF r2)
    | pisecEqTau t1 t2 : sim t1 t2 -> pi_secure_eqitF b1 b2 l vclo sim (TauF t1) (TauF t2)
    | pisecEqTauL t1 t2 (CHECK : b1) : sim t1 t2 -> pi_secure_eqitF b1 b2 l vclo sim (TauF t1) (observe t2)
    | pisecEqTauR t1 t2 (CHECK : b2) : sim t1 t2 -> pi_secure_eqitF b1 b2 l vclo sim (observe t1) (TauF t2)
    (* info_flow protecting coinductive constructors *)
    | piEqVisPriv {A} (e : E A) k1 k2 (SECCHECK : leq (priv A e) l) :
        ((forall a, vclo sim (k1 a) (k2 a) : Prop)) -> pi_secure_eqitF b1 b2 l vclo sim (VisF e k1) (VisF e k2)
    | piEqVisUnPrivTauLCo {A} (e : E A) k1 t2 (SECCHECK : ~ leq (priv A e) l) :
        (forall a, vclo sim (k1 a) t2) -> pi_secure_eqitF b1 b2 l vclo sim (VisF e k1) (TauF t2)
    | piEqVisUnPrivTauRCo {A} (e : E A) t1 k2 (SECCHECK : ~ leq (priv A e) l) :
        (forall a, vclo sim t1 (k2 a)) -> pi_secure_eqitF b1 b2 l vclo sim (TauF t1) (VisF e k2)
    | piEqVisUnPrivVisCo {A B} (e1 : E A) (e2 : E B) k1 k2 (SECCHECK1 : ~ leq (priv A e1) l) (SECCHECK2 : ~ leq (priv B e2) l)
        :
        (forall a b, vclo sim (k1 a) (k2 b)) -> pi_secure_eqitF b1 b2 l vclo sim (VisF e1 k1) (VisF e2 k2)
    (* info_flow protecting inductive constructors *)
    | piEqVisUnPrivLInd {A} (e : E A) k1 t2 (CHECK : b1) (SECCHECK : ~ leq (priv A e) l) :
        (forall a, vclo sim (k1 a) t2 ) ->
        pi_secure_eqitF b1 b2 l vclo sim (VisF e k1) (observe t2)
    | piEqVisUnPrivRInd {A} (e : E A) t1 k2 (CHECK : b2) (SECCHECK : ~ leq (priv A e) l) :
        (forall a, vclo sim t1 (k2 a) ) ->
        pi_secure_eqitF b1 b2 l vclo sim (observe t1) (VisF e k2)
  .

  Hint Constructors pi_secure_eqitF : itree.

  Definition pi_secure_eqit_ (b1 b2 : bool) (l : L) vclo (sim : itree E R1 -> itree E R2 -> Prop) : itree E R1 -> itree E R2 -> Prop :=
    fun t1 t2 => pi_secure_eqitF b1 b2 l vclo sim (observe t1) (observe t2).

  Hint Unfold pi_secure_eqit_ : itree.

  Lemma pi_secure_eqitF_mono b1 b2 l x0 x1 vclo vclo' sim sim'
        (IN: pi_secure_eqitF b1 b2 l vclo sim x0 x1)
        (MON: monotone2 vclo)
        (LEc: vclo <3= vclo')
        (LE: sim <2= sim'):
    pi_secure_eqitF b1 b2 l vclo' sim' x0 x1.
  Proof.
    intros. induction IN; eauto with itree.
  Qed.

  Lemma pi_secure_eqit_mono b1 b2 l vclo (MON: monotone2 vclo) : monotone2 (pi_secure_eqit_ b1 b2 l vclo).
  Proof.
    do 2 red. intros; eapply pi_secure_eqitF_mono; eauto with itree.
  Qed.

  Hint Resolve pi_secure_eqit_mono : paco.

  Definition pi_eqit_secure b1 b2 l := paco2 (pi_secure_eqit_ b1 b2 l id) bot2.

  (* want and eqitC_secure which could help prove some interesting stuff

   *)

End SecureProgInsens.

#[export] Hint Resolve pi_secure_eqit_mono : paco.
#[export] Hint Constructors pi_secure_eqitF : itree.

Ltac unpriv_pi := try apply piEqVisUnPrivVisCo;
                  try apply piEqVisUnPrivTauLCo;
                  try apply piEqVisUnPrivTauRCo;
                  try apply piEqVisUnPrivLInd;
                  try apply piEqVisUnPrivRInd;
                  auto with itree; intros.

Ltac contra_size :=
  match goal with
  | [ Hemp : empty ?A, Hne : nonempty ?A |- _ ] => inv Hemp; inv Hne; contradiction end.

Lemma eqit_secure_imp_pi_eqit_scure b1 b2 E R1 R2 RR Label priv l : forall (t1 : itree E R1) (t2 : itree E R2),
    eqit_secure Label priv RR b1 b2 l t1 t2 -> pi_eqit_secure Label priv RR b1 b2 l t1 t2.
Proof.
  pcofix CIH. intros t1 t2 Hps. pfold. red. punfold Hps. red in Hps.
  hinduction Hps before r; intros.
  - constructor; auto with itree.
  - constructor. right. pclearbot. eauto with itree.
  - rewrite itree_eta'. constructor; auto with itree. right. eapply CIH. pfold. apply Hps.
  - rewrite itree_eta' at 1. constructor; auto with itree. right. eapply CIH. pfold. apply Hps.
  - pclearbot. constructor; auto with itree. right. eapply CIH; eauto with itree. apply H.
  - pclearbot. unpriv_pi. right. eapply CIH; apply H.
  - pclearbot. unpriv_pi. right. eapply CIH; apply H.
  - pclearbot. unpriv_pi. right. eapply CIH; apply H.
  - pclearbot. unpriv_pi. right. eapply CIH. pfold. apply H.
  - pclearbot. unpriv_pi. right. eapply CIH. pfold. apply H.
  - unpriv_pi. inv SIZECHECK. contradiction.
  - unpriv_pi. inv SIZECHECK. contradiction.
  - unpriv_pi. inv SIZECHECK. contradiction.
  - unpriv_pi. inv SIZECHECK. contradiction.
Qed.

Lemma pi_eqit_secure_sym b1 b2 E R1 R2 RR Label priv l : forall (t1 : itree E R1) (t2 : itree E R2),
    pi_eqit_secure Label priv RR b1 b2 l t1 t2 -> pi_eqit_secure Label priv (flip RR) b2 b1 l t2 t1.
Proof.
  pcofix CIH. intros t1 t2 Hsec.
  punfold Hsec. pfold. red in Hsec. red. inversion Hsec; pclearbot; eauto;
  try (unpriv_pi; right; eapply CIH; apply H1; fail).
  constructor; auto. right. eapply CIH; apply H1.
Qed.

Lemma pi_secure_eqit_mon : forall E (b1 b2 b3 b4 : bool) R1 R2 RR1 RR2 Label priv l
      (t1 : itree E R1) (t2 : itree E R2),
    (b1 -> b3) -> (b2 -> b4) -> (RR1 <2= RR2) ->
    pi_eqit_secure Label priv RR1 b1 b2 l t1 t2 -> pi_eqit_secure Label priv RR2 b3 b4 l t1 t2.
Proof.
  intros. generalize dependent t2. revert t1. pcofix CIH.
  intros t1 t2 Ht12. pstep. red.
  punfold Ht12. red in Ht12.
  hinduction Ht12 before r; intros; eauto; pclearbot;
  try (unpriv_pi; right; apply CIH; try red; eauto; fail);
  constructor; auto. right.  eauto. apply CIH; apply H2.
Qed.

Lemma pi_eqit_secure_spin b E R1 R2 (RR : R1 -> R2 -> Prop) Label priv l : forall (t1 : itree E R1),
    pi_eqit_secure Label priv RR b true l t1 (ITree.spin).
Proof.
  pcofix CIH. intros. pfold. red. cbn. constructor; auto.
Qed.

Lemma pi_eqit_secure_private_halt b E R1 R2 (RR : R1 -> R2 -> Prop) Label priv l A (e : E A) k:
  empty A -> ~ leq (priv A e) l -> forall (t1 : itree E R1),
    pi_eqit_secure Label priv RR b true l t1 (Vis e k).
Proof.
  intros HA t1. pfold. red. cbn. intros. unpriv_pi. inv HA; contradiction.
Qed.

Lemma pi_eqit_secure_mixed_trans_aux1:
  forall (E : Type -> Type) (R1 : Type) (b2 : bool) (R2 : Type) (RR1 : R1 -> R2 -> Prop)
    (Label : Preorder) (priv : forall A : Type, E A -> L) (l : L) t1 t2,
    paco2 (pi_secure_eqit_ Label priv RR1 true b2 l id) bot2 t1 (Tau t2)  ->
    pi_eqit_secure Label priv RR1 true b2 l t1 t2.
Proof.
  intros E R1 b2 R2 RR1 Label priv l. pcofix CIH.
  intros t1 t2 Htau. punfold Htau. red in Htau.
  pfold. red. cbn in *. inv Htau; pclearbot; eauto.
  - constructor; auto. left. eapply paco2_mon; eauto. intros; contradiction.
  - constructor; auto. right. eapply CIH; eauto. pfold. red. rewrite <- H0.
    cbn. pstep_reverse.
  - pstep_reverse. eapply paco2_mon; eauto. intros; contradiction.
  - unpriv_pi. left.  eapply paco2_mon; eauto. intros; contradiction.
  - unpriv_pi. right. eapply CIH. pfold. red. rewrite <- H0.
    cbn. pstep_reverse.
Qed.

Lemma pi_eqit_secure_mixed_trans b1 b2 E R1 R2 R3 (RR1 : R1 -> R2 -> Prop) (RR2 : R2 -> R3 -> Prop)
      Label priv l : forall (t1 : itree E R1) t2 t3,
    pi_eqit_secure Label priv RR1 b1 b2 l t1 t2 -> eqit RR2 b1 b2 t2 t3 ->
    pi_eqit_secure Label priv (rcompose RR1 RR2) b1 b2 l t1 t3.
Proof.
  pcofix CIH. intros t1 t2 t3 Hsec Heq. punfold Heq.
  red in Heq. punfold Hsec. red in Hsec. pfold. red.
  hinduction Heq before r; intros; try inv CHECK; pclearbot.
  - inv Hsec; eauto with itree; unpriv_pi; pclearbot.
    + rewrite itree_eta'. constructor; auto with itree. right. eapply CIH; eauto.
      pfold. red. rewrite H0. constructor. auto.
    + rewrite itree_eta'. unpriv_pi. right. eapply CIH; eauto.
      apply H1. pfold. red. rewrite H0. constructor; auto.
  - inv Hsec; pclearbot; eauto with itree.
    + constructor. right. eapply CIH; eauto with itree.
      pfold. red. rewrite H0. constructor; auto. pstep_reverse.
    + unpriv_pi. right. eapply CIH; eauto. apply H1.
    + rewrite itree_eta'. unpriv_pi. right. eapply CIH; eauto.
      inv CHECK. apply pi_eqit_secure_mixed_trans_aux1.
      pfold. red. rewrite <- H0. cbn. pstep_reverse.
  - inv Hsec.
    + pclearbot. rewrite itree_eta'. constructor; auto. right. eapply CIH; eauto.
      pfold. red. rewrite H0. constructor. left. auto.
    + ddestruction. subst. constructor; auto with itree. right.
      pclearbot. eapply CIH; eauto with itree. apply H1.
    + ddestruction. subst. unpriv_pi. right. pclearbot.
      eapply CIH; eauto with itree. apply H1.
    + ddestruction. subst. unpriv_pi. right. pclearbot.
      eapply CIH; eauto with itree. apply H1.
    + pclearbot. remember (VisF e k2) as ovis. rewrite itree_eta'.
      unpriv_pi. rewrite Heqovis. right. eapply CIH; eauto with itree. apply H1.
      pfold. red. rewrite H0. constructor. left. auto.
    + ddestruction. subst. unpriv_pi. right. eapply CIH; eauto with itree. pclearbot. apply H1.
  - eapply IHHeq; eauto. clear IHHeq. inv Hsec; pclearbot.
    + constructor; auto.
    + constructor; auto. left. apply pi_eqit_secure_mixed_trans_aux1. pfold. red.
      rewrite <- H0. cbn. pstep_reverse.
    + pstep_reverse.
    + unpriv_pi.
    + unpriv_pi. left. apply pi_eqit_secure_mixed_trans_aux1. pfold. red.
      rewrite <- H0. cbn. pstep_reverse.
  - constructor; auto. left. pfold. eapply IHHeq; eauto.
Qed.

Lemma pi_eqit_secure_RR_imp b1 b2 E R1 R2 (RR1 : R1 -> R2 -> Prop ) (RR2 : R1 -> R2 -> Prop)
      Label priv l : (forall r1 r2, RR1 r1 r2 -> RR2 r1 r2) ->
                     forall (t1 : itree E R1) (t2 : itree E R2),
      pi_eqit_secure Label priv RR1 b1 b2 l t1 t2 ->
      pi_eqit_secure Label priv RR2 b1 b2 l t1 t2.
Proof.
  intro Himp. pcofix CIH.
  intros. pfold. red. punfold H0. red in H0.
  inv H0; eauto;
  try (constructor; auto; pclearbot; eauto; fail);
  try (pclearbot; constructor; auto; right; eapply CIH; eauto; try apply H2; fail).
Qed.

Lemma pi_eqit_secureC_wcompat_id :  forall b1 b2 E R1 R2 (RR : R1 -> R2 -> Prop )
      Label priv l
, wcompatible2 (@pi_secure_eqit_ E R1 R2 Label priv RR b1 b2 l id)
                                         (eqitC RR b1 b2) .
Proof.
  econstructor. pmonauto_itree.
  intros. destruct PR.
  punfold EQVl. punfold EQVr. unfold_eqit. red in REL. red.
  hinduction REL before r; intros; clear t1' t2'; try inv CHECK.
  - genobs_clear t1 ot1. genobs_clear t2 ot2.
    remember (RetF r1) as x.
    hinduction EQVl before r; intros; inv Heqx; eauto.
    + remember (RetF r3) as y.
      hinduction EQVr before r; intros; inv Heqy; eauto with itree.
      rewrite itree_eta' at 1. constructor; eauto with itree. gstep. red.
      eapply IHEQVr; eauto.
    + rewrite itree_eta'. constructor; auto. cbn. gstep. red. cbn.
      eauto.
  - remember (TauF t1) as y.
    hinduction EQVl before r; intros; inv Heqy; try inv CHECK; subst; eauto.
    + remember (TauF t2) as x.
      hinduction EQVr before r; intros; inv Heqx; try inv CHECK; subst; eauto.
      pclearbot. constructor. gclo. econstructor; eauto with paco.
      pclearbot.
      remember (TauF m1) as ot1. rewrite itree_eta' at 1.
      constructor; auto. rewrite Heqot1. gstep. red. cbn. eauto.
    + constructor; auto. gstep. red. eapply IHEQVl; eauto.
  - inv EQVl; pclearbot; try inv CHECK.
    + constructor; auto. gclo. econstructor; eauto with paco itree.
    + constructor; auto. gclo. econstructor; eauto with paco itree.
      apply eqit_inv_Tau_r. pfold. auto.
  - inv EQVr; pclearbot; try inv CHECK.
    + constructor; auto. gclo. econstructor; eauto with paco itree.
    + constructor; auto. gclo. econstructor; eauto with paco itree.
      apply eqit_inv_Tau_r. pfold. auto.
  - remember (VisF e k1) as x.
    hinduction EQVl before r; intros; inv Heqx; try inv CHECK; eauto.
    + ddestruction. subst. remember (VisF e0 k3) as y.
      hinduction EQVr before r; intros; inv Heqy; try inv CHECK; eauto.
      * ddestruction. subst. constructor; auto.
        intros. apply gpaco2_clo. pclearbot. econstructor; eauto with itree. apply H.
      * pclearbot. remember (VisF e0 k1) as ovis. rewrite itree_eta' at 1.
        constructor; auto. rewrite Heqovis. gstep. red. eapply IHEQVr; eauto with itree.
    + constructor; auto. gstep. red. eapply IHEQVl; eauto.
  - remember (VisF e k1) as x.
    hinduction EQVl before r; intros; inv Heqx; try inv CHECK; subst; eauto.
    + ddestruction. subst. pclearbot. remember (TauF t2) as y.
      hinduction EQVr before r; intros; inv Heqy; try inv CHECK; subst; pclearbot; eauto.
      * unpriv_pi. gclo. econstructor; cycle -1; eauto with paco itree. gfinal. left. apply H.
      * remember (VisF e0 k1) as ovis. rewrite itree_eta' at 1. constructor; auto.
        rewrite Heqovis. gstep. red. eapply IHEQVr; eauto.
    + constructor; auto. gstep. red. eapply IHEQVl; eauto.
  - remember (TauF t1) as x.
    hinduction EQVl before r; intros; inv Heqx; try inv CHECK; subst; eauto.
    + remember (VisF e k2) as y.
      hinduction EQVr before r; intros; inv Heqy; try inv CHECK; subst; eauto.
      * ddestruction. subst.
        pclearbot. unpriv_pi. gclo. econstructor; cycle -1; eauto with paco itree.
        gfinal. left. apply H.
      * remember (TauF m1) as otm1. rewrite itree_eta' at 1. constructor; auto.
        gstep. rewrite Heqotm1. red. eapply IHEQVr; eauto.
   + constructor; auto. gstep. red. eapply IHEQVl; eauto.
  - remember (VisF e1 k1) as x.
    hinduction EQVl before r; intros; inv Heqx; try inv CHECK; subst; eauto.
    + ddestruction. subst. remember (VisF e2 k3) as y.
      hinduction EQVr before r; intros; inv Heqy; try inv CHECK; subst; eauto.
      * ddestruction. subst. unpriv_pi. gclo. pclearbot.
        econstructor; eauto with paco itree. gfinal. left. apply H.
      * remember (VisF e1 k1) as ovis. rewrite itree_eta' at 1.
        constructor; auto. rewrite Heqovis. gstep. eapply IHEQVr; eauto.
    + remember (VisF e2 k2) as x.
      hinduction EQVr before r; intros; inv Heqx; try inv CHECK; subst; eauto.
      * ddestruction. subst. pclearbot. unpriv_pi.
         gclo. eapply eqit_trans_clo_intro with (t1' := Vis e1 k0); eauto with paco itree.
         gstep. red. cbn. unpriv_pi. gfinal. left. apply H.
       * remember (TauF t3) as ott3. rewrite itree_eta' at 1. constructor; auto.
         rewrite Heqott3. gstep. red. eapply IHEQVr; eauto.
  - remember (VisF e k1) as x.
    hinduction EQVl before r; intros; inv Heqx; try inv CHECK; eauto.
    + ddestruction. subst. pclearbot. unpriv_pi.
      gclo. econstructor; eauto with paco itree. gfinal. left. apply H.
    + constructor; auto. gstep. eapply IHEQVl; eauto.
  - remember (VisF e k2) as x.
    hinduction EQVr before r; intros; inv Heqx; try inv CHECK; eauto.
    + ddestruction. subst. pclearbot. unpriv_pi.
      gclo. econstructor; eauto with paco itree. gfinal. left. apply H.
    + constructor; auto. gstep. eapply IHEQVr; eauto.
Qed.

#[export] Hint Resolve pi_eqit_secureC_wcompat_id : paco.

Global Instance geuttgen_cong_secure_eqit {E} {Label priv l} {R1 R2 : Type} {RR1 : R1 -> R1 -> Prop}
    {RR2 : R2 -> R2 -> Prop} {RS : R1 -> R2 -> Prop} (b1 b2 : bool) {r rg} :
    (forall (x x' : R1) (y : R2), (RR1 x x' : Prop) -> (RS x' y : Prop) -> RS x y) ->
    (forall (x : R1) (y y' : R2), (RR2 y y' : Prop) -> RS x y' -> RS x y) ->
    Proper (@eq_itree E R1 R1 RR1 ==> eq_itree RR2 ==> flip impl)
           (gpaco2 (pi_secure_eqit_ Label priv RS b1 b2 l id) (eqitC RS b1 b2) r rg ).
Proof.
  repeat intro. gclo. econstructor; eauto with itree.
  - eapply eqit_mon, H1; eauto; discriminate.
  - eapply eqit_mon, H2; eauto; discriminate.
Qed.

Global Instance geuttgen_cong_eq_secure_eqit {E} {Label priv l} {R1 R2 : Type} {RS : R1 -> R2 -> Prop} (b1 b2 : bool) {r rg} :
    Proper (@eq_itree E R1 R1 eq ==> eq_itree eq ==> flip impl)
           (gpaco2 (pi_secure_eqit_ Label priv RS b1 b2 l id) (eqitC RS b1 b2) r rg ).
Proof.
  eapply geuttgen_cong_secure_eqit; eauto; intros; subst; auto.
Qed.

Global Instance pi_eqit_secure_eq_itree_proper {E} {Label priv l} {R1 R2 : Type} {RS : R1 -> R2 -> Prop} (b1 b2 : bool) :
   Proper (@eutt E R1 R1 eq ==> eutt eq ==> flip impl)
          (pi_eqit_secure Label priv RS true true l).
Proof.
  intros t1 t2 Ht12 t3 t4 Ht34. intros Hsec.
  apply pi_eqit_secure_RR_imp with (RR1 := rcompose RS eq).
  { intros. inv H. auto. }
  eapply pi_eqit_secure_mixed_trans. 2: { symmetry in Ht34. apply Ht34. }
  apply pi_eqit_secure_sym in Hsec. apply pi_eqit_secure_sym.
  symmetry in Ht12.
  apply pi_eqit_secure_RR_imp with (RR1 := rcompose (flip RS) eq).
  { intros. inv H. auto. }
  eapply pi_eqit_secure_mixed_trans; eauto.
Qed.

Global Instance pi_eqit_secure_eutt_proper {E} {Label priv l} {R1 R2 : Type} {RS : R1 -> R2 -> Prop} (b1 b2 : bool) :
   Proper (@eq_itree E R1 R1 eq ==> eq_itree eq ==> flip impl)
          (pi_eqit_secure Label priv RS b1 b2 l).
Proof.
  repeat intro. ginit. rewrite H, H0. gfinal. eauto.
Qed.

Lemma pi_eqit_secure_ret E Label priv l b1 b2 R1 R2 (RR : R1 -> R2 -> Prop) r1 r2 :
  RR r1 r2 -> @pi_eqit_secure E R1 R2 Label priv RR b1 b2 l (Ret r1) (Ret r2).
Proof.
  intros; pfold; constructor; auto.
Qed.

Lemma pi_eqit_secure_bind E Label priv l b1 b2 R1 R2 S1 S2 (RR : R1 -> R2 -> Prop) (RS : S1 -> S2 -> Prop) k1 k2 :
  forall (t1 : itree E R1) (t2 : itree E R2),
    (forall (r1 : R1) (r2 : R2), RR r1 r2 -> pi_eqit_secure Label priv RS b1 b2 l (k1 r1) (k2 r2) ) ->
    pi_eqit_secure Label priv RR b1 b2 l t1 t2 ->
    pi_eqit_secure Label priv RS b1 b2 l (ITree.bind t1 k1) (ITree.bind t2 k2).
Proof.
  ginit. gcofix CIH. intros. pinversion H1.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    repeat rewrite bind_ret_l. gfinal. right. eapply paco2_mon; try apply H0; auto.
    intros; contradiction.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    repeat rewrite bind_tau. gstep. constructor. gfinal. left. eapply CIH; eauto.
  - apply simpobs in H. apply simpobs in H2.  rewrite H2. rewrite H. rewrite bind_tau.
    gstep. constructor; auto. gfinal. left. eapply CIH; eauto.
    pfold. red. cbn. pstep_reverse.
  - apply simpobs in H. apply simpobs in H2.  rewrite H2. rewrite H. rewrite bind_tau.
    gstep. constructor; auto. gfinal. left. eapply CIH; eauto.
    pfold. red. cbn. pstep_reverse.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    repeat rewrite bind_vis. gstep. constructor; auto.
    gfinal. left. eapply CIH; eauto. apply H3.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    rewrite bind_vis. rewrite bind_tau. gstep. red. cbn. unpriv_pi.
    gfinal. left. eapply CIH; eauto. apply H3.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    rewrite bind_vis. rewrite bind_tau. gstep. red. cbn. unpriv_pi.
    gfinal. left. eapply CIH; eauto. apply H3.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    repeat rewrite bind_vis. gstep. red. cbn. unpriv_pi.
    gfinal. left. eapply CIH; eauto. apply H3.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    rewrite bind_vis. gstep. red. unpriv_pi.
    gfinal. left. eapply CIH; eauto. pfold. red. cbn. pstep_reverse.
  - apply simpobs in H. apply simpobs in H2. rewrite H. rewrite H2.
    rewrite bind_vis. gstep. red. unpriv_pi.
    gfinal. left. eapply CIH; eauto. pfold. red. cbn. pstep_reverse.
Qed.

Lemma pi_eqit_secure_iter_bind_aux:
  forall (E : Type -> Type) (B2 B1 A1 A2 : Type) (RA : A1 -> A2 -> Prop)
    (RB : B1 -> B2 -> Prop) (b1 b2 : bool) (Label : Preorder)
    (priv : forall A : Type, E A -> L) (l : L) (body1 : A1 -> itree E (A1 + B1))
    (body2 : A2 -> itree E (A2 + B2)) (r : itree E B1 -> itree E B2 -> Prop),
    (forall (a1 : A1) (a2 : A2), RA a1 a2 -> r (ITree.iter body1 a1) (ITree.iter body2 a2)) ->
    forall (t1 : itree E (A1 + B1)) (t2 : itree E (A2 + B2)),
      paco2 (pi_secure_eqit_ Label priv (HeterogeneousRelations.sum_rel RA RB) b1 b2 l id) bot2 t1
            t2 ->
      gpaco2 (pi_secure_eqit_ Label priv RB b1 b2 l id) (eqitC RB b1 b2) r r
             (ITree.bind t1
                         (fun lr : A1 + B1 =>
                            match lr with
                            | inl l0 => Tau (ITree.iter body1 l0)
                            | inr r0 => Ret r0
                            end))
             (ITree.bind t2
                         (fun lr : A2 + B2 =>
                            match lr with
                            | inl l0 => Tau (ITree.iter body2 l0)
                            | inr r0 => Ret r0
                            end)).
Proof.
  intros E B2 B1 A1 A2 RA RB b1 b2 Label priv l body1 body2 r CIH t1 t2 H2.
  generalize dependent t2. revert t1. gcofix CIH'. intros t1 t2 Ht12.
  pinversion Ht12; apply simpobs in H; apply simpobs in H0.
  - rewrite H, H0. repeat rewrite bind_ret_l. inv H1.
    + gstep. constructor. gfinal. left. apply CIH'0. eapply CIH; eauto.
    + gstep. constructor; auto.
  - rewrite H, H0. repeat rewrite bind_tau. gstep. constructor.
    gfinal. left. eapply CIH'; eauto.
  - rewrite H. rewrite <- itree_eta in H0. rewrite H0. rewrite bind_tau. gstep.
    constructor; auto. gfinal.
    left. eapply CIH'; eauto.
  - rewrite H0. rewrite <- itree_eta in H. rewrite H. rewrite bind_tau. gstep.
    constructor; auto. gfinal.
    left. eapply CIH'; eauto.
  - rewrite H, H0. repeat rewrite bind_vis. gstep. constructor; auto.
    intros. gfinal. left. eauto.
  - rewrite H, H0. rewrite bind_vis, bind_tau.  gstep. unpriv_pi; auto.
    intros. gfinal. left. eauto.
  - rewrite H, H0. rewrite bind_vis, bind_tau.  gstep. unpriv_pi; auto.
    intros. gfinal. left. eauto.
  - rewrite H, H0. repeat rewrite bind_vis. gstep. unpriv_pi.
    gfinal. left. eauto.
  - rewrite H. rewrite <- itree_eta in H0. rewrite H0. rewrite bind_vis.
    gstep. unpriv_pi. gfinal. left. eauto.
  - rewrite H0. rewrite <- itree_eta in H. rewrite H. rewrite bind_vis.
    gstep. unpriv_pi. gfinal. left. eauto.
Qed.

Lemma secure_eqit_iter E A1 A2 B1 B2 (RA : A1 -> A2 -> Prop) (RB : B1 -> B2 -> Prop)
                           b1 b2 Label priv l
                           (body1 : A1 -> itree E (A1 + B1) ) (body2 : A2 -> itree E (A2 + B2) ):
  (forall a1 a2, RA a1 a2 -> pi_eqit_secure Label priv (HeterogeneousRelations.sum_rel RA RB) b1 b2 l (body1 a1) (body2 a2) ) ->
                           forall (a1 : A1) (a2 : A2), RA a1 a2 ->
    pi_eqit_secure Label priv RB b1 b2 l (ITree.iter body1 a1) (ITree.iter body2 a2).
Proof.
  intro Hbody. ginit. gcofix CIH. intros. rewrite unfold_iter. rewrite unfold_iter.
  apply Hbody in H0. pinversion H0; apply simpobs in H; apply simpobs in H1.
  - rewrite H. rewrite H1. repeat rewrite bind_ret_l. inv H2.
    + gstep. constructor. gfinal. left. eapply CIH; eauto.
    + gstep. constructor; auto.
  - rewrite H. rewrite H1. repeat rewrite bind_tau. gstep.
    constructor. eapply pi_eqit_secure_iter_bind_aux; eauto.
  - rewrite H. rewrite bind_tau. gstep. constructor; auto.
    eapply pi_eqit_secure_iter_bind_aux; eauto.
    assert (t1 ≈ body1 a1).
    { rewrite H. rewrite tau_eutt. reflexivity. }
    inv CHECK. rewrite <- itree_eta in H1. rewrite H1. auto.
  - rewrite H1. rewrite bind_tau. gstep. constructor; auto.
    eapply pi_eqit_secure_iter_bind_aux; eauto. rewrite H.
    rewrite <- itree_eta. apply H2.
  - rewrite H, H1. repeat rewrite bind_vis. gstep. constructor; auto.
    intros. red.
    eapply pi_eqit_secure_iter_bind_aux; eauto.
  - rewrite H, H1. rewrite bind_vis, bind_tau. gstep. unpriv_pi.
    eapply pi_eqit_secure_iter_bind_aux; eauto.
  - rewrite H, H1. rewrite bind_vis, bind_tau. gstep. unpriv_pi.
    eapply pi_eqit_secure_iter_bind_aux; eauto.
  - rewrite H, H1. repeat rewrite bind_vis. gstep. unpriv_pi.
    eapply pi_eqit_secure_iter_bind_aux; eauto.
  - rewrite H. rewrite bind_vis. gstep. unpriv_pi.
    eapply pi_eqit_secure_iter_bind_aux; eauto.
    rewrite H1. rewrite <- itree_eta. apply H2.
  - rewrite H1. rewrite bind_vis. gstep. unpriv_pi. red.
    rewrite H. rewrite <- itree_eta.
    eapply pi_eqit_secure_iter_bind_aux; eauto.
Qed.


Require Export SystemFR.EquivalentStar.

Lemma equivalent_match:
  forall t v tn t0 ts,
    is_nat_value v ->
    tn ~>* v ->
    is_erased_term tn ->
    is_erased_term t0 ->
    is_erased_term ts ->
    wf tn 0 ->
    wf t0 0 ->
    wf ts 1 ->
    pfv tn term_var = nil ->
    pfv t0 term_var = nil ->
    pfv ts term_var = nil ->
    (v = zero -> [ t0 ≡ t ]) ->
    (forall v', v = succ v' -> [ open 0 ts v' ≡ t ]) ->
    [ tmatch tn t0 ts ≡ t ].
Proof.
  inversion 1; repeat step || t_invert_star;
    try solve [ eapply equivalent_trans; try eassumption; equivalent_star ].
Qed.

Lemma equivalent_match_zero:
  forall n e1 e2,
    is_erased_term n ->
    is_erased_term e1 ->
    is_erased_term e2 ->
    wf n 0 ->
    wf e1 0 ->
    wf e2 1 ->
    pfv n term_var = nil ->
    pfv e1 term_var = nil ->
    pfv e2 term_var = nil ->
    n ~>* zero ->
    [ tmatch n e1 e2 ≡ e1 ].
Proof.
  intros; apply equivalent_star; repeat step || list_utils;
    eauto using star_trans with smallstep cbvlemmas.
Qed.

Lemma equivalent_match_zero2:
  forall n e1 e2 e,
    n ~>* zero ->
    [ tmatch n e1 e2 ≡ e ] ->
    [ e1 ≡ e ].
Proof.
  intros.
  eapply equivalent_trans; try eassumption.
  apply equivalent_sym.
  apply equivalent_match_zero; unfold equivalent_terms in *; repeat step || list_utils.
Qed.

Lemma equivalent_match_succ:
  forall n e1 e2 v,
    is_erased_term n ->
    is_erased_term e1 ->
    is_erased_term e2 ->
    is_erased_term v ->
    wf n 0 ->
    wf e1 0 ->
    wf e2 1 ->
    wf v 0 ->
    pfv n term_var = nil ->
    pfv e1 term_var = nil ->
    pfv e2 term_var = nil ->
    cbv_value v ->
    n ~>* succ v ->
    [ tmatch n e1 e2 ≡ open 0 e2 v ].
Proof.
  intros.
  apply equivalent_star; repeat step || list_utils;
    eauto using star_trans, star_one with cbvlemmas smallstep.
Qed.

Lemma equivalent_match_succ2:
  forall n e1 e2 v e,
    cbv_value v ->
    is_erased_term v ->
    wf v 0 ->
    n ~>* succ v ->
    [ tmatch n e1 e2 ≡ e ] ->
    [ open 0 e2 v ≡ e ].
Proof.
  intros.
  eapply equivalent_trans; try eassumption.
  apply equivalent_sym.
  apply equivalent_match_succ; unfold equivalent_terms in *; repeat step || list_utils.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
      UList.v

      Definition of list with distinct elements

      Definition: ulist

                                     Laurent.Thery@inria.fr (2006)
************************************************************************)
Require Import List.
Require Import Arith.
Require Import Permutation.
Require Import ListSet.

Section UniqueList.
Variable A : Set.
Variable eqA_dec : forall (a b : A),  ({ a = b }) + ({ a <> b }).
(* A list is unique if there is not twice the same element in the list *)

Definition ulist (l1 : list A) := NoDup l1.
Definition ulist_nil := NoDup_nil.
Definition ulist_cons a l (H : ~ In a l) (H1 : ulist l) := NoDup_cons a H H1.
Hint Unfold ulist : core.
Hint Constructors NoDup : core.

(* Inversion theorem *)

Theorem ulist_inv: forall a l, ulist (a :: l) ->  ulist l.
  intros a l H; inversion H; auto.
Qed.
(* The append of two unique list is unique if the list are distinct *)

Theorem ulist_app:
  forall l1 l2,
    ulist l1 ->
    ulist l2 -> (forall (a : A), In a l1 -> In a l2 ->  False) ->  ulist (l1 ++ l2).
  intros L1; elim L1; simpl; auto.
  intros a l H l2 H0 H1 H2; apply NoDup_cons; simpl; auto.
  red; intros H3; case in_app_or with ( 1 := H3 ); auto; intros H4.
  inversion H0; auto.
  apply H2 with a; auto.
  apply H; auto.
  apply ulist_inv with ( 1 := H0 ); auto.
  intros a0 H3 H4; apply (H2 a0); auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv:
  forall l1 l2 (a : A), ulist (l1 ++ l2) -> In a l1 -> In a l2 ->  False.
  intros l1; elim l1; simpl; auto.
  intros a l H l2 a0 H0 [H1|H1] H2.
  inversion H0 as [|a1 l0 H3 H4 H5]; auto.
  case H3; rewrite H1; auto with datatypes.
  apply (H l2 a0); auto.
  apply ulist_inv with ( 1 := H0 ); auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv_l: forall (l1 l2 : list A), ulist (l1 ++ l2) ->  ulist l1.
Proof.
  intros l1 l2.
  generalize dependent l1.
  induction l2; intros l1 H.
  - rewrite app_nil_r in H. assumption.
  - apply NoDup_remove_1 in H; auto.
Qed.
(* Iinversion theorem the appended list *)

Theorem ulist_app_inv_r: forall (l1 l2 : list A), ulist (l1 ++ l2) ->  ulist l2.
  intros l1; elim l1; simpl; auto.
  intros a l H l2 H0; inversion H0; auto.
Qed.
(* Uniqueness is decidable *)

Definition ulist_dec: forall l,  ({ ulist l }) + ({ ~ ulist l }).
Proof.
  apply ListDec.NoDup_dec; auto.
Defined.
(* Uniqueness is compatible with permutation *)

Theorem ulist_perm:
  forall (l1 l2 : list A), Permutation l1 l2 -> ulist l1 ->  ulist l2.
Proof.
  apply Permutation_NoDup.
Qed.

Theorem ulist_def:
  forall l a,
    In a l -> ulist l ->  ~ (exists l1 , Permutation l (a :: (a :: l1)) ).
  intros l a H H0 [l1 H1].
  absurd (ulist (a :: (a :: l1))); auto.
  intros H2; inversion_clear H2; simpl; auto with datatypes.
  apply ulist_perm with ( 1 := H1 ); auto.
Qed.

Theorem ulist_incl_permutation:
  forall (l1 l2 : list A),
    ulist l1 -> incl l1 l2 ->  (exists l3 , Permutation l2 (l1 ++ l3) ).
Proof with auto with datatypes.
  intros l1; elim l1; simpl...
  intros l2 H H0; exists l2; simpl...
  intros a l H l2 H0 H1...
  case (in_permutation_ex _ a l2)...
  intros l3 Hl3.
  case (H l3)...
  apply ulist_inv with ( 1 := H0 )...
  intros b Hb.
  assert (H2: In b (a :: l3)).
  apply Permutation_in with ( 1 := Permutation_sym Hl3 )...
  simpl in H2 |-; case H2; intros H3; simpl...
  inversion_clear H0 as [|c lc Hk1]...
  case Hk1; subst a...
  intros l4 H4; exists l4.
  apply perm_trans with (a :: l3)...
  apply Permutation_sym...
Qed.

Theorem ulist_eq_permutation:
  forall (l1 l2 : list A),
    ulist l1 -> incl l1 l2 -> length l1 = length l2 ->  Permutation l1 l2.
Proof with auto with arith.
  intros l1 l2 H1 H2 H3.
  case (ulist_incl_permutation l1 l2)...
  intros l3 H4.
  assert (H5: l3 = @nil A).
  generalize (Permutation_length H4); rewrite app_length, H3.
  rewrite Nat.add_comm; case l3; simpl...
  intros a l H5; absurd (lt (length l2) (length l2))...
  pattern (length l2) at 2; rewrite H5...
  replace l1 with (app l1 l3)...
  apply Permutation_sym...
  rewrite H5, app_nil_end...
Qed.

Theorem ulist_incl_length:
  forall (l1 l2 : list A), ulist l1 -> incl l1 l2 ->  le (length l1) (length l2).
  intros l1 l2 H1 Hi; case ulist_incl_permutation with ( 2 := Hi ); auto.
  intros l3 Hl3; rewrite Permutation_length with ( 1 := Hl3 ); auto.
  rewrite app_length; simpl; auto with arith.
Qed.

Theorem ulist_incl2_permutation:
  forall (l1 l2 : list A),
    ulist l1 -> ulist l2 -> incl l1 l2 -> incl l2 l1  ->  Permutation l1 l2.
  intros l1 l2 H1 H2 H3 H4.
  apply ulist_eq_permutation; auto.
  apply Nat.le_antisymm; apply ulist_incl_length; auto.
Qed.

Theorem ulist_incl_length_strict:
  forall (l1 l2 : list A),
    ulist l1 -> incl l1 l2 -> ~ incl l2 l1 ->  lt (length l1) (length l2).
Proof with auto with arith.
  intros l1 l2 H1 Hi Hi0; case ulist_incl_permutation with ( 2 := Hi )...
  intros l3 Hl3; rewrite Permutation_length with ( 1 := Hl3 )...
  rewrite app_length; simpl...
  generalize Hl3; case l3; simpl...
  rewrite <- app_nil_end...
  intros H2; case Hi0...
  intros a HH; apply Permutation_in with ( 1 := H2 )...
  intros a l Hl0; (rewrite Nat.add_comm; simpl; rewrite Nat.add_comm; auto with arith).
Qed.

Theorem in_inv_dec:
  forall (a b : A) l, In a (cons b l) ->  a = b \/ ~ a = b /\ In a l.
  intros a b l H; case (eqA_dec a b); auto; intros H1.
  right; split; auto; inversion H; auto.
  case H1; auto.
Qed.

Theorem in_ex_app_first:
  forall (a : A) (l : list A),
    In a l ->
    (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2) /\ ~ In a l1  ).
  intros a l; elim l; clear l; auto.
  intros H; case H.
  intros a1 l H H1; auto.
  generalize (in_inv_dec _ _ _ H1); intros [H2|[H2 H3]].
  exists (nil (A:=A)); exists l; simpl; split; auto.
  f_equal; auto.
  case H; auto; intros l1 [l2 [Hl2 Hl3]]; exists (a1 :: l1); exists l2; simpl;
    split; auto.
  f_equal; auto.
  intros H4; case H4; auto.
Qed.

Theorem nth_ulist: forall a i j (l: list A), i < length l -> j < length l ->
                                        ulist l -> nth i l a = nth j l a -> i = j.
  intros a i j l; generalize i j; elim l; simpl; clear l i j.
  intros i j H; contradict H; auto with arith.
  intros b l1 Rec i j; case i; case j; auto with arith; clear i j.
  intros j _ H1 H2 H3; absurd (In b l1); auto.
  inversion H2; auto.
  subst; apply nth_In; auto with arith.
  intros i H1 _ H2 H3; absurd (In b l1); auto.
  inversion H2; auto.
  subst; apply nth_In; auto with arith.
  intros j i H1 H2 H3 H4; inversion H3; auto with arith.
Qed.

End UniqueList.

Arguments ulist [A].
Global Hint Unfold ulist : core.
Global Hint Constructors NoDup : core.

Theorem ulist_map:
  forall (A B : Set) (f : A ->  B) l,
    (forall x y, (In x l) -> (In y l) ->  f x = f y ->  x = y) -> ulist l ->  ulist (map f l).
Proof.
  intros a b f l Hf Hl; generalize Hf; elim Hl; clear Hf;  auto.
  simpl; auto.
  intros a1 l1 H1 H2 H3 Hf; simpl.
  apply ulist_cons; auto with datatypes.
  contradict H1.
  case in_map_inv with ( 1 := H1 ); auto.
  intros b1 [Hb1 Hb2].
  replace a1 with b1; auto with datatypes.
Qed.

Theorem ulist_list_prod:
  forall (A : Set) (l1 l2 : list A),
    ulist l1 -> ulist l2 ->  ulist (list_prod l1 l2).
Proof with auto.
  intros A l1 l2 Hl1 Hl2; elim Hl1; simpl...
  intros a l H1 H2 H3; apply ulist_app...
  apply ulist_map...
  intros x y _ _ H; inversion H...
  intros p Hp1 Hp2; case H1.
  case in_map_inv with ( 1 := Hp1 ); intros a1 [Ha1 Ha2]...
  case in_list_prod_inv with ( 1 := Hp2 ); intros b1 [c1 [Hb1 [Hb2 Hb3]]]...
  replace a with b1...
  rewrite Ha2 in Hb1; injection Hb1...
Qed.


(* -*- coq-prog-args: ("-nois") -*- *)
(* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *)
(* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0
   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *)
Declare ML Module "ltac_plugin".
Set Default Proof Mode "Classic".
Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
Reserved Notation "x = y" (at level 70, no associativity).
Delimit Scope type_scope with type.
Bind Scope type_scope with Sortclass.
Open Scope type_scope.
Axiom admit : forall {T}, T.
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Reserved Infix "o" (at level 40, left associativity).
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
Global Set Primitive Projections.
Delimit Scope morphism_scope with morphism.
Record PreCategory :=
  { object :> Type;
    morphism : object -> object -> Type;

    identity : forall x, morphism x x;
    compose : forall s d d',
                morphism d d'
                -> morphism s d
                -> morphism s d'
    where "f 'o' g" := (compose f g) }.
Infix "o" := (@compose _ _ _ _) : morphism_scope.
Set Implicit Arguments.
Local Open Scope morphism_scope.
Record Functor (C D : PreCategory) :=
  { object_of :> C -> D;
    morphism_of : forall s d, morphism C s d
                              -> morphism D (object_of s) (object_of d) }.
Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) :=
  { morphism_inverse : morphism C d s }.
Record NaturalTransformation C D (F G : Functor C D) := { components_of :> forall c, morphism D (F c) (G c) }.
Definition composeT C D (F F' F'' : Functor C D) (T' : NaturalTransformation F' F'') (T : NaturalTransformation F F')
: NaturalTransformation F F''.
  exact admit.
Defined.
Definition functor_category (C D : PreCategory) : PreCategory.
  exact (@Build_PreCategory (Functor C D)
                            (@NaturalTransformation C D)
                            admit
                            (@composeT C D)).
Defined.
Goal forall (C D : PreCategory) (G G' : Functor C D)
            (T : @NaturalTransformation C D G G')
            (H : @IsIsomorphism (@functor_category C D) G G' T)
            (x : C),
       @paths (morphism D (G x) (G x))
              (@compose D (G x) (G' x) (G x)
                        ((@morphism_inverse (@functor_category C D) G G' T H) x)
                        (T x)) (@identity D (G x)).
  intros.
  (** This [change] succeeded, but did not progress, in 07e4438bd758c2ced8caf09a6961ccd77d84e42b, because [T0 x o T1 x] was not found in the goal *)
  let T0 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T0) end in
  let T1 := match goal with |- context[components_of ?T0 ?x o components_of ?T1 ?x] => constr:(T1) end in
  progress change (T0 x o T1 x) with ((fun y => y) (T0 x o T1 x)).


From stdpp Require Import list.
From Perennial.Helpers Require Import List ListLen Map.
From Perennial.Helpers Require Import NamedProps.

From iris.proofmode Require Import tactics.
From iris.bi.lib Require Import fractional.
From Perennial.base_logic.lib Require Import own.
From Perennial.algebra Require Import auth_map.

Set Default Goal Selector "!".
Set Default Proof Using "Type".

Class alistG Σ A :=
  { alist_inG :> mapG Σ nat A; }.

Definition alistΣ A : gFunctors := #[ mapΣ nat A ].

#[global]
Instance subG_alistΣ Σ A : subG (alistΣ A) Σ → alistG Σ A.
Proof. solve_inG. Qed.

Section list.
Context {A:Type}.
Context `{!alistG Σ A}.
Implicit Types (γ:gname) (l:list A) (i:nat) (x:A).

Definition list_el γ i x := ptsto_ro γ i x.
Definition list_subseq γ start xs: iProp Σ :=
  [∗ list] i↦x ∈ xs, list_el γ (start+i) x.

Definition list_ctx γ q l: iProp Σ :=
  "Hctx" ∷ map_ctx γ q (map_seq 0 l) ∗
  "Hels" ∷ [∗ list] i↦x ∈ l, list_el γ i x.

Global Instance list_ctx_timeless γ q l : Timeless (list_ctx γ q l).
Proof. apply _. Qed.
Global Instance list_el_timeless γ i x : Timeless (list_el γ i x).
Proof. apply _. Qed.
Global Instance list_el_persistent γ i x : Persistent (list_el γ i x).
Proof. apply _. Qed.
Global Instance list_ctx_fractional γ l : Fractional (λ q, list_ctx γ q l).
Proof. apply _. Qed.

Theorem alist_alloc l :
  ⊢ |==> ∃ γ, list_ctx γ 1 l.
Proof.
  (* the proof allocates each element individually to keep track of all of the
  initial [ptsto_ro] facts *)
  induction l as [|x l] using rev_ind.
  - iMod (map_init ∅) as (γ) "Hctx".
    iModIntro.
    iExists _; iFrame.
    rewrite big_sepL_nil //.
  - iMod IHl as (γ) "Hctx".
    iExists γ.
    iNamed "Hctx".
    iMod (map_alloc_ro (length l) x with "Hctx") as "[Hctx Hx]".
    { apply lookup_map_seq_None. right. lia. }
    iModIntro.
    rewrite /list_ctx map_seq_snoc.
    iFrame "Hctx".
    rewrite big_sepL_app; iFrame.
    simpl.
    replace (length l + 0) with (length l) by lia.
    iFrame.
Qed.

Theorem alist_lookup_el {γ l q} i x :
  l !! i = Some x →
  list_ctx γ q l -∗ list_el γ i x.
Proof.
  iIntros (Hlookup) "Hctx"; iNamed "Hctx".
  iDestruct (big_sepL_lookup with "Hels") as "Hx"; eauto.
Qed.

Theorem alist_lookup_subseq {γ q} l (n m: nat) :
  n ≤ m ≤ length l →
  list_ctx γ q l -∗
  list_subseq γ n (subslice n m l).
Proof.
  iIntros (Hbound) "Hctx".
  replace m with (n + (m - n)) by lia.
  remember (m-n) as k.
  assert (n + k ≤ length l) by lia.
  clear dependent m.
  generalize dependent k; intros k ?.
  (iInduction k as [|k] "IH" forall (n H)).
  - rewrite Nat.add_0_r.
    rewrite subslice_zero_length /list_subseq //=.
  - list_elem l n as x.
    iDestruct (alist_lookup_el n with "Hctx") as "#Hx"; eauto.
    replace (n + S k) with (S n + k) by lia.
    erewrite subslice_S; eauto; try lia.
    rewrite /list_subseq /=.
    iDestruct ("IH" $! (S n) with "[%] Hctx") as "Hels".
    { lia. }
    rewrite Nat.add_0_r.
    setoid_rewrite <- Nat.add_succ_comm.
    iFrame "# ∗".
Qed.

Lemma list_subseq_nil {γ} n : ⊢ list_subseq γ n [].
Proof.
  rewrite /list_subseq big_sepL_nil //.
Qed.

Theorem alist_lookup {γ q} l i x :
  list_ctx γ q l -∗ list_el γ i x -∗ ⌜l !! i = Some x⌝.
Proof.
  iIntros "Hctx Hel"; iNamed "Hctx".
  iDestruct (map_ro_valid with "Hctx Hel") as %Hlookup.
  rewrite lookup_map_seq_0 in Hlookup.
  auto.
Qed.

Theorem alist_agree {γ} l i x1 x2 :
  list_el γ i x1 -∗
  list_el γ i x2 -∗
  ⌜x1 = x2⌝.
Proof.
  rewrite /list_el.
  iApply ptsto_ro_agree.
Qed.

Theorem alist_app1 {γ l} x :
  list_ctx γ 1 l ==∗
  list_ctx γ 1 (l ++ [x]) ∗ list_el γ (length l) x.
Proof.
  iNamed 1.
  iMod (map_alloc_ro (length l) x with "Hctx") as "[Hctx #Hx]".
  { rewrite lookup_map_seq_None. right. lia. }
  iModIntro.
  rewrite /list_ctx map_seq_snoc.
  iFrame "# ∗".
  simpl.
  rewrite Nat.add_0_r.
  iFrame "Hx".
Qed.

Theorem alist_app {γ} l xs :
  list_ctx γ 1 l ==∗
  list_ctx γ 1 (l ++ xs) ∗ list_subseq γ (length l) xs.
Proof.
  iIntros "Hctx".
  iInduction xs as [|x xs] "IH" using rev_ind.
  - rewrite app_nil_r; iFrame.
    iModIntro.
    rewrite /list_subseq //=.
  - iMod ("IH" with "Hctx") as "[Hctx Hsubseq]".
    iMod (alist_app1 x with "Hctx") as "[Hctx Hx]".
    iModIntro.
    rewrite -app_assoc.
    iFrame.
    simpl.
    rewrite right_id.
    replace (length l + (length xs + 0)) with (length (l ++ xs)).
    { iFrame. }
    rewrite app_length; lia.
Qed.

Theorem alist_subseq_lookup {γ} l start xs :
  list_ctx γ 1 l -∗ list_subseq γ start xs -∗
  ⌜subslice start (start + length xs)%nat l = xs⌝.
Proof.
  iIntros "Hctx Hxs".
  (iInduction xs as [|x xs] "IH" forall (start)).
  - simpl.
    rewrite Nat.add_0_r.
    rewrite subslice_zero_length //.
  - simpl.
    iEval (rewrite /list_subseq big_sepL_cons) in "Hxs".
    iDestruct "Hxs" as "[Hx Hxs]".
    setoid_rewrite <- Nat.add_succ_comm.
    rewrite Nat.add_0_r.
    iDestruct (alist_lookup with "Hctx Hx") as %Hx.
    iDestruct ("IH" with "Hctx Hxs") as %Hxs.
    iPureIntro.
    erewrite subslice_S by (eauto; lia).
    congruence.
Qed.

End list.

Typeclasses Opaque list_ctx.