Require Import Burrow.trees.
Require Import Burrow.ra.
From iris.prelude Require Import options.
From iris.proofmode Require Import tactics.
From iris.base_logic Require Export base_logic.

Require Import cpdt.CpdtTactics.
Require Import coq_tricks.Deex.
Require Import Burrow.tpcms.

Inductive Free (M: Type) `{!EqDecision M} :=
  | Empty : Free M
  | Have : M -> nat -> Free M
  | Conflict : Free M
.
Arguments Empty {_}%type_scope {EqDecision0}.
Arguments Have {_}%type_scope {EqDecision0} _ _%nat_scope.
Arguments Conflict {_}%type_scope {EqDecision0}.

Instance free_op {M} `{!EqDecision M} : Op (Free M) := λ a b , match a, b with
  | Empty, y => y
  | Conflict, y => Conflict
  | Have m x, Empty => Have m x
  | Have m x, Have n y => if decide (m = n) then Have m (x + y + 1) else Conflict
  | Have _ _, Conflict => Conflict
  end
.

Instance free_op_comm {M} `{!EqDecision M} : Comm (=) (@free_op M EqDecision0).
Proof. unfold Comm. intros. unfold free_op. destruct x, y; trivial.
  repeat case_decide; trivial.
  - f_equal. + symmetry. trivial. + lia.
  - crush.
  - crush.
Qed.

Instance free_op_assoc {M} `{!EqDecision M} : Assoc (=) (@free_op M EqDecision0).
Proof. unfold Assoc. intros. unfold free_op. destruct x, y, z; try case_decide; intuition.
  - case_decide; trivial. case_decide.
    + f_equal. lia.
    + crush.
  - case_decide; trivial. case_decide; trivial. crush.
Qed.

Inductive Exc (M: Type) :=
  | Unknown : Exc M
  | Yes : M -> Exc M
  | Fail : Exc M
.
Arguments Unknown {_}%type_scope.
Arguments Yes {_}%type_scope _.
Arguments Fail {_}%type_scope.

Instance exc_op {M} : Op (Exc M) := λ a b , match a, b with
  | Unknown, y => y
  | Fail, y => Fail
  | Yes m, Unknown => Yes m
  | Yes _, _ => Fail
  end
.

Instance exc_op_comm {M} `{!EqDecision M} : Comm (=) (@exc_op M).
Proof. unfold Comm. intros. unfold exc_op. destruct x, y; trivial.
Qed.

Instance exc_op_assoc {M} `{!EqDecision M} : Assoc (=) (@exc_op M).
Proof. unfold Assoc. intros. unfold exc_op. destruct x, y, z; trivial.
Qed.

