Require Import String.
Require Import Arith.
Require Import EqNat.
Require Import Bool.
Require Import FMapWeakList.
Require Import MSetWeakList.
Require Import DecidableTypeEx.

(*-----  Abstract Data Type  -----*)

(*  Name Type  *)

Module Type NAME.

Parameter name : Set.

Parameter Ntrue : name.
Parameter Nfalse : name.
Parameter Nnull : name.
Parameter Nres : name.
Parameter Nthis : name.

Parameter beq : name -> name -> bool.
Parameter peq : name -> name -> Prop.
Parameter eq_dec : forall x y : name, {x = y} + {x <> y}.

Axiom equal_1 : forall x y, beq x y = true <-> peq x y.

Axiom beq_refl : forall x : name, beq x x = true.
Axiom beq_sym : forall x y : name, beq x y = true <-> beq y x = true.
Axiom beq_trans : forall x y z : name, beq x y = true -> beq y z = true -> beq x z = true.

Axiom eq_refl : forall x : name, peq x x.
Axiom eq_sym : forall x y : name, peq x y -> peq y x.
Axiom eq_trans : forall x y z : name, peq x y -> peq y z -> peq x z.

End NAME.

(*  Method Type  *)

Module Type METHOD.

Parameter method : Set.

Parameter beq : method -> method -> bool.
Parameter peq : method -> method -> Prop.
Parameter eq_dec : forall x y : method, {x = y} + {x <> y}.

Axiom equal_1 : forall x y, beq x y = true <-> peq x y.

Axiom beq_refl : forall x : method, beq x x = true.
Axiom beq_sym : forall x y : method, beq x y = true <-> beq y x = true.
Axiom beq_trans : forall x y z : method, beq x y = true -> beq y z = true -> beq x z = true.

Axiom eq_refl : forall x : method, peq x x.
Axiom eq_sym : forall x y : method, peq x y -> peq y x.
Axiom eq_trans : forall x y z : method, peq x y -> peq y z -> peq x z.

End METHOD.

(*  RType Type  *)

Module Type RTYPE.

Parameter name : Set.

Parameter rtype : Set.
Parameter Object : rtype.
Parameter Null : rtype.
Parameter Bool : rtype.
Parameter Int : rtype.

Parameter field_type : Type.
Parameter empty_field_type : field_type.
Parameter type_env : Type.
Parameter init_type_env : type_env.

Parameter super_env : Type.
Parameter init_super_env : super_env.

Parameter beq : rtype -> rtype -> bool.
Parameter peq : rtype -> rtype -> Prop.
Parameter eq_dec : forall x y : rtype, {x = y} + {x <> y}.
Parameter update_type_env : rtype -> field_type -> type_env -> type_env.
Parameter update_field_type : name -> rtype -> field_type -> field_type.
Parameter update_super_env : rtype -> list rtype -> super_env -> super_env.
Parameter get_super : rtype -> super_env -> option (list rtype).
Parameter get_fields : rtype -> type_env -> option field_type.

Inductive subtype : rtype -> rtype -> super_env -> Prop :=
    | null_subt   : forall x y s, x = Null -> subtype x y s
    | self_subt   : forall x s, subtype x x s
    | direct_subt : forall x y z s, get_super x s = Some z -> List.In y z ->
                                      subtype x y s
    | trans_subt  : forall x y s, (exists z, subtype x z s /\ subtype z y s) ->
                                      subtype x y s.

Axiom equal_1 : forall x y, beq x y = true <-> peq x y.

Axiom beq_refl : forall x : rtype, beq x x = true.
Axiom beq_sym : forall x y : rtype, beq x y = true <-> beq y x = true.
Axiom beq_trans : forall x y z : rtype, beq x y = true -> beq y z = true -> beq x z = true.

Axiom eq_refl : forall x : rtype, peq x x.
Axiom eq_sym : forall x y : rtype, peq x y -> peq y x.
Axiom eq_trans : forall x y z : rtype, peq x y -> peq y z -> peq x z.

End RTYPE.

(*  Reference Type  *)

Module Type REF.

Parameter rtype : Set.

Parameter ref : Set.
Parameter rtrue : ref.
Parameter rfalse : ref.
Parameter rnull : ref.

Parameter alloc : Set.
Parameter init_alloc : alloc.

Parameter alloc_count : alloc -> nat.
Parameter new : rtype -> alloc -> alloc.
Parameter get_new : alloc -> ref.
Parameter beq : ref -> ref -> bool.
Parameter peq : ref -> ref -> Prop.
Parameter alloc_beq : alloc -> alloc -> bool.
Parameter alloc_peq : alloc -> alloc -> Prop.

Parameter eq_dec : forall x y : ref, {x = y} + {x <> y}.
Parameter get_type : ref -> rtype.
Parameter get_id : ref -> nat.

Axiom equal_1 : forall x y, beq x y = true <-> peq x y.
Axiom equal_2 : forall x y, peq x y <-> x = y.

Axiom beq_refl : forall x : ref, beq x x = true.
Axiom beq_sym : forall x y : ref, beq x y = true <-> beq y x = true.
Axiom beq_trans : forall x y z : ref, beq x y = true -> beq y z = true -> beq x z = true.

Axiom eq_refl : forall x : ref, peq x x.
Axiom eq_sym : forall x y : ref, peq x y -> peq y x.
Axiom eq_trans : forall x y z : ref, peq x y -> peq y z -> peq x z.

Axiom alloc_eq_refl : forall a : alloc, alloc_peq a a.
Axiom alloc_eq_sym : forall a1 a2 : alloc, alloc_peq a1 a2 -> alloc_peq a2 a1.
Axiom alloc_eq_trans : forall a1 a2 a3 : alloc,
    alloc_peq a1 a2 -> alloc_peq a2 a3 -> alloc_peq a1 a3.

End REF.

(*-----  Data  -----*)

(*  string_map  *)

Module string_DT' <: MiniDecidableType.
Definition t := string.
Definition eq_dec := string_dec.
End string_DT'.

Module string_DT <: UsualDecidableType := Make_UDT string_DT'.

Module Smap := FMapWeakList.Make string_DT.

Lemma smap_refl_1 : forall (t : Type) (eq : t -> t -> bool) e1,
    (forall t1, eq t1 t1 = true) -> Smap.Equivb eq e1 e1.
Proof.
  intros t eq e1 H.
  unfold Smap.Equivb.
  unfold Smap.Raw.Equivb.
  split. intro k. split.
  intro; assumption.
  intro; assumption.
  intros k e e' H0 H1.
  apply Smap.find_1 in H0.
  apply Smap.find_1 in H1.
  rewrite H1 in H0. inversion H0.
  apply H.
Qed.
Lemma smap_sym_1 : forall (t : Type) (eq : t -> t -> bool) e1 e2,
    (forall t1 t2, eq t1 t2 = true -> eq t2 t1 = true)
        -> Smap.Equivb eq e1 e2 -> Smap.Equivb eq e2 e1.
