(*

-> Section 4 in paper
-> Union Types + Null + Intersection Types
-> Nominal types
-> Subtyping Distributivity

*)

Require Import Metalib.Metatheory.
Require Import LibTactics.
Require Import Lia.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_top : typ (*r top type *)
 | t_bot : typ (*r bottom type *)
 | t_arrow : typ -> typ -> typ (*r function types *)
 | t_union : typ -> typ -> typ (*r intersection *)
 | t_and : typ -> typ -> typ (*r intersection *)
 | t_unit : typ (* null *)
 | t_prim (n:var).

Definition envp : Set := list ( atom * typ ).

(*well-formdness type for *)
Inductive wft (PG:envp) : typ -> Prop :=
  | wft_top :
      wft PG t_top
  | wft_bot :
      wft PG t_bot
  | wft_int :
      wft PG t_int
  | wft_arrow : forall A B,
      wft PG A ->
      wft PG B ->
      wft PG (t_arrow A B)
  | wft_or : forall A B,
      wft PG A ->
      wft PG B ->
      wft PG (t_union A B)
  | wft_and : forall A B,
      wft PG A ->
      wft PG B ->
      wft PG (t_and A B)
  | wft_unit :
      wft PG t_unit
  | wft_prim : forall i A,
      binds i A PG ->
      wft PG (t_prim i).

Inductive okenvp : envp -> Prop :=
  | okenvp_empty :
      okenvp nil
  | okenvp_cons : forall (PG:envp) (i:var),
      okenvp PG ->
      i `notin` (dom PG) ->
      okenvp ((i, t_top) :: PG)
  | okenvp_sub : forall (PG:envp) (i j:var),
      okenvp PG ->
      wft PG (t_prim j) ->
      i `notin` (dom PG) ->
      okenvp ((i, (t_prim j)) :: PG).

