From Coq Require Export Morphisms RelationClasses Setoid Program.Equality.
From ITree Require Export ITree ITreeFacts Eq.Rutt Props.Divergence Props.Finite.
From Paco Require Import paco.
From Coq Require Export Eqdep EqdepFacts.
Require Import Lia.
Require Export Refinement.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

Variant conv_refF {E : Type -> Type} {R : Type} (F : itree_spec E R -> Prop) : itree_spec' E R -> Prop :=
  | conv_ref_RetF r : conv_refF F (RetF r)
  | conv_ref_TauF t : F t -> conv_refF F (TauF t)
  | conv_ref_existsF (A : Type) (k : A -> itree_spec E R) :
    (forall a, F (k a) ) -> conv_refF F (VisF Spec_exists k)
  | conv_ref_forallF (A : Type) (k : A -> itree_spec E R) :
    A -> (forall a, F (k a)) -> conv_refF F (VisF Spec_forall k)
.

Definition conv_ref_ {E : Type -> Type} {R : Type} (F : itree_spec E R -> Prop) (t : itree_spec E R) :=
  conv_refF F (observe t).

Lemma monotone_conv_refF {E R} (ot : itree_spec' E R) sim sim'
      (LE : sim <1= sim')
      (IN : conv_refF sim ot) :
  conv_refF sim' ot.
Proof. induction IN; constructor; auto. Qed.

Lemma monotone_conv_ref_ {E R} : monotone1 (@conv_ref_ E R).
Proof. red. intros. eapply monotone_conv_refF; eauto. Qed.

Hint Resolve monotone_conv_ref_ : paco.

Definition conv_ref {E R} : itree_spec E R -> Prop := paco1 conv_ref_ bot1.

Lemma conv_ref_ret_bind E1 E2 R1 S R2 RE REAns RR r (t2 : itree_spec E2 R2) :
  forall (t1 : itree_spec E2 S),
    conv_ref t1 ->
    @refines E1 E2 R1 R2 RE REAns RR (Ret r) (t1 >> t2) ->
    refines RE REAns RR (Ret r) t2.
Proof.
  intros t1 Ht1 Href. punfold Href. red in Href. cbn in Href.
  punfold Ht1. red in Ht1. pstep. red. cbn.
  remember (RetF r) as x. remember (t1 >> t2) as tbind.
  assert (Htbind : tbind ≅ t1 >> t2). subst. reflexivity.
  clear Heqtbind. punfold Htbind. red in Htbind.
  hinduction Href before RR; intros; inv Heqx; use_simpobs.
  - unfold observe in Htbind. cbn in Htbind. destruct (observe t1) eqn : Ht1';
      inv Htbind; try inv CHECK.
    setoid_rewrite <- H2. constructor. auto.
  - assert (HDEC: (exists t1', observe t1 = TauF t1') \/ (exists r', observe t1 = RetF r') ).
    { unfold observe in Htbind. cbn in Htbind. destruct (observe t1); eauto.
      inv Htbind; inv CHECK. }
    destruct HDEC as [[t1' Ht1']  | [r' Hr'] ].
    + eapply IHHref with (t1 := t1'); eauto.
      rewrite Ht1' in Ht1. inv Ht1. pclearbot. pstep_reverse.
      assert (Tau phi ≅ t1 >> t2). pstep. auto.
      symmetry in Ht1'. use_simpobs. rewrite Ht1' in H. rewrite bind_tau in H.
      pinversion H; try inv CHECK. pclearbot. subst.
      clear - REL. pclearbot. pstep_reverse.
    + assert (Tau phi ≅ t1 >> t2). pstep. auto.
      symmetry in Hr'. use_simpobs. rewrite Hr' in H.
      rewrite bind_ret_l in H.
      punfold H. red in H. cbn in H. inv H; try inv CHECK.
      constructor. pclearbot. eapply IHHref; eauto.
      pstep_reverse. rewrite Hr', bind_ret_l. clear - REL. pclearbot. auto.
  - assert (HDEC : (exists k : A -> _, observe t1 = VisF Spec_forall k) \/ (exists r', observe t1 = RetF r') ).
    {
      unfold observe in Htbind. cbn in Htbind. destruct (observe t1); eauto.
      inv Htbind; inv CHECK.
      cbn in Htbind. inv Htbind. inj_existT. subst. eauto. }
    destruct HDEC as [ [k Hk] | [r' Hr'] ].
    + rewrite Hk in Ht1. inv Ht1. inj_existT. subst. pclearbot. rename X into a.
      eapply H0 with (t1 := k a); eauto. pstep_reverse. Unshelve. all : auto.
      assert (Vis Spec_forall kphi ≅ t1 >> t2). pstep. auto.
      symmetry in Hk. use_simpobs. rewrite Hk in H1. rewrite bind_vis in H1.
      pinversion H1. inj_existT. subst. clear - REL. pclearbot.
      pstep_reverse.
    + symmetry in Hr'. use_simpobs.
      assert (Vis Spec_forall kphi ≅ t1 >> t2). pstep. auto.
      rewrite Hr' in H1. rewrite bind_ret_l in H1.
      pinversion H1; try inv CHECK. inj_existT. subst.
      constructor. intros. clear - H REL. pclearbot.
      rewrite itree_eta' at 1. pstep_reverse. rewrite <- REL. pstep. apply H.
  -  assert (HDEC : (exists k : A -> _, observe t1 = VisF Spec_exists k) \/ (exists r', observe t1 = RetF r') ).
    {
      unfold observe in Htbind. cbn in Htbind. destruct (observe t1); eauto.
      inv Htbind; inv CHECK.
      cbn in Htbind. inv Htbind. inj_existT. subst. eauto. }
    destruct HDEC as [ [k Hk] | [r' Hr'] ].
    + rewrite Hk in Ht1. inv Ht1. inj_existT. subst. pclearbot.
      eapply IHHref with (t1 := k a); eauto. pstep_reverse.
      assert (Vis Spec_exists kphi ≅ t1 >> t2). pstep. auto.
      symmetry in Hk. use_simpobs. rewrite Hk in H. rewrite bind_vis in H.
      pinversion H. inj_existT. subst. clear - REL. pclearbot.
      pstep_reverse.
    + symmetry in Hr'. use_simpobs.
      assert (Vis Spec_exists kphi ≅ t1 >> t2). pstep. auto.
      rewrite Hr' in H. rewrite bind_ret_l in H.
      pinversion H; try inv CHECK. inj_existT. subst. econstructor.
      Unshelve. all : auto. clear - REL Href. pclearbot.
      rewrite itree_eta' at 1. pstep_reverse. rewrite <- REL. pstep. apply Href.
Qed.

Global Instance conv_ref_eqit_proper E R b1 b2 :
  Proper (@eqit (SpecEvent E) R R eq b1 b2 ==> flip impl) conv_ref.
Proof.
  pcofix CIH.
  intros t1 t2 Ht Ht2. pstep. red. punfold Ht2. red in Ht2.
  punfold Ht. red in Ht.
  hinduction Ht before R; intros; pclearbot; try (constructor; eauto).
  - right. eapply CIH; eauto. inv Ht2. pclearbot. auto.
  - inv Ht2. inj_existT. subst. constructor. right. pclearbot. eapply CIH; eauto.
    apply REL. apply H0.
    inj_existT. subst. constructor; auto. pclearbot. right. eapply CIH; eauto.
    apply REL. apply H0.
  - left. pstep. red. eapply IHHt; eauto.
  - inv Ht2. pclearbot. punfold H0.
Qed.

Lemma padded_conv_ref_ret_bind E1 E2 R1 S R2 RE REAns RR r (t2 : itree_spec E2 R2) :
  forall (t1 : itree_spec E2 S),
    conv_ref t1 ->
    @padded_refines E1 E2 R1 R2 RE REAns RR (Ret r) (t1 >> t2) ->
    padded_refines RE REAns RR (Ret r) t2.
Proof.
  intros t1 Ht1. unfold padded_refines. setoid_rewrite pad_ret.
  setoid_rewrite pad_bind. intros. rewrite pad_eutt in Ht1. eapply conv_ref_ret_bind; eauto.
Qed.

Lemma conv_ref_bind E R S (k : R -> itree_spec E S) :
  forall t, conv_ref t ->
  (forall r, conv_ref (k r) ) ->
   conv_ref (ITree.bind t k).
Proof.
  intros t Ht Hk. generalize dependent t. pcofix CIH. intros t Ht. punfold Ht. red in Ht.
  pstep. red. unfold observe. cbn. inv Ht.
  - pstep_reverse. eapply paco1_mon; try eapply Hk. intros. contradiction.
  - constructor. right. pclearbot. eapply CIH; eauto.
  - constructor. right. pclearbot. eapply CIH; apply H0.
  - constructor; auto. right. pclearbot. eapply CIH; apply H0.
Qed.

Lemma conv_ref_ret E R (r : R) :
  @conv_ref E R (Ret r).
Proof.
  pstep. red. constructor.
Qed.

Variant conv_ref_mrecF {E D : Type -> Type} {R : Type} (P : forall A, D A -> Prop)
        (F : itree_spec (D +' E) R -> Prop) :
  itree_spec' (D +' E) R -> Prop :=
  | conv_ref_mrec_RetF r : conv_ref_mrecF P F (RetF r)
  | conv_ref_mrec_TauF t : F t -> conv_ref_mrecF P F (TauF t)
  | conv_ref_mrec_existsF (A : Type) (k : A -> itree_spec _ R) :
    (forall a, F (k a) ) -> conv_ref_mrecF P F (VisF Spec_exists k)
  | conv_ref_mrec_forallF (A : Type) (k : A -> itree_spec _ R) :
    A -> (forall a, F (k a)) -> conv_ref_mrecF P F (VisF Spec_forall k)
  | conv_ref_mrec_inlF (A : Type) (d : D A) (k : A -> itree_spec _ R) :
    P A d ->
    (forall a, F (k a) ) -> conv_ref_mrecF P F (VisF (Spec_vis (inl1 d) ) k)
.

Definition conv_ref_mrec_ {E D: Type -> Type} {R : Type} P (F : itree_spec (D +' E) R -> Prop)
           (t : itree_spec (D +' E) R) :=
  conv_ref_mrecF P F (observe t).

Lemma monotone_conv_ref_mrecF {E D R} P (ot : itree_spec' (D +' E) R) sim sim'
      (LE : sim <1= sim')
      (IN : conv_ref_mrecF P sim ot) :
  conv_ref_mrecF P sim' ot.
Proof. induction IN; constructor; auto. Qed.

Lemma monotone_conv_ref_mrec_ {E D R} P : monotone1 (@conv_ref_mrec_ E D R P ).
Proof. red. intros. eapply monotone_conv_ref_mrecF; eauto. Qed.

Hint Resolve monotone_conv_ref_mrec_ : paco.

Definition conv_ref_mrec {E D R} P : itree_spec (D +' E) R -> Prop := paco1 (conv_ref_mrec_ P) bot1.

Lemma conv_ref_mrec_bind E D R S P (k : R -> itree_spec (D +' E) S ) :
  forall t, conv_ref_mrec P t ->
  (forall r, conv_ref_mrec P (k r) ) ->
   conv_ref_mrec P (ITree.bind t k).
Proof.
  intros t Ht Hk. generalize dependent t. pcofix CIH. intros t Ht.
  pstep. red. unfold observe. cbn. punfold Ht. red in Ht.
  inv Ht.
  - pstep_reverse. eapply paco1_mon; try apply Hk. intros. contradiction.
  - constructor. right. pclearbot. eapply CIH; eauto.
  - constructor. right. pclearbot. eapply CIH; eauto. apply H0.
  - constructor; auto. right. pclearbot. eapply CIH. apply H0.
  - constructor. auto. pclearbot. right. eapply CIH. apply H1.
Qed.

(*may need a more general induction hype *)

Section ConvRefMRec.
Context (E D : Type -> Type).
Context (Pre : forall A, D A -> Prop).
Context (bodies : D ~> itree_spec (D +' E) ).
Context (A : Type) (init : D A) (Hinit : Pre A init).
Context (Hconv : forall A (d : D A), Pre A d -> conv_ref_mrec Pre (bodies A d)  ).

Lemma conv_ref_interp_mrec_conv_ref:
    forall t : itree_spec (D +' E) A, conv_ref_mrec Pre t -> conv_ref (interp_mrec_spec bodies t).
Proof.
  pcofix CIH. intros t Ht. punfold Ht. red in Ht.
  pstep. red. unfold observe. cbn. inv Ht.
  - constructor.
  - constructor. right. eapply CIH; eauto. pclearbot. auto.
  - constructor. pclearbot. right. eapply CIH; eauto. apply H0.
  - constructor; auto. right. pclearbot. eapply CIH; eauto.
    apply H0.
  - constructor. right. eapply CIH. pclearbot. apply conv_ref_mrec_bind; auto.
Qed.

Lemma conv_ref_mrec_conv_ref : conv_ref (mrec_spec bodies init).
Proof.
  eapply conv_ref_interp_mrec_conv_ref. auto.
Qed.

End ConvRefMRec.

Global Instance conv_ref_mrec_eqit_proper E D R b1 b2 P :
  Proper (@eqit (SpecEvent (D +' E)) R R eq b1 b2 ==> flip impl) (conv_ref_mrec P).
Proof.
  pcofix CIH.
  intros t1 t2 Ht Ht2. pstep. red. punfold Ht2. red in Ht2.
  punfold Ht. red in Ht.
  hinduction Ht before R; intros; pclearbot; try (constructor; eauto).
  - right. eapply CIH; eauto. inv Ht2. pclearbot. auto.
  - inv Ht2; inj_existT; subst; pclearbot.
    + constructor. right. eapply CIH; eauto. apply REL. apply H0.
    + constructor; auto. right. eapply CIH. apply REL. apply H0.
    + constructor; auto. right. eapply CIH. apply REL. apply H3.
  - left. pstep. red. eapply IHHt; eauto.
  - inv Ht2. pclearbot. punfold H0.
Qed.

Lemma conv_ref_mrec_forall E D R P A k :
  A ->
  (forall a : A, @conv_ref_mrec E D R P (k a) ) ->
  conv_ref_mrec P (Vis Spec_forall k).
Proof.
  intros. pstep. constructor. auto. left. apply H.
Qed.

Lemma conv_ref_mrec_exists E D R P A k :
  (forall a : A, @conv_ref_mrec E D R P (k a) ) ->
  conv_ref_mrec P (Vis Spec_exists k).
Proof.
  intros. pstep. constructor. left. apply H.
Qed.

Lemma conv_ref_mrec_inl E D R P A k (d : D A) :
  (P A d : Prop) ->
  (forall a : A, @conv_ref_mrec E D R P (k a) ) ->
  conv_ref_mrec P (Vis (Spec_vis (inl1 d)) k ).
Proof.
  intros. pstep. constructor. auto. left. apply H0.
Qed.
(*now I want a good reasoning principle for finding conv_ref*)

    (*can infer *)
  (* shouldn't need coinduction *)

(*

Lemma monotone_satisfiesF {E R1 R2} (RR : R1 -> R2 -> Prop) ot1 (ot2 : itree_spec' E R2) sim sim'
  (LE : sim <2= sim' )
  (IN : satisfiesF RR sim ot1 ot2) :
  satisfiesF RR sim' ot1 ot2.
Proof.
  induction IN; eauto.
Qed.

Lemma monotone_satisfies_ {E R1 R2} RR : monotone2 (@satisfies_ E R1 R2 RR).
Proof. red. intros. eapply monotone_satisfiesF; eauto. Qed.

Hint Resolve monotone_satisfies_ : paco.
*)


(*|
############################################################
Adding a letrec to untyped lambda calculus
############################################################

.. contents:: Table of Contents
   :depth: 2

============================
Imports and setup
============================

|*)
From Tealeaves Require Import
  Functors.List
  Backends.LN.Atom
  Classes.EqDec_eq
  Classes.Traversable.Functor
  Classes.Kleisli.Traversable.Functor
  Categories.TypeFamilies
  Functors.Writer
  Multisorted.Classes.DTM.

Import Setlike.Functor.Notations.
Import Traversable.Functor.ToKleisli.

Import Tealeaves.Classes.Monoid.Notations.
Import Tealeaves.Data.Product.Notations.
Import Tealeaves.Classes.Applicative.Notations.
Import Multisorted.Classes.DTM.Notations.
Import List.ListNotations.

#[local] Generalizable Variables F G A B C ϕ.

(*|
============================
Language definition
============================
|*)
#[export] Instance Unit_eq : EqDec unit eq.
Proof.
  change (forall x y : unit, {x = y} + {x <> y}).
  decide equality.
Defined.

#[export] Instance Unit : Index := {| K := unit |}.

Inductive term (v : Type) :=
| tvar : v -> term v
| app : term v -> term v -> term v
| lam : atom -> term v -> term v
| letin : atom * term v -> term v -> term v.

Definition T (_ : unit) (v : Type) : Type := @term v.

Section induction_principle.

  Context
    (var : Type)
    (P : term var -> Prop)
    (case_var : forall v : var, P (@tvar var v))
    (case_app : forall (t1 t2 : term var), P t1 -> P t2 -> P (app var t1 t2))
    (case_lam : forall (a : atom) (t : term var), P t -> P (lam var a t))
    (case_let :
      forall (binders : (atom * term var))
        (IHrec : forall (bound : term var), bound ∈ binders -> P bound)
        (t : term var),
        P t ->
        P (letin var binders t)).

  Definition term_mind : forall (t : term var), P t.
    refine(
    fix F (t : term var) : P t :=
      match t return (P t) with
      | tvar _ y => case_var y
      | app _ t1 t2 => case_app t1 t2 (F t1) (F t2)
      | lam _ nm body => case_lam nm body (F body)
      | letin _ (nm, def) body =>
          @case_let (nm, def) (fun (bound : term var)
                                 (elem : (bound ∈ (nm, def)))
                                 => _ (F def))
            body (F body)
      end).
    now inversion elem.
  Defined.

End induction_principle.

Section induction_principle.

  Context
    (var : Type)
    (P : term var -> Prop)
    (case_var : forall v : var, P (@tvar var v))
    (case_app : forall (t1 t2 : term var), P t1 -> P t2 -> P (app var t1 t2))
    (case_lam : forall (a : atom) (t : term var), P t -> P (lam var a t))
    (case_let :
      forall (a : atom) (def : term var) (body : term var)
        (IHdef : P def)
        (IHbody : P body),
        P (letin _ (a, def) body)).

  Definition term_mind2 : forall (t : term var), P t.
    refine(
    fix F (t : term var) : P t :=
      match t return (P t) with
      | tvar _ y => case_var y
      | app _ t1 t2 => case_app t1 t2 (F t1) (F t2)
      | lam _ nm body => case_lam nm body (F body)
      | letin _ (nm, def) body =>
          @case_let nm def body (F def) (F body)
      end).
  Defined.

End induction_principle.

(*|
========================================
Definition of `binddt` and `return`
========================================
|*)

#[export] Instance: MReturn T := fun A k => @tvar A.

Fixpoint binddt_term (G : Type -> Type) `{Fmap G} `{Pure G} `{Mult G}
    {v1 v2 : Type} (f : forall k, list atom * v1 -> G (T k v2)) (t : term v1) : G (term v2) :=
  match t with
  | tvar _ v => f tt (nil, v)
  | app _ t1 t2 =>
      pure G (@app v2) <⋆> binddt_term G f t1 <⋆> binddt_term G f t2
  | lam _ name body =>
      pure G (@lam v2 name) <⋆> binddt_term G (fun k => f k ∘ incr [name]) body
  | letin _ p body =>
      pure G (@letin v2) <⋆> traverse (atom ×) G (binddt_term G f) p <⋆> binddt_term G (fun k => f k ∘ incr [fst p]) body
  end.

#[export] Instance MBind_term : MBind (list atom) T term := @binddt_term.

#[export] Instance MBind_T : forall k, MBind (list atom) T (T k) :=
  ltac:(intros []; typeclasses eauto).

(*|
Helpers
|*)

Section helpers.

  Context
    `{Applicative F}
    `{Applicative G}
      {v1 v2 v3 : Type}
      (f : forall k, nat * v1 -> F (T k v2))
      (g : forall k, nat * v2 -> G (T k v3)).

End helpers.

(*|
========================================
The Kleisli axioms of DTMs
========================================
|*)

Section laws.

  Ltac rewrite_with_bind_hyp :=
    match goal with
    | H : context[mbinddt] |- _ => rewrite H
    end.

  Ltac induction_on_term :=
    match goal with
    | t : term ?v |- _ => induction t using term_mind2
    end.

  Ltac dtm_setup :=
    intros; ext t; unfold id; induction_on_term; cbn.

(*|
-----------------------------
Law 1
-----------------------------
|*)

  Lemma mbinddt_comp_mret_term :
    forall (F : Type -> Type)
      `{Applicative F}
      `(f : forall k, list atom * A -> F (T k B)),
      mbinddt term F f ∘ mret T tt = f tt ∘ pair nil.
  Proof.
    reflexivity.
  Qed.

  Corollary mbinddt_comp_mret_T :
    forall k F `{Applicative F}
      `(f : forall k, list atom * A -> F (T k B)),
      mbinddt (W := (list atom)) (T := T) (T k) F f ∘ mret T k = (fun a => f k (Ƶ, a)).
  Proof.
    intros []. apply mbinddt_comp_mret_term.
  Qed.

(*|
-----------------------------
Law 2
-----------------------------
|*)

  Generalizable Variable M.

  Lemma dtm2_helper : forall (x : atom) (A : Type),
      (fun k : unit => mret T k ∘ extract (A:=A) (prod (list atom)) ∘ incr [x]) =
        (fun k : unit => mret T k ∘ extract (prod (list atom))).
  Proof.
    intros. ext k. reassociate ->. now rewrite (extract_incr).
  Qed.

  Lemma mbinddt_mret_term : forall (A : Type),
      mbinddt term (fun A => A) (fun k => mret T k ∘ extract ((list atom) ×)) = @id (term A).
  Proof.
    intros. ext t. unfold id. induction t using term_mind2.
    - cbn. reflexivity.
    - cbn. fequal.
      + assumption.
      + assumption.
    - cbn. fequal.
      + rewrite dtm2_helper. auto.
    - cbn. fequal.
      + fequal.
        * auto.
      + rewrite dtm2_helper. auto.
  Qed.

  Corollary mbinddt_mret_T :
    forall k A, mbinddt (T k) (fun A => A) (fun k => mret T k ∘ extract ((list atom) ×)) = @id (T k A).
  Proof.
    intros [] A. apply mbinddt_mret_term.
  Qed.

  Ltac solve_dtm2_case :=
    fequal; try rewrite dtm2_helper; auto.

  Lemma mbinddt_mret_term_automated : forall (A : Type),
      mbinddt term (fun A => A) (fun k => mret T k ∘ extract ((list atom) ×)) = @id (term A).
  Proof.
    dtm_setup; solve_dtm2_case.
    fequal; auto.
  Qed.

(*|
-----------------------------
Law 3
-----------------------------
|*)

  Ltac dtm3_lhs_step G1 :=
    repeat rewrite fmap_ap; (* Bring LHS <<fmap>> up to the constructor *)
    rewrite (app_pure_natural G1). (* Fuse <<fmap>> and the <<pure (constructor)>> *)

  Ltac dtm3_rhs_step G2 G1 :=
    (rewrite_strat innermost (terms (ap_compose2 G2 G1)));
    repeat rewrite fmap_ap;
    rewrite (app_pure_natural G1);
    rewrite <- ap_fmap;
    repeat rewrite fmap_ap;
    rewrite (app_pure_natural G1).

  Lemma mbinddt_mbinddt_term :
    forall (F : Type -> Type)
      (G : Type -> Type)
      `{Applicative F}
      `{Applicative G}
      `(g : forall k, list atom * B -> G (T k C))
      `(f : forall k, list atom * A -> F (T k B)),
      (fmap F (mbinddt term G g) ∘ mbinddt term F f) =
        mbinddt term (F ∘ G) (compose_dtm (T := T) g f).
  Proof.
    intros. ext t. unfold compose at 1.
    generalize dependent g.
    generalize dependent f.
    induction t using term_mind2; intros f g.
    - cbn. change [] with (Ƶ : list atom). now rewrite incr_zero.
    - cbn.
      (* left side *)
      do 2 rewrite fmap_ap.
      rewrite (app_pure_natural F).
      (* right side, IH *)
      rewrite <- IHt1.
      rewrite <- IHt2.
      (* right side, constructor *)
      unfold_ops @Pure_compose.
      (* right side, first argument *)
      rewrite_strat innermost (terms (ap_compose2 G F)).
      rewrite (app_pure_natural F).
      rewrite <- ap_fmap.
      rewrite (app_pure_natural F).
      (* right side, outer *)
      rewrite_strat innermost (terms (ap_compose2 G F)).
      rewrite fmap_ap.
      rewrite (app_pure_natural F).
      rewrite <- ap_fmap.
      rewrite fmap_ap.
      rewrite (app_pure_natural F).
      (* Done *)
      reflexivity.
    - cbn.
      (* left side *)
      rewrite fmap_ap.
      rewrite (app_pure_natural F).
      (* right side, IH *)
      rewrite (compose_dtm_incr (ix := Unit) (list atom) T g f).
      rewrite <- IHt.
      (* right side, constructor *)
      unfold_ops @Pure_compose.
      (* right side, first argument *)
      rewrite_strat innermost (terms (ap_compose2 G F)).
      rewrite (app_pure_natural F).
      rewrite <- ap_fmap.
      rewrite (app_pure_natural F).
      (* Done *)
      reflexivity.
    - cbn.
      (* left side *)
      do 2 rewrite fmap_ap.
      rewrite (app_pure_natural F).
      (* left side, first arg *)
      rewrite <- ap_fmap.
      rewrite (app_pure_natural F).
      (* right side, IH *)
      rewrite (compose_dtm_incr (ix := Unit) (list atom) T g f).
      rewrite <- IHt1.
      rewrite <- IHt2.
      (* right side, constructor *)
      unfold_ops @Pure_compose.
      (* right side, first argument *)
      change (fmap (F ∘ G) ?f) with (fmap F (fmap G f)).
      rewrite_strat innermost (terms (ap_compose2 G F)).
      rewrite (app_pure_natural F).
      rewrite <- ap_fmap.
      rewrite (app_pure_natural F).
      rewrite <- ap_fmap.
      rewrite (app_pure_natural F).
      (* right side, second argument *)
      rewrite_strat innermost (terms (ap_compose2 G F)).
      rewrite fmap_ap.
      rewrite (app_pure_natural F).
      rewrite <- ap_fmap.
      rewrite fmap_ap.
      rewrite (app_pure_natural F).
      (* Done *)
      reflexivity.
  Qed.

(*|
------------------------
Law 4
------------------------

|*)
  Section law4.

    Context
      (F : Type -> Type)
      (G : Type -> Type)
     `{ApplicativeMorphism F G ϕ}.

    Ltac invert_applicative :=
      match goal with
        | hyp : ApplicativeMorphism F G ϕ |- _ => inversion hyp
      end.

    Set Keyed Unification.
    Lemma mbinddt_morphism_term :
      forall `(f : forall k, list atom * A -> F (T k B)),
        ϕ (term B) ∘ mbinddt term F f =
          mbinddt term G (fun k => ϕ (T k B) ∘ f k).
    Proof.
      intros. ext t. unfold compose at 1.
      generalize dependent f.
      induction t using term_mind2; cbn; intro f.
      - reflexivity.
      - (* left side *)
        repeat rewrite ap_morphism_1.
        rewrite (appmor_pure F G).
        (* right side *)
        rewrite <- IHt1.
        rewrite <- IHt2.
        (* Done *)
        reflexivity.
      - (* left side *)
        repeat rewrite ap_morphism_1.
        rewrite (appmor_pure F G).
        (* right side *)
        rewrite <- IHt.
        (* Done *)
        reflexivity.
      - (* left side *)
        repeat rewrite ap_morphism_1.
        rewrite (appmor_pure F G).
        invert_applicative; rewrite appmor_natural.
        (* right side *)
        rewrite <- IHt1.
        rewrite <- IHt2.
        (* Done *)
        reflexivity.
    Qed.
    Unset Keyed Unification.

  End law4.

End laws.

(*|
-------------------------
Multisorted DTM instance
-------------------------
|*)

#[export] Instance DTP_term: DTPreModule (list atom) term T :=
  {| dtp_mbinddt_mret := @mbinddt_mret_term;
     dtp_mbinddt_mbinddt := @mbinddt_mbinddt_term;
     dtp_mbinddt_morphism := @mbinddt_morphism_term;
  |}.

#[export] Instance: forall k : unit, DTPreModule (list atom) (T k) T :=
  fun k => match k with tt => DTP_term end.

#[export] Instance: DTM (list atom) T :=
  {| dtm_mbinddt_comp_mret := mbinddt_comp_mret_T;
  |}.


(* ----------------------------------------------------------------------------------- *)
(** ** Initial bicategory and proof that it's univalent.

   Note: UniMath.CategoryTheory.categories.StandardCategories has the definition of
   initial 1-category ([empty_category]).                                              *)
(* ----------------------------------------------------------------------------------- *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.AdjointUnique.

Local Open Scope cat.

Section Initial_Bicategory.
  Definition initial_1_id_comp_cells : prebicat_1_id_comp_cells
    := tpair (λ C : precategory_data, prebicat_2cell_struct C)
             empty_category
             (λ (a b : empty_category) (f g : a --> b), ∅).

  Definition initial_2_id_comp_struct
    : prebicat_2_id_comp_struct initial_1_id_comp_cells.
  Proof.
    repeat split; exact (λ u : ∅, fromempty u).
  Defined.

  Definition initial_prebicat_data : prebicat_data
    := initial_1_id_comp_cells,, initial_2_id_comp_struct.

  Lemma initial_bicat_laws : prebicat_laws initial_prebicat_data.
  Proof.
    repeat split; exact (λ u : ∅, fromempty u).
  Qed.

  Definition initial_prebicat : prebicat
    := initial_prebicat_data,, initial_bicat_laws.

  Definition cellset_initial_prebicat
    : isaset_cells initial_prebicat
    := λ u : ∅, fromempty u.

  Definition initial_bicat : bicat
    := initial_prebicat,, cellset_initial_prebicat.

  Definition initial_bicat_invertible_2cell
             {x y : initial_bicat}
             {f g : x --> y}
             (α : f ==> g)
    : is_invertible_2cell α.
  Proof.
    exact (fromempty x).
  Defined.

  Definition initial_bicat_adjoint_equivalence
             {x y : initial_bicat}
             (f : x --> y)
    : left_adjoint_equivalence f.
  Proof.
    exact (fromempty x).
  Defined.

  (** It is univalent *)
  Definition initial_bicat_is_univalent_2_1
    : is_univalent_2_1 initial_bicat.
  Proof.
    intros x.
    exact (fromempty x).
  Defined.

  Definition initial_bicat_is_univalent_2_0
    : is_univalent_2_0 initial_bicat.
  Proof.
    intros x.
    exact (fromempty x).
  Defined.

  Definition initial_bicat_is_univalent_2
    : is_univalent_2 initial_bicat.
  Proof.
    split.
    - exact initial_bicat_is_univalent_2_0.
    - exact initial_bicat_is_univalent_2_1.
  Defined.

End Initial_Bicategory.


Require Import Coq.Lists.List.
Require Coq.Classes.EquivDec.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monoid.
Require Import ExtLib.Structures.Reducible.
Require ExtLib.Data.Nat.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.Injection.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.

Section EqDec.
  Universe u.
  Variable T : Type@{u}.
  Variable EqDec_T : EquivDec.EqDec _ (@eq T).

  Global Instance EqDec_list@{} : EquivDec.EqDec _ (@eq (list T)).
  Proof.
    red. unfold Equivalence.equiv, RelationClasses.complement.
    intros.
    change (x = y -> False) with (x <> y).
    decide equality. eapply EqDec_T.
  Qed.
End EqDec.

(* Specialized induction rules *)
Lemma list_ind_singleton@{u}
: forall {T : Type@{u}} (P : list T -> Prop)
         (Hnil : P nil)
         (Hsingle : forall t, P (t :: nil))
         (Hcons : forall t u us, P (u :: us) -> P (t :: u :: us)),
    forall ls, P ls.
Proof.
  induction ls; eauto.
  destruct ls. eauto. eauto.
Qed.

Lemma list_rev_ind@{u}
  : forall (T : Type@{u}) (P : list T -> Prop),
    P nil ->
    (forall l ls, P ls -> P (ls ++ l :: nil)) ->
    forall ls, P ls.
Proof.
  clear. intros. rewrite <- rev_involutive.
  induction (rev ls).
  apply H.
  simpl. auto.
Qed.

Section AllB.
  Universe u.
  Variable T : Type@{u}.
  Variable p : T -> bool.

  Fixpoint allb@{} (ls : list T) : bool :=
    match ls with
      | nil => true
      | l :: ls =>
        if p l then allb ls else false
    end.

  Fixpoint anyb@{} (ls : list T) : bool :=
    match ls with
      | nil => false
      | l :: ls =>
        if p l then true else anyb ls
    end.
End AllB.

Lemma Forall_map@{uT uU}
: forall (T : Type@{uT}) (U : Type@{uU}) (f : T -> U) P ls,
    Forall P (List.map f ls) <-> Forall (fun x => P (f x)) ls.
Proof.
  induction ls; simpl.
  { split; intros; constructor. }
  { split; inversion 1; intros; subst; constructor; auto.
    apply IHls. auto. apply IHls. auto. }
Qed.

Lemma Forall_cons_iff@{u} : forall (T : Type@{u}) (P : T -> Prop) a b,
    Forall P (a :: b) <-> (P a /\ Forall P b).
Proof. clear. split.
       inversion 1; auto.
       destruct 1; constructor; auto.
Qed.

Lemma Forall_nil_iff@{u} : forall (T : Type@{u}) (P : T -> Prop),
    Forall P nil <-> True.
Proof.
  clear. split; auto.
Qed.

Global Instance Foldable_list@{u} {T : Type@{u}} : Foldable (list T) T :=
  fun _ f x ls => fold_right f x ls.

Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Structures.Functor.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Applicative.

Section traversable.
  Universe u v vF.
  Context {F : Type@{v} -> Type@{vF}}.
  Context {Applicative_F : Applicative F}.
  Context {A : Type@{u}} {B : Type@{v}}.
  Variable f : A -> F B.

  Fixpoint mapT_list@{} (ls : list A) : F (list B) :=
    match ls with
      | nil => pure nil
      | l :: ls => ap (ap (pure (@cons B)) (f l)) (mapT_list ls)
    end.
End traversable.

Global Instance Traversable_list@{} : Traversable list :=
{ mapT := @mapT_list }.

Monomorphic Universe listU.

Global Instance Monad_list@{} : Monad@{listU listU} list :=
{ ret  := fun _ x => x :: nil
; bind := fun _ _ x f =>
  flat_map f x
}.

Global Instance MonadZero_list : MonadZero list :=
{ mzero := @nil }.

Global Instance MonadPlus_list : MonadPlus list :=
{ mplus _A _B a b := List.map inl a ++ List.map inr b
}.

Section list.
  Inductive R_list_len@{u} {T : Type@{u}} : list T -> list T -> Prop :=
  | R_l_len : forall n m, length n < length m -> R_list_len n m.

  Theorem wf_R_list_len@{u} (T : Type@{u}) : well_founded (@R_list_len T).
  Proof.
    constructor. intros.
    refine (@Fix _ _ Nat.wf_R_lt (fun n : nat => forall ls : list T, n = length ls -> Acc R_list_len ls)
      (fun x rec ls pfls => Acc_intro _ _)
      _ _ refl_equal).
    refine (
      match ls as ls return x = length ls -> forall z : list T, R_list_len z ls -> Acc R_list_len z with
        | nil => fun (pfls : x = 0) z pf => _
        | cons l ls => fun pfls z pf =>
          rec _ (match pf in R_list_len xs ys return x = length ys -> Nat.R_nat_lt (length xs) x with
                   | R_l_len n m pf' => fun pf_eq => match eq_sym pf_eq in _ = x return Nat.R_nat_lt (length n) x with
                                                     | refl_equal => Nat.R_lt pf'
                                                   end
                 end pfls) _ eq_refl
      end pfls).
    clear - pf; abstract (inversion pf; subst; simpl in *; inversion H).
  Defined.
End list.

Definition Monoid_list_app@{u v} {T : Type@{u}} : Monoid@{v} (list T) :=
{| monoid_plus := @List.app _
 ; monoid_unit := @nil _
 |}.

Section ListEq.
  Universe u.
  Variable T : Type@{u}.
  Variable EDT : RelDec (@eq T).

  Fixpoint list_eqb@{} (ls rs : list T) : bool :=
    match ls , rs with
      | nil , nil => true
      | cons l ls , cons r rs =>
        if l ?[ eq ] r then list_eqb ls rs else false
      | _ , _ => false
    end.

  (** Specialization for equality **)
  Global Instance RelDec_eq_list@{} : RelDec (@eq (list T)) :=
  { rel_dec := list_eqb }.

  Variable EDCT : RelDec_Correct EDT.

  Global Instance RelDec_Correct_eq_list@{v} : RelDec_Correct RelDec_eq_list.
  Proof.
    constructor; induction x; destruct y; split; simpl in *; intros;
      try reflexivity + discriminate.
    - destruct (_ : Reflect (rel_dec a t) _ _); try discriminate.
      replace y with x by (apply IHx; auto); subst; auto.
    - inversion H; subst. rewrite (rel_dec_eq_true _) by auto. apply IHx; auto.
  Qed.

End ListEq.

Global Instance Injective_cons@{u} (T : Type@{u}) (a : T) b c d : Injective (a :: b = c :: d).
refine {| result := a = c /\ b = d |}.
inversion 1; auto.
Defined.

Global Instance Injective_cons_nil@{u} (T : Type@{u}) (a : T) b : Injective (a :: b = nil).
refine {| result := False |}.
inversion 1; auto.
Defined.

Global Instance Injective_nil_cons@{u} (T : Type@{u}) (a : T) b : Injective (nil = a :: b).
refine {| result := False |}.
inversion 1; auto.
Defined.

Global Instance Injective_nil_nil@{u} (T : Type@{u}) : Injective (nil = @nil T).
refine {| result := True |}.
auto.
Defined.

Global Instance Injective_app_cons@{u} {T : Type@{u}} (a : list T) b c d
: Injective (a ++ b :: nil = (c ++ d :: nil)).
Proof.
refine {| result := a = c /\ b = d |}.
eapply app_inj_tail.
Defined.

Global Instance Injective_app_same_L@{u} {T : Type@{u}} (a : list T) b c
: Injective (b ++ a = b ++ c).
Proof.
refine {| result := a = c |}.
apply app_inv_head.
Defined.

Global Instance Injective_app_same_R@{u} {T : Type@{u}} (a : list T) b c
: Injective (a ++ b = c ++ b).
Proof.
refine {| result := a = c |}.
apply app_inv_tail.
Defined.

(*
Lemma eq_list_eq@{u v}
: forall (T : Type@{u}) (a b : T) (pf : a = b) (F : T -> Type@{v}) val,
    match pf in _ = x return list (F x) with
      | eq_refl => val
    end = map (fun val => match pf in _ = x return F x with
                            | eq_refl => val
                          end) val.
Proof.
  destruct pf. intros. rewrite map_id. reflexivity.
Qed.
Hint Rewrite eq_list_eq : eq_rw.
*)

Export Coq.Lists.List.


(** * Definition of pseudonatural transformation *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Pseudofunctor.Core.
Require Import Category.Pi.
Require Import FunctorCategory.Core.
Require Import Category.Morphisms FunctorCategory.Morphisms.
Require Import Functor.Composition.Core Functor.Identity.
Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Require Import NaturalTransformation.Identity.
Require Import NaturalTransformation.Isomorphisms.
Require Import NaturalTransformation.Paths.
Require Import FunctorCategory.Core.
Require Import HoTT.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Declare Scope pseudonatural_transformation_scope.
Delimit Scope pseudonatural_transformation_scope with pseudonatural_transformation.

Local Open Scope natural_transformation_scope.
Local Open Scope functor_scope.
Local Open Scope morphism_scope.
Local Open Scope pseudonatural_transformation_scope.

(** Quoting Michael Shulman from an email:

    The 2-limit in question is sometimes called a "descent object", or
    the totalization of a truncated cosimplicial object.  It's a
    generalization of an equalizer.  The set of natural
    transformations between two ordinary functors [F],[G : C → D] is
    the equalizer of

    [Π_x D(Fx,Gx) ⇉ Π_{x→y} D(Fx,Gy)]

    The category of pseudonatural transformations between two
    2-functors is the descent object of

    [Π_x D(Fx,Gx) ⇉ Π_{x→y} D(Fx,Gy) ⇛ Π_{x→y→z} D(Fx,Gz)]

    where there are three maps from the second product to the third,
    corresponding to picking out [x→y], [y→z], and [x→z].

    In general, the descent object of

    [A ⇉ B ⇛ C]

    is the category of objects [a∈A] equipped with an isomorphism
    between their two images in [B] which results in a commutative
    triangle between their three images in [C]. *)

(** Later, he said (https://github.com/HoTT/HoTT/pull/382##issuecomment-41240787):

    The "naturality" axiom is only necessary if the domain is a
    2-category rather than a 1-category. However, the respect for
    units axiom really is necessary; I guess I forgot to mention that
    in the email. The way it comes up in the descent object is that
    there's a map from [B] to [A] given by projecting the components
    of identities, and the coherence cell has to become an identity
    when composed with that map. *)

(** We construct the parts as above, but inline the resulting definitions for speed.
<<
Module PseudonaturalTransformationParts.
  Section PseudonaturalTransformation.
    Context `{Funext}.

    Variable X : PreCategory.

    Variables F G : Pseudofunctor X.

    Definition A : PreCategory
      := (forall x : X, F x -> G x)%category.
    Definition B : PreCategory
      := (forall x y (m : morphism X x y), F x -> G y)%category.
    Definition C : PreCategory
      := (forall x y z (m1 : morphism X y z) (m2 : morphism X x y), F x -> G z)%category.

    Definition a_part := Eval simpl in object A.

    Definition A_to_B_1 : Functor A B.
    Proof.
      refine (Build_Functor
                A B
                (fun x__Fx_to_Gx => fun x y m => x__Fx_to_Gx y o p_morphism_of F m)%functor
                (fun x__s x__d x__m => fun x y m => x__m y oR p_morphism_of F m)
                _
                _);
      simpl; repeat (intro || apply path_forall);
      [ apply composition_of_whisker_r
      | apply whisker_r_left_identity ].
    Defined.

    Definition A_to_B_2 : Functor A B.
    Proof.
      refine (Build_Functor
                A B
                (fun x__Fx_to_Gx => fun x y m => p_morphism_of G m o x__Fx_to_Gx x)%functor
                (fun x__s x__d x__m => fun x y m => p_morphism_of G m oL x__m x)
                _
                _);
      simpl; repeat (intro || apply path_forall);
      [ apply composition_of_whisker_l
      | apply whisker_l_right_identity ].
    Defined.

    Definition b_part (a : a_part)
      := Eval simpl in forall x y m, (A_to_B_1 a x y m <~=~> A_to_B_2 a x y m).

    Definition B_to_A : Functor B A
      := Build_Functor
           B A
           (fun xym__Fx_to_Gy => fun x => xym__Fx_to_Gy x x 1)
           (fun x__s x__d x__m => fun x => x__m x x 1)
           (fun _ _ _ _ _ => idpath)
           (fun _ => idpath).

    Definition b_id_part (a : a_part) (b : b_part a)
      := Eval simpl in
          forall x,
            (((left_identity_natural_transformation_1 _)
                o (p_identity_of G _ oR _)
                o (B_to_A _1 b x)
                o (_ oL (p_identity_of F _)^-1)
                o (left_identity_natural_transformation_2 _))
             = 1)%natural_transformation.

    Definition B_to_C_1 : Functor B C.
    Proof.
      refine (Build_Functor
                B C
                (fun xym__Fx_to_Gy => fun x y z m1 m2 => xym__Fx_to_Gy y z m1 o p_morphism_of F m2)%functor
                (fun xym__s xym__d xym__m => fun x y z m1 m2 => xym__m y z m1 oR p_morphism_of F m2)
                _
                _);
      simpl; repeat (intro || apply path_forall);
      [ apply composition_of_whisker_r
      | apply whisker_r_left_identity ].
    Defined.

    Definition B_to_C_2 : Functor B C.
    Proof.
      refine (Build_Functor
                B C
                (fun xym__Fx_to_Gy => fun x y z m1 m2 => p_morphism_of G m1 o xym__Fx_to_Gy x y m2)%functor
                (fun xym__s xym__d xym__m => fun x y z m1 m2 => p_morphism_of G m1 oL xym__m x y m2)
                _
                _);
      simpl; repeat (intro || apply path_forall);
      [ apply composition_of_whisker_l
      | apply whisker_l_right_identity ].
    Defined.

    Definition B_to_C_3 : Functor B C
      := Build_Functor
           B C
           (fun xym__Fx_to_Gy => fun x y z m1 m2 => xym__Fx_to_Gy x z (m1 o m2))
           (fun xym__s xym__d xym__m => fun x y z m1 m2 => xym__m x z (m1 o m2))
           (fun _ _ _ _ _ => idpath)
           (fun _ => idpath).

    Definition c_part' (a : a_part) (b : b_part a)
    : forall (x y z : X) (m1 : morphism X y z) (m2 : morphism X x y), Type.
    Proof.
      hnf in a, b.
      pose (fun x y m => (b x y m : morphism _ _ _)) as bB; simpl in *.
      intros x y z m1 m2.
      exact (((associator_2 _ _ _)
                o (B_to_C_2 _1 bB x y z m1 m2)
                o (associator_1 _ _ _)
                o (B_to_C_1 _1 bB x y z m1 m2)
                o (associator_2 _ _ _))
             = ((p_composition_of G _ _ _ m1 m2 oR _)
                  o (B_to_C_3 _1 bB x y z m1 m2)
                  o (_ oL (p_composition_of F _ _ _ m1 m2)^-1)))%natural_transformation.
    Defined.

    Arguments c_part' / .

    Definition c_part (a : a_part) (b : b_part a)
      := Eval simpl in forall x y z m1 m2, @c_part' a b x y z m1 m2.

    (** We would like to define [PseudonaturalTransformation] here, then our types are η-expanded. *)
  (*Record PseudonaturalTransformation :=
      { p_components_of :> a_part;
        p_commutes : b_part p_components_of;
        p_commutes_coherent : c_part p_commutes }.*)
  End PseudonaturalTransformation.
End PseudonaturalTransformationParts.

Print PseudonaturalTransformationParts.a_part.
Print PseudonaturalTransformationParts.b_part.
Print PseudonaturalTransformationParts.b_id_part.
Print PseudonaturalTransformationParts.c_part.
>> *)

Record PseudonaturalTransformation `{Funext} (X : PreCategory)
       (F G : Pseudofunctor X) :=
  { p_components_of
      :> forall a : X, Functor (F a) (G a);
    p_commutes
    : forall (x y : X) (m : morphism X x y),
        ((p_components_of y o p_morphism_of F m)%functor <~=~> (p_morphism_of G m o p_components_of x)%functor)%natural_transformation;
    p_commutes_respects_identity
    : forall x : X,
        ((left_identity_natural_transformation_1 (p_components_of x))
           o (p_identity_of G x oR p_components_of x)
           o (p_commutes x x 1%morphism)
           o (p_components_of x oL (p_identity_of F x) ^-1)
           o (right_identity_natural_transformation_2 (p_components_of x))
         = 1)%natural_transformation;
    p_commutes_respects_composition
    : forall (x y z : X) (m1 : morphism X y z) (m2 : morphism X x y),
        (((associator_2 (p_morphism_of G m1) (p_morphism_of G m2) (p_components_of x))
            o (p_morphism_of G m1 oL p_commutes x y m2)
            o (associator_1 (p_morphism_of G m1) (p_components_of y) (p_morphism_of F m2))
            o (p_commutes y z m1 oR p_morphism_of F m2)
            o (associator_2 (p_components_of z) (p_morphism_of F m1) (p_morphism_of F m2)))
         = ((p_composition_of G x y z m1 m2 oR p_components_of x o p_commutes x z (m1 o m2)%morphism)
              o (p_components_of z oL (p_composition_of F x y z m1 m2) ^-1)))%natural_transformation }.

Bind Scope pseudonatural_transformation_scope with PseudonaturalTransformation.

Create HintDb pseuodnatural_transformation discriminated.

Arguments p_components_of {_} {X}%category {F G}%pseudofunctor T%pseudonatural_transformation
          a%object : rename, simpl nomatch.

Hint Resolve @p_commutes_respects_identity @p_commutes_respects_composition : category pseudonatural_transformation.


From algebra Require Import Foundation.
From algebra.rings Require Ring RingHom.
From algebra Require Category.

Import Ring.Exports RingHom.Exports Category.Exports.
Open Scope ring_scope.

Set Primitive Projections.

Module Class.
  Record axioms (A : [Ring]) (I : A → Prop) :=
    Class
      {zero : I 0;
       one : I 1;
       neg : ∀ x, I (Ring.neg x);
       add : ∀ x y, I x → I y → I (x + y);
       mul : ∀ x y, I x → I y → I (x ⋅ y)}.
End Class.

Record type A := Pack {pred; class : Class.axioms A pred}.

Module PredCoercion.
  Coercion pred : type >-> Funclass.
End PredCoercion.
Import PredCoercion.

Section Operations.
  Context {A : [Ring]} {I : type A}.
  Definition zero := Class.zero _ _ (class _ I).
  Definition neg := Class.neg _ _ (class _ I).
  Definition add := Class.add _ _ (class _ I).
  Definition one := Class.one _ _ (class _ I).
  Definition mul := Class.mul _ _ (class _ I).
End Operations.

Definition ring {A} : type A → [Ring].
  move=> I.
  unshelve econstructor.
  - exact: ({x : A | I x}).
  - unshelve apply: Ring.make_class.
    + axiom "zero"; econstructor; apply: zero.
    + axiom "add" => x y.
      exists (sval x + sval y).
      by apply: add; expose_subset.
    + axiom "neg" => x.
      exists (Ring.neg (sval x)); apply: neg.
    + axiom "one"; econstructor; apply: one.
    + axiom "mul" => x y.
      exists (sval x ⋅ sval y).
      by apply: mul; expose_subset.
    + repeat split => *; move=> *; apply: eq_subset; simpl;
      try by autorewrite with ring.
      * apply: Ring.addC.
      * apply: Ring.mulC.
Defined.

Definition hom {A} (I : type A) : [Ring] (ring I) A.
  unshelve econstructor.
  - case; auto.
  - split; simpl; auto.
Defined.

Module Exports.
  Export PredCoercion.
End Exports.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal71.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3eqsynthconj2 : forall  (lv0 : natural), (@eq natural (lv0) (lv0)).
Admitted.
QuickChick conj3eqsynthconj2.


Require Import Recdef.
Require Import Coq.micromega.Lia.
Set Implicit Arguments.

(** A function defined using measure or well-founded relation **)
Function Plus1 (n: nat) {measure id n} : nat :=
  match n with
    | 0 => 1
    | S p => S (Plus1 p)
  end.
- intros. unfold id. abstract lia.
Defined.

Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import MetaCoq.Template.Loader.
Require Import MetaCoq.Template.All.

From MetaCoq.Template Require Import Pretty.
(* Use template-coq to make a [program] from function defined above *)
Time MetaCoq Quote Recursively Definition p_Plus1 := Plus1.

(* Eval cbv in (print_program false 1 p_Plus1).
Eval lazy in (print_term (empty_ext (fst p_Plus1)) nil true (snd p_Plus1)). *)

(** The program p_Plus1 is too big to read, so we define some
*** diagnostic software **)
Section occ_term_Sec.
Variable str:kername.
  (** does [tConst str] occur in a term? **)
Fixpoint pocc_term (n:nat) (t:term): bool :=
  match n with
    | 0 => false
    | S n =>
      match t with
        | tCast t _ ty => pocc_term n t || pocc_term n ty
        | tProd _ ty t => pocc_term n t || pocc_term n ty
        | tLambda _ ty t => pocc_term n t || pocc_term n ty
        | tLetIn _ dfn ty t => pocc_term n dfn || pocc_term n t || pocc_term n ty
        | tApp fn args => pocc_term n fn || fold_left orb (map (pocc_term n) args) false
        | tConst nm _ => if eqb str nm then true else false
        | tCase _ ty mch brs =>
          existsb (pocc_term n) (pparams ty) || pocc_term n (preturn ty) ||
          pocc_term n mch ||
          fold_left orb (map (fun x => pocc_term n (bbody x)) brs) false
        | tFix ds _ =>
          fold_left
            orb (map (fun x => pocc_term n (dtype x) || pocc_term n (dbody x)) ds) false
        | _ => false
      end
  end.
  (** does [tConst str] occur anywhere in a program? **)

Definition bound_global_decl (d : kername * global_decl) : bool :=
  if eq_kername str (fst d) then true else false.

Definition bound_program (p : program) := List.existsb bound_global_decl (fst p).(declarations).

Definition pocc_global_decl (d : kername * global_decl) : bool :=
match snd d with
| ConstantDecl {| cst_type := ty;  cst_body := Some t |} => pocc_term 2000 ty || pocc_term 2000 t
| ConstantDecl {| cst_type := ty;  cst_body := None |} => pocc_term 2000 ty
| InductiveDecl _ => false
end.

Definition pocc_program p := pocc_term 2000 (snd p) || List.existsb pocc_global_decl (fst p).(declarations).

End occ_term_Sec.

Require Import List. Import ListNotations. Open Scope bs_scope.
(* MetaCoq Test Unquote (tConst (MPfile ["Nat"; "PeanoNat"; "Arith"; "Coq"], "pred") []) . *)

Eval vm_compute in (eq_refl : pocc_program (MPfile ["Nat"; "PeanoNat"; "Arith"; "Coq"], "pred") p_Plus1 = false).
Eval vm_compute in (eq_refl : bound_program (MPfile ["Nat"; "PeanoNat"; "Arith"; "Coq"], "pred") p_Plus1 = false).

Eval vm_compute in (eq_refl : pocc_program (MPfile ["Nat"; "Init"; "Coq"], "pred") p_Plus1 = true).
Eval vm_compute in (eq_refl : bound_program (MPfile ["Nat"; "Init"; "Coq"], "pred") p_Plus1 = true).


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Natural.Transformation.
Require Export Category.Theory.Adjunction.
Require Import Category.Functor.Opposite.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Program Definition Opposite_Adjunction `(F : D ⟶ C) `(U : C ⟶ D)
        (A : F ⊣ U) :
  U^op ⊣ F^op := {|
  adj := fun x y =>
    {| to          := from (@adj _ _ _ _ A y x)
     ; from        := to (@adj _ _ _ _ A y x)
     ; iso_to_from := iso_from_to (@adj _ _ _ _ A y x)
     ; iso_from_to := iso_to_from (@adj _ _ _ _ A y x) |};

  to_adj_nat_l   := fun _ _ _ f g => @from_adj_nat_r _ _ _ _ A _ _ _ g f;
  to_adj_nat_r   := fun _ _ _ f g => @from_adj_nat_l _ _ _ _ A _ _ _ g f;
  from_adj_nat_l := fun _ _ _ f g => @to_adj_nat_r  _ _ _ _ A _ _ _ g f;
  from_adj_nat_r := fun _ _ _ f g => @to_adj_nat_l  _ _ _ _ A _ _ _ g f
|}.

Notation "N ^op" := (@Opposite_Adjunction _ _ _ _ N)
  (at level 7, format "N ^op") : adjunction_scope.

Corollary Opposite_Adjunction_invol `(F : D ⟶ C) `(U : C ⟶ D) (A : F ⊣ U) :
  (A^op)^op = A.
Proof. reflexivity. Qed.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Lia.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.
Require Import Subtyping.Toplike.

Require Import Value.
Require Import Disjoint.
Require Import PrincipalTyping.
Require Import Consistent.
Require Import Typing.

(** * Definition *)

Inductive casting : term -> type -> term -> Prop :=
| Ct_Lit : forall n A,
    sub A Int ->
    casting (Ann (Lit n) A) Int (Ann (Lit n) Int)
| Ct_Top : forall A v,
    lc v ->
    toplike A ->
    ordinary A ->
    casting v A (Ann (Lit 1) A)
| Ct_Lam : forall A B C D E e,
    lc (Lam A e B) ->
    ~ toplike D ->
    sub E (Arr C D) ->
    ordinary D ->
    casting (Ann (Lam A e B) E)
            (Arr C D)
            (Ann (Lam A e D) (Arr C D))
| Ct_Rcd : forall v v' A l,
    ordinary A ->
    ~ toplike A ->
    casting v A v' ->
    casting (Fld l v) (Rcd l A) (Fld l v')
| Ct_Mrg_L : forall v1 v2 v A,
    casting v1 A v ->
    ordinary A ->
    casting (Mrg v1 v2) A v
| Ct_Mrg_R : forall v1 v2 v A,
    casting v2 A v ->
    ordinary A ->
    casting (Mrg v1 v2) A v
| Ct_And : forall v1 v2 v A A1 A2,
    splitable A A1 A2 ->
    casting v A1 v1 ->
    casting v A2 v2 ->
    casting v A (Mrg v1 v2).

Hint Constructors casting : core.

Notation "e ⇝ [ A ] e'" := (casting e A e') (at level 68).

(** * Determinism *)

(** Under toplike and ordinary type A, value v is always casted to a constant *)

Lemma casting_ordinary_toplike :
  forall v v' A,
    ordinary A ->
    toplike A ->
    casting v A v' ->
    v' = (Ann (Lit 1) A).
Proof.
  introv Ord Tl Ct.
  induction Ct; eauto.
Qed.

(** Value v can only be casted by its super type *)

Lemma casting_super :
  forall A B v v',
    value v ->
    typing nil v Inf B ->
    casting v A v' ->
    sub B A.
Proof.
  introv Val Typ Ct. gen B.
  induction Ct; eauto; intros.
  - Case "Lit".
    repeat (dependent destruction Typ).
    assumption.
  - Case "Lam".
    dependent destruction Typ.
    assumption.
  - Case "Record".
    dependent destruction Val.
    dependent destruction Typ.
    eapply sub_record; eauto.
  - Case "Merge L".
    dependent destruction Val.
    dependent destruction Typ;
      eapply sub_and_l; eauto.
  - Case "Merge R".
    dependent destruction Val.
    dependent destruction Typ;
      eapply sub_and_r; eauto.
Qed.

(** We first prove the general version of determinism (generlized on consistent) *)

Lemma casting_determinism_gen :
  forall v1 v2 v1' v2' A B C,
    value v1 -> value v2 ->
    typing nil v1 Inf A -> typing nil v2 Inf B ->
    consistent v1 v2 ->
    casting v1 C v1' ->
    casting v2 C v2' ->
    v1' = v2'.
Proof.
  introv Val1 Val2 Typ1 Typ2 Con Ct1 Ct2.
  gen A B v1 v2 v1' v2'.
  ind_type_size (size_type C).
  destruct (splitable_or_ordinary C).
  - Case "Ord".
    gen A B. induction Con; eauto; intros.
    + SCase "Arr".
      dependent destruction Val1. dependent destruction Val2.
      dependent destruction Ct1; dependent destruction Ct2; eauto.
    + SCase "Anno".
      dependent destruction Val1. dependent destruction Val2.
      destruct H; dependent destruction Ct1; dependent destruction Ct2; eauto.
    + SCase "Record".
      dependent destruction Val1. dependent destruction Val2.
      dependent destruction Ct1; dependent destruction Ct2; eauto.
      dependent destruction Typ1. dependent destruction Typ2.
      f_equal. assert (Sz: size_type A < i) by (simpl in SizeInd; lia).
      pose proof (IH A Sz _ _ _ Val1 Typ1 _ Val2 Typ2). eauto.
    + SCase "Disjoint".
      pose proof (typing_to_ptype _ _ (value_is_uvalue _ Val1) Typ1).
      pose proof (typing_to_ptype _ _ (value_is_uvalue _ Val2) Typ2).
      repeat (subst_ptype).
      pose proof (disjoint_complete _ _ H2).
      pose proof (casting_super _ _ _ _ Val1 Typ1 Ct1).
      pose proof (casting_super _ _ _ _ Val2 Typ2 Ct2).
      assert (Tl: toplike C) by eauto.
      pose proof (casting_ordinary_toplike _ _ _ H Tl Ct1).
      pose proof (casting_ordinary_toplike _ _ _ H Tl Ct2).
      now subst.
    + SCase "Merge L".
      dependent destruction Ct1; eauto.
      * symmetry. eapply casting_ordinary_toplike; eauto.
      * dependent destruction Typ1; eauto.
      * dependent destruction Typ1; eauto.
    + SCase "Merge R".
      dependent destruction Ct2; eauto.
      * eapply casting_ordinary_toplike; eauto.
      * dependent destruction Typ2; eauto.
      * dependent destruction Typ2; eauto.
  - Case "Spl".
    destruct H as [C1 H]. destruct H as [C2 H].
    dependent destruction Ct1; dependent destruction Ct2; eauto.
    repeat (subst_splitable).
    pose proof (splitable_decrease_size _ _ _ H1) as SplSize. destruct SplSize.
    assert (size_type C1 < i) by lia. assert (size_type C2 < i) by lia.
    f_equal; eauto 3.
Qed.

(** Then prove its determinism by directly applying [casting_determinism_gen] *)

Lemma casting_determinism :
  forall v v1 v2 A B,
    value v ->
    typing nil v Inf A ->
    casting v B v1 ->
    casting v B v2 ->
    v1 = v2.
Proof.
  introv Val Typ Ct1 Ct2.
  eapply casting_determinism_gen; eauto.
Qed.

(** * Casting & Value *)

(** Value property is preserved by casting *)

Lemma casting_lc :
  forall v v' A,
    lc v ->
    casting v A v' ->
    lc v'.
Proof.
  introv Lc Ct.
  dependent induction Ct; eauto 3; econstructor; eauto.
Qed.

Lemma casting_value :
  forall v v' A,
    value v ->
    casting v A v' ->
    value v'.
Proof.
  introv Val Ct.
  induction Ct; eauto.
  inversion Val; eauto.
Qed.

Hint Resolve casting_value : core.

(** * Transitivity *)

Lemma casting_transitivity :
  forall v v1 v2 A B,
    value v ->
    casting v A v1 ->
    casting v1 B v2 ->
    casting v B v2.
Proof.
  introv Val Ct1 Ct2. gen B v2.
  induction Ct1; intros; try solve [dependent induction Ct2; eauto].
  - dependent induction Ct2; eauto.
    eapply Ct_Lam; eauto. eapply sub_transitivity; eauto.
  - dependent destruction Val.
    dependent induction Ct2; eauto.
  - dependent destruction Val.
    dependent induction Ct2; eauto.
  - dependent destruction Val.
    dependent induction Ct2; eauto.
Qed.

(** * Progress *)

Lemma casting_progress' :
  forall v A B,
    value v ->
    typing nil v Inf A ->
    sub A B ->
    exists v', casting v B v'.
Proof.
  introv Val Typ Sub. gen v.
  induction Sub; intros.
  - Case "Sub-Int".
    dependent destruction Typ; eauto.
    dependent destruction Val. dependent destruction H.
    + SCase "Lit".
      dependent destruction Typ; eauto.
    + SCase "Lam".
      dependent destruction Typ; eauto.
      dependent destruction Typ; eauto.
  - Case "Sub-Top".
    dependent destruction Typ; eauto.
  - Case "Sub-Arr".
    dependent destruction Typ; eauto.
    destruct (toplike_decidable D).
    + SCase "Toplike".
      eexists; eauto.
    + SCase "Not Toplike".
      dependent destruction Val. dependent destruction H0; eauto.
      dependent destruction Typ. dependent destruction Typ.
      dependent destruction H2; eauto. dependent destruction H3.
      assert (toplike D) by (eapply sub_toplike; eauto).
      contradiction.
  - destruct (toplike_decidable B); eauto.
    + eexists; eauto.
    + dependent destruction Typ; eauto.
      * dependent destruction Val. destruct (IHSub e); eauto.
      * dependent destruction Val.
        assert (~ toplike A) by (eapply sub_not_toplike; eauto).
        destruct H0.
        repeat (dependent destruction Typ). dependent destruction H2; eauto.
        repeat (dependent destruction Typ). dependent destruction H3; eauto.
  - Case "Sub-And".
    pose proof (IHSub1 _ Val Typ). pose proof (IHSub2 _ Val Typ).
    destruct_conjs; eauto.
  - Case "Sub-And-L".
    dependent destruction Typ; eauto.
    + dependent destruction Val.
      pose proof (IHSub _ Val1 Typ1). destruct_conjs; eauto.
    + dependent destruction Val.
      pose proof (IHSub _ Val1 Typ1). destruct_conjs; eauto.
  - Case "Sub-And-R".
    dependent destruction Typ; eauto.
    + dependent destruction Val.
      pose proof (IHSub _ Val2 Typ2). destruct_conjs; eauto.
    + dependent destruction Val.
      pose proof (IHSub _ Val2 Typ2). destruct_conjs; eauto.
Qed.

Lemma casting_progress :
  forall v A ,
    value v ->
    typing nil v Chk A ->
    exists v', casting v A v'.
Proof.
  introv Val Typ.
  dependent destruction Typ.
  eapply casting_progress'; eauto.
Qed.

(** * Casting & Consistent *)

(** ** Specification *)

Definition consistent_spec v1 v2 :=
  forall A v1' v2',
    ordinary A ->
    casting v1 A v1' ->
    casting v2 A v2' ->
    v1' = v2'.

(** ** Soundness *)

Lemma consistent_sound :
  forall v1 v2 A B,
    value v1 -> value v2 ->
    typing nil v1 Inf A ->
    typing nil v2 Inf B ->
    consistent v1 v2 ->
    consistent_spec v1 v2.
Proof.
  introv Val1 Val2 Typ1 Typ2 Con.
  unfold consistent_spec. intros C v1' v2' Ord Ct1 Ct2.
  now pose proof (casting_determinism_gen _ _ _ _ _ _ _ Val1 Val2 Typ1 Typ2 Con Ct1 Ct2).
Qed.

(** ** Completeness *)

(** We need two "inversion lemmas" on specification *)

Lemma consistent_spec_inv_merge_l :
  forall v v1 v2,
    consistent_spec (Mrg v1 v2) v ->
    consistent_spec v1 v /\ consistent_spec v2 v.
Proof.
  introv Cons. split; unfold consistent_spec in *; intros; eauto.
Qed.

Lemma consistent_spec_inv_merge_r :
  forall v v1 v2,
    consistent_spec v (Mrg v1 v2) ->
    consistent_spec v v1 /\ consistent_spec v v2.
Proof.
  introv Cons. split; unfold consistent_spec in *; intros; eauto.
Qed.

Ltac ind_term_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : term |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => (dependent destruction H; eauto) end
    | intros ].

Ltac inv :=
  match goal with
  | Typ: typing nil (Ann _ _) Inf _       |- _ => dependent destruction Typ
  | Typ: typing nil _ Chk _               |- _ => dependent destruction Typ
  | Typ: typing nil (Lit _) Inf _         |- _ => dependent destruction Typ
  | Typ: typing nil (Lam _ _ _) Inf _     |- _ => dependent destruction Typ
  | Sub: sub Int ?A, nTl: ~ toplike ?A, Ord: ordinary ?A |- _ =>
      (pose proof (sub_inv_int _ nTl Sub Ord); clear nTl Sub Ord; subst)
  | Sub: sub (Arr _ _) ?A, nTl: ~ toplike ?A, Ord: ordinary ?A |- _ =>
      (pose proof (sub_inv_arrow_arrow _ _ _ nTl Ord Sub); clear Sub)
  end.

Lemma consistent_spec_inv_rcd :
  forall v1 v2 l A B,
    value v1 -> value v2 ->
    typing nil v1 Inf A ->
    typing nil v2 Inf B ->
    consistent_spec (Fld l v1) (Fld l v2) ->
    consistent_spec v1 v2.
Proof.
  introv Val1 Val2 Typ1 Typ2 Cons.
  unfold consistent_spec in *. introv Ord Ct1 Ct2.
  destruct (toplike_decidable A0).
  - pose proof (casting_ordinary_toplike _ _ _ Ord H Ct1) as Eq1.
    pose proof (casting_ordinary_toplike _ _ _ Ord H Ct2) as Eq2.
    congruence.
  - assert ((Fld l v1') = (Fld l v2')) as Eq.
    eapply (Cons (Rcd l A0)); eauto.
    dependent destruction Eq; eauto.
Qed.

Lemma consistent_complete :
  forall v1 v2 A B,
    value v1 -> value v2 ->
    typing nil v1 Inf A ->
    typing nil v2 Inf B ->
    consistent_spec v1 v2 ->
    consistent v1 v2.
Proof.
  introv Val1 Val2 Typ1 Typ2 Cons. gen A B.
  ind_term_size (size_term v1 + size_term v2).
  dependent destruction Val1; dependent destruction Val2; simpl in SizeInd.
  - Case "Anno~Anno".
    repeat inv.
    destruct (toplike_decidable B0); destruct (toplike_decidable B).
    + eapply Con_Dj; eauto; eapply disjoint_toplike; eauto.
    + eapply Con_Dj; eauto; eapply disjoint_toplike; eauto.
    + eapply consistent_symmetry; eauto. eapply Con_Dj; eauto; eapply disjoint_toplike; eauto.
    + destruct H; destruct H1.
      * SCase "Lit Lit".
        repeat inv.
        (* derive equality from Cons *)
        unfold consistent_spec in Cons.
        assert (Ct1: casting (Ann (Lit n) Int) Int (Ann (Lit n) Int)) by eauto.
        assert (Ct2: casting (Ann (Lit n0) Int) Int (Ann (Lit n0) Int)) by eauto.
        pose proof (Cons _ _ _ Ord_Tnt Ct1 Ct2) as Eq.
        dependent destruction Eq. eauto.
      * SCase "Lit Lam".
        repeat inv. destruct_conjs. subst. eauto.
      * SCase "Lam Lit".
        repeat inv. destruct_conjs. subst. eauto.
      * SCase "Lam Lam".
        unfold consistent_spec in Cons.
        repeat inv. destruct_conjs. subst.
        match goal with
        | |- consistent (Ann _ (Arr _ ?A)) (Ann _ (Arr _ ?B)) =>
            destruct (disjoint_spec_decidable A B); eauto
        end.
        destruct_conjs.
        match goal with
        | [H1: sub ?D1 ?DD, H2: sub ?D2 ?DD
           |- consistent (Ann (Lam ?A1 ?e1 ?B1) (Arr ?C1 ?D1)) (Ann (Lam ?A2 ?e2 ?B2) (Arr ?C2 ?D2))] =>
            (pose proof (casting_progress' (Ann (Lam A1 e1 B1) (Arr C1 D1)) (Arr C1 D1) (Arr (And C1 C2) DD)) as Ct1;
             pose proof (casting_progress' (Ann (Lam A2 e2 B2) (Arr C2 D2)) (Arr C2 D2) (Arr (And C1 C2) DD)) as Ct2;
             assert (Ord: ordinary (Arr (And C1 C2) DD)) by eauto)
        end.
        destruct Ct1 as [x1 Ct1]; eauto. destruct Ct2 as [x2 Ct2]; eauto.
        pose proof (Cons _ _ _ Ord Ct1 Ct2). subst.
        dependent destruction Ct1; dependent destruction Ct2; eauto.
  - Case "Ann~Rcd".
    eapply Con_Dj; eauto.
    dependent destruction Typ1. dependent destruction Typ2.
    destruct H.
    + dependent destruction Typ1. dependent destruction Typ1.
      dependent destruction H1; eauto. eapply disjoint_toplike; eauto.
    + dependent destruction Typ1. dependent destruction Typ1.
      dependent destruction H2; eauto. eapply disjoint_toplike; eauto.
  - eapply consistent_spec_inv_merge_r in Cons. destruct_conjs.
    dependent destruction Typ2;
      eapply Con_Mrg_R; eapply IH; eauto; simpl in *; lia.
  - Case "Rcd~Ann".
    eapply Con_Dj; eauto.
    dependent destruction Typ1. dependent destruction Typ2.
    destruct H.
    + dependent destruction Typ2. dependent destruction Typ2.
      dependent destruction H1; eauto. eapply disjoint_symmetry. eapply disjoint_toplike; eauto.
    + dependent destruction Typ2. dependent destruction Typ2.
      dependent destruction H2; eauto. eapply disjoint_symmetry. eapply disjoint_toplike; eauto.
  - dependent destruction Typ1. dependent destruction Typ2.
    destruct (l == l0).
    + subst. assert (consistent_spec v v0) by (eapply consistent_spec_inv_rcd; eauto).
      eapply Con_Rcd. eapply (IH _ Val1 _ Val2 H); eauto; try lia.
    + eapply Con_Dj; eauto.
  - eapply consistent_spec_inv_merge_r in Cons. destruct_conjs.
    dependent destruction Typ2;
      eapply Con_Mrg_R; eapply IH; eauto; simpl in *; lia.
  - eapply consistent_spec_inv_merge_l in Cons. destruct_conjs.
    dependent destruction Typ1;
      eapply Con_Mrg_L; eapply IH; eauto; simpl in *; lia.
  - eapply consistent_spec_inv_merge_l in Cons. destruct_conjs.
    dependent destruction Typ1;
      eapply Con_Mrg_L; eapply IH; eauto; simpl in *; lia.
  - eapply consistent_spec_inv_merge_l in Cons. destruct_conjs.
    dependent destruction Typ1;
      eapply Con_Mrg_L; eapply IH; eauto; simpl in *; lia.
Qed.

(** ** Preservation *)

Lemma casting_consistent :
  forall v v1 v2 A A1 A2 B C,
    value v ->
    typing nil v Inf A ->
    typing nil v1 Inf A1 ->
    typing nil v2 Inf A2 ->
    casting v B v1 ->
    casting v C v2 ->
    consistent v1 v2.
Proof.
  introv Val Typ Typ1 Typ2 Ct1 Ct2.
  eapply consistent_complete; eauto.
  unfold consistent_spec. intros E v1' v2' Ord Ct1' Ct2'.
  pose proof (casting_transitivity v v1 v1' B E Val Ct1 Ct1').
  pose proof (casting_transitivity v v2 v2' C E Val Ct2 Ct2').
  eapply casting_determinism_gen; eauto.
Qed.

(** * Preservation *)

Lemma casting_preservation :
  forall v v' A B,
    value v ->
    typing nil v Inf B ->
    casting v A v' ->
    exists C, typing nil v' Inf C /\ isosub C A.
Proof.
  introv Val Typ Ct. gen B.
  induction Ct; intros; try solve [eexists; eauto].
  - Case "Lit".
    exists A. split; eauto.
  - Case "Lam".
    exists (Arr C D). split; eauto 3.
    repeat (dependent destruction Typ).
    dependent destruction Val.
    assert (Sub1: sub (Arr A B) (Arr C D)) by (eapply sub_transitivity; eauto).
    dependent destruction Sub1; eauto 3.
    assert (Sub2: sub (Arr A D) (Arr C D)) by eauto.
    eapply Ty_Ann; eauto. eapply Ty_Sub; eauto.
    eapply Ty_Lam; eauto. intros. eapply typing_chk_sub; eauto.
  - Case "Rcd".
    dependent destruction Val. dependent destruction Typ; eauto.
    pose proof (IHCt Val _ Typ). destruct H1. destruct H1.
    exists (Rcd l x). split; eauto.
  - Case "Merge L".
    dependent destruction Val. dependent destruction Typ; eauto.
  - Case "Merge R".
    dependent destruction Val. dependent destruction Typ; eauto.
  - Case "Merge".
    pose proof (IHCt1 Val B Typ) as IH1. destruct IH1 as [x1 IH1].
    pose proof (IHCt2 Val B Typ) as IH2. destruct IH2 as [x2 IH2].
    destruct_conjs.
    exists (And x1 x2). split; eauto. eapply Ty_Mrg_Uv; eauto.
    eapply casting_consistent; eauto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal71.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj2eqsynthconj2 : forall  (lv0 : natural), (@eq natural (Succ lv0) (Succ lv0)).
Admitted.
QuickChick conj2eqsynthconj2.


Require Import Ascii String ZArith List Bool.
Require Import DecimalString.
Require Import location error.
Require Import micheline_tokens micheline_parser micheline_lexer michelson2micheline.
Require Import micheline_syntax.

Definition string_of_Z z := DecimalString.NilZero.string_of_int (Z.to_int z).

Fixpoint make_string (a : ascii) (n : nat) :=
  match n with
  | 0 => EmptyString
  | S n' => String a (make_string a n')
  end.

Definition lf := (String "010" EmptyString).

Open Scope string_scope.

(* Length taken by a Micheline expression when printed on a single line *)
(* TODO: avoid computing Z.to_int twice for each number litteral *)
Fixpoint micheline_length (mich : loc_micheline) (in_seq : bool) :=
  let '(Mk_loc_micheline (_, _, m)) := mich in
  match m with
  | NUMBER z => String.length (string_of_Z z)
  | STR s => 2 + String.length s
  | BYTES s => 2 + String.length s
  | SEQ nil => 2
  | SEQ es => fold_left (fun acc m => 2 + micheline_length m true + acc) es 0
  | PRIM (_, _, s) nil => String.length s
  | PRIM (_, _, s) es =>
    (if in_seq then 0 else 2) + String.length s +
    fold_left (fun acc m => 1 + micheline_length m false + acc) es 0
  end.

Fixpoint micheline_pp_single_line (mich : loc_micheline) (in_seq : bool) :=
  let '(Mk_loc_micheline (_, _, m)) := mich in
  match m with
  | NUMBER z => string_of_Z z
  | STR s => """" ++ s ++ """"
  | BYTES s => "0x" ++ s
  | SEQ es => "{" ++ String.concat "; " (map (fun m => micheline_pp_single_line m true) es) ++ "}"
  | PRIM (_, _, s) nil => s
  | PRIM (_, _, s) es =>
    let res := s ++ " " ++ String.concat " " (map (fun m => micheline_pp_single_line m false) es) in
    (if in_seq then res else "(" ++ res ++")")
  end.

Fixpoint micheline_pp (mich : loc_micheline) (indent : nat) (in_seq : bool)
         (seq_lf : bool) :=
  if (micheline_length mich in_seq) + indent <? 80 then
    micheline_pp_single_line mich in_seq
  else
  match mich with
  | Mk_loc_micheline (_, _, NUMBER z) => (string_of_Z z)
  | Mk_loc_micheline (_, _, STR s) => """"++s++""""
  | Mk_loc_micheline (_, _, BYTES s) => "0x"++s
  | Mk_loc_micheline (_, _, SEQ es) =>
    let indent_space := (make_string " " indent) in
    let separator := (";"  ++ lf ++ indent_space ++ "  ") in
    "{ " ++(String.concat separator
                          (map
                             (fun m => micheline_pp m (indent+2) true seq_lf)
                             es))
         ++ lf ++ indent_space ++ "}"
  | Mk_loc_micheline (_, _, PRIM (_, _, s) nil) => s
  | Mk_loc_micheline (_, _, PRIM (_, _, s) es) =>
    let newIndent := indent + 1 + String.length s in
    let separator := lf++(make_string " " newIndent) in
    let res := s++" "++
                (String.concat
                   separator
                   (map
                      (fun m =>
                         micheline_pp m newIndent false
                                      (negb (eqb_string s "PUSH")))
                      es)) in
    if in_seq then res else "("++res++")"
  end.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import finset.
Require Import paths.
Require Import connect.
Require Import hypermap.
Require Import walkup.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Planarity.

Theorem even_genusP : forall g, even_genus g.
Proof.
move=> g; elim: {g}(card g) {-3 4}g (erefl (card g)) => [|n Hrec] g Dn.
  have Hc0: forall a : set g, card a = 0.
    move=> a; apply: eqP; rewrite -leqn0 -Dn; apply max_card.
  by rewrite /even_genus /genus /genus_rhs /genus_lhs /n_comp Dn !Hc0.
case: (set0Pnx g _); first by rewrite /set0b Dn.
move=> z _; apply: (@even_genus_walkup g z); apply Hrec.
by rewrite card_walkup Dn.
Qed.

Theorem genus_le : forall g, genus_rhs g <= genus_lhs g.
Proof. move=> g; rewrite even_genusP; apply leq_addl. Qed.

Remark node_is_last : forall g  x p,
 exists2 y : dart g, node y = last x p & y = finv node (last x p).
Proof.
by move=> g x p; exists (finv node (last x p)); rewrite ?(f_finv (Inode g)).
Qed.

Theorem planar_jordan : forall g, planar g -> jordan g.
Proof.
move=> g Hg; elim: {g}(card g) {-4 5}g Hg (erefl (card g)) => [|n Hrec] g Hg Dn.
  by move=> [|x p]; last by move: (max_card (eqd x)); rewrite card1 Dn.
have HcE: forall z : g, jordan (walkupE z).
  by move=> z; apply: (Hrec _ (planar_walkupE z Hg)); rewrite card_walkup Dn.
have HcN: forall z : g, jordan (walkupN z).
  move=> z; apply: (Hrec _ (planar_walkupN z Hg)).
  by apply: (etrans (card_walkup _)); rewrite /= Dn.
have HcF: forall z : g, jordan (walkupF z).
  move=> z; apply: (Hrec _ (planar_walkupF z Hg)).
  by apply: (etrans (card_walkup _)); rewrite /= Dn.
clear n Dn Hrec.
have HpE: forall (z x : g) p, path clink x p ->
      negb (Adds x p z) ->
    let pg : walkupE z -> g := @subdE _ _ in
    exists2 x', pg x' = x & exists2 p', path clink x' p' & maps pg p' = p.
  move=> z x p; rewrite /= /setU1 eqd_sym; move=> Hp; move/norP=> [Hx Hpz].
  exists (@subdI g (setC1 z) x Hx); trivial.
  elim: p x Hx Hp Hpz => [|y p Hrec] x Hx; first by exists (Seq0 (walkupE z)).
  rewrite /= /setU1 eqd_sym; move/andP=> [Hxy Hp]; move/norP=> [Hy Hpz].
  case: {Hrec Hp Hpz}(Hrec y Hy Hp Hpz) => [p' Hp' Dp].
  exists (Adds (@subdI g (setC1 z) y Hy) p'); last by rewrite /= Dp.
  apply/andP; split; [ apply/clinkP | done ].
  case/clinkP: Hxy => [Dny|Dfx]; [ left | right ]; apply: subdE_inj.
    by rewrite /= /skip1 -Dny (negbE Hx).
  by rewrite /= /skip1 Dfx (negbE Hy).
have HpN: forall (z x : g) p, path clink x p ->
      negb (Adds x p z) -> negb (p (face z)) ->
    let pg : walkupN z -> g := @subdE _ _ in
    exists2 x', pg x' = x & exists2 p', path clink x' p' & maps pg p' = p.
  move=> z x p; rewrite /= /setU1 eqd_sym; move=> Hp; move/norP=> [Hx Hpz] Hpfz.
  exists (@subdI g (setC1 z) x Hx); trivial.
  elim: p x Hx Hp Hpz Hpfz => [|y p Hrec] x;
   first by exists (Seq0 (walkupN z)).
  rewrite /= /setU1 !(eqd_sym y); move=> Hx; move/andP=> [Hxy Hp].
  move/norP=> [Hy Hpz]; move/norP=> [Hyfz Hpfz].
  case: {Hrec Hp Hpz Hpfz}(Hrec y Hy Hp Hpz Hpfz) => [p' Hp' Dp].
  exists (Adds (@subdI g (setC1 z) y Hy) p'); last by congr Adds.
  apply/andP; split; [ apply/clinkP | done ].
  case/clinkP: Hxy => [Dny|Dfx]; [ left | right ]; apply: subdE_inj.
    rewrite /= /skip_edge1 /= -(monic2F_eqd (Eface g)) -Dny (negbE Hx).
    by rewrite (negbE Hyfz) if_same.
  by rewrite /= /skip1 /= Dfx (negbE Hy).
have HpF: forall (z x : g) p, path clink x p ->
      negb (Adds x p z) -> negb (p (face (edge z))) ->
    let pg : walkupF z -> g := @subdE _ _ in
    exists2 x', pg x' = x & exists2 p', path clink x' p' & maps pg p' = p.
  move=> z x p; rewrite /= /setU1 eqd_sym; move=> Hp; move/norP=> [Hx Hpz] Hpfez.
  exists (@subdI g (setC1 z) x Hx); trivial.
  elim: p x Hx Hp Hpz Hpfez => [|y p Hrec] x; first by exists (Seq0 (walkupF z)).
  rewrite /= /setU1 (eqd_sym y); move=> Hx; move/andP=> [Hxy Hp].
  move/norP=> [Hy Hpz]; move/norP=> [Hyfez Hpfez].
  case: {Hrec Hp Hpz Hpfez}(Hrec y Hy Hp Hpz Hpfez) => [p' Hp' Dp].
  exists (Adds (@subdI g (setC1 z) y Hy) p'); last by congr Adds.
  apply/andP; split; [ apply/clinkP | done ].
  case/clinkP: Hxy => [Dny|Dfx]; [ left | right ]; apply: subdE_inj.
    by rewrite /= /skip1 /= -Dny (negbE Hx).
  rewrite /= /skip_edge1 /= Dfx (negbE Hy) !(eqd_sym z).
  by rewrite (monic2F_eqd (Enode g)) (negbE Hyfez) if_same.
move=> [|x p]; [ done | apply/and3P ].
case: (node_is_last x p) => [y Dny <-] [Hp2 Up Hp].
have HeI := @subdE_inj g (setC1 _).
case: (pickP (setC (Adds x p))) => [z Hz|Hpg].
case: {Hp}(HpE _ _ _ Hp Hz) => [x' Dx [p' Hp' Dp]].
simpl in Dp; case/and3P: (HcE z (Adds x' p')); split; auto.
case: (node_is_last x' p') => [[y' Hy'] Dny' <-]; simpl in Dny'.
 rewrite -(mem2_maps (HeI z)) /= Dp Dx /skip1.
  rewrite -Dp -Dx last_maps /= -Dny' /= /skip1 in Dny.
  case: (z =P node x) => [Dz|_].
    by rewrite Dz /setC /= (setU1r x (mem2r Hp2)) in Hz.
    case: (z =d node y') Dny => [|] Dny; last by rewrite -(Inode g Dny).
    by rewrite -(Inode g Dny) /setC /= (setU1r x (mem2l Hp2)) in Hz.
  by rewrite -(uniq_maps (HeI z)) /= Dx Dp.
move: (cardC (Adds x p)); rewrite (card_uniqP Up) (eq_card Hpg) card0 addn0.
case: p x {Hp2}(mem2l Hp2) Hp Up (Hp2) Dny Hpg => [|x1 p] x0 //=.
case Hx0y: (x0 =d y); first by move=> H _; rewrite (eqP Hx0y) H.
clear; move/andP=> [Hx01 Hp]; move/andP=> [Hpx0 Up] Hp2 Dny.
rewrite mem2_adds in Hp2.
case/clinkP: Hx01 => [Dnx1|Dfx0].
  case: {Hp}(HpE _ _ _ Hp Hpx0) => [x' Dx1 [p' Hp' Dp]].
  case/and3P: (HcE x0 (Adds x' p')); split; auto.
    case: (x1 =P y) Hp2 => [Dy|_] Hp2.
      by rewrite Dnx1 {2}Dy Dny mem_lastU in Hpx0.
    case: (node_is_last x' p') => [[y' Hy'] Dny' <-].
    rewrite -(mem2_maps (HeI x0)).
    rewrite [maps _ _]Dp /= /skip1 Dx1 -Dnx1 set11.
    rewrite -Dp -Dx1 last_maps -Dny' /= /skip1 in Dny.
    case: (x0 =d node y') Dny => [|] Dny; last by rewrite -(Inode g Dny).
    by rewrite (Inode g Dny) set11 in Hx0y.
  by rewrite -Dp -Dx1 in Up; rewrite -(uniq_maps (HeI x0)).
case: p Hp Hp2 Dny Up Dfx0 Hpx0 => [|x2 p].
  simpl; case (x1 =d y); rewrite // /setU1 orbF /=.
  by move=> _ H Dny; rewrite -(inj_eqd (Inode g)) Dny eqd_sym H in Hx0y.
simpl; move/andP=> [Hx1p Hp] Hp2 Dny; move/andP=> [Hpx1 Up] Dfx0.
move/norP=> [Hx10 Hpx0]; set (u01 := subdI (a := setC1 x1) Hx10).
case/clinkP: Hx1p => [Dnx2|Dfx1].
  case: {Hp}(HpF _ _ _ Hp Hpx1); first by rewrite Dnx2 Enode; case/andP: Up.
  case Hx1nx0: (x1 =d node x0).
    by rewrite (eqP Hx1nx0) in Dnx2; rewrite (Inode g Dnx2) setU11 in Hpx0.
  move=> x' Dx2 [p' Hp' Dp].
  case/and3P: (HcF x1 (Adds u01 (Adds x' p'))); split.
   rewrite last_adds -(mem2_maps (HeI x1)).
    case: (node_is_last x' p') => [[y' Hy'] Dny' <-]; simpl in y', Hy'.
    rewrite -Dp -Dx2 last_maps -Dny' /= /skip1 /= in Dny; simpl in Dp, Dx2.
    rewrite /= Dp Dx2 /skip1 /= Hx1nx0.
    case: (x1 =P node y') Dny => [Dx1|_] Dny.
      rewrite Dx1 in Dnx2; rewrite (Inode g Dnx2) mem2_adds set11.
      by rewrite (Inode g Dny) set11 /setU1 Hx1nx0 in Hp2.
    by rewrite (Inode g Dny) (negbE Hy') in Hp2 |- *.
   by simpl in Dp, Dx2; rewrite -(uniq_maps (HeI x1)) /= Dp Dx2 Hpx0.
  apply/andP; split; [ apply/clinkP; right; apply: subdE_inj | done ].
  rewrite Dx2 /= /skip_edge1 /= -{1}Dfx0 (inj_eqd (Iface g)).
  rewrite (eqd_sym x0) (negbE Hx10) Dfx0 set11.
  case: (x1 =P node x1) => [Dx1|_]; last by rewrite Dnx2 Enode.
  by rewrite Dx1 in Dnx2; rewrite (Inode g Dnx2) setU11 in Hpx1.
rewrite -if_negb in Hp2; case Hx1y: (negb (eqd x1 y)) Hp2.
  case: {Hp}(HpE _ _ _ Hp Hpx1) => [x' Dx2 [p' Hp' Dp]] Hp2.
  case/and3P: (HcE x1 (Adds u01 (Adds x' p'))); split.
   rewrite -(mem2_maps (d':=walkupE x1) (HeI x1)) last_adds.
    case: (node_is_last x' p') => [[y' Hy'] Dny' <-]; simpl in y', Hy'.
    rewrite -Dp -Dx2 last_maps -Dny' /= /skip1 in Dny; simpl in Dp, Dx2.
    rewrite /= Dp Dx2 /skip1 /=.
    case: (x1 =P node x0) => [Dx1|_].
      by rewrite -Dx1 in Hp2; rewrite -mem_adds (mem2r Hp2) in Hpx1.
      case: (eqd x1 (node y')) Dny => [|] Dny; last by rewrite -(Inode g Dny).
    by rewrite (Inode g Dny) set11 in Hx1y.
   by simpl in Dp, Dx2; rewrite -(uniq_maps (HeI x1)) /= Dp Dx2 Hpx0.
  apply/andP; split; [ apply/clinkP; right; apply: subdE_inj | done ].
  by rewrite Dx2 /= /skip1 Dfx0 set11 Dfx1.
move/eqP: Hx1y Dny => <- Dnx1 Hp2.
case Hnx1: (x1 =d node x1).
  by rewrite (eqP Hnx1) Dnx1 mem_lastU in Hpx1.
case Hx1nx0: (negb (eqd x1 (node x0))).
  rewrite /setU1 (negbE Hx1nx0) /= in Hp2; case: {Hp}(HpN _ _ _ Hp Hpx1).
    by rewrite Dfx1; case: (andP Up).
  move=> x' Dx2 [p' Hp' Dp].
  case/and3P: (HcN x1 (Adds u01 (Adds x' p'))); split.
  - rewrite -(mem2_maps (HeI x1)) last_adds.
    case: (node_is_last x' p') => [[y' Hy'] Dny' <-]; simpl in y', Hy'.
    rewrite -Dp -Dx2 last_maps -Dny' /= /skip_edge1 /= in Dnx1.
    simpl in Dp, Dx2; rewrite /= Dp Dx2 /skip_edge1 /=; move: Dnx1.
    rewrite (negbE Hx1nx0) -!(monic2F_eqd (Eface g)) Hnx1 Dfx1.
    case: (x2 =P x0) => [Dx0|_]; first by rewrite -Dx0 setU11 in Hpx0.
    case: (x2 =P y') => [Dy'|_]; first by rewrite -Dy' mem2_adds set11.
    case: (x1 =d node y') {Dny'} => [|] Dnx1.
      by rewrite (Inode g Dnx1) setU11 in Hpx1.
   - by rewrite /setC1 (Inode g Dnx1) set11 in Hy'.
   by simpl in Dp, Dx2; rewrite -(uniq_maps (HeI x1)) /= Dp Dx2 Hpx0.
  apply/andP; split; [ apply/clinkP; right; apply: subdE_inj | done ].
  by rewrite Dx2 /= /skip1 /= Dfx0 set11 Dfx1.
move: {Hx1nx0}(esym (eqP (negbEf Hx1nx0))) {Hnx1 Hp2} => Dnx0.
case: p Hp Up Hpx0 Hpx1 Dfx1 Dnx1 => [|x3 p].
  rewrite /= /setU1 !orbF; move=> _ _ Hx20 Hx21 Dfx1 Dnx1 Hpg Hcg.
  have Hge1: forall e, connect_sym e -> e x0 x1 -> e x1 x2 -> n_comp e g = 1.
    move=> e He He01 He12; rewrite -(card1 (root e x1)); apply: eq_card => [x].
    rewrite /setI andbT; congr (@eqd g); apply: (rootP He).
    case/or3P: (Hpg x); rewrite ?orbF; case/eqP=> <-.
    - by apply connect1.
    - by rewrite connect0.
    by rewrite He; apply connect1.
  have Dex0: edge x0 = x1.
    apply: eqP; rewrite (monic2F_eqd (Eedge g)) Dfx1;
    move/idP: (Hpg (node x2)).
    rewrite /setU1 -Dnx0 -{3}Dnx1 !(inj_eqd (Inode g)) -!(eqd_sym x2).
    by rewrite (negbE Hx20) (negbE Hx21) !orbF.
  have Dex1: edge x1 = x2.
    apply: (Iface g (eqP _)); rewrite -Dnx0 Enode; move/idP: (Hpg (face x2)).
    rewrite /setU1 -Dfx0 -{3}Dfx1 !(inj_eqd (Iface g)) -!(eqd_sym x2).
    by rewrite (negbE Hx20) (negbE Hx21) !orbF.
  move: Hg; rewrite /planar /genus /genus_lhs /genus_rhs.
  rewrite -Hcg !Hge1 //; try by apply/eqP.
  - exact (Sface g).
  - exact (Snode g).
  - exact (Sedge g).
  - exact (Sglink g).
  - by rewrite -Dfx0 glinkF.
  by rewrite -Dfx1 glinkF.
simpl; move/andP=> [Hx2p Hp]; move/andP=> [Hpx2 Up].
move/norP=> [Hx20 Hpx0]; move/norP=> [Hx21 Hpx1] Dfx1 Dnx1.
pose u02 := @subdI g (setC1 x2) x0 Hx20.
pose u12 := @subdI g (setC1 x2) x1 Hx21.
case/clinkP: Hx2p => [Dnx3|Dfx2].
  case: {Hp}(HpF _ _ _ Hp Hpx2); first by rewrite Dnx3 Enode; case (andP Up).
  move=> x' Dx3 [p' Hp' Dp].
  case/and3P: (HcF x2 (Adds u02 (Adds u12 (Adds x' p')))); split.
  - rewrite -(mem2_maps (HeI x2)) !last_adds.
    case: (node_is_last x' p') => [[y' Hy'] Dny' <-]; simpl in y', Hy'.
    rewrite -Dp -Dx3 last_maps -Dny' /= /skip1 /= in Dnx1; simpl in Dp, Dx3.
    rewrite /= Dp Dx3 /skip1 /= Dnx0 (negbE Hx21).
    case: (x2 =d node y') Dnx1 => [|] Dnx1.
      by case/eqP: (Hx21); apply Inode.
    by rewrite (Inode g Dnx1) mem2_adds set11 setU11.
  - simpl in Dp, Dx3; rewrite -(uniq_maps (HeI x2)) /= Dp Dx3.
    by rewrite {1}/setU1 negb_orb Hx10 Hpx0 Hpx1.
  apply/and3P; split; auto; apply/clinkP; right; apply: subdE_inj.
    rewrite /= /skip_edge1 /= Dfx0 (negbE Hx21) Dnx3 (inj_eqd (Inode g)).
    case: (x3 =P x1) => [Dx1|_]; first by rewrite -Dx1 setU11 in Hpx1.
    by rewrite if_same.
  rewrite Dx3 /= /skip_edge1 /= Dfx1 set11 -{1}Dfx1 (inj_eqd (Iface g)).
  rewrite (eqd_sym x1) (negbE Hx21) {1}Dnx3 (inj_eqd (Inode g)).
  case: (x3 =P x2) => [Dx2|_]; first by rewrite -Dx2 setU11 in Hpx2.
  by rewrite Dnx3 Enode.
case: {Hp}(HpE _ _ _ Hp Hpx2) => [x' Dx3 [p' Hp' Dp]].
  case/and3P: (HcE x2 (Adds u02 (Adds u12 (Adds x' p')))); split.
    rewrite -(mem2_maps (HeI x2)) !last_adds.
    case: (node_is_last x' p') => [[y' Hy'] Dny' <-]; simpl in y', Hy'.
    rewrite -Dp -Dx3 last_maps -Dny' /= /skip1 in Dnx1; simpl in Dp, Dx3.
    rewrite /= Dp Dx3 /skip1 /= Dnx0 (negbE Hx21).
    case: (x2 =d node y') Dnx1 => [|] Dnx1.
      by case/eqP: (Hx21); apply Inode.
    by rewrite (Inode g Dnx1) mem2_adds set11 setU11.
  simpl in Dp, Dx3; rewrite -(uniq_maps (HeI x2)) /= Dp Dx3.
  by rewrite {1}/setU1 negb_orb Hx10 Hpx0 Hpx1.
apply/and3P; split; auto; apply/clinkP; right; apply: subdE_inj.
  by rewrite /= /skip1 /= Dfx0 (negbE Hx21).
by rewrite /= /skip1 Dfx1 set11 Dfx2.
Qed.

Lemma euler_tree : forall g, jordan g -> forall x : g,
  negb (disjoint (cedge x) (fun y => clink y y || negb (cross_edge y))).
Proof.
move=> g Hj x0; apply/set0P => [Hx0].
move: (@root g (eqdf face)) (rootPx (Sface g)) => rf rfP.
suffice []: ~ (exists2 x, cedge x0 x
          & exists2 p, fpath edge x p /\ uniq (maps rf (Adds x p))
          & rf (node (face x)) = rf (last x p)).
  have Hp' := fconnect1 edge x0; rewrite Sedge in Hp'.
  case/connectP: Hp' => [p' Hp' Ep']; pose p := Adds (edge x0) p'.
  have: negb (uniq (maps rf (Adds x0 p))).
    by rewrite /= -{2}Ep' -(last_maps rf) mem_lastU.
  have: last x0 p = x0 by done.
  have: fpath edge x0 p by rewrite /= /eqdf set11.
  elim Dp: p {1 2 4}x0 => {p' Hp' Ep'} [|ex p' Hrec] // x.
  rewrite -{3}Dp /=; move/andP=> [Dex Hp] Ep.
  case Up: (uniq (maps rf p)); last by move: (negbI Up); rewrite Dp; eauto.
  rewrite andbT negb_elim Dp {Hrec}; move/mapsP=> [y Hpy Drfy].
  have Hx0x': cedge x0 ex by rewrite Sedge; apply/connectP; exists p'.
  case/splitPl: {p' Ep}Hpy Dp Hp => [p1 p2 Ep1]; rewrite -cat_adds; move=> Dp Hp.
  rewrite path_cat in Hp; case/andP: Hp => [Hp1 _].
  rewrite Dp maps_cat uniq_cat in Up; case/andP: Up => [Up1 _].
  by exists ex; last by exists p1; [ split | rewrite Ep1 -(eqP Dex) Eedge ].
case; move=> x Hx0x; set fx := face x; set nfx := node fx.
move=> [pe [Hpe Upe] Erpe].
have [pc [Hpc Epc] [Upc _ Hnpc]]:
    exists2 pc, path clink fx pc /\ last fx pc = nfx
         & let xpc := Adds fx pc in
           and3 (uniq xpc) (maps rf xpc =1 maps rf (Adds x pe))
            (forall y, xpc (face y) -> negb (belast fx pc y) -> last x pe = y).
  have Hfpcp: forall y (p : seq g), fpath face y p -> path clink y p.
    move=> y p; elim: p y => [|y' p Hrec] y //=; move/andP=> [Dy Hp].
    by rewrite (Hrec _ Hp) -(eqP Dy) clinkF.
  move: Hpe Upe Erpe {Hx0x}; clearbody nfx; rewrite {}/fx.
  elim: pe x => [|ex p Hrec] x /=.
    do 2 clear; rewrite (rfP x _ (fconnect1 _ _)).
    move/esym; move/(introT (rfP _ _)); case/connectP; move=> pc0.
    case/shortenP=> [pc Hpc Upc _] Epc; exists pc; split; auto=> {pc0 Epc}.
      move=> z; rewrite /setU1 orbF; case (rf (face x) =P z); first done.
      move=> H; apply/mapsP => [] [y Hy Dz]; case: H; rewrite -{z}Dz.
      exact (rfP _ _ (path_connect Hpc (setU1r _ Hy))).
    move=> y; rewrite /setU1 (inj_eqd (Iface g)).
    case: (x =P y) => [Dx|_] // H; case/splitPr: H Hpc {Upc} => [p1 p2].
    rewrite path_cat belast_cat mem_cat /= /setU /setU1.
    rewrite {2}/eqdf (inj_eqd (Iface g)) eqd_sym.
    by case (y =d last (face x) p1); rewrite /= ?orbT ?andbF.
  move/andP=> [Dex Hp]; move/andP=> [Hpx Up] Ep.
  case: {Hrec Hp Up}(Hrec _ Hp Up Ep) => [q2 [Hq2 Eq2] [Uq2 Hrq2 Hfq2]].
  case/connectP: (etrans (Sface _ _ x) (fconnect1 _ _)).
  move=> q0; case/shortenP=> q1 Hq1 Uq1 _ Eq1 {q0}.
  have Hrq1: forall y, Adds (face x) q1 y -> rf y = rf x.
    move=> y Hq1y; symmetry; apply: rfP; rewrite cface1.
    exact (path_connect Hq1 Hq1y).
  exists (cat q1 (Adds (face ex) q2)).
    rewrite path_cat last_cat Eq1 /=; split; last done.
    by rewrite (Hfpcp _ _ Hq1) -(Eedge g x) (eqP Dex) clinkN.
  split.
    rewrite -uniq_adds -cat_adds uniq_cat Uq1 Uq2 andbT.
    apply/hasP => [[y Hq2y Hq1y]]; case/idP: Hpx.
    apply: (etrans (esym (Hrq2 _))); apply/mapsP; exists y; auto.
    move=> y; rewrite maps_cat {1 2}/setU1 mem_cat /setU Hrq2 orbA; congr orb.
    apply/(mapsPx _ (Adds _ _) _)/eqP => [[z Hq1z <-]|<-]; first by symmetry; auto.
    by exists x; first by rewrite -{2}Eq1 mem_last.
  move=> y; rewrite -cat_add_last belast_cat belast_add_last last_add_last.
  rewrite -mem_adds cat_add_last -cat_adds !mem_cat /setU.
  have Hcq1: fcycle face (Adds (face x) q1).
    by rewrite /= -cats1 path_cat Eq1 Hq1 /= /eqdf set11.
  rewrite -!(fconnect_cycle Hcq1 (mem_last _ _)) Eq1 !(Sface g x) -cface1.
  by case Hyx: (cface y x); last by exact (Hfq2 y).
have Hnfx: cedge x nfx by rewrite Sedge -(Eface g x) /nfx fconnect1.
have Hfx: cedge x fx.
  suffice Hnx: (fclosed node (cedge x)) by rewrite (fclosed1 Hnx).
  apply: (intro_closed (Snode g)) => [y1 y2 Dy2 Hy1].
  apply: (connect_trans Hy1).
  move: (negbI (Hx0 y1)); rewrite -(eqP Dy2) /setI (connect_trans Hx0x Hy1).
  by rewrite /= negb_orb negb_elim /cross_edge; case/andP.
have Hpefx: negb (Adds x pe fx).
  move/andP: Upe => [Hpx _]; apply/orP=> [] [Dx|Hpfx].
    by case/andP: (Hx0 x); split; rewrite // {2}(eqP Dx) /fx clinkF.
  by case/mapsP: Hpx; exists fx; last by exact (esym (rfP _ _ (fconnect1 _ _))).
    case: (fx =P nfx) => [Dfx|Hfxn].
    case/andP: (Hx0 nfx); split; first by exact (connect_trans Hx0x Hnfx).
  by rewrite -{2}Dfx /nfx clinkN.
clear x0 Hx0 rf rfP Hx0x Upe Erpe.
have [qe [Hqe Eqe] Hqepe]: exists2 qe, fpath edge fx qe /\ last fx qe = nfx
                                     & negb (Adds fx qe (last x pe)).
  case: (connectP Hnfx); rewrite Sedge in Hnfx.
  move=> q0; case/shortenP=> q Hq Uq _ {q0} Eq.
  have Hqfx: Adds x q fx.
    apply: (etrans (esym _) Hfx); apply: fconnect_cycle; rewrite /= ?setU11 //.
    by rewrite -cats1 path_cat Hq Eq /= /eqdf /nfx /fx Eface set11.
  case/splitPl: {q Hnfx Hfx Hnpc}Hqfx Hq Uq Eq => [q1 qe Eq1].
  rewrite path_cat last_cat Eq1; move/andP=> [Hq1 Hqe] Uq Eqe.
  exists qe; [ by split | simpl; apply/norP; split ].
    by apply/eqP => [Dfx]; rewrite Dfx mem_last in Hpefx.
  move: {nfx npc Hpc Upc Epc Hfxn Eq1 Eqe Hqe}Eq1 Hpefx Hpe => <- {fx}.
  elim: q1 pe x Hq1 Uq => [|y q1 Hrec] pe x /=; first by rewrite setU11.
  move/andP=> [Dy Hq1]; move/andP=> [Hqx Uq]; case/norP.
  case: pe => [|y' pe] _ Hpeq1 /=.
    by rewrite /setU1 mem_cat /setU orbA in Hqx; case/norP: Hqx.
  move/andP=> [Dy' Hpe]; rewrite /eqdf (eqP Dy) in Dy'.
  by rewrite -(eqP Dy') in Hpeq1 Hpe |- *; auto.
suffice [qc [_ Eqc] Hqpc]:
    exists2 qc, path clink nfx qc /\ last nfx qc = fx & negb (has (Adds fx pc) qc).
  case/idP: Hqpc; rewrite has_sym /=.
  case: qc Eqc => [|y qc] Eqc; first by case Hfxn.
  by simpl in Eqc; rewrite -Eqc mem_last.
elim: qe {-5}fx Eqe Hqe Hqepe => [|y' qe Hrec] /=; first by exists (Seq0 g); auto.
move=> y Eqe; move/andP=> [Dy' Hqe]; move/norP=> [_ Hqepe].
case: {Hrec Hqe Eqe}(Hrec _ Eqe Hqe Hqepe) => [qc [Hqc Eqc] Hqcpc].
have Hny := fconnect1 node (face (edge y)); rewrite Snode Eedge in Hny.
case/connectP: Hny => [p Hp Ep]; apply (@proj2 (y <> nfx)).
elim: p {-3}y Hp Ep => [|z' p Hrec] z /=.
  move=> _ Dz; case Hpcz: (Adds fx pc z).
    case/idP: Hqepe; rewrite Dz in Hpcz; rewrite (Hnpc _ Hpcz).
      by rewrite (eqP Dy') setU11.
    apply/idP => [Hey]; case/hasP: Hqcpc.
    exists (edge y); [ move: (mem_last nfx qc) | by apply mem_belast ].
  rewrite Eqc (eqP Dy') /= /setU1; case: (nfx =P y') => [Dnfx|H] //.
    by rewrite lastI Epc Dnfx -(eqP Dy') -cats1 uniq_cat /= Hey andbC in Upc.
  split; first by move=> Dnfx; rewrite Dnfx -Epc mem_last in Hpcz.
  exists (add_last qc z).
    split; last by rewrite last_add_last.
    by rewrite -cats1 path_cat Hqc Eqc -(eqP Dy') Dz /= clinkF.
  by rewrite -cats1 has_cat /= -mem_adds Hpcz orbF.
move/andP=> [Dz' Hp] Ep {Hnpc y' qe Dy' Hqepe qc Hqc Ehqc Eqc Hqcpc}.
case: {y Hrec Hp Ep}(Hrec _ Hp Ep); move=> Hz'nfx [qc0 []].
case/shortenP=> [qc Hqc Uqc Hqc0] Eqc.
case Hpcqc: (has (Adds fx pc) qc).
  case/hasP; case/hasP: Hpcqc => [y Hqcy Hpcy]; exists y; auto.
  clear; case Hpcz: (Adds fx pc z) {qc0 Hqc0}.
  case/and3P: (Hj (Adds fx (cat pc qc))); split.
  - rewrite last_cat Epc Eqc -(eqP Dz') (finv_f (Inode g)) -/nfx -Epc.
    rewrite mem2_cat -orbA; apply/orP; left; simpl in Hpcz; case/orP: Hpcz.
      by move=> Dfx; case Hz'nfx; rewrite /nfx (eqP Dfx) (eqP Dz').
    case: pc Epc {Upc Hpcqc Hpc} => [|fx' pc] *; first by case Hfxn.
   - by rewrite /= mem2_last.
   by rewrite -cat_adds uniq_cat Upc Hpcqc; case/andP: Uqc.
  by rewrite path_cat Hpc Epc.
split; first by move=> Dz; rewrite Dz -Epc mem_last in Hpcz.
exists (add_last qc z).
  split; last by rewrite last_add_last.
  by rewrite -cats1 path_cat Hqc Eqc -(eqP Dz') /= clinkN.
by simpl in Hpcqc; rewrite -cats1 has_cat /= -mem_adds Hpcqc Hpcz.
Qed.

Theorem jordan_planar : forall g, jordan g -> planar g.
Proof.
move=> g Hg; elim: {g}(card g) {-4 5}g Hg (erefl (card g)) => [|n Hrec] g Hg Dn.
  have Hc0: forall a : set g, card a = 0.
    move=> a; apply: eqP; rewrite -leqn0 -Dn; apply max_card.
  by rewrite /planar /genus /genus_rhs /genus_lhs /n_comp Dn !Hc0.
  case Hg0: (set0b g); first by rewrite (eqnP Hg0) in Dn.
case/set0Pn: Hg0 => [x _].
case/set0Pn: (euler_tree Hg x); move=> z; move/andP=> [_ Hz].
rewrite /planar -(@genus_walkupE_eq _ z).
  by apply: (Hrec _ (jordan_walkupE Hg)); rewrite card_walkup Dn.
case/orP: Hz; [ case/clinkP=> Dz; left | by right ].
  by rewrite {2}Dz glinkN.
by rewrite -{2}Dz glinkF.
Qed.

Theorem planarP : forall g, reflect (jordan g) (planarb g).
Proof. move=> g; exact (iffP idP (@planar_jordan g) (@jordan_planar g)). Qed.

End Planarity.

Unset Implicit Arguments.


Require Import List.
Require Cecoa.Syntax Cecoa.Program Cecoa.CBV_cache Cecoa.Ordering Cecoa.QI Cecoa.Final Cecoa.Evaluates.

Module Type SYNTAX.
  Parameters variable function constructor : Type.

  (* Default values, for error cases *)
  Parameter function_default : function.
  Parameter constructor_default : constructor.

  Parameter variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.
  Parameter function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.
  Parameter constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.
End SYNTAX.

Module MkSyn (S: SYNTAX).
  Definition value := Syntax.value S.constructor.
  Definition term := Syntax.term S.variable S.function S.constructor.
  Definition pattern := Syntax.pattern S.variable S.constructor.
  Definition rule := Syntax.rule S.variable S.function S.constructor.

  Definition var : S.variable -> term := @Syntax.var _ _ _.
  Definition capply : S.constructor -> list term -> term := @Syntax.capply _ _ _.
  Definition fapply : S.function -> list term -> term := @Syntax.fapply _ _ _.

  Definition c_capply : S.constructor -> list value -> value := @Syntax.c_capply _.

  Definition value_default : value := c_capply S.constructor_default nil.
  Definition rule_default : rule :=
    Syntax.rule_intro S.function_default nil (capply S.constructor_default nil).

  Definition term_from_value : value -> term :=
    @Syntax.term_from_value S.variable S.function S.constructor.
  Definition term_from_pattern : pattern -> term :=
    @Syntax.term_from_pattern S.variable S.function S.constructor.

  Definition cbv : Type := CBV_cache.cbv S.variable S.function S.constructor.
  Definition cache : Type := list (term * value).
  Definition cbv_constr : list cbv -> cache -> term -> cache -> value -> cbv :=
    @CBV_cache.cbv_constr S.variable S.function S.constructor.
  Definition cbv_split : list cbv -> cbv -> cache -> term -> cache -> value -> cbv :=
    @CBV_cache.cbv_split S.variable S.function S.constructor.
  Definition cbv_update : nat -> (S.variable -> value) -> cbv -> cache -> term -> cache -> value -> cbv :=
    @CBV_cache.cbv_update S.variable S.function S.constructor.
  Definition cbv_read : cache -> term -> value -> cbv :=
    @CBV_cache.cbv_read S.variable S.function S.constructor.

  Definition cbv_size : cbv -> nat := @CBV_cache.size S.variable S.function S.constructor.

  Definition proj_left : cbv -> term :=
    @CBV_cache.proj_left S.variable S.function S.constructor.
  Definition proj_right : cbv -> value :=
    @CBV_cache.proj_right S.variable S.function S.constructor.

  Module Type PROGRAM.
    Parameter prog : list rule.
  End PROGRAM.

  Module MkProg (P: PROGRAM).
    Definition ranklist := Program.ranklist S.variable S.function S.constructor S.function_eq_dec P.prog.
    Definition max_rank : nat := Program.max_rank S.variable S.function S.constructor S.function_eq_dec P.prog.
    Ltac autorank := TopologicalSort.autorank.

    Definition max_arity : nat := Program.max_arity_prog S.variable S.function S.constructor P.prog.
    Definition wf_prog : Prop := Program.wf_prog S.variable S.function S.constructor P.prog.

    Definition cbv_wf : cbv -> Prop :=
      CBV_cache.wf
        S.variable_eq_dec S.function_eq_dec S.constructor_eq_dec
        rule_default P.prog max_arity.

    Definition PPO_prog (rank: S.function -> nat) : Prop := Ordering.PPO_prog P.prog rank.
    Ltac ppo := Ordering.ppo S.variable_eq_dec S.function_eq_dec S.constructor_eq_dec.

    (* QI *)
    Module QI.
      Definition constructor_non_zero := @QI.constructor_non_zero S.constructor.
      Definition mcs_is_max_constructor_size := @QI.mcs_is_max_constructor_size S.constructor.
      Definition additive := @QI.additive S.constructor.
      Definition subterm := @QI.subterm S.function.
      Definition monotonicity_qic := @QI.monotonicity_qic S.constructor.
      Definition monotonicity_qif := @QI.monotonicity_qif S.function.
      Definition cache_bounded :=
        @QI.cache_bounded S.variable S.function S.constructor.
      Definition compatible_QI :=
        @QI.compatible_QI S.variable S.function S.constructor P.prog.
      Definition term_assignment :=
        @QI.term_assignment S.variable S.function S.constructor.
      Definition valid_QI :=
        @QI.valid_QI S.variable S.function S.constructor P.prog.
      Definition global_bound :=
        Final.global_bound S.variable S.function S.constructor P.prog max_arity max_rank.
      Definition P_criterion wf_prog rank :=
        Final.P_criterion S.variable S.function S.constructor P.prog max_arity rule_default wf_prog
                          S.variable_eq_dec S.function_eq_dec S.constructor_eq_dec rank max_rank.
    End QI.

    Module Evaluator.
      Definition first_rule := Evaluates.first_rule S.variable_eq_dec S.function_eq_dec S.constructor_eq_dec value_default P.prog.
      Definition evaluates := Evaluates.evaluates S.variable_eq_dec S.function_eq_dec S.constructor_eq_dec value_default P.prog.
      Ltac reduce := Evaluates.reduce.
      Ltac auto_for_auto lemma :=
        let t' := type of lemma in
        let t := eval unfold evaluates in t' in
            exact t.
      Hint Unfold evaluates : eval.
    End Evaluator.
  End MkProg.

  (* Notations for program definitions *)

  Module ProgramNotations.
    Fixpoint patternify (t: term) : pattern :=
      match t with
      | Syntax.var v         => Syntax.p_var v
      | Syntax.capply cst ys => Syntax.p_capply cst (map patternify ys)
      | _                    => Syntax.p_capply S.constructor_default nil
      end.

    Definition rulify (t e: term) : rule :=
      match t with
        | Syntax.fapply f ys => Syntax.rule_intro f (map patternify ys) e
        | _                  => Syntax.rule_intro S.function_default nil (Syntax.capply S.constructor_default nil)
      end.

    Notation " f '(:' ':)' " := (Syntax.fapply f (@nil term)) (at level 65).
    Notation " f '(:' x ':)' " := (Syntax.fapply f (@cons term x nil)) (at level 65).
    Notation " f '(:' x ',' .. ',' z ':)' " := (Syntax.fapply f (@cons term x .. (@cons term z nil) .. )) (at level 65).
    Notation "fl '-->' e" := (rulify fl e) (at level 70).

    Definition var_coercion_gen : S.variable -> term := @Syntax.var _ _ _.
  End ProgramNotations.
End MkSyn.