(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

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

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

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

  Authors: Abhishek Anand
           Vincent Rahli
           Mark Bickford

*)

Require Export rules_union.
Require Import rules_typehood.

(* ============ INL EQUALITY (ALT) ============ *)

  (*
   H |- inl a1 = inl a2 in union(A,B)

     By inlEquality_alt

     H |- a1 = a2 in A
     H |- istype(B)
 *)
Definition rule_inl_equality_alt {p}
           (A B a1 a2 : NTerm)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_inl a1)
                      (mk_inl a2)
                      (mk_union A B)
                      )))
    [ mk_baresequent H (mk_conclax (mk_equality a1 a2 A)),
      mk_baresequent H (mk_conclax (mk_istype B ))
    ]
    [].

(* ============ INR EQUALITY (ALT) ============ *)

  (*
   H |- inr b1 = inr b2 in union(A,B)

     By inrEquality_alt

     H |- b1 = b2 in B
     H |- istype(A)
 *)

Definition rule_inr_equality_alt {p}
           (A B b1 b2 : NTerm)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_inr b1)
                      (mk_inr b2)
                      (mk_union A B)
                      )))
    [ mk_baresequent H (mk_conclax (mk_equality b1 b2 B)),
      mk_baresequent H (mk_conclax (mk_istype A))
    ]
    [].

(* ============ INL FORMATION (ALT)============ *)

  (*
   H |- union(A,B) ext inl(s)

     By inlEquality_alt

     H |- A ext s
     H |- istype(B)
 *)
Definition rule_inl_formation_alt {p}
           (A B s : NTerm)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent H (mk_concl (mk_union A B) (mk_inl s)))
    [
      mk_baresequent H (mk_concl A s),
      mk_baresequent H (mk_conclax (mk_istype B ))
    ]
    [].

(* ============ INR FORMATION ============ *)

  (*
   H |- union(A,B) ext inr(s)

     By inrEquality i

     H |- B ext s
     H |- istype(A)
 *)

Definition rule_inr_formation_alt {p}
           (A B s : NTerm)
           (H : @barehypotheses p) :=
  mk_rule
    (mk_baresequent H (mk_concl (mk_union A B) (mk_inr s)))
    [
      mk_baresequent H (mk_concl B s),
      mk_baresequent H (mk_conclax (mk_istype A ))
    ]
    [].

Lemma rule_inl_equality_alt_true {p} :
  forall lib,
  forall A B a1 a2 : NTerm,
  forall H : @barehypotheses p,
    rule_true lib
         (rule_inl_equality_alt
                 A B a1 a2 H).
Proof.
   unfold rule_inl_equality_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
    (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom p (nh_vars_hyps H)).
   (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  apply tequality_mkc_equality_implies in h0.
  pose proof (@tequality_mkc_istype p lib) as teqistype.
  rw teqistype in h2.
  apply equality_axiom_in_mkc_istype in h3.
  repnd.
  generalize (teq_and_eq_if_equality lib (mk_union A B) (mk_inl a1) (mk_inl a2) s1 s2 H
              wT w1 w2 c1 c0 c2 c3  cT cT0  eqh sim
              ); intro k; lsubst_tac; apply k; clear k; auto.

  - apply tequality_mkc_union; dands; auto; destruct h2 as [xx | yy];  auto.
  - clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.
  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  rw teqistype in hyp3.
  repnd.
  generalize_lsubstc_terms a11.
  generalize_lsubstc_terms a22.
  generalize_lsubstc_terms A1.
  generalize_lsubstc_terms B1.
  revert hyp1.
  generalize_lsubstc_terms a21.
  revert hyp0.
  generalize_lsubstc_terms a12.
  generalize_lsubstc_terms A2.
  introv teq eq.
  apply tequality_mkc_equality_implies in teq.
  repnd.
  dimp teq1.
  assert ( type lib B1 ) as Btyp.
  { apply equality_axiom_in_mkc_istype in hyp2. auto. }

  assert (equality lib a11 a22  A1) as eq2.
  + apply equality_trans with (t2 := a12); auto. apply teq3.
    apply equality_refl in eq. auto.
    eapply tequality_preserving_equality; [exact hyp |apply tequality_sym;auto ].
  + apply equality_mkc_union; dands; auto.
  * eapply tequality_refl; eauto.
  * left. eexists; eexists; dands; [spcast | spcast | exact eq2];
    apply computes_to_valc_refl; apply iscvalue_mkc_inl.
Qed.

Lemma rule_inr_equality_alt_true {p} :
  forall lib,
  forall A B b1 b2 : NTerm,
  forall H : @barehypotheses p,
    rule_true lib
         (rule_inr_equality_alt
                 A B b1 b2 H).
Proof.
   unfold rule_inr_equality_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.
    (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.
  exists (@covered_axiom p (nh_vars_hyps H)).
   (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.
  pose proof (@tequality_mkc_istype p lib) as teqistype.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  apply tequality_mkc_equality_implies in h0.
  rw teqistype in h2.
  repnd.
  generalize (teq_and_eq_if_equality lib (mk_union A B) (mk_inr b1) (mk_inr b2) s1 s2 H
              wT w1 w2 c1 c0 c2 c3  cT cT0  eqh sim
              ); intro k; lsubst_tac; apply k; clear k; auto.

  - apply tequality_mkc_union; dands; auto; destruct h2 as [xx | yy];  auto.
  - clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.
  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_equality_iff.
  rw teqistype in hyp3.
  repnd.
  generalize_lsubstc_terms b11.
  generalize_lsubstc_terms b22.
  generalize_lsubstc_terms A1.
  generalize_lsubstc_terms B1.
  revert hyp1.
  generalize_lsubstc_terms b21.
  revert hyp0.
  generalize_lsubstc_terms b12.
  generalize_lsubstc_terms B2.
  introv teq eq.
  apply tequality_mkc_equality_implies in teq.
  repnd.
  dimp teq1.
  assert ( type lib A1 ) as Atyp.
  { apply equality_axiom_in_mkc_istype in hyp2.
    auto. }
  assert (equality lib b11 b22  B1) as eq2.
  + eapply equality_trans with (t2 := b12); auto. apply teq3.
    apply equality_refl in eq. auto.
    { eapply tequality_preserving_equality; [exact hyp |apply tequality_sym;auto ]. }
  + apply equality_mkc_union; dands; auto.
  * eapply tequality_refl; eauto.
  * right. eexists; eexists; dands; [spcast | spcast | exact eq2];
    apply computes_to_valc_refl; apply iscvalue_mkc_inr.
Qed.

Lemma rule_inl_formation_alt_true3 {p} :
  forall lib,
  forall A B s : NTerm,
  forall H : @barehypotheses p,
    rule_true3 lib (rule_inl_formation_alt A B s H).
Proof.
  unfold rule_inl_formation_alt, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ ws1 hyp1 ].
  destruct Hyp0 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_concl (mk_union A B) (mk_inl s)))) as wfs.
  { clear hyp1 hyp2.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp; try (apply wf_inl; auto).
    introv xx; allrw in_app_iff; tcsp. }
  exists wfs.
  unfold wf_csequent, wf_sequent, wf_concl in wfs; allsimpl; repnd; proof_irr; GC.

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp1 s1 s2 eqh sim) as q.
  pose proof (hyp2 s1 s2 eqh sim) as h.
  clear hyp1 hyp2.
  exrepnd.
  lsubst_tac.
  pose proof (@tequality_mkc_istype p lib) as teqistype.

  rw teqistype in h0.
  apply equality_axiom_in_mkc_istype in h1.
  rw @tequality_mkc_union.
  rw @equality_mkc_union.
  dands; auto;
    try (complete (eapply member_in_uni; eauto));
    try (complete (eapply inhabited_implies_tequality; eauto)).

  left.
  exists (lsubstc s wfce0 s1 pt4) (lsubstc s wfce0 s2 pt5).
  dands; spcast; auto; try (apply computes_to_valc_refl; eauto 3 with slow).
Qed.

Lemma rule_inr_formation_alt_true3 {p} :
  forall lib,
  forall A B s : NTerm,
  forall H : @barehypotheses p,
    rule_true3 lib (rule_inr_formation_alt A B s H).
Proof.
  unfold rule_inl_formation, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ ws1 hyp1 ].
  destruct Hyp0 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent ((H) ||- (mk_concl (mk_union A B) (mk_inr s)))) as wfs.
  { clear hyp1 hyp2.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp; try (apply wf_inl; auto).
    introv xx; allrw in_app_iff; tcsp. }
  exists wfs.
  unfold wf_csequent, wf_sequent, wf_concl in wfs; allsimpl; repnd; proof_irr; GC.

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp1 s1 s2 eqh sim) as q.
  pose proof (hyp2 s1 s2 eqh sim) as h.
  clear hyp1 hyp2.
  exrepnd.
  lsubst_tac.
  pose proof (@tequality_mkc_istype p lib) as teqistype.

  rw teqistype in h0.
  apply equality_axiom_in_mkc_istype in h1.
  rw @tequality_mkc_union.
  rw @equality_mkc_union.
  dands; auto;
    try (complete (eapply member_in_uni; eauto));
    try (complete (eapply inhabited_implies_tequality; eauto)).

  right.
  exists (lsubstc s wfce0 s1 pt4) (lsubstc s wfce0 s2 pt5).
  dands; spcast; auto; try (apply computes_to_valc_refl; eauto 3 with slow).
Qed.


Require Export Problems.PCP Shared.Prelim Problems.Reduction.

(** *Some basic things concerning lists *)

Lemma list_prefix_inv X (a : X) x u y v :
  ~ a el x -> ~ a el u -> x ++ a :: y = u ++ a :: v -> x = u /\ y = v.
Proof.
  intro. revert u.
  induction x; intros; destruct u; inv H1; try now firstorder.
    eapply IHx in H4; try now firstorder. intuition congruence.
Qed.

Lemma split_inv X (u z x y : list X) (s : X) :
  u ++ z = x ++ s :: y -> ~ s el u -> exists x' : list X, x = u ++ x'.
Proof.
  revert u. induction x; cbn; intros.
  - destruct u. cbn. eauto. inv H. firstorder.
  - destruct u. cbn. eauto.
    inv H. edestruct IHx. cbn. rewrite H3. reflexivity. firstorder. subst. cbn. eauto.
Qed.

Lemma in_split X (a : X) (x : list X) :
  a el x -> exists y z, x = y ++ [a] ++ z.
Proof.
  induction x; cbn; intros.
  - firstorder.
  - destruct H as [-> | ].
    + now exists [], x.
    + destruct (IHx H) as (y & z & ->).
      now exists (a0 :: y), z.
Qed.

(** * Definitions *)

Definition symbol := nat.
Definition string := (string nat).
Definition card : Type := (card nat).
Definition stack := stack nat.
Notation "x / y" := (x,y).

Implicit Types a b : symbol.
Implicit Types x y z : string.
Implicit Types d e : card.
Implicit Types A R P : stack.

Coercion sing (n : nat) := [n].

(** ** Post Correspondence Problem *)

Lemma tau1_app A B : tau1 (A ++ B) = tau1 A ++ tau1 B.
Proof.
  induction A; cbn; try destruct _; simpl_list; congruence.
Qed.

Lemma tau2_app A B : tau2 (A ++ B) = tau2 A ++ tau2 B.
Proof.
  induction A; cbn; try destruct _; simpl_list; congruence.
Qed.

Definition cards x := map (fun a => [a] / [a]) x.

Lemma tau1_cards x : tau1 (cards x) = x.
Proof.
  induction x; cbv in *; try rewrite IHx; trivial.
Qed.

Lemma tau2_cards x : tau2 (cards x) = x.
Proof.
  induction x; cbv in *; try rewrite IHx; trivial.
Qed.

Hint Rewrite tau1_app tau2_app tau1_cards tau2_cards : list.

(** ** String Rewriting *)