(* defns DSub *)
Inductive declarative_subtyping (PG: envp) : typ -> typ -> Prop :=    (* defn declarative_subtyping *)
 | DS_refl : forall (A:typ),
     okenvp PG ->
     wft PG A ->
     declarative_subtyping PG A A
 | DS_trans : forall (A C B:typ),
     declarative_subtyping PG A B ->
     declarative_subtyping PG B C ->
     declarative_subtyping PG A C
 | DS_top : forall (A:typ),
     okenvp PG ->
     wft PG A ->
     declarative_subtyping PG A t_top
 | DS_bot : forall (A:typ),
     okenvp PG ->
     wft PG A ->
     declarative_subtyping PG t_bot A
 | DS_arrow : forall (A C B D:typ),
     declarative_subtyping PG B A ->
     declarative_subtyping PG C D ->
     declarative_subtyping PG (t_arrow A C) (t_arrow B D)
 | DS_and : forall (A B C:typ),
     declarative_subtyping PG A B ->
     declarative_subtyping PG A C ->
     declarative_subtyping PG A (t_and B C)
 | DS_andl : forall (A B:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG (t_and A B) A
 | DS_andr : forall (A B:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG (t_and A B) B
 | DS_or : forall (A B C:typ),
     declarative_subtyping PG A C ->
     declarative_subtyping PG B C ->
     declarative_subtyping PG (t_union A B) C
 | DS_orl : forall (A B:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG A (t_union A B)
 | DS_orr : forall (B A:typ),
     okenvp PG ->
     wft PG A -> wft PG B ->
     declarative_subtyping PG B (t_union A B)
 | DS_distArr : forall (A B1 B2:typ),
     okenvp PG ->
     wft PG A -> wft PG B1 -> wft PG B2 ->
     declarative_subtyping PG (t_and  (t_arrow A B1)   (t_arrow A B2) ) (t_arrow A (t_and B1 B2))
| DS_distArrU : forall (A1 B A2:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_and  (t_arrow A1 B)   (t_arrow A2 B) ) (t_arrow (t_union A1 A2) B)
 | DS_distOr : forall (A1 B A2:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_and  (t_union A1 B)   (t_union A2 B) ) (t_union  (t_and A1 A2)  B)
 | DS_prim : forall i A,
     okenvp PG ->
     binds i A PG ->
     declarative_subtyping PG (t_prim i) A.
(** definitions *)

(* defns Ordinary *)
Inductive ordu : typ -> Prop :=    (* defn ordu *)
 | OU_top :
     ordu t_top
 | OU_bot :
     ordu t_bot
 | OU_int :
     ordu t_int
 | OU_arrow : forall (A B:typ),
     ordu (t_arrow A B)
 | OU_and : forall (A B:typ),
     ordu A ->
     ordu B ->
     ordu (t_and A B)
 | OU_null :
     ordu t_unit
 | OU_prim : forall (i:var),
     ordu (t_prim i).

Inductive ordi : typ -> Prop :=    (* defn ordi *)
 | OI_top :
     ordi t_top
 | OI_bot :
     ordi t_bot
 | OI_int :
     ordi t_int
 | OI_arrow : forall (A B:typ),
     ordu A ->
     ordi B ->
     ordi (t_arrow A B)
 | OI_or : forall (A B:typ),
     ordi A ->
     ordi B ->
     ordi (t_union A B)
 | OI_null :
     ordi t_unit
 | OI_prim : forall (i:var),
     ordi (t_prim i).
(** definitions *)

(* defns Split *)
Inductive splu : typ -> typ -> typ -> Prop :=    (* defn splu *)
 | SpU_or : forall (A B:typ),
     splu (t_union A B) A B
 | SpU_andl : forall (A B A1 A2:typ),
     splu A A1 A2 ->
     splu (t_and A B) (t_and A1 B) (t_and A2 B)
 | SpU_andr : forall (A B B1 B2:typ),
     ordu A ->
     splu B B1 B2 ->
     splu (t_and A B) (t_and A B1) (t_and A B2).

Inductive spli : typ -> typ -> typ -> Prop :=    (* defn spli *)
 | SpI_and : forall (A B:typ),
     spli (t_and A B) A B
 | SpI_arrow : forall (A B C D:typ),
     spli B C D ->
     spli (t_arrow A B) (t_arrow A C) (t_arrow A D)
 | SpI_arrowUnion : forall (A D B C:typ),
     ordi D ->
     splu A B C ->
     spli (t_arrow A D) (t_arrow B D) (t_arrow C D)
 | SpI_orl : forall (A B A1 A2:typ),
     spli A A1 A2 ->
     spli (t_union A B) (t_union A1 B) (t_union A2 B)
 | SpI_orr : forall (A B B1 B2:typ),
     ordi A ->
     spli B B1 B2 ->
     spli (t_union A B) (t_union A B1) (t_union A B2).
(** definitions *)

(* defns SSub *)
Inductive algo_sub : envp -> typ -> typ -> Prop :=    (* defn algo_sub *)
 | AS_refl : forall PG A,
     okenvp PG ->
     wft PG A ->
     algo_sub PG A A
 | AS_prim_neq : forall PG i A n1 n2,
     okenvp ((i, A) :: PG) ->
     (* (issupertype PG n1 n2 = true) -> *)
     i <> n1 ->
     algo_sub PG (t_prim n1) (t_prim n2) ->
     algo_sub (((i, A))::PG) (t_prim n1) (t_prim n2)
 | AS_prim_eq : forall PG j n1 n2,
     okenvp (((n1,t_prim j))::PG) ->
     (* (issupertype PG n1 n2 = true) -> *)
     algo_sub PG (t_prim j) (t_prim n2) ->
     algo_sub (((n1,t_prim j))::PG) (t_prim n1) (t_prim n2)
 | AS_top : forall PG (A:typ),
     okenvp PG ->
     wft PG A ->
     algo_sub PG A t_top
 | AS_bot : forall PG (A:typ),
     okenvp PG ->
     wft PG A ->
     algo_sub PG t_bot A
 | AS_arrow : forall PG (A1 A2 B1 B2:typ),
     algo_sub PG B1 A1 ->
     algo_sub PG A2 B2 ->
     algo_sub PG (t_arrow A1 A2) (t_arrow B1 B2)
 | AS_and : forall PG (A B B1 B2:typ),
     spli B B1 B2 ->
     algo_sub PG A B1 ->
     algo_sub PG A B2 ->
     algo_sub PG A B
 | AS_andl : forall PG (A B A1 A2:typ),
     wft PG A2 ->
     spli A A1 A2 ->
     algo_sub PG A1 B ->
     algo_sub PG A B
 | AS_andr : forall PG (A B A1 A2:typ),
     wft PG A1 ->
     spli A A1 A2 ->
     algo_sub PG A2 B ->
     algo_sub PG A B
 | AS_or : forall PG (A B A1 A2:typ),
     splu A A1 A2 ->
     algo_sub PG A1 B ->
     algo_sub PG A2 B ->
     algo_sub PG A B
 | AS_orl : forall PG (A B B1 B2:typ),
     wft PG B2 ->
     splu B B1 B2 ->
     algo_sub PG A B1 ->
     algo_sub PG A B
 | AS_orr : forall PG (A B B1 B2:typ),
     wft PG B1 ->
     splu B B1 B2 ->
     algo_sub PG A B2 ->
     algo_sub PG A B.

#[export] Hint Resolve AS_refl : core.

(******************************************************************************)
(** * Size *)
Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
  match A1 with
    | t_int => 1
    | t_top => 1
    | t_bot => 1
    | t_unit => 1
    | t_prim _ => 1
    | t_arrow A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_and A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_union A2 B1 => 1 + (size_typ A2) + (size_typ B1)
  end.

Fixpoint size_envp (G : envp) := match G with
                                 | nil => 0
                                 | (i, A) :: G => size_envp G + size_typ A + 1
                                     end.

(* Definition size_envp (G : envp) := fold_right plus 0 (map size_typ G). *)

Lemma size_typ_min :
  forall A1, 1 <= size_typ A1.
Proof.
  induction A1; simpl in *; eauto; try lia.
Qed.

Create HintDb SubHd.
Create HintDb FalseHd.

#[export] Hint Resolve OI_top OI_bot OI_int OU_top OU_bot OU_int OU_arrow SpI_and SpU_or : core.
#[export] Hint Constructors algo_sub ordi ordu spli splu : SubHd.

(* Types are Either Ordinary or Splittable *)
Lemma ordu_or_split: forall A,
    ordu A \/ exists B C, splu A B C.
Proof with (eauto with SubHd ; intros).
  intros. induction A...
  - (* and *)
    lets [?|(?&?&?)]: IHA1;
      lets [?|(?&?&?)]: IHA2...
Qed.

Lemma ordi_or_split: forall A,
    ordi A \/ exists B C, spli A B C.
Proof with (eauto with SubHd ; intros).
  intros. induction A...
  - (* arrow *)
    lets [?|(?&?&?)]: ordu_or_split A1;
      lets [?|(?&?&?)]: IHA2...
  - (* and *)
    lets [?|(?&?&?)]: IHA1;
      lets [?|(?&?&?)]: IHA2...
Qed.

(* destrcut conjunctions *)
Ltac destruct_conj :=
  repeat match goal with H: ?T |- _ =>
                         match T with
                         | exists _ , _ => destruct H
                         | _ /\ _ => destruct H
                         end
         end.

(********************************************)
(*                                          *)
(*            Ltac solve_false              *)
(*  try solve the goal by contradiction     *)
(*                                          *)
(********************************************)
Ltac solve_false := try intro; try solve [false; eauto 3 with FalseHd].

#[export] Hint Extern 1 => match goal with
                           | H: _ = _ |- _ => inverts H; fail
                           | H: ordi _ |- _ => inverts H; fail
                           | H: ordu _ |- _ => inverts H; fail
                           | H: spli _ _ _ |- _ => inverts H; fail
                           | H: splu _ _ _ |- _ => inverts H; fail
                         end : FalseHd.

(* splittable types and disjoint types are not overlapping *)
Lemma splu_ord_false : forall A B C,
    splu A B C -> ordu A -> False.
Proof.
  introv. gen B C.
  induction A; intros B C s o;
    try solve [inverts* s];
    try solve [inverts* o];
    inverts o;
    inverts* s.
Qed.

Lemma spli_ord_false : forall A B C,
    spli A B C -> ordi A -> False.
Proof.
  introv. gen B C.
  induction A; intros B C s o;
    try solve [inverts* s];
    try solve [inverts* o];
    inverts o;
    inverts* s.
  applys splu_ord_false; eassumption.
Qed.

#[export] Hint Resolve spli_ord_false splu_ord_false : FalseHd.

(* lemmas for ordinary *)
Lemma spli_keep_ordu_l : forall A B C,
   ordu A -> spli A B C -> ordu B.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

Lemma spli_keep_ordu_r : forall A B C,
   ordu A -> spli A B C -> ordu C.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

Lemma splu_keep_ord_l : forall A B C,
   ordi A -> splu A B C -> ordi B.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

Lemma splu_keep_ord_r : forall A B C,
   ordi A -> splu A B C -> ordi C.
Proof.
  introv Hord Hspl.
  inductions Hspl; try destruct m; inverts* Hord.
Qed.

#[export] Hint Immediate spli_keep_ordu_l spli_keep_ordu_r
     splu_keep_ord_l splu_keep_ord_r : SubHd.

(* Subtyping *)
Lemma typ_size_lg_z : forall T, size_typ T > 0.
Proof.
  introv.
  pose proof (size_typ_min) T.
  inverts~ H.
Qed.

#[export] Hint Resolve typ_size_lg_z : core.

Lemma splu_decrease_size: forall A B C,
    splu A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof with (pose proof (typ_size_lg_z); simpl in *; try lia).
  introv H.
  induction H; simpl in *; eauto...
Qed.

Lemma spli_decrease_size: forall A B C,
    spli A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof with (pose proof (typ_size_lg_z); simpl in *; try lia).
  introv H.
  induction H; simpl in *; eauto...
  forwards (?&?): splu_decrease_size H0...
Qed.

Ltac s_spl_size :=
  try repeat match goal with
         | [ H: spli _ _ _ |- _ ] =>
           ( lets (?&?): spli_decrease_size H; clear H)
         | [ H: splu _ _ _ |- _ ] =>
           ( lets (?&?): splu_decrease_size H; clear H)
             end.

(********************************************)
(*                                          *)
(*               Ltac elia                 *)
(*  enhanced lia with split_decrease_size *)
(*                                          *)
(********************************************)
Ltac elia :=
  try solve [pose proof (typ_size_lg_z);
             s_spl_size; simpl in *; try lia].

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

Ltac indTypEnvSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : typ |- _ ] => (gen h) end;
  repeat match goal with | [ h : envp |- _ ] => (gen h) end;
  induction i as [|i IH]; [
    intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
  | intros ].
(* Splitting types is deterministic *)
(********************************************)
(*                                          *)
(*          Lemma split_unique              *)
(*                                          *)
(********************************************)
Lemma splu_unique : forall T A1 A2 B1 B2,
    splu T A1 B1 -> splu T A2 B2 -> A1 = A2 /\ B1 = B2.
Proof with (try eassumption; solve_false; subst~).
  intro T.
  induction T; intros;
    inverts H; inverts H0...
  - forwards (?&?): IHT1 H4 H5...
  - forwards (?&?): IHT2 H6 H7...
Qed.

Lemma spli_unique : forall T A1 A2 B1 B2,
    spli T A1 B1 -> spli T A2 B2 -> A1 = A2 /\ B1 = B2.
Proof with (try eassumption; solve_false; subst~).
  intro T.
  induction T; intros;
    inverts H; inverts H0...
  - forwards (?&?): IHT2 H4 H5...
  - forwards (?&?): splu_unique H6 H7...
  - forwards (?&?): IHT1 H4 H5...
  - forwards (?&?): IHT2 H6 H7...
Qed.

(********************************************)
(*                                          *)
(*             Ltac auto_unify              *)
(*                                          *)
(*  extends choose_unify                    *)
(*  no solve_false at the end                *)
(*                                          *)
(********************************************)
Ltac auto_unify :=
  simpl in *;
  try repeat match goal with
         | [ H1: spli ?A  _ _ , H2: spli ?A _ _ |- _ ] =>
           (forwards (?&?): spli_unique H1 H2;
            subst; clear H2)
         | [ H1: splu ?A  _ _ , H2: splu ?A _ _ |- _ ] =>
           (forwards (?&?): splu_unique H1 H2;
            subst; clear H2)
         end.

Ltac inverts_all_ord :=
  repeat match goal with
         | H: ordu (_ _ _) |- _ => inverts H
         | H: ordu (_ _) |- _ => inverts H
         | H: ordi (_ _ _) |- _ => inverts H
         | H: ordi (_ _) |- _ => inverts H
         end.

Ltac inverts_all_spl :=
  repeat match goal with
         | H: splu (_ _ _) _ _ |- _ => inverts H
         | H: splu (_ _) _ _ |- _ => inverts H
         | H: spli (_ _ _) _ _ |- _ => inverts H
         | H: spli (_ _) _ _ |- _ => inverts H
         end.

(******************************************************************************)
(* * wft *)

Ltac wft_inv := match goal with
                  H: wft ?G _ |- wft ?G ?A => match type of H with
                                           context[A] => inverts H; try assumption
                                         end
                end.
#[export] Hint Extern 1 (wft _ _) => wft_inv : core.

Lemma wft_splu_1 : forall G A1 A2 B,
    splu B A1 A2 -> wft G B -> wft G A1.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
Qed.
Lemma wft_splu_2 : forall G A1 A2 B,
    splu B A1 A2 -> wft G B -> wft G A2.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
Qed.
Lemma wft_splu : forall G A1 A2 B,
    splu B A1 A2 -> wft G A1 -> wft G A2 -> wft G B.
Proof.
  introv Spl Wf1 Wf2.
  induction* Spl. all: constructor~.
Qed.
#[export] Hint Immediate wft_splu_1 wft_splu_2 wft_splu : core.

Lemma wft_spli_1 : forall G A1 A2 B,
    spli B A1 A2 -> wft G B -> wft G A1.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
  inverts* Wf.
Qed.
Lemma wft_spli_2 : forall G A1 A2 B,
    spli B A1 A2 -> wft G B -> wft G A2.
Proof.
  introv Spl Wf.
  induction* Spl. all: constructor~.
  inverts* Wf.
Qed.
Lemma wft_spli : forall G A1 A2 B,
    spli B A1 A2 -> wft G A1 -> wft G A2 -> wft G B.
Proof.
  introv Spl Wf1 Wf2.
  induction* Spl. all: constructor*. eauto using wft_splu.
Qed.
#[export] Hint Immediate wft_spli_1 wft_spli_2 wft_spli: core.

Ltac inverts_all_wft :=
  repeat match goal with
         | H: wft _ (_ _ _) |- _ => inverts H
         | H: wft _ (_ _) |- _ => inverts H
         | H: wft _ ?A, Hspl: spli ?A _ _ |- _ => forwards: wft_spli_1 Hspl H; forwards: wft_spli_2 Hspl H; clear H
         | H: wft _ ?A, Hspl: splu ?A _ _ |- _ => forwards: wft_splu_1 Hspl H; forwards: wft_splu_2 Hspl H; clear H
         end.

#[export] Hint Constructors wft okenvp : core.

Lemma wf_typ_weakening : forall p T G,
  wft G T ->
  okenvp (p::G) ->
  wft (p::G) T.
Proof with simpl_env; eauto.
  introv Hwf_typ Hk.
  induction Hwf_typ; intros; subst...
Qed.

Lemma okenvp_uniq : forall G,
  okenvp G -> uniq G.
Proof.
  introv H. induction* H.
Qed.

Lemma wft_in_domain : forall G n,
    wft G (t_prim n) -> n `in` dom G.
Proof.
  introv H.
  inductions H. eauto.
Qed.

Lemma wft_strenthen_prim : forall G m B n,
   wft ((m,B)::G) (t_prim n) -> m <> n -> wft G (t_prim n) .
Proof.
  introv Wf Neq. inductions Wf; eauto.
  inverts* H. injection H0; intros; subst*.
  contradiction.
Qed.

Lemma algo_sub_wft : forall G A B,
    algo_sub G A B -> okenvp G /\ wft G A /\ wft G B.
Proof with split; destruct_conj; eauto using wf_typ_weakening.
  introv H.
  induction* H...
Qed.

#[export] Hint Extern 1 (wft _ ?A) =>  match goal with
                             | H: algo_sub _ _ _ |- _ =>
                               match type of H with context[A] => forwards (?&?&?): algo_sub_wft H end
                             | Hspl: spli ?B A _, H: algo_sub _ _ _ |- _ =>
                               match type of H with context[B] => forwards (?&?&?): algo_sub_wft H end
                             | Hspl: spli ?B _ A, H: algo_sub _ _ _ |- _ =>
                               match type of H with context[B] => forwards (?&?&?): algo_sub_wft H end
                             | Hspl: splu ?B _ A, H: algo_sub _ _ _ |- _ =>
                               match type of H with context[B] => forwards (?&?&?): algo_sub_wft H end
                             end : core.

Lemma okenvp_inv : forall a PG,
    okenvp (a::PG) -> okenvp PG.
Proof.
  introv Ok. inverts~ Ok.
Qed.

#[export] Hint Immediate okenvp_inv : core.

(******************************************************************************)
(* algorithm correctness *)

(* Lemma 13 *)

Lemma algo_sub_arrow_inv : forall G A B C D,
      algo_sub G (t_arrow A B) (t_arrow C D) ->
      (algo_sub G C A) /\ (algo_sub G B D).
Proof with (try eassumption).
  introv s.
  indTypSize (size_typ (t_arrow A B) + size_typ (t_arrow C D)).
  inverts s; inverts_all_spl; inverts_all_ord; inverts_all_wft; try assumption;
    repeat match goal with
           | H: algo_sub _ (t_arrow _ _) (t_arrow _ _) |- _ => forwards (?&?): IH H; elia; clear H
           end.
  all: split; eauto 3 with *.
  (* refl *)
  all: constructor~; wft_inv.
Qed.

Lemma double_split : forall T A1 A2 B1 B2,
    splu T A1 A2 -> spli T B1 B2 ->
    ((exists C1 C2, spli A1 C1 C2 /\ splu B1 C1 A2 /\ splu B2 C2 A2) \/
    (exists C1 C2, spli A2 C1 C2 /\ splu B1 A1 C1 /\ splu B2 A1 C2)) \/
    ((exists C1 C2, splu B1 C1 C2 /\ spli A1 C1 B2 /\ spli A2 C2 B2) \/
    (exists C1 C2, splu B2 C1 C2 /\ spli A1 B1 C1 /\ spli A2 B1 C2)).
Proof with exists; repeat split*.
  introv Hu Hi.
  indTypSize (size_typ T).
  inverts keep Hu; inverts keep Hi.
  - (* spli or *) left. left...
  - (* spli or *) left. right...
  - (* splu and *) right. left...
  - (* splu and *) right. right...
Qed.

Ltac double_split_inv := match goal with
                           H1: spli ?A _ _, H2: splu ?A _ _ |- _ => forwards [ [?|?] | [?|?] ]: double_split H2 H1
                         end; destruct_conj.

Lemma algo_sub_or_inv : forall G A A1 A2 B,
    algo_sub G A B -> splu A A1 A2 ->
    algo_sub G A1 B /\ algo_sub G A2 B.
Proof with (auto_unify; try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; solve_false; auto_unify; auto.
  1,2: split; eauto 3 with *.
  1,4,5: (* splu A *)
    repeat match goal with
              H1 : algo_sub _ ?A ?B, H2 : splu ?A _ _ |- _ => forwards(?&?): IH H2 H1; clear H1; elia
           end; split...
  1,2:  (* double split A *)
    double_split_inv; inverts_all_wft;
      try match goal with
            H1 : algo_sub _ ?A ?B, H2 : splu ?A _ _ |- _ => forwards(?&?): IH H2 H1; elia
          end; split...
Qed.

Ltac splu_l_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : splu ?A _ _ |- _ => forwards(?&?): algo_sub_or_inv H1 H2; clear H1; elia
                   end.

Lemma algo_sub_orlr_inv : forall G A B B1 B2,
    algo_sub G A B -> ordu A -> splu B B1 B2 ->
    algo_sub G A B1 \/ algo_sub G A B2.
Proof with (solve_false; auto_unify; try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; solve_false; auto_unify; auto.
  1,2: eauto 3 with *.
  1: (* double split *)
    double_split_inv; inverts_all_wft;
      repeat match goal with
               H0: ordu ?A, H1 : algo_sub _ ?A ?B, H2 : splu ?B _ _ |- _ => forwards [?|?]: IH H0 H1 H2; clear H1; elia
             end...
  1,2 : match goal with
              H1 : algo_sub _ ?A ?B, H2 : splu ?B _ _ |- _ => forwards [?|?]: IH H1 H2; elia
        end...
Qed.

Ltac splu_r_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : splu ?B _ _, H3: ordu ?A |- _ => forwards[?|?]: algo_sub_orlr_inv H1 H3 H2; clear H1; elia
                     end.

Lemma algo_sub_and_inv : forall G A B B1 B2,
    algo_sub G A B -> spli B B1 B2 -> algo_sub G A B1 /\ algo_sub G A B2.
Proof with (auto_unify; try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; inverts_all_wft; solve_false; auto_unify; auto.
  1,2: split; eauto 3 with *.
  1,3,4,5: (* spli B *)
    repeat match goal with
              H1 : algo_sub _ ?A ?B, H2 : spli ?B _ _ |- _ => forwards(?&?): IH H1 H2; clear H1; elia
           end; split...
  1: splu_l_inv; split...
  1,2:  (* double split A *)
    double_split_inv; inverts_all_wft;
      try match goal with
            H1 : algo_sub _ ?A ?B, H2 : spli ?B _ _ |- _ => forwards(?&?): IH H1 H2; elia
          end; split...
Qed.

Ltac spli_r_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : spli ?B _ _ |- _ => forwards(?&?): algo_sub_and_inv H1 H2; clear H1; elia
                   end.

Lemma algo_sub_andlr_inv : forall G A B A1 A2,
    algo_sub G A B -> spli A A1 A2 -> ordi B ->
    algo_sub G A1 B \/ algo_sub G A2 B.
Proof with (try eassumption; elia; eauto 3 with SubHd).
  introv Hsub Hspl.
  indTypSize (size_typ A + size_typ B).
  inverts Hsub; inverts_all_spl; inverts_all_ord; inverts_all_wft; solve_false; auto_unify; auto;
    repeat match goal with
              H0: ordi ?B, H1 : algo_sub ?A ?B, H2 : spli ?A _ _ |- _ => forwards [?|?]: IH H1 H2 H0; clear H1; elia
    end.
  1,2: eauto 3 with *.
  1,3,4,5:  (* spli A *)
    repeat match goal with
             H1 : algo_sub _ ?A ?B, H2 : spli ?A _ _ |- _ => forwards[?|?]: IH H1 H2; clear H1; elia
                end...
  1: (* double split *)
    double_split_inv; inverts_all_wft;
      repeat match goal with
               H0: ordi ?B, H1 : algo_sub _ ?A ?B, H2 : spli ?A _ _ |- _ => forwards [?|?]: IH H1 H2 H0; clear H1; elia
             end...
  splu_r_inv...
Qed.

Ltac spli_l_inv := match goal with
                     H1 : algo_sub _ ?A ?B, H2 : spli ?A _ _, H3: ordi ?B |- _ => forwards[?|?]: algo_sub_orlr_inv H1 H2 H3; clear H1; elia
                   end.

(********************************************)
(*                                          *)
(*             Ltac auto_inv                *)
(*                                          *)
(*  extends choose_unify                    *)
(*  no solve_false at the end               *)
(*                                          *)
(********************************************)
Ltac auto_inv :=
  repeat try match goal with
         | [ H1: algo_sub _ (t_arrow _ _) (t_arrow _ _) |- _ ] =>
           try (forwards~ (?&?): algo_sub_arrow_inv H1; clear H1)
         | [ H1: algo_sub _ ?A (t_and _ _) |- _ ] =>
           try (forwards~ (?&?): algo_sub_and_inv H1; clear H1)
      end;
  repeat try match goal with
         | [ H1: algo_sub _ ?A ?B, H2: spli ?B _ _ |- _ ] =>
           try (forwards~ (?&?): algo_sub_and_inv H1 H2; clear H1)
         | [ H1: algo_sub _ ?A (t_and _ _) |- _ ] =>
           try (forwards~ (?&?): algo_sub_and_inv H1; clear H1)
      end;
  repeat try match goal with
         | [ Hord: ordi ?B, H1: algo_sub _ ?A ?B, H2: spli ?A _ _ |- _ ] =>
           try (forwards~ [?|?]: algo_sub_andlr_inv H1 H2 Hord; clear H1)
         | [ Hord: ordi ?B, H1: algo_sub _ (t_and  _ _)  ?B |- _ ] =>
           try (forwards~ [?|?]: algo_sub_andlr_inv H1 Hord; clear H1)
      end;
  repeat try match goal with
         | [ H1: algo_sub _ ?A ?B, H2: splu ?A _ _ |- _ ] =>
           try (forwards~ (?&?): algo_sub_or_inv H1 H2; clear H1)
         | [ H1: algo_sub _ (t_union _ _) ?B |- _ ] =>
           try (forwards~ (?&?): algo_sub_or_inv H1; clear H1)
         end;
  repeat try match goal with
         | [ Hord: ordu ?A, H1: algo_sub _ ?A ?B, H2: splu ?B _ _ |- _ ] =>
           try (forwards~ [?|?]: algo_sub_orlr_inv H1 Hord H2; clear H1)
         | [ Hord: ordu ?A, H1: algo_sub _ ?A (t_union _ _) |- _ ] =>
           try (forwards~ [?|?]: algo_sub_orlr_inv H1 Hord; clear H1)
             end.

Lemma trans_via_top : forall G A B,
    algo_sub G t_top B -> wft G A -> algo_sub G A B.
Proof.
  introv s w.
  inductions s; inverts_all_wft; eauto 3 with SubHd; solve_false.
  forwards~ : IHs1. forwards~ : IHs2. applys~ AS_and H.
Qed.

(******************************************************************************)
(** * Nominal types *)
Lemma algo_sub_in_domain_1 : forall G n A,
  algo_sub G (t_prim n) A -> n `in` dom G.
Proof with solve_false.
  introv Sub. apply algo_sub_wft in Sub. destruct_conj.
  applys~ wft_in_domain.
Qed.

Lemma algo_sub_in_domain_2 : forall G n A,
  algo_sub G A (t_prim n) -> n `in` dom G.
Proof with solve_false.
  introv Sub. apply algo_sub_wft in Sub. destruct_conj.
  applys~ wft_in_domain.
Qed.

#[export] Hint Immediate algo_sub_in_domain_1 algo_sub_in_domain_2 : core.

Lemma algo_sub_weakening : forall p G S T,
  algo_sub G S T ->
  okenvp (p::G) ->
  algo_sub (p::G) S T.
Proof with eauto using wf_typ_weakening.
  introv Sub Ok.
  induction Sub; intros; subst...
  1: (* prim_neq *)
    { clear IHSub. destruct p. case_eq (eq_dec a n1); intros; subst.
       - false. apply algo_sub_in_domain_1 in Sub.
         apply okenvp_uniq in Ok. inverts Ok.
         rewrite dom_cons in H6. eauto.
       - applys~ AS_prim_neq.
         applys~ AS_prim_neq.
  }
  1: (* prim_eq *)
    { clear IHSub. destruct p. case_eq (eq_dec a n1); intros; subst.
      - false.
        apply okenvp_uniq in Ok. inverts Ok.
         rewrite dom_cons in H5. eauto.
       - applys~ AS_prim_neq.
         applys~ AS_prim_eq.
  }
  all: try constructor~...
  all: try forwards: IHSub...
  all: try forwards: IHSub1...
  all: try forwards: IHSub2...
  all: try eauto 2 with *.
  all: try solve [applys AS_andl; try eassumption; eauto using wf_typ_weakening].
  all: try solve [applys AS_andr; try eassumption; eauto using wf_typ_weakening].
  all: try solve [applys AS_orl; try eassumption; eauto using wf_typ_weakening].
  all: try solve [applys AS_orr; try eassumption; eauto using wf_typ_weakening].
Qed.

Lemma algo_sub_completeness: forall i A G,
    okenvp G -> binds i A G -> algo_sub G (t_prim i) A.
Proof.
  introv WF HB. gen i A.
  induction WF; intros; solve_false.
  - inverts HB.
    + injection H0; intros; subst.
      applys* AS_top.
    + applys~ algo_sub_weakening.
  - inverts HB.
    + injection H1; intros; subst.
      applys* AS_prim_eq.
    + applys algo_sub_weakening.
      applys* IHWF. constructor*.
Qed.

Lemma algo_sub_prim_eq:  forall PG j n1 A,
    okenvp ((n1,t_prim j) :: PG) ->
    algo_sub PG (t_prim j) A ->
    algo_sub (((n1,t_prim j))::PG) (t_prim n1) A.
Proof with try eassumption.
  introv Uni Sub.
  inductions Sub; solve_false;
    assert (wft ((n1, t_prim j) :: PG) (t_prim n1)) by eauto;
    eauto 3 with SubHd.
  - forwards~ : IHSub1... forwards~ : IHSub2...
    eauto 3 with SubHd.
  - forwards~ : IHSub...
    eauto 3 using wf_typ_weakening with SubHd.
  - forwards~ : IHSub...
    eauto 3 using wf_typ_weakening with SubHd.
Qed.

#[export] Hint Resolve algo_sub_prim_eq : SubHd.

Lemma algo_sub_prim_strenthen_head : forall i A G n B,
    algo_sub ((i, A) :: G) (t_prim n) B -> i <> n -> wft G B -> algo_sub G (t_prim n) B.
Proof with try eassumption; eauto 3 with SubHd.
  introv Sub Neq Wf.
  inductions Sub; solve_false...
  all: try assert (okenvp G) by inverts~ H.
  all: assert (HWF: wft ((i, A) :: G) (t_prim n)) by eauto.
  all: assert (wft G (t_prim n)).
  all: inverts HWF as Bind; inverts Bind as Heq;
    try injection Heq; intros; subst*; eauto; try solve [contradiction].
  all: eauto 3 with SubHd.
  - forwards~ : IHSub1. eauto. forwards~ : IHSub2...
Qed.

Lemma algo_sub_prim_ord : forall G n A,
   algo_sub G (t_prim n) A -> ordu A -> ordi A -> A = t_top \/ exists m, A = t_prim m.
Proof.
  introv Sub Ord1 Ord2.
  inductions Sub; solve_false.
  all: try solve [left~].
  all: try solve [right*].
Qed.
(******************************************************************************)
Ltac eassumption_spl :=
  match goal with
    | |- spli _ _ _ => try eassumption
    | |- splu _ _ _ => try eassumption
  end.
#[export] Hint Extern 0 => eassumption_spl : core.

Local Ltac algo_trans_autoIH :=
  match goal with
  | [ IH: forall G : envp, _ , H1: algo_sub _ ?A ?B , H2: algo_sub _ ?B ?C |- algo_sub _ ?A ?C ] =>
    (applys~ IH H1 H2; elia; auto)
  | [ IH: forall G : envp, _ , H1: algo_sub _ ?A ?B  |- algo_sub _ ?A ?C ] =>
    (applys~ IH H1; elia; try constructor~)
  | [ IH: forall G : envp, _ , H2: algo_sub _ ?B ?C |- algo_sub _ ?A ?C ] =>
    (applys~ IH H2; elia; try constructor~)
  end.

Lemma algo_sub_prim_neq : forall i A n m G,
    algo_sub ((i,A)::G) (t_prim n) (t_prim m) -> i <> n -> i <> m.
Proof.
  introv Sub Neq.
  inverts Sub; solve_false.
  - subst. apply okenvp_uniq in H4. inverts H4.
    forwards* : algo_sub_in_domain_2 G m.
Qed.

Lemma algo_sub_trans : forall G A B C, algo_sub G A B -> algo_sub G B C -> algo_sub G A C.
Proof with (solve_false; auto_unify; try eassumption_spl; auto_inv; inverts_all_wft; eauto 3 with SubHd; try solve algo_trans_autoIH).
  introv s1 s2.
  indTypEnvSize (size_envp G + size_typ A + size_typ B + size_typ C).
  forwards(?&?&?): algo_sub_wft s1. forwards(?&?&?): algo_sub_wft s2.
  lets [Hi|(?&?&Hi)]: ordi_or_split C...
  - lets [Hu|(?&?&Hu)]: ordu_or_split A...
    + lets [Hi'|(?&?&Hi')]: ordi_or_split B...
      lets [Hu'|(?&?&Hu')]: ordu_or_split B...
      lets [Hi''|(?&?&Hi'')]: ordi_or_split A...
      * (* double ord A B *)
        assert (okenvp G) by eauto.
        inverts keep s1; auto_unify...
        ** (* prim neq *)
          lets [Hu''|(?&?&Hu'')]: ordu_or_split C.
          *** forwards~ [?|(?&?)]: algo_sub_prim_ord s2 Hu''; subst; solve_false.
              1: { eauto 4 with SubHd. }
              applys algo_sub_weakening.
              applys~ IH...
              applys~ algo_sub_prim_strenthen_head s2.
              { assert (n2 `in` dom PG) by applys* wft_in_domain.
                apply okenvp_uniq in H. inverts H. intro HF. subst*. }
              { applys wft_strenthen_prim. now eauto.
                applys algo_sub_prim_neq s2.
                applys~ algo_sub_prim_neq s1. }
              now elia. now auto.
          *** auto_inv.
              { applys AS_orl... }
              { applys AS_orr... }
        ** (* prim eq *)
          lets [Hu''|(?&?&Hu'')]: ordu_or_split C.
          *** forwards~ [?|(?&?)]: algo_sub_prim_ord s2 Hu''; subst; solve_false.
              1: { eauto 4 with SubHd. }
              case_eq (eq_dec n1 n2); intros; subst~.
              applys~ algo_sub_prim_eq.
              apply algo_sub_prim_strenthen_head in s2; auto.
              applys IH... now elia.
              { applys wft_strenthen_prim. now eauto.
                applys~ algo_sub_prim_neq s2. }
          *** auto_inv.
              { applys AS_orl... }
              { applys AS_orr... }
        ** (* top *) applys~ trans_via_top.
        ** (* arrow *) inverts~ s2...
           (* *** applys AS_top... *)
           *** applys AS_arrow...
           *** applys AS_orl...
           *** applys AS_orr...
      * applys AS_andl...
      * applys AS_andr...
    + lets [Hi'|(?&?&Hi')]: ordi_or_split A...
      * applys AS_or Hu...
      * assert (algo_sub G x C)...
        assert (algo_sub G x0 C)...
  - applys AS_and Hi...
Qed.

#[export] Hint Resolve algo_sub_trans : SubHd.

Lemma algo_sub_symm_and: forall G A B,
    wft G A -> wft G B -> okenvp G -> algo_sub G (t_and A B) (t_and B A).
Proof with eauto 3 with SubHd.
  intros. applys~ AS_and...
Qed.

Lemma algo_sub_symm_or: forall G A B,
    wft G A -> wft G B -> okenvp G ->
    algo_sub G (t_union A B) (t_union B A).
Proof with eauto 3 with SubHd.
  intros. applys~ AS_or...
Qed.

Ltac split_inter_constructors :=
  applys* SpI_and + applys* SpI_orl +
  applys* SpI_arrow + applys* SpI_orl.
Ltac split_union_constructors :=
  applys* SpU_or + applys* SpU_andl.
Ltac swap_or_r := applys algo_sub_trans; [ | applys algo_sub_symm_or ].
Ltac swap_and_l := applys algo_sub_trans; [ (applys algo_sub_symm_and) | ].
Ltac split_r := applys AS_and; try split_inter_constructors.
Ltac split_l := applys AS_or; try split_union_constructors.
Ltac use_left_l := applys AS_andl; try split_inter_constructors.
Ltac use_right_l := applys AS_andr; try split_inter_constructors.
Ltac use_left_r := applys AS_orl; try split_union_constructors.
Ltac use_right_r := applys AS_orr; try split_union_constructors.

Ltac match_or := split_l; [ use_left_r | use_right_r].
Ltac match_and := split_r; [ use_left_l | use_right_l].
Ltac match_or_rev := split_l; [ use_right_r |  use_left_r ].
Ltac match_and_rev := split_r; [ use_right_l | use_left_l ].
Ltac swap_or_l := applys algo_sub_trans; [ applys algo_sub_symm_or | ].
Ltac swap_and_r := applys algo_sub_trans; [ | (applys algo_sub_symm_and) ].

Lemma algo_sub_distArrU: forall G A B C,
    wft G A -> wft G B -> wft G C -> okenvp G ->
    algo_sub G (t_and (t_arrow A C) (t_arrow B C)) (t_arrow (t_union A B) C).
Proof with eauto.
  introv.
  indTypSize (size_typ C).
  lets [Hi1|(?&?&Hi1)]: ordi_or_split C.
  - applys AS_and; eauto 3 with SubHd.
    use_left_l... use_right_l...
  - (* split C x x0 *)
    forwards~ Hs1: IH A B x... now elia.
    forwards~ Hs2: IH A B x0... now elia.
    applys AS_and. now eauto 3 with SubHd.
    + applys algo_sub_trans Hs1. match_and...
      applys AS_arrow... eauto 3 with SubHd.
      applys AS_arrow... eauto 3 with SubHd.
    + applys algo_sub_trans Hs2. match_and...
      applys AS_arrow... eauto 3 with SubHd.
      applys AS_arrow... eauto 3 with SubHd.
Qed.

#[export] Hint Resolve algo_sub_distArrU : SubHd.

Local Ltac auto_sub :=
  match goal with
        | |- algo_sub _ (t_arrow (t_union _ _) _) (t_and _ _) => split_r; auto_sub
        | H1: algo_sub _ ?A ?B, H2: algo_sub _ ?B ?C |- algo_sub _ ?A ?C => applys algo_sub_trans H1 H2
        | |- algo_sub _ ?A (t_union ?A _) => use_left_r; auto
        | |- algo_sub _ ?A (t_union _ ?A) => use_right_r; auto
        | |- algo_sub _ (t_and ?A _) ?A => use_left_l; auto
        | |- algo_sub _ (t_and _ ?A) ?A => use_right_l; auto
        | |- algo_sub _ ?A ?A => applys AS_refl; auto_sub
        | |- algo_sub _ (t_arrow _ _) (t_arrow _ _) => applys AS_arrow; auto_sub
        | |- algo_sub _ (t_and _ _) (t_and _ _) => match_and; auto with *
        | |- algo_sub _ (t_and (t_union _ _) (t_union _ _)) (t_union (t_and _ _) _) =>
          match_and; auto with *
        | |- algo_sub _ (t_and (t_union _ _) (t_union _ _)) (t_union _ (t_and _ _)) =>
          swap_or_r; auto with *; match_and; match_or_rev; auto with *

        | |- algo_sub _ _ (t_union _ _) => match_or; try applys AS_refl; auto with *
        | |- algo_sub _ (t_union _ _) (_ (t_union _ _)) => match_or; auto with *
        | |- algo_sub _ (t_and (t_union _ _) _) (t_union (t_and _ _) (t_and _ _)) =>
          match_or; auto with *
        | |- algo_sub _ (t_and _ (t_union _ _)) (t_union (t_and _ _) (t_and _ _)) =>
          swap_and_l; auto with *; match_or; match_and_rev; auto with *

        | |- algo_sub _ (t_and _ _) (_ (t_and _ _)) => match_and; auto with *
        | |- algo_sub _ (t_union _ _) (_ _ (t_union _ _)) => match_or; auto with *
        | |- algo_sub _ (_ _ (t_and _ _)) (t_and _ _) => match_and; auto with *
        | |- _ => auto
  end.

Lemma algo_sub_soundness: forall i j G,
    algo_sub G (t_prim i) (t_prim j) ->
    i=j \/ binds i (t_prim j) G \/ exists A, binds i A G /\ algo_sub G A (t_prim j).
Proof.
  introv Sub.
  inductions Sub; solve_false.
  - now tauto.
  - forwards~ [?|[?|(?&?&?)]]: IHSub.
    right. right. exists. splits*.
    applys~ algo_sub_weakening.
  - right. right. exists (t_prim j0). splits*.
    applys~ algo_sub_weakening.
Qed.

(******************************************************************************)
#[export] Hint Constructors declarative_subtyping : SubHd.

Lemma DS_distArrRev : forall PG (A B1 B2:typ),
     okenvp PG ->
     wft PG A -> wft PG B1 -> wft PG B2 ->
     declarative_subtyping PG (t_arrow A (t_and B1 B2)) (t_and  (t_arrow A B1)   (t_arrow A B2) ).
Proof.
  introv Ok Wf1 Wf2 Wf3.
  applys* DS_and; applys DS_arrow; eauto with SubHd.
Qed.

Lemma DS_distArrURev : forall PG (A1 A2 B:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_arrow (t_union A1 A2) B) (t_and  (t_arrow A1 B)   (t_arrow A2 B) ).
Proof.
  introv Ok Wf1 Wf2 Wf3.
  applys* DS_and; applys DS_arrow; eauto with SubHd.
Qed.

Lemma dsub_symm_and: forall G A B,
    okenvp G -> wft G A -> wft G B -> declarative_subtyping G (t_and A B) (t_and B A).
Proof.
  intros.
  applys DS_and; eauto with SubHd.
Qed.

Lemma dsub_symm_or: forall G A B,
    okenvp G -> wft G A -> wft G B -> declarative_subtyping G (t_union A B) (t_union B A).
Proof.
  intros.
  applys DS_or; eauto with SubHd.
Qed.

#[export] Hint Resolve dsub_symm_and dsub_symm_or : SubHd.

Lemma DS_distAnd : forall PG (A1 A2 B:typ),
     okenvp PG ->
     wft PG A1 -> wft PG A2 -> wft PG B ->
     declarative_subtyping PG (t_and  (t_union A1 A2)  B) (t_union  (t_and A1 B)   (t_and A2 B) ).
Proof.
  introv Ok Wf1 Wf2 Wf3.
  applys DS_trans; [ | applys~ DS_distOr].
  applys DS_and; applys DS_trans.
  2,4: applys~ dsub_symm_or.
  all: applys DS_trans; [ | applys~ DS_distOr]; applys DS_and.
  all: applys DS_trans; [ | applys~ dsub_symm_or].
  1: applys* DS_andl.
  all: applys DS_trans.
  1,3,5: applys~ DS_andr.
  all: try solve [applys~ DS_orl]; try solve[applys~ DS_orr].
Qed.

#[export] Hint Resolve DS_distArrRev DS_distArrURev DS_distAnd : SubHd.

Lemma decl_sub_weakening : forall p G S T,
  declarative_subtyping G S T ->
  okenvp (p::G) ->
  declarative_subtyping (p::G) S T.
Proof with eauto 4 using wf_typ_weakening with SubHd.
  introv Sub Ok.
  induction Sub; intros; subst...
  all: constructor...
  destruct p. applys~ binds_cons_3.
Qed.

Lemma dsub_splu: forall G A B C,
    splu A B C -> okenvp G -> wft G A -> declarative_subtyping G B A /\ declarative_subtyping G C A.
Proof with intuition.
  introv Spl Ok Wf.
  induction Spl; inverts_all_wft; intuition eauto.
  all: try forwards (?&?): IHSpl.
  all: eauto 3 with SubHd.
  - applys DS_and. applys~ DS_trans. applys~ DS_andl. now auto.
    applys~ DS_andr.
  - eauto with SubHd.
  - eauto with SubHd.
  - eauto with SubHd.
Qed.

Lemma dsub_spli: forall G A B C,
    spli A B C -> okenvp G -> wft G A -> declarative_subtyping G A B /\ declarative_subtyping G A C.
Proof with intuition.
  introv Spl Ok Wf.
  induction Spl; inverts_all_wft; forwards~ : dsub_splu; intuition eauto.
  all: try forwards (?&?): IHSpl.
  all: eauto 3 with SubHd.
  all: eauto with SubHd.
Qed.

#[export] Hint Resolve dsub_splu dsub_spli : SubHd.

Lemma dsub_or: forall G A B C,
    okenvp G -> wft G A -> splu A B C -> declarative_subtyping G A (t_union B C).
Proof with (inverts_all_wft; eauto 3 with SubHd).
  introv Ok Wf Spl.
  induction Spl; try intuition; eauto 3 with SubHd.
  - applys DS_trans.
    2: { applys* DS_distAnd... }
    applys* DS_and... applys DS_trans. applys* DS_andl.
    applys* IHSpl.
  - applys~ DS_trans. applys~ dsub_symm_and.
    applys DS_trans (t_union (t_and B1 A) (t_and B2 A)).
    1: { applys~ DS_trans.
        2: { applys~ DS_distAnd... }
        applys* DS_and... applys DS_trans. applys* DS_andl.
    applys* IHSpl. }
    applys DS_or.
    applys DS_trans (t_and A B1)...
    applys DS_trans (t_and A B2)...
Qed.

Lemma dsub_and: forall G A B C,
    okenvp G -> wft G A -> spli A B C -> declarative_subtyping G (t_and B C) A.
Proof with (inverts_all_wft; eauto 3 with SubHd).
  introv Ok Wf Spl.
  induction Spl; try intuition; eauto 3 with SubHd.
  - forwards: IHSpl... applys DS_trans...
  - forwards: dsub_or H0... applys DS_trans...
  - applys DS_trans.
    1: { applys DS_distOr... }
    applys DS_or... applys DS_trans...
  - applys DS_trans. 2: { applys dsub_symm_or... }
    applys DS_trans (t_and (t_union B1 A) (t_union B2 A))...
    2: { applys DS_trans. applys DS_distOr...
         applys DS_or... applys DS_trans... }
    applys DS_and.
    applys DS_trans (t_union A B1)...
    applys DS_trans (t_union A B2)...
Qed.

#[export] Hint Resolve dsub_and dsub_or : SubHd.

#[export] Hint Extern 1 (okenvp ?G) =>  match goal with
                             | H: algo_sub _ _ _ |- _ =>
                               match type of H with context[G] => forwards (?&?&?): algo_sub_wft H end
                             end : core.

Ltac inverts_all_wft_2 :=
  repeat match goal with
         | H: wft _ (_ _ _) |- _ => inverts H
         | H: wft _ (_ _) |- _ => inverts H
         | H: wft _ ?A, Hspl: spli ?A _ _ |- _ => forwards: wft_spli_1 Hspl H; forwards: wft_spli_2 Hspl H; clear H
         | H: wft _ ?A, Hspl: splu ?A _ _ |- _ => forwards: wft_splu_1 Hspl H; forwards: wft_splu_2 Hspl H; clear H
         | H: algo_sub _ _ _ |- wft _ _ => forwards (?&?&?): algo_sub_wft H; clear H
         end.

(* Equivalence of subtyping *)
(* Lemma 14 *)

Theorem dsub2asub: forall G A B,
    declarative_subtyping G A B <-> algo_sub G A B.
Proof with (simpl in *; try applys SpI_and; try applys SpU_or; inverts_all_wft_2; try eassumption; eauto 3 with SubHd).
  split; introv H.
  - induction H...
    all: try solve [ auto_sub ].
    + applys~ algo_sub_completeness.
  - induction H; auto with SubHd.
    + (* prim *) applys~ decl_sub_weakening.
    + (* prim eq *) applys DS_trans.
      2: { applys* decl_sub_weakening. }
      applys~ DS_prim.
    + (* and *)
      applys DS_trans (t_and B1 B2)... applys dsub_and...
    + (* andl *)
      forwards (?&?): dsub_spli PG H0...
    + (* andr *)
      forwards (?&?): dsub_spli PG H0...
    +  (* or *)
      applys DS_trans (t_union A1 A2)... applys dsub_or...
    + (* orl *)
      forwards (?&?): dsub_splu PG H0...
    + (* orr *)
      forwards (?&?): dsub_splu PG H0...
Qed.

Lemma wft_dec : forall G A, wft G A \/ ~ wft G A.
Proof.
  intros. induction* A.
  all: try solve [destruct IHA1; destruct IHA2; auto].
  induction G.
  - right. intro HF. inverts* HF.
  - destruct a.
    case_eq (eq_dec a n); intros; subst*.
    destruct IHG.
    + left*. apply wft_in_domain in H0.
      lets (?&?): binds_In_inv H0.
      econstructor. applys* binds_cons.
    + right. intro HF. apply H0.
      inverts HF. rewrite_env (nil ++ [(a,t)] ++ G) in H2.
      apply binds_remove_mid in H2. all: now eauto.
Qed.

#[export] Hint Immediate okenvp_uniq : core.

(* Lemma uniq_dec : forall (G: envp), uniq G \/ ~ uniq G. *)
(* Proof. *)
(*   introv. induction* G. *)
(*   destruct IHG. *)
(*   - destruct a. *)
(*     assert (HIn: a `in` dom G \/ a `notin` dom G) by *)
(*         forwards~ [?|?]: AtomSetNotin.D.FSetDecideAuxiliary.dec_In a (dom G). *)
(*     destruct* HIn. *)
(*     right. intro Uni. inverts~ Uni. *)
(*   - right. intro Uni. inverts~ Uni. *)
(* Qed. *)

Lemma okenvp_dec : forall G, okenvp G \/ ~ okenvp G.
Proof.
  introv. induction* G.
  destruct IHG.
  - destruct a. destruct t.
    all: try solve [right; intro HF; inverts HF].
    + forwards* [?|?]: AtomSetNotin.D.FSetDecideAuxiliary.dec_In a (dom G).
      right*. intro Ok. inverts~ Ok.
    + forwards* [?|?]: wft_dec G (t_prim n).
      * forwards* [?|?]: AtomSetNotin.D.FSetDecideAuxiliary.dec_In a (dom G).
        right*. intro Ok. inverts~ Ok.
      * right; intro HF; inverts~ HF.
  - right*.
Qed.

Lemma algo_sub_prim_dec : forall G n m,
    okenvp G ->
    algo_sub G (t_prim n) (t_prim m) \/ ~ algo_sub G (t_prim n) (t_prim m).
Proof.
  introv Ok. gen n m.
  induction G; intros.
  - right. intro HF. forwards : algo_sub_wft HF. destruct_conj.
    inverts H0. inverts H3.
  - forwards* [?|?]: IHG n m.
    + left. applys~ algo_sub_weakening.
    + destruct a. case_eq (a==n); intros; subst.
      * case_eq (n==m); intros; subst*.
        destruct t; try solve [inverts Ok].
        ** right; intro HF.
           inverts HF; solve_false.
        ** forwards* [?|?]: IHG n1 m.
           *** left. applys algo_sub_trans.
               2: applys~ algo_sub_weakening H2.
               applys* AS_prim_eq.
           *** right; intro HF.
               inverts HF; solve_false.
      * right; intro HF. apply H.
        forwards~ : algo_sub_prim_neq HF.
        applys~ algo_sub_prim_strenthen_head HF.
        applys* wft_strenthen_prim H1.
Qed.

(* Decidability of subtyping *)

(* Lemma 15 *)

Theorem decidability : forall G A B,
    algo_sub G A B \/ not (algo_sub G A B).
Proof with (simpl in *; solve_false; jauto; elia; try solve [right; intros HF; auto_inv; inverts HF; simpl in *; solve_false]; eauto 3 with SubHd).
  introv.
  indTypSize (size_typ A + size_typ B).
  lets [?|?]: okenvp_dec G. 2: { right. intro HF. applys* H. }
  lets [?|?]: wft_dec G A. 2: { right. intro HF. applys* H0. }
  lets [?|?]: wft_dec G B. 2: { right. intro HF. applys* H1. }
  lets [Hi|(?&?&Hi)]: ordi_or_split B.
  - lets [Hi'|(?&?&Hi')]: ordi_or_split A.
    + lets [Hu|(?&?&Hu)]: ordu_or_split A.
      * lets [Hu'|(?&?&Hu')]: ordu_or_split B.
        ** (* all ordinary *)
          destruct A; destruct B...
          *** forwards [IHA1|IHA1] : IH B1 A1...
              forwards [IHA2|IHA2] : IH A2 B2...
          *** applys~ algo_sub_prim_dec.
        ** (* spl > B, S-orl/r *)
          forwards [IHA1|IHA1] : IH A x...
          forwards [IHA2|IHA2] : IH A x0...
      * forwards [IHA1|IHA1] : IH x B...
        forwards [IHA2|IHA2] : IH x0 B...
    + (* spl < A, S-andl/r *)
      forwards [IHA1|IHA1] : IH x B...
      forwards [IHA2|IHA2] : IH x0 B...
  - (* spl < B, S-and *)
    forwards [IHA1|IHA1] : IH A x...
    forwards [IHA2|IHA2] : IH A x0...