Inductive RwLock (M: Type) `{!EqDecision M} :=
  | Rwl : (Exc (bool * Z * M)) -> Exc () -> Exc () -> nat -> Free M -> RwLock M
.
Arguments Rwl {_}%type_scope {EqDecision0} _ _ _ _%nat_scope _.

Instance rw_op {M} `{!EqDecision M} : Op (RwLock M) := λ a b , match a, b with
  | Rwl c ep eg sp sg, Rwl c' ep' eg' sp' sg' =>
      Rwl (c ⋅ c') (ep ⋅ ep') (eg ⋅ eg') (sp + sp') (sg ⋅ sg')
  end
.

Instance rw_op_comm {M} `{!EqDecision M} : Comm (=) (@rw_op M EqDecision0).
Proof. unfold Comm. intros. unfold rw_op. destruct x, y.
  f_equal.
  - apply exc_op_comm.
  - apply exc_op_comm.
  - apply exc_op_comm.
  - lia.
  - apply free_op_comm.
Qed.

Instance rw_op_assoc {M} `{!EqDecision M} : Assoc (=) (@rw_op M EqDecision0).
Proof. unfold Assoc. intros. unfold rw_op. destruct x, y, z.
  f_equal.
  - apply exc_op_assoc.
  - apply exc_op_assoc.
  - apply exc_op_assoc.
  - lia.
  - apply free_op_assoc.
Qed.

Definition Central {M: Type} `{!EqDecision M} (e: bool) (r: Z) (x: M) : RwLock M :=
  Rwl (Yes (e, r, x)) Unknown Unknown 0 (Empty).

Definition ExcPending {M: Type} `{!EqDecision M}: RwLock M :=
  Rwl Unknown (Yes ()) Unknown 0 (Empty).

Definition ExcGuard {M: Type} `{!EqDecision M}: RwLock M :=
  Rwl Unknown Unknown (Yes ()) 0 (Empty).

Definition ShPending {M: Type} `{!EqDecision M}: RwLock M :=
  Rwl Unknown Unknown Unknown 1 (Empty).

Definition ShGuard {M: Type} `{!EqDecision M} (m: M) : RwLock M :=
  Rwl Unknown Unknown Unknown 0 (Have m 0).

Definition free_count {M} `{!EqDecision M} (m: Free M) : nat :=
  match m with
  | Empty => 0
  | Have _ n => n + 1
  | Conflict => 0
  end.

Definition P {M} `{!EqDecision M} (rw: RwLock M) :=
  match rw with
  | Rwl _ Fail _ _ _ => False
  | Rwl _ _ Fail _ _ => False
  | Rwl _ _ _ _ Conflict => False
  | Rwl (Yes (e, r, x)) ep eg sp sg =>
         r = sp + (free_count sg)
      /\ (e = false -> ep = Unknown /\ eg = Unknown)
      /\ (e = true -> (ep = Yes () \/ eg = Yes ()) /\ ¬(ep = Yes() /\ eg = Yes()))
      /\ (eg = Yes () -> sg = Empty)
      /\ (match sg with Have m _ => x = m | _ => True end)
  | _ => False
  end.

Definition V {M} `{!EqDecision M} (rw: RwLock M) :=
  ∃ z , P (rw ⋅ z).

Definition rw_unit (M: Type) `{!EqDecision M} : RwLock M :=
  Rwl Unknown Unknown Unknown 0 Empty.

Definition I_defined {M} `{!EqDecision M} (rw: RwLock M) :=
  rw = rw_unit M \/ P rw.

Definition I {M} `{!EqDecision M} `{!TPCM M} (rw: RwLock M) :=
  match rw with
  | Rwl (Yes (_,_,x)) _ Unknown _ _ => x
  | _ => unit
  end.

Definition rw_mov {M} `{!EqDecision M} `{!TPCM M} (a b : RwLock M) :=
  ∀ p, I_defined (a ⋅ p) -> I_defined (b ⋅ p) /\ I (a ⋅ p) = I (b ⋅ p).

Lemma rw_unit_dot (M: Type) `{!EqDecision M} (a : RwLock M) :
  rw_op a (rw_unit M) = a.
Proof.
  unfold rw_unit. destruct a. unfold "⋅", rw_op. unfold "⋅", exc_op, free_op.
  f_equal; trivial.
  - destruct e; trivial.
  - destruct e0; trivial.
  - destruct e1; trivial.
  - lia.
  - destruct f; trivial.
Qed.

Lemma rw_init_valid {M} `{!EqDecision M} `{!TPCM M} (x: M)
  : P (Central false 0 x).
Proof.
  unfold P, Central, free_count. split; trivial.
  - intuition; discriminate.
Qed.

Lemma rw_mov_exc_begin {M} `{!EqDecision M} `{!TPCM M} rc x
  : rw_mov (Central false rc x) (Central true rc x ⋅ ExcPending).
Proof.
  unfold rw_mov. intros. unfold I_defined, I in *.
  destruct H.
  - exfalso. unfold "⋅", rw_op, rw_unit, Central in H. destruct p. inversion H.
      unfold "⋅", exc_op in H1. destruct e; discriminate.
  - split.
    + right. unfold P in *. unfold Central, ExcPending in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op in *. destruct e, e0, e1, f; try contradiction; crush.
    + unfold P in *. unfold Central, ExcPending in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op in *. destruct e, e0, e1, f; try contradiction; crush.
Qed.

Definition rw_exchange_cond {M} `{!EqDecision M} `{!TPCM M}
    (f: RwLock M) (m: M) (f': RwLock M) (m': M) :=
  ∀ p ,
    I_defined (f ⋅ p) -> I_defined (f' ⋅ p) /\ mov (dot m (I (f ⋅ p))) (dot m' (I (f' ⋅ p))).

Lemma rw_mov_exc_acquire {M} `{!EqDecision M} `{!TPCM M} (exc: bool) (x: M)
  : rw_exchange_cond
    (Central exc 0 x ⋅ ExcPending)
    (unit: M)
    (Central exc 0 x ⋅ ExcGuard)
    x.
Proof.
  unfold rw_exchange_cond. intro. intro. split.
  - unfold I_defined, "⋅", rw_op, Central, ExcGuard, ExcPending in *. destruct p.
      unfold "⋅", exc_op, free_op in *.  right. destruct H.
      + exfalso. unfold rw_unit in H. destruct e, e0, e1, f; inversion H.
      + destruct e, e0, e1, f; unfold P in *; intuition; try destruct exc; try destruct u; intuition; unfold free_count in *; try lia; intuition; try discriminate.
  - rewrite unit_dot_left. unfold I, I_defined in *. unfold "⋅", Central, ExcPending, ExcGuard, rw_op in *.
      destruct p. unfold "⋅", free_op, exc_op in *. destruct e, e1, e0; trivial;
        try (rewrite unit_dot);
        try (rewrite unit_dot_left);
        try (apply reflex);
        unfold P in H; destruct f; try (destruct u); try (destruct exc); unfold rw_unit in *; intuition; try (inversion H0).
Qed.

Lemma rw_mov_exc_release {M} `{!EqDecision M} `{!TPCM M} (exc: bool) (rc: Z) (x y: M)
  : rw_exchange_cond
    (Central exc rc y ⋅ ExcGuard)
    x
    (Central false rc x)
    (unit: M).
Proof.
  unfold rw_exchange_cond. intro. intro. split.
  - unfold I_defined, "⋅", rw_op, Central, ExcGuard, ExcPending in *. destruct p.
      unfold "⋅", exc_op, free_op in *.  right. destruct H.
      + exfalso. unfold rw_unit in H. destruct e, e0, e1, f; inversion H.
      + destruct e, e0, e1, f; unfold P; intuition; try destruct exc; try destruct u; crush.
  - rewrite unit_dot_left. unfold I, I_defined in *. unfold "⋅", Central, ExcPending, ExcGuard, rw_op in *.
      destruct p. unfold "⋅", free_op, exc_op in *. destruct e, e1, e0; trivial;
        try (rewrite unit_dot);
        try (rewrite unit_dot_left);
        try (apply reflex);
        unfold P in H; destruct f; try (destruct u); try (destruct exc); unfold rw_unit in *; intuition; try (inversion H0).
Qed.

Lemma rw_mov_shared_begin {M} `{!EqDecision M} `{!TPCM M} (exc: bool) (rc: Z) (x: M)
  : rw_mov
    (Central exc rc x)
    (Central exc (rc + 1) x ⋅ ShPending).
Proof.
  unfold rw_mov. intros. unfold I_defined, I in *.
  destruct H.
  - exfalso. unfold "⋅", rw_op, rw_unit, Central in H. destruct p. inversion H.
      unfold "⋅", exc_op in H1. destruct e; discriminate.
  - split.
    + right. unfold P in *. unfold Central, ShPending in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op, free_count in *. destruct e, e0, e1, f; try contradiction; try destruct exc; intuition; try lia.
    + unfold P in *. unfold Central, ShPending in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op in *. destruct e, e0, e1, f; try contradiction; crush.
Qed.

Lemma rw_mov_shared_acquire {M} `{!EqDecision M} `{!TPCM M} (rc: Z) (x: M)
  : rw_mov
    (Central false rc x ⋅ ShPending)
    (Central false rc x ⋅ ShGuard x).
Proof.
  unfold rw_mov. intros. unfold I_defined, I in *.
  destruct H.
  - exfalso. unfold "⋅", rw_op, rw_unit, Central in H. destruct p. inversion H.
  - split.
    + right. unfold P in *. unfold Central, ShPending, ShGuard in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op, free_count in *. destruct e, e0, e1, f; try contradiction; intuition; try lia; try discriminate.
        case_decide; intuition; try lia; try discriminate.
    + unfold P in *. unfold Central, ShPending, ShGuard in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op in *. destruct e, e0, e1, f; try contradiction; crush.
Qed.

Lemma rw_mov_shared_release {M} `{!EqDecision M} `{!TPCM M} (exc: bool) (rc: Z) (x y: M)
  : rw_mov
    (Central exc rc x ⋅ ShGuard y)
    (Central exc (rc - 1) x).
Proof.
  unfold rw_mov. intros. unfold I_defined, I in *.
  destruct H.
  - exfalso. unfold "⋅", rw_op, rw_unit, Central in H. destruct p. inversion H.
      unfold "⋅", exc_op in H1. destruct e; discriminate.
  - split.
    + right. unfold P in *. unfold Central, ShGuard in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op, free_count in *. destruct e, e0, e1, f, exc; try contradiction; try case_decide; intuition; try lia; try discriminate; try subst x; trivial.
    + unfold P in *. unfold Central, ShGuard in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op in *. destruct e, e0, e1, f; try contradiction; crush.
Qed.

Lemma rw_mov_shared_retry {M} `{!EqDecision M} `{!TPCM M} (exc: bool) (rc: Z) (x: M)
  : rw_mov
    (Central exc rc x ⋅ ShPending)
    (Central exc (rc - 1) x).
Proof.
  unfold rw_mov. intros. unfold I_defined, I in *.
  destruct H.
  - exfalso. unfold "⋅", rw_op, rw_unit, Central in H. destruct p. inversion H.
  - split.
    + right. unfold P in *. unfold Central, ShPending in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op, free_count in *. destruct e, e0, e1, f, exc; try contradiction; try case_decide; intuition; try lia.
    + unfold P in *. unfold Central, ShPending in *. destruct p.
      unfold "⋅", rw_op in *. unfold "⋅", exc_op, free_op in *. destruct e, e0, e1, f; try contradiction; crush.
Qed.

Definition rw_borrow_back_cond {M} `{!EqDecision M} `{!TPCM M} (f: RwLock M) (m: M)
  := ∀ p ,
    I_defined (f ⋅ p) -> ∃ z , (dot m z) = I (f ⋅ p).

Lemma rw_mov_shared_borrow {M} `{!EqDecision M} `{!TPCM M} (x: M)
  : rw_borrow_back_cond (ShGuard x) x.
Proof.
  unfold rw_borrow_back_cond. intros. exists unit. rewrite unit_dot.
  unfold ShGuard, "⋅", rw_op, I, I_defined in *. destruct p. destruct H.
  - exfalso. unfold rw_unit in H. inversion H. unfold "⋅" in H5. unfold free_op in H5.
      destruct f; try discriminate. case_decide; try discriminate.
  - unfold "⋅", exc_op, free_op in *. unfold P in H. destruct e, e0, e1, f; try contradiction;
      try (case_decide); try contradiction; try (destruct p); try (destruct p);
      try intuition; try (destruct u); try contradiction; unfold free_count in *; try lia;
      intuition; try discriminate; destruct b; intuition; destruct u0; intuition;
      try discriminate.
Qed.

Global Instance free_eqdec {M} `{!EqDecision M} : EqDecision (Free M).
Proof. solve_decision. Qed.

Global Instance exc_eqdec {M} `{!EqDecision M} : EqDecision (Exc M).
Proof. solve_decision. Qed.

Global Instance rwlock_eqdec {M} `{!EqDecision M} : EqDecision (RwLock M).
Proof. solve_decision. Qed.

Lemma rw_valid_monotonic {M} `{!EqDecision M} `{!TPCM M}
  (f: RwLock M) (g: RwLock M) : V (f ⋅ g) -> V f.
Proof.
  unfold V. intro. deex. exists (g ⋅ z). unfold "⋅" in *. rewrite rw_op_assoc. trivial. Qed.

Lemma rw_unit_valid {M} `{!EqDecision M} `{!TPCM M}
  : V (rw_unit M).
Proof.
  unfold V. exists (Central false 0 (unit: M)).
    unfold "⋅".
    rewrite rw_op_comm.
    rewrite rw_unit_dot. unfold P, rw_unit, Central. unfold free_count. crush.
Qed.

Lemma rw_mov_reflex {M} `{!EqDecision M} `{!TPCM M}
  (f: RwLock M) : rw_mov f f.
Proof.
  unfold rw_mov. intros. split; trivial. Qed.

Lemma rw_mov_trans {M} `{!EqDecision M} `{!TPCM M}
  (f g h: RwLock M) : rw_mov f g -> rw_mov g h -> rw_mov f h.
Proof. unfold rw_mov. intuition.
  - have q := H p. have q0 := H0 p. intuition.
  - have q := H p. have q0 := H0 p. intuition.
    rewrite H4. trivial.
Qed.

Lemma left_is_unit {M} `{!EqDecision M} (a b: RwLock M)
  : rw_op a b = rw_unit M -> a = rw_unit M.
Proof.
  intros. unfold rw_op, rw_unit in *. destruct a, b. inversion H. f_equal.
  - unfold "⋅" in *. unfold exc_op in H1. destruct e; unfold exc_op in *; intuition.
      destruct e2; intuition; try discriminate.
  - unfold "⋅" in *. unfold exc_op in H2. destruct e; unfold exc_op in *; intuition;
      destruct e2; intuition; try discriminate; destruct e1; intuition; destruct e0; intuition;
      try discriminate; try subst e4; try subst e3; trivial; try destruct e3; trivial;
      try discriminate; try destruct e4; try discriminate.
  - unfold "⋅" in *. unfold exc_op in H3. destruct e1, e4; intuition; try discriminate.
  - lia.
  - unfold "⋅" in *. unfold free_op in *. destruct f; try (symmetry; trivial); destruct f0;
      trivial; try case_decide; try discriminate.
Qed.

Lemma rw_mov_monotonic {M} `{!EqDecision M} `{!TPCM M} : forall x y z ,
      rw_mov x y -> V (rw_op x z) -> V (rw_op y z) /\ rw_mov (rw_op x z) (rw_op y z).
Proof.
  intros. assert (V (rw_op y z)) as Vrw.
  - have h : Decision (rw_op y z = rw_unit M) by solve_decision. destruct h.
    + rewrite e. apply rw_unit_valid.
    + unfold V in *.
      deex. unfold rw_mov in H. have h := H (rw_op z z0).
      unfold I_defined in h. unfold "⋅" in *.  intuition.
      rewrite rw_op_assoc in H2.
      have h := H2 H0. destruct_ands. destruct H3.
      * rewrite rw_op_assoc in H3.
        have liu := left_is_unit _ _ H3. contradiction.
      * exists z0. rewrite rw_op_assoc in H3. trivial.
  - split; trivial. unfold rw_mov. intros. unfold rw_mov in H.
    unfold "⋅" in *. rewrite <- rw_op_assoc. rewrite <- rw_op_assoc.
      apply H.
      rewrite <- rw_op_assoc in H1. trivial.
Qed.

Global Instance rwlock_tpcm {M} `{!EqDecision M} `{!TPCM M} : TPCM (RwLock M) := {
  m_valid := V ;
  dot := rw_op ;
  mov := rw_mov ;
  unit := rw_unit M ;
  valid_monotonic := rw_valid_monotonic ;
  unit_valid := rw_unit_valid ;
  unit_dot := rw_unit_dot M ;
  tpcm_comm := rw_op_comm ;
  tpcm_assoc := rw_op_assoc ;
  reflex := rw_mov_reflex ;
  trans := rw_mov_trans ;
  mov_monotonic := rw_mov_monotonic ;
}.

Lemma rwlock_I_valid_left
    {M} `{!EqDecision M} `{!TPCM M}
  : ∀ r : RwLock M, I_defined r → m_valid r.
Proof. intro.
  unfold m_valid, rwlock_tpcm.
  unfold I_defined. intro. destruct H.
  - rewrite H. apply rw_unit_valid.
  - unfold V. exists (rw_unit M). unfold "⋅". rewrite rw_unit_dot. trivial.
Qed.

Lemma rwlock_I_defined_unit
    {M} `{!EqDecision M} `{!TPCM M}
   : I_defined (unit: RwLock M).
Proof.
  unfold I_defined. left. trivial.
Qed.

Lemma rwlock_I_unit
    {M} `{!EqDecision M} `{!TPCM M}
  : I unit = unit.
Proof.
  trivial.
Qed.

Lemma rwlock_I_mov_refines
    {M} `{!EqDecision M} `{!TPCM M}
  : ∀ b b' : RwLock M, mov b b' → I_defined b → I_defined b' ∧ mov (I b) (I b').
Proof.
  intros.
  unfold mov, rwlock_tpcm, rw_mov in H.
  have h := H (rw_unit M). unfold "⋅" in h.
  repeat (rewrite rw_unit_dot in h). intuition. rewrite H3. apply reflex.
Qed.

Definition rwlock_ref
    M `{!EqDecision M} `{!TPCM M}
    : Refinement (RwLock M) M :=
({|
  rel_defined := I_defined ;
  rel := I ;
  rel_valid_left := rwlock_I_valid_left ;
  rel_defined_unit := rwlock_I_defined_unit ;
  rel_unit := rwlock_I_unit ;
  mov_refines := rwlock_I_mov_refines ;
|}).

Section RwlockLogic.

Context {𝜇: BurrowCtx}.
Context `{hG : @gen_burrowGS 𝜇 Σ}.

Context {M} `{!EqDecision M} `{!TPCM M}.
Context `{m_hastpcm: !HasTPCM 𝜇 M}.
Context `{rw_hastpcm: !HasTPCM 𝜇 (RwLock M)}.
Context `{!HasRef 𝜇 rw_hastpcm m_hastpcm (rwlock_ref M)}.

Definition rwloc 𝛼 𝛾 := extend_loc 𝛼 (rwlock_ref M) 𝛾.

Lemma rw_new 𝛾 (x: M)
  : L 𝛾 x ==∗ ∃ 𝛼 , L (rwloc 𝛼 𝛾) (Central false 0 x).
Proof.
  apply InitializeExt.
  - unfold rel_defined, rwlock_ref.
    unfold I_defined. right. apply rw_init_valid.
  - trivial.
Qed.

Lemma rw_exc_begin 𝛾 rc (x: M)
  : L 𝛾 (Central false rc x) ==∗ L 𝛾 (Central true rc x) ∗ L 𝛾 ExcPending.
Proof.
  rewrite <- L_op.
  apply FrameUpdate.
  apply rw_mov_exc_begin.
Qed.

Lemma rw_exc_acquire 𝛼 𝛾 exc (x: M)
   : L (rwloc 𝛼 𝛾) (Central exc 0 x)
  -∗ L (rwloc 𝛼 𝛾) ExcPending
 ==∗ L (rwloc 𝛼 𝛾) (Central exc 0 x)
   ∗ L (rwloc 𝛼 𝛾) ExcGuard
   ∗ L 𝛾 x.
Proof.
  iIntros "A B".
  iDestruct (L_join with "A B") as "T".
  iMod (L_unit M 𝛾) as "U".
  iMod (FrameExchange _ _ _ _ x _ (dot (Central exc 0 x) ExcGuard) with "T U") as "T".
  - apply rw_mov_exc_acquire.
  - rewrite L_op.
    iModIntro.
    iDestruct "T" as "[[S R] U]".
    iFrame.
Qed.

Lemma rw_exc_release 𝛼 𝛾 exc rc (x y: M)
   : L (rwloc 𝛼 𝛾) (Central exc rc y)
  -∗ L (rwloc 𝛼 𝛾) ExcGuard
  -∗ L 𝛾 x
 ==∗ L (rwloc 𝛼 𝛾) (Central false rc x).
Proof.
  iIntros "a b c".
  iDestruct (L_join with "a b") as "a".
  iMod (FrameExchange _ _ _ _ (unit: M) _ (Central false rc x) with "a c") as "[a b]".
  - apply rw_mov_exc_release.
  - iModIntro. iFrame.
Qed.

Lemma rw_shared_begin 𝛾 exc rc (x: M)
  : L 𝛾 (Central exc rc x) ==∗ L 𝛾 (Central exc (rc+1) x) ∗ L 𝛾 ShPending.
Proof.
  rewrite <- L_op.
  apply FrameUpdate.
  apply rw_mov_shared_begin.
Qed.

Lemma rw_shared_acquire 𝛾 rc (x: M)
  : L 𝛾 (Central false rc x) -∗ L 𝛾 ShPending ==∗ L 𝛾 (Central false rc x) ∗ L 𝛾 (ShGuard x).
Proof.
  iIntros "A B".
  iDestruct (L_join with "A B") as "A".
  iMod (FrameUpdate _ _ (dot (Central false rc x) (ShGuard x)) with "A") as "A".
  - apply rw_mov_shared_acquire.
  - rewrite L_op. iModIntro. iFrame.
Qed.

Lemma rw_shared_release 𝛾 exc rc (x y: M)
  : L 𝛾 (Central exc rc x) -∗ L 𝛾 (ShGuard y) ==∗ L 𝛾 (Central exc (rc-1) x).
Proof.
  iIntros "A B".
  iDestruct (L_join with "A B") as "A".
  iMod (FrameUpdate _ _ ((Central exc (rc-1) x)) with "A") as "A".
  - apply rw_mov_shared_release.
  - iModIntro. iFrame.
Qed.

Lemma rw_shared_retry 𝛾 exc rc (x: M)
  : L 𝛾 (Central exc rc x) -∗ L 𝛾 ShPending ==∗ L 𝛾 (Central exc (rc-1) x).
Proof.
  iIntros "A B".
  iDestruct (L_join with "A B") as "A".
  iMod (FrameUpdate _ _ ((Central exc (rc-1) x)) with "A") as "A".
  - apply rw_mov_shared_retry.
  - iModIntro. iFrame.
Qed.

Lemma rw_borrow_back 𝛼 𝛾 (x: M) 𝜅
  : B 𝜅 (rwloc 𝛼 𝛾) (ShGuard x) ⊢ B 𝜅 𝛾 x.
Proof.
  apply BorrowBack. apply rw_mov_shared_borrow. Qed.

End RwlockLogic.


From Equations Require Import Equations.
Require Import Equations.Prop.Subterm.

Require Import Psatz.

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Require Export SystemFR.OpenTOpen.
Require Export SystemFR.ReducibilitySubst.
Require Export SystemFR.TOpenTClose.
Require Export SystemFR.NoTypeFVar.
Require Export SystemFR.Polarity.
Require Export SystemFR.EquivalentPairsWithRelation.

Opaque makeFresh.
Opaque PeanoNat.Nat.eq_dec.
Opaque reducible_values.

Lemma polarity_open_aux:
  forall m T pols k rep,
    type_nodes T < m ->
    has_polarities T pols ->
    is_erased_term rep ->
    has_polarities (open k T rep) pols.
Proof.
  induction m; destruct T;
    repeat step || constructor || step_inversion has_polarities;
      eauto with lia;
      eauto with b_polarity.
  exists X; repeat
         step || fv_open || list_utils ||
         (progress rewrite is_erased_term_tfv in * by steps) ||
         (rewrite <- open_topen by (steps; eauto with twf)).

  apply_any; repeat step || autorewrite with bsize; try lia.
Qed.

Lemma polarity_open:
  forall T pols k rep,
    has_polarities T pols ->
    is_erased_term rep ->
    has_polarities (open k T rep) pols.
Proof.
  eauto using polarity_open_aux.
Qed.

Lemma pair_in_list:
  forall X Y (l: list (X*Y)) x y,
    (x,y) ∈ l ->
    x ∈ support l.
Proof.
  induction l; steps; eauto.
Qed.

Lemma support_invert_polarities:
  forall pols, support (invert_polarities pols) = support pols.
Proof.
  induction pols; repeat step || f_equal.
Qed.

Lemma equivalent_pairs_same:
  forall pols pols' rel X X',
    equivalent_pairs_with_relation rel pols pols' eq ->
    lookup PeanoNat.Nat.eq_dec rel X = Some X' ->
    lookup PeanoNat.Nat.eq_dec (swap rel) X' = Some X ->
    ((X, Negative) ∈ pols -> False) ->
    (X', Negative) ∈ pols' ->
    False.
Proof.
  induction pols; destruct pols'; repeat step; eauto.
Qed.

Definition hp_rename_prop T :=
  forall pols T' pols' rel,
    has_polarities T pols ->
    equivalent_pairs_with_relation rel pols pols' eq ->
    equal_with_relation type_var rel T T' ->
    has_polarities T' pols'.

Definition hp_rename_prop_aux n T := type_nodes T = n -> hp_rename_prop T.

Definition hp_rename_until n :=
  forall n', n' < n -> forall T, hp_rename_prop_aux n' T.

#[export]
Hint Unfold hp_rename_prop: u_hprename.
#[export]
Hint Unfold hp_rename_prop_aux: u_hprename.
#[export]
Hint Unfold hp_rename_until: u_hprename.

Lemma has_polarities_rename_fvar:
  forall n x f, hp_rename_prop_aux n (fvar x f).
Proof.
  repeat autounfold with u_hprename.
  repeat step || step_inversion has_polarities.
  force_invert equal_with_relation;
    repeat step;
    try solve [ constructor; eauto with lia; eauto using equivalent_pairs_same ].
Qed.

#[export]
Hint Immediate has_polarities_rename_fvar: b_hp_rename.

Lemma equivalent_with_pairs_invert:
  forall (pols pols' : map nat polarity) (rel : map nat nat),
    equivalent_pairs_with_relation rel pols pols' eq ->
    equivalent_pairs_with_relation rel (invert_polarities pols) (invert_polarities pols') eq.
Proof.
  induction pols; steps.
Qed.

Lemma hp_rename_induct_invert:
  forall T1 T2 n pols pols' rel,
    hp_rename_until n ->
    equivalent_pairs_with_relation rel pols pols' eq ->
    has_polarities T1 (invert_polarities pols) ->
    equal_with_relation type_var rel T1 T2 ->
    type_nodes T1 < n ->
    has_polarities T2 (invert_polarities pols').
Proof.
  repeat autounfold with u_hprename; intros.
  repeat step || eapply_any;
    eauto using equivalent_with_pairs_invert.
Qed.

Lemma hp_rename_induct:
  forall T1 T2 n pols pols' rel,
    hp_rename_until n ->
    equivalent_pairs_with_relation rel pols pols' eq ->
    has_polarities T1 pols ->
    equal_with_relation type_var rel T1 T2 ->
    type_nodes T1 < n ->
    has_polarities T2 pols'.
Proof.
  repeat autounfold with u_hprename; intros.
  repeat step; eauto.
Qed.

Lemma equivalent_with_pairs_cons:
  forall T (pols pols': map nat T) (rel : map nat nat) X Y,
    equivalent_pairs_with_relation rel pols pols' eq ->
    (X ∈ support pols -> False) ->
    (Y ∈ range rel -> False) ->
    equivalent_pairs_with_relation ((X, Y) :: rel) pols pols' eq.
Proof.
  induction pols; destruct pols'; repeat step || t_lookup.
Qed.

Lemma has_polarities_rename_rec:
  forall n k T0 Ts, hp_rename_until n -> hp_rename_prop_aux n (T_rec k T0 Ts).
Proof.
  unfold hp_rename_prop_aux, hp_rename_prop.
  repeat
    step || step_inversion has_polarities || step_inversion equal_with_relation || constructor;
    eauto using hp_rename_induct_invert with lia;
    eauto using hp_rename_induct with lia.

  - exists (makeFresh (pfv Ts' type_var :: support pols' :: range rel :: nil)); steps; try finisher.
    eapply (
        hp_rename_induct _ _ _ _ _
                         ((X, makeFresh (pfv Ts' type_var :: support pols' :: range rel :: nil)) :: rel)); eauto 1;
      repeat step || apply equal_with_relation_topen || finisher || autorewrite with bsize ||
             apply equivalent_with_pairs_cons;
      try lia; try finisher.
Qed.

#[export]
Hint Immediate has_polarities_rename_rec: b_hp_rename.

Lemma strong_induction_aux:
  forall P,
    (forall n, (forall n', n' < n -> P n') -> P n) ->
    forall n, forall n', n' < n -> P n'.
Proof.
  induction n; repeat step; eauto with lia.
Qed.

Lemma strong_induction:
  forall P,
    (forall n, (forall n', n' < n -> P n') -> P n) ->
    forall n, P n.
Proof.
  intros; eapply strong_induction_aux; steps.
Qed.

Lemma has_polarities_rename_aux: forall n T, hp_rename_prop_aux n T.
Proof.
  induction n using strong_induction; destruct T; steps;
    eauto 2 with b_hp_rename;
    try solve [
      unfold hp_rename_prop_aux, hp_rename_prop;
      repeat
        step || step_inversion has_polarities || step_inversion equal_with_relation || constructor;
        eauto using hp_rename_induct with lia;
        eauto using hp_rename_induct_invert with lia
    ].
Qed.

Lemma has_polarities_rename: forall T, hp_rename_prop T.
Proof.
  intros; eapply has_polarities_rename_aux; eauto.
Qed.

Lemma equivalent_with_pairs_refl:
  forall T rel (l: list (nat * T)),
    (forall x, x ∈ support l -> lookup PeanoNat.Nat.eq_dec rel x = Some x) ->
    (forall x, x ∈ support l -> lookup PeanoNat.Nat.eq_dec (swap rel) x = Some x) ->
    equivalent_pairs_with_relation rel l l eq.
Proof.
  induction l; steps.
Qed.

Lemma has_polarities_rename_one:
  forall T X Y pol pols k,
    has_polarities (topen k T (fvar X type_var)) ((X, pol) :: pols) ->
    ~(X ∈ pfv T type_var) ->
    ~(Y ∈ pfv T type_var) ->
    ~(X ∈ support pols) ->
    ~(Y ∈ support pols) ->
    has_polarities (topen k T (fvar Y type_var)) ((Y, pol) :: pols).
Proof.
  intros.
  eapply (has_polarities_rename _ _ _ _ ((X,Y) :: idrel (pfv T type_var ++ support pols))); eauto 1;
    repeat step || apply equal_with_relation_topen || apply equal_with_idrel ||
           apply equivalent_with_pairs_cons || apply equivalent_pairs_with_relation ||
           apply equivalent_with_pairs_refl || rewrite swap_idrel in * ||
           apply idrel_lookup || apply equal_with_relation_refl2 ||
           rewrite range_idrel in * || list_utils.
Qed.

Lemma has_polarities_swap_aux:
  forall n T pols i j,
    type_nodes T < n ->
    has_polarities T pols ->
    has_polarities (swap_type_holes T i j) pols.
Proof.
  induction n; destruct T; repeat step || constructor || apply_any || step_inversion has_polarities;
    eauto with lia.

  exists X; repeat step || rewrite pfv_swap_type_holes in *.
  rewrite topen_swap2; steps.
  apply IHn; repeat step || autorewrite with bsize in *; try lia.
Qed.

Lemma has_polarities_swap:
  forall T pols i j,
    has_polarities T pols ->
    has_polarities (swap_type_holes T i j) pols.
Proof.
  eauto using has_polarities_swap_aux.
Qed.

Lemma has_polarities_topen_aux:
  forall n T pols X k,
    type_nodes T < n ->
    has_polarities T pols ->
    ~(X ∈ support pols) ->
    has_polarities (topen k T (fvar X type_var)) pols.
Proof.
  induction n; destruct T;
    repeat step || constructor || t_lookup ||
           step_inversion has_polarities || apply_any ||
           rewrite support_invert_polarities in *;
    eauto with lia;
    eauto using pair_in_list.

  define M (makeFresh ((X :: nil) :: pfv T3 type_var :: pfv (topen (S k) T3 (fvar X type_var)) type_var :: support pols :: nil)).
  exists M; steps; try finisher.

  rewrite open_swap; steps.
  apply_any; repeat step || autorewrite with bsize; eauto with lia; try finisher.

  rewrite topen_swap; repeat step || apply has_polarities_swap.
  apply has_polarities_rename_one with X0; steps; try finisher.
Qed.

Lemma has_polarities_topen:
  forall T pols X k,
    has_polarities T pols ->
    ~(X ∈ support pols) ->
    has_polarities (topen k T (fvar X type_var)) pols.
Proof.
  eauto using has_polarities_topen_aux.
Qed.


Require Import LogicalRelations.
Require Import SimulationRelation.
Require Export SimValues.
Require Export AsmX.
Require Import FiniteFunctionalChoice.

(** * Relations for [Asm.regset]s *)

Section ASM_REL.
  Context `{Hmem: BaseMemoryModel}.
  Context {D1 D2} (R: simrel D1 D2).

  (** ** Preliminaries *)

  (** We need the following definition in order to express the
    monotonicity of [set_regs]. XXX: set_regs is no longer a thing? *)

  Definition indexed_rel C A B := C -> rel A B.

  Inductive list_indexed_rel {C A B} (R: indexed_rel C A B):
    indexed_rel (list C) (list A) (list B) :=
    | nil_indexed_rel:
        Monotonic nil
          (list_indexed_rel R nil)
    | cons_indexed_rel c cs:
        Monotonic cons
          (R c ++> list_indexed_rel R cs ++> list_indexed_rel R (c::cs)).

  Lemma list_indexed_rel_match_val_of_type_intro p tl:
    forall vl vl2,
      list_rel (match_val R p) vl vl2 ->
      Val.has_type_list vl2 tl ->
      list_indexed_rel (match_val_of_type R p) tl vl vl2.
  Proof.
    induction tl; inversion 1; inversion 1; subst; constructor; auto.
    apply match_val_of_type_intro; auto.
  Qed.

  Global Instance list_indexed_rel_match_val_of_type_elim p tl:
    Related
      (list_indexed_rel (match_val_of_type R p) tl)
      (list_rel (match_val R p))
      subrel.
  Proof.
    red.
    induction 1; constructor; auto.
    eapply match_val_erase_type; eauto.
  Qed.

  Global Instance list_indexed_rel_match_val_of_type_weaken l p:
    Related
      (list_indexed_rel (match_val_of_type R p) l)
      (list_rel (match_val R p))
      subrel.
  Proof.
    red.
    induction 1; constructor; auto.
    eapply match_val_erase_type; eauto.
  Qed.

  (** ** The [regset_match] relation *)

  Definition regset_match p: rel regset regset :=
    (- ==> match_val R p).

  Global Instance regset_match_relim p rs1 rs2 r:
    RElim (regset_match p) rs1 rs2 True (match_val R p (rs1 r) (rs2 r)).
  Proof.
    unfold regset_match.
    repeat intro; solve_monotonic.
  Qed.

  Lemma wt_regset_regset_match p:
    Monotonic (@wt_regset) (regset_match p --> impl).
  Proof.
    intros rs2 rs1 Hrs Hrs2 r.
    specialize (Hrs r).
    specialize (Hrs2 r).
    eapply (val_has_type_match R); eauto.
  Qed.

  (** ** The [wt_regset_match] relation *)

  Definition wt_regset_match p: rel regset regset :=
    forall_pointwise_rel (fun r => match_val_of_type R p (typ_of_preg r)).

  Global Instance wt_regset_match_relim p rs1 rs2 r ty:
    RElim (wt_regset_match p) rs1 rs2
      (typ_of_preg r = ty)
      (match_val_of_type R p ty (rs1 r) (rs2 r)).
  Proof.
    unfold wt_regset_match.
    intros Hrs Hty; subst.
    solve_monotonic.
  Qed.

  Lemma wt_regset_match_intro p rs1 rs2:
    wt_regset rs2 ->
    regset_match p rs1 rs2 ->
    wt_regset_match p rs1 rs2.
  Proof.
    intros Hrs2 Hrs r.
    eapply match_val_of_type_intro; eauto.
  Qed.

  Lemma wt_regset_match_elim p rs1 rs2:
    wt_regset_match p rs1 rs2 ->
    wt_regset rs2 /\ regset_match p rs1 rs2.
  Proof.
    intros Hrs.
    split.
    - intro r.
      eapply (match_val_has_type R).
      solve_monotonic.
    - solve_monotonic.
      intros r; rauto.
  Qed.

  Global Instance wt_regset_match_subrel p:
    Related (wt_regset_match p) (regset_match p) subrel.
  Proof.
    intros rs1 rs2 Hrs.
    solve_monotonic.
    intros r; rauto.
  Qed.

  Global Instance wt_regset_match_le_subrel:
    Monotonic (@wt_regset_match) (le ++> subrel)%rel.
  Proof.
    intros p p' LE rs rs' Hrs i. specialize (Hrs i). simpl in Hrs.
    eapply match_val_of_type_acc; eauto.
  Qed.

  Global Instance reg_eq_transport p rs1 rs2 r v1:
    Transport (wt_regset_match p) rs1 rs2
      (rs1 r = v1)
      (exists v2, rs2 r = v2 /\ match_val_of_type R p (typ_of_preg r) v1 v2)%type.
  Proof.
    intros Hrs H.
    specialize (Hrs r).
    rewrite H in Hrs; clear H.
    eauto.
  Qed.

  (** ** Relational properties of [regset] operations *)

  (** *** [Pregmap.set] *)

  Global Instance regset_set_rel_wt p:
    Monotonic
      (@Pregmap.set val)
      (forallr - @ r,
         match_val_of_type R p (typ_of_preg r) ++>
         wt_regset_match p ++>
         wt_regset_match p).
  Proof.
    unfold Pregmap.set.
    solve_monotonic.
    intros r; solve_monotonic.
    congruence.
  Qed.

  Local Instance regset_set_rel p:
    Monotonic
      (@Pregmap.set val)
      (- ==> match_val R p ++> regset_match p ++> regset_match p).
  Proof.
    unfold Pregmap.set.
    solve_monotonic.
    intros r; solve_monotonic.
  Qed.

  Global Instance regset_set_rel_params:
    Params (@Pregmap.set) 4.

  (** *** [undef_regs] *)

  Global Instance undef_regs_match_wt p:
    Monotonic
      (@undef_regs)
      (- ==> wt_regset_match p ++> wt_regset_match p).
  Proof.
    intro l.
    induction l; simpl; solve_monotonic.
  Qed.

  Local Instance undef_regs_match p:
    Monotonic
      (@undef_regs)
      (- ==> regset_match p ++> regset_match p).
  Proof.
    intro l.
    induction l; simpl; solve_monotonic.
  Qed.

  Local Instance set_pair_match p:
    Monotonic (@set_pair)
              ( - ==> match_val R p ++> regset_match p ++> regset_match p).
  Proof.
    intro pr. destruct pr; repeat rstep; simpl; repeat rstep.
  Qed.

  (** *** [set_regs] *)

  (** XXX set_regs is no longer a thing? *)

  (*
  Local Instance set_regs_match D1 D2 (R: simrel D1 D2) p:
    Monotonic
      (@set_regs)
      (- ==> list_rel (match_val R p) ++> regset_match p ++> regset_match p).
  Proof.
    intro l.
    induction l; simpl.
    - solve_monotonic.
    - intros v1 v2 H.
      Local Remove Hints arrow_pointwise_rintro : typeclass_instances.
      solve_monotonic.
  Qed.
  *)
End ASM_REL.

Global Instance regset_match_le_subrel_params:
  Params (@regset_match) 3.

Global Instance wt_regset_match_le_subrel_params:
  Params (@wt_regset_match) 3.

(** ** Functoriality of [regset_match] *)

Section FUNCTOR.
  Context `{Hmem: BaseMemoryModel}.

  Lemma FunctionalChoice_on_preg {B}:
    ChoiceFacts.FunctionalChoice_on preg B.
  Proof.
    eapply FunctionalChoice_on_finite.
    - solve_finite ltac:(fun r => destruct r as [|[]|[]| |[]|]).
    - exact (inhabits PC).
    - exact preg_eq.
  Qed.

  Lemma regset_match_id {D} p:
    regset_match (simrel_id (D:=D)) p = eq.
  Proof.
    apply functional_extensionality; intro rs1.
    apply functional_extensionality; intro rs2.
    unfold regset_match.
    unfold simrel_id; simpl.
    rewrite match_val_simrel_id.
    apply prop_ext; split.
    - intros H.
      apply functional_extensionality; intro r.
      auto.
    - red; congruence.
  Qed.

  Lemma regset_match_compose {D1 D2 D3} R12 R23 p q:
    regset_match (simrel_compose (D1:=D1) (D2:=D2) (D3:=D3) R12 R23) (p, q) =
    rel_compose (regset_match R12 p) (regset_match R23 q).
  Proof.
    unfold regset_match.
    rewrite (match_val_simrel_compose R12 R23) by typeclasses eauto.
    rewrite arrow_pointwise_rel_compose.
    - reflexivity.
    - apply FunctionalChoice_on_preg.
  Qed.

  Lemma wt_regset_match_compose {D1 D2 D3} R12 R23 p q:
    wt_regset_match (simrel_compose (D1:=D1) (D2:=D2) (D3:=D3) R12 R23) (p, q) =
    rel_compose (wt_regset_match R12 p) (wt_regset_match R23 q).
  Proof.
    apply functional_extensionality; intro rs1.
    apply functional_extensionality; intro rs3.
    apply prop_ext; split.
    - intros H.
      apply wt_regset_match_elim in H.
      destruct H as [Hrs3 Hrs].
      rewrite regset_match_compose in Hrs.
      destruct Hrs as (rs2 & Hrs12 & Hrs23).
      exists rs2; split; eapply wt_regset_match_intro; eauto.
      eapply (wt_regset_regset_match R23); eauto.
    - intros (rs2 & Hrs12 & Hrs23).
      apply wt_regset_match_elim in Hrs12; destruct Hrs12 as [Hrs2 Hrs12].
      apply wt_regset_match_elim in Hrs23; destruct Hrs23 as [Hrs3 Hrs23].
      apply wt_regset_match_intro; eauto.
      rewrite regset_match_compose.
      exists rs2; split; eauto.
  Qed.

  Global Instance regset_match_wfunctor:
    SimrelFunctorW (@regset_match Hmem).
  Proof.
    split.
    - intros.
      intros wa wb Hwb.
      red in Hwb; subst.
      unfold regset_match.
      rstep. eapply match_val_simrel_equiv_fw.
    - intros.
      eapply regset_match_id.
    - intros.
      eapply regset_match_compose.
  Qed.
End FUNCTOR.


(* nn_prop library for yalla *)

(** * Parametric negative translation from [ll] into [ill]. *)
(** Properties relying on cut admissibility *)

Require Import List_more.
Require Import List_Type_more.
Require Import Permutation_Type.
Require Import genperm_Type.

Require Import subs.
Require Import ll_fragments.
Require Export nn_def.

Require Import bbb.

Section RTranslation.

(** We fix the parameter [R] of the translation. *)

Variable R : iformula.

(** In [llR] (where [bot] is equivalent to [R]),
  [A] is implied by the dual of its translation. *)
Lemma back_to_llR : forall A,
  llR (unill R) (unill (trans R A) :: A :: nil).
Proof with myeeasy ; try ((try rewrite a2a_i) ; PCperm_Type_solve).
induction A ; simpl ; rewrite ? bidual.
- apply parr_r.
  apply (ex_r _ ((covar a :: var a :: nil) ++ unill R :: nil))...
  eapply (@cut_r (pfrag_llR (unill R)) eq_refl (dual one)).
  + apply (ex_r _ (unill R :: one :: nil))...
    apply (gax_r (pfrag_llR (unill R)) false).
  + apply bot_r.
    apply ax_r.
- apply (ex_r _ (covar a :: var a :: nil))...
  apply ax_r...
- eapply parr_r.
  apply (bot_r (pfrag_llR (unill R))).
  apply (gax_r (pfrag_llR (unill R)) false).
- apply (ex_r _ (bot :: one :: nil))...
  apply bot_r.
  apply one_r.
- assert (Hax := @ax_exp (pfrag_llR (unill R)) (unill R)).
  apply parr_r.
  apply parr_r.
  change (tens (dual (unill R)) (unill (trans R A2)) ::
  tens (dual (unill R)) (unill (trans R A1)) :: unill R :: tens A1 A2 :: nil)
    with (tens (dual (unill R)) (unill (trans R A2)) ::
    (tens (dual (unill R)) (unill (trans R A1)) :: unill R :: tens A1 A2 :: nil) ++ nil).
  apply tens_r.
  + apply (gax_r (pfrag_llR (unill R)) true).
  + apply (ex_r _ (tens (dual (unill R)) (unill (trans R A1))
             :: (unill (trans R A2) :: tens A1 A2 :: nil) ++ (unill R :: nil)))...
    apply tens_r.
    -- eapply ex_r ; [ | apply Permutation_Type_swap ]...
    -- apply (ex_r _ (tens A1 A2 ::
             (unill (trans R A2) :: nil) ++ unill (trans R A1) :: nil))...
       apply tens_r.
       ++ eapply ex_r ; [ apply IHA1 | ]...
       ++ eapply ex_r ; [ apply IHA2 | ]...
- apply (ex_r _ (parr A1 A2 ::
                 tens (unill (trans R A2)) (unill (trans R A1)) :: nil))...
  apply parr_r.
  apply (ex_r _ (tens (unill (trans R A2)) (unill (trans R A1))
                  :: (A1 :: nil) ++ (A2 :: nil)))...
  apply tens_r...
- apply parr_r.
  apply top_r.
- eapply ex_r ; [ | apply Permutation_Type_swap ].
  eapply top_r.
- assert (Hax := @ax_exp (pfrag_llR (unill R)) (unill R)).
  apply parr_r.
  apply with_r.
  + apply (ex_r _ (tens (dual (unill R)) (unill (trans R A1)) ::
                    (aplus A1 A2 :: nil) ++ unill R :: nil))...
    apply tens_r.
    * eapply ex_r ; [ | apply Permutation_Type_swap ]...
    * eapply ex_r ; [ | apply Permutation_Type_swap ].
      apply plus_r1.
      eapply ex_r ; [ | apply Permutation_Type_swap ]...
  + apply (ex_r _ (tens (dual (unill R)) (unill (trans R A2)) ::
                    (aplus A1 A2 :: nil) ++ unill R :: nil))...
    apply tens_r...
    * eapply ex_r ; [ | apply Permutation_Type_swap ]...
    * eapply ex_r ; [ | apply Permutation_Type_swap ].
      apply plus_r2.
      eapply ex_r ; [ | apply Permutation_Type_swap ]...
- assert (Hax := @ax_exp (pfrag_llR (unill R)) (unill R)).
  eapply ex_r ; [ | apply Permutation_Type_swap ].
  apply with_r.
  + eapply ex_r ; [ | apply Permutation_Type_swap ].
    apply plus_r1...
  + eapply ex_r ; [ | apply Permutation_Type_swap ].
    apply plus_r2...
- apply parr_r.
  apply (ex_r _ ((oc A ::
                  map wn (tens (dual (unill R)) (unill (trans R A)) :: nil))
                  ++ unill R :: nil)) ; [idtac | simpl]...
  apply (@cut_r (pfrag_llR (unill R)) eq_refl (dual one)).
  + apply (ex_r _ (unill R :: one :: nil))...
    apply (gax_r (pfrag_llR (unill R)) false).
  + apply bot_r.
    apply oc_r ; simpl.
    apply (ex_r _ ((wn (tens (dual (unill R)) (unill (trans R A))) :: nil)
                     ++ (A :: nil) ++ nil))...
    apply de_r.
    apply tens_r...
    apply (gax_r (pfrag_llR (unill R)) true).
- assert (Hax := @ax_exp (pfrag_llR (unill R)) (unill R)).
  change (wn A :: nil) with (map wn (A :: nil)).
  apply oc_r ; simpl.
  apply parr_r.
  apply (ex_r _ (tens (dual (unill R)) (unill (trans R A)) :: (wn A :: nil) ++ unill R :: nil))...
  apply tens_r.
  + eapply ex_r...
  + apply (ex_r _ (wn A :: unill (trans R A) :: nil))...
    apply de_r...
    eapply ex_r ; [ | apply Permutation_Type_swap ]...
Qed.

(** The previous lemma comes with the following result from the [ll_fragments] library:
<<
Lemma ll_to_llR : forall R l, ll_ll l -> llR R l.
>> to deduce: *)

(** A sequent whose translation is provable in [ill] was provable in [llR]. *)
Lemma ill_trans_to_llR : forall l,  ill_ll (map (trans R) l) R -> llR (unill R) l.
Proof with myeeasy ; try PCperm_Type_solve.
intros l Hill.
apply (ill_to_ll i2a) in Hill.
apply (stronger_pfrag _ (mk_pfrag true NoAxioms false false true))
  in Hill.
- eapply cut_admissible_axfree in Hill.
  + apply (ll_to_llR (unill R)) in Hill.
    assert (forall l',
      llR (unill R) (l' ++ map dual (map unill (map (trans R) (rev l))))
        -> llR (unill R) (l' ++ rev l)) as Hll.
    { clear.
      induction l using rev_ind_Type ; intros...
      assert (Hb := back_to_llR x).
      rewrite rev_unit in X.
      apply (ex_r _ _ (dual (unill (trans R x))
               :: l' ++ map dual (map unill (map (trans R) (rev l))))) in X...
      apply (@cut_r _ (eq_refl (pcut (pfrag_llR (unill R)))) _ _ _ X) in Hb.
      rewrite rev_unit.
      change (x :: rev l) with ((x :: nil) ++ rev l).
      rewrite app_assoc.
      eapply IHl.
      eapply ex_r... }
    assert (llR (unill R) (dual (unill R) :: nil)) as HR
      by (apply (gax_r (pfrag_llR (unill R)) true)).
    apply (@cut_r _ (eq_refl (pcut (pfrag_llR (unill R)))) _ _ _ HR) in Hill.
    rewrite app_nil_r in Hill.
    rewrite <- (app_nil_l (rev _)) in Hill.
    rewrite <- ? map_rev in Hill.
    apply Hll in Hill.
    eapply ex_r ; [ apply Hill | ].
    symmetry.
    apply Permutation_Type_rev.
  + intros Hax ; inversion Hax.
- nsplit 5 ; myeasy.
  intros Hax ; inversion Hax.
Qed.

(** *** Sufficient condition on [R] for embedding [llR] into [ill_ll]

extension of [ll_to_ill_trans] *)

(** Elementary intuitionistic formulas *)
Inductive ielem : iformula -> Type :=
| ie_ivar : forall X, X <> atN -> ielem (ivar X)
| ie_ione : ielem ione
| ie_itens : forall A B, ielem A -> ielem B -> ielem (itens A B)
| ie_izero : ielem izero
| ie_iplus : forall A B, ielem A -> ielem B -> ielem (iplus A B)
| ie_itop : ielem itop.

Lemma ie_ie : forall A, ielem A ->
  ill_ll (A :: nil) (negR R (trans R (unill A))).
Proof with try now (apply ax_exp_ill).
induction A ; intros Hgfn ; inversion Hgfn ;
  simpl ; unfold trans.
- unfold a2i ; unfold i2a ; rewrite (i2i_not_atN _ H0).
  apply negR_irr.
  apply negR_ilr...
  reflexivity.
- apply negR_irr.
  apply negR_ilr...
  reflexivity.
- apply IHA1 in H1.
  apply IHA2 in H2.
  apply negR_irr.
  apply negR_ilr ; [ reflexivity | | ]...
  rewrite <- (app_nil_l _).
  apply tens_ilr.
  list_simpl ; cons2app.
  apply tens_irr ; eassumption.
- apply negR_irr.
  rewrite <- (app_nil_l _).
  apply zero_ilr.
- rewrite <- (app_nil_l _).
  apply zero_ilr.
- apply IHA1 in H1.
  apply IHA2 in H2.
  apply negR_irr.
  apply negR_ilr ; [ reflexivity | | ]...
  rewrite <- (app_nil_l _).
  apply plus_ilr ; constructor ; eassumption.
Qed.

Lemma ie_dual : forall A, ielem A ->
  ill_ll (trans R (dual (unill A)) :: nil) A.
Proof with try now (apply ax_exp_ill).
induction A ; intros Hgfn ; inversion Hgfn ;
  simpl ; unfold trans...
- unfold a2i ; unfold i2a ; rewrite (i2i_not_atN _ H0)...
- apply IHA1 in H1.
  apply IHA2 in H2.
  rewrite <- (app_nil_l _).
  apply tens_ilr.
  list_simpl.
  cons2app.
  apply tens_irr ; eassumption.
- apply top_irr.
- apply IHA1 in H1.
  apply IHA2 in H2.
  rewrite <- (app_nil_l _).
  apply plus_ilr ; constructor ; eassumption.
Qed.

End RTranslation.

Lemma ie_ie_diag : forall A, ielem A ->
  ill_ll (trans A (unill A) :: A :: nil) A.
Proof.
intros A Hgfn.
eapply ex_ir ; [ | apply Permutation_Type_swap ].
cons2app.
rewrite <- (app_nil_l _).
eapply cut_ir_axfree.
- intros a ; destruct a.
- apply ie_ie.
  assumption.
- apply negR_ilr ; try apply ax_exp_ill.
  reflexivity.
Qed.

Lemma ie_dual_diag : forall A, ielem A ->
  ill_ll (trans A (dual (unill A)) :: nil) A.
Proof.
intros A ; apply ie_dual.
Qed.

Proposition llR_ie_to_ill_trans : forall R l, ielem R ->
  llR (unill R) l -> ill_ll (map (trans R) l) R.
Proof with myeeasy ; try PEperm_Type_solve.
intros R l Hie Hll.
assert (Hax := @ax_exp_ill ipfrag_ill R).
rewrite <- (app_nil_l (R :: _)) in Hax.
induction Hll ;
  (try now (apply Hmix0)) ;
  (try now (rewrite map_app ; eapply Hmix2)) ;
  (try now (apply P_axfree in H ; inversion H)) ;
  (try now (inversion f)) ;
  simpl.
- eapply ex_ir.
  + eapply lmap_ilr ; [ | apply Hax ].
    eapply (ax_ir _ (a2i X)).
  + PEperm_Type_solve.
- eapply ex_ir...
  apply Permutation_Type_map...
- list_simpl in IHHll ; rewrite trans_wn in IHHll.
  list_simpl ; rewrite trans_wn.
  eapply Permutation_Type_map in p.
  eapply ex_oc_ir...
- rewrite <- (app_nil_l _).
  rewrite <- (app_nil_l _).
  apply lmap_ilr...
  apply one_irr.
- rewrite <- (app_nil_l (ione :: _)).
  apply one_ilr...
- apply negR_irr in IHHll1.
  apply negR_irr in IHHll2.
  apply (tens_irr _ _ _ _ _ IHHll1) in IHHll2.
  apply (lmap_ilr _ _ _ _ _ _ _ IHHll2) in Hax.
  apply (ex_ir _ _ _ _ Hax)...
- rewrite <- (app_nil_l (itens _ _ :: _)).
  apply tens_ilr.
  eapply ex_ir...
- rewrite <- (app_nil_l (izero :: _)).
  apply zero_ilr.
- apply negR_irr in IHHll.
  apply (plus_irr1 _ _ (negR R (trans R B))) in IHHll.
  apply (lmap_ilr _ _ _ _ _ _ _ IHHll) in Hax.
  apply (ex_ir _ _ _ _ Hax)...
- apply negR_irr in IHHll.
  apply (plus_irr2 _ _ (negR R (trans R B))) in IHHll.
  apply (lmap_ilr _ _ _ _ _ _ _ IHHll) in Hax.
  apply (ex_ir _ _ _ _ Hax)...
- rewrite <- (app_nil_l (iplus _ _ :: _)).
  apply plus_ilr...
- simpl in IHHll ; rewrite map_map in IHHll.
  simpl in IHHll ; rewrite <- map_map in IHHll.
  apply negR_irr in IHHll.
  apply oc_irr in IHHll.
  apply negR_ilr...
  eapply ex_ir...
  list_simpl...
  rewrite ? map_map...
- rewrite <- (app_nil_l (ioc _ :: _)).
  apply de_ilr...
  eapply ex_ir ; [ | apply Permutation_Type_middle ].
  apply negR_ilr...
  apply negR_irr.
  eapply ex_ir...
- rewrite <- (app_nil_l (ioc _ :: _)).
  apply wk_ilr...
- rewrite <- (app_nil_l (ioc _ :: _)).
  change nil with (map ioc nil).
  rewrite <- (app_nil_l (map _ _ ++ _)).
  apply co_ilr.
  eapply ex_ir...
- apply negR_irr in IHHll1.
  apply negR_irr in IHHll2.
  apply (stronger_ipfrag _ (cutupd_ipfrag ipfrag_ill true) (cutupd_ipfrag_true _)) in IHHll1.
  apply (stronger_ipfrag _ (cutupd_ipfrag ipfrag_ill true) (cutupd_ipfrag_true _)) in IHHll2.
  assert (pi0 := @trans_dual R (cutupd_ipfrag ipfrag_ill true) eq_refl eq_refl A).
  rewrite <- (app_nil_l _) in pi0.
  eapply (cut_ir _ _ _ _ _ _ IHHll2) in pi0.
  list_simpl in pi0.
  eapply (cut_ir _ _ _ _ _ _ IHHll1) in pi0.
  unfold ill_ll ;  change ipfrag_ill with (cutrm_ipfrag (cutupd_ipfrag ipfrag_ill true)).
  apply cut_admissible_ill_axfree ; [ intros a ; destruct a | ].
  eapply ex_ir...
- destruct a ; subst.
  + apply ie_dual_diag...
  + simpl.
    eapply ex_ir ; [ | apply Permutation_Type_swap ].
    rewrite <- 2 (app_nil_l (negR _ _ :: _)).
    apply lmap_ilr...
    * apply one_irr.
    * eapply ex_ir.
      -- apply ie_ie_diag...
      -- PEperm_Type_solve.
Unshelve. all : reflexivity.
Qed.

(** Ingredients for generating fresh variables *)
Definition a2n := yalla_ax.a2n.
Definition n2a := yalla_ax.n2a.
Definition n2n_a := yalla_ax.n2n_a.

(** ** Study of the case [R = bot] *)

(** Given a sequent, the following 3 statements are equivalent:
 - the translation of the sequent is provable in [ill] for any [R];
 - the sequent is provable in [llR bot];
 - the sequent is provable in [ll].
*)

Theorem ill_trans_to_llR_bot : forall l,
  (forall R, ill_ll (map (trans R) l) R) -> llR bot l.
Proof with myeeasy ; try PCperm_Type_solve.
intros l Hill.
remember (fresh_of_list a2n n2a l) as z.
specialize Hill with (ivar (a2i z)).
apply ill_trans_to_llR in Hill...
apply (subs_llR _ bot z) in Hill ; subst.
simpl in Hill.
rewrite repl_at_eq in Hill...
rewrite (subs_fresh_list _ _ n2n_a) in Hill...
Qed.

Theorem llR_bot_to_ll : forall l, llR bot l -> ll_ll l.
Proof with myeeasy.
intros l HR.
induction HR ;
  (try now (inversion f)) ;
  try now constructor.
- eapply ex_r...
- eapply ex_wn_r...
- eapply cut_ll_r...
- destruct a.
  + apply one_r.
  + apply bot_r.
    apply one_r.
Qed.

Theorem ll_ll_to_ill_trans : forall R l,
  ll_ll l -> ill_ll (map (trans R) l) R.
Proof.
intros R l Hll.
apply (ll_to_ill_trans R) in Hll ; myeasy.
- eapply stronger_ipfrag ; [ | apply Hll ].
  nsplit 3 ; myeasy.
  intros a ; destruct a.
- intros f ; inversion f.
- intros f ; inversion f.
Qed.

(** ** Study of the case [R = one] *)

(** Given a sequent, the following 3 statements are equivalent:
 - the translation of the sequent is provable in [ill] for parameter [ione];
 - the sequent is provable in [llR one];
 - the sequent is provable in [ll_mix02].
*)

Lemma ill_trans_to_llR_one : forall l,
  ill_ll (map (trans ione) l) ione -> llR one l.
Proof.
apply ill_trans_to_llR.
Qed.

Theorem llR_one_to_ll_mix02 : forall l, llR one l -> ll_mix02 l.
Proof with myeeasy.
intros l pi.
induction pi ; try now constructor.
- eapply ex_r...
- eapply ex_wn_r...
- eapply cut_mix02_r...
- destruct a ; simpl.
  + apply bot_r.
    apply mix0_r...
  + change (one :: one :: nil) with ((one :: nil) ++ (one :: nil)).
    apply mix2_r ; try apply one_r...
Qed.

Theorem ll_mix02_to_ill_trans : forall l,
  ll_mix02 l -> ill_ll (map (trans ione) l) ione.
Proof with myeeasy.
intros l Hll.
apply (ll_to_ill_trans ione) in Hll ; myeasy.
- eapply stronger_ipfrag ; [ | apply Hll ].
  nsplit 3 ; myeasy.
  intros a ; destruct a.
- intros f.
  apply one_irr.
- intros f l1 l2 pi1 pi2.
  rewrite <- (app_nil_l (map _ l2 ++ map _ l1)).
  rewrite <- (app_nil_r (map _ l2 ++ map _ l1)).
  eapply cut_ir_axfree.
  + intros a ; destruct a.
  + apply tens_irr...
  + apply tens_ilr.
    apply one_ilr.
    apply one_ilr.
    apply one_irr.
Qed.

(** ** Study of the case [R = zero] *)

(** Given a sequent, the following 2 statements are equivalent:
 - the translation of the sequent is provable in [ill] for parameter [izero];
 - the sequent is provable in [llR zero].
*)

Lemma ill_trans_to_llR_zero : forall l,
  ill_ll (map (trans izero) l) izero -> llR zero l.
Proof.
apply ill_trans_to_llR.
Qed.

Lemma llR_zero_to_ill_trans : forall l,
  llR zero l -> ill_ll (map (trans izero) l) izero.
Proof with myeeasy.
intros l pi.
eapply llR_ie_to_ill_trans...
constructor.
Qed.

(** Moreover in these systems, the general weakening rule is admissible. *)
Lemma aff_to_ill_trans : forall l A,
  ill_ll (map (trans izero) l) izero -> ill_ll (map (trans izero) (A :: l)) izero.
Proof with myeeasy.
intros l A Hll.
simpl.
cons2app.
rewrite <- (app_nil_r (map _ _)).
eapply cut_ir_axfree ; try (now (intros a ; destruct a))...
apply zero_ilr.
Qed.

(** ** Study of the case [R = wn one] *)

(** Given a sequent, the following 3 statements are equivalent:
 - the translation of the sequent is provable in [ill] for any parameter [R] such that [R] is provable in [ill];
 - the sequent is provable in [llR (wn one)];
 - the sequent is provable in [ll_mix0].
*)

Theorem ill_trans_to_llR_wn_one : forall l,
  (forall R, ill_ll nil R -> ill_ll (map (trans R) l) R) -> llR (wn one) l.
Proof with myeeasy ; try PCperm_Type_solve.
intros l Hill.
remember (fresh_of_list a2n n2a l) as z.
assert (ill_ll nil (ilpam (ioc (ivar (a2i z))) (ivar (a2i z))))
  as Hz.
{ apply lpam_irr.
  apply de_ilr.
  apply ax_ir. }
specialize Hill with (ilpam (ioc (ivar (a2i z))) (ivar (a2i z))).
assert (Hz2 := Hz).
apply Hill in Hz2 ; clear Hill.
apply ill_trans_to_llR in Hz2...
apply (subs_llR _ bot z) in Hz2 ; subst.
simpl in Hz2.
rewrite repl_at_eq in Hz2 ; try rewrite a2a_i...
eapply (llR1_R2 _ (wn one)) in Hz2.
- rewrite (subs_fresh_list _ _ n2n_a) in Hz2...
- simpl.
  rewrite <- (app_nil_l (wn _ :: _)).
  apply tens_r.
  + change (wn one :: nil) with (map wn (one :: nil)).
    apply oc_r ; simpl.
    apply bot_r.
    apply de_r.
    apply one_r.
  + apply one_r.
- simpl.
  apply (ex_r _ (parr bot (wn one) :: oc bot :: nil))...
  apply parr_r.
  apply bot_r.
  change (wn one) with (dual (oc bot)).
  apply ax_exp.
Qed.

Theorem llR_wn_one_to_ll_mix0 : forall l, llR (wn one) l -> ll_mix0 l.
Proof with myeeasy.
intros l pi.
induction pi ; try now constructor.
- eapply ex_r...
- eapply ex_wn_r...
- eapply cut_mix0_r...
- destruct a ; simpl.
  + change nil with (map wn nil).
    apply oc_r.
    apply bot_r.
    apply mix0_r...
  + apply wk_r.
    apply one_r.
Qed.

Theorem ll_mix0_to_ill_trans : forall R l,
  ill_ll nil R -> ll_mix0 l -> ill_ll (map (trans R) l) R.
Proof with myeeasy.
intros R l HR Hll.
apply (stronger_pfrag _ (cutupd_pfrag pfrag_mix0 true)) in Hll.
- apply (ll_to_ill_trans R) in Hll ; myeasy.
  + unfold ill_ll ; change ipfrag_ill with (cutrm_ipfrag (cutupd_ipfrag ipfrag_ill true)).
    apply cut_admissible_ill_axfree ; [ intros a ; destruct a | ].
    eapply stronger_ipfrag ; [ | apply Hll ].
    nsplit 3...
    intros a ; destruct a.
  + intros f.
    eapply stronger_ipfrag ; [ | apply HR ].
    nsplit 3...
    intros a ; destruct a.
  + intros f ; inversion f.
- nsplit 5...
  intros a ; destruct a.
Qed.

(** ** Study of the case [R = oc bot] *)

(** Given a sequent, the following 3 statements are equivalent:
 - the translation of the sequent is provable in [ill] for any parameter [ioc R];
 - the sequent is provable in [llR (oc bot)];
 - the sequent is provable in [ll_bbb].
*)

Theorem ill_trans_to_llR_oc_bot : forall l,
  (forall R, ill_ll (map (trans (ioc R)) l) (ioc R)) ->
  llR (oc bot) l.
Proof with myeeasy ; try PCperm_Type_solve.
intros l Hill.
remember (fresh_of_list a2n n2a l) as z.
specialize Hill with (ivar (a2i z)).
apply ill_trans_to_llR in Hill...
apply (subs_llR _ bot z) in Hill ; subst.
simpl in Hill.
rewrite repl_at_eq in Hill...
rewrite (subs_fresh_list _ _ n2n_a) in Hill...
Qed.

Theorem llR_oc_bot_to_ll_bbb : forall l, llR (oc bot) l -> ll_bbb l.
Proof.
apply bb_to_bbb.
Qed.

Lemma ll_mix02_to_ill_trans_gen : forall R l,
 ll_mix02 l -> ill_ll (ioc R :: map (trans (ioc R)) l) (ioc R).
Proof with myeeasy.
intros R l Hll.
change (ioc R :: map (trans _) l)
  with (map ioc (R :: nil) ++ map (trans (ioc R)) l).
apply (stronger_pfrag _ (cutupd_pfrag pfrag_mix02 true)) in Hll.
- eapply (ll_to_ill_trans_gen (ioc R) _ _ (R :: nil)) in Hll ; myeasy.
  + unfold ill_ll ; change ipfrag_ill with (cutrm_ipfrag (cutupd_ipfrag ipfrag_ill true)).
    apply cut_admissible_ill_axfree ; [ intros a ; destruct a | ].
    eapply stronger_ipfrag ; [ | apply Hll ].
    nsplit 3...
    intros a ; destruct a.
  + intros ; apply ax_exp_ill.
  + intros ; simpl.
    rewrite <- (app_nil_l (ioc R :: _)).
    rewrite <- (app_nil_r (map _ l1)).
    rewrite app_comm_cons.
    rewrite (app_assoc _ (map _ l1)).
    eapply (cut_ir _ (itens (ioc R) (ioc R))).
    * rewrite <- 2 (app_nil_l (ioc R :: _)).
      rewrite <- ? app_assoc.
      change nil with (map ioc nil) at 2.
      apply co_ilr.
      eapply ex_ir.
      -- apply tens_irr ; [ apply X | apply X0 ].
      -- PEperm_Type_solve.
    * apply tens_ilr.
      apply wk_ilr.
      apply ax_exp_ill.
- nsplit 5...
  intros a ; destruct a.
Unshelve. all: reflexivity.
Qed.

Theorem ll_bbb_to_ill_trans : forall R l,
  ll_bbb l -> ill_ll (map (trans (ioc R)) l) (ioc R).
Proof with myeeasy ; try PEperm_Type_solve ; try now (apply ax_exp_ill).
intros R l Hll.
induction Hll ; (try now (inversion f)) ; simpl.
- eapply ex_ir.
  + eapply lmap_ilr ; [ | ].
    * eapply (ax_ir _ (a2i X)).
    * rewrite app_nil_l...
  + PEperm_Type_solve.
- eapply ex_ir...
  apply Permutation_Type_map...
- apply (ll_mix02_to_ill_trans_gen R) in l.
  rewrite <- (app_nil_l (ioc _ :: _)) in l.
  rewrite map_app.
  rewrite <- (app_nil_r (map _ l1)).
  eapply (cut_ir_axfree) ; [ intros a ; destruct a | | ]...
  eapply ex_ir ; [ | apply Permutation_Type_app_comm ]...
- apply negR_ilr...
  apply one_irr.
- rewrite <- (app_nil_l (ione :: _)).
  apply one_ilr...
- apply negR_ilr...
  list_simpl.
  eapply ex_ir ; [ | apply Permutation_Type_app_comm ].
  apply tens_irr ; apply negR_irr ; eapply ex_ir.
  + apply IHHll1.
  + PEperm_Type_solve.
  + apply IHHll2.
  + PEperm_Type_solve.
- rewrite <- (app_nil_l (itens _ _ :: _)).
  apply tens_ilr.
  eapply ex_ir...
- rewrite <- (app_nil_l (izero :: _)).
  apply zero_ilr.
- apply negR_ilr...
  apply plus_irr1 ; apply negR_irr ; eapply ex_ir...
- apply negR_ilr...
  apply plus_irr2 ; apply negR_irr ; eapply ex_ir...
- rewrite <- (app_nil_r (map _ _)).
  rewrite <- (app_nil_l (iplus _ _ :: _)).
  apply plus_ilr ; eapply ex_ir ; [ apply IHHll1 | | apply IHHll2 | ]...
- apply negR_ilr...
  rewrite map_map ; simpl.
  rewrite <- map_map.
  simpl in IHHll ; rewrite map_map in IHHll.
  simpl in IHHll ; rewrite <- map_map in IHHll.
  apply oc_irr.
  apply negR_irr.
  eapply ex_ir...
- rewrite <- (app_nil_l (ioc _ :: _)).
  apply de_ilr...
  list_simpl.
  apply negR_ilr...
  apply negR_irr...
- rewrite <- (app_nil_l (ioc _ :: _)).
  apply wk_ilr...
- rewrite <- 2 (app_nil_l (ioc _ :: _)).
  change nil with (map ioc nil).
  apply co_ilr.
  eapply ex_ir...
Qed.

(** The following result is the converse of [bb_to_bbb] proved in the [bbb] library *)

Theorem bbb_to_bb : forall l, ll_bbb l -> llR (oc bot) l.
Proof.
intros l pi.
apply ill_trans_to_llR_oc_bot.
intros R.
apply ll_bbb_to_ill_trans ; eassumption.
Qed.