(*
 * Copyright (c) 2009-2012, Andrew Appel, Robert Dockins and Aquinas Hobor.
 * This presentation of Permission Algebras and Separation Algebras
 * includes ideas from a discussion with Jonas Jensen and also from
 * a paper by Francois Pottier.
 *)
Require Import msl.Extensionality.

Set Implicit Arguments.

Class Join (t: Type) : Type := join: t -> t -> t -> Prop.

(* "Permission Algebra": commutative semigroup,
   such that if units exist, they must have certain properties. *)
Class Perm_alg (t: Type) {J: Join t} : Type :=
  mkPerm   {
   join_eq: forall {x y z z'}, join x y z -> join x y z' -> z = z';
   join_assoc: forall {a b c d e}, join a b d -> join d c e ->
                    {f : t & join b c f /\ join a f e};
   join_comm: forall {a b c}, join a b c -> join b a c;
   join_positivity: forall {a a' b b'}, join a a' b -> join b b' a -> a=b
}.
Arguments Perm_alg _ [J].

Definition unit_for {t}{J: Join t} (e a: t) := join e a a.
Definition identity {t} {J: Join t} (e: t) := forall a b, join e a b -> a=b.

Hint Extern 2 (@join _ _ _ _ _) =>
   (eapply join_comm; trivial;
     try eassumption;
     (* This next line looks superfluous, but it is not: it catches the
      case where H is join at a function type, where the goal is
      join at an applied function. *)
     match goal with H: @join _ _ _ _ _ |- _ => apply H end).
 (* Hint Immediate @join_comm. *)

Hint Unfold unit_for.

Lemma join_assoc_uniq:
  forall {t} {J: Join t} (PA1 PA2: @Perm_alg t J),
      forall a b c d e H H',
         (projT1 (@join_assoc _ _ PA1  a b c d e H H'))
        = (projT1 (@join_assoc _ _ PA2  a b c d e H H')).
Proof.
  intros.
  destruct (@join_assoc _ _ PA1  a b c d e H H') as [f [? ?]].
  destruct (@join_assoc _ _ PA2  a b c d e H H') as [g [? ?]].
  simpl. apply (join_eq j j1).
Qed.

  (* Sep_alg: additional properties that makes a Permission Algebra
     into a Separation Algebra.  The notion of "core" comes from
    F. Pottier, "Syntactic soundness proof of a type-and-capability
      system with hidden state" *)
  Class Sep_alg A {J: Join A} : Type :=
    mkSep {
      core: A -> A;
      core_unit: forall t, unit_for (core t) t;
      join_core: forall {a b c}, join a b c -> core a = core c
    }.
Arguments Sep_alg _ [J].

Lemma core_duplicable {A}{J: Join A}{SA: Sep_alg A}:
  forall a, join (core a) (core a) (core a).
Proof.
 intros.
 generalize (core_unit a); unfold unit_for; intro.
 generalize (core_unit (core a)); unfold unit_for; intro.
 generalize (join_core H); intro.
 rewrite H1 in H0; auto.
Qed.

Lemma core_self_join {A}{J: Join A}{SA: Sep_alg A}:
  forall a, a = core a -> join a a a.
Proof.
  intros.
  generalize (core_unit a); rewrite <- H; intro. apply H0.
Qed.

Lemma core_idem {A}{J: Join A}{SA: Sep_alg A}:
  forall a, core (core a) = core a.
Proof.
 intros.
 generalize (core_unit a); unfold unit_for; intro.
 apply (join_core H).
Qed.

Lemma core_hom {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall {a b c}, join a b c -> join (core a) (core b) (core c).
Proof.
 intros.
 generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
 rewrite H0; rewrite H1.
 apply core_duplicable.
Qed.

Lemma split_core{A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall a b c, join a b (core c) -> unit_for a a.
Proof.
 intros.
 unfold unit_for.
 generalize (join_core H); rewrite core_idem; intro.
 rewrite <- H0 in H.
 clear dependent c.
 generalize (core_unit a); unfold unit_for; intro.
 generalize (join_positivity H H0); intro.
 rewrite <- H1 in H0; auto.
Qed.

Lemma core_uniq {t} {J: Join t}{PA: Perm_alg t}:
   forall (SA1: @Sep_alg _ J)
          (SA2: @Sep_alg _ J),
     forall x, @core _ _ SA1 x = @core _ _ SA2 x.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
 intros.
 generalize  (@core_unit _ _ SA1 x); unfold unit_for; intro.
 generalize  (@core_unit _ _ SA2 x); unfold unit_for; intro.
 destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
 generalize (@core_unit _ _ SA2 (@core _ _ SA1 x)); unfold unit_for; intro.
 generalize (@core_unit _ _ SA1 (@core _ _ SA2 x)); unfold unit_for; intro.
 destruct (join_assoc ( H4) H2) as [g [? ?]].
 destruct (join_assoc H5 (join_comm H2)) as [h [? ?]].
 generalize (join_eq H6 (join_comm H8)); intro. rewrite <- H10 in *; clear dependent h.
 generalize (@join_core _ _ SA1 _ _ _ H4); intro.
 generalize (@join_core _ _ SA1 _ _ _ H0); intro.
 generalize (@join_core _ _ SA2 _ _ _ H0); intro.
 rewrite H11 in *. rewrite H12 in *. rewrite H10 in *.
 apply join_comm in H4.
 apply (join_eq H4 H5).
Qed.

Lemma join_core2 {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall a b c, join a b c -> core a = core b.
Proof.
intros. generalize H; intro.
apply join_comm in H.
apply join_core in H0; apply join_core in H. congruence.
Qed.

(* Canc_alg: makes a Permission Algebra into a cancellative Perm.Alg. *)
Class Canc_alg (t: Type) {J: Join t} :=
    join_canc: forall {a1 a2 b c}, join a1 b c -> join a2 b c -> a1 = a2.
Arguments Canc_alg _ [J].

Lemma   unit_identity {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A} :
        forall {e} b, unit_for e b -> identity e.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
 unfold unit_for, identity; intros.
 remember (core a) as c.
 generalize (core_unit a); intro.
 rewrite <- Heqc in H2. rename H2 into u.
 unfold unit_for in u.
 destruct (join_assoc (join_comm u) (join_comm H1)) as [f [? ?]].
 generalize (join_canc H1 (join_comm H3)); intro.
 rewrite <- H4 in *; clear f H4 H3.
 destruct (join_assoc H2 H1) as [f [? ?]].
 generalize (join_eq H1 H3); intro.
 rewrite H5 in *; clear b0 H5 H3.
 destruct (join_assoc H2 H0) as [g [? ?]].
 generalize (join_eq H0 H3); intro.
 rewrite <- H6 in *; clear g H6 H3.
 generalize (join_canc H0 H5); intro.
 rewrite <- H3 in *; clear dependent c.
 eapply join_canc. eapply join_comm; apply H1.
 apply join_comm; auto.
Qed.

Lemma core_identity  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
  forall a, identity (core a).
Proof.
  intros. eapply unit_identity. apply core_unit.
Qed.

Lemma join_ex_identity  {A}{J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
     forall a, {e : A & prod (identity e) (unit_for e a) }.
Proof.
 intros.
 exists (core a).
 split.
 apply core_identity.
 apply core_unit.
Qed.

(* Disj_alg: adds the property that no nonempty element can join with itself. *)
Class Disj_alg  (t: Type) {J: Join t} :=
   join_self: forall {a b}, join a a b -> a = b.
Arguments Disj_alg _ [J].

  (* Sing_alg: adds the property that makes the Permission Algebra
     into a single-unit Separation Algebra.  (this is the "traditional"
     kind of Separation Algebra).   *)
Class Sing_alg A {J: Join A}{SA: Sep_alg A} :=
    mkSing {
      the_unit: A;
      the_unit_core: forall a, core a = the_unit
    }.
Arguments Sing_alg _ [J] [SA].
Arguments mkSing [A] [J] [SA] _ _.

  (* Positive Permission Algebra: there are no units, every element is nonempty *)
  Class Pos_alg  {A} {J: Join A} :=
    no_units: forall e a, ~unit_for e a.
Arguments Pos_alg _ [J].

(* Has the "cross-split" property described in Dockins et al,
    "A fresh look at separation algebras and share accounting", 2009 *)
Class Cross_alg (t: Type)  `{J: Join t} :=
   cross_split :
      forall a b c d z : t,
       join a b z ->
       join c d z ->
    { x:(t*t*t*t) &  match x with (ac,ad,bc,bd) =>
         join ac ad a /\ join bc bd b /\ join ac bc c /\ join ad bd d
       end
    }.
Arguments Cross_alg _ [J].

(* Has the "triple join" property  *)
Class Trip_alg {A} {J: Join A} :=
  triple_join_exists:
  forall (a b c ab bc ac : A), join a b ab -> join b c bc -> join a c ac ->
       {abc | join ab c abc}.
Arguments Trip_alg _ [J].

(* We do NOT yet introduce "emp" as a notation or synonym for "identity".
  This is because "emp" is a predicate of Separation Logic, but this file
  contains only Separation Algebras.  Some separation logics have
  predicates that are not just "t -> Prop", and therefore it is premature
  in this file to define "emp".
*)

(** * Lemmas about separation algebras. *)

Lemma  join_ex_units{A}{J: Join A}{SA: Sep_alg A}:
    forall a, {e : A & unit_for e a }.
Proof.
 intros. exists (core a). apply core_unit.
Qed.

Lemma same_identity {A}{J: Join A}{PA: Perm_alg A}:
  forall e e' a, identity e -> unit_for e a -> identity e' -> unit_for e' a -> e = e'.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
 intros.
 unfold unit_for in *.
 destruct (join_assoc (join_comm H1) (join_comm H3)) as [f [? ?]].
 generalize (H0 _ _ H4); intro.
 generalize (H2 _ _ (join_comm H4)); intro.
 rewrite H6; apply H7.
Qed.

Lemma same_unit {A}{J: Join A}{PA: Perm_alg A}{SA:Sep_alg A}{CA: Canc_alg A}:
       forall {e1 e2 a}, unit_for e1 a -> unit_for e2 a -> e1 = e2.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
intros.
generalize (unit_identity _ H0); intro.
unfold unit_for in *.
destruct (join_assoc (join_comm H0) (join_comm H1)) as [f [? ?]].
generalize (H2 _ _ H3); intro.
rewrite <- H5 in *; clear f H5.
apply join_comm in H3.
apply (unit_identity _ H1 _ _ H3).
Qed.

  (** Elements [a] and [b] join. *)
  Definition joins {A} {J: Join A} (a b : A) : Prop :=
    exists c, join a b c.

  Definition overlap {A}{J: Join A} (a b: A) := ~(joins a b).

  Lemma join_joins {A} {J: Join A}: forall {a b c},
    join a b c -> joins a b.
  Proof. intros; econstructor; eauto.
  Qed.

  Lemma join_joins' {A} {J: Join A} {PA: Perm_alg A}: forall {a b c},
    join a b c -> joins b a.
  Proof.
    intros; econstructor. eauto.
  Qed.

  Lemma joins_sym {A}  {J: Join A} {PA: Perm_alg A}: forall a b,
    joins a b <-> joins b a.
  Proof.
    intros.
    split; intro; destruct H;
      exists x; apply join_comm; trivial.
  Qed.

  Lemma joins_sym': forall {A} `{Perm_alg A} {phi1 phi2}, joins phi1 phi2 -> joins phi2 phi1.
  Proof.
   intros.
   apply joins_sym. auto.
  Qed.

  (** Elememt [a] is a subelement of [c] .  This relation forms a partial order. *)
  Definition join_sub {A} `{Join A} (a c : A) : Prop :=
    exists b, join a b c.

  Lemma join_join_sub {A} `{Perm_alg A}: forall {a b c},
    join a b c ->
    join_sub a c.
  Proof.
    intros; econstructor; eauto.
  Qed.

  Lemma join_join_sub' {A} `{Perm_alg A}: forall {a b c},
    join a b c ->
    join_sub b c.
  Proof.
    intros; econstructor; eauto.
  Qed.

  Lemma join_sub_refl {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a,
    join_sub a a.
  Proof.
    intros.
    exists (core a). apply join_comm.
    apply core_unit.
  Qed.

  Hint Resolve @join_sub_refl.

  Lemma join_sub_trans {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall a b c,
    join_sub a b ->
    join_sub b c ->
    join_sub a c.
  Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
    intros. destruct H0; destruct H1.
    destruct (join_assoc H0 H1) as [f [? ?]].
    econstructor; eauto.
  Qed.

Lemma join_sub_same_identity {A} {J: Join A}{PA: Perm_alg A}:
   forall e e' a c,  identity e -> unit_for e a -> identity e' -> unit_for e' c ->
                  join_sub a c -> e = e'.
Proof.
 pose proof I. (* hack: shift up auto-named hyps *)
  intros.
  destruct H4.
  unfold unit_for in *.
  destruct (join_assoc (join_comm H1) H4) as [f [? ?]].
   generalize (H0 _ _ H5); intro.
   rewrite <- H7 in *; clear dependent f.
   destruct (join_assoc H5 (join_comm H6)) as [g [? ?]].
   generalize (join_eq H4 (join_comm H7)); intro.
   rewrite <- H9 in *; clear dependent g.
   apply same_identity with c; auto.
Qed.

  Lemma join_sub_joins {A} `{HA: Perm_alg A}: forall {a b},
    join_sub a b -> joins a b -> joins a a.
  Proof.
    intros a b [? ?] [? ?].
    apply join_comm in H0.
    destruct (join_assoc H H0) as [? [? ?]].
    destruct (join_assoc H1 (join_comm H2)) as [? [? ?]].
    econstructor; eauto.
  Qed.
  (* Note: there are two other conceivable conclusions from the above
     premises: "joins b b" and "join_sub b a".  Neither must follow, since
     neither is true on the bools, but also neither is a contradiction
     since both are true on Z *)

  Lemma join_sub_joins_trans {A} `{HA: Perm_alg A}: forall {a b c},
    join_sub a c -> joins c b -> joins a b.
  Proof.
    intros.
    destruct H as [wx ?].
    destruct H0 as [wy ?].
    destruct (join_assoc (join_comm H) H0) as [wf [? ?]].
    econstructor; eauto.
  Qed.

  Lemma join_sub_joins'  {A} `{HA: Perm_alg A}:
    forall {a a' b b' : A},
      join_sub a a' -> join_sub b b' -> joins a' b' -> joins a b.
  Proof.
    intros.
    destruct H; destruct H0; destruct H1.
    destruct (join_assoc (join_comm H) H1) as [f [? ?]].
    destruct (join_assoc (join_comm H0) (join_comm H2)) as [g [? ?]].
    exists g; apply join_comm; auto.
  Qed.

  Definition sub_silhouette {A} `{Perm_alg A} (a b: A) : Prop :=
    forall c, joins c b -> joins c a.

  Definition same_silhouette {A} `{Perm_alg A} (a b: A) : Prop :=
    forall c, joins c a <-> joins c b.

  Lemma sub_silhouette_refl {A} `{Perm_alg A}: forall a, sub_silhouette a a.
  Proof. unfold sub_silhouette; intuition. Qed.

  Lemma sub_silhouette_trans {A} `{Perm_alg A}: forall a b c,
    sub_silhouette a b -> sub_silhouette b c -> sub_silhouette a c.
  Proof. unfold sub_silhouette; intuition. Qed.

  Lemma same_silhouette_refl {A} `{Perm_alg A}: forall a, same_silhouette a a.
  Proof. unfold same_silhouette; intuition. Qed.

  Lemma same_silhouette_sym {A} `{Perm_alg A}: forall a b,
    same_silhouette a b -> same_silhouette b a.
  Proof.  unfold same_silhouette; intros; split; apply H0; auto.
  Qed.

  Lemma same_silhouette_trans {A} `{Perm_alg A}: forall a b c,
    same_silhouette a b -> same_silhouette b c -> same_silhouette a c.
 Proof. unfold same_silhouette; intros; split; intros;
             destruct (H0 c0); destruct (H1 c0);   auto. Qed.

  Lemma same_silhouette_sub1{A} `{Perm_alg A}: forall a b,
    same_silhouette a b -> sub_silhouette a b.
  Proof. unfold same_silhouette, sub_silhouette; intros; intuition; destruct (H0 c); auto. Qed.

  Lemma same_silhouette_sub2 {A} `{Perm_alg A}: forall a b,
     same_silhouette a b -> sub_silhouette b a.
  Proof. unfold same_silhouette, sub_silhouette; intros; intuition; destruct (H0 c); auto. Qed.

  Lemma sub_same_silhouette {A} `{Perm_alg A}:
    forall a b, sub_silhouette a b -> sub_silhouette b a -> same_silhouette a b.
  Proof. unfold same_silhouette, sub_silhouette; intuition; destruct (H0 c); auto. Qed.

  Lemma same_silhouette_join {A} `{HA: Perm_alg A}:
    forall phi phi' phiy phiz phiz',
      same_silhouette phi phi' ->
      join phi phiy phiz ->
      join phi' phiy phiz' ->
      same_silhouette phiz phiz'.
  Proof.
    intros.
    intro phiu.
    split; intros [phix ?].
    destruct (join_assoc H0 (join_comm H2)) as [phif [? ?]].
    specialize (H phif).
    destruct H.
    assert (exists phiz, join phi phif phiz) by eauto.
    assert (joins phif phi) by (apply joins_sym;  auto).
    specialize (H H7).
    clear H5 H6 H7.
    destruct H as [phix' ?].
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
    generalize (join_eq H1 (join_comm H5)); intro.
    rewrite <- H7 in *. clear phig H7 H5.
    exists phix'.
    auto.
    destruct (join_assoc H1 (join_comm H2)) as [phif [? ?]].
    specialize (H phif).
    destruct H.
    assert (exists phiz, join phi' phif phiz) by eauto.
    assert (joins phif phi') by (apply joins_sym;  auto).
    specialize (H5 H7).
    clear H H6 H7.
    destruct H5 as [phix' ?].
    destruct (join_assoc (join_comm H3) H) as [phig [? ?]].
    generalize (join_eq H0 (join_comm H5)); intro.
    rewrite <- H7 in *; clear phig H7 H5.
    exists phix'.
    auto.
  Qed.

Hint Resolve @join_joins @join_joins' @join_join_sub @join_join_sub'.

  Definition nonidentity {A} `{Perm_alg A} (a: A) := ~(identity a).

  (** If [a] is a subelement of [b], their units are equal. *)
  Lemma join_sub_units_eq {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A} :
   forall {a b} ea eb,
    join_sub a b ->
    unit_for ea a ->
    unit_for eb b ->
    ea = eb.
  Proof.
    unfold unit_for.
    intros.
    destruct H.
    destruct (join_assoc H0 H) as [f [? ?]].
    generalize (join_eq H H2); intro.
    rewrite <- H4 in *; clear f H4 H2.
    eapply same_unit; eauto.
  Qed.

  Lemma unit_core{A} {JA: Join A}{SA: Sep_alg A}{CA: Canc_alg A}:
      forall {a}, unit_for a a -> a = (core a).
  Proof.
   unfold unit_for; intros.
   generalize (core_unit a); intro.
   unfold unit_for in H0.
   apply (join_canc H H0).
  Qed.

  (** A unit for an element is a unit for itself (is idempotent). *)
  Lemma unit_self_unit {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A} :
   forall a ea,   unit_for ea a ->  unit_for ea ea.
  Proof.
    intros.
    unfold unit_for in *.
    destruct (join_assoc (join_comm H) (join_comm H)) as [f [? _]].
    generalize (unit_identity _ H); intro.
    generalize (H1 _ _ H0); intro.
   rewrite <- H2 in H0; clear f H2.
   auto.
  Qed.

  (** If a joins with b, then their units are equal. *)
  Lemma joins_units_eq {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
   forall {a b} ea eb,
    joins a b ->
    unit_for ea a ->
    unit_for eb b ->
    ea  = eb.
  Proof.
    intros.
    destruct H.
    unfold unit_for in *.
    destruct (join_assoc (join_comm H0) H) as [f [? ?]].
    generalize (unit_identity _ H0 _ _ H2); intro.
    rewrite <- H4 in *; clear f H4.
    eapply same_unit; eauto.
  Qed.

  (** The existence of identity elements. *)
  Lemma join_ex_identities {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall a,
    {e : A & identity e /\ joins e a}.
  Proof.
    intro x.
    destruct (join_ex_identity x) as [e [? ?]].
   exists e; split; auto.
   exists x; auto.
  Qed.

  (** If something is an identity and it joins with an element then it is a
     unit for that element. *)
  Lemma identity_unit {A} `{HA: Perm_alg A}: forall e a,
    identity e ->
    joins e a ->
    unit_for e a.
  Proof.
    intros. destruct H0.
    generalize (H a x H0); intro.
    rewrite <- H1 in *; clear x H1.
    trivial.
  Qed.

  (** Identities are exactly units for themselves (are idempotent).*)
  Lemma identity_unit_equiv {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
    forall a,  identity a <-> unit_for a a.
  Proof.
    intros.
    split; intro.
    apply identity_unit; trivial.
    exists a.
    destruct (join_ex_units a) as [ea H0].
    generalize (join_comm H0); intro.
    generalize (H ea a H1); intro.
    rewrite <- H2 in *; clear a H2.
    trivial.
    apply (unit_identity _ H).
  Qed.

  (** Joinable identities are unique. *)
  Lemma identities_unique {A} `{HA: Perm_alg A} :
   forall e1 e2,  identity e1 ->  identity e2 ->  joins e1 e2 ->  e1 = e2.
  Proof.
    intros.
    destruct H1.
    assert (e2 = x) by auto.
    apply join_comm in H1.
    assert (e1 = x) by auto.
    rewrite H3; rewrite H2; reflexivity.
  Qed.

Lemma split_identity{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
 forall a b c, join a b c -> identity c -> identity a.
Proof.
 intros.
 apply identity_unit_equiv.
 apply (split_core a b c).
 generalize (core_hom H); intro.
 generalize (join_core H); intro.
  generalize (split_core _ _ _ H1); unfold unit_for; intro.
  apply identity_unit_equiv in H0.
  generalize (core_unit c); unfold unit_for; intro.
  generalize (join_canc H0 H4); intro.
  rewrite <- H5; auto.
Qed.

  (* The contrapositive of split_identity *)
  Lemma join_nonidentity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall a b c,
    nonidentity a -> join a b c -> nonidentity c.
  Proof.
    intros a b c H H0 H1.
    contradiction H.
    apply split_identity with b c; auto.
  Qed.

  Lemma join_sub_antisym {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall x y,
    join_sub x y ->
    join_sub y x ->
    x = y.
  Proof.
    intros ? ? [? ?] [? ?].
    destruct (join_assoc H H0). destruct a.
    apply join_comm in H2.
    generalize(unit_identity _ H2); intro.
    generalize(split_identity _ _ H1 H3); intro.
    apply join_comm in H.
    auto.
  Qed.

  (** This lemma uses the full power of self_join and eliminates both N and Z. *)
  Lemma join_sub_joins_identity {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DS: Disj_alg A}: forall a b,
    join_sub a b -> joins a b -> identity a.
  Proof.
    intros.
    apply identity_unit_equiv.
    generalize (join_sub_joins H H0); intro.
    destruct H1.
    generalize (join_self H1); intro.
    rewrite <- H2 in *; clear x H2.
    trivial.
  Qed.

  (** Sometimes it is useful to use a negative form of the previous lemma *)
  Lemma join_overlap {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DS: Disj_alg A}: forall a b,
    join_sub a b -> nonidentity a -> overlap a b.
  Proof.
    repeat intro.
    apply H0.
    eapply join_sub_joins_identity; eauto.
  Qed.

(** The opposite of identity is maximal or full *)

Definition full {A} {JA: Join A}(sigma : A) : Prop :=
   forall sigma', joins sigma sigma' -> identity sigma'.

Definition maximal {A} {JA: Join A} (sigma : A) : Prop :=
  forall sigma', join_sub sigma sigma' -> sigma = sigma'.

Lemma full_maximal {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A} :
       forall a, full a <-> maximal a.
Proof with auto.
 pose proof I. (* hack: shift up auto-named hyps *)
  split; intro.
  intros a'' ?.
  destruct H1 as [a' ?].
  specialize (H0 a').
  apply H0. eauto. apply join_comm...
  intros a' ?.
  destruct H1 as [a'' ?].
  rewrite <- (H0 a'') in *; eauto; clear a'' H0.
  eapply unit_identity; eauto.
Qed.

(** The elements of a multi-unit separation algebra can be partitioned
    into equivalance classes, where two elements are in the class iff
    they have the same unit.
  *)

  Definition comparable {A} `{Sep_alg A}  (a b:A)
    := core a = core b.

  Lemma comparable_refl {A} `{Sep_alg A} : forall a, comparable a a.
  Proof. intros; red; auto. Qed.

  Lemma comparable_sym {A} `{Sep_alg A}: forall a b, comparable a b -> comparable b a.
  Proof. unfold comparable; intros; symmetry; auto. Qed.

  Lemma comparable_trans {A} `{Sep_alg A}: forall a b c, comparable a b -> comparable b c -> comparable a c.
  Proof. unfold comparable; intros; etransitivity; eauto. Qed.

  Lemma comparable_common_unit {A} `{Sep_alg A}: forall a b,
    comparable a b ->
    exists e, join e a a /\ join e b b.
  Proof.
    intros.
    red in H0.
    exists (core a); split.
    apply core_unit.
    rewrite H0; apply core_unit.
  Qed.

  Lemma common_unit_comparable {A} `{Sep_alg A} : forall a b,
    (exists e, join e a a /\ join e b b) ->
    comparable a b.
  Proof.
    intros.
    destruct H0 as [e [H1 H2]].
    unfold comparable.
    rewrite <- (join_core H1).  apply (join_core H2).
Qed.

Lemma join_comparable  {A} `{Sep_alg A}:
  forall phi1 phi2 phi3, join phi1 phi2 phi3 -> comparable phi1 phi3.
Proof.
  intros.
  unfold comparable.
  eapply join_core; eauto.
Qed.

Lemma join_comparable2  {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall phi1 phi2 phi3, join phi1 phi2 phi3 -> comparable phi1 phi2.
Proof.
  intros.
  unfold comparable.
  generalize (join_core H); intro.
  generalize (join_core (join_comm H)); intro.
  rewrite H0; rewrite H1; reflexivity.
Qed.

Lemma join_sub_comparable  {A} `{Sep_alg A} : forall a c,
  join_sub a c -> comparable a c.
Proof.
  intros.
  destruct H0.
  eapply join_comparable; eauto.
Qed.

Lemma joins_comparable  {A} {J: Join A}{PA: Perm_alg A}{SA: Sep_alg A} : forall a c,
  joins a c -> comparable a c.
Proof.
  intros a c H0.
  destruct H0.
  eapply join_comparable2; eauto.
Qed.

Lemma join_unit1 {A} `{Perm_alg A}:
  forall x y z, unit_for x z -> y = z -> join x y z.
Proof.
intros. rewrite H1 in *; auto.
Qed.

Lemma join_unit2 {A} `{Perm_alg A}:
  forall x y z, unit_for y z -> x = z -> join x y z.
Proof.
intros. rewrite  H1 in *;  clear x H1. apply join_comm; auto.
Qed.

Lemma join_unit1_e {A} `{Perm_alg A}:
  forall x y z, identity x -> join x y z -> y = z.
Proof.
intros.
eapply join_eq; eauto.
apply identity_unit; eauto.
Qed.

Lemma join_unit2_e {A} `{Perm_alg A}:
  forall x y z, identity y -> join x y z -> x = z.
Proof.
intros.
apply join_comm in H1.
eapply join_unit1_e; eauto.
Qed.

Lemma PermAlg_ext:
  forall (T: Type) (J: @Join T) (sa1 sa2: @Perm_alg T J), sa1=sa2.
Proof. intros.
destruct sa1, sa2.
f_equal; try apply proof_irr.
extensionality a b c d e H1 H2.
destruct (join_assoc1 a b c d e H1 H2) as [f [? ?]].
destruct (join_assoc0 a b c d e H1 H2) as [f0 [? ?]].
apply existT_ext.
eapply join_eq0; eauto.
Qed.

Lemma Sep_alg_ext {T} {J} {PA: @Perm_alg _ J}:
   forall (sa1 sa2: @Sep_alg T J), sa1=sa2.
Proof.
intros.
generalize (@core_uniq _ J _ sa1 sa2); intro.
destruct sa1; destruct sa2.
simpl in H.
assert (core0 = core1).
  extensionality; auto.
subst core1.
f_equal.
apply proof_irr.
apply proof_irr.
Qed.

Definition nonunit {A} `{Join A}  (a: A) := forall x, ~ unit_for a x.

Lemma nonidentity_nonunit {A} {JA: Join A} {PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
  forall {a}, nonidentity a -> nonunit a.
Proof.
 intros. intros ? H0; apply H. eapply unit_identity; apply H0.
Qed.

Lemma nonunit_nonidentity {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
  forall x, nonunit x -> ~identity x.
Proof. intros. intro.
  apply identity_unit_equiv in H0. apply (H _ H0).
Qed.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Data.Bool.
Require Import ExtLib.Data.String.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.syms.SymEnv.
Require Import MirrorCore.syms.SymSum.
Require Import MirrorCore.Lambda.Expr.

Require Import Charge.Logics.ILogic.
Require Import Charge.ModularFunc.BaseType.
Require Import Charge.ModularFunc.SemiEqDecTyp.
Require Import Charge.ModularFunc.Denotation.

Require Import Coq.Strings.String.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

Inductive base_func typ {RType_typ : RType typ} :=
  | pConst t : typD t -> base_func
  | pEq : typ -> base_func
  | pPair : typ -> typ -> base_func.

Implicit Arguments base_func [[RType_typ]].

Class BaseFunc (typ func : Type) {RType_typ : RType typ} := {
  fConst t : typD t -> func;

  fEq : typ -> func;
  fPair : typ -> typ -> func;

  baseS : func -> option (base_func typ)
}.

Implicit Arguments BaseFunc [[RType_typ]].

Section BaseFuncSum.
	Context {typ func : Type} {RType_typ : RType typ} {H : BaseFunc typ func}.

	Global Instance BaseFuncSumL (A : Type) :
		BaseFunc typ (func + A) := {
		  fConst t e := inl (fConst t e)

        ; fEq t := inl (fEq t)
        ; fPair t1 t2 := inl (fPair t1 t2)
        ; baseS f := match f with
        			   | inl a => baseS a
        			   | inr _ => None
        			 end
        }.

	Global Instance BaseFuncSumR (A : Type) :
		BaseFunc typ (A + func) := {
		  fConst t e := inr (fConst t e)
        ; fEq t := inr (fEq t)
        ; fPair t1 t2 := inr (fPair t1 t2)
        ; baseS f := match f with
        			   | inr a => baseS a
        			   | inl _ => None
        			 end
        }.

    Global Instance BaseFuncExpr :
    	BaseFunc typ (expr typ func) := {
		  fConst t e := Inj (fConst t e);
    	  fEq t := Inj (fEq t);
    	  fPair t1 t2 := Inj (fPair t1 t2);
    	  baseS f := match f with
    	  			   | Inj f => baseS f
    	  			   | _     => None
    	  			 end
    }.

End BaseFuncSum.

Section BaseFuncInst.
  Context {typ : Type} {HR : RType typ}
          {BT : BaseType typ} {HTD : BaseTypeD BT}.
  Context {func : Type} {H : BaseFunc typ func}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

  Context {Hseq : SemiEqDecTyp typ}.
  Context {HseqOk : SemiEqDecTypOk Hseq}.

  Context {Typ2_tyArr : Typ2 _ Fun}.
  Context {Typ0_tyProp : Typ0 _ Prop}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyProp : typ := @typ0 _ _ _ _.

  Global Instance BaseFuncInst : BaseFunc typ (base_func typ) := {
	fConst t e := pConst t e;
	fEq := pEq;
	fPair := pPair;
	baseS f := Some f
  }.

  Definition typeof_base_func bf :=
    match bf with
      | pConst t _ => Some t
      | pEq t => Some (tyArr t (tyArr t tyProp))
      | pPair t1 t2 => Some (tyArr t1 (tyArr t2 (tyProd t1 t2)))
    end.

  Definition rel_dec_cases {T A : Type} {RelDec_T : RelDec (@eq T)} {HROk : RelDec_Correct RelDec_T} (x y : T)
    (f_true : x = y -> A) (f_false : x <> y -> A) : A :=
  match Reflect_RelDecCorrect T eq RelDec_T HROk x y with
	| reflect_true H => (fun eq : x = y => f_true eq) H
	| reflect_false H => (fun neq : x <> y => f_false neq) H
  end.

  Implicit Arguments rel_dec_cases [[T] [A] [RelDec_T] [HROk]].

	  Definition base_func_eq (a b : base_func typ) : option bool :=
	  match a , b with
		| pConst t1 e1, pConst t2 e2 =>
		  rel_dec_cases t1 t2
		    (fun pf => semi_eq_dec_typ e1 (@eq_rect_r _ _ typD e2 _ pf))
		    (fun _ => None)
	    | pEq t1, pEq t2 => Some (t1 ?[ eq ] t2)
	    | pPair t1 t2, pPair t3 t4 => Some (t1 ?[ eq ] t3 &&
	      								    t2 ?[ eq ] t4)%bool
	    | _, _ => None
	  end.

	Definition PropD (P : typD tyProp) : Prop :=
	  trmD P (typ0_cast (Typ0 := Typ0_tyProp)).

	Definition PropR (P : Prop) : typD tyProp :=
	  trmR P (typ0_cast (Typ0 := Typ0_tyProp)).

	 Definition eqD (t : typ) : typD (tyArr t (tyArr t tyProp)) :=
	   (tyArrR2 (fun a b => PropR (@eq (typD t) a b))).

	 Definition pairD (t u : typ) : typD (tyArr t (tyArr u (tyProd t u))) :=
	   (tyArrR2 (fun a b => prodR t u (a, b))).

	 Definition base_func_symD bf :=
		match bf as bf return match typeof_base_func bf with
								| Some t => typD t
								| None => unit
							  end with
        | pConst _ c => c
	    | pEq t => eqD t
        | pPair t u => pairD t u
	end.

	Global Instance RSym_BaseFunc : SymI.RSym (base_func typ) := {
	  typeof_sym := typeof_base_func;
	  symD := base_func_symD;
	  sym_eqb := base_func_eq
	}.

	Global Instance RSymOk_BaseFunc : SymI.RSymOk RSym_BaseFunc.
	Proof.
		split; intros.
		destruct a, b; simpl; try apply I.
		+ unfold rel_dec_cases.
		  forward; inv_all; subst.
		  unfold eq_rect_r, eq_rect, eq_sym in H1.
		  pose proof (semi_eq_dec_typOk t1 t0 t2) as H2.
		  rewrite H1 in H2.
		  destruct b; [try intuition congruence|].
		  intros H3; apply H2; inversion H3.
		  apply Structures.EqDep.inj_pair2 in H5. apply H5.
		+ consider (t ?[ eq ] t0); intuition congruence.
		+ consider (t ?[ eq ] t1 && t0 ?[ eq ] t2)%bool;
		  intuition congruence.
	Qed.

End BaseFuncInst.

Section MakeBase.
	Context {typ func : Type} {RType_typ : RType typ}.
	Context {HT : BaseType typ} {HF : BaseFunc typ func}.

	Definition mkConst t e : expr typ func := Inj (fConst t e).

	Definition mkNat (n : typD tyNat) : expr typ func := mkConst tyNat n.
	Definition mkBool (b : typD tyBool) : expr typ func := mkConst tyBool b.
	Definition mkString (s : typD tyString) : expr typ func := mkConst tyString s.
	Definition mkEq (t : typ) (a b : expr typ func) := App (App (fEq t) a) b.
	Definition mkPair t u a b := App (App (fPair t u) a) b.

End MakeBase.

Section BaseFuncOk.
  Context {typ func : Type} {RType_typ : RType typ}.
  Context {BF: BaseFunc typ func} {RSym_func : RSym func}.
  Context {RelDec_eq : RelDec (@eq typ)}.
  Context {RelDec_eqOk : RelDec_Correct RelDec_eq}.
  Context {BT : BaseType typ} {BTD : BaseTypeD BT}.
  Context {Heqd : SemiEqDecTyp typ}.

  Context {Typ2_tyArr : Typ2 _ Fun}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  Class BaseFuncOk := {
    bf_funcAsOk (f : func) (e : @base_func typ RType_typ) : baseS f = Some e ->
      forall t,
        funcAs f t =
        funcAs (RSym_func := RSym_BaseFunc) e t;
	bf_fConstOk t e : baseS (fConst t e) = Some (pConst t e);
    bf_fEqOk t : baseS (fEq t) = Some (pEq t);
    bf_fPairOk t u : baseS (fPair t u) = Some (pPair t u)
  }.

End BaseFuncOk.

Implicit Arguments BaseFuncOk [[BF] [RType_typ] [RSym_func] [RelDec_eq] [BT] [BTD]
                               [Typ2_tyArr] [Typ0_Prop] [RelDec_eqOk] [Heqd]].

Section BaseFuncBaseOk.
  Context {typ func : Type} {RType_typ : RType typ}.
  Context {BF: BaseFunc typ func} {RSym_func : RSym func}.
  Context {RelDec_eq : RelDec (@eq typ)}.
  Context {RelDec_eqOk : RelDec_Correct RelDec_eq}.
  Context {Heqd : SemiEqDecTyp typ}.
  Context {BT : BaseType typ}.
  Context {BTD : BaseTypeD BT}.

  Context {Typ2_tyArr : Typ2 _ Fun}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Global Program Instance BaseFuncBaseOk :
  	BaseFuncOk typ (RSym_func := RSym_BaseFunc) (base_func typ) := {
    bf_funcAsOk := fun _ _ _ _ => eq_refl;
    bf_fConstOk t e := eq_refl;
    bf_fEqOk t := eq_refl;
    bf_fPairOk t u := eq_refl
  }.

End BaseFuncBaseOk.

Section BaseFuncExprOk.
  Context {typ func : Type} `{HOK : BaseFuncOk typ func}.
  Context {HROk : RTypeOk}.
  Context {A : Type} {RSymA : RSym A}.

  Context {Typ2_tyArrOk : Typ2Ok Typ2_tyArr}
          {RSym_funcOk : RSymOk RSym_func0}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyProp : typ := @typ0 _ _ _ _.

  Lemma BaseFunc_typeOk (f : func) (e : base_func typ) (H : baseS f = Some e) :
    typeof_sym f = typeof_base_func e.
  Proof.
    destruct HOK as [H1 H2 _ _ _ _ _ _ _].
    specialize (H1 _ _ H).
    destruct e; simpl in *;
    match goal with
      | |- typeof_sym ?f = Some ?t =>
	 	specialize (H1 t);
	 	simpl in H1;
	 	unfold funcAs in H1; simpl in H1 ; rewrite type_cast_refl in H1; [|apply _];
	    generalize dependent (symD f);
	 	destruct (typeof_sym f); simpl; intros; [forward|]; inversion H1
 	end.
  Qed.

  Lemma bf_typeof_const (t : typ) (c : typD t) : typeof_sym (fConst t c) = Some t.
  Proof.
    pose proof (BaseFunc_typeOk _ (bf_fConstOk t c)).
    rewrite H. reflexivity.
  Qed.

  Lemma bf_const_func_type_eq (f : func) t e t' df
    (H1 : baseS f = Some (pConst t e)) (H2 : funcAs f t' = Some df) :
    t = t'.
  Proof.
    rewrite (bf_funcAsOk _ H1) in H2.
    unfold funcAs in H2; simpl in *.
    forward.
  Qed.

  Lemma bf_const_type_eq (e : expr typ func) t c t' tus tvs de
    (H1 : baseS e = Some (pConst t c)) (H2 : exprD' tus tvs t' e = Some de) :
    t = t'.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst.
   apply (bf_const_func_type_eq _ _ H1 H).
  Qed.

  Lemma bf_eq_func_type_eq (f : func) t u df
    (H1 : baseS f = Some (pEq t)) (H2 : funcAs f u = Some df) :
    u = tyArr t (tyArr t tyProp).
  Proof.
    rewrite (bf_funcAsOk _ H1) in H2.
    unfold funcAs in H2; simpl in *.
    forward.
    rewrite <- r; reflexivity.
  Qed.

  Lemma bf_eq_type_eq tus tvs (e : expr typ func) t u de
    (H1 : baseS e = Some (pEq t)) (H2 : exprD' tus tvs u e = Some de) :
    u = tyArr t (tyArr t tyProp).
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst.
   apply (bf_eq_func_type_eq _ _ H1 H).
  Qed.

  Lemma bf_pair_func_type_eq (f : func) t u v df
    (H1 : baseS f = Some (pPair t u)) (H2 : funcAs f v = Some df) :
    v = tyArr t (tyArr u (tyProd t u)).
  Proof.
    rewrite (bf_funcAsOk _ H1) in H2.
    unfold funcAs in H2; simpl in *.
    forward.
    rewrite <- r; reflexivity.
  Qed.

  Lemma bf_pair_type_eq tus tvs (e : expr typ func) t u v df
    (H1 : baseS e = Some (pPair t u)) (H2 : exprD' tus tvs v e = Some df) :
    v = tyArr t (tyArr u (tyProd t u)).
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in H2; simpl in H2; forward; inv_all; subst.
   apply (bf_pair_func_type_eq _ _ H1 H).
  Qed.

  Existing Instance RSym_sum.

  Global Program Instance BaseFuncOkSumR : BaseFuncOk typ ((A + func)%type) := {
    bf_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    bf_fConstOk t e := bf_fConstOk (func := func) t e;
    bf_fEqOk t := bf_fEqOk (func := func) t;
    bf_fPairOk t u := bf_fPairOk (func := func) t u
  }.
  Next Obligation.
    apply (bf_funcAsOk (func := func)).
    apply H.
  Qed.

  Global Program Instance BaseFuncOkSumL : BaseFuncOk typ ((func + A)%type) := {
    bf_funcAsOk :=
      fun a f H t =>
        match a with
          | inl b => _
          | inr b => _
        end;
    bf_fConstOk t e := bf_fConstOk (func := func) t e;
    bf_fEqOk t := bf_fEqOk (func := func) t;
    bf_fPairOk t u := bf_fPairOk (func := func) t u
  }.
  Next Obligation.
    apply (bf_funcAsOk (func := func)).
    apply H.
  Qed.

End BaseFuncExprOk.

Section TypeOfFunc.
  Context {typ func : Type}.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {RSym_func : RSym func}.

  Lemma typeof_funcAs f t e (H : funcAs f t = Some e) : typeof_sym f = Some t.
  Proof.
    unfold funcAs in H.
    generalize dependent (symD f).
    destruct (typeof_sym f); intros; [|congruence].
    destruct (type_cast t0 t); [|congruence].
    destruct r; reflexivity.
  Qed.

  Lemma funcAs_Some f t (pf : typeof_sym f = Some t) :
    funcAs f t =
    Some (match pf in (_ = z)
      return match z with
               | Some z' => typD z'
               | None => unit
             end
      with
      | eq_refl => symD f
      end).
  Proof.
    unfold funcAs.
    generalize (symD f).
    rewrite pf. intros.
    rewrite type_cast_refl. reflexivity. apply _.
  Qed.

End TypeOfFunc.

Section MakeBaseFuncSound.
  Context {typ func : Type} `{HOK : BaseFuncOk typ func}.
  Context {HeqdOk : SemiEqDecTypOk Heqd}.
  Context {HROk : RTypeOk} {Typ2_tyArrOk : Typ2Ok Typ2_tyArr}
          {RSym_funcOk : RSymOk RSym_func0}.

  Let tyProp : typ := @typ0 _ _ _ _.
  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.

  Lemma bf_const_func_eq (t : typ) (c : typD t) (f : func) (fD : typD t)
    (Ho : baseS f = Some (pConst t c))
    (Hf : funcAs f t = Some fD) :
    fD = c.
  Proof.
   rewrite (bf_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [|apply HROk].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma bf_const_eq (t : typ) (c : typD t) (e : expr typ func) tus tvs
    (eD : ExprI.exprT tus tvs (typD t))
    (Ho : baseS e = Some (pConst t c))
    (Hf : exprD' tus tvs t e = Some eD) :
    eD = fun us vs => c.
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   rewrite (bf_const_func_eq _ Ho H); reflexivity.
  Qed.

  Lemma bf_eq_func_eq (t : typ) (f : func) (fD : typD (tyArr t (tyArr t tyProp)))
    (Ho : baseS f = Some (pEq t))
    (Hf : funcAs f (tyArr t (tyArr t tyProp)) = Some fD) :
    fD = eqD t.
  Proof.
   rewrite (bf_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [|apply HROk].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma bf_eq_eq tus tvs (t : typ) (e : expr typ func)
    (eD : ExprI.exprT tus tvs (typD (tyArr t (tyArr t tyProp))))
    (Ho : baseS e = Some (pEq t))
    (Hf : exprD' tus tvs (tyArr t (tyArr t tyProp)) e = Some eD) :
    eD = (fun us vs => eqD t).
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   rewrite (bf_eq_func_eq _ Ho H); reflexivity.
  Qed.

  Lemma bf_pair_func_eq (t u : typ) (f : func) (fD : typD (tyArr t (tyArr u (tyProd t u))))
    (Ho : baseS f = Some (pPair t u))
    (Hf : funcAs f (tyArr t (tyArr u (tyProd t u))) = Some fD) :
    fD = pairD t u.
  Proof.
   rewrite (bf_funcAsOk _ Ho) in Hf.
   unfold funcAs in Hf; simpl in *.
   rewrite type_cast_refl in Hf; [|apply HROk].
   unfold Rcast, Relim_refl in Hf.
   inversion Hf. reflexivity.
  Qed.

  Lemma bf_pair_eq tus tvs (t u : typ) (e : expr typ func)
    (eD : ExprI.exprT tus tvs (typD (tyArr t (tyArr u (tyProd t u)))))
    (Ho : baseS e = Some (pPair t u))
    (Hf : exprD' tus tvs (tyArr t (tyArr u (tyProd t u))) e = Some eD) :
    eD = (fun us vs => pairD t u).
  Proof.
   destruct e; simpl in *; try congruence.
   autorewrite with exprD_rw in Hf; simpl in Hf; forward; inv_all; subst.
   rewrite (bf_pair_func_eq _ Ho H); reflexivity.
  Qed.

  Lemma mkConst_sound (t : typ) (c : typD t) (tus tvs : tenv typ) :
    exprD' tus tvs t (mkConst t c) = Some (fun _ _ => c).
  Proof.
    unfold mkConst; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (bf_fConstOk t c) as H1.
    pose proof (bf_funcAsOk _ H1) as H2. rewrite H2.
    unfold funcAs; simpl; rewrite type_cast_refl; [|apply _].
    reflexivity.
  Qed.

  Lemma mkEq_sound (t : typ) (tus tvs : tenv typ) a b
    (aD : ExprI.exprT tus tvs (typD t))
    (bD : ExprI.exprT tus tvs (typD t))
    (Ha : exprD' tus tvs t a = Some aD)
    (Hb : exprD' tus tvs t b = Some bD)  :
    exprD' tus tvs tyProp (mkEq t a b) = Some (exprT_App (exprT_App (fun _ _ => eqD t) aD) bD).
  Proof.
    unfold mkEq; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ b _ Hb).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ a _ Ha).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (bf_fEqOk t) as Ho.
    pose proof (bf_funcAsOk _ Ho) as H1.
    rewrite H1. unfold funcAs; simpl.
    rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

  Lemma mkPair_sound (t u : typ) (tus tvs : tenv typ) a b
    (aD : ExprI.exprT tus tvs (typD t))
    (bD : ExprI.exprT tus tvs (typD u))
    (Ha : exprD' tus tvs t a = Some aD)
    (Hb : exprD' tus tvs u b = Some bD)  :
    exprD' tus tvs (tyProd t u) (mkPair t u a b) = Some (exprT_App (exprT_App (fun _ _ => pairD t u) aD) bD).
  Proof.
    unfold mkPair; simpl.
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ b _ Hb).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    rewrite (ExprTac.exprD_typeof_Some _ _ _ a _ Ha).
    autorewrite with exprD_rw; simpl; forward; inv_all; subst.
    pose proof (bf_fPairOk t u) as Ho.
    pose proof (bf_funcAsOk _ Ho) as H1.
    rewrite H1. unfold funcAs; simpl.
    rewrite type_cast_refl; [reflexivity | apply _].
  Qed.

End MakeBaseFuncSound.


Require Export hott_lemmas.

(** Delooping of symmetric groups **)

Section deloop.
Open Scope nat.

Private Inductive deloop : nat -> Type :=
  | dlpt0 : deloop 0
  | dli : forall n : nat, deloop n -> deloop n.+1.
Global Arguments dli {n} _.

Fixpoint dlpt (n : nat) : deloop n
  := match n with
  | 0 => dlpt0
  | n'.+1 => dli (dlpt n') end.

Axiom dltw : forall (n : nat) (a : deloop n),
  dli (dli a) = dli (dli a)
  :> deloop n.+2.
Global Arguments dltw {n} _.

Axiom dldo : forall (n : nat) (a : deloop n),
  dltw a @ dltw a = idpath
  :> (dli (dli a) = dli (dli a)).
Global Arguments dldo {n} _.

  Definition dldo_ : forall (n : nat) (a : deloop n),
    (dltw a)^ = dltw a.
  Proof.
    intros n a.
    refine (cancelR (dltw a)^ (dltw a) (dltw a) _).
    exact (concat_Vp _ @ (dldo a)^).
  Defined.
  Global Arguments dldo_ {n} _.

Axiom dlbr : forall (n : nat) (a : deloop n),
  dltw (dli a) @ ap dli (dltw a) @ dltw (dli a) = ap dli (dltw a) @ dltw (dli a) @ ap dli (dltw a)
  :> (dli (dli (dli a)) = dli (dli (dli a))).
Global Arguments dlbr {n} _.

Axiom dlT : forall (n : nat), IsTrunc 1 (deloop n).

Definition deloop_dot
  := sig deloop.

Definition dlT_dot
  : IsTrunc 1 deloop_dot.
Proof.
  srapply @trunc_sigma; intro; apply dlT.
Defined.

Definition dlpt0_dot
  : deloop_dot
  := (0; dlpt0).

Definition Sdli
  : deloop_dot -> deloop_dot
  := sigma_function S (@dli).

Section deloop_ind.

Definition dltw'_type
  (P : forall n : nat, deloop n -> Type)
  (dli' : forall (n : nat) (a : deloop n) (a' : P n a), P n.+1 (dli a))
  : Type
  := forall (n : nat) (a : deloop n) (a' : P n a),
  transport (P n.+2) (dltw a) (dli' _ _ (dli' _ _ a')) = dli' _ _ (dli' _ _ a').

Definition dldo'_type
  (P : forall n : nat, deloop n -> Type)
  (dli' : forall (n : nat) (a : deloop n) (a' : P n a), P n.+1 (dli a))
  (dltw' : dltw'_type P dli')
  : Type
  := forall (n : nat) (a : deloop n) (a' : P n a),
  (ap (fun z => transport (P n.+2) z (dli' _ _ (dli' _ _ a'))) (dldo a))^
  @ concat_D (dltw' _ _ a') (dltw' _ _ a')
  = idpath.

Definition dlbr'_type
  (P : forall n : nat, deloop n -> Type)
  (dli' : forall (n : nat) (a : deloop n) (a' : P n a), P n.+1 (dli a))
  (dltw' : dltw'_type P dli')
  : Type
  := forall (n : nat) (a : deloop n) (a' : P n a),
  (ap (fun z => transport (P n.+3) z (dli' _ _ (dli' _ _ (dli' _ _ a')))) (dlbr a))^ @
  concat_D
    (concat_D
      (dltw' _ _ (dli' _ _ a'))
      (transport_ap_nat (@dli) (@dli') (dltw a) (dltw' _ _ a')))
    (dltw' _ _ (dli' _ _ a'))
  = concat_D
    (concat_D
      (transport_ap_nat (@dli) (@dli') (dltw a) (dltw' _ _ a'))
      (dltw' _ _ (dli' _ _ a')))
    (transport_ap_nat (@dli) (@dli') (dltw a) (dltw' _ _ a')).

Context (P : forall n : nat, deloop n -> Type)
  (dlpt0' : P 0 dlpt0)
  (dli' : forall (n : nat) (a : deloop n) (a' : P n a), P n.+1 (dli a)).
Arguments dli' {n} {a} _.

Fixpoint deloop_ind
  (dltw' : dltw'_type P (@dli'))
  (dldo' : dldo'_type P (@dli') dltw')
  (dlbr' : dlbr'_type P (@dli') dltw')
  (dlT' : forall (n : nat) (x : deloop n), IsTrunc 1 (P n x))
  (n : nat) (s : deloop n)
  : P n s
  := match s with
  | dlpt0 => fun _ => fun _ => fun _ => fun _ => dlpt0'
  | dli n s0 => fun _ => fun _ => fun _ => fun _ =>
    dli' (deloop_ind dltw' dldo' dlbr' dlT' n s0)
  end dltw' dldo' dlbr' dlT'.

Axiom deloop_ind_beta_dltw
  : forall
  (dltw' : dltw'_type P (@dli'))
  (dldo' : dldo'_type P (@dli') dltw')
  (dlbr' : dlbr'_type P (@dli') dltw')
  (dlT' : forall (n : nat) (x : deloop n), IsTrunc 1 (P n x))
  (n : nat) (a : deloop n),
  apD (deloop_ind dltw' dldo' dlbr' dlT' n.+2) (dltw a) =
  dltw' _ _ (deloop_ind dltw' dldo' dlbr' dlT' n a).

Lemma deloop_ind_to_set
  (dltw' : dltw'_type P (@dli'))
  (dlT' : forall (n : nat) (x : deloop n), IsTrunc 0 (P n x))
  (n : nat) (s : deloop n)
  : P n s.
Proof.
  srapply @deloop_ind.
  { exact dltw'. }
  all: repeat intro; srapply @path_ishprop.
Defined.

Lemma deloop_ind_to_prop
  (dlT' : forall (n : nat) (x : deloop n), IsHProp (P n x))
  (n : nat) (s : deloop n)
  : P n s.
Proof.
  srapply @deloop_ind_to_set.
  repeat intro; srapply @path_ishprop.
Defined.

End deloop_ind.

Section deloop_rec.

Definition dltw'_rec_type
  (P : nat -> Type)
  (dli' : forall n : nat, P n -> P n.+1)
  : Type
  := forall (n : nat) (a' : P n),
  dli' _ (dli' _ a') = dli' _ (dli' _ a').

Definition dldo'_rec_type
  (P : nat -> Type)
  (dli' : forall n : nat, P n -> P n.+1)
  (dltw' : dltw'_rec_type P dli')
  : Type
  := forall (n : nat) (a' : P n),
  dltw' n a' @ dltw' n a' = idpath.

Definition dlbr'_rec_type
  (P : nat -> Type)
  (dli' : forall n : nat, P n -> P n.+1)
  (dltw' : dltw'_rec_type P dli')
  : Type
  := forall (n : nat) (a' : P n),
    dltw' _ (dli' _ a') @ ap (dli' _) (dltw' _ a') @ dltw' _ (dli' _ a') = ap (dli' _) (dltw' _ a') @ dltw' _ (dli' _ a') @ ap (dli' _) (dltw' _ a').

Context (P : nat -> Type)
  (dlpt0' : P 0)
  (dli' : forall n : nat, P n -> P n.+1).
Arguments dli' {_} _.

Definition deloop_rec_do_ind_of_rec
  (dltw' : dltw'_rec_type P (@dli'))
  (dldo' : dldo'_rec_type P (@dli') dltw')
  : forall (n : nat) (a : deloop n) (a' : P n),
  (ap (fun z : dli (dli a) = dli (dli a) => transport (fun _ : deloop n.+2 => P n.+2) z (dli' (dli' a')))
(dldo a))^ @
  concat_D
    (transport_const (dltw a) (dli' (dli' a')) @ dltw' n a')
    (transport_const (dltw a) (dli' (dli' a')) @ dltw' n a') =
  transport_const 1 (dli' (dli' a')).
Proof.
  intros.
  refine (whiskerL _ (concat_D_const_p (dltw' n a') (dltw' n a')) @ _).
  refine (concat_p_pp _ _ _ @ _).
  refine (whiskerL _ (dldo' _ a') @ _).
  refine (concat_p1 _ @ _).
  apply moveR_Vp.
  refine (transport_const_pq (dldo a) (dli' (dli' a')))^.
Defined.

Definition deloop_rec_br_ind_of_rec
  (dltw' : dltw'_rec_type P (@dli'))
  (dlbr' : dlbr'_rec_type P (@dli') dltw')
  : forall (n : nat) (a : deloop n) (a' : P n), (ap
   (fun z : dli (dli (dli a)) = dli (dli (dli a)) => transport (fun _ : deloop n.+3 => P n.+3) z (dli' (dli' (dli' a')))) (dlbr a))^ @
  concat_D
    (concat_D (transport_const (dltw (dli a)) (dli' (dli' (dli' a'))) @ dltw' n.+1 (dli' a'))
      (transport_ap_nat (@dli) (fun (n0 : nat) (_ : deloop n0) => @dli' n0) (dltw a)
        (transport_const (dltw a) (dli' (dli' a')) @ dltw' n a')))
    (transport_const (dltw (dli a)) (dli' (dli' (dli' a'))) @ dltw' n.+1 (dli' a'))
  = concat_D
    (concat_D
      (transport_ap_nat (@dli) (fun (n0 : nat) (_ : deloop n0) => @dli' n0) (dltw a)
        (transport_const (dltw a) (dli' (dli' a')) @ dltw' n a'))
      (transport_const (dltw (dli a)) (dli' (dli' (dli' a'))) @ dltw' n.+1 (dli' a')))
    (transport_ap_nat (@dli) (fun (n0 : nat) (_ : deloop n0) => @dli' n0) (dltw a)
      (transport_const (dltw a) (dli' (dli' a')) @ dltw' n a')).
Proof.
  intros.
  rewrite transport_ap_nat_transport_const_p.
  rewrite concat_D_const_p, concat_D_const_p, concat_D_const_p, concat_D_const_p.
  refine (concat_p_pp _ _ _ @ _).
  refine (whiskerL _ (dlbr' _ a') @ _); apply whiskerR.
  apply moveR_Vp.
  exact (transport_const_pq _ _)^.
Defined.

Definition deloop_rec
  (dltw' : dltw'_rec_type P (@dli'))
  (dldo' : dldo'_rec_type P (@dli') dltw')
  (dlbr' : dlbr'_rec_type P (@dli') dltw')
  (dlT' : forall n : nat, IsTrunc 1 (P n))
  (m : nat)
  : deloop m -> P m.
Proof.
  srefine (deloop_ind (fun n _ => P n) dlpt0' (fun n _ => dli') _ _ _ (fun n _ => dlT' n) m).
  + unfold dltw'_type. simpl; intros. refine (transport_const _ _ @ _). exact (dltw' _ a').
  + unfold dldo'_type. apply deloop_rec_do_ind_of_rec. exact dldo'.
  + unfold dlbr'_type. apply deloop_rec_br_ind_of_rec. exact dlbr'.
Defined.

Lemma deloop_rec_beta_dltw
  (dltw' : dltw'_rec_type P (@dli'))
  (dldo' : dldo'_rec_type P (@dli') dltw')
  (dlbr' : dlbr'_rec_type P (@dli') dltw')
  (dlT' : forall n : nat, IsTrunc 1 (P n))
  (n : nat) (a : deloop n)
  : ap (deloop_rec dltw' dldo' dlbr' dlT' n.+2) (dltw a)
    = dltw' _ (deloop_rec dltw' dldo' dlbr' dlT' _ a).
Proof.
  eapply (cancelL (transport_const (dltw a) _)).
  refine ((apD_const _ (dltw a))^ @ _).
  refine (deloop_ind_beta_dltw _ _ _ _ _ _ _ _ _).
Defined.

Lemma deloop_rec_to_set
  (dlT' : forall n : nat, IsTrunc 0 (P n))
  (dltw' : dltw'_rec_type P (@dli'))
  (m : nat)
  : deloop m -> P m.
Proof.
  srapply @deloop_rec.
  { exact dltw'. }
  all: repeat intro; srapply @path_ishprop.
Defined.

Lemma deloop_rec_to_prop
  (dlT' : forall n : nat, IsHProp (P n))
  (m : nat)
  : deloop m -> P m.
Proof.
  srapply @deloop_rec_to_set.
  repeat intro; srapply @path_ishprop.
Defined.

End deloop_rec.

Section deloop_rec_const.

Context (P : Type)
  (dlpt0' : P )
  (dli' : P -> P)
  (dltw' : forall a' : P, dli' (dli' a') = dli' (dli' a'))
  (dldo' : forall a' : P, dltw' a' @ dltw' a' = idpath)
  (dlbr' : forall a' : P, (dltw' (dli' a') @ ap dli' (dltw' a')) @ dltw' (dli' a') = (ap dli' (dltw' a') @ dltw' (dli' a')) @ ap dli' (dltw' a'))
  (dlT' : IsTrunc 1 P).

Definition deloop_rec_const
  (m : nat)
  : deloop m -> P.
Proof.
  srapply @deloop_rec; simpl.
  + exact dlpt0'.
  + intro; exact dli'.
  + unfold dltw'_rec_type; simpl. intro; exact dltw'.
  + unfold dldo'_rec_type; simpl. intro; exact dldo'.
  + unfold dlbr'_rec_type; simpl. intro; exact dlbr'.
Defined.

Lemma deloop_rec_const_beta_dltw
  (m : nat) (a : deloop m)
  : ap (deloop_rec_const m.+2) (dltw a) = dltw' (deloop_rec_const m a).
Proof.
  srapply @deloop_rec_beta_dltw.
Defined.

End deloop_rec_const.

Section deloop_rec_subuniverse.

Lemma deloop_rec_truncfib
  (A : Type)
  (Q : nat -> A -> Type)
  (T : forall n : nat, IsTrunc 1 {a : A & Q n a})
  (Tf : forall (n : nat) (a : A), IsHProp (Q n a))
  (dlpt0' : A)
  (dlpt0'q : Q 0 dlpt0')
  (dli' : nat -> A -> A)
  (dli'q : forall (n : nat) (a : A), Q n a -> Q n.+1 (dli' n a))
  (dltw' : forall (n : nat) (a : A), dli' n.+1 (dli' n a) = dli' n.+1 (dli' n a))
  (dldo' : forall (n : nat) (a : A), dltw' n a @ dltw' n a = idpath)
  (dlbr' : forall (n : nat) (a : A), (dltw' n.+1 (dli' n a) @ ap (dli' n.+2) (dltw' n a)) @ dltw' n.+1 (dli' n a) = (ap (dli' n.+2) (dltw' n a) @ dltw' n.+1 (dli' n a)) @ ap (dli' n.+2) (dltw' n a))
  : forall (n : nat), deloop n -> {a : A & Q n a}.
Proof.
  srapply @deloop_rec; hnf.
  + exists dlpt0'. exact dlpt0'q.
  + intro n. exact (sigma_function (dli' n) (dli'q n)).
  + simpl. intros n [a q]; unfold sigma_function.
    srapply @sigma_truncfib. apply dltw'.
  + abstract (intros n [a q];
    refine (sigma_truncfib_concat _ _ (dltw' n a) (dltw' n a) @ _ @ @sigma_truncfib_1 _ (fun a : A => Q n.+2 a) _ _ (Tf n.+2) _ idpath);
    apply ap; apply dldo').
  + abstract (intros n [a q]; simpl;
    rewrite ap_sigma_function_p;
    unfold path_sigma_function;
    rewrite path_path_sigma'_concat, path_path_sigma'_concat, path_path_sigma'_concat, path_path_sigma'_concat;
    srapply @path_path_sigma'_truncfib;
    rewrite sigma_truncfib_pr1;
    apply dlbr').
Defined.

Lemma deloop_rec_truncfib_beta_dltw
  (A : Type)
  (Q : nat -> A -> Type)
  (T : forall n : nat, IsTrunc 1 {a : A & Q n a})
  (Tf : forall (n : nat) (a : A), IsHProp (Q n a))
  (dlpt0' : A)
  (dlpt0'q : Q 0 dlpt0')
  (dli' : nat -> A -> A)
  (dli'q : forall (n : nat) (a : A), Q n a -> Q n.+1 (dli' n a))
  (dltw' : forall (n : nat) (a : A), dli' n.+1 (dli' n a) = dli' n.+1 (dli' n a))
  (dldo' : forall (n : nat) (a : A), dltw' n a @ dltw' n a = idpath)
  (dlbr' : forall (n : nat) (a : A), (dltw' n.+1 (dli' n a) @ ap (dli' n.+2) (dltw' n a)) @ dltw' n.+1 (dli' n a) = (ap (dli' n.+2) (dltw' n a) @ dltw' n.+1 (dli' n a)) @ ap (dli' n.+2) (dltw' n a))
  (n : nat) (a : deloop n)
  : ap pr1 (ap (deloop_rec_truncfib A Q T Tf dlpt0' dlpt0'q dli' dli'q dltw' dldo' dlbr' n.+2) (dltw a))
    = dltw' n (deloop_rec_truncfib A Q T Tf dlpt0' dlpt0'q dli' dli'q dltw' dldo' dlbr' n a).1.
Proof.
  unfold deloop_rec_truncfib.
  refine (ap (ap pr1) (deloop_rec_beta_dltw _ _ _ _ _ _ _ _ a) @ _).
  apply sigma_truncfib_pr1.
Defined.

Definition deloop_rec_subuniverse
  := deloop_rec_truncfib Type.

Definition deloop_rec_subuniverse_beta_dltw
  := deloop_rec_truncfib_beta_dltw Type.

End deloop_rec_subuniverse.

End deloop.

Ltac unfold_deloop_types
  := try unfold dltw'_type in *;
      try unfold dldo'_type in *;
      try unfold dlbr'_type in *;
      try unfold dltw'_rec_type in *;
      try unfold dldo'_rec_type in *;
      try unfold dlbr'_rec_type in *.

Open Scope nat.

(** deloop 0 and deloop 1 are contractible **)

Lemma deloop_contr_0 `{Funext}
  : forall (n : nat) (a : deloop n), n = 0 -> dlpt n = a.
Proof.
  srapply @deloop_ind_to_set; simpl.
  + intros; exact idpath.
  + intros n b IH p. apply Empty_rec. exact (not_sn_0 p).
  + unfold dltw'_type. intros. srapply @path_forall. intro p.
    apply Empty_rec. exact (not_sn_0 p).
  + intros; srapply @trunc_forall; intros; srapply @dlT.
Defined.

Lemma Contr_deloop0 `{Funext}
  : Contr (deloop 0).
Proof.
  srapply @Build_Contr.
  + apply dlpt.
  + intro a. exact (deloop_contr_0 0 a idpath).
Defined.

Lemma deloop_contr_1 `{Funext}
  : forall (n : nat) (a : deloop n), n = 1 -> dlpt n = a.
Proof.
  srapply @deloop_ind_to_set; simpl.
  + intros; exact idpath. (* Or ex falso; we don't care. *)
  + intros n b _ p. induction n.
    - apply ap. apply Contr_deloop0.
    - apply Empty_rec. exact (not_ssn_1 p).
  + unfold dltw'_type; intros; simpl. srapply @path_forall. intro p.
    apply Empty_rec. exact (not_ssn_1 p).
  + intros; srapply @trunc_forall; intros; srapply @dlT.
Defined.

Lemma Contr_deloop1 `{Funext}
  : Contr (deloop 1).
Proof.
  srapply @Build_Contr.
  + apply dlpt.
  + intro a. exact (deloop_contr_1 1 a idpath).
Defined.

(** The argument, of course, fails starting at 2! **)
Lemma deloop_contr_2 `{Funext}
  : forall (n : nat) (a : deloop n), n = 2 -> dlpt n = a.
Proof.
  assert (T : forall (n : nat) (x : deloop n), IsHSet (n = 2 -> dlpt n = x)).
  { intros; srapply @trunc_forall; intros; srapply @dlT. }
  srefine (deloop_ind_to_set _ _ _ _ T); simpl.
  + intros; exact idpath.
  + intros n b _ p. induction n.
    - apply Empty_rec. exact (not_ssn_1 p^).
    - clear IHn. induction n.
      * apply ap. apply Contr_deloop1.
      * apply Empty_rec. exact (not_ssn_1 (sn_sm p)).
  + unfold dltw'_type; intros; simpl. srapply @path_forall. intro p.
    induction n.
    - simpl. refine (@transport_forall_fun_path_const_l_idmap_r (deloop 2) (fun _ => 2 = 2) (dlpt 2) _ _ (dltw a) _ p @ _).
      refine (_ @ concat_p1 _); apply whiskerL. (* contradiction! *)
Abort.

(** deloop n is connected for every n **)
Lemma Connected_deloopn
  : forall n : nat, Contr (Trunc 0 (deloop n)).
Proof.
  intro n. srapply @Build_Contr.
  + apply tr. exact (dlpt n).
  + srapply @Trunc_ind.
    revert n. srapply @deloop_ind_to_prop; simpl.
    - constructor.
    - intros m b p.
      exact (ap (truncmap 0 dli) p).
Defined.

(** if we had a path tw = refl, then deloop n would be contractible **)
Lemma almost_contr_deloop_n
  : (forall (n : nat) (a : deloop n), dltw a = idpath)
    -> forall n : nat, Contr (deloop n).
Proof.
  intros twrefl n. srapply @Build_Contr.
  + apply dlpt.
  + revert n. srapply @deloop_ind_to_set; simpl.
    - constructor.
    - intros n a a'. exact (ap dli a').
    - intros n a a'; simpl.
      exact (ap (fun z => transport (fun s => dlpt n.+2 = s) z (ap dli (ap dli a'))) (twrefl n a)).
    - intros; srapply @dlT.
Defined.

(** tw commutes with ap i (ap i) **)
Lemma dltw_natural
  : forall (n : nat) (a b : deloop n) (p : a = b),
  ap dli (ap dli p) @ dltw b = dltw a @ ap dli (ap dli p).
Proof.
  intros; induction p; simpl.
  exact (concat_1p _ @ (concat_p1 _)^).
Defined.
Global Arguments dltw_natural {n} {a} {b} p.

Lemma dltw_natural_n
  : forall (n : nat) (a b : deloop n) (p : a = b),
  ap Sdli (ap Sdli (path_sigma' deloop idpath p)) @ path_sigma' deloop idpath (dltw b) = path_sigma' deloop idpath (dltw a) @ ap Sdli (ap Sdli (path_sigma' deloop idpath p)).
Proof.
  intros; induction p; simpl.
  exact (concat_1p _ @ (concat_p1 _)^).
Defined.
Global Arguments dltw_natural_n {n} {a} {b} p.

Lemma dltw_natural_n_sigma
  {x x' : {n : nat & deloop n}} (p : x = x')
  : ap Sdli (ap Sdli p) @ path_sigma' deloop idpath (dltw _) = path_sigma' deloop idpath (dltw _) @ ap Sdli (ap Sdli p).
Proof.
  intros; induction p; simpl.
  exact (concat_1p _ @ (concat_p1 _)^).
Defined.

Lemma dltw_natural_n_sigma_f
  (f : {n : nat & deloop n} -> {n : nat & deloop n})
  {n : nat} {a : deloop n} (p : f (n; a) = (n; a))
  : ap Sdli (ap Sdli p) @ path_sigma' deloop idpath (dltw _) = path_sigma' deloop idpath (dltw (f (n; a)).2) @ ap Sdli (ap Sdli p).
Proof.
  exact (@dltw_natural_n_sigma (f (n; a)) (n; a) p).
Defined.

(** Small results using connectedness of deloop **)
Section mere_statements.
Context `{Univalence}.

Lemma mere_dlptn
  : forall (n : nat) (a : deloop n), merely (dlpt n = a).
Proof.
  intro n.
  exact (@conn_to_prop _ (deloop n) (Connected_deloopn n) (fun a => merely (dlpt n = a)) _ (dlpt n) (tr idpath)).
Defined.

Lemma merely_dli_inj
  : forall (n : nat) (a : deloop n.+1), merely {a' : deloop n & a = dli a'}.
Proof.
  intro n.
  srefine (@conn_to_prop _ (deloop n.+1) (Connected_deloopn n.+1) (fun a => merely {a' : deloop n & a = dli a'}) _ (dlpt n.+1) _); hnf.
  apply tr. exists (dlpt n). exact idpath.
Defined.
End mere_statements.

(** Symmetric monoidal structure on deloop_dot **)

Require Import smonoidalgroupoid.

Section deloop_smgpd.
Context `{Univalence}.

  Definition dltw_dot
    : forall a : deloop_dot, Sdli (Sdli a) = Sdli (Sdli a).
  Proof.
    intro. exact (path_sigma' deloop idpath (dltw a.2)).
  Defined.

  Lemma dldo_dot
    : forall a : deloop_dot, dltw_dot a @ dltw_dot a = idpath.
  Proof.
    intro.
    refine (path_sigma'_concat _ _ _ _ _ @ _). simpl.
    srefine (path_sigma'_1 _ _ idpath _); simpl.
    exact (dldo _)^.
  Defined.

  Lemma dlbr_dot
    : forall a : deloop_dot,
    dltw_dot (Sdli a) @ ap Sdli (dltw_dot a) @ dltw_dot (Sdli a) = ap Sdli (dltw_dot a) @ dltw_dot (Sdli a) @ ap Sdli (dltw_dot a).
  Proof.
    intro.
    unfold Sdli.
    repeat rewrite ap_sigma_function_p.
    unfold dltw_dot. unfold path_sigma_function.
    rewrite <- path_sigma'_ap'_p.
    change ((path_sigma' deloop 1 (dltw (Sdli a).2) @ ap Sdli (path_sigma' deloop 1 (dltw a.2))) @ path_sigma' deloop 1 (dltw (Sdli a).2) = (ap Sdli (path_sigma' deloop 1 (dltw a.2)) @ path_sigma' deloop 1 (dltw (Sdli a).2)) @ ap Sdli (path_sigma' deloop 1 (dltw a.2))).
    rewrite ap_sigma_function_path_sigma'_1.
    repeat rewrite path_sigma'_concat. simpl. apply ap.
    apply dlbr.
  Defined.

  Lemma dltw_dot_natural
    {x y : deloop_dot} (p : x = y)
    : ap Sdli (ap Sdli p) @ dltw_dot y = dltw_dot x @ ap Sdli (ap Sdli p).
  Proof.
    induction p; simpl.
    exact (concat_1p _ @ (concat_p1 _)^).
  Defined.

Definition deloop_e
  : deloop_dot
  := dlpt0_dot.

  Definition deloop_m_dli
    : (deloop_dot -> deloop_dot) -> deloop_dot -> deloop_dot.
  Proof.
    intro a'. exact (Sdli o a').
  Defined.

  Definition deloop_m_dltw
    : forall a' : deloop_dot -> deloop_dot, deloop_m_dli (deloop_m_dli a') = deloop_m_dli (deloop_m_dli a').
  Proof.
    unfold deloop_m_dli.
    intros. srapply @path_forall; intro x.
    apply dltw_dot.
  Defined.

  Definition deloop_m_dldo
    : forall a' : deloop_dot -> deloop_dot, deloop_m_dltw a' @ deloop_m_dltw a' = 1%path.
  Proof.
    unfold deloop_m_dltw.
    intros.
    refine ((path_forall_pp _ _ _ _ _)^ @ _).
    refine (_ @ path_forall_1 _).
    apply ap. srapply @path_forall; intro x.
    apply dldo_dot.
  Defined.

  Definition deloop_m_dlbr
    : forall a' : deloop_dot -> deloop_dot,
      (deloop_m_dltw (deloop_m_dli a') @ ap deloop_m_dli (deloop_m_dltw a')) @ deloop_m_dltw (deloop_m_dli a')
      = (ap deloop_m_dli (deloop_m_dltw a') @ deloop_m_dltw (deloop_m_dli a')) @ ap deloop_m_dli (deloop_m_dltw a').
  Proof.
    unfold deloop_m_dltw, deloop_m_dli.
    intros.
    rewrite ap_compose_pf.
    repeat rewrite <- path_forall_pp.
    apply ap. srapply @path_forall; intro x.
    apply dlbr_dot.
  Defined.

Definition deloop_m
  : deloop_dot -> deloop_dot -> deloop_dot.
Proof.
  srapply @sig_rect; intro n; revert n; hnf.
  assert (T : (IsTrunc 1 (deloop_dot -> deloop_dot))).
  { exact (@trunc_forall _ _ _ _ (fun _ => dlT_dot)). }
  srefine (deloop_rec_const (deloop_dot -> deloop_dot) _ _ _ _ _ _); clear T.
  + exact idmap.
  + exact deloop_m_dli.
  + exact deloop_m_dltw.
  + exact deloop_m_dldo.
  + exact deloop_m_dlbr.
Defined.

Lemma ap_sig_rect_ap_base
  {A : Type} (B : A -> Type) (C : Type)
  (f : forall a : A, B a -> C)
  (a0 : A)
  {b b' : B a0} (p : b = b')
  : ap (sig_rect (fun _ : sig B => C) f) (ap (fun b : B a0 => (a0; b)) p) = ap (f a0) p.
Proof.
  induction p; constructor.
Defined.

Lemma ap_deloop_m_path_sigma_dltw {n : nat} (a : deloop n) (b : deloop_dot)
  : ap (fun x => deloop_m x b) (path_sigma' deloop idpath (dltw a)) = dltw_dot (deloop_m (n; a) b).
Proof.
  refine (@ap_compose deloop_dot (deloop_dot -> deloop_dot) deloop_dot deloop_m (fun q => q b) _ _ _ @ _).
  unfold deloop_m.
  refine (ap (ap (fun q : deloop_dot -> deloop_dot => q b)) (ap_sig_rect_ap_base deloop (deloop_dot -> deloop_dot) _ n.+2 (dltw a)) @ _).
  unfold deloop_rec_const.
  refine (ap (ap (fun q : deloop_dot -> deloop_dot => q b)) (@deloop_rec_beta_dltw (fun _ : nat => deloop_dot -> deloop_dot) idmap (fun _ : nat => deloop_m_dli) (fun _ : nat => deloop_m_dltw) (fun _ : nat => deloop_m_dldo) (fun _ : nat => deloop_m_dlbr) (fun _ : nat => (@trunc_forall _ _ _ _ (fun _ => dlT_dot))) n a) @ _).
  unfold deloop_m_dltw.
  refine (ap_pf_D _ b).
Defined.

Lemma ap_deloop_m_dltw {n : nat} (a : deloop n) (b : deloop_dot)
  : ap (fun x : deloop n.+2 => deloop_m (n.+2; x) b) (dltw a) = dltw_dot (deloop_m (n; a) b).
Proof.
  refine (@ap_compose (deloop n.+2) deloop_dot deloop_dot (fun x => (n.+2; x)) (fun x => deloop_m x b) _ _ (dltw a) @ _).
  srapply @ap_deloop_m_path_sigma_dltw.
Defined.

Lemma ap_deloop_m_dltw_dot (a : deloop_dot) (b : deloop_dot)
  : ap (fun z : deloop_dot => deloop_m z b) (dltw_dot a) = dltw_dot (deloop_m a b).
Proof.
  refine (ap_deloop_m_path_sigma_dltw a.2 b).
Defined.

Lemma ap011_deloop_m_ap_Sdli (* compare: ap011_sapp_ap_cons *)
  {a a' b b' : deloop_dot} (p : a = a') (q : b = b')
  : ap011 deloop_m (ap Sdli p) q = ap Sdli (ap011 deloop_m p q).
Proof.
  induction p, q; constructor.
Defined.

Definition alpha_deloop
  : forall a b c : deloop_dot, deloop_m (deloop_m a b) c = deloop_m a (deloop_m b c).
Proof.
  intros [n a] b c; revert a; revert n.
  assert (T : (forall (n : nat) (a : deloop n), IsHSet (deloop_m (deloop_m (n; a) b) c = deloop_m (n; a) (deloop_m b c)))).
  { intros. srapply (@istrunc_paths _ _ dlT_dot). }
  srefine (deloop_ind_to_set _ _ _ _ T); clear T; hnf.
  + constructor.
  + intros n a h.
    change (Sdli (deloop_m (deloop_m (n; a) b) c) = Sdli (deloop_m (n; a) (deloop_m b c))).
    apply ap. exact h.
  + abstract (intros n a a'; simpl;
    srefine (@transport_paths_FlFr (deloop n.+2) _ (fun a0 => deloop_m (deloop_m (n.+2; a0) b) c) (fun a0 => deloop_m (n.+2; a0) (deloop_m b c)) _ _ (dltw a) _ @ concat_pp_p _ _ _ @ _); apply moveR_Vp;
    srefine (whiskerL _ (ap_deloop_m_dltw _ _) @ _);
    srefine (_ @ whiskerR (@ap_compose (deloop n.+2) deloop_dot deloop_dot (fun a0 => deloop_m (n.+2; a0) b) (fun x => deloop_m x c) _ _ (dltw a))^ _);
    rewrite ap_deloop_m_dltw;
    rewrite ap_deloop_m_path_sigma_dltw;
    change (ap Sdli (ap Sdli a') @ path_sigma' (fun n0 : nat => deloop n0) 1 (dltw (deloop_m (n; a) (deloop_m b c)).2) = path_sigma' deloop idpath (dltw (deloop_m (deloop_m (n; a) b) c).2) @ ap Sdli (ap Sdli a'));
    apply dltw_dot_natural ) using alpha_deloop_dltw.
Defined.

Definition lambda_deloop
  : forall b : deloop_dot, deloop_m deloop_e b = b.
Proof.
  constructor.
Defined.

Definition rho_deloop
  : forall a : deloop_dot, deloop_m a deloop_e = a.
Proof.
  intros [n a]; revert a; revert n.
  assert (T : (forall (n : nat) (a : deloop n), IsHSet (deloop_m (n; a) deloop_e = (n; a)))).
  { intros. srapply (@istrunc_paths _ _ dlT_dot). }
  srefine (deloop_ind_to_set _ _ _ _ T); clear T; hnf.
  + constructor.
  + intros n a h.
    exact (ap Sdli h).
  + abstract (intros n a a'; simpl;
    srefine (@transport_paths_FlFr (deloop n.+2) _ (fun a0 => deloop_m (n.+2; a0) deloop_e) (fun a0 => (n.+2; a0)) _ _ (dltw a) _ @ concat_pp_p _ _ _ @ _); apply moveR_Vp;
    rewrite ap_deloop_m_dltw;
    change (ap Sdli (ap Sdli a') @ path_sigma' (fun n0 : nat => deloop n0) 1 (dltw a) = path_sigma' (fun n0 : nat => deloop n0) 1 (dltw (deloop_m (n; a) deloop_e).2) @ ap Sdli (ap Sdli a'));
    exact (dltw_dot_natural a') ) using rho_deloop_dltw.
Defined.

    Lemma tau_deloop_Q_dltw (y : deloop_dot)
      : forall (n : nat) (a : deloop n) (a' : Sdli (deloop_m (n; a) y) = deloop_m (n; a) (Sdli y)),
        transport
          (fun a0 : deloop n.+2 => Sdli (deloop_m (n.+2; a0) y) = deloop_m (n.+2; a0) (Sdli y))
          (dltw a)
          (dltw_dot (deloop_m (n.+1; dli a) y)
        @  ap Sdli (dltw_dot (deloop_m (n; a) y) @ ap Sdli a'))
        = dltw_dot (deloop_m (n.+1; dli a) y) @ ap Sdli (dltw_dot (deloop_m (n; a) y) @ ap Sdli a').
    Proof.
      intros n a h.
      refine (@transport_paths_FlFr (deloop n.+2) _ (fun a0 => Sdli (deloop_m (n.+2; a0) y)) (fun a0 => deloop_m (n.+2; a0) (Sdli y)) _ _ (dltw a) _ @ concat_pp_p _ _ _ @ _); apply moveR_Vp.
      rewrite (@ap_compose (deloop n.+2) deloop_dot deloop_dot (fun a0 => deloop_m (n.+2; a0) y) Sdli _ _ (dltw a)).
      repeat rewrite ap_deloop_m_dltw.
      repeat rewrite ap_pp.
      repeat rewrite concat_p_pp; refine (concat_pp_p _ _ _ @ _).
      refine (whiskerL _ (dltw_dot_natural _) @ concat_p_pp _ _ _ @ _); apply whiskerR.
      apply dlbr_dot.
    Defined.

  Definition tau_deloop_Q
    : forall (y x : deloop_dot), Sdli (deloop_m x y) = deloop_m x (Sdli y).
  Proof.
    intros y [n a]; revert a; revert n.
    assert (T : (forall (n : nat) (a : deloop n), IsHSet (Sdli (deloop_m (n; a) y) = deloop_m (n; a) (Sdli y)))).
    { intros. srapply (@istrunc_paths _ _ dlT_dot). }
    srefine (deloop_ind_to_set _ _ _ _ T); clear T; hnf.
    + constructor.
    + intros n a h. change (Sdli (Sdli (deloop_m (n; a) y)) = Sdli (deloop_m (n; a) (Sdli y))).
      exact (dltw_dot (deloop_m (n; a) y) @ (ap Sdli h)).
    + apply tau_deloop_Q_dltw.
  Defined.

  Definition tau_deloop_R
    : forall (n : nat) (a : deloop n) (b : deloop_dot),
      ap Sdli (tau_deloop_Q (n; a) b) @ (tau_deloop_Q (n.+1; dli a) b @ ap (fun a0 : deloop n.+2 => deloop_m b (n.+2; a0)) (dltw a))
      = dltw_dot (deloop_m b (n; a)) @ (ap Sdli (tau_deloop_Q (n; a) b) @ tau_deloop_Q (n.+1; dli a) b).
  Proof.
    intros n a [m b]; revert b; revert m.
    assert (T : (forall m b, IsHProp (ap Sdli (tau_deloop_Q (n; a) (m; b)) @ (tau_deloop_Q (n.+1; dli a) (m; b) @ ap (fun a0 : deloop n.+2 => deloop_m (m; b) (n.+2; a0)) (dltw a)) = dltw_dot (deloop_m (m; b) (n; a)) @ (ap Sdli (tau_deloop_Q (n; a) (m; b)) @ tau_deloop_Q (n.+1; dli a) (m; b))))).
    { intros. srapply (@istrunc_paths _ _ dlT_dot). }
    srapply @deloop_ind_to_prop; hnf.
    + refine (concat_1p _ @ concat_1p _ @ (concat_p1 _)^).
    + intros m b IHb.
      change (
(ap Sdli (dltw_dot (deloop_m (m; b) (n; a)) @ ap Sdli (tau_deloop_Q (n; a) (m; b)))) @
((dltw_dot (deloop_m (m; b) (n.+1; dli a)) @ ap Sdli (tau_deloop_Q (n.+1; dli a) (m; b))) @
 ap (fun a0 : deloop n.+2 => Sdli (deloop_m (m; b) (n.+2; a0))) (dltw a)) =
dltw_dot (Sdli (deloop_m (m; b) (n; a))) @
((ap Sdli (dltw_dot (deloop_m (m; b) (n; a)) @ ap Sdli (tau_deloop_Q (n; a) (m; b)))) @ (dltw_dot (deloop_m (m; b) (n.+1; dli a)) @ ap Sdli (tau_deloop_Q (n.+1; dli a) (m; b))))
).
      repeat rewrite (ap_pp Sdli).
      refine (concat_p_pp _ _ _ @ whiskerR (concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _ @ whiskerL _ (dltw_dot_natural (tau_deloop_Q (n; a) (m; b)))) _) _ @ _).
      refine (_ @ whiskerL _ (whiskerR (whiskerL _ (dltw_dot_natural (tau_deloop_Q (n; a) (m; b)))^ @ concat_p_pp _ _ _) _ @ concat_pp_p _ _ _)).
      refine (_ @ whiskerR (whiskerR (dlbr_dot (deloop_m (m; b) (n; a)))^ _ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _) _ @ concat_pp_p _ _ _);
      repeat rewrite concat_pp_p; apply whiskerL; apply whiskerL.
      refine (whiskerL _ (whiskerL _ (ap_compose (fun a0 : deloop n.+2 => deloop_m (m; b) (n.+2; a0)) Sdli _)) @ _).
      repeat rewrite <- (ap_pp Sdli); apply ap; exact IHb.
  Qed.

  Lemma tau_deloop_dltw
    : forall (n : nat) (a : deloop n) (a' : forall b : {n0 : nat & deloop n0}, deloop_m (n; a) b = deloop_m b (n; a)),
      transport
        (fun a0 : deloop n.+2 => forall b : {n0 : nat & deloop n0}, deloop_m (n.+2; a0) b = deloop_m b (n.+2; a0))
        (dltw a)
        (fun b : {n0 : nat & deloop n0} => ap Sdli (ap Sdli (a' b) @ tau_deloop_Q (n; a) b) @ tau_deloop_Q (n.+1; dli a) b)
      = (fun b : {n0 : nat & deloop n0} => ap Sdli (ap Sdli (a' b) @ tau_deloop_Q (n; a) b) @ tau_deloop_Q (n.+1; dli a) b).
  Proof.
    intros.
    srapply @path_forall; intro b.
    refine (@transport_forall' (deloop n.+2) deloop_dot deloop_dot (fun a0 b0 => deloop_m (n.+2; a0) b0) (fun a0 b0 => deloop_m b0 (n.+2; a0)) _ _ (dltw a) _ _ @ _); apply moveR_Vp.
    rewrite ap_deloop_m_dltw.
    rewrite ap_pp; repeat rewrite concat_p_pp.
    rewrite <- dltw_dot_natural; repeat rewrite concat_pp_p; apply whiskerL.
    srapply tau_deloop_R.
  Defined.

  Lemma tau_deloop_nil_dltw
    : forall (n : nat) (a : deloop n) (a' : (n; a) = deloop_m (n; a) (0; dlpt0)),
transport (fun b : deloop n.+2 => (n.+2; b) = deloop_m (n.+2; b) (0; dlpt0)) (dltw a) (ap Sdli (ap Sdli a')) =
ap Sdli (ap Sdli a').
  Proof.
    intros; simpl.
    refine (@transport_paths_FlFr (deloop n.+2) deloop_dot (fun z => (n.+2; z)) (fun z => deloop_m (n.+2; z) (0; dlpt0)) _ _ (dltw a) _ @ concat_pp_p _ _ _ @ _); apply moveR_Vp.
    change (ap Sdli (ap Sdli a') @ ap (fun z : deloop n.+2 => deloop_m (n.+2; z) (0; dlpt0)) (dltw a) =
dltw_dot (n; a) @ ap Sdli (ap Sdli a')).
    refine (_ @ dltw_dot_natural a'); apply whiskerL.
    refine (_ @ ap_deloop_m_dltw_dot (n; a) (0; dlpt0)).
    exact (ap_sigma_ap_fiber deloop (fun z => deloop_m z (0; dlpt0)) (dltw a))^.
  Defined.

Definition tau_deloop
  : forall a b : deloop_dot, deloop_m a b = deloop_m b a.
Proof.
  intros [n a]; revert a; revert n.
  assert (T : (forall (n : nat) (a : deloop n), IsHSet (forall b, deloop_m (n; a) b = deloop_m b (n; a)))).
  { intros. enough (t : forall b, IsHSet (deloop_m (n; a) b = deloop_m b (n; a))). { srapply @trunc_forall. }
    intros. exact (@istrunc_paths _ _ (dlT_dot) _ _). }
  srefine (deloop_ind_to_set _ _ _ _ T); clear T; hnf.
  + intro. change (b = deloop_m b (0; dlpt0)). (*  exact (rho_deloop b)^. *)
    induction b as [m b]; revert b; revert m.
    assert (T : (forall (m : nat) (b : deloop m), IsHSet ((m; b) = deloop_m (m; b) (0; dlpt0)))).
    { intros. srapply @istrunc_paths. exact dlT_dot. }
    srefine (deloop_ind_to_set _ _ _ _ T); clear T; hnf.
    - constructor.
    - intros n a h.
      change (Sdli (n; a) = Sdli (deloop_m (n; a) (0; dlpt0))).
      exact (ap Sdli h).
    - hnf. exact tau_deloop_nil_dltw.
  + intros n a ih b.
    change (Sdli (deloop_m (n; a) b) = deloop_m b (Sdli (n; a))).
    refine (ap Sdli (ih b) @ _).
    exact (tau_deloop_Q (n; a) b).
  + exact tau_deloop_dltw.
Defined.

(* This goes exactly the same way as for slists.
We show the pentagon and the triangle as an example. *)
Definition pentagon_deloop
  : IsPentagonCoherent deloop_m alpha_deloop.
Proof.
  unfold IsPentagonCoherent.
  intros [n a] b c d; revert a; revert n.
  assert (T : forall (n : nat) (a : deloop n), IsHProp (alpha_deloop (deloop_m (n; a) b) c d @ alpha_deloop (n; a) b (deloop_m c d) =
(ap011 deloop_m (alpha_deloop (n; a) b c) 1 @ alpha_deloop (n; a) (deloop_m b c) d) @
ap011 deloop_m 1 (alpha_deloop b c d))).
  { intros. apply @istrunc_paths. apply @istrunc_paths. exact dlT_dot. }
  refine (deloop_ind_to_prop _ _ _ T); clear T; hnf.
  + simpl. refine (concat_p1 _ @ _ @ (concat_1p _)^).
    change (alpha_deloop b c d = ap idmap (alpha_deloop b c d)).
    exact (ap_idmap _)^.
  + intros n a h.
    change (ap Sdli (alpha_deloop (deloop_m (n; a) b) c d) @ ap Sdli (alpha_deloop (n; a) b (deloop_m c d)) = (ap011 deloop_m (ap Sdli (alpha_deloop (n; a) b c)) 1 @ ap Sdli (alpha_deloop (n; a) (deloop_m b c) d)) @ ap011 deloop_m (ap Sdli (idpath (n; a))) (alpha_deloop b c d)).
    rewrite (ap011_deloop_m_ap_Sdli (alpha_deloop (n; a) b c) (idpath d)).
    rewrite (ap011_deloop_m_ap_Sdli (idpath (n; a)) (alpha_deloop b c d)).
    repeat rewrite <- (ap_pp Sdli); apply ap; exact h.
Qed.

Definition triangle_deloop
  : IsTriangleCoherent deloop_e deloop_m alpha_deloop lambda_deloop rho_deloop.
Proof.
  unfold IsTriangleCoherent.
  intros [n a] b; revert a; revert n.
  assert (T : forall (n : nat) (a : deloop n), IsHProp (alpha_deloop (n; a) deloop_e b @ ap011 deloop_m 1 (lambda_deloop b) = ap011 deloop_m (rho_deloop (n; a)) 1)).
  { intros. apply @istrunc_paths. apply @istrunc_paths. exact dlT_dot. }
  refine (deloop_ind_to_prop _ _ _ T); clear T; hnf.
  + constructor.
  + intros n a h.
    change (ap Sdli (alpha_deloop (n; a) deloop_e b) @ ap Sdli 1 = ap011 deloop_m (ap Sdli (rho_deloop (n; a))) 1).
    rewrite (ap011_deloop_m_ap_Sdli (rho_deloop (n; a)) 1).
    rewrite <- (ap_pp Sdli); apply ap; exact h.
Qed.

Definition hexagon_deloop
  : IsHexagonCoherent deloop_m alpha_deloop tau_deloop.
Proof.
Admitted.

Definition bigon_deloop
  : IsBigonCoherent deloop_m tau_deloop.
Proof.
Admitted.

Definition deloopSMG
  : SymMonoidalGroupoid
  := Build_SymMonoidalGroupoid deloop_dot dlT_dot deloop_e deloop_m alpha_deloop lambda_deloop rho_deloop tau_deloop pentagon_deloop triangle_deloop hexagon_deloop bigon_deloop.

End deloop_smgpd.


From st.STLCmuVS Require Import lang typing scopedness.
From st.STLCmu Require Import types.
From st.backtranslations.un_syn Require Import expressions universe.base.

Lemma back_typed (e : expr) n (pCn :  expr_scoped n e) : (replicate n TUniverse) ⊢ₙₒ <<e>> : TUniverse.
Proof.
  generalize dependent n.
  induction e; intros n pCn; inversion pCn; simplify_eq; simpl; try by repeat (apply inject_typed || rewrite -replicate_S || apply extract_typed || apply IHe || apply IHe0 || apply IHe1 || apply IHe2 || apply IHe3 || closed_solver || econstructor).
  - econstructor. apply lookup_replicate_2. by inversion pCn.
  - specialize (IHe n). specialize (IHe0 (S n)).
    eapply LetIn_typed. apply IHe0. by inversion pCn. apply IHe. auto.
  - by repeat (apply inject_typed || rewrite -replicate_S || apply (extract_typed TCArrow) || apply IHe1 || apply IHe2 || econstructor).
  - destruct l; repeat (apply inject_typed || econstructor).
  - by destruct op; repeat (apply inject_typed || apply (extract_typed) || apply IHe1 || apply IHe2 || econstructor || closed_solver).
  - by repeat (apply inject_typed || apply (extract_typed TCProd) || apply IHe || econstructor).
  - by repeat (apply inject_typed || apply (extract_typed TCProd) || apply IHe || econstructor).
  - specialize (IHe0 (S n)). specialize (IHe1 (S n)). by repeat (apply inject_typed || apply (extract_typed TCSum) || apply IHe || apply IHe0 || apply IHe1 || econstructor).
  - assert (TUniverse = TUniverse.[TRec TUniverse/]) as eq. by asimpl. rewrite eq. econstructor. econstructor.
    apply extract_typed. rewrite -eq. apply IHe. done.
Qed.


(** * Expressions *)

(** Doing the expressions in their own file to avoid some clutter and facilitate reuse
*)

From Coq Require Import Strings.String.
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.

Module BasicExpr.
  Inductive Aexpr : Type :=
  | AConst (n:nat)
  | AVar (x:string)
  | APlus (a1 a2:Aexpr).

  Inductive Bexpr : Type :=
  | BTrue
  | BFalse
  | BNot (b:Bexpr)
  | BAnd (b1 b2:Bexpr)
  | BLeq (a1 a2:Aexpr).

  Coercion AVar : string >-> Aexpr.
  Coercion AConst : nat >-> Aexpr.

  Declare Custom Entry com.
  Declare Scope com_scope.

  Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
  Notation "( x )" := x (in custom com, x at level 99) : com_scope.
  Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
  Notation "x + y"   := (APlus x y) (in custom com at level 70, no associativity).
  Notation "x <= y"  := (BLeq x y) (in custom com at level 70, no associativity).
  Notation "'~' b"   := (BNot b) (in custom com at level 75, right associativity).
  Notation "x && y"  := (BAnd x y) (in custom com at level 80, left associativity).

  Definition X : string := "x".
  Definition Y : string := "y".
  Definition Z : string := "z".

  Module Aexpr_as_DT.
    Definition t := Aexpr.
    Definition eq_dec (x y: t): {x = y} + {x <> y}.
    Proof. Admitted.
  End Aexpr_as_DT.

  Module Bexpr_as_DT.
    Definition t := Bexpr.
    Definition eq_dec (x y: t): {x = y} + {x <> y}.
    Proof. Admitted.
  End Bexpr_as_DT.

End BasicExpr.

Module ProcedureExpr.
  Definition LVar := string.
  Definition GVar := string.

  Inductive Aexpr : Type :=
  | AConst (n:nat)
  | AGVar (x:GVar)
  | ALVar (x:LVar)
  | APlus (a1 a2:Aexpr).

  Coercion AConst : nat >-> Aexpr.
  Coercion AGVar : GVar >-> Aexpr.
  Coercion ALVar : LVar >-> Aexpr.

  Inductive Bexpr : Type :=
  | BTrue
  | BFalse
  | BNot (b:Bexpr)
  | BAnd (b1 b2:Bexpr)
  | BLeq (a1 a2:Aexpr).

  Notation "<{ e }>" := e (at level 0, e custom com at level 99) : com_scope.
  Notation "( x )" := x (in custom com, x at level 99) : com_scope.
  Notation "x" := x (in custom com at level 0, x constr at level 0) : com_scope.
  Notation "x + y"   := (APlus x y) (in custom com at level 70, no associativity).
  Notation "x <= y"   := (BLeq x y) (in custom com at level 70, no associativity).
  Notation "'~' b"   := (BNot b) (in custom com at level 75, right associativity).
  Notation "x && y"  := (BAnd x y) (in custom com at level 80, left associativity).
End ProcedureExpr.


Require Import List Omega FunctionalExtensionality Basics.

Variable G : Set.
Variable list_G : list G.
Variable list_G_k : nat -> list (list G).

Axiom G_finite: forall g : G, In g list_G.

Axiom finite_words_finite : forall k (w : list G), length w = k -> In w (list_G_k k).

Open Scope list_scope.

Definition isR (X : Type) (p : (list G -> list G) * (list G -> X)) :=
  match p with | (t, c) => exists k, forall w v,
  length w = k -> t(w ++ v) = v /\ c(w ++ v) = c(w) end.

Inductive R (X : Type) : Type :=
  | C : forall t c, isR X (t, c) -> R X.

Axiom proof_irrelevance_R :
forall X f1 f2 g1 g2 H1 H2 (E1 : f2 = f1) (E2 : g2 = g1),
  C X f1 g1 H1 = C X f2 g2 H2.

Lemma R_fun_correct {X Y} (f : X -> Y)
(t : list G -> list G)
(c : list G -> X)
(i : isR X (t, c)) :
isR Y (t, fun s : list G => f (c s)).
Proof.
  destruct i. exists x. intros.
  eapply H in H0. destruct H0.
  split.
  - apply H0.
  - rewrite H1. reflexivity.
Qed.

Definition R_fun {X Y : Type} (f : X -> Y) (p : R X) : R Y :=
  match p with | C _ t c i =>
  (C Y t (fun s => f (c (s))) (R_fun_correct f t c i)) end.

Lemma R_fun_compose {X Y Z : Type} (f : Y -> Z) (g : X -> Y) :
  R_fun (compose f g) = compose (R_fun f) (R_fun g).
Proof.
  extensionality x. unfold R_fun.
  destruct x. apply proof_irrelevance_R.
  - reflexivity.
  - reflexivity.
Qed.

Definition W (X : Type) : Type := (list G) * X.

Definition W_fun (X Y : Type) (f : X -> Y) (p : W X) : W Y.
  destruct p. apply (l, f x).
Defined.

Lemma eta_correct {X} (x : X) :
  isR (W X) (fun w : list G => w, fun _ : list G => (nil, x)).
Proof.
  intros. unfold isR. exists 0. intros.
  split.
  - simpl. rewrite length_zero_iff_nil in H. rewrite H. reflexivity.
  - reflexivity.
Qed.

Definition eta {X : Type} (x : X) : R (W X) :=
  (C (W X) (fun (w: list G) => w)
  (fun (w : list G) => (@nil G, x)) (eta_correct x)).

Lemma delta_correct {X : Type}
(s : list G)
(t : list G -> list G)
(c : list G -> X)
(H : isR X (t, c)) :
isR (W X) (fun s' => s'),
  fun s' : list G => (s', c (s ++ s'))).
Proof.
  destruct H. exists x.
  intros. eapply H in H0. destruct H0. split.

  - rewrite H0. admit.
  - rewrite H0. reflexivity.
Qed.

Definition delta {X : Type} (pp : W (R X)) : R (W X) :=
  match pp with (s, p) => match p with (C _ t c H) =>
  (C (W X) (fun s' => t(s ++ t(s'))) (fun s' => (s', c(s ++ t(s'))))
  (delta_correct s t c H)) end end.

Import Nat.
Require Import PeanoNat Epsilon.

Fixpoint maximum {X : Type} (l : list X) (f : X -> nat) : nat :=
  match l with
    | nil => 0
    | (x :: l) => let n := maximum l f in (if (f x) <=? n then n else f x)
  end.

Definition getDependency {X : Type} (c : list G -> R X) (l : list G): nat.
  apply c in l. destruct l.
  apply constructive_indefinite_description in i. destruct i.
  apply x.
Defined.

Fixpoint drop {X : Type} (k : nat) (l : list X) := match k,l with
  | 0, _ => l
  | _, nil => nil
  | S k, x :: l => drop k l
  end.

Fixpoint take {X : Type} (k : nat) (l : list X) := match k,l with
  | 0, _ => nil
  | _, nil => nil
  | S k, x :: l => x :: take k l
  end.

Require Import Omega.

Lemma helper {X : Type}
(t1 : list G -> list G)
(c1 : list G -> R X)
(k1 : nat)
(R1 : forall w v : list G, length w = k1 -> t1 (w ++ v) = v /\ c1 (w ++ v) = c1 w)
(k2 : nat)
(Heqk2 : k2 = maximum (list_G_k k1) (getDependency c1)) :
isR X
  (fun s : list G => match c1 s with
                     | C _ _ _ _ => drop k2 (t1 s)
                     end, fun s : list G => match c1 s with
                                            | C _ _ c2 _ => c2 (t1 s)
                                            end).
Proof.
  unfold isR. exists (k1 + k2).
  intros.

  destruct (c1 (w ++ v)) as [t2 c2 R2] eqn:D. destruct R2 as [k R2].
  assert(k <= k2). admit.
  assert (exists x y z, length x = k1 /\ length y = k /\
    length (y ++ z) = k2 /\ w = x ++ y ++ z). admit.
  destruct H1 as [x [y [z [L1 [L2 [L3 A]]]]]].
  split.
  - rewrite A. eapply R1 in L1. destruct L1. rewrite <- app_assoc in *. rewrite H1.
    admit.
  - assert( c1 (w ++ v) = c1 x).
    eapply R1 in L1. destruct L1. rewrite A. rewrite <- app_assoc in *. rewrite H2.
    reflexivity.
    pose proof L1.
    eapply R1 in L1. destruct L1. rewrite A.
    rewrite H3. rewrite H4. rewrite <- H1. rewrite D.
    eapply R1 in H2. destruct H2. rewrite <- app_assoc in *. erewrite H2.
    assert(c2 (y ++ z) = c2 y).
    apply R2. apply L2. rewrite H6. rewrite <- app_assoc. apply R2. apply L2.
Admitted.

Definition contract {X : Type} (pp : R (R X)) : R X.
  destruct pp as [t1 c1 R1].
  unfold isR in R1.
  apply constructive_indefinite_description in R1. destruct R1 as [k1 R1].
  remember (maximum (list_G_k k1) (getDependency c1)) as k2.
  apply (C X
     (fun s => match c1(s) with
      | C _ t2 c2 H => drop k2 (t1(s))
      end)
    (fun s => match c1(s) with
      | C _ t2 c2 H => c2(t1(s))
      end)). eapply helper. apply R1. apply Heqk2.
Defined.

Definition epsilon' {X : Type} (p : R (R (W X))) : R X.
  apply contract in p.
  destruct p  as [t1 c1].
  apply (C X t1
    (fun s => match c1 s with | (s, x) => x end)).
  unfold isR. destruct i as [k H].
  exists k. intros. split.
  - apply H; auto.
  - eapply H in H0. destruct H0. rewrite H1. reflexivity.
Defined.

Lemma prop1 {X} (p : R X) : R_fun delta (eta p) = R_fun eta p.
Proof.
  unfold delta. unfold eta. unfold R_fun.
  destruct p.
  apply proof_irrelevance_R.
  destruct p as [t c [k H]].
  unfold R_fun. unfold eta.
  apply proof_irrelevance_R.

Definition mu {X} (p : R (W (R (W X)))) : R (W X) := epsilon' (R_fun delta p).

Lemma helper2 {X : Type}
(t1 : list G -> list G)
(c1 : list G -> W (R (W X)))
(H1 : isR (W (R (W X))) (t1, c1)) :
isR (W X)
  (fun s1 : list G =>
   let (s2, r) := c1 s1 in match r with
                           | C _ t2 _ _ => t2 (s2 ++ t1 s1)
                           end,
  fun s1 : list G =>
  let (s2, r) := c1 s1 in
  match r with
  | C _ _ c2 _ => let (s3, x) := c2 (s2 ++ t1 s1) in (s2 ++ s3, x)
  end).
Admitted.

Definition mu' {X} (p1 : R (W (R (W X)))) : R (W X).
  destruct p1 as [t1 c1 H1].
  apply (C (W X)
    (fun s1 =>
      match c1 s1 with | (s2, (C _ t2 c2 H2)) =>
        t2(s2 ++ t1(s1))
      end)
    (fun s1 =>
      match c1 s1 with | (s2, (C _ t2 c2 H2)) =>
      match c2 (s2 ++ t1(s1)) with (s3 , x) => (s2 ++ s3, x) end end )).
apply helper2. apply H1.
Defined.

Import EqNotations.

Lemma mu_correct {X : Type} (p : R (W (R (W X)))): @mu X p= @mu' X p.
  destruct p.
  unfold mu'. unfold mu. unfold epsilon'.
  destruct (contract (R_fun delta (C (W (R (W X))) t c i))) eqn:D.
  inversion D.
  destruct (constructive_indefinite_description
          (fun k : nat =>
           forall w v : list G, length w = k -> t (w ++ v) = v /\ delta (c (w ++ v)) = delta (c w))
          match i with
          | ex_intro _ x H =>
              ex_intro
                (fun k : nat =>
                 forall w v : list G, length w = k -> t (w ++ v) = v /\ delta (c (w ++ v)) = delta (c w)) x
                (fun (w v : list G) (H0 : length w = x) =>
                 match H w v H0 with
                 | conj H1 H2 =>
                     conj H1 (eq_ind_r (fun x0 : W (R (W X)) => delta x0 = delta (c w)) eq_refl H2)
                 end)
          end).
  inversion H0. clear H0. apply fe; extensionality s.
  - rewrite <- H1. destruct (c s), r.
    destruct (delta (l, C (W X) t1 c1 i1)).

  destruct (contract (R_fun delta (C (W (R (W X))) t c i))) eqn:C.
  apply fe; extensionality s; destruct (c s) eqn:D.
  inversion C. destruct i. unfold delta in *. unfold R_fun in *.
  -

Definition kleisli {X Y} (p : X -> R (W Y)) (q : R (W X)) : R (W Y).
  apply mu. apply (R_fun (W_fun _ _ p)). apply q.
Defined.

Definition pop_push_one {X} (x : X) : R (W X).
  apply (C (W X)
    (fun s1 => drop 1 s1)
    (fun s1 => (take 1 s1, x))).
  exists 1. intros. destruct w; try destruct w; inversion H.
  split.
  - reflexivity.
  - reflexivity.
Defined.