Qed.


Require Import ZArith.
Require Import String.
Require Export maps.

Set Implicit Arguments.
Inductive float : Set :=.

Inductive Defn : Set :=
   FunDef : string -> list string -> Stmt -> Defn
with Exp : Set :=
   BCon : bool -> Exp
 | EVar : string -> Exp
 | ECon : Z -> Exp
 | ExpUndef : Undef -> Exp
 | ENeg : Exp -> Exp
 | EMult : Exp -> Exp -> Exp
 | EPlus : Exp -> Exp -> Exp
 | EMinus : Exp -> Exp -> Exp
 | EDiv : Exp -> Exp -> Exp
 | BLe : Exp -> Exp -> Exp
 | BLt : Exp -> Exp -> Exp
 | BEq : Exp -> Exp -> Exp
 | BAnd : Exp -> Exp -> Exp
 | BOr : Exp -> Exp -> Exp
 | EBuild : Map k k -> Exp
 | ECall : string -> list Exp -> Exp
 | ELoad : Exp -> Exp
 | BNot : Exp -> Exp
 | HOLE_Exp : Exp
with Frame : Set :=
   frame : k -> Map k k -> Frame
with kitem : Set :=
   KBool : bool -> kitem
 | KDefn : Defn -> kitem
 | KExp : Exp -> kitem
 | KExps : list Exp -> kitem
 | KFrame : Frame -> kitem
 | KFrames : list Frame -> kitem
 | KId : string -> kitem
 | KIds : list string -> kitem
 | KInt : Z -> kitem
 | KMap : Map k k -> kitem
 | KPgm : list Defn -> kitem
 | KStmt : Stmt -> kitem
 | KUndef : Undef -> kitem
 | KFreeze : kitem -> kitem