Proof.
  intros t eq e1 e2 H H0.
  unfold Smap.Equivb.
  unfold Smap.Raw.Equivb.
  unfold Smap.Equivb in H0.
  unfold Smap.Raw.Equivb in H0.
  destruct H0.
  split. intro k. split.
  intro; apply H0; assumption.
  intro; apply H0; assumption.
  intros k e e' H2 H3.
  assert (eq e' e = true).
  apply H1 with (k := k).
  assumption. assumption.
  apply H; assumption.
Qed.
Lemma smap_trans_1 : forall (t : Type) (eq : t -> t -> bool) e1 e2 e3,
    (forall t1 t2 t3, eq t1 t2 = true -> eq t2 t3 = true -> eq t1 t3 = true)
        -> Smap.Equivb eq e1 e2 -> Smap.Equivb eq e2 e3 -> Smap.Equivb eq e1 e3.
Proof.
  intros t eq e1 e2 e3 H H0 H1.
  unfold Smap.Equivb.
  unfold Smap.Raw.Equivb.
  unfold Smap.Equivb in H0.
  unfold Smap.Raw.Equivb in H0.
  unfold Smap.Equivb in H1.
  unfold Smap.Raw.Equivb in H1.
  destruct H0. destruct H1.
  split. intro k. split.
  intro; apply H1; apply H0; assumption.
  intro; apply H0; apply H1; assumption.
  intros k e e' H4 H5.
  assert (Smap.Raw.PX.In k (Smap.this e2)).
  apply H1. exists e'. assumption.
  destruct H6. assert (eq e x = true).
  apply H2 with (k := k).
  assumption. assumption.
  assert (eq x e' = true).
  apply H3 with (k := k).
  assumption. assumption.
  apply H with (t2 := x).
  assumption. assumption.
Qed.

Lemma smap_refl_2 : forall (t : Type) (eq : t -> t -> bool) e1,
    (forall t1, eq t1 t1 = true) -> Smap.equal eq e1 e1 = true.
Proof.
  intros t eq e1 H.
  apply Smap.equal_1.
  apply smap_refl_1.
  assumption.
Qed.
Lemma smap_sym_2 : forall (t : Type) (eq : t -> t -> bool) e1 e2,
    (forall t1 t2, eq t1 t2 = true -> eq t2 t1 = true)
        -> Smap.equal eq e1 e2 = true -> Smap.equal eq e2 e1 = true.
Proof.
  intros t eq e1 e2 H H0.
  apply Smap.equal_1.
  apply Smap.equal_2 in H0.
  apply smap_sym_1.
  assumption. assumption.
Qed.
Lemma smap_trans_2 : forall (t : Type) (eq : t -> t -> bool) e1 e2 e3,
  (forall t1 t2 t3, eq t1 t2 = true -> eq t2 t3 = true -> eq t1 t3 = true)
    -> Smap.equal eq e1 e2 = true -> Smap.equal eq e2 e3 = true -> Smap.equal eq e1 e3 = true.
Proof.
  intros t eq e1 e2 e3 H H0 H1.
  apply Smap.equal_1.
  apply Smap.equal_2 in H0.
  apply Smap.equal_2 in H1.
  apply smap_trans_1 with (e2 := e2).
  assumption. assumption. assumption.
Qed.
Lemma smap_equal: forall (t : Type) (eq : t -> t -> bool),
    (forall e1 e2, eq e1 e2 = true <-> e1 = e2) ->
    (forall m1 m2, Smap.equal eq m1 m2 = true <-> m1 = m2).
Proof.
  intros t eq H m1 m2.
Admitted.
Lemma smap_inject: forall (t : Type) k (e1 e2 : t) m,
    Smap.MapsTo k e1 m -> Smap.MapsTo k e2 m -> e1 = e2.
Proof.
  intros t k e1 e2 m H H0.
  apply Smap.find_1 in H.
  apply Smap.find_1 in H0.
  rewrite H in H0. inversion H0.
  reflexivity.
Qed.
Lemma smap_add: forall (t : Type) k (e1 e2 : t) m,
    Smap.MapsTo k e1 (Smap.add k e2 m) -> e1 = e2.
Proof.
  intros t k e1 e2 m H.
  assert (Smap.MapsTo k e2 (Smap.add k e2 m)).
  apply Smap.add_1. reflexivity.
  apply smap_inject with (k := k) (m := Smap.add k e2 m).
  assumption. assumption.
Qed.

(*  string_set  *)

Module Sset := MSetWeakList.Make string_DT.

Lemma sset_refl : forall e1, Sset.equal e1 e1 = true.
Proof.
  intro e1. apply Sset.equal_spec.
  unfold Sset.Equal. intro a. split.
  intro; assumption.
  intro; assumption.
Qed.
Lemma sset_sym : forall e1 e2, Sset.equal e1 e2 = true -> Sset.equal e2 e1 = true.
Proof.
  intros e1 e2 H.
  apply Sset.equal_spec.
  apply Sset.equal_spec in H.
  unfold Sset.Equal.
  unfold Sset.Equal in H.
  intro; split.
  apply H. apply H.
Qed.
Lemma sset_trans : forall e1 e2 e3,
    Sset.equal e1 e2 = true -> Sset.equal e2 e3 = true -> Sset.equal e1 e3 = true.
Proof.
  intros e1 e2 e3 H H0.
  apply Sset.equal_spec.
  apply Sset.equal_spec in H.
  apply Sset.equal_spec in H0.
  unfold Sset.Equal.
  unfold Sset.Equal in H.
  unfold Sset.Equal in H0.
  intro; split.
  intro; apply H0; apply H; assumption.
  intro; apply H; apply H0; assumption.
Qed.

Definition sset_dsj (s1 s2 : Sset.t) := forall x,
    (Sset.In x s1 -> ~ Sset.In x s2) /\ (Sset.In x s2 -> ~ Sset.In x s1).

Lemma sset_dsj_empty : forall s, sset_dsj s Sset.empty.
Proof.
  unfold sset_dsj. intros s x. split.
  intro; apply Sset.empty_spec.
  intro H; apply Sset.empty_spec in H; elim H.
Qed.
Lemma sset_dsj_sym : forall s1 s2, sset_dsj s1 s2 -> sset_dsj s2 s1.
Proof.
  unfold sset_dsj. intros s1 s2 H x.
  destruct H with (x := x).
  split. assumption. assumption.
Qed.
Lemma sset_dsj_union : forall s1 s2 s3,
    sset_dsj s1 (Sset.union s2 s3) <-> sset_dsj s1 s2 /\ sset_dsj s1 s3.
Proof.
  unfold sset_dsj. intros s1 s2 s3.
  split. intro H. split. intro x.
  destruct H with (x := x). split.
  intros H2 H3. apply H0 in H2; elim H2.
  apply Sset.union_spec. left; assumption.
  intros H2 H3. apply H0 in H3; elim H3.
  apply Sset.union_spec. left; assumption.
  intro x. destruct H with (x := x). split.
  intros H2 H3. apply H0 in H2; elim H2.
  apply Sset.union_spec. right; assumption.
  intros H2 H3. apply H0 in H3; elim H3.
  apply Sset.union_spec. right; assumption.
  intros H x. destruct H. destruct H with (x := x).
  destruct H0 with (x := x). split.
  intros H5 H6. apply Sset.union_spec in H6.
  destruct H6. apply H2 in H6; elim H6; assumption.
  apply H4 in H6; elim H6; assumption.
  intros H5 H6. apply Sset.union_spec in H5.
  destruct H5. apply H2 in H5; elim H5; assumption.
  apply H4 in H5; elim H5; assumption.
Qed.
Lemma sset_dsj_self : forall s, sset_dsj s s -> Sset.Empty s.
Proof.
  unfold Sset.Empty; unfold sset_dsj.
  intros s H a H0. destruct H with (x := a).
  elim H1. assumption. assumption.
Qed.
Lemma sset_dsj_left : forall s1 s2 e,
    sset_dsj (Sset.add e s1) s2 <-> ~ Sset.In e s2 /\ sset_dsj s1 s2.
Proof.
  unfold sset_dsj. intros s1 s2 e. split.
  intro H. split. destruct H with (x := e).
  intro H2. apply H1 in H2; elim H2.
  apply Sset.add_spec. left; reflexivity.
  intro x. destruct H with (x := x). split.
  intros H2 H3. apply H1 in H3; elim H3.
  apply Sset.add_spec. right; assumption.
  intros H2 H3. apply H1 in H2; elim H2.
  apply Sset.add_spec. right; assumption.
  intros H x. destruct H. split.
  intros H1 H2. apply Sset.add_spec in H1.
  destruct H1. elim H; rewrite <- H1; assumption.
  apply H0 in H1. assumption. assumption.
  intros H1 H2. apply Sset.add_spec in H2.
  destruct H2. elim H; rewrite <- H2; assumption.
  apply H0 in H2. assumption. assumption.
Qed.
Lemma sset_dsj_right : forall s1 s2 e,
    sset_dsj s1 (Sset.add e s2) <-> ~ Sset.In e s1 /\ sset_dsj s1 s2.
Proof.
  intros s1 s2 e. split.
  intro H. apply sset_dsj_sym in H.
  apply sset_dsj_left in H. destruct H.
  split. assumption. apply sset_dsj_sym; assumption.
  intro H. destruct H. apply sset_dsj_sym in H0.
  apply sset_dsj_sym. apply sset_dsj_left.
  split. assumption. assumption.
Qed.
Lemma sset_dsj_card : forall s1 s2,
    Sset.cardinal (Sset.union s1 s2) = Sset.cardinal s1 + Sset.cardinal s2
    -> sset_dsj s1 s2.
Proof.
  intro s1. case (eq_nat_dec (Sset.cardinal s1) (Sset.cardinal s1)).
  pattern (Sset.cardinal s1) at -1.
  induction (Sset.cardinal s1).
  intros H s2 H0.
Admitted.

Open Scope string_scope.

(*  Name  *)

Module Name <: NAME.

Definition name := string.

Definition Ntrue := "true".
Definition Nfalse := "false".
Definition Nnull := "null".
Definition Nres := "res".
Definition Nthis := "this".

Definition beq x y := andb (prefix x y) (prefix y x).
Definition peq (x y : name) := x = y.
Definition eq_dec := string_dec.

Lemma prefix_refl : forall x, prefix x x = true.
Proof.
  induction x. auto.
  unfold prefix; fold prefix.
  case (Ascii.ascii_dec a a).
  intro; assumption.
  intro H; elim H; reflexivity.
Qed.

Lemma equal_1 : forall x y, beq x y = true <-> peq x y.
Proof.
  unfold beq; unfold peq. induction x, y.
  simpl. tauto. simpl. split.
  intro; discriminate.
  intro; discriminate.
  simpl. split.
  intro; discriminate.
  intro; discriminate.
  unfold prefix; fold prefix.
  case (Ascii.ascii_dec a a0).
  intro H. rewrite H. split.
  intro H0. apply Bool.andb_true_iff in H0.
  destruct H0. case (Ascii.ascii_dec a0 a0) in H1.
  assert (x = y). apply IHx.
  apply Bool.andb_true_iff. split.
  assumption. assumption.
  rewrite H2; reflexivity.
  discriminate. intro H0.
  inversion H0.
  apply Bool.andb_true_iff. split.
  apply prefix_refl.
  rewrite prefix_refl.
  case (Ascii.ascii_dec a0 a0).
  intro; reflexivity.
  intro H1; elim H1; reflexivity.
  intro H. split. intro H0.
  apply Bool.andb_true_iff in H0. destruct H0.
  discriminate. intro H0.
  inversion H0. elim H. assumption.
Qed.

Lemma eq_refl : forall x : name, peq x x.
Proof.
  unfold peq.
  reflexivity.
Qed.
Lemma eq_sym : forall x y : name, peq x y -> peq y x.
Proof.
  unfold peq.
  intros x y H.
  rewrite H; reflexivity.
Qed.
Lemma eq_trans : forall x y z : name, peq x y -> peq y z -> peq x z.
Proof.
  unfold peq.
  intros x y z H0 H1.
  rewrite H0; assumption.
Qed.

Lemma beq_refl : forall x : name, beq x x = true.
Proof.
  intro x. apply equal_1.
  reflexivity.
Qed.
Lemma beq_sym : forall x y : name, beq x y = true <-> beq y x = true.
Proof.
  intros x y. split.
  intro H. apply equal_1 in H.
  rewrite H. apply beq_refl.
  intro H. apply equal_1 in H.
  rewrite H. apply beq_refl.
Qed.
Lemma beq_trans : forall x y z : name,
    beq x y = true -> beq y z = true -> beq x z = true.
Proof.
  intros x y z H H0.
  apply equal_1 in H.
  apply equal_1 in H0.
  rewrite H. rewrite H0.
  apply beq_refl.
Qed.

End Name.

(*  Method  *)

Module Method <: METHOD.

Definition method := string.

Definition beq x y := andb (prefix x y) (prefix y x).
Definition peq (x y : method) := x = y.
Definition eq_dec := string_dec.

Lemma equal_1 : forall x y, beq x y = true <-> peq x y.
Proof.
  apply Name.equal_1.
Qed.

Lemma eq_refl : forall x : method, peq x x.
Proof.
  unfold peq.
  reflexivity.
Qed.
Lemma eq_sym : forall x y : method, peq x y -> peq y x.
Proof.
  unfold peq.
  intros x y H.
  rewrite H; reflexivity.
Qed.
Lemma eq_trans : forall x y z : method, peq x y -> peq y z -> peq x z.
Proof.
  unfold peq.
  intros x y z H0 H1.
  rewrite H0; assumption.
Qed.

Lemma beq_refl : forall x : method, beq x x = true.
Proof.
  intro x. apply equal_1.
  reflexivity.
Qed.
Lemma beq_sym : forall x y : method, beq x y = true <-> beq y x = true.
Proof.
  intros x y. split.
  intro H. apply equal_1 in H.
  rewrite H. apply beq_refl.
  intro H. apply equal_1 in H.
  rewrite H. apply beq_refl.
Qed.
Lemma beq_trans : forall x y z : method,
    beq x y = true -> beq y z = true -> beq x z = true.
Proof.
  intros x y z H H0.
  apply equal_1 in H.
  apply equal_1 in H0.
  rewrite H. rewrite H0.
  apply beq_refl.
Qed.

End Method.

(*  RType  *)

Module RType <: RTYPE.

Definition name := Name.name.

Definition rtype := string.

Definition Object := "Object".
Definition Null := "Null".
Definition Bool := "Bool".
Definition Int := "Int".

Definition field_type := Smap.t rtype.
Definition empty_field_type := Smap.empty rtype.
Definition type_env := Smap.t field_type.
Definition empty_type_env := Smap.empty field_type.
Definition init_type_env :=
    Smap.add "Object" empty_field_type
    (Smap.add "Bool" empty_field_type
    (Smap.add "Null" empty_field_type empty_type_env)).

Definition beq x y := andb (prefix x y) (prefix y x).
Definition peq (x y : rtype) := x = y.

Definition eq_dec := string_dec.

Definition super_env := Smap.t (list rtype).
Definition init_super_env := Smap.add "Bool" (cons "Object" nil) (Smap.empty (list rtype)).

Definition update_super_env (t : rtype) (super : list rtype) (s : super_env) :=
    Smap.add t super s.

Definition get_super (t : rtype) (s : super_env) := Smap.find t s.

Inductive subtype : rtype -> rtype -> super_env -> Prop :=
    | null_subt   : forall x y s, x = Null -> subtype x y s
    | self_subt   : forall x s, subtype x x s
    | direct_subt : forall x y z s, get_super x s = Some z -> List.In y z ->
                                      subtype x y s
    | trans_subt  : forall x y s, (exists z, subtype x z s /\ subtype z y s) ->
                                      subtype x y s.

Definition update_type_env (t : rtype) (f : field_type) (e : type_env) : type_env :=
    Smap.add t f e.

Definition update_field_type (n : name) (t : rtype) (f : field_type) : field_type :=
    Smap.add n t f.

Definition get_fields (t : rtype) (e : type_env) : option field_type :=
    Smap.find t e.

Lemma equal_1 : forall x y, beq x y = true <-> peq x y.
Proof.
  apply Name.equal_1.
Qed.

Lemma eq_refl : forall x : rtype, peq x x.
Proof.
  unfold peq.
  reflexivity.
Qed.
Lemma eq_sym : forall x y : rtype, peq x y -> peq y x.
Proof.
  unfold peq.
  intros x y H.
  rewrite H; reflexivity.
Qed.
Lemma eq_trans : forall x y z : rtype, peq x y -> peq y z -> peq x z.
Proof.
  unfold peq.
  intros x y z H0 H1.
  rewrite H0; assumption.
Qed.

Lemma beq_refl : forall x : rtype, beq x x = true.
Proof.
  intro x. apply equal_1.
  reflexivity.
Qed.
Lemma beq_sym : forall x y : rtype, beq x y = true <-> beq y x = true.
Proof.
  intros x y. split.
  intro H. apply equal_1 in H.
  rewrite H. apply beq_refl.
  intro H. apply equal_1 in H.
  rewrite H. apply beq_refl.
Qed.
Lemma beq_trans : forall x y z : rtype,
    beq x y = true -> beq y z = true -> beq x z = true.
Proof.
  intros x y z H H0.
  apply equal_1 in H.
  apply equal_1 in H0.
  rewrite H. rewrite H0.
  apply beq_refl.
Qed.

End RType.

Open Scope list_scope.

(*  Reference  *)

Module Ref <: REF.

Definition rtype := RType.rtype.

Definition ref := (nat * rtype)%type.
Definition rfalse := (0, RType.Bool).
Definition rtrue := (1, RType.Bool).
Definition rnull := (2, RType.Null).

Definition alloc := list ref.
Definition init_alloc := rnull :: rtrue :: rfalse :: nil.

Definition alloc_count (a : alloc) :=
    match a with
        | nil => 0
        | (n, _) :: _ => n
    end.

Definition new (t : rtype) (a : alloc) : alloc :=
    match a with
        | nil => (0, t) :: nil
        | (n, _) :: _ => (n+1, t) :: a
    end.

Definition get_new (a : alloc) : ref :=
    match a with
        | nil => rnull (* Impossible *)
        | r :: _ => r
    end.

Definition beq (r1 r2 : ref) :=
    match r1 with (n1, t1) =>
        match r2 with (n2, t2) =>
            andb (beq_nat n1 n2) (RType.beq t1 t2)
        end
    end.

Definition peq (r1 r2 : ref) :=
    match r1 with (n1, t1) =>
        match r2 with (n2, t2) =>
            (eq_nat n1 n2) /\ (RType.peq t1 t2)
        end
    end.

Fixpoint alloc_beq (a1 a2 : alloc) : bool :=
    match a1, a2 with
        | nil, nil => true
        | b1::c1, b2::c2 => andb (Ref.beq b1 b2) (alloc_beq c1 c2)
        | _, _ => false
    end.

Fixpoint alloc_peq (a1 a2 : alloc) : Prop :=
    match a1, a2 with
        | nil, nil => True
        | b1::c1, b2::c2 => (Ref.peq b1 b2) /\ (alloc_peq c1 c2)
        | _, _ => False
    end.

Definition eq_dec : forall x y : ref, {x = y} + {x <> y}.
Proof.
  induction x, y.
  decide equality; (apply eq_nat_dec || apply RType.eq_dec).
Qed.

Definition get_type (r : ref) := snd r.

Definition get_id (r : ref) := fst r.

Lemma equal_1 : forall x y, beq x y = true <-> peq x y.
Proof.
  intros x y.
  induction x, y.
  split. intro H.
  unfold beq in H.
  apply andb_true_iff in H.
  destruct H. unfold peq.
  split. apply beq_nat_true in H.
  apply eq_eq_nat. assumption.
  apply RType.equal_1. assumption.
  unfold peq. unfold beq.
  intro H. destruct H.
  apply andb_true_iff.
  split. apply eq_nat_eq in H.
  rewrite H. apply eq_sym.
  apply beq_nat_refl.
  apply RType.equal_1. assumption.
Qed.

Lemma equal_2 : forall x y, peq x y <-> x = y.
Proof.
  intros x y.
  induction x, y.
  unfold peq.
  split. intro H.
  destruct H.
  apply eq_nat_eq in H.
  rewrite H. rewrite H0.
  reflexivity.
  intro H. inversion H.
  split. apply eq_nat_refl.
  apply RType.eq_refl.
Qed.

Lemma beq_nat_sym : forall n n' : nat, beq_nat n n' = beq_nat n' n.
Proof.
  induction n, n'.
  reflexivity.
  unfold beq_nat; reflexivity.
  unfold beq_nat; reflexivity.
  unfold beq_nat; fold beq_nat. apply IHn.
Qed.

Lemma beq_nat_trans : forall n1 n2 n3 : nat, beq_nat n1 n2 = true ->
    beq_nat n2 n3 = true -> beq_nat n1 n3 = true.
Proof.
  induction n1, n2, n3.
  intros H H0; assumption.
  intros H H0; assumption.
  intros H H0; unfold beq_nat in H; elim H; discriminate H.
  intros H H0; unfold beq_nat in H; elim H; discriminate H.
  intros H H0; unfold beq_nat in H; elim H; discriminate H.
  intros H H0; unfold beq_nat in H; elim H; discriminate H.
  intros H H0; unfold beq_nat in H0; elim H0; discriminate H0.
  intros H H0. apply IHn1 with (n2 := n2).
  assumption. assumption.
Qed.

Lemma beq_refl : forall x : ref, beq x x = true.
Proof.
  intro x.
  unfold beq.
  induction x.
  apply andb_true_iff.
  split.
  apply eq_sym.
  apply beq_nat_refl.
  apply RType.beq_refl.
Qed.

Lemma beq_sym : forall x y : ref, beq x y = true <-> beq y x = true.
Proof.
  induction x, y.
  unfold beq.
  assert (beq_nat a n = true \/ beq_nat a n = false).
  case (beq_nat a n).
  left; reflexivity.
  right; reflexivity.
  assert (RType.beq b r = true \/ RType.beq b r = false).
  case (RType.beq b r).
  left; reflexivity.
  right; reflexivity.
  destruct H. rewrite H.
  rewrite beq_nat_sym in H.
  rewrite H. simpl.
  destruct H0. rewrite H0.
  apply RType.beq_sym in H0.
  rewrite H0. reflexivity.
  rewrite H0. split.
  intro H1; inversion H1.
  intro H1. apply RType.beq_sym in H1.
  rewrite H0 in H1; inversion H1.
  rewrite beq_nat_sym with (n := n).
  rewrite H. simpl. reflexivity.
Qed.

Lemma beq_trans : forall x y z : ref, beq x y = true -> beq y z = true -> beq x z = true.
Proof.
  unfold beq.
  intros x y z H H'.
  induction x, y, z.
  apply Bool.andb_true_iff.
  apply Bool.andb_true_iff in H.
  apply Bool.andb_true_iff in H'.
  destruct H. destruct H'.
  split. apply beq_nat_trans with (n2 := n).
  assumption. assumption.
  apply RType.beq_trans with (y := r).
  assumption. assumption.
Qed.

Lemma eq_refl : forall r : ref, peq r r.
Proof.
  intro r.
  induction r.
  unfold peq.
  split.
  apply eq_nat_refl.
  unfold RType.peq.
  reflexivity.
Qed.

Lemma eq_sym : forall r1 r2 : ref, peq r1 r2 -> peq r2 r1.
Proof.
  intros r1 r2 H.
  induction r1.
  induction r2.
  unfold peq.
  unfold peq in H.
  destruct H.
  split.
  apply eq_nat_is_eq.
  apply eq_nat_is_eq in H.
  apply eq_sym.
  assumption.
  unfold RType.peq.
  unfold RType.peq in H0.
  apply eq_sym.
  assumption.
Qed.

Lemma eq_trans : forall r1 r2 r3 : ref, peq r1 r2 -> peq r2 r3 -> peq r1 r3.
Proof.
  intros r1 r2 r3 H H0.
  induction r1.
  induction r2.
  induction r3.
  unfold peq.
  unfold peq in H.
  destruct H.
  unfold peq in H0.
  destruct H0.
  split.
  apply eq_nat_is_eq.
  apply eq_nat_is_eq in H.
  apply eq_nat_is_eq in H0.
  rewrite H.
  assumption.
  unfold RType.peq.
  unfold RType.peq in H1.
  unfold RType.peq in H2.
  rewrite H1.
  assumption.
Qed.

Lemma alloc_eq_refl : forall a : alloc, alloc_peq a a.
Proof.
  intro a.
  induction a.
  unfold alloc_peq.
  auto.
  unfold alloc_peq.
  split.
  apply eq_refl.
  apply IHa.
Qed.

Lemma alloc_eq_sym : forall a1 a2 : alloc, alloc_peq a1 a2 -> alloc_peq a2 a1.
Proof.
  induction a1, a2.
  intro H; assumption.
  intro H; unfold alloc_peq in H; elim H.
  intro H; unfold alloc_peq in H; elim H.
  unfold alloc_peq.
  fold alloc_peq.
  intro H. destruct H.
  split.
  apply eq_sym.
  assumption.
  apply IHa1.
  assumption.
Qed.

Lemma alloc_eq_trans : forall a1 a2 a3 : alloc,
    alloc_peq a1 a2 -> alloc_peq a2 a3 -> alloc_peq a1 a3.
Proof.
  induction a1, a2, a3.
  intros H H0; assumption.
  intros H H0; assumption.
  intros H H0; apply alloc_eq_refl.
  intros H H0; unfold alloc_peq in H; elim H.
  intros H H0; unfold alloc_peq in H; elim H.
  intros H H0; unfold alloc_peq in H; elim H.
  intros H H0; unfold alloc_peq in H0; elim H0.
  unfold alloc_peq.
  fold alloc_peq.
  intros H H0. destruct H. destruct H0.
  split.
  apply eq_trans with (r2 := r).
  assumption. assumption.
  apply IHa1 with (a2 := a2).
  assumption. assumption.
Qed.

End Ref.

(*  ref_map  *)

Module ref_DT <: UsualDecidableType.
Definition t := Ref.ref.
Definition eq := @eq t. (*Ref.peq.*)
Definition eq_refl := @eq_refl t.
Definition eq_sym := @eq_sym t.
Definition eq_trans := @eq_trans t.
Definition eq_dec := Ref.eq_dec.
End ref_DT.

Module Rmap := FMapWeakList.Make ref_DT.

Lemma rmap_refl_1 : forall (t : Type) (eq : t -> t -> bool) e1,
    (forall t1, eq t1 t1 = true) -> Rmap.Equivb eq e1 e1.
Proof.
  intros t eq e1 H.
  unfold Smap.Equivb.
  unfold Smap.Raw.Equivb.
  split. intro k. split.
  intro; assumption.
  intro; assumption.
  intros k e e' H0 H1.
  apply Rmap.find_1 in H0.
  apply Rmap.find_1 in H1.
  rewrite H1 in H0. inversion H0.
  apply H.
Qed.
Lemma rmap_sym_1 : forall (t : Type) (eq : t -> t -> bool) e1 e2,
    (forall t1 t2, eq t1 t2 = true -> eq t2 t1 = true)
        -> Rmap.Equivb eq e1 e2 -> Rmap.Equivb eq e2 e1.
Proof.
  intros t eq e1 e2 H H0.
  unfold Smap.Equivb.
  unfold Smap.Raw.Equivb.
  unfold Smap.Equivb in H0.
  unfold Smap.Raw.Equivb in H0.
  destruct H0.
  split. intro k. split.
  intro; apply H0; assumption.
  intro; apply H0; assumption.
  intros k e e' H2 H3.
  assert (eq e' e = true).
  apply H1 with (k := k).
  assumption. assumption.
  apply H; assumption.
Qed.
Lemma rmap_trans_1 : forall (t : Type) (eq : t -> t -> bool) e1 e2 e3,
    (forall t1 t2 t3, eq t1 t2 = true -> eq t2 t3 = true -> eq t1 t3 = true)
        -> Rmap.Equivb eq e1 e2 -> Rmap.Equivb eq e2 e3 -> Rmap.Equivb eq e1 e3.
Proof.
  intros t eq e1 e2 e3 H H0 H1.
  unfold Smap.Equivb.
  unfold Smap.Raw.Equivb.
  unfold Smap.Equivb in H0.
  unfold Smap.Raw.Equivb in H0.
  unfold Smap.Equivb in H1.
  unfold Smap.Raw.Equivb in H1.
  destruct H0. destruct H1.
  split. intro k. split.
  intro; apply H1; apply H0; assumption.
  intro; apply H0; apply H1; assumption.
  intros k e e' H4 H5.
  assert (Rmap.Raw.PX.In k (Rmap.this e2)).
  apply H1. exists e'. assumption.
  destruct H6. assert (eq e x = true).
  apply H2 with (k := k).
  assumption. assumption.
  assert (eq x e' = true).
  apply H3 with (k := k).
  assumption. assumption.
  apply H with (t2 := x).
  assumption. assumption.
Qed.

Lemma rmap_refl_2 : forall (t : Type) (eq : t -> t -> bool) e1,
    (forall t1, eq t1 t1 = true) -> Rmap.equal eq e1 e1 = true.
Proof.
  intros t eq e1 H.
  apply Rmap.equal_1.
  apply rmap_refl_1.
  assumption.
Qed.
Lemma rmap_sym_2 : forall (t : Type) (eq : t -> t -> bool) e1 e2,
    (forall t1 t2, eq t1 t2 = true -> eq t2 t1 = true)
        -> Rmap.equal eq e1 e2 = true -> Rmap.equal eq e2 e1 = true.
Proof.
  intros t eq e1 e2 H H0.
  apply Rmap.equal_1.
  apply Rmap.equal_2 in H0.
  apply rmap_sym_1.
  assumption. assumption.
Qed.
Lemma rmap_trans_2 : forall (t : Type) (eq : t -> t -> bool) e1 e2 e3,
  (forall t1 t2 t3, eq t1 t2 = true -> eq t2 t3 = true -> eq t1 t3 = true)
    -> Rmap.equal eq e1 e2 = true -> Rmap.equal eq e2 e3 = true -> Rmap.equal eq e1 e3 = true.
Proof.
  intros t eq e1 e2 e3 H H0 H1.
  apply Rmap.equal_1.
  apply Rmap.equal_2 in H0.
  apply Rmap.equal_2 in H1.
  apply rmap_trans_1 with (e2 := e2).
  assumption. assumption. assumption.
Qed.

Lemma rmap_equal: forall (t : Type) (eq : t -> t -> bool),
    (forall e1 e2, eq e1 e2 = true <-> e1 = e2) ->
    (forall m1 m2, Rmap.equal eq m1 m2 = true <-> m1 = m2).
Proof.
  intros t eq H m1 m2.
Admitted.
Lemma rmap_inject: forall (t : Type) k (e1 e2 : t) m,
    Rmap.MapsTo k e1 m -> Rmap.MapsTo k e2 m -> e1 = e2.
Proof.
  intros t k e1 e2 m H H0.
  apply Rmap.find_1 in H.
  apply Rmap.find_1 in H0.
  rewrite H in H0. inversion H0.
  reflexivity.
Qed.
Lemma rmap_add: forall (t : Type) k (e1 e2 : t) m,
    Rmap.MapsTo k e1 (Rmap.add k e2 m) -> e1 = e2.
Proof.
  intros t k e1 e2 m H.
  assert (Rmap.MapsTo k e2 (Rmap.add k e2 m)).
  apply Rmap.add_1. reflexivity.
  apply rmap_inject with (k := k) (m := Rmap.add k e2 m).
  assumption. assumption.
Qed.

Close Scope list_scope.
Close Scope string_scope.

(*  Lemmas  *)

Lemma lr_trans : forall a b c, (a <-> b) -> (b <-> c) -> (a <-> c).
Proof. tauto. Qed.
Lemma notF_T : ~ False <-> True.
Proof. tauto. Qed.
Lemma conjl_T : forall P, True /\ P <-> P.
Proof. tauto. Qed.
Lemma conjr_T : forall P, P /\ True <-> P.
Proof. tauto. Qed.
Lemma conjl_F : forall P, False /\ P <-> False.
Proof. tauto. Qed.
Lemma conjr_F : forall P, P /\ False <-> False.
Proof. tauto. Qed.
Lemma disjl_F : forall P, False \/ P <-> P.
Proof. tauto. Qed.
Lemma disjr_F : forall P, P \/ False <-> P.
Proof. tauto. Qed.
Lemma conj_disj : forall P Q R, P /\ (Q \/ R) <-> P /\ Q \/ P /\ R.
Proof. tauto. Qed.
Lemma disj_asso : forall P Q R, (P \/ Q) \/ R <-> P \/ Q \/ R.
Proof. tauto. Qed.
Lemma disj_abs : forall P Q, P \/ P \/ Q <-> P \/ Q.
Proof. tauto. Qed.
Lemma disj_abs2 : forall P Q R, P \/ Q \/ P \/ R <-> P \/ Q \/ R.
Proof. tauto. Qed.
Lemma disj_abs3 : forall P Q R S, P \/ Q \/ R \/ P \/ S <-> P \/ Q \/ R \/ S.
Proof. tauto. Qed.
Lemma neq_eq : forall m s t : Method.method, m <> s /\ m = t <-> t <> s /\ m = t.
Proof. split; intros [H H0]; (split; [subst|]; assumption). Qed.

(*  Ltacs  *)

Ltac inductS i := let x := fresh "x" in let H := fresh "H" in
    assert ((exists Fv, i = Some Fv) \/ i = None) as H;
    [case i; [intro x; left; exists x; reflexivity | right; reflexivity] |
     destruct H as [H|H]; [destruct H as [x H]|]; try rewrite H].
Ltac propSimp H := repeat (rewrite neq_eq in H || rewrite notF_T in H ||
    rewrite conjl_T in H || rewrite conjr_T in H || rewrite conjl_F in H ||
    rewrite conjr_F in H || rewrite disjl_F in H || rewrite disjr_F in H ||
    rewrite conj_disj in H || rewrite disj_asso in H || rewrite disj_abs in H ||
    rewrite disj_abs2 in H || rewrite disj_abs3 in H).


Require Export deloop_to_BS.

(** Equivalence: formalization is not complete **)

Section equiv_deloop_to_BS.
Open Scope nat.
Let deloop := deloop.deloop.

Context `{Univalence}.

(** deloop_to_BS n is an equivalence if
ap (deloop_to_BSb) : (a = dlpt n) -> (deloop_to_BSb a = Finn n)
is an embedding for every a : deloop n **)

Theorem condition_equiv_deloop_to_BS (n : nat)
  : (forall (a : deloop n) (p : deloop_to_BSb n a = FFin n), {q : a = dlpt n & ap (deloop_to_BSb n) q = p}) ->
    IsEquiv (deloop_to_BS n).
Proof.
  intro h.
  srapply @isequiv_fcontr.  (* to show that it is an equivalence, we can check that the all fibers are contractible *)
  refine (forall_BS_hprop n _ _ (deloop_to_BS n (dlpt n)) _); (* since BS n.+2 is connected, we can verify only selected fibers *)
  hnf.
  srapply @contr_sigma_prop; (* since the family is of paths in a sigma-type with contractible fibers, we ignore those *)
  change (Contr {a : deloop n & deloop_to_BSb n a = FFin n}).
  srapply @Build_Contr.
  { exact (dlpt n; idpath). } (* center of contraction *)
  (* we need the proof of contraction *)
  intros [a p]. symmetry. srapply @path_sigma; simpl.
  + exact (h a p).1.
  + refine (@transport_paths_Fl (deloop n) _ (deloop_to_BSb n) _ _ (FFin n) (h a p).1 p @ _);
    apply moveR_Vp; refine (_ @ (concat_p1 _)^).
    exact (h a p).2^.
Defined.

(** in order to verify the embedding, we can use the elimination principle of deloop **)

  Lemma conditions_equiv_deloop_to_BS_b_dltw
    (eib : forall (n : nat) (a : deloop n), (deloop_to_BSb n a = FFin n -> a = dlpt n) -> deloop_to_BSb n.+1 (dli a) = FFin n.+1 -> dli a = dlpt n.+1)
    (etwb : forall (n : nat) (a' : deloop_to_BSb n (dlpt n) = FFin n -> dlpt n = dlpt n) (p : FFin n.+2 = FFin n.+2),
      eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') (gamma (FFin n) @ p)
      = dltw (dlpt n) @ eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') p)
    : forall (n : nat) (a : deloop.deloop n) (a' : deloop_to_BSb n a = FFin n -> a = dlpt n), transport (fun a0 : deloop n.+2 => deloop_to_BSb n.+2 a0 = FFin n.+2 -> a0 = dlpt n.+2) (dltw a) (eib n.+1 (dli a) (eib n a a')) = eib n.+1 (dli a) (eib n a a').
  Proof.
    intros. by_extensionality p.
    refine (@transport_forall_fun_path_idmap_l_const_r (deloop n.+2) (fun a => deloop_to_BSb n.+2 a = FFin n.+2) (dlpt n.+2) _ _ (dltw a) _ p @ _); apply moveR_Vp.
    refine (ap (eib n.+1 (dli a) (eib n a a')) (@transport_paths_Fl (deloop n.+2) _ (deloop_to_BSb n.+2) _ _ _ (dltw a)^ p @ whiskerR (ap inverse (ap_V _ _) @ inv_V _ @ ap_deloop_to_BSb_dltw a) _) @ _).
    revert p; revert a'; revert a.
    assert (T : forall a : deloop n, IsHProp (forall (a' : deloop_to_BSb n a = FFin n -> a = dlpt n) (p : deloop_to_BSb n.+2 (dli (dli a)) = FFin n.+2), eib n.+1 (dli a) (eib n a a') (gamma (deloop_to_BSb n a) @ p) = dltw a @ eib n.+1 (dli a) (eib n a a') p)).
    { intros. enough (forall (a' : deloop_to_BSb n a = FFin n -> a = dlpt n) (p : deloop_to_BSb n.+2 (dli (dli a)) = FFin n.+2), IsHProp (eib n.+1 (dli a) (eib n a a') (gamma (deloop_to_BSb n a) @ p) = dltw a @ eib n.+1 (dli a) (eib n a a') p)). { srapply @trunc_forall. }
      intros. srapply @istrunc_paths. srapply @istrunc_paths. apply dlT. }
    srefine (@conn_to_prop _ (deloop n) (Connected_deloopn n) _ T (dlpt n) _); hnf.
    exact (etwb n).
  Qed.

  Definition conditions_equiv_deloop_to_BS_b
  (e0b : deloop_to_BSb 0 dlpt0 = FFin 0 -> dlpt0 = dlpt 0)
  (eib : forall (n : nat) (a : deloop n) (ihb : deloop_to_BSb n a = FFin n -> a = dlpt n), deloop_to_BSb n.+1 (dli a) = FFin n.+1 -> dli a = dlpt n.+1)
  (etwb : forall (n : nat) (a' : deloop_to_BSb n (dlpt n) = FFin n -> dlpt n = dlpt n) (p : FFin n.+2 = FFin n.+2),
    eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') (gamma (FFin n) @ p)
    = dltw (dlpt n) @ eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') p)
    : forall (n : nat) (a : deloop n), deloop_to_BSb n a = FFin n -> a = dlpt n.
  Proof.
    assert (T : forall n a, IsHSet (deloop_to_BSb n a = FFin n -> a = dlpt n)).
    { intros. enough (deloop_to_BSb n a = FFin n -> IsHSet (a = dlpt n)). { apply trunc_forall. }
      intros. srapply @istrunc_paths. apply dlT. }
    srefine (deloop_ind_to_set _ e0b eib (conditions_equiv_deloop_to_BS_b_dltw eib etwb) T).
  Defined.

Lemma conditions_equiv_deloop_to_BS
  (e0b : deloop_to_BSb 0 dlpt0 = FFin 0 -> dlpt0 = dlpt 0)
  (eib : forall (n : nat) (a : deloop n) (ihb : deloop_to_BSb n a = FFin n -> a = dlpt n), deloop_to_BSb n.+1 (dli a) = FFin n.+1 -> dli a = dlpt n.+1)
  (etwb : forall (n : nat) (a' : deloop_to_BSb n (dlpt n) = FFin n -> dlpt n = dlpt n) (p : FFin n.+2 = FFin n.+2),
    eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') (gamma (FFin n) @ p)
    = dltw (dlpt n) @ eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') p)
  (e0f : forall p, ap (deloop_to_BSb 0) (e0b p) = p)
  (eif : forall (n : nat) (a : deloop n) (ihb : deloop_to_BSb n a = FFin n -> a = dlpt n) (ihf : forall (p : deloop_to_BSb n a = FFin n), ap (deloop_to_BSb n) (ihb p) = p) (p : deloop_to_BSb n.+1 (dli a) = FFin n.+1), ap (deloop_to_BSb n.+1) (eib n a ihb p) = p)
  : forall (n : nat), IsEquiv (deloop_to_BS n).
Proof.
  intro n. apply condition_equiv_deloop_to_BS; revert n.
  enough (e' : {eb : forall (n : nat) (a : deloop n), deloop_to_BSb n a = FFin n -> a = dlpt n & forall (n : nat) (a : deloop n) (p : deloop_to_BSb n a = FFin n), ap (deloop_to_BSb n) (eb n a p) = p}).
  { intros n a p. exact (e'.1 n a p; e'.2 n a p). }
  srefine (_; _).
  + exact (conditions_equiv_deloop_to_BS_b e0b eib etwb).
  + simpl. assert (T : forall n a, IsHProp (forall p : deloop_to_BSb n a = FFin n, ap (deloop_to_BSb n) (conditions_equiv_deloop_to_BS_b e0b eib etwb n a p) = p)).
    { intros. enough (forall p, IsHProp (ap (deloop_to_BSb n) (conditions_equiv_deloop_to_BS_b e0b eib etwb n a p) = p)).
      { srapply @trunc_forall. } intros. apply IsHProp_path2_in_BS_type. }
    srefine (deloop_ind_to_prop _ e0f _ T); hnf.
    intros. exact (eif n a (conditions_equiv_deloop_to_BS_b e0b eib etwb n a) a' p).
Defined.

(** Proofs of lemmas relative to dlpt0 **)

Definition e0b
  : deloop_to_BSb 0 dlpt0 = FFin 0 -> dlpt0 = dlpt 0
  := fun _ => idpath.

Definition e0f
  : forall p, ap (deloop_to_BSb 0) (e0b p) = p.
Proof.
  intros; simpl. srapply @path_ishprop.
Defined.

(** Combinatorics relative to dli **)

Arguments equiv_path {_} {_} _.

Definition move {n : nat}
  : FFin n -> FFin n = FFin n.
Proof.
  intro i; induction n.
  + exact idpath.
  + clear IHn. induction n.
    - exact idpath.
    - clear IHn. change (FFin n.+1 + Unit)%type in i. induction i as [j|[]].
      * induction n.
        ++ exact (gamma Empty).
        ++ change (FFin n.+1 + Unit)%type in j. induction j as [k|[]].
          -- exact (gamma (FFin n.+1) @ ap add (IHn k) @ gamma (FFin n.+1)).
          -- exact (gamma (FFin n.+1)).
      * exact idpath.
Defined.

Lemma move_inr_tt {n : nat}
  : @move n.+1 (inr tt) = idpath.
Proof.
  induction n; constructor.
Qed.

Lemma move_do' {n : nat} (i : FFin n)
  : (move i)^ = move i.
Proof.
  induction n.
  + simpl. constructor.
  + clear IHn. induction n.
    - simpl. constructor.
    - clear IHn. change (FFin n.+1 + Unit)%type in i; induction i as [j|[]].
      * induction n.
        ++ simpl. apply gamma_double'.
        ++ change (FFin n.+1 + Unit)%type in j; induction j as [k|[]].
          -- change ((gamma (FFin n.+1) @ ap add (@move n.+2 (inl k)) @ gamma (FFin n.+1))^ = gamma (FFin n.+1) @ ap add (@move n.+2 (inl k)) @ gamma (FFin n.+1)).
             refine (inv_pp _ _ @ concat2 (gamma_double' _) (inv_pp _ _ @ concat2 ((ap_V _ _)^ @ ap (ap add) _) (gamma_double' _)) @ concat_p_pp _ _ _).
             apply IHn.
          -- simpl. apply gamma_double'.
      * simpl. constructor.
Defined.

Lemma move_do {n : nat} (i : FFin n)
  : move i @ move i = idpath.
Proof.
  exact (whiskerL _ (move_do' i)^ @ concat_pV _).
Defined.

Lemma equiv_path_move_i_move_i {n : nat} (i : FFin n)
  : equiv_path (move i @ move i) = 1%equiv.
Proof.
  exact (ap equiv_path (move_do i)).
Defined.

Lemma equiv_path_move_i_i {n : nat} (i : FFin n.+1)
  : equiv_path (move i) i = inr tt.
Proof.
  induction n.
  - simpl. induction i as [[]|[]]. constructor.
  - clear IHn. change (FFin n.+1 + Unit)%type in i; induction i as [j|[]].
    * induction n.
      ++ simpl. rewrite (transport_idmap_path_universe (omega Empty)).
         induction j as [[]|[]]. constructor.
      ++ change (FFin n.+1 + Unit)%type in j; induction j as [k|[]].
        -- change (equiv_path (gamma (FFin n.+1) @ ap add (@move n.+2 (inl k)) @ gamma (FFin n.+1)) (inl (inl k)) = inr tt).
           repeat rewrite equiv_path_pp; unfold gamma.
           repeat rewrite (eisretr equiv_path).
           rewrite equiv_path_ap_add.
           change (omega (FFin n.+1) (exp (equiv_path (@move n.+2 (inl k))) (omega (FFin n.+1) (inl (inl k)))) = inr tt).
           change (omega (FFin n.+1) (exp (equiv_path (@move n.+2 (inl k))) (inl (inl k))) = inr tt).
           change (omega (FFin n.+1) (inl (equiv_path (@move n.+2 (inl k)) (inl k))) = inr tt).
           rewrite IHn.
           constructor.
        -- simpl. rewrite (transport_idmap_path_universe (omega (FFin n.+1))). constructor.
    * simpl. constructor.
Qed.

Definition path_last {A n} (p : (A + Unit)%type = FFin n.+1)
  : FFin n.+1
  := equiv_path p (inr tt).

Definition path_second_last {A n} (p : (A + Unit + Unit)%type = FFin n.+2)
  : FFin n.+2
  := equiv_path p (inl (inr tt)).

Definition path_last_ne_path_second_last {A n} (p : (A + Unit + Unit)%type = FFin n.+2)
  : path_last p = path_second_last p -> Empty.
Proof.
  refine (equiv_diff (equiv_path p) _).
  apply inr_ne_inl.
Defined.

Lemma path_last_gamma_p {A n} (p : (A + Unit + Unit)%type = FFin n.+2)
  : path_last (gamma A @ p) = path_second_last p.
Proof.
  unfold path_last. rewrite equiv_path_pp.
  change (equiv_path p (equiv_path (gamma A) (inr tt)) = path_second_last p).
  rewrite (eisretr equiv_path _). constructor.
Defined.

Lemma path_second_last_gamma_p {A n} (p : (A + Unit + Unit)%type = FFin n.+2)
  : path_second_last (gamma A @ p) = path_last p.
Proof.
  unfold path_second_last. rewrite equiv_path_pp.
  change (equiv_path p (equiv_path (gamma A) (inl (inr tt))) = path_last p).
  rewrite (eisretr equiv_path _). constructor.
Defined.

Lemma pre_reduce_last {A n} (p : (A + Unit)%type = FFin n.+1)
  : equiv_path (p @ move (path_last p)) (inr tt) = inr tt.
Proof.
  rewrite equiv_path_pp.
  change (equiv_path (move (path_last p)) (path_last p) = inr tt).
  srapply equiv_path_move_i_i.
Qed.

Definition reduce {A n} (p : (A + Unit)%type = FFin n.+1)
  : A = FFin n.
Proof.
  refine (path_universe_uncurried (restriction (equiv_path (p @ move (path_last p))) _)).
  apply pre_reduce_last.
Defined.

Lemma reduce_add {A n} (p : A = FFin n)
  : reduce (ap add p) = p.
Proof.
  unfold reduce, path_last.
  assert (h : equiv_path (ap add p @ @move n.+1 (equiv_path (ap add p) (inr tt))) = exp (equiv_path p)).
  { refine (_ @ equiv_path_ap_add _); apply ap.
    refine (_ @ concat_p1 _); apply whiskerL.
    rewrite equiv_path_ap_add.
    change (@move n.+1 (inr tt) = idpath).
    apply move_inr_tt. }
  refine (ap path_universe_uncurried (restriction_invariant _ _ (pre_reduce_last (ap add p)) h) @ _).
  refine (_ @ eissect equiv_path p); apply (ap path_universe_uncurried).
  refine (_ @ restriction_exp (equiv_path p)).
  apply restriction_invariant_p.
Qed.

Lemma ap_add_reduce {A n} (p : (A + Unit)%type = FFin n.+1)
  : ap add (reduce p) = p @ @move n.+1 (path_last p).
Proof.
  unfold reduce.
  refine (ap_add_ua _ @ _ @ eissect equiv_path _); apply (ap path_universe_uncurried).
  apply exp_restriction.
Defined.

Definition movedel {n : nat}
  : FFin n -> dlpt n = dlpt n.
Proof.
  intro i; induction n.
  + exact idpath.
  + clear IHn. induction n.
    - exact idpath.
    - clear IHn. change (FFin n.+1 + Unit)%type in i. induction i as [j|[]].
      * induction n.
        ++ exact (dltw dlpt0).
        ++ change (FFin n.+1 + Unit)%type in j. induction j as [k|[]].
          -- exact (dltw (dlpt n.+1) @ ap dli (IHn k) @ dltw (dlpt n.+1)).
          -- exact (dltw (dlpt n.+1)).
      * exact idpath.
Defined.

Lemma ap_deloop_to_BSb_movedel {n} (i : FFin n)
  : ap (deloop_to_BSb n) (movedel i) = move i.
Proof.
  induction n.
  + constructor.
  + clear IHn. induction n.
    - constructor.
    - clear IHn. change (FFin n.+1 + Unit)%type in i. induction i as [j|[]].
      * induction n.
        ++ exact (ap_deloop_to_BSb_dltw dlpt0).
        ++ change (FFin n.+1 + Unit)%type in j. induction j as [k|[]].
          -- change (ap (deloop_to_BSb n.+3) (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl k)) @ dltw (dlpt n.+1)) = gamma (FFin n.+1) @ ap add (@move n.+2 (inl k)) @ gamma (FFin n.+1)).
             refine (ap_pp _ _ _ @ whiskerR (ap_pp _ _ _) _ @ concat2 (concat2 (ap_deloop_to_BSb_dltw (dlpt n.+1)) _) (ap_deloop_to_BSb_dltw (dlpt n.+1))).
             refine (ap_deloop_to_BSb_ap_dli (@movedel n.+2 (inl k)) @ _); apply ap.
             exact (IHn k).
          -- exact (ap_deloop_to_BSb_dltw (dlpt n.+1)).
      * constructor.
Defined.

(** Proofs of lemmas relative to dli **)

Definition eib
  : forall (n : nat) (a : deloop n)
    (ihb : deloop_to_BSb n a = FFin n -> a = dlpt n),
    deloop_to_BSb n.+1 (dli a) = FFin n.+1 -> dli a = dlpt n.+1.
Proof.
  intros n a ihb p.
  exact (ap dli (ihb (reduce p)) @ @movedel n.+1 (path_last p)).
Defined.

Definition eif
  : forall (n : nat) (a : deloop n)
    (ihb : deloop_to_BSb n a = FFin n -> a = dlpt n)
    (ihf : forall (p : deloop_to_BSb n a = FFin n), ap (deloop_to_BSb n) (ihb p) = p)
    (p : deloop_to_BSb n.+1 (dli a) = FFin n.+1),
    ap (deloop_to_BSb n.+1) (eib n a ihb p) = p.
Proof.
  intros. unfold eib.
  refine (ap_pp _ _ _ @ _).
  rewrite ap_deloop_to_BSb_ap_dli.
  rewrite (ihf (reduce p)).
  rewrite ap_add_reduce.
  refine (concat_pp_p _ _ _ @ _ @ concat_p1 _); apply whiskerL.
  rewrite <- (move_do' _); apply moveR_Vp; refine (_ @ (concat_p1 _)^).
  srapply ap_deloop_to_BSb_movedel.
Qed.

(** Combinatorics relative to dltw **)

Lemma movedel_do {n : nat} (i : FFin n)
  : movedel i @ movedel i = idpath.
Proof.
  induction n.
  + simpl. constructor.
  + clear IHn. induction n.
    - simpl. constructor.
    - clear IHn. change (FFin n.+1 + Unit)%type in i; induction i as [j|[]].
      * induction n.
        ++ simpl. apply dldo.
        ++ change (FFin n.+1 + Unit)%type in j; induction j as [k|[]].
          -- change ((dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl k)) @ dltw (dlpt n.+1)) @ (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl k)) @ dltw (dlpt n.+1)) = idpath).
             exact (whiskerL _ (concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _ @ whiskerL _ (dldo _) @ concat_p1 _) _ @ concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _ @ whiskerL _ ((ap_pp dli _ _)^ @ ap (ap dli) (IHn k)) @ concat_p1 _) _ @ dldo _).
          -- simpl. apply dldo.
      * simpl. constructor.
Defined.

Lemma movedel_do' {n : nat} (i : FFin n)
  : (movedel i)^ = movedel i.
Proof.
  refine ((concat_p1 _)^ @ _); apply moveR_Vp; exact (movedel_do _)^.
Defined.

Lemma movedel_br {n} (i : FFin n)
  : dltw (dlpt n) @ ap dli (@movedel n.+1 (inl i)) @ dltw (dlpt n)
    = ap dli (@movedel n.+1 (inl i)) @ dltw (dlpt n) @ ap dli (@movedel n.+1 (inl i)).
Proof.
  induction n.
  + induction i.
  + change (FFin n + Unit)%type in i. induction i as [j|[]].
    - induction n.
      * apply dlbr.
      * clear IHn0.
        change ((dltw (dlpt n.+2) @ ap dli (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl j)) @ dltw (dlpt n.+1))) @ dltw (dlpt n.+2) = (ap dli (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl j)) @ dltw (dlpt n.+1)) @ dltw (dlpt n.+2)) @ ap dli (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl j)) @ dltw (dlpt n.+1))).
        repeat rewrite ap_pp.
        refine (whiskerR (concat_p_pp _ _ _ @ whiskerR (concat_p_pp _ _ _ @ whiskerR ((concat_p1 _)^ @ whiskerL _ (dldo (dlpt n.+2))^ @ concat_p_pp _ _ _) _ @ concat_pp_p _ _ _) _ @ concat_pp_p _ _ _) _ @ _).
        refine (whiskerR (whiskerL _ (whiskerR (dltw_natural (@movedel n.+2 (inl j)))^ _)) _ @ _).
        refine (whiskerR (whiskerR (dlbr (dlpt n.+1)) _ @ concat_p_pp _ _ _) _ @ concat_pp_p _ _ _ @ whiskerR (concat_p_pp _ _ _) _ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _ @ dlbr (dlpt n.+1)) @ _).
        refine (whiskerL _ (concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ whiskerL _ (whiskerL _ (ap_pp dli _ _)^ @ (ap_pp dli _ _)^ @ ap (ap dli) (concat_p_pp _ _ _ @ IHn j) @ ap_pp dli _ _ @ whiskerR (ap_pp dli _ _) _)) _ @ _).
        refine (whiskerR (concat_pp_p _ _ _ @ whiskerL _ (whiskerL _ (concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ whiskerR (dltw_natural (@movedel n.+2 (inl j)))^ _ @ concat_p_pp _ _ _) @ concat_p_pp _ _ _) _ @ concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _ @ whiskerL _ (dltw_natural (@movedel n.+2 (inl j)))) _ @ _).
        refine (whiskerR (concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _ @ whiskerL _ (concat_pp_p _ _ _ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _ @ dlbr (dlpt n.+1)))) _) _ @ _).
        repeat rewrite concat_pp_p. constructor.
    - induction n; apply dlbr.
Qed.

Definition last_reduce_w {n} (i j : FFin n.+2) (d : i = j -> Empty)
  : FFin n.+1.
Proof.
  induction n.
  + exact (inr tt).
  + change (FFin n + Unit + Unit + Unit)%type in i, j.
    induction i as [[i|[]]|[]].
    - induction j as [[j|[]]|[]].
      * exact (inl (IHn (inl i) (inl j) (fun p => d (ap inl p)))).
      * exact (inr tt).
      * exact (inl i).
    - induction j as [[j|[]]|[]].
      * exact (inl j).
      * induction (d idpath).
      * exact (inr tt).
    - induction j as [j|[]].
      * exact j.
      * induction (d idpath).
Defined.

Lemma last_reduce_w_inl_i_inr_tt {n} (i : FFin n.+1)
  : last_reduce_w (inl i) (inr tt) (inl_ne_inr i tt) = i.
Proof.
  induction n.
  + induction i as [[]|[]]; constructor.
  + change (FFin n + Unit + Unit)%type in i.
    induction i as [[i|[]]|[]]; constructor.
Defined.

Lemma last_reduce_w_d {n} (i j : FFin n.+2) (d d' : i = j -> Empty)
  : last_reduce_w i j d = last_reduce_w i j d'.
Proof.
  apply ap. apply path_forall. intro z. induction (d z).
Defined.

Lemma last_reduce_w_pq {n} {i i' j j' : FFin n.+2}
  (p : i = i') (q : j = j')
  (d : i = j -> Empty)
  : last_reduce_w i j d = last_reduce_w i' j' (fun z : i' = j' => d (p @ z @ q^)).
Proof.
  induction p, q; simpl.
  apply last_reduce_w_d.
Defined.

Lemma equiv_path_move_i_j {n} (i j : FFin n.+2) (d : i = j -> Empty)
  : equiv_path (@move n.+2 i) j = inl (last_reduce_w i j d).
Proof.
  change (FFin n.+1 + Unit)%type in i, j.
  induction i as [i|[]].
  * induction n.
    ++ simpl. rewrite (transport_idmap_path_universe_uncurried (omega Empty)).
       induction i as [[]|[]]; induction j as [[[]|[]]|[]].
       +++ induction (d idpath).
       +++ constructor.
    ++ change (FFin n.+1 + Unit)%type in i. induction i as [i|[]].
      -- change (equiv_path (gamma (FFin n.+1) @ ap add (@move n.+2 (inl i)) @ gamma (FFin n.+1)) j = inl (@last_reduce_w n.+1 (inl (inl i)) j d)).
         repeat rewrite equiv_path_pp.
         rewrite equiv_path_ap_add.
         change (transport idmap (gamma (FFin n.+1)) (exp (equiv_path (@move n.+2 (inl i))) (transport idmap (gamma (FFin n.+1)) j)) = inl (@last_reduce_w n.+1 (inl (inl i)) j d)).
         repeat rewrite (transport_idmap_path_universe_uncurried (omega (FFin n.+1))).
         change (FFin n.+1 + Unit + Unit)%type in j. induction j as [[j|[]]|[]].
        --- change (omega (FFin n.+1) (inl (equiv_path (@move n.+2 (inl i)) (inl j))) = inl (@last_reduce_w n.+1 (inl (inl i)) (inl (inl j)) d)).
            rewrite (IHn i (inl j) (fun p => d (ap inl p))). constructor.
        --- constructor.
        --- change (omega (FFin n.+1) (inl ((equiv_path (@move n.+2 (inl i))) (inr tt))) = inl (@last_reduce_w n.+1 (inl (inl i)) (inr tt) d)).
            rewrite (IHn i (inr tt) (inl_ne_inr i tt)). simpl.
            apply ap. apply ap.
            apply last_reduce_w_inl_i_inr_tt.
      -- change (transport idmap (gamma (FFin n.+1)) j = inl (@last_reduce_w n.+1 (inl (inr tt)) j d)).
         rewrite (transport_idmap_path_universe_uncurried (omega (FFin n.+1))).
         change (FFin n.+1 + Unit + Unit)%type in j. induction j as [[j|[]]|[]]; simpl.
        --- constructor.
        --- induction (d idpath).
        --- constructor.
  * simpl. induction n.
    ++ induction j as [[[]|[]]|[]]; simpl.
      -- constructor.
      -- induction (d idpath).
    ++ change (FFin n.+1 + Unit + Unit)%type in j. induction j as [[j|[]]|[]]; simpl.
      -- constructor.
      -- constructor.
      -- induction (d idpath).
Qed.

Lemma last_reduce {n} (a : deloop n) (p : deloop_to_BSb n.+2 (dli (dli a)) = FFin n.+2)
  : path_last (reduce p) = last_reduce_w (path_last p) (path_second_last p) (path_last_ne_path_second_last p).
Proof.
  srefine (@coproduct_paths_l _ Unit _ _ _).
  refine (_ @ equiv_path_move_i_j _ _ _).
  unfold path_second_last.
  change (inl (path_last (reduce p)) = (equiv_path (move (path_last p)) oE (equiv_path p)) (inl (inr tt))).
  rewrite <- equiv_path_pp.
  unfold path_last.
  unfold reduce.
  rewrite (eisretr equiv_path).
  refine (inl_un_inl _ _).
Qed.

Lemma Assumption_1 {n} (p : FFin n.+2 = FFin n.+2)
  (h : path_last p = inr tt)
  : reduce p = reduce (gamma (FFin n) @ p).
Proof.
Admitted.

Lemma Assumption_2 {n} (p : FFin n.+2 = FFin n.+2)
  (h : path_last p = inl (inr tt)) (h' : {j : FFin n & path_second_last p = inl (inl j)})
  : reduce (reduce p) = reduce (reduce (gamma (FFin n) @ p)).
Proof.
Admitted.

Lemma Assumption_3 (n : nat)
  (a' : deloop_to_BSb n.+1 (dlpt n.+1) = FFin n.+1 -> dlpt n.+1 = dlpt n.+1)
  (p : FFin n.+3 = FFin n.+3)
  (i : FFin n.+1) (hi : path_last p = inl (inl i))
  (j : FFin n.+1) (hj : path_second_last p = inl (inl j))
  (IHn : forall (a' : FFin n = FFin n -> dlpt n = dlpt n) (p : FFin n.+2 = FFin n.+2)
      (i : FFin n.+2) (hi : path_last p = i)
      (j : FFin n.+2) (hj : path_second_last p = j),
      ap dli (ap dli (a' (reduce (reduce (gamma (FFin n) @ p))))) @ (ap dli (@movedel n.+1 (path_last (reduce (gamma (FFin n) @ p)))) @ @movedel n.+2 j)
      = ap dli (ap dli (a' (reduce (reduce p)))) @ (dltw (dlpt n) @ (ap dli (@movedel n.+1 (path_last (reduce p))) @ @movedel n.+2 i)))
  : ap dli (ap dli (a' (reduce (reduce (gamma (FFin n.+1) @ p))))) @ (ap dli (@movedel n.+2 (path_last (reduce (gamma (FFin n.+1) @ p)))) @ @movedel n.+3 (inl (inl j)))
  = ap dli (ap dli (a' (reduce (reduce p)))) @ (dltw (dlpt n.+1) @ (ap dli (@movedel n.+2 (path_last (reduce p))) @ @movedel n.+3 (inl (inl i)))).
Proof.
Admitted.

(** Proof of lemma relative to dltw **)

  Lemma etwb_2_reduce_reduce (p : FFin 2 = FFin 2)
    : reduce (reduce (gamma Empty @ p)) = reduce (reduce p).
  Proof.
    srapply @path_ishprop.
  Qed.

  Lemma etwb_2_reduce_last (p : FFin 2 = FFin 2)
    : path_last (reduce p) = inr tt.
  Proof.
    exact (last_reduce (dlpt 0) p).
  Qed.

  Lemma etwb_2_reduce_gamma_p_last (p : FFin 2 = FFin 2)
    : path_last (reduce (gamma Empty @ p)) = inr tt.
  Proof.
    exact (last_reduce (dlpt 0) _).
  Qed.

  Lemma etwb_3_inr_tt_inl_inr_tt_reduce_p_last {n} (p : FFin n.+3 = FFin n.+3)
    (hi : path_last p = inr tt) (hj : path_second_last p = inl (inr tt))
    : path_last (reduce p) = inr tt.
  Proof.
    refine (last_reduce (dlpt n.+1) p @ _).
    exact (last_reduce_w_pq hi hj _).
  Qed.

  Lemma etwb_3_inr_tt_inl_inl_j_reduce_p_last {n} (j : FFin n.+1) (p : FFin n.+3 = FFin n.+3)
    (hi : path_last p = inr tt) (hj : path_second_last p = inl (inl j))
    : path_last (reduce p) = inl j.
  Proof.
    refine (last_reduce (dlpt n.+1) p @ _).
    exact (last_reduce_w_pq hi hj _).
  Qed.

  Lemma etwb_3_inl_inr_tt_inl_inl_j_reduce_p_last {n} (j : FFin n.+1) (p : FFin n.+3 = FFin n.+3)
    (hi : path_last p = inl (inr tt)) (hj : path_second_last p = inl (inl j))
    : path_last (reduce p) = inl j.
  Proof.
    refine (last_reduce (dlpt n.+1) p @ _).
    exact (last_reduce_w_pq hi hj _).
  Qed.

  Lemma etwb_3_inl_inr_tt_inl_inl_j_reduce_gamma_p_last {n} (j : FFin n.+1) (p : FFin n.+3 = FFin n.+3)
    (hi : path_last p = inl (inr tt)) (hj : path_second_last p = inl (inl j))
    : path_last (reduce (gamma (FFin n.+1) @ p)) = inr tt.
  Proof.
    refine (last_reduce (dlpt n.+1) (gamma (FFin n.+1) @ p) @ _).
    exact (last_reduce_w_pq (path_last_gamma_p p @ hj) (path_second_last_gamma_p p @ hi) _).
  Qed.

Definition etwb
  : forall (n : nat) (a' : deloop_to_BSb n (dlpt n) = FFin n -> dlpt n = dlpt n)
    (p : FFin n.+2 = FFin n.+2),
    eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') (gamma (FFin n) @ p)
    = dltw (dlpt n) @ eib n.+1 (dli (dlpt n)) (eib n (dlpt n) a') p.
Proof.
  intros.
  unfold eib. repeat rewrite ap_pp.
  rewrite path_last_gamma_p.
  refine (_ @ whiskerR (whiskerR (dltw_natural (a' (reduce (reduce p)))) _ @ concat_pp_p _ _ _) _ @ concat_pp_p _ _ _).
  repeat rewrite concat_pp_p.
  remember (path_last p) as i eqn:hi.
  remember (path_second_last p) as j eqn:hj.
  rewrite hi, hj.
  change (FFin n + Unit + Unit)%type in i, j.
  induction n.
  + rewrite etwb_2_reduce_reduce, etwb_2_reduce_gamma_p_last, etwb_2_reduce_last.
    apply whiskerL. refine (concat_1p _ @ _ @ whiskerL _ (concat_1p _)^).
    induction i as [[[]|[]]|[]]; induction j as [[[]|[]]|[]]; try induction (path_last_ne_path_second_last p (hi @ hj^)).
    - simpl. exact (dldo dlpt0)^.
    - simpl. exact (concat_p1 _)^.
  + induction i as [[i|[]]|[]]; induction j as [[j|[]]|[]].
    all:try induction (path_last_ne_path_second_last p (hi @ hj^)).
    - (* case (vii), not formalized *)
      exact (Assumption_3 n a' p i hi j hj IHn).
    - (* case (vi), similar to case (iv) *)
      refine (_ @ whiskerR (ap (ap dli) (ap (ap dli) (ap a' (ap reduce (ap reduce (concat_p_pp _ _ _ @ whiskerR (gamma_double (FFin n.+1)) p @ concat_1p p)))))) _).
      refine (_ @ whiskerL _ (whiskerL _ (whiskerR (ap (ap dli) (ap (@movedel n.+2) (ap path_last (ap reduce (concat_p_pp _ _ _ @ whiskerR (gamma_double (FFin n.+1)) p @ concat_1p p))))) _))).
      set (q := gamma (FFin n.+1) @ p).
      set (ki := @path_last_gamma_p (FFin n.+1) n.+1 p @ hj : path_last q = inl (inr tt)).
      set (kj := @path_second_last_gamma_p (FFin n.+1) n.+1 p @ hi : path_second_last q = inl (inl i)).
      rewrite <- (@Assumption_2 n.+1 q ki (i; kj)).
      rewrite (etwb_3_inl_inr_tt_inl_inl_j_reduce_p_last i q ki kj).
      rewrite (etwb_3_inl_inr_tt_inl_inl_j_reduce_gamma_p_last i q ki kj).
      apply whiskerL. change (ap dli (@movedel n.+2 (inl i)) @ dltw (dlpt n.+1) = dltw (dlpt n.+1) @ (idpath @ (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl i)) @ dltw (dlpt n.+1)))).
      refine (_ @ concat_pp_p _ _ _ @ concat_pp_p _ _ _); apply whiskerR.
      refine ((concat_1p _)^ @ whiskerR _ _ @ concat_pp_p _ _ _).
      refine ((dldo (dlpt n.+1))^ @ whiskerR (concat_p1 _)^ _).
    - (* case (v), similar to case (ii) *)
      refine (_ @ whiskerR (ap (ap dli) (ap (ap dli) (ap a' (ap reduce (ap reduce (concat_p_pp _ _ _ @ whiskerR (gamma_double (FFin n.+1)) p @ concat_1p p)))))) _).
      refine (_ @ whiskerL _ (whiskerL _ (whiskerR (ap (ap dli) (ap (@movedel n.+2) (ap path_last (ap reduce (concat_p_pp _ _ _ @ whiskerR (gamma_double (FFin n.+1)) p @ concat_1p p))))) _))).
      set (q := gamma (FFin n.+1) @ p).
      set (ki := @path_last_gamma_p (FFin n.+1) n.+1 p @ hj : path_last q = inr tt).
      set (kj := @path_second_last_gamma_p (FFin n.+1) n.+1 p @ hi : path_second_last q = inl (inl i)).
      rewrite <- (@Assumption_1 n.+1 q ki).
      repeat rewrite (etwb_3_inr_tt_inl_inl_j_reduce_p_last i q ki kj).
      apply whiskerL.
      refine (concat_p1 _ @ _).
      change (ap dli (@movedel n.+2 (inl i)) = dltw (dlpt n.+1) @ (ap dli (@movedel n.+2 (inl i)) @ (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl i)) @ dltw (dlpt n.+1)))).
      refine (_ @ concat_p_pp _ _ _ @ whiskerR (movedel_br i @ concat_pp_p _ _ _)^ _ @ concat_pp_p _ _ _ @ whiskerL _ (concat_p_pp _ _ _) @ concat_pp_p _ _ _).
      refine ((concat_p1 _)^ @ _); apply whiskerL.
      symmetry.
      refine (concat_p_pp _ _ _ @ whiskerR (concat_pp_p _ _ _ @ whiskerL _ ((ap_pp dli _ _)^ @ ap (ap dli) (@movedel_do n.+2 (inl i))) @ concat_p1 _) _ @ _).
      apply dldo.
    - (* case (iv) *)
      rewrite <- (Assumption_2 p hi (j; hj)).
      rewrite (etwb_3_inl_inr_tt_inl_inl_j_reduce_p_last j p hi hj).
      rewrite (etwb_3_inl_inr_tt_inl_inl_j_reduce_gamma_p_last j p hi hj).
      apply whiskerL. refine (concat_1p _ @ concat_pp_p _ _ _).
    - (* case (iii), similar to case (i) *)
      refine (_ @ whiskerR (ap (ap dli) (ap (ap dli) (ap a' (ap reduce (ap reduce (concat_p_pp _ _ _ @ whiskerR (gamma_double (FFin n.+1)) p @ concat_1p p)))))) _).
      refine (_ @ whiskerL _ (whiskerL _ (whiskerR (ap (ap dli) (ap (@movedel n.+2) (ap path_last (ap reduce (concat_p_pp _ _ _ @ whiskerR (gamma_double (FFin n.+1)) p @ concat_1p p))))) _))).
      set (q := gamma (FFin n.+1) @ p).
      set (ki := @path_last_gamma_p (FFin n.+1) n.+1 p @ hj : path_last q = inr tt).
      set (kj := @path_second_last_gamma_p (FFin n.+1) n.+1 p @ hi : path_second_last q = inl (inr tt)).
      rewrite <- (@Assumption_1 n.+1 q ki).
      repeat rewrite (etwb_3_inr_tt_inl_inr_tt_reduce_p_last q ki kj).
      apply whiskerL. simpl.
      refine ((dldo _)^ @ whiskerL _ (concat_1p _)^).
    - (* case (ii) *)
      rewrite <- (Assumption_1 p hi).
      repeat rewrite (etwb_3_inr_tt_inl_inl_j_reduce_p_last j p hi hj).
      apply whiskerL.
      refine (_ @ whiskerL _ (concat_p1 _)^).
      change (ap dli (@movedel n.+2 (inl j)) @ (dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl j)) @ dltw (dlpt n.+1)) =
dltw (dlpt n.+1) @ ap dli (@movedel n.+2 (inl j))).
      refine (whiskerL _ (movedel_br j @ concat_pp_p _ _ _) @ concat_p_pp _ _ _ @ _).
      refine (_ @ concat_1p _); apply whiskerR.
      refine ((ap_pp dli _ _)^ @ _).
      change (ap dli (@movedel n.+2 (inl j) @ @movedel n.+2 (inl j)) = ap dli idpath); apply ap.
      apply movedel_do.
    - (* case (i) *)
      rewrite <- (Assumption_1 p hi).
      repeat rewrite (etwb_3_inr_tt_inl_inr_tt_reduce_p_last p hi hj).
      apply whiskerL. simpl.
      exact (concat_1p _ @ (concat_p1 _)^).
Qed.

(** Equivalence **)

Theorem equiv_deloop_to_BS
  : forall n, IsEquiv (deloop_to_BS n).
Proof.
  exact (conditions_equiv_deloop_to_BS e0b eib etwb e0f eif).
Defined.

End equiv_deloop_to_BS.


(* * Basic definitions of decidablility and Functions
- includes basic Lemmas about said functions
 *)

Require Export PslBase.Base.

(** * Definition of useful tactics *)

(** dec is used to destruct all decisions appearing in the goal or assumptions. *)
Ltac dec := repeat (destruct Dec).

(** This tactic completely solves listComplete goals for base types *)
Ltac listComplete := intros x; simpl; dec; destruct x; try congruence.
(** simplifies (decision x = x) *)
Ltac deq x := destruct (Dec (x=x)) as [[]  | isnotequal]; [> | contradict isnotequal; reflexivity] .

(** Function that takes two lists and returns the list of all pairs of elements from the two lists *)
Fixpoint prodLists {X Y: Type} (A: list X) (B: list Y) {struct A} :=
  match A with
  | nil => nil
  | cons x A' => map (fun y => (x,y)) B ++ prodLists A' B end.

(** Crossing any list with the empty list always yields the empty list *)
Lemma prod_nil (X Y: Type) (A: list X) :
  prodLists A ([]: list Y) = [].
Proof.
  induction A.
  - reflexivity.
  - cbn. assumption.
Qed.

(** This function takes a (A: list X) and yields a list (option X) which for every x in A contains Some x. The resultung list also contains None. The order is preserved. None is the first element of the resulting list. *)

Definition toOptionList {X: Type} (A: list X) :=
  None :: map (@Some _) A .

(** This function counts the number of occurences of an element in a given list and returns the result *)
Fixpoint count (X: Type) `{eq_dec X}  (A: list  X) (x:  X) {struct A} : nat :=
  match A with
  | nil => O
  | cons y A' =>  if Dec (x=y) then S(count A' x) else count A' x end.

Definition toSumList1 {X: Type}  (Y: Type) (A: list X): list (X + Y) :=
  map inl A.
Definition toSumList2 {Y: Type}  (X: Type) (A: list Y): list (X + Y) :=
  map inr A.

(** * Basic lemmas about functions *)

(** In the list containing all pairs of (x,y') with y' from a list B the pair (x,y) is contained exactly as many times as y is contained in the list B. *)

Lemma countMap (X Y: eqType) (x:X) (B: list Y) y :
  count ( map (fun y => (x,y)) B) (x, y) = count B y.
Proof.
  induction B.
  - reflexivity.
  - simpl. dec;  congruence.
Qed.

(** If a list is split somewhere in two list the number of occurences of an element in the list is equal to the sum of the number of occurences in the left and the right part. *)

Lemma countSplit (X: eqType) (A B: list X) (x: X)  : count A x + count B x = count (A ++ B) x.
Proof.
  induction A.
  - reflexivity.
  - cbn. decide (x=a).
    +cbn. f_equal; exact IHA.
    + exact IHA.
Qed.

(** In a list of tupels with x as a left element the number of tupels with something different from x as a left element is 0. *)
Lemma countMapZero  (X Y: eqType) (x x':X) (B: list Y) y : x' <> x -> count  ( map (fun y => (x,y)) B) (x', y) =0.
Proof.
  intros ineq. induction B.
  - reflexivity.
  -  simpl. dec.
     + inversion e; congruence.
     + exact IHB.
Qed.

Lemma notInZero (X: eqType) (x: X) A :
  not (x el A) <-> count A x = 0.
Proof.
  split; induction A.
  -  reflexivity.
  - intros H. cbn in *. dec.
    + exfalso. apply H. left. congruence.
    + apply IHA. intros F. apply H. now right.
  - tauto.
  - cbn. dec.
    + subst a. omega.
    + intros H [E | E].
      * now symmetry in E.
      * tauto.
Qed.

Lemma countIn (X:eqType) (x:X) A:
  count A x > 0 -> x el A.
Proof.
  induction A.
  - cbn. omega.
  - cbn.  dec.
    + intros. left. symmetry. exact e.
    + intros. right. apply IHA. exact H.
Qed.

Lemma InCount (X:eqType) (x:X) A:
  x el A -> count A x > 0.
Proof.
  induction A.
  - intros [].
  - intros [[] | E]; cbn.
    + deq a. omega.
    + specialize (IHA E). dec; omega.
Qed.

Lemma count_in_equiv (X: eqType) (x:X) A : count A x > 0 <-> x el A.
Proof.
  split.
  - apply countIn.
  - apply InCount.
Qed.

Lemma countApp (X: eqType) (x: X) (A B: list X) :
  count (A ++ x::B) x > 0.
Proof.
  auto using InCount.
Qed.

(**  Dupfree Lists containing every x countain x exactly once *)
Lemma dupfreeCount (X: eqType) (x:X) (A: list X) : dupfree A -> x el A -> count A x = 1.
Proof.
  intros D E. induction D.
  -  contradiction E.
  - cbn. dec.
    + f_equal. subst x0. now apply notInZero.
    + destruct E as [E | E]; [> congruence | auto].
Qed.

(** toSumlist1 does not change the number of occurences of an existing element in the list *)
Lemma toSumList1_count (X: eqType) (x: X) (Y: eqType) (A: list X) :
  count (toSumList1 Y A) (inl x) =  count A x .
Proof.
  induction A; simpl; dec; congruence.
Qed.

(** toSumlist2 odes not change the numbe of occurences of an existing element in the list *)
Lemma toSumList2_count (X Y: eqType) (y: Y) (A: list Y):
  count (toSumList2 X A) (inr y) = count A y.
Proof.
  induction A; simpl; dec; congruence.
Qed.

(** to sumList1 does not produce inr proofs *)
Lemma toSumList1_missing (X Y: eqType) (y: Y) (A: list X):
  count (toSumList1 Y A ) (inr y) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

(** toSumlist2 does not produce inl proofs *)
Lemma toSumList2_missing (X Y: eqType) (x: X) (A: list Y):
  count (toSumList2 X A ) (inl x) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

(** * Cardinality Lemmas for lists*)
Lemma cons_incll (X: Type) (A B: list X) (x:X) : x::A <<= B -> A <<= B.
Proof.
  unfold "<<=". auto.
Qed.

Lemma card_length_leq (X: eqType) (A: list X) : card A <= length A.
Proof.
  induction A; auto. cbn. dec; omega.
Qed.

(** * Various helpful Lemmas *)

(** If the concatenation of two lists is nil then each list was nil *)
Lemma appendNil (X: Type) (A B: list X) :
  A ++ B = nil -> A = nil /\ B = nil.
Proof.
  intros H. assert (|A ++ B| = 0) by now rewrite H.
  rewrite app_length in H0. rewrite <- !length_zero_iff_nil. omega.
Qed.

Lemma countZero (X: eqType) (x: X) (A: list X) : count A x = 0 -> not (x el A).
Proof.
  induction A; cbn in *; dec; firstorder congruence.
Qed.

(** The product of two numbers is greater zero if both numbers are greater zero *)
Lemma NullMul a b : a > 0 -> b > 0 -> a * b > 0.
Proof.
  induction 1; cbn; omega.
Qed.


From distris Require Import tactics proofmode notation adequacy network.

Import Network.

Section relay.
  Context `{X : Type, distG Σ}.

  Definition relay_resp_si (P : X -> iProp Σ) Pin Pout :
    socket_interp Σ :=
    (λ msg, ∃ φ (v : X), ms_sender msg ⤇ φ ∗
           Pin (ms_body msg) v ∗ P v ∗
           (∀ m', P v ∗ Pout (ms_body m') v -∗ φ m'))%I.

End relay.


(* TLC in Coq
 *
 * Module: tlc.semantics.predicate
 * Purpose: Contains the semantics for predicate forms.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.seq.
Require Import tlc.semantics.term.
Require Import tlc.syntax.all_syntax.
Require Import tlc.utility.monad.
Require Import tlc.utility.result.
Require Import tlc.utility.seq.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition push_predicate_params_rec p k :=
  match p with
  | PEqual x1 x2 =>
    PEqual
      (push_term_params_rec x1 k)
      (push_term_params_rec x2 k)
  | PLess x1 x2 =>
    PLess
      (push_term_params_rec x1 k)
      (push_term_params_rec x2 k)
  | PMember y xs =>
    PMember
      (push_term_params_rec y k)
      (push_term_params_rec xs k)
  | PExtension xs' xs =>
    PExtension
      (push_term_params_rec xs' k)
      (push_term_params_rec xs k)
  end.

Definition push_predicate_params p := push_predicate_params_rec p 0.

(* Unify two predicates within an argument map
 * If the two predicates are equal when substituting according to the map,
 * an updated map is returned.
 *)
Definition unify_predicate_with p' p us :=
  match p', p with
  | PEqual x'1 x'2, PEqual x1 x2
  | PLess x'1 x'2, PLess x1 x2
  | PMember x'1 x'2, PMember x1 x2
  | PExtension x'1 x'2, PExtension x1 x2 =>
    us <- unify_term_with x'1 x1 us;
    unify_term_with x'2 x2 us
  | _, _ => None
  end.

(* Open a predicate p at depth k with bindings us *)
Definition open_predicate_at k us p :=
  match p with
  | PEqual x1 x2 =>
    x1 <- open_term_at k us x1;
    x2 <- open_term_at k us x2;
    pure (PEqual x1 x2)
  | PLess x1 x2 =>
    x1 <- open_term_at k us x1;
    x2 <- open_term_at k us x2;
    pure (PLess x1 x2)
  | PMember y xs =>
    y <- open_term_at k us y;
    xs <- open_term_at k us xs;
    pure (PMember y xs)
  | PExtension xs' xs =>
    xs' <- open_term_at k us xs';
    xs <- open_term_at k us xs;
    pure (PExtension xs' xs)
  end.
Definition open_predicate := open_predicate_at 0.

(* Determine whether a predicate is locally closed
 * A predicate is locally closed if every parameter reference is well-formed.
 *)
Definition predicate_lc_in ks p :=
  match p with
  | PEqual x1 x2 => term_lc_in ks x1 && term_lc_in ks x2
  | PLess x1 x2 => term_lc_in ks x1 && term_lc_in ks x2
  | PMember y xs => term_lc_in ks y && term_lc_in ks xs
  | PExtension xs' xs => term_lc_in ks xs' && term_lc_in ks xs
  end.
Definition predicate_lc := predicate_lc_in [::].

(* Any predicate that is closed at depth ks is closed at depth k :: ks *)
Lemma predicate_lc_in_cons k ks p :
  predicate_lc_in ks p ->
  predicate_lc_in (k :: ks) p.
Proof.
Admitted.

(* Any predicate that is closed at depth ks is closed at depth ks' ++ ks *)
Lemma predicate_lc_in_concat ks' ks p :
  predicate_lc_in ks p ->
  predicate_lc_in (ks' ++ ks) p.
Proof.
  elim: ks' => [| k ks' IH] //=.
  by move=> H; specialize (IH H); apply predicate_lc_in_cons.
Qed.

(* Opening a closed predicate at a depth above its closure depth has no effect *)
Lemma open_lc_predicate_at k ks us p :
  k >= size ks ->
  predicate_lc_in ks p ->
  open_predicate_at k us p = Success p.
Proof.
Admitted.

(* Compute the set of flexible variables appearing in a predicate *)
Definition predicate_flexibles p :=
  match p with
  | PEqual x1 x2 => term_flexibles x1 ++ term_flexibles x2
  | PLess x1 x2 => term_flexibles x1 ++ term_flexibles x2
  | PMember y xs => term_flexibles y ++ term_flexibles xs
  | PExtension xs' xs => term_flexibles xs' ++ term_flexibles xs
  end.

(* Compute the set of rigid variables appearing in a predicate *)
Definition predicate_rigids p :=
  match p with
  | PEqual x1 x2 => term_rigids x1 ++ term_rigids x2
  | PLess x1 x2 => term_rigids x1 ++ term_rigids x2
  | PMember y xs => term_rigids y ++ term_rigids xs
  | PExtension xs' xs => term_rigids xs' ++ term_rigids xs
  end.

(* Compute the set of variables appearing in a predicate *)
Definition predicate_vars p :=
  map VF (predicate_flexibles p) ++ map VR (predicate_rigids p).

(* Determine whether a predicate is globally closed
 * A predicate is globally closed if it contains no rigid variables.
 *)
Definition predicate_gc_in xs p := subset (predicate_rigids p) xs.
Definition predicate_gc := predicate_gc_in [::].

(* Determine whether a predicate is closed
 * A predicate is closed if it is locally and globally closed.
 *)
Definition predicate_closed_in ks xs p :=
  predicate_lc_in ks p && predicate_gc_in xs p.
Definition predicate_closed p := predicate_lc p && predicate_gc p.

(* A closed predicate is locally closed *)
Lemma closed_predicate_lc ks xs p :
  predicate_closed_in ks xs p ->
  predicate_lc_in ks p.
Proof.
  by move/andP => [??].
Qed.

(* A closed predicate is globally closed *)
Lemma closed_predicate_gc ks xs p :
  predicate_closed_in ks xs p ->
  predicate_gc_in xs p.
Proof.
  by move/andP => [??].
Qed.

(* Well-formed opening will not fail *)
Lemma open_closed_predicate_at ks xs k us p :
  predicate_closed_in ks xs p ->
  onth ks k = Some (size us) ->
  exists p', open_predicate_at k us p = Success p'.
Proof.
Admitted.

(* Determine whether a predicate is rigid
 * A predicate is rigid if it contains no flexible variables.
 *)
Definition predicate_rigid p :=
  match p with
  | PEqual x1 x2 => term_rigid x1 && term_rigid x2
  | PLess x1 x2 => term_rigid x1 && term_rigid x2
  | PMember y xs => term_rigid y && term_rigid xs
  | PExtension xs' xs => term_rigid xs' && term_rigid xs
  end.

(* Replace all instances of term x with term u within p *)
Definition replace_predicate_term x u p :=
  match p with
  | PEqual x1 x2 => PEqual (replace_term x u x1) (replace_term x u x2)
  | PLess x1 x2 => PLess (replace_term x u x1) (replace_term x u x2)
  | PMember y xs => PMember (replace_term x u y) (replace_term x u xs)
  | PExtension xs' xs =>
    PExtension (replace_term x u xs') (replace_term x u xs)
  end.

(* Replace all instances of variable x with term u within p *)
Definition replace_predicate_var x u p := replace_predicate_term (TVariable x) u p.

(* Reduce the subterms of predicate P *)
Definition reduce_predicate p :=
  match p with
  | PEqual x1 x2 =>
    x1 <- [[t x1]];
    x2 <- [[t x2]];
    pure (PEqual x1 x2)
  | PLess x1 x2 =>
    x1 <- [[t x1]];
    x2 <- [[t x2]];
    pure (PLess x1 x2)
  | PMember y xs =>
    y <- [[t y]];
    xs <- [[t xs]];
    pure (PMember y xs)
  | PExtension xs' xs =>
    xs' <- [[t xs']];
    xs <- [[t xs]];
    pure (PExtension xs' xs)
  end.
Notation "[[P p ]]" := (reduce_predicate p) (at level 0, no associativity).


(** attempted 1  optional and completed 1 optional *)

(** Exercise 1 (optimize_0plus_b) *)
Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b1 => BNot b1
  | BAnd b1 b2  => BAnd b1 b2
  end.
Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  intros b. induction b;
  simpl; repeat (rewrite -> optimize_0plus_sound); reflexivity.
Qed.

(** Exercise 2 (update_eq) *)
Theorem update_eq : forall n x st,
  (update st x n) x = n.
Proof.
  intros.
  unfold update. apply eq_id.
Qed.

(** Exercise 3 (update_neq) *)
Theorem update_neq : forall x2 x1 n st,
  x2 <> x1 ->
  (update st x2 n) x1 = (st x1).
Proof.
  intros.
  unfold update. apply neq_id. apply H.
Qed.

(** Exercise 4 (update_example) *)
Theorem update_example : forall (n:nat),
  (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  intros. unfold update. simpl. unfold empty_state. reflexivity.
Qed.

(** Exercise 5 (update_shadow) *)
Theorem update_shadow : forall n1 n2 x1 x2 (st : state),
   (update  (update st x2 n1) x2 n2) x1 = (update st x2 n2) x1.
Proof.
  intros. unfold update. destruct (eq_id_dec x2 x1).
  reflexivity.
  reflexivity.
Qed.

(** Exercise 6 (update_same) *)
Theorem update_same : forall n1 x1 x2 (st : state),
  st x1 = n1 ->
  (update st x1 n1) x2 = st x2.
Proof.
  intros. unfold update. destruct (eq_id_dec x1 x2).
  subst. reflexivity. reflexivity.
Qed.

(** Exercise 7 (update_permute) *)
Theorem update_permute : forall n1 n2 x1 x2 x3 st,
  x2 <> x1 ->
  (update (update st x2 n1) x1 n2) x3 = (update (update st x1 n2) x2 n1) x3.
Proof.
  unfold update. intros. generalize dependent x2. destruct (eq_id_dec x1 x3).
  Case "x1 = x3".
    subst. intros. rewrite neq_id. reflexivity. apply H.
  Case "x1 <> x3".
    reflexivity.
Qed.

(** Exercise 8 (ceval_example2) *)
Example ceval_example2:
    (X ::= ANum 0;; Y ::= ANum 1;; Z ::= ANum 2) / empty_state ||
    (update (update (update empty_state X 0) Y 1) Z 2).
Proof.
  apply E_Seq with (update empty_state X 0).
  apply E_Ass. reflexivity.
  apply E_Seq with (update (update empty_state X 0) Y 1).
  apply E_Ass. reflexivity.
  apply E_Ass. reflexivity.
Qed.

(** Exercise 9 (XtimesYinZ_spec) *)
(* Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y))*)
Theorem XtimesYinZ_spec : forall st x y st',
  st X = x ->
  st Y = y ->
  XtimesYinZ / st || st' ->
  st' Z = x * y.
Proof.
  intros st x y st' stX stY ev.
  inversion ev. subst. simpl.
  apply update_eq.
Qed.

(** Exercise 10 (loop_never_stops) *)
Theorem loop_never_stops : forall st st',
  ~(loop / st || st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef.
  (* Proceed by induction on the assumed derivation showing that
     [loopdef] terminates.  Most of the cases are immediately
     contradictory (and so can be solved in one step with
     [inversion]). *)
  induction contra; try inversion Heqloopdef.
    rewrite -> H1 in H. inversion H.
    subst. apply IHcontra2. reflexivity.
Qed.

(** Exercise 11 (no_whilesR) *)
Inductive no_whilesR: com -> Prop :=
  | nw_skip : no_whilesR SKIP
  | nw_ass  : forall v e, no_whilesR (v ::= e)
  | nw_seq  : forall c1 c2, no_whilesR c1 -> no_whilesR c2 -> no_whilesR (c1 ; c2)
  | nw_if   : forall e c1 c2, no_whilesR c1 -> no_whilesR c2 -> no_whilesR (IFB e THEN c1 ELSE c2 FI).

Theorem no_whiles_eqv:
   forall c, no_whiles c = true <-> no_whilesR c.
Proof.
  split.
    induction c; intros H; try constructor; try (apply IHc1); try (apply IHc2);
    try (simpl in H; apply andb_true_iff in H; apply H).
      inversion H.
    intros r. induction r; try reflexivity;
      try (simpl; rewrite -> IHr1; rewrite -> IHr2; reflexivity).
Qed.

(** Exercise 12 (optional (neq_id)) *)
Theorem beq_id_sym: forall i1 i2,
  beq_id i1 i2 = beq_id i2 i1.
Proof.
  intros i1 i2.
  destruct i1. destruct i2.
  unfold beq_id. apply beq_nat_sym.
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sha_sel_other_reduce :
  forall T1 x L ss1 T1', T1 = (t_sha_sel x L ss1 T1') ->
                    forall T2, (T2 <> t_top) ->
                          (forall x L T2', T2 <> (t_sel_low x L T2')) ->
                          (forall x L T2', T2 <> (t_sel_equ x L T2')) ->
                          (forall L2 T2', T2 <> (t_upp L2 T2')) ->
                          (forall L2 T2', T2 <> (t_equ L2 T2')) ->
                          (forall L2 T2', T2 <> (t_low L2 T2')) ->
                          (forall L2 T2', T2 <> (t_nom L2 T2')) ->
                          (T2 <> t_nil) ->
                          (forall T2' Ts2, T2 <> (t_con T2' Ts2)) ->
                          subtype T1 T2 = subtype T1' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T2; auto.

  contradiction H0; auto.
  contradiction (H1 v l T2); auto.
  contradiction (H2 v l T2); auto.
  contradiction (H3 l T2); auto.
  contradiction (H5 l T2); auto.
  contradiction (H4 l T2); auto.
  contradiction (H6 l T2); auto.
  contradiction H7; auto.
  contradiction (H8 T2_1 T2_2); auto.
Qed.


Add LoadPath "C:\Coq\Classical Foundations" as LF.
From LF Require Export Foundations.
From LF Require Export Logical_Properties.
Require Import Ltac.

Parameter In:Set->Set->Prop.
Notation "x ∈ y" := (In x y) (at level 10).
Notation "x ∉ y" := (not (In x y)) (at level 10).
Axiom ax_ext : forall x y:Set, (forall t:Set, t∈x⇔t∈y)->x=y.
Axiom ax_emp : ∃x:Set, forall y:Set, y∉x.
Axiom ax_par : forall x y:Set, ∃z:Set, forall z0:Set, z0∈z⇔z0=x∨z0=y.
Axiom ax_uun : forall x:Set, ∃y:Set, forall y0:Set, y0∈y⇔∃x0:Set, x0∈x∧y0∈x0.
Axiom ax_spf : forall (x:Set) (P:Set->Prop), ∃y:Set, forall y0:Set, y0∈y⇔y0∈x∧P y0.
Axiom ax_rep : forall (x:Set) (f:Set->Set), ∃y:Set, forall y0:Set, y0∈y⇔∃x0:Set, x0∈x∧f x0=y0.
Axiom ax_ind : forall (x:Set) (f:Set->Set), ∃y:Set, forall y0:Set, y0∈y->f y0∈y.
Axiom ax_pow : forall x:Set, ∃y:Set, forall y0:Set, y0∈y⇔(forall y1:Set, y1∈y0->y1∈x).
Axiom ax_fnd : forall P:Set->Prop, (forall x:Set, (forall x0:Set, x0∈x-> P x0)->P x) -> forall x:Set, P x.
Axiom ax_gch : ∃f:Set->Set, forall x:Set, (∃x0:Set, x0∈x)->f x∈x.

Theorem abc : forall P:Set->Set->Prop, (forall x:Set, ∃!y:Set, P x y)->∃f:Set->Set, forall x y:Set, P x y⇔f x=y.
Proof. intros.
assert (forall x y:Set, P x y⇔ (fun x:Set => eps exue1 (H x)) x =y). intros. refine (iffi _ _).
intro. pose proof def exue1 (H x). exact (exue2 (H x) _ _ H1 H0).
intro. pose proof def exue1 (H x). exact (H0 _ H1). exact (exi _ H0). Qed.

Definition non_emp := fun x:Set => ∃x0:Set, x0∈x.
Theorem lch : forall x:Set, (forall x0:Set, x0∈x->non_emp x0)->∃f:Set->Set, forall x0:Set, x0∈x->f x0∈x0.
Proof. intros. pose proof (ax_gch). refine(exe H0 _).
intros. pose proof (H x0 H2).
exact (H1 x0 H3). Qed.

Definition zero := eps ax_emp.
Notation "0" := (zero).
Theorem zeroi : forall x:Set, x∉0.
Proof def ax_emp.
Definition one : Set := eps (ax_par 0 0).
Notation "1" := (one).
Theorem onei : forall x:Set, x∈1⇔x=0.
Proof. intro. assert (forall x:Set, x∈1 ⇔ x=0∨x=0). exact (def (ax_par 0 0)).
assert (x∈1->x=0).
  intro. pose proof (H x). pose proof (iffe1 H1 H0). pose proof(fun a:x=0 => a).
exact (H2 (x=0) H3 H3).
assert (x=0->x∈1).
  intro. pose proof (or_intro1 (x=0) (x=0) H1).
exact (iffe2 (H x) H2).
exact (iffi H0 H1). Qed.
Definition two : Set := eps (ax_par 0 1).
Notation "2" := (two).
Theorem twoi : forall x:Set, x∈2⇔x=0∨x=1.
Proof def (ax_par 0 1).
Lemma id_01 : 0∈1.
Proof. pose proof (onei 0). exact (iffe2 H (eqi 0)). Qed.
Lemma id_02 : 0∈2.
Proof. pose proof (twoi 0). pose proof (eqi 0). pose proof (or_intro1 (0=0) (0=1) H0).
exact (iffe2 H H1). Qed.
Lemma id_12 : 1∈2.
Proof.  pose proof (twoi 1). pose proof (eqi 1). pose proof (or_intro2 (1=0) (1=1) H0).
exact (iffe2 H H1). Qed.
Lemma id_setfalse : ¬1=0.
Proof. intro. pose proof id_01. pose proof H _ H0. pose proof zeroi 0. exact (H2 H1). Qed.

Theorem lem : forall p:Prop, p∨¬p.
Proof. intro p. pose proof (ax_spf 2 (fun x:Set => x=0∨p)). pose proof (ax_spf 2 (fun x:Set => x=1∨p)).
assert (forall a b:Set, (forall a0:Set, a0∈a⇔a0∈2∧(a0=0∨p))->(forall b0:Set, b0∈b⇔b0∈2∧(b0=1∨p))->p∨¬p).
  intros.
  assert (non_emp a).
    pose proof (H1 0). pose proof (or_intro1 (0=0) p (eqi 0)). pose proof (iffe2 H3 (andi id_02 H4)).
  exact (exi _ H5).
  assert (non_emp b).
    pose proof (H2 1). pose proof (or_intro1 (1=1) p (eqi 1)). pose proof (iffe2 H4 (andi id_12 H5)).
  exact (exi _ H6).
  pose proof (ax_par a b).
  assert(forall c:Set, (forall z0 : Set, z0 ∈ c ⇔ z0 = a ∨ z0 = b)->p∨¬p).
    intros.
    assert (forall c0:Set, c0∈c-> non_emp c0).
      intros. pose proof iffe1 (H6 c0) H7.
        assert(c0=a-> non_emp c0).
          intro. pose proof (eqs H9).
        exact (H10 _ H3).
        assert(c0=b->non_emp c0).
          intro. pose proof (eqs H10).
        exact(H11 _ H4).
      exact (H8 _ H9 H10).
    pose proof (lch c  H7).
    assert (forall f:Set->Set, (forall x:Set, x∈c->f x∈x)->p∨¬p).
      intros. pose proof H9 a (iffe2 (H6 a) (or_intro1 _ _ (eqi a))).
      pose proof  H9 b (iffe2 (H6 b) (or_intro2 _ _ (eqi b))).
      pose proof H1 (f a). pose proof ande2 (iffe1 H12 H10). pose proof (fun x:p => or_intro1 p (¬p) x).
      assert  (f a =0 -> p∨¬p).
        intro. pose proof H2 (f b). pose proof ande2 (iffe1 H16 H11).
        assert(f b=1-> p∨¬p).
          intro. assert(¬p). intro. assert (forall x:Set, x∈a⇔x∈b). intro.
          assert (x∈a->x∈b). intro. pose proof (H1 x). pose proof (iffe1 H21 H20). pose proof ande1 H22.
          pose proof (or_intro2 (x=1) _ H19). pose proof andi  H23 H24. exact(iffe2 (H2 x) H25). assert(x∈b->x∈a).
          intro. pose proof H2 x. pose proof iffe1 H22 H21. pose proof ande1 H23. pose proof or_intro2 (x=0) _ H19.
          pose proof andi H24 H25. exact(iffe2 (H1 x) H26). exact (iffi H20 H21). pose proof ax_ext a b H20.
          assert (f b=0). exact(H21 (fun x:Set => f x=0) H15). assert (1=0) by exact(H18 (fun x:Set => x=0) H22).
          exact (id_setfalse H23).
        exact(or_intro2 p _ H19).
      exact(H17 _ H18 H14).
    exact(H13 _ H15 H14).
  exact(H8 _ H9).
exact (H5 _ H6).
assert (forall a:Set, (forall a0 : Set, a0∈a⇔a0∈2∧(a0=0∨p))->(∃b:Set, (forall b0:Set, b0∈b⇔b0∈2∧(b0=1∨p)))->p∨¬p).
  intros. pose proof H1 a. assert (forall b:Set, (forall b0:Set, b0∈b⇔b0∈2∧(b0=1∨p))->p∨¬ p). intros.
  exact (H1 a b H2 H5).
exact (H3 _ H5).
pose proof (H _ H2). exact (H3 H0). Qed.

Theorem lem2 : forall p:Prop, ¬¬p->p.
Proof. intros. pose proof lem p. apply H0. exact (fun x => x). intro. pose proof H H1. apply H2. Qed.
Theorem lem_comm_ne@{u} (A:Type@{u}) (P:A->Prop) : ¬ (∃a:A, P a)->(forall a:A, ¬P a).
Proof. unfold not. intros. apply H. exact (exi _ H0). Qed.
Theorem lem_comm_na@{u} (A:Type@{u}) (P:A->Prop) : ¬ (forall a:A, P a)->(∃a:A, ¬P a).
Proof. intro. pose proof lem (∃a:A, ¬P a). apply H0. exact (fun x => x). intro. pose proof (lem_comm_ne _ _ H1).
assert (⊥). apply H. intro. pose proof H2 a. exact (lem2 _ H3). apply H3. Qed.

Theorem empu : ∃!x:Set, forall y:Set, y∉x.
Proof. refine (exui _ _). exact ax_emp. intros. apply ax_ext. intro. apply iffi.
intro. pose proof H t H1. exact (H2 _).
intro. pose proof H0 t H1. exact (H2 _). Qed.
Theorem paru : forall x y:Set, ∃!z:Set, forall z0:Set, z0∈z⇔z0=x∨z0=y.
Proof. intros. refine (exui _ _). exact (ax_par x y). intros. refine (ax_ext t0 t1 _).
intro. pose proof H t. pose proof H0 t. refine (iffi _ _). intro. pose proof (iffe1 H1 H3).
exact (iffe2 H2 H4). intro. pose proof iffe1 H2 H3. exact (iffe2 H1 H4). Qed.
Theorem uunu : forall x:Set, ∃!y:Set, forall y0:Set, y0∈y⇔∃x0:Set, x0∈x∧y0∈x0.
Proof. intros. apply exui. apply ax_uun. intros. apply ax_ext. intro. apply iffi.
intro. pose proof H t. pose proof iffe1 H2 H1. pose proof H0 t. exact (iffe2 H4 H3).
intro. pose proof H0 t. pose proof iffe1 H2 H1. pose proof H t. exact (iffe2 H4 H3). Qed.
Theorem spfu : forall (x:Set) (P:Set->Prop), ∃!y:Set, forall y0:Set, y0∈y⇔y0∈x∧P y0.
Proof. intros. apply exui. apply ax_spf. intros. apply ax_ext. intro. apply iffi.
intro. pose proof H t. pose proof iffe1 H2 H1. pose proof H0 t. exact (iffe2 H4 H3).
intro. pose proof H0 t. pose proof iffe1 H2 H1. pose proof H t. exact (iffe2 H4 H3). Qed.
Theorem repu : forall (x:Set) (f:Set->Set), ∃!y:Set, forall y0:Set, y0∈y⇔∃x0:Set, x0∈x∧f x0=y0.
Proof. intros. apply exui. apply ax_rep. intros. apply ax_ext. intro. apply iffi.
intro. pose proof H t. pose proof iffe1 H2 H1. pose proof H0 t. exact (iffe2 H4 H3).
intro. pose proof H0 t. pose proof iffe1 H2 H1. pose proof H t. exact (iffe2 H4 H3). Qed.
Theorem powu : forall x:Set, ∃!y:Set, forall y0:Set, y0∈y⇔(forall y1:Set, y1∈y0->y1∈x).
Proof. intros. apply exui. apply ax_pow. intros. apply ax_ext. intro. apply iffi.
intro. pose proof H t. pose proof iffe1 H2 H1. pose proof H0 t. exact (iffe2 H4 H3).
intro. pose proof H0 t. pose proof iffe1 H2 H1. pose proof H t. exact (iffe2 H4 H3). Qed.

Definition par := fun x y:Set => eps (ax_par x y).
Theorem par_intro : forall x y:Set, forall t:Set, t∈(par x y)⇔t=x∨t=y.
Proof. intros. pose proof (def (ax_par x y)). apply iffi. intro. pose proof H t. exact (iffe1 H1 H0).
intro. pose proof H t. exact (iffe2 H1 H0). Qed.
Definition parif := fun x y:Set => par_intro x y.
Notation "'pari' p" := (iffe2 (parif  _ _ _) p) (at level 10).
Notation "'pare' p" := (iffe1 (parif  _ _ _) p) (at level 10).

Definition uun := fun x:Set => eps (ax_uun x).
Notation "⋃ x" := (uun x) (at level 9).
Theorem uun_intro : forall x t:Set, t∈⋃x⇔∃x0:Set, x0∈x∧t∈x0.
Proof. intros. pose proof def (ax_uun x). apply iffi. intro. pose proof H t. exact (iffe1 H1 H0).
intro. pose proof H t. exact (iffe2 H1 H0). Qed.
Definition uuniff := fun x:Set => uun_intro x.
Notation "'uunif' p" := (iffe2 (uuniff  _ _) p) (at level 10).
Notation "'uune' p" := (iffe1 (uuniff  _ _) p) (at level 10).

Definition spf := fun (x:Set) (P:Set->Prop) => eps (ax_spf x P).
Notation "{ x0 ∈ x | P }" := (spf x (fun x0:Set => P)) (at level 9, x0 name).
Theorem spf_intro : forall (x:Set) (P:Set->Prop) (t:Set), t∈(spf x P)⇔t∈x∧P t.
Proof. intros. pose proof def (ax_spf x P). apply iffi. intro. pose proof H t. exact (iffe1 H1 H0).
intro. pose proof H t. exact (iffe2 H1 H0). Qed.
Definition spfif := fun (x:Set) (P:Set->Prop) => spf_intro x P.
Notation "'spfi' p" := (iffe2 (spfif  _ _) p) (at level 10).
Notation "'spfe' p" := (iffe1 (spfif  _ _) p) (at level 10).

Definition subs := fun x y:Set => (forall t:Set, t∈x->t∈y).
Notation "x ⊆ y" := (subs x y) (at level 9).

Definition pow := fun x:Set => eps ax_pow x.
Theorem pow_intro : forall x t:Set, t∈(pow x)⇔t⊆x.
Proof. intros. pose proof def (ax_pow x). apply iffi. intro. pose proof H t. exact (iffe1 H1 H0).
intro. pose proof H t. exact (iffe2 H1 H0). Qed.
Definition powif := fun x:Set => pow_intro x.
Notation "'powi' p" := (iffe2 (uuniff  _ _) p) (at level 10).
Notation "'powe' p" := (iffe1 (uuniff  _ _) p) (at level 10).

Definition rep := fun (x:Set) (f:Set->Set) => eps (ax_rep x f).
Notation "{ P | x0 ∈ x }" := (rep x (fun x0:Set => P)) (at level 9, x0 name).
Theorem rep_intro : forall (x:Set) (f:Set->Set) (t:Set), t∈(rep x f)⇔∃x0:Set, x0∈x∧f x0=t.
Proof. intros. pose proof def (ax_rep x f). apply iffi. intro. pose proof H t. exact (iffe1 H1 H0).
intro. pose proof H t. exact (iffe2 H1 H0). Qed.
Definition repif := fun (x:Set) (f:Set->Set) => rep_intro x f.
Notation "'repi' p" := (iffe2 (repif  _ _) p) (at level 10).
Notation "'repe' p" := (iffe1 (repif  _ _) p) (at level 10).

Definition un := fun x y:Set => ⋃(par x y).
Notation "x ∪ y" := (un x y) (at level 9, right associativity).
Theorem un_intro : forall x y:Set, forall t:Set, t∈x∪y⇔t∈x∨t∈y.
Proof. intros. pose proof uuniff (par x y). pose proof H t. apply iffi. intro. pose proof iffe1 H0 H1.
assert (forall x0:Set, x0∈(par x y)∧t∈x0->t∈x∨t∈y). intros. pose proof ande1 H3. pose proof parif x y x0.
pose proof iffe1 H5 H4. pose proof ande2 H3. apply H6.
intro. apply ori1. apply H8. assumption. intro. apply ori2. apply H8. assumption.
pose proof exe H2 H3. apply H4. exact (fun _ x => x).
intro. apply (iffe2 H0). apply H1. intro. assert (x∈(par x y)). pose proof parif x y. pose proof H3 x.
apply (iffe2 H4). apply ori1. exact (eqi x). pose proof (andi H3 H2). exact (ex_intro _ _ x H4).
intro. assert (y∈(par x y)). pose proof parif x y. pose proof H3 y.
apply (iffe2 H4). apply ori2. exact (eqi y). pose proof (andi H3 H2). exact (ex_intro _ _ y H4). Qed.
Definition unif := fun x y:Set => un_intro x y.
Notation "'uni' p" := (iffe2 (unif  _ _) p) (at level 10).
Notation "'une' p" := (iffe1 (unif  _ _) p) (at level 10).

Definition pun := fun (I:Set) (f:Set->Set) => ⋃ (rep I f).
Theorem pun_intro : forall (I:Set) (f:Set->Set), forall t:Set, t∈(pun I f)⇔∃i:Set, i∈I∧t∈(f i).
Proof. intros. unfold pun. pose proof uuniff (rep I f) t. pose proof repif I f. apply iffi.
intro. pose proof iffe1 H H1. apply H2. intros. pose proof ande1 H3. pose proof iffe1 (H0 t0) H4.
apply H5. intros. pose proof ande2 H6. pose proof ande2 H3. assert (t∈(f t1)). pose proof eqs H7. apply H9. exact H8.
pose proof ande1 H6. pose proof andi H10 H9. apply (exi t1 H11).
intro. apply (iffe2 H). apply H1. intros. refine (exi (f t0) _). apply andi. apply (iffe2 (H0 (f t0))). pose proof ande1 H2.
pose proof eqi (f t0). pose proof andi H3 H4. exact (exi t0 H5). exact (ande2 H2). Qed.
Definition punif := fun (I:Set) (f:Set->Set) => pun_intro I f.
Notation "'puni' p" := (iffe2 (punif  _ _) p) (at level 10).
Notation "'pune' p" := (iffe1 (punif  _ _) p) (at level 10).

Definition ins := fun x y:Set => spf x (fun t:Set => t∈y).
Notation "x ∩ y" := (ins x y) (at level 9, right associativity).
Theorem ins_intro : forall x y:Set, forall t:Set, t∈x∩y⇔t∈x∧t∈y.
Proof. unfold ins. intros. apply iffi. intro. pose proof spfif x (fun s => s∈y). pose proof H0 t. exact (iffe1 H1 H).
intro. pose proof spfif x (fun s => s∈y). pose proof H0 t. exact (iffe2 H1 H). Qed.
Definition insi := fun x y:Set => ins_intro x y.
Notation "'inse' p" := (iffe1 (insi  _ _ _) p) (at level 10).

Definition pins := fun (I:Set) (f:Set->Set) (i:Set) (p:i∈I) => spf (f i) (fun x => forall i0:Set, i0∈I->x∈(f i0)).
Theorem pins_intro : forall (I:Set) (f:Set->Set) (i:Set) (p:i∈I), forall x:Set, x∈(pins I f i p)⇔forall i:Set, i∈I-> x∈(f i).
Proof. intros. pose proof spfif (f i) ((fun x => forall i0:Set, i0∈I->x∈(f i0))). apply iffi.
intros. pose proof H x. apply (iffe1 H2 H0). intros. exact (H4 i0 H1).
intro. pose proof H x. apply (iffe2 H1). apply andi. exact (H0 i p). intros. exact (H0 i0 H2). Qed.
Notation "'pinsi' I f p" := (pins_intro I f _ p) (at level 9, right associativity).

Definition setm := fun x y:Set => spf x (fun t => t∉y).
Theorem setm_intro : forall x y:Set, forall t:Set, t∈(setm x y) ⇔ t∈x∧t∉y.
Proof. intros. apply iffi. intro. pose proof spfif x (fun t=>t∉y). pose proof H0 t. exact (iffe1 H1 H).
intro. pose proof spfif x (fun t=>t∉y). pose proof H0 t. exact (iffe2 H1 H). Qed.
Definition setmi := fun x y:Set => setm_intro x y.

Definition orp := fun x y:Set => par (par x y) (par x x).
Theorem orp_intro : forall a b c d:Set, orp a b = orp c d->a=c∧b=d.
Proof. unfold orp. intros. pose proof parif (par a b) (par a a). assert(a=c). assert ((par a a)∈(orp a b)).
pose proof H0 (par a a). apply (iffe2 H1). apply ori2. exact (eqi _). pose proof (H _ H1).
pose proof parif (par c d) (par c c). pose proof iffe1 (H3 _) H2. apply H4. intro. pose proof parif c d.
pose proof H6 c. pose proof (iffe2 H7 (ori1 (eqi c))). pose proof eqs H5. pose proof H9 _ H8.
pose proof parif a a. pose proof iffe1 (H11 c) H10. apply H12. intro. exact (eqs H13). intro. exact (eqs H13).
intro. pose proof parif a a. pose proof H6 a. pose proof iffe2 H7 (ori1 (eqi a)). pose proof H5 _ H8.
pose proof parif c c. pose proof iffe1 (H10 a) H9. apply H11. exact (fun x=>x). exact (fun x=>x).
assert (par (par c b) (par c c) = par (par c d) (par c c)).
exact (H1 (fun a=> par (par a b) (par a a)= par (par c d) (par c c)) H). pose proof parif (par c b) (par c c).
pose proof H3 (par c b). pose proof iffe2 H4 (ori1 (eqi _)). pose proof H2 _ H5. pose proof parif (par c d) (par c c).
pose proof iffe1 (H7 (par c b)) H6. apply andi. assumption. apply H8. intro. assert (b∈(par c d)).
pose proof parif c b. pose proof iffe2 (H10 b) (ori2 (eqi _)). exact (H9 _ H11). pose proof parif c d b. pose proof iffe1 H11 H10.
apply H12. intro. pose proof H13 (fun x=>par c x=par c d) H9. pose proof parif c d d. pose proof iffe2 H15 (ori2 (eqi d)).
pose proof eqs H14. pose proof H17 _ H16. pose proof parif c c d. pose proof iffe1 H19 H18. assert (d=c). apply H20. exact (fun x=>x).
exact (fun x=>x). pose proof eqs H21. exact (eq_transitivity _ _ _ _ H13 H22). exact (fun x=>x). intro. pose proof parif c b b.
pose proof iffe2 H10 (ori2 (eqi b)). pose proof parif c c b. pose proof H9 _ H11. pose proof iffe1 H12 H13. assert (b=c).
apply H14. exact (fun x=>x). exact (fun x=>x). pose proof parif (par c d) (par c c) (par c d).
pose proof iffe2 H16 (ori1 (eqi _)). pose proof eqs H. pose proof H18 _ H17. pose proof parif (par a b) (par a a) (par c d).
pose proof iffe1 H20 H19. pose proof parif c d d. pose proof iffe2 H22 (ori2 (eqi _)). apply H21. intro.
pose proof H24 _ H23. pose proof parif a b d. pose proof iffe1 H26 H25. apply H27. intro. pose proof eq_transitivity _ _ _ _ H28 H1.
pose proof eqs H29. exact (eq_transitivity _ _ _ _ H15 H30). intro. exact (eqs H28). intro. pose proof H24 _ H23. pose proof parif a a d.
pose proof iffe1 H26 H25. assert (d=a). apply H27. exact (fun x=>x). exact (fun x=>x). pose proof eq_transitivity _ _ _ _ H28 H1.
pose proof eqs H29. exact (eq_transitivity _ _ _ _ H15 H30). Qed.
Definition orpi := fun (a b c d:Set) => orp_intro a b c d.

Definition cart := fun X Y:Set => ⋃ (rep X (fun x:Set => rep Y (fun y:Set => orp x y))).
Notation "x × y" := (cart x y) (at level 9, right associativity).
Theorem cart_intro : forall X Y:Set, forall s:Set, s∈X×Y⇔∃x:Set, ∃y:Set, x∈X∧y∈Y∧(orp x y)=s.
Proof. intros. unfold cart. apply iffi. intro. pose proof iffe1 (uuniff _ _) H. apply H0. intros. pose proof ande2 H1.
pose proof ande1 H1. pose proof iffe1 (repif _ _ _) H3. apply H4. intros. pose proof ande1 H5. pose proof ande2 H5.
pose proof (eqs H7) _ H2. pose proof iffe1 (repif _ _ _) H8. apply H9. intros. pose proof ande1 H10. pose proof ande2 H10.
pose proof andi H11 H12. pose proof andi H6 H13. refine (exi t0 _). refine (exi t1 _). exact H14.
intro. apply (iffe2 (uuniff _ _)). apply H. intros x H0. apply H0. intros y H1.
assert (rep Y (fun y=> orp x y)∈(rep X (fun x=> rep Y (fun y=>orp x y))) ∧ s∈(rep Y (fun y=> orp x y))). apply andi.
apply (iffe2 (repif _ _ _)). refine (exi x _). apply andi. exact (ande1 H1). exact (eqi _). apply (iffe2 (repif _ _ _)).
refine (exi y _). apply andi. exact (ande1 (ande2 H1)). exact (ande2 (ande2 H1)). exact (exi (rep Y (fun y=> orp x y)) H2). Qed.
Definition carti := fun x y:Set => cart_intro x y.

Lemma ur1 : forall x:Set, x∉x.
Proof. refine (ax_fnd (fun x=> x∉x) _). intros. unfold not. intro. pose proof H x H0.  exact (H1 H0). Qed.
Lemma ur2 : forall x y:Set, x∈y->y∉x.
Proof. refine (ax_fnd (fun x=> forall y:Set, x∈y->y∉x) _). unfold not. intros.  exact (H y H1 x H1 H0). Qed.
Lemma non_0 : forall x:Set, x≠0-> ∃y:Set, y∈x.
Proof. intros. pose proof lem (∃y:Set, y∈x). apply H0. exact (fun x=>x). intro. pose proof lem_comm_ne _ _ H1.
assert (x=0). apply ax_ext. intros. pose proof zeroi. apply iffi. intro. pose proof H2 t H4. apply H5. intro. apply (H3 t H4).
exact (H H3 _). Qed.
Theorem reg : forall x:Set, non_emp x -> ∃y:Set, y∈x∧y∩x=0.
Proof. assert(forall x:Set, forall y:Set, x∈y->∃z:Set, z∈y∧z∩y=0).
apply (ax_fnd (fun x:Set => (forall y:Set, x∈y->∃z:Set, z∈y∧z∩y=0))). intros. pose proof lem (x∩y=0).
apply H1. intro. exact (exi x (andi H0 H2)). intro. pose proof non_0 (x∩y) H2. apply H3. intros. pose proof inse H4.
pose proof ande1 H5. pose proof ande2 H5. exact (H _ H6 _ H7). intros.
apply H0. intros. exact (H _ _ H1). Qed.