Inductive rew (R : SRS) : string -> string -> Prop :=
  rewB x y u v : u / v el R -> rew R (x ++ u ++ y) (x ++ v ++ y).
Inductive rewt (R : SRS) : string -> string -> Prop :=
  rewR z : rewt R z z
| rewS x y z :  rew R x y -> rewt R y z -> rewt R x z.

Lemma rewt_induct :
  forall (R : SRS) z (P : string -> Prop),
    (P z) ->
    (forall x y : string, rew R x y -> rewt R y z -> P y -> P x) -> forall s, rewt R s z -> P s.
Proof.
  intros. induction H1; firstorder.
Qed.
Scheme rewt_ind' := Induction for rewt Sort Prop.

Instance PreOrder_rewt R : PreOrder (rewt R).
Proof.
  split.
  - econstructor.
  - hnf. intros. induction H; eauto using rewt.
Qed.

Lemma rewt_app_L R x x' y : rewt R x x' -> rewt R (y ++ x) (y ++ x').
Proof.
  induction 1. reflexivity.
  inv H.
  replace (y ++ x0 ++ u ++ y1) with ((y ++ x0) ++ u ++ y1).
  econstructor. econstructor. eassumption. simpl_list. eassumption.
  now simpl_list.
Qed.

Instance Proper_rewt R : Proper (rewt R ==> rewt R ==> rewt R) (@app symbol).
Proof.
  hnf. intros. hnf. intros. induction H.
  - now eapply rewt_app_L.
  - inv H. transitivity (x1 ++ u ++ (y1 ++ x0)). now simpl_list.
    econstructor. econstructor. eassumption. rewrite <- IHrewt. now simpl_list.
Qed.

Lemma rewt_subset R P x y :
  rewt R x y -> R <<= P -> rewt P x y.
Proof.
  induction 1; intros.
  - reflexivity.
  - inv H. eauto using rewt, rew.
Qed.

Lemma rewt_left R x y z :
  rewt R x y -> rew R y z -> rewt R x z.
Proof.
  induction 1; eauto using rewt.
Qed.

(** ** Post Grammars *)

Fixpoint sigma (a : symbol) A :=
  match A with
    nil => [a]
  | x/y :: A => x ++ (sigma a A) ++ y
  end.

(** ** Alphabets *)

Fixpoint sym (R : SRS) :=
  match R with
    [] => []
  | x / y :: R => x ++ y ++ sym R
  end.

Lemma sym_app P R :
  sym (P ++ R) = sym P ++ sym R.
Proof.
  induction P as [ | [] ]; eauto; cbn; rewrite IHP. now simpl_list.
Qed.

Lemma sym_map X (f : X -> card) l Sigma :
  (forall x : X, x el l -> sym [f x] <<= Sigma) -> sym (map f l) <<= Sigma.
Proof.
  intros. induction l as [ | ]; cbn in *.
  - firstorder.
  - pose proof (H a). destruct _. repeat eapply incl_app.
    + eapply app_incl_l, H0. eauto.
    + eapply app_incl_l, app_incl_R; eauto.
    + eauto.
Qed.

Lemma sym_word_l R u v  :
  u / v el R -> u <<= sym R.
Proof.
  induction R; cbn; intros.
  - eauto.
  - destruct a as (u', v'). destruct H; try inv H; eauto.
Qed.

Lemma sym_word_R R u v  :
  u / v el R -> v <<= sym R.
Proof.
  induction R; cbn; intros.
  - eauto.
  - destruct a as (u', v'). destruct H; try inv H; eauto.
Qed.

Hint Resolve sym_word_l sym_word_R.

Lemma sym_mono A P :
  A <<= P -> sym A <<= sym P.
Proof.
  induction A as [ | (x,y) ]; cbn; intros.
  - firstorder.
  - repeat eapply incl_app; eauto.
Qed.

Lemma tau1_sym A : tau1 A <<= sym A.
Proof.
  induction A as [ | (x & y) ].
  - firstorder.
  - cbn. intros ? [ | ] % in_app_iff. eapply in_app_iff. eauto.
    rewrite !in_app_iff. eauto.
Qed.

Lemma tau2_sym A : tau2 A <<= sym A.
Proof.
  induction A as [ | (x & y) ].
  - firstorder.
  - cbn. cbn. intros ? [ | ] % in_app_iff. eapply in_app_iff. eauto.
    rewrite !in_app_iff. eauto.
Qed.

Lemma rewt_sym R x y Sigma:
  sym R <<= Sigma -> x <<= Sigma -> rewt R x y -> y <<= Sigma.
Proof.
  intros. induction H1.
  - eauto.
  - inv H1. eapply IHrewt. repeat eapply incl_app.
    + eapply app_incl_l. eauto.
    + rewrite <- H. eapply sym_word_R. eauto.
    + eapply app_incl_R, app_incl_R. eauto.
Qed.

(** *** Fresh symbols *)

Fixpoint fresh (l : list nat) :=
  match l with
  | [] => 0
  | x :: l => S x + fresh l
  end.

Lemma fresh_spec' l a : a el l -> a < fresh l.
Proof.
  induction l.
  - firstorder.
  - cbn; intros [ | ]; firstorder omega.
Qed.

Lemma fresh_spec (a : symbol) (l : string) : a el l -> fresh l <> a.
Proof.
  intros H % fresh_spec'. intros <-. omega.
Qed.

Definition SRH '(R, x, a) := exists y, rewt R x y /\ a el y.
Definition SR '(R, x, y) := rewt R x y.
(* Definition PCP P := exists A : SRS, A <<= P /\ A <> [] /\ tau1 A = tau2 A. *)
Definition MPCP '((x,y), P) := exists A : SRS, A <<= x/y :: P /\ x ++ tau1 A = y ++ tau2 A.
Definition CFP '(R, a) := exists A : SRS, A <<= R /\ A <> [] /\ sigma a A = rev (sigma a A).
Definition CFI '(R1, R2, a) := exists A1 A2, A1 <<= R1 /\ A2 <<= R2 /\ A1 <> [] /\ A2 <> [] /\ sigma a A1 = sigma a A2.


(*********************************************)
(* This has been a bug reported by Y. Bertot *)
Inductive expr : Set :=
  | b : expr -> expr -> expr
  | u : expr -> expr
  | a : expr
  | var : nat -> expr.

Fixpoint f (t : expr) : expr :=
  match t with
  | b t1 t2 => b (f t1) (f t2)
  | a => a
  | x => b t a
  end.

Fixpoint f2 (t : expr) : expr :=
  match t with
  | b t1 t2 => b (f2 t1) (f2 t2)
  | a => a
  | x => b x a
  end.

(*********************************************)
(* Test expansion of aliases                 *)
(* Originally taken from NMake_gen.v         *)

 Local Notation SizePlus n := (S (S (S (S (S (S n)))))).
 Local Notation Size := (SizePlus O).

 Parameter zn2z : Type -> Type.
 Parameter w0 : Type.
 Fixpoint word (w : Type) (n : nat) {struct n} : Type :=
  match n with
  | 0 => w
  | S n0 => zn2z (word w n0)
  end.

 Definition w1 := zn2z w0.
 Definition w2 := zn2z w1.
 Definition w3 := zn2z w2.
 Definition w4 := zn2z w3.
 Definition w5 := zn2z w4.
 Definition w6 := zn2z w5.

 Definition dom_t n := match n with
  | 0 => w0
  | 1 => w1
  | 2 => w2
  | 3 => w3
  | 4 => w4
  | 5 => w5
  | 6 => w6
  | SizePlus n => word w6 n
 end.
Parameter plus_t : forall n m : nat, word (dom_t n) m -> dom_t (m + n).

(* This used to fail because of a bug in expansion of SizePlus wrongly
   reusing n as an alias for the subpattern *)
Definition plus_t1 n : forall m, word (dom_t n) m -> dom_t (m+n) :=
   match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with
     | SizePlus (S n') as n => plus_t n
     | _ as n =>
         fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with
                    | SizePlus (S (S m')) as m => plus_t n m
                    | _ => fun x => x
                  end
   end.

(* Test (useless) intermediate alias *)
Definition plus_t2 n : forall m, word (dom_t n) m -> dom_t (m+n) :=
   match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with
     | S (S (S (S (S (S (S n'))))) as n) as n'' => plus_t n''
     | _ as n =>
         fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with
                    | SizePlus (S (S m')) as m => plus_t n m
                    | _ => fun x => x
                  end
   end.

(*****************************************************************************)
(* Check that alias expansion behaves consistently from versions to versions *)

Definition g m :=
  match pred m with
  | 0 => 0
  | n => n (* For compatibility, right-hand side should be (S n), not (pred m) *)
  end.

Goal forall m, g m = match pred m with 0 => 0 | S n => S n end.
intro; reflexivity.
Abort.


From Undecidability.Shared.Libs.PSL Require Import FinTypes Vectors.
From Undecidability.L Require Import L_facts UpToC.

From Coq Require Vector.
Import ListNotations.

From Coq Require Import List.

From Undecidability.TM.L.CompilerBoolFuns Require Import Compiler_spec.

From Undecidability.TM Require Import TM_facts Hoare ProgrammingTools.
From Undecidability.TM.Code Require Import CaseBool CaseList WriteValue Copy ListTM.

Set Default Proof Using "Type".

Module Boollist2encBoolsTM.
Section Fix.

  Variable Σ : finType.
  Variable s b : Σ^+.

  Variable (retr_list : Retract (sigList bool) Σ).
  Local Instance retr_bool : Retract bool Σ := ComposeRetract retr_list (Retract_sigList_X _).

  Definition M__step : pTM (Σ) ^+ (option unit) 3 :=
    If (CaseList _ ⇑ retr_list @ [|Fin0;Fin2|])
       (Switch (CaseBool ⇑ retr_bool @ [|Fin2|])
            (fun x =>
            WriteMove (if x then s else b) Lmove @ [|Fin1|];;
            Return Nop None))
       (Reset _ @[|Fin0|];;Return (Write b @ [|Fin1|]) (Some tt)).

  Definition M__loop := While M__step.

  Lemma loop_SpecT:
    { f : UpToC (fun bs => length bs + 1) &
    forall bs res,
      TripleT
        (≃≃([]%list,[|Contains _ bs; Custom (fun t => right t = map (fun (x:bool) => if x then s else b) res
        /\ length (left t) <= length bs); Void|]) )
        (f bs)
        M__loop
        (fun _ => ≃≃([]%list,[|Void; Custom (eq (encBoolsTM s b (rev bs++res))) ; Void  |])) }.
  Proof.
    evar (c1 : nat);evar (c2 :nat).
    exists_UpToC (fun bs => c1 * length bs + c2). 2:now smpl_upToC_solve.
    intros bs res.
    unfold M__loop.
    refine (While_SpecTReg _ _
      (PRE := fun '(bs,res) => (_,_)) (INV := fun '(bs,res) y => ([y = match bs with []%list => Some tt | _ => None end]%list,_)) (POST := fun '(bs,res) y => (_,_))
    (f__step := fun '(bs,res) => _) (f__loop := fun '(bs,res) => _) (bs,res));
    clear bs res; intros (bs,res); cbn in *.
    { unfold M__step. hstep.
      - hsteps_cbn. cbn. tspec_ext.
      - cbn. hintros H.
        refine (_ :  TripleT _ _  _ (fun y => ≃≃( _ ,match bs with nil => _ | cons b0 bs => _ end))).
        destruct bs as [ | b0 bs]. easy. hsteps_cbn;cbn. 3:reflexivity. now tspec_ext.
        + hintros ? ->. hsteps_cbn. 2:cbn;reflexivity. tspec_ext.
      - cbn. hintros H. destruct bs. 2:easy.
        hsteps_cbn; cbn. tspec_ext. now unfold Reset_steps;cbn;reflexivity.
      - cbn. intros ? ->. reflexivity.
    }
    cbn. split.
    -intros. destruct bs. 2:easy. split.
      +tspec_ext. unfold encBoolsTM,encBoolsListTM. destruct H1 as (t&->&H'&Hr). rewrite H'.
       destruct (left t). all:easy.
      + cbn. rewrite Nat.mul_0_r. cbn. shelve.
    - intros. destruct bs as [ | b' bs]. easy. eexists (_,_);cbn.
      split.
      +tspec_ext. destruct H1 as (t&->&?&?).
       rewrite tape_right_move_left',tape_left_move_left'. rewrite H1.
       instantiate (1:=b'::res). split. easy. destruct (left t);cbn in H2|-*. all:nia.
      + split. 2:{ tspec_ext. rewrite <- H1. now rewrite <- app_assoc. }
        shelve.
    Unshelve.
    3:unfold c2;reflexivity.
    2:{ unfold CaseList_steps,CaseList_steps_cons. rewrite Encode_bool_hasSize.
     ring_simplify. [c1]:exact 68. subst c1. cbn - ["+" "*"] in *. fold Nat.add. nia. }
  Qed.

  Definition M : pTM (Σ) ^+ unit 3 :=
    (*LiftTapes (MoveToSymbol (fun _ => false) id) [|Fin1|];;*) M__loop.

  Lemma SpecT:
  { f : UpToC (fun bs => length bs + 1) &
    forall bs,
      TripleT
        (≃≃([],[|Contains _ bs; Custom (eq niltape); Void|]) )
        (f bs)
        M
        (fun _ => ≃≃([],[|Void; Custom (eq (encBoolsTM s b (rev bs))) ; Void  |])) }.
  Proof.
    eexists. intros. eapply ConsequenceT.
    eapply (projT2 loop_SpecT) with (res:=[]).
    -tspec_ext. rewrite <- H0. now cbn.
    -intros []. now rewrite app_nil_r.
    -reflexivity.
  Qed.

  Theorem Realise :
    Realise M (fun t '(r, t') =>
                     forall (l : list bool),
                        t[@Fin0] ≃ l ->
                        t[@Fin1] = niltape ->
                        isVoid (t[@Fin2]) ->
                        t'[@Fin1] = encBoolsTM s b (rev l)
                        /\ (isVoid (t'[@Fin0]) /\ isVoid (t'[@Fin2]))).
  Proof.
    repeat (eapply RealiseIntroAll;intro). eapply Realise_monotone.
    -eapply TripleT_Realise. eapply (projT2 SpecT).
    -cbn. intros ? [] H **. modpon H.
    {unfold "≃≃",withSpace;cbn. intros i; destruct_fin i;cbn. all:easy. }
    repeat destruct _;unfold "≃≃",withSpace in H;cbn in H.
    all:specializeFin H;eauto 6.
  Qed.

End Fix.
End Boollist2encBoolsTM.

Module encBoolsTM2boollist.
Section Fix.

  Variable Σ : finType.
  Variable s b : Σ^+.

  Variable (retr_list : Retract (sigList bool) Σ).
  Local Instance retr_bool : Retract bool Σ := ComposeRetract retr_list (Retract_sigList_X _).

  Definition M__step : pTM (Σ) ^+ (option unit) 2 :=
    Switch (ReadChar @ [|Fin0|])
      (fun x =>
        match x with
          None => Return Nop (Some tt)
        | Some x => Move Lmove @ [|Fin0|];;
                    If (Relabel (ReadChar @ [|Fin0|]) ssrbool.isSome)
                       ((Cons_constant.M (if Dec (x=s) then true else false)) ⇑ retr_list @ [|Fin1|];;Return Nop (None))
                       (Return (Move Rmove @ [|Fin0|]) (Some tt))
        end).

  Definition M__loop := While M__step.

  Lemma loop_SpecT (H__neq : s <> b):
    { f : UpToC (fun bs => length bs + 1) &
    forall bs res tin,
      TripleT
        (≃≃([right tin = map (fun (x:bool) => if x then s else b) res
           /\ tape_local_l tin = (map (fun (x:bool) => if x then s else b) bs++[b]) ],[| Custom (eq tin); Contains _ res|]) )
        (f bs)
        M__loop
        (fun _ => ≃≃([],[|Custom (eq (encBoolsTM s b (rev bs++res))) ; Contains _ (rev bs ++ res)|])) }.
  Proof.
    evar (c1 : nat);evar (c2 :nat).
    exists_UpToC (fun bs => c1 * length bs + c2). 2:now smpl_upToC_solve.
    intros bs res tin.
    unfold M__loop.
    refine (While_SpecTReg
      (PRE := fun '(bs,res,tin) => (_,_))
      (INV := fun '(bs,res,tin) y =>
      ([match y with None => bs <> nil | _ => bs = nil end;
      right tin = map (fun (x:bool) => if x then s else b) res;
      tape_local_l tin = (map (fun (x:bool) => if x then s else b) bs++[b])],
      match bs with nil => [|Custom (eq tin) ; Contains _ res|]
               | b'::bs => [|Custom (eq (tape_move_left tin));Contains _ (b'::res)|] end)) (POST := fun '(bs,res,tin) y => (_,_))
    (f__step := fun '(bs,res,tin) => _) (f__loop := fun '(bs,res,tin) => _) _ _ ((bs,res,tin)));
    clear bs res tin; intros [[bs res] tin]; cbn in *.
    { unfold M__step. hintros [Hres Hbs]. hsteps_cbn;cbn. 2:reflexivity.
      cbn. intros y.
      hintros (?&->&<-).
      assert (Hcur : current tin = Some (hd s (map (fun x : bool => if x then s else b) bs ++ [b]))).
      { destruct bs;cbn in Hbs. all:now eapply tape_local_l_current_cons in Hbs as ->. }
      setoid_rewrite Hcur at 2;cbn.
      hstep;cbn. now hsteps_cbn. 2:reflexivity.
      cbn;intros _.
      hstep.
      { hsteps_cbn;cbn. intros yout. hintros (?&Hy&?&->&_&<-).
        set (y:=@ssrbool.isSome (boundary + Σ) yout).
        refine (_ : Entails _ ≃≃([ y=match bs with [] => false | _ => true end],_)). subst y yout.
        tspec_ext.
        destruct bs;cbn in Hbs;eapply tape_local_l_move_left in Hbs;cbn in Hbs.
        now destruct (tape_move_left tin);cbn in Hbs|-*;congruence.
        destruct bs;cbn in Hbs;eapply tape_local_l_current_cons in Hbs. all:now rewrite Hbs.
      }
      2:{destruct bs;hintros [=];[]. cbn in *. hsteps_cbn.
        tspec_ext. 1-2:assumption. destruct H0 as (?&?&?&?&->&?&<-). rewrite H0.
        erewrite tape_move_left_right. all:easy.
      }
      { destruct bs;hintros [=];[]. cbn in *. hsteps.
        { tspec_ext;cbn in *. contains_ext. }
        { intros. hsteps_cbn. tspec_ext. 1-3:easy. 2:now destruct H0 as (?&?&?&?&?);congruence.
          f_equal. destruct b0;decide _. all:congruence. } cbv. reflexivity.
      }
      cbn. intros ? ->. destruct bs. 2:reflexivity. nia.
    }
    split.
    - intros [Hres Hbs] _;cbn. split. 2:{ cbn. [c2]:exact 14. subst c2. fold plus. nia. }
      destruct bs as [ | ];cbn. 2:easy.
      apply midtape_tape_local_l_cons in Hbs. rewrite Hres in Hbs.
      rewrite Hbs. reflexivity.
    - intros H. destruct bs as [ | b' bs]. easy.
      intros Hres Hbs. cbn in Hbs.
      apply midtape_tape_local_l_cons in Hbs. rewrite Hres in Hbs.
       eexists ((bs,b'::res),tape_move_left tin).
      repeat eapply conj.
      +cbn.
      erewrite tape_right_move_left. 2:subst;reflexivity.
      erewrite tape_local_l_move_left. 2:subst;reflexivity.
      rewrite Hres. tspec_ext. easy.
     + subst c2;cbn;ring_simplify. [c1]:exact 15. unfold c1;fold plus;nia.
     + cbn. rewrite <- !app_assoc. reflexivity.
  Qed.

  Definition M : pTM (Σ) ^+ unit 2 :=
    (MoveToSymbol (fun _ => false) (fun x => x);;Move Lmove) @ [|Fin0|];;
    WriteValue (@nil bool)⇑ retr_list @ [|Fin1|];;
    M__loop.

  Lemma SpecT (H__neq : s <> b):
    { f : UpToC (fun bs => length bs + 1) &
      forall bs,
      TripleT
        (≃≃([],[| Custom (eq (encBoolsTM s b bs)); Void|]) )
        (f bs)
        M
        (fun _ => ≃≃([],[|Custom (eq (encBoolsTM s b bs)) ; Contains _ bs|])) }.
  Proof.
    evar (f : nat -> nat).
    exists_UpToC (fun bs => f (length bs)). 2:now shelve.
    unfold M.
    intros bs.
    hstep. {hsteps_cbn. reflexivity. }
    hnf.
    intros _.
    hstep. {hsteps_cbn. reflexivity. } 2:reflexivity.
    cbn. intros _.
    {
      eapply ConsequenceT. eapply (projT2 (loop_SpecT H__neq)) with (bs:=_)(res:=_) (tin:=_).
      3:reflexivity. 2:{ intro;cbn. rewrite rev_involutive,app_nil_r. reflexivity. }
      eapply EntailsI. intros tin.
      unfold encBoolsTM,encBoolsListTM.
      rewrite MoveToSymbol_correct_midtape_end. 2:easy.
      intros [_ H]%tspecE.
      specializeFin H.
      destruct H0 as (?&H0&<-).
      tspec_solve. 2:rewrite H0;reflexivity.
      cbn. split. easy. rewrite <- map_rev,map_map;cbn. destruct (rev bs);cbn. all:easy.
    }
    cbn - ["+"].
    rewrite UpToC_le. ring_simplify.
    unfold encBoolsTM,encBoolsListTM.
    rewrite MoveToSymbol_steps_midtape_end. 2:easy.
    rewrite map_length,rev_length.
    [f]:intros n. now unfold f;set (n:=length bs);reflexivity.

    Unshelve. subst f;cbn beta. smpl_upToC_solve.
  Qed.

  Theorem Realise (H__neq : s <> b):
    Realise M (fun t '(r, t') =>
                     forall (l : list bool),
                        t[@Fin0] = encBoolsTM s b l ->
                        isVoid t[@Fin1] ->
                        t[@Fin0] = t'[@Fin0]
                        /\ t'[@Fin1] ≃ l).
  Proof.
    repeat (eapply RealiseIntroAll;intro). eapply Realise_monotone.
    -eapply TripleT_Realise,(projT2 (SpecT H__neq)).
    -intros ? [] H **. modpon H.
    {unfold "≃≃",withSpace;cbn. intros i; destruct_fin i;cbn. all:eauto. }
    repeat destruct _;unfold "≃≃",withSpace in H;cbn in H.
    specializeFin H. cbn in *;easy.
  Qed.

End Fix.
End encBoolsTM2boollist.


Require Import init.

Require Import list.
Require Import unordered_list_base.

Require Import equivalence.

Unset Keyed Unification.

Lemma in_ulist_wd U : ∀ (a : U) l1 l2, list_permutation l1 l2 →
    in_list l1 a = in_list l2 a.
Proof.
    intros a l1 l2 eq.
    apply propositional_ext.
    revert a.
    exact (list_perm_in eq).
Qed.
Definition in_ulist {U} l a
    := unary_op (E := ulist_equiv U) (in_ulist_wd U a) l.

Theorem list_perm_unique {U} : ∀ al bl : list U,
    list_permutation al bl → list_unique al → list_unique bl.
Proof.
    intros al bl albl al_uni.
    revert bl albl al_uni.
    induction al as [|a al]; intros.
    -   apply list_perm_nil_eq in albl.
        rewrite <- albl.
        exact true.
    -   destruct al_uni as [a_nin al_uni].
        assert (in_list (a ꞉ al) a) as a_in by (left; reflexivity).
        apply (list_perm_in albl) in a_in.
        apply in_list_split in a_in as [l1 [l2 eq]]; subst bl.
        pose proof (list_perm_split l1 l2 a) as eq.
        pose proof (list_perm_trans albl eq) as eq2.
        apply list_perm_add_eq in eq2.
        specialize (IHal _ eq2 al_uni).
        apply list_unique_comm.
        rewrite list_conc_add.
        cbn.
        split; [>|apply list_unique_comm; exact IHal].
        intros a_in.
        apply (list_perm_trans2 (list_perm_conc _ _)) in eq2.
        apply (list_perm_in eq2) in a_in.
        contradiction.
Qed.

Lemma ulist_unique_wd U : ∀ l1 l2 : list U, list_permutation l1 l2 →
    list_unique l1 = list_unique l2.
Proof.
    intros l1 l2 eq.
    apply propositional_ext; split.
    -   exact (list_perm_unique _ _ eq).
    -   apply list_perm_sym in eq.
        exact (list_perm_unique _ _ eq).
Qed.
Definition ulist_unique {U} :=
    unary_op (E := ulist_equiv U) (ulist_unique_wd U).

Theorem in_ulist_end {U} : ∀ a : U, ¬in_ulist ulist_end a.
Proof.
    intros a contr.
    unfold in_ulist, ulist_end in contr; equiv_simpl in contr.
    exact contr.
Qed.

Theorem in_ulist_add {U} : ∀ (a b : U) l,
    in_ulist (b ː l) a ↔ b = a ∨ in_ulist l a.
Proof.
    intros a b l.
    equiv_get_value l.
    unfold in_ulist, ulist_add; equiv_simpl.
    reflexivity.
Qed.

Theorem in_ulist_single {U} : ∀ (a b : U), in_ulist (a ː ulist_end) b → a = b.
Proof.
    intros a b b_in.
    rewrite in_ulist_add in b_in.
    destruct b_in as [b_in|b_in].
    -   exact b_in.
    -   contradiction (in_ulist_end _ b_in).
Qed.

Theorem ulist_unique_end {U} : ulist_unique (@ulist_end U).
Proof.
    unfold ulist_unique, ulist_end; equiv_simpl.
    exact true.
Qed.

Theorem ulist_unique_single {U} : ∀ a : U, ulist_unique (a ː ulist_end).
Proof.
    intros a.
    unfold ulist_unique, ulist_add, ulist_end; equiv_simpl.
    apply list_unique_single.
Qed.

Theorem ulist_unique_add {U} : ∀ (a : U) l,
    ulist_unique (a ː l) ↔ ¬in_ulist l a ∧ ulist_unique l.
Proof.
    intros a l.
    equiv_get_value l.
    unfold ulist_unique, in_ulist, ulist_add; equiv_simpl.
    reflexivity.
Qed.

Theorem in_ulist_conc {U} : ∀ l1 l2 (a : U),
    in_ulist (l1 + l2) a → in_ulist l1 a ∨ in_ulist l2 a.
Proof.
    intros l1 l2 a.
    equiv_get_value l1 l2.
    unfold in_ulist, plus; equiv_simpl.
    apply in_list_conc.
Qed.

Theorem in_ulist_lconc {U} : ∀ l1 l2 (a : U),
    in_ulist l1 a → in_ulist (l1 + l2) a.
Proof.
    intros l1 l2 a.
    equiv_get_value l1 l2.
    unfold in_ulist, plus; equiv_simpl.
    apply in_list_lconc.
Qed.
Theorem in_ulist_rconc {U} : ∀ l1 l2 (a : U),
    in_ulist l2 a → in_ulist (l1 + l2) a.
Proof.
    intros l1 l2 a.
    equiv_get_value l1 l2.
    unfold in_ulist, plus; equiv_simpl.
    apply in_list_rconc.
Qed.

Theorem in_ulist_split {U} : ∀ l (a : U), in_ulist l a → ∃ l', l = a ː l'.
Proof.
    intros l a a_in.
    equiv_get_value l.
    unfold in_ulist in a_in; equiv_simpl in a_in.
    apply list_split_perm in a_in as [l' eq].
    exists (to_equiv _ l').
    unfold ulist_add; equiv_simpl.
    exact eq.
Qed.

Theorem in_ulist_image {U V} : ∀ l a (f : U → V),
    in_ulist l a → in_ulist (ulist_image f l) (f a).
Proof.
    intros l a f.
    equiv_get_value l.
    unfold in_ulist, ulist_image; equiv_simpl.
    apply in_list_image.
Qed.

Theorem image_in_ulist {U V} : ∀ l y (f : U → V),
    in_ulist (ulist_image f l) y → ∃ x, f x = y ∧ in_ulist l x.
Proof.
    intros l y f.
    equiv_get_value l.
    unfold in_ulist, ulist_image; equiv_simpl.
    intros y_in.
    apply image_in_list in y_in as [x H].
    exists x.
    equiv_simpl.
    exact H.
Qed.

Theorem ulist_image_unique {U V} : ∀ (l : ulist U) (f : U → V),
    ulist_unique (ulist_image f l) → ulist_unique l.
Proof.
    intros l f.
    equiv_get_value l.
    unfold ulist_image, ulist_unique; equiv_simpl.
    apply list_image_unique.
Qed.

Theorem ulist_in_unique_eq {U} : ∀ al bl : ulist U,
    ulist_unique al → ulist_unique bl →
    (∀ x, in_ulist al x ↔ in_ulist bl x) → al = bl.
Proof.
    intros al bl.
    equiv_get_value al bl.
    unfold ulist_unique, in_ulist; equiv_simpl.
    intros al_uni bl_uni ins.
    apply (list_in_unique_perm _ _ al_uni bl_uni).
    intros x.
    specialize (ins x).
    equiv_simpl in ins.
    exact ins.
Qed.


Require Export Common Computation.

(** Type of a constructor. *)
Definition constructorType (rep dom : Type)
  :=  dom (* Initialization arguments *)
     -> Comp rep (* Freshly constructed model *).

(** Type of a method. *)
Definition methodType (rep dom cod : Type)
  := rep    (* Initial model *)
     -> dom (* Method arguments *)
     -> Comp (rep * cod) (* Final model and return value. *).

(* Signatures of ADT operations *)
Record ADTSig :=
  {
    (** The index set of constructors *)
    ConstructorIndex : Type;

    (** The index set of methods *)
    MethodIndex : Type;

    (** The representation-independent domain of constructors. *)
    ConstructorDom : ConstructorIndex -> Type;

    (** The representation-independent domain and codomain of methods. *)
    MethodDomCod : MethodIndex -> Type * Type

  }.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.

Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.

Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.

Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories.
Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActionsInBicat.

Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory.

Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Biequivalence.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.

Import BifunctorNotations.

Local Opaque bifunctor_data_from_functorintoendofunctorcat_is_bifunctor.

Section ActegoryToObject.

  Context {V : category} (Mon_V : monoidal V).
  Context {C : category}.

  Definition fmonoidal_data_to_object
             (act : actegory Mon_V C)
    : fmonoidal_data
        (monoidal_swapped Mon_V)
        (monoidal_from_bicat_and_ob (C : bicat_of_cats))
        (bifunctor_to_functorintoendofunctorcat act).
  Proof.
    split.
    - intros v w.
      exists (λ c, actegory_actorinvdata act w v c).
      abstract (intros v1 w1 f;
      apply actorinv_nat_leftwhisker).
    - exists (λ v, actegory_unitorinvdata act v).
      abstract (intros v w f;
      exact (! actegory_unitorinvnat Mon_V act v w f)).
  Defined.

  Definition fmonoidal_laxlaws_to_object
             (act : actegory Mon_V C)
    : fmonoidal_laxlaws (fmonoidal_data_to_object act).
  Proof.
    repeat split ; (intro ; intros ; apply nat_trans_eq ; [apply homset_property | intro ; cbn ]).
    - apply actorinv_nat_rightwhisker.
    - apply actorinv_nat_leftrightwhisker.
    - rewrite id_left.
      apply pentagon_identity_actorinv.
    - rewrite (! actegory_triangleidentity Mon_V act x x0).
      rewrite assoc.
      etrans. {
        apply maponpaths_2.
        rewrite assoc'.
        apply maponpaths.
        exact (pr2 (actegory_actorisolaw Mon_V act x (monoidal_unit Mon_V) x0)).
      }
      rewrite id_right.
      rewrite (! bifunctor_leftcomp act _ _ _ _ _ _).
      etrans. {
        apply maponpaths.
        apply actegory_unitorisolaw.
      }
      apply (bifunctor_leftid act).
    - set (tri := actegory_triangleidentity' Mon_V act x x0).
      rewrite (! tri).
      rewrite assoc.
      etrans. {
        apply maponpaths_2.
        rewrite assoc'.
        apply maponpaths.
        exact (pr2 (actegory_actorisolaw Mon_V act (monoidal_unit Mon_V) x x0)).
      }
      rewrite id_right.
      apply actegory_unitorisolaw.
  Qed.

  Definition fmonoidal_lax_to_object
             (act : actegory Mon_V C)
    : fmonoidal_lax
        (monoidal_swapped Mon_V)
        (monoidal_from_bicat_and_ob (C : bicat_of_cats))
        (bifunctor_to_functorintoendofunctorcat act)
    := fmonoidal_data_to_object act ,, fmonoidal_laxlaws_to_object act.

  Definition fmonoidal_stronglaws_to_object (Act : actegory Mon_V C)
    : fmonoidal_stronglaws
        (pr1 (fmonoidal_data_to_object Act))
        (pr2 (fmonoidal_data_to_object Act)).
  Proof.
    repeat (use tpair).
    - intros v w.
      use tpair.
      + exists (λ c, actegory_actordata Act w v c).
        abstract (intros c1 c2 f;
        cbn;
        apply (! actegory_actornatleft _ _ _ _ _ _ _ )).
      + use tpair;
        [ apply nat_trans_eq;
          [ apply homset_property |
          intro;
          apply actegory_actorisolaw]
        | apply nat_trans_eq;
          [ apply homset_property |
          intro;
          apply (pr1 (actegory_actorisolaw Mon_V Act w v x))] ].
    - exact (λ c, actegory_unitordata Act c).
    - abstract (intros c1 c2 f;
      cbn;
      apply actegory_unitornat).
    - abstract (use nat_trans_eq;
      [ apply homset_property |
      intro;
      cbn;
      apply actegory_unitorisolaw]).
    - abstract (use nat_trans_eq;
      [ apply homset_property |
      intro;
      cbn;
      apply actegory_unitorisolaw]).
  Defined.

  Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats).

  Definition actegory_to_object (Act : actegory Mon_V C)
    : bicatactionbicat (monoidal_swapped Mon_V) bicat_of_cats ax2.
  Proof.
    exists C.
    exists (bifunctor_to_functorintoendofunctorcat Act).
    exists (fmonoidal_lax_to_object Act).
    exact (fmonoidal_stronglaws_to_object Act).
  Defined.

End ActegoryToObject.

Section ActegoryFromObject.

  Context {V : category}.
  Context (Mon_V : monoidal V).

  Context (ax2 : actionbicat_ax2 Mon_V bicat_of_cats).

  Context (C : bicatactionbicat Mon_V bicat_of_cats ax2).

  Local Definition action_C := pr12 C.
  Local Definition action_fmon_lax := pr122 C.
  Local Definition action_fmon_strong := pr222 C.

  Definition unitor_from_object
    :  action_unitor_data Mon_V (bifunctor_from_functorintoendofunctorcat action_C).
  Proof.
    intro ; apply (pr12 action_fmon_strong).
  Defined.

  Definition unitorinv_from_object
    : action_unitorinv_data Mon_V (bifunctor_from_functorintoendofunctorcat action_C).
  Proof.
    intro ; apply (fmonoidal_preservesunit action_fmon_lax).
  Defined.

  Definition actor_from_object
    : actor_data (monoidal_swapped Mon_V) (bifunctor_from_functorintoendofunctorcat action_C)
    := λ v w c, pr11 (pr1 action_fmon_strong w v) c.

  Definition actorinv_from_object
    : actorinv_data (monoidal_swapped Mon_V) (bifunctor_from_functorintoendofunctorcat action_C)
    := λ v w c, pr1 (fmonoidal_preservestensordata (pr122 C) w v) c.

  Definition actegory_data_from_object
    : actegory_data (monoidal_swapped Mon_V) (pr1 C).
  Proof.
    exists (bifunctor_from_functorintoendofunctorcat action_C).
    exists unitor_from_object.
    exists unitorinv_from_object.
    exists actor_from_object.
    exact actorinv_from_object.
  Defined.

  Lemma actegory_laws_from_object
    : actegory_laws (monoidal_swapped Mon_V) actegory_data_from_object.
  Proof.
    split5.
    - apply bifunctor_data_from_functorintoendofunctorcat_is_bifunctor.
    - repeat split.
      + intro ; intros.
        (* That the monoidal unit is strongly preserved, means that we have
           a morphism in the category of endofunctors on C,
           i.e. a natural transformation, hence, we use this naturality *)
        apply (pr212 action_fmon_strong).
      + (* Here we use that the unit is strongly preserved, that is,
           we use that the equation that expresses that the
           unit preserving morphism is invertible *)
        apply (eqtohomot (base_paths _ _ (pr222 action_fmon_strong))).
      + (* Idem as previous bullet point *)
        apply (eqtohomot (base_paths _ _ (pr122 action_fmon_strong))).
    - repeat split.
      + intro ; intros.
        (* That the monoidal unit is strongly preserved, means that we have
           a morphism in the category of endofunctors on C,
           i.e. a natural transformation, hence, we use this naturality *)
        exact (! pr21 (pr1 action_fmon_strong w v) z z' h).
      + intros v1 v2 w c f.
        set (fmon_strong_preserves_tensor_inv := preservestensor_inv_is_nattrans
              (pr12 action_fmon_lax)
              (pr122 action_fmon_lax)
              (pr1 action_fmon_strong)).
        exact (! (eqtohomot (base_paths _ _ (pr12 fmon_strong_preserves_tensor_inv w _ _ f)) c)).
      + intros w v1 v2 c f.
        exact (eqtohomot (base_paths _ _ (preserves_tensorinv_nat_right (pr1 action_fmon_strong) (pr122 action_fmon_lax) v1 v2 w f)) c).
      + apply (eqtohomot (base_paths _ _ (pr22 (pr1 action_fmon_strong w v)))).
      + apply (eqtohomot (base_paths _ _ (pr12 (pr1 action_fmon_strong w v)))).
    - intros v c.
      cbn.
      assert (plu := preserves_leftunitality'' (_,,pr222 C) v).
      assert (pluc := eqtohomot (base_paths _ _ plu) c).
      refine (_ @ pluc).
      clear pluc ; clear plu.
      cbn.
      rewrite ! id_right.
      apply idpath.
    - intro ; intros.
      cbn.
      unfold actor_from_object.
      assert (t := ! eqtohomot (base_paths _ _ (preserves_associativity_of_inverse_preserves_tensor (pr1 (pr222 action_fmon_lax)) (pr1 action_fmon_strong) v' v w)) z).
      cbn in t.
      rewrite id_right in t.
      set (αisov'vw := z_iso_inv (z_iso_from_associator_iso Mon_V v' v w)).
      rewrite assoc' in t.
      assert (pf:  (pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong v' (v ⊗_{ Mon_V} w))) z
                      · pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong v w)) (pr1 ((pr12 C) v') z))
                   =  pr1 (# (pr12 C) (monoidal_associatorinvdata Mon_V v' v w)) z · (pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong (v' ⊗_{ Mon_V} v) w)) z
                                                                                · # (pr1 ((pr12 C) w)) (pr1 (is_z_isomorphism_mor (pr1 action_fmon_strong v' v)) z))).
      {
        etrans.
        2: {
          apply maponpaths.
          exact t.
        }
        rewrite ! assoc.
        apply maponpaths_2.
        etrans.
        2: {
          apply maponpaths_2.
          assert (bla := eqtohomot (base_paths _ _ (maponpaths (# (pr12 C)) (pr2 (monoidal_associatorisolaw Mon_V v' v w)))) z).
          rewrite functor_comp in bla.
          exact (! bla).
        }
        rewrite functor_id.
        apply (! id_left _).
      }
      refine (_ @ ! pf).
      apply assoc'.
  Qed.

  Definition actegory_from_object
    : actegory (monoidal_swapped Mon_V) (pr1 C)
    := actegory_data_from_object ,, actegory_laws_from_object.

End ActegoryFromObject.

Context {V : category} (Mon_V : monoidal V).

Local Definition ACAT
  : bicat := actbicat Mon_V.

Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats).

Local Definition ACTI
  : bicat := bicatactionbicat (monoidal_swapped Mon_V) bicat_of_cats ax2.

Section EqualityLemmaHelpers.

  Definition equality_of_2cells_in_ACAT
             {a b : ACAT} {f g : ACAT⟦a,b⟧} (α β : prebicat_cells _ f g)
    : (∏ x : (pr11 a),  pr11 α x = pr11 β x) -> α = β.
  Proof.
    intro p.
    use total2_paths_f.
    {
      use nat_trans_eq.
      { apply homset_property. }
      exact (λ x, p x).
    }
    apply proofirrelevance.
    repeat (apply impred_isaprop ; intro).
    apply homset_property.
  Qed.

  Definition equality_of_2cells_in_ACTI
             {a b : ACTI} {f g : ACTI⟦a,b⟧} (α β : prebicat_cells _ f g)
    : (∏ x : (pr11 a),  pr11 α x = pr11 β x) -> α = β.
  Proof.
    intro p.
    use total2_paths_f.
    {
      use nat_trans_eq.
      { apply homset_property. }
      intro x.
      exact (p x).
    }
    apply proofirrelevance.
    apply impred_isaprop ; intro.
    apply cellset_property.
  Qed.

  Lemma equality_of_ACTI_endofunctors
        {a b : psfunctor_bicat ACTI ACTI}
        {f g : (psfunctor_bicat ACTI ACTI)⟦a,b⟧}
        (α β : prebicat_cells (psfunctor_bicat ACTI ACTI) f g)
    : (∏ x : ACTI,  ∏ x0 : pr11 ((pr111 a) x), (pr11 ((pr111 α) x)) x0 = (pr11 ((pr111 β) x)) x0) -> α = β.
  Proof.
    intro p.
    use total2_paths_f.
    2: { apply proofirrelevance ; apply isapropunit. }
    use total2_paths_f.
    2: { use total2_paths_f ;
         (apply proofirrelevance ; try (apply isapropdirprod) ; apply isapropunit). }
    use total2_paths_f.
    2: { apply proofirrelevance ;
          repeat (apply impred_isaprop ; intro) ;
         apply cellset_property. }
    apply funextsec ; intro.
    use equality_of_2cells_in_ACTI.
    intro.
    apply p.
  Qed.

  Lemma equality_of_ACAT_endofunctors
        {a b : psfunctor_bicat ACAT ACAT}
        {f g : (psfunctor_bicat ACAT ACAT)⟦a,b⟧}
        (α β : prebicat_cells (psfunctor_bicat ACAT ACAT) f g)
    : (∏ x : ACAT,  ∏ x0 : pr11 ((pr111 a) x), (pr11 ((pr111 α) x)) x0 = (pr11 ((pr111 β) x)) x0) -> α = β.
  Proof.
    intro p.
    use total2_paths_f.
    2: { apply proofirrelevance ; apply isapropunit. }
    use total2_paths_f.
    2: { use total2_paths_f ;
         (apply proofirrelevance ; try (apply isapropdirprod) ; apply isapropunit). }
    use total2_paths_f.
    2: { apply proofirrelevance ;
          repeat (apply impred_isaprop ; intro) ;
         apply cellset_property. }
    apply funextsec ; intro.
    use equality_of_2cells_in_ACAT.
    intro.
    apply p.
  Qed.

End EqualityLemmaHelpers.

Section FromActegoriesToActionsInCat.

  Import MonoidalNotations.

  Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats).
  Definition acat_to_acti_on_ob : ob ACAT -> ob ACTI
    := λ act, actegory_to_object Mon_V ax2 (pr2 act).

  Lemma actegory_hom_preserves_unitor_inv
        {a1 a2 : ACAT} (f : ACAT ⟦ a1, a2 ⟧)
        (c : pr11 (actegory_to_object Mon_V ax2 (pr2 a1)))
    : actegory_unitorinvdata (pr2 a2 : actegory _ _) (pr1 (pr1 f) c) · (pr12 f) I_{ Mon_V} c
      = # (pr11 f) (actegory_unitorinvdata (pr2 a1 : actegory _ _) c).
  Proof.
    set (t := (pr222 (pr22 f)) c). (* preserves_unitor *)
    apply (z_iso_inv_on_right _ _ _ (_,,_,,actegory_unitorisolaw Mon_V (pr2 a2) (pr1 (pr1 f) c))).
    cbn.
    etrans.
    2: { apply maponpaths_2 ; apply t. }
    rewrite assoc'.
    rewrite <- functor_comp.
    rewrite (pr1 (actegory_unitorisolaw Mon_V (pr2 a1) c)).
    rewrite functor_id.
    apply (! id_right _).
  Qed.

  Definition acat_to_acti_on_mor_data_data
    {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) :
    nat_trans_data (ActionBasedStrongFunctorsWhiskeredMonoidal.H(V:=V)(FA':=pr12(actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f))
      (ActionBasedStrongFunctorsWhiskeredMonoidal.H'(FA:=pr12(actegory_to_object Mon_V ax2 (pr2 a1))) (pr1 f)).
  Proof.
    intro v.
    exists (λ c, pr1 (pr2 f) v c).
    abstract (exact (λ c1 c2 g, pr1 (pr22 f) v c1 c2 g)).
  Defined.

  Definition acat_to_acti_on_mor_data_data_is_nat_trans
    {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) :
    is_nat_trans _ _ (acat_to_acti_on_mor_data_data f).
  Proof.
    intros v w g.
    use nat_trans_eq.
    { apply homset_property. }
    intro c.
    cbn.
    exact (pr12 (pr22 f) v w c g).
  Qed.

  Definition acat_to_acti_on_mor_data
    {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) :
    ActionBasedStrongFunctorsWhiskeredMonoidal.parameterized_distributivity_bicat_nat(V:=V)
      (FA:=pr12(actegory_to_object Mon_V ax2 (pr2 a1)))(FA':=pr12(actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f)
    := _,,acat_to_acti_on_mor_data_data_is_nat_trans f.

  Lemma acat_to_acti_on_mor_laws
    {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧) :
    ActionBasedStrongFunctorsWhiskeredMonoidal.param_distr_bicat_triangle_eq (monoidal_swapped Mon_V)
      (pr22 (actegory_to_object Mon_V ax2 (pr2 a1))) (pr22 (actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f) (acat_to_acti_on_mor_data f)
      × ActionBasedStrongFunctorsWhiskeredMonoidal.param_distr_bicat_pentagon_eq (monoidal_swapped Mon_V)
      (pr22 (actegory_to_object Mon_V ax2 (pr2 a1))) (pr22 (actegory_to_object Mon_V ax2 (pr2 a2))) (pr1 f) (acat_to_acti_on_mor_data f).
  Proof.
    split.
    - use nat_trans_eq.
      { apply homset_property. }
      intro c ;
        cbn ;
        rewrite ! id_left ;
        apply actegory_hom_preserves_unitor_inv.
    - intros v w.
      use nat_trans_eq.
      { apply homset_property. }
      intro c ;
        cbn ;
        rewrite ! id_left ;
        assert (t := pr122 (pr22 f) w v c) ;
        apply (z_iso_inv_on_right _ _ _ (_,,_,,actegory_actorisolaw Mon_V (pr2 a2) _ _ _)) ;
        rewrite assoc ;
        set (i := (_,,_,,actegory_actorisolaw Mon_V (pr2 a1) w v c) : z_iso _ _) ;
        apply (z_iso_inv_on_left _ _ _ _ (functor_on_z_iso (pr1 f) i)) ;
        cbn ;
        rewrite assoc ;
        rewrite t ;
        apply idpath.
  Qed.

  Definition acat_to_acti_on_mor
             {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧)
    : ACTI⟦actegory_to_object Mon_V ax2 (pr2 a1), actegory_to_object Mon_V ax2 (pr2 a2)⟧.
  Proof.
    exists (pr1 f).
    exists (acat_to_acti_on_mor_data f).
    apply acat_to_acti_on_mor_laws.
  Defined.

  Definition acat_to_acti_data
    : psfunctor_data ACAT ACTI.
  Proof.
    use make_psfunctor_data.
    - exact acat_to_acti_on_ob.
    - exact (λ a1 a2 f, acat_to_acti_on_mor f).
    - intros a1 a2 f g α.
      exists (pr1 α).
      abstract (intro v; use nat_trans_eq;
      [apply homset_property |
      exact (λ c, pr2 α v c)]).
    - intro a.
      use tpair.
      + apply nat_trans_id.
      + abstract
          (intro v;
           use nat_trans_eq;
           [apply homset_property | ] ;
           intro c;
           cbn ;
           unfold identity_lineator_data ;
           rewrite ! id_left ;
           rewrite id_right ;
           apply (! bifunctor_leftid (_ ,, pr122 a) _ _)).
    - intros a1 a2 a3 f g.
      use tpair.
      {  simpl. apply nat_trans_id. }
      abstract (intro v;
                use nat_trans_eq;
                [apply homset_property |
                  intro c;
                  cbn;
                  rewrite (bifunctor_leftid (_ ,, pr122 a3));
                  rewrite ! id_left;
                  rewrite ! id_right;
                  apply idpath]).
  Defined.

  Definition acat_to_acti_laws
    : psfunctor_laws acat_to_acti_data.
  Proof.
    repeat split ;
      (intro ; intros ; use equality_of_2cells_in_ACTI ; intro ; try (apply idpath) ; cbn).
    - rewrite ! id_right ; apply (! functor_id _ _).
    - rewrite ! id_right ; apply idpath.
    - rewrite ! id_right ; rewrite (! functor_id _ _) ; rewrite id_left ; apply idpath.
    - rewrite id_left ; apply (! id_right _).
    - rewrite id_left ; apply (! id_right _).
  Qed.

  Definition acat_to_acti_invertible_cells
    : invertible_cells acat_to_acti_data.
  Proof.
    use tpair.
    - intro.
      use tpair.
      + use tpair.
        * apply nat_trans_id.
        * intro.
          use nat_trans_eq.
          { apply homset_property. }
          intro.
          cbn.
          rewrite ! id_right.
          apply (! bifunctor_leftid (_ ,, pr122 a) _ _).
      + use tpair ; use equality_of_2cells_in_ACTI ; intro ; apply id_right.
    - intro ; intros.
      use tpair.
      + use tpair.
        * apply nat_trans_id.
        * intro.
          use nat_trans_eq.
          { apply homset_property. }
          intro.
          simpl.
          rewrite ! id_right.
          rewrite ! id_left.
          rewrite (bifunctor_leftid (_ ,, pr122 c)).
          apply (! id_left _).
      + use tpair ; use equality_of_2cells_in_ACTI ; intro ; apply id_right.
  Qed.

  Definition acat_to_acti
    : psfunctor ACAT ACTI.
  Proof.
    use make_psfunctor.
    - exact acat_to_acti_data.
    - exact acat_to_acti_laws.
    - exact acat_to_acti_invertible_cells.
  Defined.

End FromActegoriesToActionsInCat.

Section FromActionInCatToActegories.

  Definition acti_to_acat_on_ob : (ob ACTI) -> (ob ACAT)
    := λ act, _ ,, actegory_from_object _ ax2 act.

  Definition acti_to_acat_on_mor_lineator_data
             {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧)
    :  lineator_data Mon_V (actegory_from_object (monoidal_swapped Mon_V) ax2 a1)
                     (actegory_from_object (monoidal_swapped Mon_V) ax2 a2) (pr1 f)
    := λ v c, pr1 (pr112 f v) c.

  Definition acti_to_acat_on_mor_lineator_lax_laws
             {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧)
    :  lineator_laxlaws
         Mon_V
         (actegory_from_object (monoidal_swapped Mon_V) ax2 a1)
         (actegory_from_object (monoidal_swapped Mon_V) ax2 a2)
         (pr1 f)
         (acti_to_acat_on_mor_lineator_data f).
  Proof.
    repeat split.
    - intros v c1 c2 g.
      exact (pr2 (pr112 f v) c1 c2 g).
    - intros v w c g.
      exact (eqtohomot (base_paths _ _ (pr212 f v w g)) c).
    - intros v w c.
      induction f as [f [δ [tri pent]]].
      assert (tt := eqtohomot (base_paths _ _ (pent w v)) c).
      cbn in tt.
      rewrite ! id_left in tt.
      transparent assert (z_iso_ptwvFc
               : (is_z_isomorphism ( pr1 (fmonoidal_preservestensordata (pr22 a2) w v) (pr1 f c)))
             ).
      { exists (pr11 (fmonoidal_preservestensorstrongly (pr22 a2) w v) (pr1 f c)).
        exists (eqtohomot (base_paths _ _ (pr12 (fmonoidal_preservestensorstrongly (pr22 a2) w v))) (pr1 f c)).
        exact (eqtohomot (base_paths _ _ (pr22 (fmonoidal_preservestensorstrongly (pr22 a2) w v))) (pr1 f c)).
      }
      assert (tt' := ! z_iso_inv_on_right _ _ _ (_,,z_iso_ptwvFc) _ _ (! tt)).
      etrans. {
        apply maponpaths_2.
        exact tt'.
      }
      cbn.
      clear tt'.
      etrans.
      2: { apply assoc. }
      etrans. { apply assoc'. }
      apply maponpaths.
      etrans. { apply assoc'. }
      etrans. { apply assoc'. }
      apply maponpaths.
      etrans. {
        apply maponpaths.
        rewrite (! functor_comp f _ _).
        apply maponpaths.
        exact (eqtohomot (base_paths _ _ (pr12 (pr1 (pr222 a1) w v))) c).
      }
      simpl.
      rewrite functor_id.
      apply id_right.
    - (* preserves_unitor *)
      intro c.
      induction f as [F [δ [tri pent]]].
      assert (tric := eqtohomot (base_paths _ _ tri) c).
      cbn in tric.
      rewrite ! id_left in tric.
      transparent assert (z_iso_puFc
                           : (is_z_isomorphism ( pr1 (fmonoidal_preservesunit (pr22 a2)) (pr1 F c)))).
      {
        exists (pr11 (fmonoidal_preservesunitstrongly (pr22 a2))(pr1 F c)).
        exists (eqtohomot (base_paths _ _ (pr122 (pr222 a2))) (pr1 F c)).
        exact (eqtohomot (base_paths _ _ (pr222 (pr222 a2))) (pr1 F c)).
      }
      assert (tric' := ! z_iso_inv_on_right _ _ _ (_,,z_iso_puFc) _ _ (! tric)).
      etrans. { apply maponpaths_2 ; exact tric'. }
      clear tric'.
      clear tric.
      rewrite assoc'.
      etrans. {
        apply maponpaths.
        exact (! functor_comp F  (pr1 (fmonoidal_preservesunit (pr22 a1)) c) _).
      }
      etrans. {
        do 2 apply maponpaths.
        exact (eqtohomot (base_paths _ _ (pr122 (pr222 a1))) c).
      }
      rewrite (functor_id F _).
      apply id_right.
  Qed.

  Definition acti_to_acat_on_mor_lineator_lax
             {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧)
    : lineator_lax Mon_V (actegory_from_object (monoidal_swapped Mon_V) ax2 a1)
                   (actegory_from_object (monoidal_swapped Mon_V) ax2 a2) (pr1 f).
  Proof.
    exists (acti_to_acat_on_mor_lineator_data f).
    exact (acti_to_acat_on_mor_lineator_lax_laws f).
  Defined.

  Definition acti_to_acat_on_mor
             {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧)
    : ACAT ⟦ acti_to_acat_on_ob a1, acti_to_acat_on_ob a2⟧.
  Proof.
    exists (pr1 f).
    exact (acti_to_acat_on_mor_lineator_lax f).
  Defined.

  Definition acti_to_acat_data
    : psfunctor_data ACTI ACAT.
  Proof.
    use make_psfunctor_data.
    - exact acti_to_acat_on_ob.
    - exact (λ a1 a2 f, acti_to_acat_on_mor f).
    - intros a1 a2 f g α.
      exists (pr1 α).
      intros v a.
      exact (eqtohomot (base_paths _ _ (pr2 α v)) a).
    - intro a.
      use tpair.
      + exists (λ c, identity c).
        intro ; intros ; exact (id_right _ @ ! id_left _).
      + intros v c.
        cbn.
        rewrite ! id_right.
        unfold identity_lineator_data.
        cbn.
        apply (! functor_id _ _).
    - intros a1 a2 a3 f g.
      use tpair.
      + exists (λ c, identity _).
        intro ; intros ; exact (id_right _ @ ! id_left _).
      + intros v c.
        cbn.
        unfold comp_lineator_data.
        cbn.
        rewrite ! id_right.
        rewrite ! id_left.
        cbn.
        rewrite (functor_id ((pr12 a3) v)).
        rewrite id_left.
        apply idpath.
  Defined.

  Definition acti_to_acat_laws
    : psfunctor_laws acti_to_acat_data.
  Proof.
    repeat split ;
      (intro ; intros ; use equality_of_2cells_in_ACAT ; intro ; try (apply idpath) ; cbn).
    - rewrite ! id_right ; apply (! functor_id _ _).
    - rewrite ! id_right ; apply idpath.
    - rewrite ! id_right ; rewrite (! functor_id _ _) ; rewrite id_left ; apply idpath.
    - rewrite id_left ; apply (! id_right _).
    - rewrite id_left ; apply (! id_right _).
  Qed.

  Definition acti_to_acat_invertible_cells
    : invertible_cells acti_to_acat_data.
  Proof.
    use tpair.
    - intro.
      use tpair.
      + use tpair.
        * apply nat_trans_id.
        * intro ; intro.
          cbn.
          rewrite ! id_right.
          apply (! functor_id _ _).
      + use tpair ; use equality_of_2cells_in_ACAT ; intro ; apply id_right.
    - intro ; intros.
      use tpair.
      + use tpair.
        * apply nat_trans_id.
        * intro ; intro.
          rewrite ! id_right.
          etrans.
          2: { apply cancel_postcomposition. cbn.
               apply pathsinv0, functor_id. }
          rewrite id_left.
          cbn.
          unfold ActionBasedStrongFunctorsWhiskeredMonoidal.parameterized_distributivity_bicat_nat_funclass.
          unfold comp_lineator_data.
          cbn.
          rewrite ! id_right.
          rewrite ! id_left.
          apply idpath.
      + use tpair ; use equality_of_2cells_in_ACAT ; intro ; apply id_right.
  Qed.

  Definition acti_to_acat
    : psfunctor ACTI ACAT.
  Proof.
    use make_psfunctor.
    - exact acti_to_acat_data.
    - exact acti_to_acat_laws.
    - exact acti_to_acat_invertible_cells.
  Defined.

End FromActionInCatToActegories.

Section ActionInCatEquivActegories.

  Context (ax2 : actionbicat_ax2 (monoidal_swapped Mon_V) bicat_of_cats).

  Definition acti_to_acat_unit_data_on_ob (a : ACTI)
    : ACTI ⟦Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat a, Identity.id_psfunctor ACTI a⟧.
  Proof.
    exists (identity _).
    use tpair.
      + use make_nat_trans.
        * intro v.
          exists (λ c, identity _).
          intros c1 c2 f.
          abstract (
              simpl ;
              rewrite id_left ;
              apply id_right).
        * intros v w f.
          use nat_trans_eq.
          { apply homset_property. }
          abstract ( intro c; cbn;
          rewrite id_left;
          apply id_right ).
      + use tpair.
        * use nat_trans_eq.
          { apply homset_property. }
          intro c.
          abstract (
              cbn ;
              rewrite id_right ;
              rewrite ! id_left ;
              apply idpath).
        * intro ; intro.
          use nat_trans_eq.
          { apply homset_property. }
          intro c.
          abstract (
              cbn ;
              rewrite ! id_left ;
              rewrite ! id_right ;
              rewrite (functor_id ((pr12 a) w)) ;
              apply (! id_left _)).
  Defined.

  Definition acti_to_acat_unit_data
    :  pstrans_data (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat) (Identity.id_psfunctor ACTI).
  Proof.
    use make_pstrans_data.
    - exact (λ a, acti_to_acat_unit_data_on_ob a).
    - intros a1 a2 f.
      use tpair.
      + use tpair.
        * exists (λ c, identity _).
          intros c1 c2 g.
          abstract (
              simpl ;
              rewrite id_left ;
              apply id_right
            ).
        * intro.
          use nat_trans_eq.
          { apply homset_property. }
          intro.
          abstract (
              cbn ;
              rewrite ! id_left ;
              rewrite ! id_right ;
              unfold ActionBasedStrongFunctorsWhiskeredMonoidal.parameterized_distributivity_bicat_nat_funclass ;
              rewrite (functor_id (pr1 f)) ;
              rewrite (functor_id ((pr12 a2) v)) ;
              rewrite id_left ;
              apply id_right
            ).
      +  use tpair.
         * use tpair.
           -- exists (λ c, identity _).
              intros c1 c2 g.
              simpl.
              rewrite id_left.
              apply id_right.
           -- intro.
              use nat_trans_eq.
              { apply homset_property. }
              intro.
              abstract (
                  simpl ;
                  rewrite ! id_left ;
                  rewrite ! id_right ;
                  rewrite (functor_id  ((pr12 a2) v)) ;
                  rewrite (functor_id (pr1 f)) ;
                  rewrite id_left ;
                  apply (! id_right _)
                ).
         * use tpair ; use equality_of_2cells_in_ACTI ;
             intro ; simpl ; apply id_right.
  Defined.

  Lemma acti_to_acat_unit_is_pstrans
    : is_pstrans acti_to_acat_unit_data.
  Proof.
    repeat split ; intros ; intros ; use equality_of_2cells_in_ACTI ; intro ; intros ; simpl.
    - rewrite id_left ; apply id_right.
    - rewrite id_left ; apply (! id_left _).
    - rewrite ! id_left ; rewrite ! id_right ; apply (! functor_id _ _).
  Qed.

  Definition acti_to_acat_unit
    :  pstrans (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat) (Identity.id_psfunctor ACTI).
  Proof.
    use make_pstrans.
    - exact acti_to_acat_unit_data.
    - exact acti_to_acat_unit_is_pstrans.
  Defined.

  Definition acti_to_acat_counit_data_on_ob (a : ACAT)
    : ACAT ⟦Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2) a, Identity.id_psfunctor ACAT a⟧.
  Proof.
    exists (identity _).
    exists (λ _ _, identity _).
    abstract (
        simpl ;
        repeat split ; (intro ; intros ; try (rewrite id_right ; rewrite id_left ; apply idpath)) ;
        [
          rewrite id_left ;
          rewrite id_right ;
          rewrite (bifunctor_leftid (_ ,, pr122 a)) ;
          apply (! id_right _)
        |
          rewrite id_left ; apply idpath ]).
  Defined.

  Definition acti_to_acat_counit_data
    :  pstrans_data (Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2)) (Identity.id_psfunctor ACAT).
  Proof.
    use make_pstrans_data.
    - exact (λ a, acti_to_acat_counit_data_on_ob a).
    - intros a1 a2 f.
      use tpair.
      + use tpair.
        * exists (λ c, identity _).
          intros c1 c2 g.
          abstract (
              simpl ;
              rewrite id_left ;
              apply id_right
            ).
        * abstract (
              intro ; intro ;
              simpl ;
              unfold comp_lineator_data ;
              simpl ;
              rewrite functor_id ;
              rewrite ! id_right ;
              rewrite (bifunctor_leftid (_ ,, pr122 a2));
              rewrite ! id_left ;
              apply idpath
            ).
      + use tpair.
        * use tpair.
           -- exists (λ c, identity _).
              abstract (
                  intros c1 c2 g ;
                  simpl ;
                  rewrite id_left ;
                  apply id_right
                ).
           -- abstract (
                  intro ; intro ;
                  simpl ;
                  unfold comp_lineator_data ;
                  simpl ;
                  rewrite functor_id ;
                  rewrite ! id_right ;
                  rewrite (bifunctor_leftid (_ ,, pr122 a2)) ;
                  rewrite ! id_left ;
                  apply idpath
                ).
        * use tpair ; use equality_of_2cells_in_ACAT ;
             intro ; simpl ; apply id_right.
  Defined.

  Lemma acti_to_acat_counit_is_pstrans
    : is_pstrans acti_to_acat_counit_data.
  Proof.
    repeat split ; intros ; intros ; use equality_of_2cells_in_ACAT ; intro ; intros ; simpl.
    - rewrite id_left ; apply id_right.
    - rewrite id_left ; apply (! id_left _).
    - rewrite ! id_left ; rewrite ! id_right ; apply (! functor_id _ _).
  Qed.

  Definition acti_to_acat_counit
    :  pstrans (Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2)) (Identity.id_psfunctor ACAT).
  Proof.
    use make_pstrans.
    - exact acti_to_acat_counit_data.
    - exact acti_to_acat_counit_is_pstrans.
  Defined.

  Definition acti_biequiv_unit_counit_acat
    : is_biequivalence_unit_counit acti_to_acat (acat_to_acti ax2).
  Proof.
    exists acti_to_acat_unit.
    exact acti_to_acat_counit.
  Defined.

  Definition ps_base_ACTI
    :  Base.ps_base ACTI ACTI ⟦ pr111 (Identity.id_psfunctor ACTI),
  pr111 (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat) ⟧.
  Proof.
    intro.
    exists (functor_identity _).
    use tpair.
    + use make_nat_trans.
      * intro.
        exists (λ _, identity _).
        abstract (
            intro ; intros ;
            rewrite id_left ;
            apply id_right
          ).
      * intro ; intros ; use nat_trans_eq.
        { apply homset_property. }
        intro ; cbn; rewrite id_left; apply id_right.
      + use tpair.
        * use nat_trans_eq.
          { apply homset_property. }
          abstract (
              intro ;
              cbn ;
              rewrite ! id_left ;
              apply id_right
            ).
        * intro ; intro.
          use nat_trans_eq.
          { apply homset_property. }
          abstract (
              intro ;
              cbn ;
              rewrite ! id_left ;
              rewrite ! id_right ;
              rewrite (functor_id ((pr12 x) w)) ;
              apply (! id_left _)
            ).
  Defined.

  Definition ps_base_ACAT
    :  Base.ps_base ACAT ACAT ⟦ pr111 (Identity.id_psfunctor ACAT),
                                pr111 (Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2)) ⟧.
  Proof.
    intro.
    exists (functor_identity _).
    repeat (use tpair).
    - exact (λ _ _, identity _).
    - abstract (
            intro ; intros ;
            rewrite id_left ;
            apply id_right
        ).
    - abstract (
            intro ; intros ;
            rewrite id_left ;
            apply id_right
        ).
    - abstract (
          intro ; intros ;
          cbn ;
          rewrite (bifunctor_leftid (_ ,, pr122 x)) ;
          rewrite ! id_left ;
          rewrite ! id_right ;
          apply idpath
        ).
    - abstract (intro ; apply id_left).
  Defined.

  Definition ACAT_invertible_2cell {a1 a2 : ACAT} (f : ACAT⟦a1,a2⟧)
    : invertible_2cell (ps_base_ACAT a1 · acti_to_acat_on_mor (acat_to_acti_on_mor ax2 f)) (f · ps_base_ACAT a2).
  Proof.
    repeat (use tpair).
    - exact (λ _, identity _).
    - abstract (
            intro ; intros ;
            cbn ;
            rewrite id_left ;
            apply id_right
        ).
    - abstract (
          intro ; intro ;
          cbn ;
          unfold comp_lineator_data ;
          simpl ;
          rewrite (bifunctor_leftid (_ ,, pr122 a2)) ;
          rewrite ! id_left ;
          rewrite functor_id ;
          rewrite id_right ;
          apply id_right
        ).
    - exact (λ _, identity _).
    - abstract (
            intro ; intros ;
            cbn ;
            rewrite id_left ;
            apply id_right
        ).
    - abstract (
          intro ; intro ;
          cbn ;
          unfold comp_lineator_data ;
          simpl ;
          rewrite (bifunctor_leftid (_ ,, pr122 a2)) ;
          rewrite ! id_left ;
          rewrite functor_id ;
          apply idpath
        ).
    - abstract (use equality_of_2cells_in_ACAT; intro; cbn; apply id_right).
    - abstract (use equality_of_2cells_in_ACAT; intro; cbn; apply id_right).
  Defined.

  Definition ACTI_invertible_2cell {a1 a2 : ACTI} (f : ACTI⟦a1,a2⟧)
    :   invertible_2cell (ps_base_ACTI a1 · acat_to_acti_on_mor ax2 (acti_to_acat_on_mor f)) (f · ps_base_ACTI a2).
  Proof.
    use tpair.
    - use tpair.
      + exists (λ _, identity _).
        abstract (
            intro ; intros ;
            cbn ;
            rewrite id_left ;
            apply id_right
          ).
      + intro.
        use nat_trans_eq.
        { apply homset_property. }
        abstract (
            intro ;
            cbn ;
            rewrite (functor_id (pr1 f)) ;
            rewrite ! id_left ;
            rewrite ! id_right ;
            rewrite (functor_id ((pr12 a2) v)) ;
            apply (! id_left _)
          ).
    - use tpair.
      + use tpair.
        * exists (λ _, identity _).
          abstract (
              intro ; intros ;
              rewrite id_left ;
              apply id_right
            ).
        * intro.
          use nat_trans_eq.
          { apply homset_property. }
          abstract (
              intro ;
              cbn ;
              rewrite (functor_id (pr1 f)) ;
              rewrite ! id_left ;
              rewrite ! id_right ;
              rewrite (functor_id ((pr12 a2) v)) ;
              apply (! id_left _)
            ).
      + abstract (
            use tpair ; use equality_of_2cells_in_ACTI ;
             intro ; simpl ; apply id_left).
  Defined.

  Definition ps_functor_ACTI
    : psfunctor_bicat ACTI ACTI ⟦ Identity.id_psfunctor ACTI,
                                  Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat ⟧.
  Proof.
    refine (_ ,, tt).
    use tpair.
    - exists ps_base_ACTI.
      exact (λ a1 a2 f, ACTI_invertible_2cell f).
    - repeat (use tpair) ; (intro ; intros ; use equality_of_2cells_in_ACTI ;
             intro ; simpl).
      + abstract (rewrite id_left ; apply id_right).
      + abstract (apply idpath).
      + abstract (rewrite ! id_left ;
                  rewrite ! id_right ;
                  apply (! functor_id (pr1 g) _)
                 ).
  Defined.

  Definition ps_functor_ACAT
    :  psfunctor_bicat ACAT ACAT ⟦ Identity.id_psfunctor ACAT,
  Composition.comp_psfunctor acti_to_acat (acat_to_acti ax2) ⟧.
  Proof.
    refine (_ ,, tt).
    use tpair.
    - exists ps_base_ACAT.
      exact (λ a1 a2 f, ACAT_invertible_2cell f).
    - repeat (use tpair) ; (intro ; intros ; use equality_of_2cells_in_ACAT ;
             intro ; simpl).
      + abstract (rewrite id_left ; apply id_right).
      + abstract (apply idpath).
      + abstract (rewrite ! id_left ;
                  rewrite ! id_right ;
                  apply (! functor_id (pr1 g) _)
                 ).
  Defined.

  Definition unit_left_adjoint_data
    :  Adjunctions.left_adjoint_data acti_to_acat_unit.
  Proof.
    exists ps_functor_ACTI.
    use tpair ; refine (_ ,, tt).

    - use tpair.
      + use tpair.
        * intro. use tpair.
          -- exists (λ _, identity _).
             abstract (
                 intro ; intros ;
                 simpl ;
                 rewrite id_left ;
                 rewrite id_right ;
                 apply idpath
               ).
          -- intro ; intros.
             use nat_trans_eq.
             { apply homset_property. }
             abstract (
                 intro ;
                 cbn ;
                 rewrite ! id_left ;
                 rewrite id_right ;
                 apply (! functor_id _ _)
               ).
        * abstract (
              intro ; intros ;
              use equality_of_2cells_in_ACTI ;
              intro ; simpl ;
              rewrite ! id_right ;
              apply (! functor_id (pr1 f) _)
            ).
      + exact (tt,,(tt,,tt)).
    - use tpair.
      + use tpair.
        * intro.
          use tpair.
          -- exists (λ _, identity _).
             abstract (
                 intro ; intros ;
                 rewrite id_left ;
                 apply id_right
               ).
          -- intro ; intros.
             use nat_trans_eq.
             { apply homset_property. }
             abstract (
                 intro ; simpl ;
                 rewrite ! id_left ;
                 rewrite id_right ;
                 apply (! functor_id _ _)
               ).
        * abstract (
              intro ; intros ;
              use equality_of_2cells_in_ACTI ;
              intro ; simpl ;
              rewrite (functor_id (pr1 f) _) ;
              rewrite ! id_right ;
              apply idpath
            ).
      + exact (tt,, (tt,,tt)).
  Defined.

  Definition counit_left_adjoint_data
    :  Adjunctions.left_adjoint_data acti_to_acat_counit.
  Proof.
    exists ps_functor_ACAT.
    use tpair ; refine (_ ,, tt).

    - use tpair.
      + use tpair.
        * intro.
          use tpair.
          -- exists (λ _, identity _).
             abstract (
                 intro ; intros ;
                 simpl ;
                 rewrite id_left ;
                 rewrite id_right ;
                 apply idpath
               ).
          -- abstract (
                 intro ; intros ;
                 cbn ;
                 rewrite (bifunctor_leftid (_ ,, pr122 x)) ;
                 rewrite ! id_left ;
                 apply (! id_right _)
               ).
        * abstract (
              intro ; intros ;
              use equality_of_2cells_in_ACAT ;
              intro ;
              cbn ;
              rewrite ! id_left ;
              rewrite id_right ;
              apply (! functor_id _ _)
            ).
      + exact (tt,,(tt,,tt)).
    - use tpair.
      + use tpair.
        * intro.
          use tpair.
          -- exists (λ _, identity _).
             abstract (
                 intro ; intros ;
                 rewrite id_left ;
                 apply id_right
               ).
          -- abstract (
                 intro ; intros ;
                 simpl ;
                 rewrite (bifunctor_leftid (_ ,, pr122 x)) ;
                 apply id_right
               ).
        * abstract (
              intro ; intros ;
              use equality_of_2cells_in_ACAT ;
              intro ;
                 cbn ;
                 rewrite ! id_left ;
                 rewrite id_right ;
                 apply (! functor_id _ _)).
      + exact (tt,,(tt,,tt)).
  Defined.

  Lemma unit_left_adjoints_axioms
    :  Adjunctions.left_adjoint_axioms unit_left_adjoint_data.
  Proof.
    use tpair ; apply equality_of_ACTI_endofunctors ; intro ; intro ; simpl ; rewrite ! id_right ; apply idpath.
  Qed.

  Definition invertible_2cell_unit_data (a : ACTI)
    :  prebicat_cells ACTI
    ((pr111 (acti_to_acat_unit · Adjunctions.left_adjoint_right_adjoint unit_left_adjoint_data)) a)
    ((pr111 (identity (Composition.comp_psfunctor (acat_to_acti ax2) acti_to_acat))) a).
  Proof.
    use tpair.
      + exists (λ _, identity _).
        abstract (
            intro ; intros ;
            simpl ;
            rewrite id_left ;
            apply id_right
          ).
      + intro ; intros.
        use nat_trans_eq.
        { apply homset_property. }
        abstract (
            intro ;
            simpl ;
            rewrite ! id_left ;
            rewrite id_right ;
            apply (! functor_id _ _)
          ).
  Defined.

  Lemma is_invertible_2cell_unit
    : is_invertible_2cell (Adjunctions.left_adjoint_unit unit_left_adjoint_data).
  Proof.
    use make_is_invertible_2cell.
    - use tpair.
      + use tpair.
        * exists (λ a, invertible_2cell_unit_data a).
          do 3 intro ; use equality_of_2cells_in_ACTI.
          abstract (
              intro ;
              simpl ;
              rewrite ! id_left ;
              rewrite id_right ;
              apply (! functor_id _ _)
            ).
        * repeat (use tpair) ; try (exact tt).
      + exact tt.
    - abstract (
          use equality_of_ACTI_endofunctors ;
          intro ; intro ;
          simpl ; apply id_right
        ).
    - abstract (use equality_of_ACTI_endofunctors ;
      intro ; intro ; simpl ; apply id_right).
  Qed.

  Lemma is_invertible_2cell_counit
    : is_invertible_2cell (Adjunctions.left_adjoint_counit unit_left_adjoint_data).
  Proof.
    repeat (use tpair) ; try (exact tt).
    - intro.
      use tpair.
      + exists (λ _, identity _).
        abstract (
            intro ; intros ;
            simpl ;
            rewrite id_left ;
            apply id_right
          ).
      + intro ; intros.
        use nat_trans_eq.
        { apply homset_property. }
        abstract (
            intro ;
            simpl ;
            rewrite ! id_left ;
            rewrite id_right ;
            apply (! functor_id _ _)
          ).
    - abstract (
          intro ; intros ;
          use equality_of_2cells_in_ACTI ;
          intro ;
          simpl ;
          rewrite ! id_left ;
          rewrite id_right ;
          apply (! functor_id _ _)
        ).
    - abstract (
          use equality_of_ACTI_endofunctors ;
          intro ; intro ;
          simpl ;
          apply id_right
        ).
    - abstract (
          use equality_of_ACTI_endofunctors ;
          intro ; intro ;
          simpl ;
          apply id_right
        ).
   Qed.

  Definition prebicat_cells_ACAT (a : ACAT)
    :  prebicat_cells ACAT ((pr111 (identity (Identity.id_psfunctor ACAT))) a)
                      ((pr111 (Adjunctions.left_adjoint_right_adjoint counit_left_adjoint_data · acti_to_acat_counit)) a).
  Proof.
    use tpair.
      + exists (λ _, identity _).
        abstract (
            intro ; intros ;
            simpl ;
            rewrite id_left ;
            apply id_right
          ).
      + abstract (
            intro ; intros ;
            simpl ;
            rewrite (bifunctor_leftid (_ ,, pr122 a)) ;
            apply (! id_left _)
          ).
  Defined.

  Lemma is_invertible_2cell_counit'
    : is_invertible_2cell (Adjunctions.left_adjoint_counit counit_left_adjoint_data).
  Proof.
    repeat (use tpair) ; try (exact tt).
    - exact (λ _, prebicat_cells_ACAT _).

    - abstract (
          intro ; intros ;
          use equality_of_2cells_in_ACAT ;
          intro ;
          simpl ;
          rewrite ! id_left ;
          rewrite id_right ;
          apply (! functor_id _ _)
        ).

    - abstract (
          use equality_of_ACAT_endofunctors ;
          intro ; intro ;
          simpl ;
          apply id_right
        ).
    - abstract (
          use equality_of_ACAT_endofunctors ;
          intro ; intro ;
          simpl ;
          apply id_right
        ).
   Qed.

  Lemma counit_left_adjoints_axioms
    :  Adjunctions.left_adjoint_axioms counit_left_adjoint_data.
  Proof.
    use tpair ; apply equality_of_ACAT_endofunctors ; intro ; intro ; simpl ; rewrite ! id_right ; apply idpath.
  Qed.

  Lemma is_invertible_2cell_unit'
    :  is_invertible_2cell (Adjunctions.left_adjoint_unit counit_left_adjoint_data).
  Proof.
    repeat (use tpair) ; try (exact tt).
    - intro.
      use tpair.
      + exists (λ _, identity _).
        abstract (
            intro ; intros ;
            simpl ;
            rewrite id_left ;
            apply id_right
          ).
      + abstract (
            intro ; intros ;
            simpl ;
            unfold comp_lineator_data ;
            unfold identity_lineator_data ;
            cbn ;
            rewrite (bifunctor_leftid (_ ,, pr122 x)) ;
            apply id_right
          ).
    - abstract (
          intro ; intros ;
          use equality_of_2cells_in_ACAT ;
          intro ;
          simpl ;
          rewrite ! id_left ;
          rewrite id_right ;
          apply (! functor_id _ _)
        ).
    - abstract (
          use equality_of_ACAT_endofunctors ;
          intro ; intro ;
          simpl ; apply id_right
        ).
    - abstract (use equality_of_ACAT_endofunctors ;
      intro ; intro ; simpl ; apply id_right).
  Qed.

  Lemma unit_left_adjoint_equiv_axiom
    :  Adjunctions.left_equivalence_axioms unit_left_adjoint_data.
  Proof.
    exists is_invertible_2cell_unit.
    exact is_invertible_2cell_counit.
  Qed.

  Lemma counit_left_adjoint_equiv_axiom
    :  Adjunctions.left_equivalence_axioms counit_left_adjoint_data.
  Proof.
    exists is_invertible_2cell_unit'.
    exact is_invertible_2cell_counit'.
  Qed.

  Definition unit_left_adjoint_equivalence
    :  Adjunctions.left_adjoint_equivalence (unit_of_is_biequivalence acti_biequiv_unit_counit_acat).
  Proof.
    exists unit_left_adjoint_data.
    exists unit_left_adjoints_axioms.
    exact unit_left_adjoint_equiv_axiom.
  Defined.

  Definition counit_left_adjoint_equivalence
    :  Adjunctions.left_adjoint_equivalence (counit_of_is_biequivalence acti_biequiv_unit_counit_acat).
  Proof.
    exists counit_left_adjoint_data.
    exists counit_left_adjoints_axioms.
    exact counit_left_adjoint_equiv_axiom.
  Defined.

  Definition acti_biequiv_adj_acat
    : is_biequivalence_adjoints acti_biequiv_unit_counit_acat.
  Proof.
    exists unit_left_adjoint_equivalence.
    exact counit_left_adjoint_equivalence.
  Defined.

  Definition acti_is_biequiv_acat
    : is_biequivalence acti_to_acat.
  Proof.
    exists (acat_to_acti ax2).
    exists acti_biequiv_unit_counit_acat.
    exact acti_biequiv_adj_acat.
  Defined.

  Definition acti_biequiv_acat
    : biequivalence ACTI ACAT.
  Proof.
    exists (acti_to_acat).
    exact acti_is_biequiv_acat.
  Defined.

End ActionInCatEquivActegories.