with KResult : Set :=
   Bool : bool -> KResult
 | Int : Z -> KResult
 | VUndef : Undef -> KResult
with Stmt : Set :=
   HAssign : Exp -> Exp -> Stmt
 | SAssign : string -> Exp -> Stmt
 | Seq : Stmt -> Stmt -> Stmt
 | Decl : string -> Stmt
 | SIf : Exp -> Stmt -> Stmt -> Stmt
 | Jump : Exp -> Stmt
 | SReturnVoid : Stmt
 | SReturn : Exp -> Stmt
 | SCall : string -> list Exp -> Stmt
 | Skip : Stmt
 | SWhile : Exp -> Stmt -> Stmt
with Undef : Set :=
   undef : Undef
with k : Set :=
   kdot : k
 | kra : kitem -> k -> k.

Definition KResultToExp (x : KResult) : Exp :=
  match x with
  | Bool i => BCon i
  | Int i => ECon i
  | VUndef i => ExpUndef i
  end.
Definition KResultFromExp (x : Exp) : option KResult :=
  match x with
  | BCon i => Some (Bool i)
  | ECon i => Some (Int i)
  | ExpUndef i => Some (VUndef i)
  | _ => None
  end.
Definition KResultToK (x : KResult) : kitem :=
  match x with
  | Bool i => KBool i
  | Int i => KInt i
  | VUndef i => KUndef i
  end.
Definition KResultFromK (x : kitem) : option KResult :=
  match x with
  | KBool i => Some (Bool i)
  | KInt i => Some (Int i)
  | KUndef i => Some (VUndef i)
  | _ => None
  end.
Definition ExpToK (x : Exp) : kitem :=
  match x with
  | BCon i => KBool i
  | EVar i => KId i
  | ECon i => KInt i
  | ExpUndef i => KUndef i
  | _ => KExp x
  end.
Definition ExpFromK (x : kitem) : option Exp :=
  match x with
  | KExp i => Some i
  | KBool i => Some (BCon i)
  | KId i => Some (EVar i)
  | KInt i => Some (ECon i)
  | KUndef i => Some (ExpUndef i)
  | _ => None
  end.


Module AssetMapping.
Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export maps_def.
Require Export assettheory_def.
Require Export formulatheory_def.
Require Export featuremodelsemantics_def.
Require Export assettheory_int.
Require Export assettheory_inst.
Import FormulaTheory.
Import Maps.
Import AssetTheory.
Import FeatureModelSemantics.

  Definition pair : Type := AssetName * Asset.
  Definition pairs := set pair.
  (** Um AM se trata de um map_*)
  Definition AM := map_.

  (* Asset mapping refinement *)
  (** Para os mapeamentos de ativos A e A ', o último refina
     o primeiro, denotado por A ⊑ A', sempre que:
     dom (A) = dom (A ') ∧ ∀ n ∈ dom (A) · A <n> ⊑ A' < n> *)
  Definition aMR_func (am1 am2: AM) : Prop := (dom_func am1 = dom_func am2) /\
    forall (an : AssetName), set_In an (dom_func am1) ->
      exists (a1 a2: Asset), (isMappable_func am1 an a1)
        /\ (isMappable_func am2 an a2)
          /\ (assetRef_func (set_add Asset_dec a1 nil) (set_add Asset_dec a2 nil)).

  (*Axiom <Asset refinement is pre-order>*)
  Axiom assetMappingRefinement_axiom:
    forall x y z: AM, aMR_func x x /\ aMR_func x y -> aMR_func y z ->  aMR_func x z.

End AssetMapping.


(** CS6225 -- Problem Set 4b (200 points) *)

(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 2 *)

Require Import Frap.

(* Authors:
 * Ben Sherman (sherman@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

(** * Polymorphic container types *)

(* In this problem set, we'll get some practice using some of the polymorphic
 * container types, in particular, [option], [list], and [tree]. We'll then use
 * [tree] and [option] together to create binary tries (i.e., finite maps keyed
 * by lists of Booleans).
 *
 * First, we'll reproduce some definitions we need from Lecture 2,
 * [tree] and [flatten]:
 *)

Inductive tree {A} :=
| Leaf
| Node (l : tree) (d : A) (r : tree).
Arguments tree : clear implicits.

Fixpoint flatten {A} (t : tree A) : list A :=
  match t with
  | Leaf => []
  | Node l d r => flatten l ++ d :: flatten r
  end.

(* And here's one additional definition that we'll use in this problem set.
 * [either] combines two [option] values into one.
 * If either argument to [either] is a [Some], then so is
 * the result of the [either], preferring the contents of
 * the first argument if both are [Some].
 *
 * We will observe an "analogy" between the [either]
 * function on options and the [++] function on lists.
 *)
Definition either {A} (xo yo : option A) : option A :=
  match xo with
  | None => yo
  | Some x => Some x
  end.

(* A binary trie is a finite map keyed by lists of Booleans.
 * We will implement a binary trie with entries of type [A]
 * by [tree (option A)]. The value at the root of the tree
 * corresponds to the entry for the key [nil : list bool],
 * the left subtree contains entries for those keys that
 * begin with [true], and the right subtree contains entries
 * for those keys that begin with [false].
 *)

Definition binary_trie A := tree (option A).

(* Here, again, is the module type setting out exactly which theorems you need
 * to prove for full credit on this assignment. *)
Module Type S.

  (* If we [either] an [option] value with [None]
   * on the right, it leaves that value unchanged,
   * (just as if we put the [None] on the left).
   * This is analogous to how appending [nil]
   * on either side of a list leaves it unchanged.
   *)
  Axiom either_None_right : forall {A} (xo : option A),
    either xo None = xo.
  (* 10 points *)

  (* [either] is associative, just like [++].
   *)
  Axiom either_assoc : forall {A} (xo yo zo : option A),
    either (either xo yo) zo = either xo (either yo zo).
  (* 10 points *)

  (* [head] should compute the head of a list, that is,
   * it should return [Some] with the first element of
   * the list if the list is nonempty, and [None]
   * if the list is empty.
   *)
  Parameter head : forall {A}, list A -> option A.
  (* 10 points *)

  Axiom head_example : head [1; 2; 3] = Some 1.
  (* 10 points *)

  (* The following theorem makes a formal connection
   * between [either] and [++].
   *)
  Axiom either_app_head : forall {A} (xs ys : list A),
      head (xs ++ ys) = either (head xs) (head ys).
  (* 10 points *)

  (* [leftmost_Node] should compute the leftmost node of
   * a tree.
   *
   * Please implement [leftmost_Node] directly using
   * recursion (i.e., pattern matching) on the [tree] argument,
   * without using the [flatten] operation.
   *)
  Parameter leftmost_Node : forall {A}, tree A -> option A.
  (* 10 points *)

  Axiom leftmost_Node_example :
    leftmost_Node (Node (Node Leaf 2 (Node Leaf 3 Leaf)) 1 Leaf)
    = Some 2.
  (* 10 points *)

  (* Prove that the leftmost node of the tree is the same
   * as the head of the list produced by flattening the tree
   * with an in-order traversal.
   *)
  Axiom leftmost_Node_head : forall {A} (t : tree A),
      leftmost_Node t = head (flatten t).
  (* 20 points *)

  (* Now let's work with the binary tries we defined earlier!
   *
   * Define [lookup] such that [lookup k t] looks up the
   * map entry corresponding to the key [k : list bool] in the
   * binary trie [t : binary_trie A], interpreting [t] such that
   * the value at the root of [t] corresponds to the
   * entry for the key [nil], the left subtree contains entries
   * for those keys that begin with [true], and the right subtree
   * contains entries for those keys that begin with [false].
   *)
  Parameter lookup : forall {A}, list bool -> binary_trie A -> option A.
  (* 10 points *)

  Axiom lookup_example1 : lookup [] (Node Leaf (None : option nat) Leaf) = None.
  (* 10 points *)

  Axiom lookup_example2 : lookup [false; true]
    (Node (Node Leaf (Some 2) Leaf) None (Node (Node Leaf (Some 1) Leaf) (Some 3) Leaf))
                          = Some 1.
  (* 10 points *)

  (* [Leaf] represents an empty binary trie, so a lookup for
   * any key should return [None].
   *)
  Axiom lookup_empty : forall {A} (k : list bool),
      lookup k (Leaf : binary_trie A) = None.
  (* 10 points *)

  (* Define an operation to "insert" a key and optional value
   * into a binary trie. The [insert] definition should satisfy two
   * properties: one is [lookup_insert] below, which says that if we
   * look up a key [k] in a trie where [(k, v)] has just been inserted,
   * the result should be [v]. The other is that lookups on keys different
   * from the one just inserted should be the same as on the original map.
   *
   * If an entry for that key already exists, [insert] should replace
   * that entry with the new one being inserted. Note that [insert] can
   * be used to remove an entry from the trie, too, by inserting [None]
   * as the value.
   *
   * Hint: it may be helpful to define an auxiliary function that inserts
   * a key and optional value into the empty trie.
   *)
  Parameter insert : forall {A}, list bool -> option A -> binary_trie A -> binary_trie A.
  (* 20 points *)

  Axiom insert_example1 : lookup [] (insert [] None (Node Leaf (Some 0) Leaf)) = None.
  Axiom insert_example2 : lookup [] (insert [true] (Some 2) (Node Leaf (Some 0) Leaf)) = Some 0.
  (* 10 points *)

  Axiom lookup_insert : forall {A} (k : list bool) (v : option A) (t : binary_trie A),
      lookup k (insert k v t) = v.
  (* 40 points *)
End S.

(* The template file Pset4b.v also suggests an additional challenge problem,
 * which won't be graded, but which provides extra practice with container data
 * structures.  The key operation is *left-biased merge for trees*. *)


(************************************************************************

This file contains various useful tactics

************************************************************************)

Require Import UniMath.Foundations.All.

(** A version of "easy" specialized for the needs of UniMath.
This tactic is supposed to be simple and predictable. The goal
is to use it to finish "trivial" goals *)
Ltac easy :=
  trivial; intros; solve
   [ repeat (solve [trivial | apply pathsinv0; trivial] || split)
   | match goal with | H : ∅ |- _ => induction H end
   | match goal with | H : ¬ _ |- _ => induction H; trivial end
   | match goal with | H : _ → ∅ |- _ => induction H; trivial end
   | match goal with | H : _ → _ → ∅ |- _ => induction H; trivial end ].

(** Override the Coq now tactic so that it uses unimath_easy instead *)
Tactic Notation "now" tactic(t) := t; easy.

(* hSet_induction in Foundations is wrong, so redefine it here: *)
Ltac hSet_induction f e := generalize f; apply hSet_rect; intro e; clear f.

(* When the goal is displayed as x=y and the types of x and y are hard to discern,
   use this tactic -- it will add the type to the context in simplified form. *)
Ltac show_id_type := match goal with |- @paths ?ID _ _ => set (TYPE := ID); simpl in TYPE end.

Require Import UniMath.Foundations.Sets UniMath.Foundations.UnivalenceAxiom.

Definition post_cat {X} {x y z:X} {p:y = z} : x = y -> x = z.
Proof. intros q. exact (pathscomp0 q p). Defined.

Definition pre_cat {X} {x y z:X} {p:x = y} : y = z -> x = z.
Proof. intros q. exact (pathscomp0 p q). Defined.

Ltac maponpaths_pre_post_cat :=
  repeat rewrite path_assoc; repeat apply (maponpaths post_cat); repeat rewrite <- path_assoc;
  repeat apply (maponpaths pre_cat); repeat rewrite path_assoc; repeat rewrite maponpathsinv0;
  try reflexivity.

Ltac prop_logic :=
  abstract (intros; simpl;
            repeat (try (apply isapropdirprod);try (apply isapropishinh);apply impred ;intro);
            try (apply isapropiscontr); try assumption) using _L_.

Lemma iscontrweqb' {X Y} (is:iscontr Y) (w:X ≃ Y) : iscontr X.
Proof. intros. apply (iscontrweqb (Y:=Y)). assumption. assumption. Defined.

Ltac intermediate_iscontr  Y' := apply (iscontrweqb (Y := Y')).
Ltac intermediate_iscontr' Y' := apply (iscontrweqb' (Y := Y')).

Ltac isaprop_goal x :=
  let G := match goal with |- ?G => constr:(G) end in
  assert (x : isaprop(G)).

(* less fancy than [isaprop_goal ig.] is [apply isaprop_goal; intro ig.] *)
Definition isaprop_goal X (ig:isaprop X) (f:isaprop X -> X) : X.
Proof. intros. exact (f ig). Defined.

Ltac isaset_goal x :=
  let G := match goal with |- ?G => constr:(G) end in
  assert (x : isaset(G)).

Ltac split3 := split; [| split].
Ltac split4 := split; [| split3].
Ltac split5 := split; [| split4].
Ltac split6 := split; [| split5].
Ltac split7 := split; [| split6].
Ltac split8 := split; [| split7].
Ltac split9 := split; [| split8].
Ltac split10 := split; [| split9].
Ltac split11 := split; [| split10].
Ltac split12 := split; [| split11].
Ltac split13 := split; [| split12].
Ltac split14 := split; [| split13].
Ltac split15 := split; [| split14].
Ltac split16 := split; [| split15].
Ltac split17 := split; [| split16].
Ltac split18 := split; [| split17].
Ltac split19 := split; [| split18].
Ltac split20 := split; [| split19].
Ltac split21 := split; [| split20].
(** this allows to decompose a goal for [prebicat_laws] *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Group_kernel.
(** Title "Factorisation of a group homomorphism: G -> G/Kerf -> coKerf -> G'." *)
Section Def.
Variable G G' : GROUP.
Variable f : Hom G G'.

Definition surj_group_quo_ker :
  Hom G (group_quo G (Ker f) (kernel_normal (G:=G) (G':=G') (f:=f))) :=
  group_quo_surj (kernel_normal (f:=f)).

Lemma surj_group_quo_ker_surjective : surjective surj_group_quo_ker.
red in |- *.
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
intros y; exists y; try assumption.
simpl in |- *.
apply Trans with (Ap (sgroup_map (monoid_sgroup_hom f)) (monoid_unit G));
 auto with algebra.
Qed.

Definition inj_coKer_group : Hom (coKer f:GROUP) G'.
apply (BUILD_HOM_GROUP (G:=coKer f) (G':=G') (ff:=inj_part (coKer f))).
simpl in |- *.
auto with algebra.
simpl in |- *.
auto with algebra.
simpl in |- *.
auto with algebra.
Defined.

Lemma inj_coKer_group_injective : injective inj_coKer_group.
exact (inj_part_injective (E:=G') (A:=coKer f)).
Qed.

Definition bij_group_quo_ker_coKer :
  Hom (group_quo G (Ker f) (kernel_normal (G:=G) (G':=G') (f:=f)):GROUP)
    (coKer f).
apply
 (BUILD_HOM_GROUP
    (G:=group_quo G (Ker f) (kernel_normal (G:=G) (G':=G') (f:=f)))
    (G':=coKer f)
    (ff:=fun x : G =>
         Build_subtype (P:=image (sgroup_map (monoid_sgroup_hom f)) (full G))
           (subtype_elt:=f x) (coKer_prop f x))).
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
intros x y H'; try assumption.
apply
 GROUP_reg_right
  with (group_inverse _ (Ap (sgroup_map (monoid_sgroup_hom f)) y));
 auto with algebra.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (Ap (sgroup_map (monoid_sgroup_hom f)) (group_inverse G y)));
 auto with algebra.
apply
 Trans
  with
    (Ap (sgroup_map (monoid_sgroup_hom f))
       (sgroup_law G x (group_inverse G y))); auto with algebra.
apply Trans with (monoid_unit G'); auto with algebra.
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
intros x y; try assumption.
exact (SGROUP_hom_prop f x y).
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
auto with algebra.
Defined.

Lemma bij_group_quo_ker_coKer_bijective : bijective bij_group_quo_ker_coKer.
red in |- *.
split; [ try assumption | idtac ].
red in |- *.
simpl in |- *.
unfold group_quo_eq, subtype_image_equal in |- *.
simpl in |- *.
intros x y H'; try assumption.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (Ap (sgroup_map (monoid_sgroup_hom f)) (group_inverse G y)));
 auto with algebra.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (group_inverse _ (Ap (sgroup_map (monoid_sgroup_hom f)) y)));
 auto with algebra.
apply
 Trans
  with
    (sgroup_law G' (Ap (sgroup_map (monoid_sgroup_hom f)) x)
       (group_inverse _ (Ap (sgroup_map (monoid_sgroup_hom f)) x)));
 auto with algebra.
red in |- *.
intros y; try assumption.
elim y.
intros y' subtype_prf; try assumption.
elim subtype_prf.
intros x H'; try assumption.
elim H'; intros H'0 H'1; try exact H'0; clear H'.
exists x; try assumption.
Qed.

Theorem factor_group_hom :
 Equal f
   (comp_hom inj_coKer_group
      (comp_hom bij_group_quo_ker_coKer surj_group_quo_ker)).
simpl in |- *.
unfold Map_eq in |- *.
simpl in |- *.
auto with algebra.
Qed.
End Def.
Hint Resolve factor_group_hom bij_group_quo_ker_coKer_bijective
  inj_coKer_group_injective surj_group_quo_ker_surjective: algebra.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

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

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

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

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export symbol_lemmas.
Require Export tactics_util.

(** definition of state *)
Definition state := KAssignable -> R.

(** Dummy state *)
Definition DumState : state := fun v => DumR.

(** some properties about states *)

(** change KAssignable (variable or differential of variable)  a with r in state s *)
Definition upd_state (s : state) (a : KAssignable) (r : R) : state :=
  fun x =>
    if KAssignable_dec x a
    then r
    else s x.

(** after variable a in state s is update with value r, it's value in state s is r *)
Lemma upd_state_same :
  forall s a r, upd_state s a r a = r.
Proof.
  intros s a r.
  unfold upd_state.
  destruct (KAssignable_dec a a) as [n|n]; auto.
  destruct n; auto.
Qed.
Hint Rewrite upd_state_same.

(** special case of upd_state is defined for variables *)
Definition upd_state_var S v r :=
  upd_state S (KAssignVar v) r.

(** special case of upd_state_same is defined for variables *)
Lemma upd_state_var_same :
  forall s v r, upd_state_var s v r (KAssignVar v) = r.
Proof.
  intros s v r.
  unfold upd_state_var; autorewrite with core; auto.
Qed.
Hint Rewrite upd_state_var_same.

(** if we consider two different KAssignables a and b in one state,
and we update value of a, then value of b remains the same as before update *)
Lemma upd_state_diff :
  forall s a r b, a <> b -> upd_state s a r b = s b.
Proof.
  intros s a r b d.
  unfold upd_state.
  destruct (KAssignable_dec b a) as [n|n]; subst; auto.
  destruct d; auto.
Qed.

(** special case of upd_state_diff is defined for variables *)
Lemma upd_state_var_diff :
  forall s v r a, KAssignVar v <> a -> upd_state_var s v r a = s a.
Proof.
  intros s v r ac d.
  apply upd_state_diff; auto.
Qed.

Definition var_sub := list (KVariable * R).

(** update list of variables sub in state s *)
Fixpoint upd_list_state (s : state) (sub : var_sub) : state :=
  match sub with
  | [] => s
  | (v,r) :: sub => upd_state (upd_list_state s sub) (KAssignVar v) r
  end.

(** builds a var_sub from a state [s] w.r.t. a support [l] *)
Fixpoint state2var_sub (s : state) (l : list KVariable) : var_sub :=
  match l with
  | [] => []
  | v :: vs => (v, s (KAssignVar v)) :: state2var_sub s vs
  end.

(** updates [s1] with the values of [s2] at [l] *)
Definition upd_state_st (s1 : state) (s2 : state) (l : list KVariable) : state :=
  upd_list_state s1 (state2var_sub s2 l).

Lemma upd_state_st_nil :
  forall s1 s2, upd_state_st s1 s2 [] = s1.
Proof.
  tcsp.
Qed.
Hint Rewrite upd_state_st_nil : core.

(** states s1 and s2 are equal except that for variable x, s2 maps to r *)
Definition differ_state_except (s1 s2 : state) x (r : R) : Prop :=
  (forall y, x <> y -> s1 y = s2 y)
  /\
  s2 x = r.

Lemma differ_state_except_prop1 :
  forall v w x r y,
    differ_state_except v w x r
    -> y <> x
    -> v y = w y.
Proof.
  introv d1 d2.
  destruct d1 as [h1 h2].
  apply h1; auto.
Qed.

Lemma differ_state_except_prop2 :
  forall v w x r,
    differ_state_except v w x r
    -> w x = r.
Proof.
  introv d.
  destruct d as [h1 h2]; auto.
Qed.

(* this definition is used in definition of dynamic semantics of programs *)
(** states s1 and s2 are equal except for variables in vars *)
Definition equal_states_except (s1 s2 : state) (vs : list KAssignable) : Prop :=
  forall x,
    not (List.In x vs)
    -> s1 x = s2 x.

Lemma differ_state_except_implies_equal_states_except :
  forall v w x r,
    differ_state_except v w x r
    -> equal_states_except v w [x].
Proof.
  introv h i; simpl in *.
  destruct h as [h1 h2].
  apply h1; tcsp.
Qed.


(* -*- coding: utf-8 *)

(** * Group actions *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.Propositions.
Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.MoreFoundations.Univalence.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Combinatorics.OrderedSets.

Import UniMath.MoreFoundations.PartA.

(** ** Definitions *)

Definition action_op G (X:hSet) : Type := ∏ (g:G) (x:X), X.

Section A.
  Context (G:gr) (X:hSet).
  Definition ActionStructure : Type :=
    ∑ (act_mult  :    action_op G X)
      (act_unit  :    ∏ x, act_mult (unel G) x = x),
   (*  act_assoc : *) ∏ g h x, act_mult (op g h) x = act_mult g (act_mult h x).
  Definition make act_mult act_unit act_assoc : ActionStructure := act_mult,, act_unit,, act_assoc.
  Definition act_mult (x:ActionStructure) := pr1 x.
  Definition act_unit (x:ActionStructure) := pr12 x.
  Definition act_assoc (x:ActionStructure) := pr22 x.
End A.
Arguments act_mult {_ _} _ _ _.

Lemma isaset_ActionStructure (G:gr) (X:hSet) : isaset (ActionStructure G X).
Proof.
  intros.
  apply isaset_total2.
  { apply (impred 2); intro g. apply impred; intro x. apply setproperty. }
  intro op.
  apply isaset_total2.
  { apply (impred 2); intro x. apply hlevelntosn. apply setproperty. }
  intro un. apply (impred 2); intro g. apply (impred 2); intro h. apply (impred 2); intro x.
  apply hlevelntosn. apply setproperty.
Qed.

Definition Action (G:gr) := total2 (ActionStructure G).
Definition makeAction {G:gr} (X:hSet) (ac:ActionStructure G X) :=
  X,,ac : Action G.

Definition ac_set {G:gr} (X:Action G) := pr1 X.
Coercion ac_set : Action >-> hSet.
Definition ac_type {G:gr} (X:Action G) := pr1hSet (ac_set X).
Definition ac_str {G:gr} (X:Action G) := pr2 X : ActionStructure G (ac_set X).
Definition ac_mult {G:gr} (X:Action G) := act_mult (pr2 X).
Declare Scope action_scope.
Delimit Scope action_scope with action.
Local Notation "g * x" := (ac_mult _ g x) : action_scope.
Local Open Scope action_scope.
Definition ac_assoc {G:gr} (X:Action G) := act_assoc _ _ (pr2 X) : ∏ g h x, (op g h)*x = g*(h*x).

Definition right_mult {G:gr} {X:Action G} (x:X) := λ g, g*x.
Definition left_mult {G:gr} {X:Action G} (g:G) := λ x:X, g*x.

Definition is_equivariant {G:gr} {X Y:Action G} (f:X->Y) : hProp :=
  (∀ g x, f (g*x) = g*(f x))%logic.

Definition is_equivariant_isaprop {G:gr} {X Y:Action G} (f:X->Y) :
  isaprop (is_equivariant f).
Proof.
  apply propproperty.
Qed.

(** The following fact is fundamental: it shows that our definition of
    [is_equivariant] captures all of the structure.  The proof reduces to
    showing that if G acts on a set X in two ways, and the identity function is
    equivariant, then the two actions are equal.  A similar fact will hold in
    other cases: groups, rings, monoids, etc.  Refer to section 9.8 of the HoTT
    book, on the "structure identity principle", a term coined by Peter Aczel. *)
Local Open Scope transport.

Definition is_equivariant_identity {G:gr} {X Y:Action G}
           (p:ac_set X = ac_set Y) :
  p # ac_str X = ac_str Y ≃ is_equivariant (cast (maponpaths pr1hSet p)).
Proof.
  revert X Y p; intros [X [Xm [Xu Xa]]] [Y [Ym [Yu Ya]]] ? .
  (* should just apply hPropUnivalence at this point, as in Poset_univalence_prelim! *)
  simpl in p. destruct p; simpl. unfold transportf; simpl.
  simple refine (make_weq _ _).
  { intros p g x. simpl in x. simpl.
    exact (eqtohomot (eqtohomot (maponpaths act_mult p) g) x). }
  use isweq_iso.
  { unfold cast; simpl.
    intro i.
    assert (p:Xm=Ym).
    { apply funextsec; intro g. apply funextsec; intro x; simpl in x.
      exact (i g x). }
    destruct p. clear i. assert (p:Xu=Yu).
    { apply funextsec; intro x; simpl in x. apply setproperty. }
    destruct p. assert (p:Xa=Ya).
    { apply funextsec; intro g. apply funextsec; intro h.
      apply funextsec; intro x. apply setproperty. }
    destruct p. apply idpath. }
  { intro p. apply isaset_ActionStructure. }
  { intro is. apply proofirrelevance.
    apply impred; intros g.
    apply impred; intros x.
    apply setproperty. }
Defined.

Definition is_equivariant_comp {G:gr} {X Y Z:Action G}
           (p:X->Y) (i:is_equivariant p)
           (q:Y->Z) (j:is_equivariant q) : is_equivariant (funcomp p q).
Proof.
  intros. intros g x. exact (maponpaths q (i g x) @ j g (p x)).
Defined.

Definition ActionMap {G:gr} (X Y:Action G) := total2 (@is_equivariant _ X Y).

Definition underlyingFunction {G:gr} {X Y:Action G} (f:ActionMap X Y) := pr1 f.

Coercion underlyingFunction : ActionMap >-> Funclass.

Definition equivariance {G:gr} {X Y:Action G} (f:ActionMap X Y) : is_equivariant f
  := pr2 f.

Definition composeActionMap {G:gr} (X Y Z:Action G)
           (p:ActionMap X Y) (q:ActionMap Y Z) : ActionMap X Z.
Proof.
  revert p q; intros [p i] [q j]. exists (funcomp p q).
  apply is_equivariant_comp. assumption. assumption.
Defined.

Definition ActionIso {G:gr} (X Y:Action G) : Type.
Proof.
  exact  (∑ f:(ac_set X) ≃ (ac_set Y), is_equivariant f).
Defined.

Lemma ActionIso_isaset {G:gr} (X Y:Action G) : isaset (ActionIso X Y).
Proof.
  apply (isofhlevelsninclb _ pr1).
  { apply isinclpr1; intro f. apply propproperty. }
  apply isofhlevelsnweqtohlevelsn.
  apply setproperty.
Defined.

Coercion underlyingIso {G:gr} {X Y:Action G} (e:ActionIso X Y) : X ≃ Y := pr1 e.

Lemma underlyingIso_incl {G:gr} {X Y:Action G} :
  isincl (underlyingIso : ActionIso X Y -> X ≃ Y).
Proof.
  intros. apply isinclpr1; intro f. apply propproperty.
Defined.

Local Goal ∏ G (X Y:Action G) (i : ActionIso X Y) (x:X), Y.
  intros.
  exact (i x).
Qed.

Lemma underlyingIso_injectivity {G:gr} {X Y:Action G}
      (e f:ActionIso X Y) :
  (e = f) ≃ (underlyingIso e = underlyingIso f).
Proof.
  intros. apply weqonpathsincl. apply underlyingIso_incl.
Defined.

Definition underlyingActionMap {G:gr} {X Y:Action G} (e:ActionIso X Y) : ActionMap X Y :=
  pr1weq (pr1 e),, pr2 e.

Definition idActionIso {G:gr} (X:Action G) : ActionIso X X.
Proof.
  intros. exists (idweq _). intros g x. reflexivity.
Defined.

Definition composeActionIso {G:gr} {X Y Z:Action G}
           (e:ActionIso X Y) (f:ActionIso Y Z) : ActionIso X Z.
Proof.
  revert e f; intros [e i] [f j]. exists (weqcomp e f).
  destruct e as [e e'], f as [f f']; simpl.
  apply is_equivariant_comp. exact i. exact j.
Defined.

Lemma composeActionIsoId {G:gr} {X Y:Action G} (f : ActionIso X Y) : composeActionIso (idActionIso X) f = f.
Proof.
  apply subtypePath.
  { intros g. apply propproperty. }
  apply subtypePath.
  { intros g. apply isapropisweq. }
  reflexivity.
Defined.

Lemma composeActionIsoId' {G:gr} {X Y:Action G} (f : ActionIso X Y) : composeActionIso f (idActionIso Y) = f.
Proof.
  apply subtypePath.
  { intros g. apply propproperty. }
  apply subtypePath.
  { intros g. apply isapropisweq. }
  reflexivity.
Defined.

Definition path_to_ActionIso {G:gr} {X Y:Action G} (e:X = Y) : ActionIso X Y.
Proof.
  intros. destruct e. exact (idActionIso X).
Defined.

Definition castAction {G:gr} {X Y:Action G} (e:X = Y) : X -> Y.
Proof.
  intros x. exact (path_to_ActionIso e x).
Defined.

(** ** Applications of univalence *)

Definition Action_univalence_prelim {G:gr} {X Y:Action G} :
  (X = Y) ≃ (ActionIso X Y).
Proof.
  intros.
  simple refine (weqcomp (total2_paths_equiv (ActionStructure G) X Y) _).
  simple refine (weqbandf _ _ _ _).
  { apply hSet_univalence. }
  simpl. intro p. simple refine (weqcomp (is_equivariant_identity p) _).
  exact (eqweqmap (maponpaths (λ f, hProptoType (is_equivariant f)) (pr1_eqweqmap (maponpaths pr1hSet p)))).
Defined.

Definition Action_univalence_prelim_comp {G:gr} {X Y:Action G} (p:X = Y) :
   Action_univalence_prelim p = path_to_ActionIso p.
Proof.
  intros. destruct p. apply (maponpaths (tpair _ _)). apply funextsec; intro g.
  apply funextsec; intro x. apply setproperty.
Defined.

Lemma path_to_ActionIsweq_iso {G:gr} {X Y:Action G}  :
   isweq (@path_to_ActionIso G X Y).
Proof.
  intros. exact (isweqhomot Action_univalence_prelim
                            path_to_ActionIso
                            Action_univalence_prelim_comp
                            (pr2 Action_univalence_prelim)).
Qed.

Definition Action_univalence {G:gr} {X Y:Action G} :
  (X = Y) ≃ (ActionIso X Y).
Proof.
  intros. exists path_to_ActionIso. apply path_to_ActionIsweq_iso.
Defined.

Definition Action_univalence_comp {G:gr} {X Y:Action G} (p:X = Y) :
   Action_univalence p = path_to_ActionIso p.
Proof.
  reflexivity.
Defined.

Definition Action_univalence_inv {G:gr} {X Y:Action G}
  : (ActionIso X Y) ≃ (X=Y) := invweq Action_univalence.

Definition Action_univalence_inv_comp {G:gr} {X Y:Action G} (f:ActionIso X Y) :
  path_to_ActionIso (Action_univalence_inv f) = f.
Proof.
  intros.
  unfold Action_univalence_inv, Action_univalence.
  apply (homotweqinvweq Action_univalence f).
Defined.

Definition Action_univalence_inv_comp_eval {G:gr} {X Y:Action G} (f:ActionIso X Y) (x:X) :
  castAction (Action_univalence_inv f) x = f x.
Proof.
  intros. exact (eqtohomot
                   (maponpaths pr1weq
                               (maponpaths underlyingIso
                                           (Action_univalence_inv_comp f)))
                   x).
Defined.

(** ** Torsors *)

Definition is_torsor {G:gr} (X:Action G) :=
  nonempty X × ∏ x:X, isweq (right_mult x).

Lemma is_torsor_isaprop {G:gr} (X:Action G) : isaprop (is_torsor X).
Proof.
  intros. apply isapropdirprod.
  { apply propproperty. }
  { apply impred; intro x. apply isapropisweq. }
Qed.

Definition Torsor (G:gr) := total2 (@is_torsor G).

Coercion underlyingAction {G} (X:Torsor G) := pr1 X : Action G.

Definition is_torsor_prop {G} (X:Torsor G) := pr2 X.

Definition torsor_nonempty {G} (X:Torsor G) := pr1 (is_torsor_prop X).

Definition torsor_splitting {G} (X:Torsor G) := pr2 (is_torsor_prop X).

Definition torsor_mult_weq {G} (X:Torsor G) (x:X) :=
  make_weq (right_mult x) (torsor_splitting X x) : G ≃ X.

Definition torsor_mult_weq' {G} (X:Torsor G) (g:G) : X ≃ X.
Proof.
  exists (left_mult g).
  use isweq_iso.
    - exact (left_mult (grinv G g)).
    - intros x. unfold left_mult.
      intermediate_path ((grinv G g * g)%multmonoid * x).
      + apply pathsinv0,act_assoc.
      + intermediate_path (unel G * x).
        * apply (maponpaths (right_mult x)). apply grlinvax.
        * apply act_unit.
    - intros x. unfold left_mult.
      intermediate_path ((g * grinv G g)%multmonoid * x).
      + apply pathsinv0,act_assoc.
      + intermediate_path (unel G * x).
        * apply (maponpaths (right_mult x)). apply grrinvax.
        * apply act_unit.
Defined.

Definition left_mult_Iso {G:abgr} (X:Torsor G) (g:G) : ActionIso X X.
Proof.
  exists (torsor_mult_weq' X g). intros h x.
  change (g * (h * x) = h * (g * x)).
  refine (! ac_assoc X g h x @ _ @ ac_assoc X h g x).
  exact (maponpaths (right_mult x) (commax G g h)).
Defined.

Definition torsor_update_nonempty {G} (X:Torsor G) (x:nonempty X) : Torsor G.
Proof.
  exact (underlyingAction X,,(x,,pr2(is_torsor_prop X))).
Defined.

Definition castTorsor {G} {T T':Torsor G} (q:T = T') : T -> T'.
Proof.
  exact (castAction (maponpaths underlyingAction q)).
Defined.

Lemma castTorsor_transportf {G} {T T':Torsor G} (q:T = T') (t:T) :
  transportf (λ S, underlyingAction S) q t = castTorsor q t.
Proof.
  now induction q.
Defined.

Lemma underlyingAction_incl {G:gr} :
  isincl (underlyingAction : Torsor G -> Action G).
Proof.
  intros. refine (isinclpr1 _ _); intro X. apply is_torsor_isaprop.
Defined.

Lemma underlyingAction_injectivity {G:gr} {X Y:Torsor G} :
      (X = Y) ≃ (underlyingAction X = underlyingAction Y).
Proof.
  intros. apply weqonpathsincl. apply underlyingAction_incl.
Defined.

Definition underlyingAction_injectivity_comp {G:gr} {X Y:Torsor G} (p:X = Y) :
  underlyingAction_injectivity p = maponpaths underlyingAction p.
Proof.
  reflexivity.
Defined.

Definition underlyingAction_injectivity_comp' {G:gr} {X Y:Torsor G} :
     pr1weq (@underlyingAction_injectivity G X Y)
  = @maponpaths (Torsor G) (Action G) (@underlyingAction G) X Y.
Proof.
  reflexivity.
Defined.

Definition underlyingAction_injectivity_inv_comp {G:gr} {X Y:Torsor G}
           (f:underlyingAction X = underlyingAction Y) :
  maponpaths underlyingAction (invmap underlyingAction_injectivity f) = f.
Proof.
  intros. apply (homotweqinvweq underlyingAction_injectivity f).
Defined.

Definition PointedTorsor (G:gr) := ∑ X:Torsor G, X.
Definition underlyingTorsor {G} (X:PointedTorsor G) := pr1 X : Torsor G.
Coercion underlyingTorsor : PointedTorsor >-> Torsor.
Definition underlyingPoint {G} (X:PointedTorsor G) := pr2 X : X.

Lemma is_quotient {G} (X:Torsor G) (y x:X) : ∃! g, g*x = y.
Proof.
  intros. exact (pr2 (is_torsor_prop X) x y).
Defined.

Definition quotient {G} (X:Torsor G) (y x:X) := pr1 (iscontrpr1 (is_quotient X y x)) : G.
Local Notation "y / x" := (quotient _ y x) : action_scope.

Lemma quotient_times {G} {X:Torsor G} (y x:X) : (y/x)*x = y.
Proof.
  intros. exact (pr2 (iscontrpr1 (is_quotient _ y x))).
Defined.

Lemma quotient_uniqueness {G} {X:Torsor G} (y x:X) (g:G) : g*x = y -> g = y/x.
Proof.
  intros e.
  exact (maponpaths pr1 (uniqueness (is_quotient _ y x) (g,,e))).
Defined.

Lemma quotient_mult {G} (X:Torsor G) (g:G) (x:X) : (g*x)/x = g.
Proof.
  intros. apply pathsinv0. apply quotient_uniqueness. reflexivity.
Defined.

Lemma quotient_1 {G} (X:Torsor G) (x:X) : x/x = 1%multmonoid.
Proof.
  intros. apply pathsinv0. apply quotient_uniqueness. apply act_unit.
Defined.

Lemma quotient_product {G} (X:Torsor G) (z y x:X) : op (z/y) (y/x) = z/x.
Proof.
  intros. apply quotient_uniqueness.
  exact (ac_assoc _ _ _ _
                  @ maponpaths (left_mult (z/y)) (quotient_times y x)
                  @ quotient_times z y).
Defined.

Lemma quotient_map {G} {X Y:Torsor G} (f : ActionMap X Y) (x x':X) : f x' / f x = x' / x.
Proof.
  refine (! (quotient_uniqueness (f x') (f x) (x' / x) _)).
  assert (p := equivariance f (x'/x) x).
  refine (!p @ _); clear p.
  apply maponpaths.
  apply quotient_times.
Qed.

Lemma torsorMapIsIso {G} {X Y : Torsor G} (f : ActionMap X Y) : isweq f.
Proof.
  apply (squash_to_prop (torsor_nonempty X)).
  - apply isapropisweq.
  - intros x.
    set (y := f x).
    set (f' := λ y', y' / y * x).
    apply (isweq_iso f f').
    + intros x'.
      unfold f', y.
      assert (p := quotient_times x' x).
      refine (_ @ p); clear p.
      apply (maponpaths (λ g, g * x)).
      apply quotient_map.
    + intros y'.
      unfold f'.
      assert (p := equivariance f (y'/y) x).
      refine (p @ _); clear p.
      fold y.
      apply quotient_times.
Defined.

Definition torsorMap_to_torsorIso {G} {X Y : Torsor G} (f : ActionMap X Y) : ActionIso X Y.
Proof.
  use tpair.
  - exists f. apply torsorMapIsIso.
  - simpl. apply equivariance.
Defined.

Definition trivialTorsor (G:gr) : Torsor G.
Proof.
  intros. exists (makeAction G (make G G op (lunax G) (assocax G))).
  exact (hinhpr (unel G),,
         λ x, isweq_iso
           (λ g, op g x)
           (λ g, op g (grinv _ x))
           (λ g, assocax _ g x (grinv _ x) @ maponpaths (op g) (grrinvax G x) @ runax _ g)
           (λ g, assocax _ g (grinv _ x) x @ maponpaths (op g) (grlinvax G x) @ runax _ g)).
Defined.

Definition toTrivialTorsor {G:gr} (g:G) : trivialTorsor G.
Proof.
  exact g.
Defined.

Definition pointedTrivialTorsor (G:gr) : PointedTorsor G.
Proof.
  intros. exists (trivialTorsor G). exact (unel G).
Defined.

Definition univ_function {G:gr} (X:Torsor G) (x:X) : trivialTorsor G -> X.
Proof.
  apply right_mult. assumption.
Defined.

Definition univ_function_pointed {G:gr} (X:Torsor G) (x:X) :
  univ_function X x (unel _) = x.
Proof.
  intros. apply act_unit.
Defined.

Definition univ_function_is_equivariant {G:gr} (X:Torsor G) (x:X) :
  is_equivariant (univ_function X x).
Proof.
  intros. intros g h. apply act_assoc.
Defined.

Definition triviality_isomorphism {G:gr} (X:Torsor G) (x:X) :
  ActionIso (trivialTorsor G) X.
Proof.
  intros.
  exact (torsor_mult_weq X x,, univ_function_is_equivariant X x).
Defined.

Lemma triviality_isomorphism_compute (G:gr) :
  triviality_isomorphism (trivialTorsor G) (unel G) = idActionIso (trivialTorsor G).
Proof.
  apply subtypePath_prop.
  apply subtypePath.
  { intros X. apply isapropisweq. }
  apply funextsec; intros g.
  change (op g (unel _) = g).
  apply runax.
Defined.

Definition trivialTorsor_weq (G:gr) (g:G) : (trivialTorsor G) ≃ (trivialTorsor G).
Proof.
  intros. exists (λ h, op h g). apply (isweq_iso _ (λ h, op h (grinv G g))).
  { exact (λ h, assocax _ _ _ _ @ maponpaths (op _) (grrinvax _ _) @ runax _ _). }
  { exact (λ h, assocax _ _ _ _ @ maponpaths (op _) (grlinvax _ _) @ runax _ _). }
Defined.

Definition trivialTorsorAuto (G:gr) (g:G) :
  ActionIso (trivialTorsor G) (trivialTorsor G).
Proof.
  intros. exists (trivialTorsor_weq G g).
  intros h x. simpl.  exact (assocax _ h x g).
Defined.

Lemma pr1weq_injectivity {X Y} (f g:X ≃ Y) : (f = g) ≃ (pr1weq f = pr1weq g).
Proof.
  intros. apply weqonpathsincl. apply isinclpr1weq.
Defined.

Definition trivialTorsorRightMultiplication (G:gr) : G ≃ ActionIso (trivialTorsor G) (trivialTorsor G).
Proof.
  exists (trivialTorsorAuto G). simple refine (isweq_iso _ _ _ _).
  { intro f. exact (f (unel G)). }
  { intro g; simpl. exact (lunax _ g). }
  { intro f; simpl. apply (invweq (underlyingIso_injectivity _ _)); simpl.
    apply (invweq (pr1weq_injectivity _ _)). apply funextsec; intro g.
    simpl. exact ((! (pr2 f) g (unel G)) @ (maponpaths (pr1 f) (runax G g))). }
Defined.

Definition autos_comp (G:gr) (g:G) :
  underlyingIso (trivialTorsorRightMultiplication G g) = trivialTorsor_weq G g.
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Definition autos_comp_apply (G:gr) (g h:G) :
  (trivialTorsorRightMultiplication _ g) h = (h * g)%multmonoid.
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Lemma trivialTorsorAuto_unit (G:gr) :
  trivialTorsorAuto G (unel _) = idActionIso _.
Proof.
  intros. simple refine (subtypePath _ _).
  { intro k. apply is_equivariant_isaprop. }
  { simple refine (subtypePath _ _).
    { intro; apply isapropisweq. }
    { apply funextsec; intro x; simpl. exact (runax G x). } }
Defined.

Lemma trivialTorsorAuto_mult (G:gr) (g h:G) :
  composeActionIso (trivialTorsorAuto G g) (trivialTorsorAuto G h)
  = (trivialTorsorAuto G (op g h)).
Proof.
  intros. simple refine (subtypePath _ _).
  { intro; apply is_equivariant_isaprop. }
  { simple refine (subtypePath _ _).
    { intro; apply isapropisweq. }
    { apply funextsec; intro x; simpl. exact (assocax _ x g h). } }
Defined.

(** ** Applications of univalence *)

Definition torsor_univalence {G:gr} {X Y:Torsor G} : (X = Y) ≃ (ActionIso X Y).
Proof.
  intros. simple refine (weqcomp underlyingAction_injectivity _).
  apply Action_univalence.
Defined.

Definition torsor_univalence_transport {G:gr} {X Y:Torsor G} (p:X=Y) (x:X) :
  torsor_univalence p x = transportf (λ X:Torsor G, X:Type) p x.
(* compare with castTorsor_transportf above *)
Proof.
  now induction p.
Defined.

Corollary torsor_hlevel {G:gr} : isofhlevel 3 (Torsor G).
Proof.
  intros X Y.
  apply (isofhlevelweqb 2 torsor_univalence).
  apply ActionIso_isaset.
Defined.

Definition torsor_univalence_comp {G:gr} {X Y:Torsor G} (p:X = Y) :
   torsor_univalence p = path_to_ActionIso (maponpaths underlyingAction p).
Proof.
  reflexivity.
Defined.

Definition torsor_univalence_inv_comp_eval {G:gr} {X Y:Torsor G}
           (f:ActionIso X Y) (x:X) :
  castTorsor (invmap torsor_univalence f) x = f x.
Proof.
  intros. unfold torsor_univalence.
  unfold castTorsor. rewrite invmapweqcomp. (* too slow *)
  unfold weqcomp; simpl.
  rewrite underlyingAction_injectivity_inv_comp.
  apply Action_univalence_inv_comp_eval.
Defined.

Definition torsor_eqweq_to_path {G:gr} {X Y:Torsor G} : ActionIso X Y -> X = Y.
Proof.
  intros f. exact (invweq torsor_univalence f).
Defined.

Definition torsorMap_to_path {G:gr} {X Y:Torsor G} : ActionMap X Y -> X = Y.
Proof.
  intros f.
  apply (invweq torsor_univalence).
  apply torsorMap_to_torsorIso.
  exact f.
Defined.

Theorem TorsorIso_rect {G:gr} {X Y : Torsor G} (P : ActionIso X Y -> UU) :
  (∏ e : X = Y, P (torsor_univalence e)) -> ∏ f, P f.
Proof.
  intros ih ?.
  set (p := ih (invmap torsor_univalence f)).
  set (h := homotweqinvweq torsor_univalence f).
  exact (transportf P h p).
Defined.

Ltac torsor_induction f e :=
  generalize f; apply TorsorIso_rect; intro e; clear f.

Theorem TorsorIso_rect' {G:gr} {X : Torsor G} (P : ∏ Y : Torsor G, ActionIso X Y -> Type) :
  P X (idActionIso X) -> ∏ (Y : Torsor G) (f:ActionIso X Y), P Y f.
Proof.
  intros p ? ?. torsor_induction f q. induction q. exact p.
Defined.

Ltac torsor_induction' f X :=
  generalize f; generalize X; apply TorsorIso_rect'; clear f X.

Lemma torsor_univalence_id {G:gr} (X:Torsor G) : invmap torsor_univalence (idActionIso X) = idpath X.
(* upstream *)
Proof.
  change (idActionIso X) with (torsor_univalence (idpath X)).
  apply homotinvweqweq.
Defined.

Definition invUnivalenceCompose {G:gr} {X Y Z : Torsor G} (f : ActionIso X Y) (g : ActionIso Y Z) :
  invmap torsor_univalence f @ invmap torsor_univalence g = invmap torsor_univalence (composeActionIso f g).
Proof.
  torsor_induction' g Z. rewrite composeActionIsoId'. rewrite torsor_univalence_id. apply pathscomp0rid.
Defined.

Definition PointedActionIso {G:gr} (X Y:PointedTorsor G)
    := ∑ f:ActionIso X Y, f (underlyingPoint X) = underlyingPoint Y.

Definition pointed_triviality_isomorphism {G:gr} (X:PointedTorsor G) :
  PointedActionIso (pointedTrivialTorsor G) X.
Proof.
  revert X; intros [X x]. exists (triviality_isomorphism X x).
  simpl. apply univ_function_pointed.
Defined.

Definition Pointedtorsor_univalence {G:gr} {X Y:PointedTorsor G} :
  (X = Y) ≃ (PointedActionIso X Y).
Proof.
  intros.
  simple refine (weqcomp (total2_paths_equiv _ X Y) _).
  simple refine (weqbandf _ _ _ _).
  { intros.
    exact (weqcomp (weqonpathsincl underlyingAction underlyingAction_incl X Y)
                   Action_univalence). }
  destruct X as [X x], Y as [Y y]; simpl. intro p. destruct p; simpl.
  exact (idweq _).
Defined.

Definition ClassifyingSpace G := pointedType (Torsor G) (trivialTorsor G).
Definition E := PointedTorsor.
Definition B := ClassifyingSpace.
Definition π {G:gr} := underlyingTorsor : E G -> B G.

Lemma isBaseConnected_BG (G:gr) : isBaseConnected (B G).
Proof.
  intros X. use (hinhfun _ (torsor_nonempty X)); intros x.
  exact (torsor_eqweq_to_path (triviality_isomorphism X x)).
Defined.

Goal ∏ (G:gr), triviality_isomorphism (trivialTorsor G) (unel G) = idActionIso (trivialTorsor G).
  Fail reflexivity.
Abort.

Goal ∏ (G:gr), isBaseConnected_BG G (trivialTorsor G) = hinhpr (idpath (trivialTorsor G)).
  intros.
  unfold isBaseConnected_BG, pr2.
  change (pr1 (trivialTorsor G) : Type) with (G : Type).
  change (torsor_nonempty (trivialTorsor G)) with (hinhpr (unel G)).
  change (hinhpr (torsor_eqweq_to_path (triviality_isomorphism (trivialTorsor G) (unel G)))
          = hinhpr (idpath (trivialTorsor G))).
  apply maponpaths.
  Fail reflexivity.
Abort.

Lemma isConnected_BG (G:gr) : isConnected (B G).
Proof.
  apply baseConnectedness. apply isBaseConnected_BG.
Defined.

Lemma iscontr_EG (G:gr) : iscontr (E G).
Proof.
  intros. exists (pointedTrivialTorsor G). intros [X x].
  apply pathsinv0. apply (invweq Pointedtorsor_univalence).
  apply pointed_triviality_isomorphism.
Defined.

Theorem loopsBG (G:gr) : G ≃ Ω (B G).
Proof.
  intros.
  simple refine (weqcomp _ (invweq torsor_univalence)).
  apply trivialTorsorRightMultiplication.
Defined.

Definition loopsBG_comp (G:gr) (g:G) :
  loopsBG G g = invmap torsor_univalence (trivialTorsorAuto G g).
Proof.
  reflexivity.
Defined.

Definition loopsBG_comp' {G:gr} (p : Ω (B G)) :
  invmap (loopsBG G) p = path_to_ActionIso (maponpaths underlyingAction p) (unel G).
Proof.
  reflexivity.
Defined.

Definition loopsBG_comp_2 (G:gr) (g h:G)
  : castTorsor (loopsBG G g) h = (h*g)%multmonoid.
Proof.
  exact (torsor_univalence_inv_comp_eval (trivialTorsorAuto G g) h).
Defined.

(** Theorem [loopsBG] also follows from the Rezk Completion theorem of the CategoryTheory
    package.  To see that, regard G as a category with one object.  Consider a
    merely representable functor F : G^op -> Set.  Let X be F of the object *.
    Apply F to the arrows to get an action of G on X.  Try to prove that X is a
    torsor.  Since being a torsor is a mere property, we may assume F is
    actually representable.  There is only one object *, so F is isomorphic to
    h_*.  Apply h_* to * and we get Hom(*,*), which is G, regarded as a G-set.
    That's a torsor.  So the Rezk completion RCG is equivalent to BG, the type
    of G-torsors.  Now the theorem also says there is an equivalence G -> RCG.
    So RCG is connected and its loop space is G.

    A formalization of that argument should be added eventually. *)

(*
Local Variables:
compile-command: "make -C ../.. UniMath/CategoryTheory/RepresentableFunctors/GroupAction.vo"
End:
*)


(** * Testcases for [choose_such_that.v]
Authors:
    - Cosmin Manea (1298542)

Creation date: 09 June 2021

Testcases for the [Obtain ... such that ...] tactic.
Tests pass if they can be run without unhandled errors.
--------------------------------------------------------------------------------

This file is part of Waterproof-lib.

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

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

You should have received a copy of the GNU General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)

From Ltac2 Require Import Ltac2.
Require Import Rbase.
Require Import Qreals.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import Ranalysis.
Require Import Integration.
Require Import micromega.Lra.
Require Import Max.

Require Import Waterproof.test_auxiliary.
Load choose_such_that.

(** Test 0: with labeling *)
Goal (exists n : nat, n + 1 = n)%nat -> False.
Proof.
  intro i.
  Obtain n according to (i), so for n : nat it holds that (n + 1 = n)%nat (ii).
Abort.

(** Test 1: without labeling *)
Goal (exists n : nat, n + 1 = n)%nat -> False.
Proof.
  intro i.
  Obtain n according to (i), so for n : nat it holds that (n + 1 = n)%nat.
Abort.

(** Test 2: wrong type variable *)
Goal (exists n : nat, n + 1 = n)%nat -> False.
Proof.
  intro i.
  Fail Obtain n3 according to (i), so for n3 : bool it holds that (n3 + 1 = n3)%nat.
Abort.

(** Test 3: wrong property *)
Goal (exists n : nat, n + 1 = n)%nat -> False.
Proof.
  intro i.
  Fail Obtain n4 according to (i), so for n4 : nat it holds that (n4 + 1 = n4 + 1)%nat.
Abort.

(** Test 4: whether statement of existence hypothesis is replecated *)
Goal (exists n : nat, n + 1 = n)%nat -> False.
Proof.
  intro i.
  Obtain n according to (i), so for n : nat it holds that (n + 1 = n)%nat.
Abort.

(** Test 5: tactic also works for destructing sig types *)
Goal {n : nat | (n + 1 = n)%nat} -> False.
Proof.
  intro i.
  Obtain n according to (i), so for n : nat it holds that (n + 1 = n)%nat.
Abort.

(** Test 6: whether original hypothesis is destructed, so if the goal depends on the
      specific term of the sigma type, the goal changes as well.
      As one would expect when using 'destruct .. as [.. ..]'. *)
Goal forall p : {n : nat | (n + 1 = n)%nat}, (proj1_sig p = 0)%nat.
Proof.
  intro p.
  Obtain n according to (p), so for n : nat it holds that (n + 1 = n)%nat (ii).
  simpl.
  assert_goal_is constr:((n = 0)%nat).
Abort.

(** Test 7: more advanced use of the [Obtain...such that...] in the context of limits of sequences *)
Local Open Scope R_scope.

Definition evt_eq_sequences (a b : nat -> R) := (exists k : nat, forall n : nat, (n >= k)%nat -> a n = b n).

Goal forall (a b : nat -> R) (l : R), evt_eq_sequences a b -> (Un_cv a l) -> (Un_cv b l).
Proof.
    intros.
    intro.
    intro.
    pose (H0 eps H1) as i.
    Fail Obtain N1 according to (i), so for N1 : nat it holds that
           (forall n : nat, (n >= N1)%nat -> R_dist (a n) l < eps) (i).
    Obtain N1 according to (i), so for N1 : nat it holds that
           (forall n : nat, (n >= N1)%nat -> R_dist (a n) l < eps).
Abort.