(**************************************************************************************************
* Preservation and Progress for simple polymorphic calculus with duotyping, Union and Intersection types *
* Based on original code by: Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1
* Modifications by Bruno C. d. S. Oliveira, Shaobo Cui and Baber Rehman, January 2020, Coq v8.7.0   *
***************************************************************************************************)

Set Implicit Arguments.
Require Import TLC.LibLN.
Implicit Types x : var.
Implicit Types X : var.

(* ********************************************************************** *)
(** * Description of the Language *)

(** Representation of types *)

Inductive typ : Set :=
  | typ_btm   : typ
  | typ_top   : typ
  | typ_int   : typ
  | typ_arrow : typ -> typ -> typ
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_all   : typ -> typ
  | typ_and   : typ -> typ -> typ
  | typ_or    : typ -> typ -> typ.

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_unit : trm
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_nval : nat -> trm
  | trm_nsucc: trm -> trm
  | trm_nind : trm -> trm -> trm -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_tabs : trm -> trm
  | trm_tapp : trm -> typ -> trm.

(** Opening up a type binder occuring in a type *)

Fixpoint open_tt_rec (K : nat) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_btm         => typ_btm
  | typ_top         => typ_top
  | typ_int         => typ_int
  | typ_bvar J      => If K = J then U else (typ_bvar J)
  | typ_fvar X      => typ_fvar X
  | typ_arrow T1 T2 => typ_arrow (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_and T1 T2   => typ_and (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_or T1 T2    => typ_or (open_tt_rec K U T1) (open_tt_rec K U T2)
  | typ_all T       => typ_all (open_tt_rec (S K) U T)
  end.

Definition open_tt T U := open_tt_rec 0 U T.

(** Opening up a type binder occuring in a term *)

Fixpoint open_te_rec (K : nat) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_unit      => trm_unit
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_nval v    => trm_nval v
  | trm_nsucc t   => trm_nsucc (open_te_rec K U t)
  | trm_nind t1 t2 t3 => trm_nind (open_te_rec K U t1) (open_te_rec K U t2) (open_te_rec K U t3)
  | trm_abs V e1  => trm_abs  (open_tt_rec K U V)  (open_te_rec K U e1)
  | trm_app e1 e2 => trm_app  (open_te_rec K U e1) (open_te_rec K U e2)
  | trm_tabs e1 => trm_tabs (open_te_rec (S K) U e1)
  | trm_tapp e1 V => trm_tapp (open_te_rec K U e1) (open_tt_rec K U V)
  end.

Definition open_te t U := open_te_rec 0 U t.

(** Opening up a term binder occuring in a term *)

Fixpoint open_ee_rec (k : nat) (f : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_unit      => trm_unit
  | trm_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_nval v    => trm_nval v
  | trm_nsucc s   => trm_nsucc (open_ee_rec k f s)
  | trm_nind i z s => trm_nind (open_ee_rec k f i) (open_ee_rec k f z) (open_ee_rec k f s)
  | trm_abs V e1  => trm_abs V (open_ee_rec (S k) f e1)
  | trm_app e1 e2 => trm_app (open_ee_rec k f e1) (open_ee_rec k f e2)
  | trm_tabs t    => trm_tabs (open_ee_rec k f t)
  | trm_tapp t  T => trm_tapp (open_ee_rec k f t) T
  end.

Definition open_ee t u := open_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "T 'open_tt_var' X" := (open_tt T (typ_fvar X)) (at level 67).
Notation "t 'open_te_var' X" := (open_te t (typ_fvar X)) (at level 67).
Notation "t 'open_ee_var' x" := (open_ee t (trm_fvar x)) (at level 67).

(** Types as locally closed pre-types *)

Inductive type : typ -> Prop :=
  | type_top :
      type typ_top
  | type_int :
      type typ_int
  | type_btm :
      type typ_btm
  | type_var : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2)
  | type_all : forall L T,
      (forall X, X \notin L -> type (T open_tt_var X)) ->
      type (typ_all T).

(** Terms as locally closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_unit : term trm_unit
  | term_var : forall x,
      term (trm_fvar x)
  | term_nval : forall v,
      term (trm_nval v)
  | term_nsucc : forall t,
    term t -> term (trm_nsucc t)
  | term_nind : forall t1 t2 t3,
    term t1 ->
    term t2 ->
    term t3 ->
    term (trm_nind t1 t2 t3)
  | term_abs : forall L V e1,
      type V ->
      (forall x, x \notin L -> term (e1 open_ee_var x)) ->
      term (trm_abs V e1)
  | term_app : forall e1 e2,
      term e1 ->
      term e2 ->
      term (trm_app e1 e2)
  | term_tabs : forall L e1,
      (forall X, X \notin L -> term (e1 open_te_var X)) ->
      term (trm_tabs e1)
  | term_tapp : forall e1 V,
      term e1 ->
      type V ->
      term (trm_tapp e1 V).

(** Binding map term variables to types, and keeps type variables in the environment.
 [x ~: T] is a typing assumption *)

Inductive bind : Set :=
  | bind_tvr : bind
  | bind_typ : typ -> bind.

Notation "X !:" := (X ~ bind_tvr)
  (at level 23, left associativity) : env_scope.

Notation "x ~: T" := (x ~ bind_typ T)
  (at level 23, left associativity) : env_scope.

Definition env := LibEnv.env bind.

(** Well-formedness of a pre-type T in an environment E:
  all the type variables of T must be bound via a
  subtyping relation in E. This predicates implies
  that T is a type *)

Inductive wft : env -> typ -> Prop :=
  | wft_top : forall E,
      wft E typ_top
  | wft_var : forall E X,
      binds X bind_tvr E ->
      wft E (typ_fvar X)
  | wft_int : forall E,
      wft E typ_int
  | wft_btm :forall E,
      wft E typ_btm
  | wft_arrow : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_arrow T1 T2)
  | wft_all : forall L E T,
      (forall X, X \notin L ->
        wft (E & X !:) (T open_tt_var X)) ->
      wft E (typ_all T).

Inductive okt : env -> Prop :=
  | okt_empty :
      okt empty
  | okt_tvr : forall E X,
      okt E ->  X # E -> okt (E & X !:)
  | okt_typ : forall E x T,
      okt E -> wft E T -> x # E -> okt (E & x ~: T).

(** Generalized Subtyping Judgements *)

Inductive Mode := Sub | Sup.

Definition flip (m : Mode) : Mode :=
  match m with
  | Sub => Sup
  | Sup => Sub
  end.

Definition mode_to_sub m := match m with
  | Sub => typ_top
  | Sup => typ_btm end.

Definition choose (m : Mode) : typ -> typ -> typ :=
  match m with
  | Sub => typ_and
  | Sup => typ_or
  end.

Inductive R : Mode -> typ -> typ -> Prop :=
| SInt : forall m, R m typ_int typ_int
| STB1 : forall A m, R m A (mode_to_sub m)
| STB2 : forall A m, R m (mode_to_sub (flip m)) A
| SFun : forall A B C D m, R (flip m) A C -> R m B D -> R m (typ_arrow A B) (typ_arrow C D)
| SVarRefl : forall X m, R m (typ_fvar X) (typ_fvar X)
| SAll : forall L m T1 T2,
    (forall X, X \notin L ->
               R m (T1 open_tt_var X) (T2 open_tt_var X)) ->
    R m (typ_all T1) (typ_all T2)
| SLeft1  : forall A B C m, R m A C -> R m (choose m A B) C
| SLeft2  : forall A B C m, R m A B -> R m A (choose (flip m) B C)
| SRight1 : forall A B C m, R m B C -> R m (choose m A B) C
| SRight2 : forall A B C m, R m A C -> R m A (choose (flip m) B C)
| SBoth1  : forall A B C m, R m A B -> R m A C -> R m A (choose m B C)
| SBoth2  : forall A B C m, R m A C -> R m B C -> R m (choose (flip m) A B) C.

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_unit : forall E, okt E ->typing E trm_unit typ_top
  | typing_var : forall E x T,
      okt E ->
      binds x (bind_typ T) E ->
      typing E (trm_fvar x) T
  | typing_nval : forall E v,
      okt E ->
   typing E (trm_nval v) typ_int
  | typing_nsucc : forall E t,
    okt E ->
    typing E t typ_int ->
    typing E (trm_nsucc t) typ_int
  | typing_nind : forall E V t1 t2 t3,
    okt E ->
    typing E t1 typ_int ->
    typing E t2 V ->
    typing E t3 (typ_arrow V V) ->
    typing E (trm_nind t1 t2 t3) V
  | typing_abs : forall L E V e1 T1,
      (forall x, x \notin L ->
        typing (E & x ~: V) (e1 open_ee_var x) T1) ->
      typing E (trm_abs V e1) (typ_arrow V T1)
  | typing_app : forall T1 E e1 e2 T2,
      typing E e1 (typ_arrow T1 T2) ->
      typing E e2 T1 ->
      typing E (trm_app e1 e2) T2
  | typing_tabs : forall L E e T,
      (forall X, X \notin L ->
        typing (E & X!:) (e open_te_var X) (T open_tt_var X)) ->
      typing E (trm_tabs e) (typ_all T)
  | typing_tapp : forall E T1 T2 e,
    typing E e (typ_all T1) ->
    wft E T2 ->
    typing E (trm_tapp e T2) (open_tt T1 T2)
  | typing_sub : forall S E e T,
      typing E e S ->
      R Sub S T ->
      wft E T ->
      typing E e T.

(** Values *)

Inductive value : trm -> Prop :=
  | value_unit : value trm_unit
  | value_abs  : forall V e1, term (trm_abs V e1) ->
                 value (trm_abs V e1)
  | value_ival : forall v, value (trm_nval v)
  | value_tabs : forall e, term (trm_tabs e) ->
                 value (trm_tabs e).

(** One-step reduction *)

Inductive red : trm -> trm -> Prop :=
  | red_app_1 : forall e1 e1' e2,
      term e2 ->
      red e1 e1' ->
      red (trm_app e1 e2) (trm_app e1' e2)
  | red_app_2 : forall e1 e2 e2',
      value e1 ->
      red e2 e2' ->
      red (trm_app e1 e2) (trm_app e1 e2')
  | red_abs : forall V e1 v2,
      term (trm_abs V e1) ->
      value v2 ->
      red (trm_app (trm_abs V e1) v2) (open_ee e1 v2)
  | red_succ_can : forall v,
      red (trm_nsucc (trm_nval v)) (trm_nval (S v))
  | red_succ_red : forall t t',
      red t t'->
      red (trm_nsucc t) (trm_nsucc t')
  | red_ind_nred : forall t1 t1' t2 t3,
      red t1 t1' ->
      term t2 ->
      term t3 ->
      red (trm_nind t1 t2 t3) (trm_nind t1' t2 t3)
  | red_ind_icase : forall t1 t2 t3 t3',
      value t1 ->
      term t2 ->
      red t3 t3' ->
      red (trm_nind t1 t2 t3) (trm_nind t1 t2 t3')
  | red_ind_izero : forall t2 t3,
      term t2 ->
      value t3 ->
      red (trm_nind (trm_nval 0) t2 t3) t2
  | red_ind_isucc : forall k t2 t3,
      term t2 ->
      value t3 ->
      red (trm_nind (trm_nval (S k)) t2 t3) (trm_app t3 (trm_nind (trm_nval k) t2 t3))
  | red_tabs : forall e V,
      term (trm_tabs e) ->
      type V ->
      red (trm_tapp (trm_tabs e) V) (open_te e V)
  | red_tapp : forall e1 e1' V,
      type V ->
      red e1 e1' ->
      red (trm_tapp e1 V) (trm_tapp e1' V).

(** Our goal is to prove preservation and progress *)

Definition preservation := forall E e e' T,
  typing E e T ->
  red e e' ->
  typing E e' T.

Definition progress := forall e T,
  typing empty e T ->
     value e
  \/ exists e', red e e'.

(** * Additional Definitions Used in the Proofs *)

(** Computing free term variables in a type *)

Fixpoint fv_tt (T : typ) {struct T} : vars :=
  match T with
  | typ_fvar X      => \{X}
  | typ_arrow T1 T2 => (fv_tt T1) \u (fv_tt T2)
  | typ_all T       => fv_tt T
  | typ_and T1 T2   => (fv_tt T1) \u (fv_tt T2)
  | typ_or T1 T2    => (fv_tt T1) \u (fv_tt T2)
  | _               => \{}
  end.

(** Computing free type variables in a term *)

Fixpoint fv_te (e : trm) {struct e} : vars :=
  match e with
  | trm_nsucc t   => fv_te t
  | trm_nind t1 t2 t3 => (fv_te t1) \u (fv_te t2) \u (fv_te t3)
  | trm_abs V e1  => (fv_tt V) \u (fv_te e1)
  | trm_app e1 e2 => (fv_te e1) \u (fv_te e2)
  | trm_tabs e1   =>  (fv_te e1)
  | trm_tapp e1 V => (fv_tt V) \u (fv_te e1)
  | _ => \{}
  end.

(** Computing free term variables in a type *)

Fixpoint fv_ee (e : trm) {struct e} : vars :=
  match e with
  | trm_unit      => \{}
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_nval _    => \{}
  | trm_nsucc t   => fv_ee t
  | trm_nind t1 t2 t3 => (fv_ee t1) \u (fv_ee t2) \u (fv_ee t3)
  | trm_abs V e1  => (fv_ee e1)
  | trm_app e1 e2 => (fv_ee e1) \u (fv_ee e2)
  | trm_tabs t    => fv_ee t
  | trm_tapp t1 _ => (fv_ee t1)
  end.

(** Substitution for free type variables in types. *)

Fixpoint subst_tt (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top         => typ_top
  | typ_int         => typ_int
  | typ_btm         => typ_btm
  | typ_bvar J      => typ_bvar J
  | typ_fvar X      => If X = Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_and T1 T2   => typ_and (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_or T1 T2    => typ_or (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all T       => typ_all (subst_tt Z U T)
  end.

(** Substitution for free type variables in terms. *)

Fixpoint subst_te (Z : var) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_unit      => trm_unit
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_nval v    => trm_nval v
  | trm_nsucc t   => trm_nsucc (subst_te Z U t)
  | trm_nind t1 t2 t3 => trm_nind (subst_te Z U t1) (subst_te Z U t2) (subst_te Z U t3)
  | trm_abs V e1  => trm_abs  (subst_tt Z U V)  (subst_te Z U e1)
  | trm_app e1 e2 => trm_app  (subst_te Z U e1) (subst_te Z U e2)
  | trm_tabs e => trm_tabs (subst_te Z U e)
  | trm_tapp e1 V => trm_tapp (subst_te Z U e1) (subst_tt Z U V)
  end.

(** Substitution for free term variables in terms. *)

Fixpoint subst_ee (z : var) (u : trm) (e : trm) {struct e} : trm :=
  match e with
  | trm_unit      => trm_unit
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_nval i    => trm_nval i
  | trm_nsucc t   => trm_nsucc (subst_ee z u t)
  | trm_nind t1 t2 t3 => trm_nind (subst_ee z u t1) (subst_ee z u t2) (subst_ee z u t3)
  | trm_abs V e1  => trm_abs V (subst_ee z u e1)
  | trm_app e1 e2 => trm_app (subst_ee z u e1) (subst_ee z u e2)
  | trm_tabs t    => trm_tabs (subst_ee z u t)
  | trm_tapp t1 T => trm_tapp (subst_ee z u t1) T
  end.

Definition subst_tb (Z : var) (P : typ) (b : bind) : bind :=
  match b with
  | bind_tvr   => bind_tvr
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

(* ********************************************************************** *)
(** * Tactics *)

(** Constructors as hints. *)

Hint Constructors type term wft ok okt value red R.

Hint Resolve
  (*STB1 STB2 SInt SFun *) SVarRefl
  typing_var typing_app typing_sub typing_tapp typing_nval typing_nsucc typing_nind.

(** Gathering free names already used in the proofs *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : trm => fv_te x) in
  let D := gather_vars_with (fun x : trm => fv_ee x) in
  let E := gather_vars_with (fun x : typ => fv_tt x) in
  let F := gather_vars_with (fun x : env => dom x) in
  constr:(A \u B \u C \u D \u E \u F).

(** "pick_fresh x" tactic create a fresh variable with name x *)

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

(** "apply_fresh T as x" is used to apply inductive rule which
   use an universal quantification over a cofinite set *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; autos*.

(** These tactics help applying a lemma which conclusion mentions
  an environment (E & F) in the particular case when F is empty *)

Ltac get_env :=
  match goal with
  | |- wft ?E _ => E
  | |- typing ?E _ _ => E
  end.

Tactic Notation "apply_empty_bis" tactic(get_env) constr(lemma) :=
  let E := get_env in rewrite <- (concat_empty_r E);
  eapply lemma; try rewrite concat_empty_r.

Tactic Notation "apply_empty" constr(F) :=
  apply_empty_bis (get_env) F.

Tactic Notation "apply_empty" "*" constr(F) :=
  apply_empty F; autos*.

(** Tactic to undo when Coq does too much simplification *)

Ltac unsimpl_map_bind :=
  match goal with |- context [ ?B (subst_tt ?Z ?P ?U) ] =>
    unsimpl ((subst_tb Z P) (B U)) end.

Tactic Notation "unsimpl_map_bind" "*" :=
  unsimpl_map_bind; autos*.

(* ********************************************************************** *)
(** * Properties of Substitutions *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma open_tt_rec_type_core : forall T j V U i, i <> j ->
  (open_tt_rec j V T) = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof.
  induction T; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_tt_rec_type : forall T U,
  type T -> forall k, T = open_tt_rec k U T.
Proof.
 induction 1; intros; simpl; f_equal*. unfolds open_tt.
  pick_fresh X. apply* (@open_tt_rec_type_core T 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_tt_fresh : forall Z U T,
  Z \notin fv_tt T -> subst_tt Z U T = T.
Proof.
  induction T.
  simpl. intros. f_equal*.
  simpl. intros. f_equal*.
  simpl. intros. f_equal*.
  simpl. intros. f_equal*.
  simpl. intros. f_equal*.
  simpl. intros. case_var*.
  simpl. intros. f_equal*.
  simpl. intros. f_equal*.
  simpl. intros. f_equal*.
Qed.

(* BABER: TODO  Done*)

(** Substitution distributes on the open operation. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P n, type P ->
  subst_tt X P (open_tt_rec n T2 T1) =
  open_tt_rec n (subst_tt X P T2) (subst_tt X P T1).
Proof.
  introv WP. generalize n.
  induction T1; intros k; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_tt_rec_type.
Qed.

Lemma subst_tt_open_tt : forall T1 T2 X P, type P ->
  subst_tt X P (open_tt T1 T2) =
  open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof.
  unfold open_tt. autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_tt_open_tt_var : forall X Y U T, Y <> X -> type U ->
  (subst_tt X U T) open_tt_var Y = subst_tt X U (T open_tt_var Y).
Proof.
  introv Neq Wu. rewrite* subst_tt_open_tt.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_tt_intro : forall X T2 U,
  X \notin fv_tt T2 -> type U ->
  open_tt T2 U = subst_tt X U (T2 open_tt_var X).
Proof.
  introv Fr Wu. rewrite* subst_tt_open_tt.
  rewrite* subst_tt_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in terms *)

Lemma open_te_rec_term_core : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H; f_equal*; f_equal*.
Qed.

Lemma open_te_rec_type_core : forall e j Q i P, i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
   e = open_te_rec i P e.
Proof.
  induction e; intros; simpl in *; inversion H0; f_equal*;
  match goal with H: ?i <> ?j |- ?t = open_tt_rec ?i _ ?t =>
   apply* (@open_tt_rec_type_core t j) end.
Qed.

Lemma open_te_rec_term : forall e U,
  term e -> forall k, e = open_te_rec k U e.
Proof.
  intros e U WF. induction WF; intros; simpl;
    f_equal*; try solve [ apply* open_tt_rec_type ].
  unfolds open_ee. pick_fresh x.
   apply* (@open_te_rec_term_core e1 0 (trm_fvar x)).
  unfolds open_te. pick_fresh X.
   apply* (@open_te_rec_type_core e1 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_te_fresh : forall X U e,
  X \notin fv_te e -> subst_te X U e = e.
Proof.
  induction e; simpl; intros; f_equal*; autos* subst_tt_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_te_open_te : forall e T X U, type U ->
  subst_te X U (open_te e T) =
  open_te (subst_te X U e) (subst_tt X U T).
Proof.
  intros. unfold open_te. generalize 0.
  induction e; intros; simpls; f_equal*;
  autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_te_open_te_var : forall X Y U e, Y <> X -> type U ->
  (subst_te X U e) open_te_var Y = subst_te X U (e open_te_var Y).
Proof.
  introv Neq Wu. rewrite* subst_te_open_te.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_te_intro : forall X U e,
  X \notin fv_te e -> type U ->
  open_te e U = subst_te X U (e open_te_var X).
Proof.
  introv Fr Wu. rewrite* subst_te_open_te.
  rewrite* subst_te_fresh. simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Properties of term substitution in terms *)

Lemma open_ee_rec_term_core : forall e j v u i, i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv Neq H; simpl in *; inversion H; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma open_ee_rec_type_core : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; introv H; simpls; inversion H; f_equal*.
Qed.

Lemma open_ee_rec_term : forall u e,
  term e -> forall k, e = open_ee_rec k u e.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds open_ee. pick_fresh x.
   apply* (@open_ee_rec_term_core e1 0 (trm_fvar x)).
   unfolds open_te. pick_fresh X.
   apply* (@open_ee_rec_type_core e1 0 (typ_fvar X)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_ee_fresh : forall x u e,
  x \notin fv_ee e -> subst_ee x u e = e.
Proof.
  induction e; simpl; intros; f_equal*.
  case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_ee_open_ee : forall t1 t2 u x, term u ->
  subst_ee x u (open_ee t1 t2) =
  open_ee (subst_ee x u t1) (subst_ee x u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1; intros; simpls; f_equal*.
  case_nat*.
  case_var*. rewrite* <- open_ee_rec_term.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_ee_open_ee_var : forall x y u e, y <> x -> term u ->
  (subst_ee x u e) open_ee_var y = subst_ee x u (e open_ee_var y).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_ee_intro : forall x u e,
  x \notin fv_ee e -> term u ->
  open_ee e u = subst_ee x u (e open_ee_var x).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_var*.
Qed.

(** Interactions between type substitutions in terms and opening
  with term variables in terms. *)

Lemma subst_te_open_ee_var : forall Z P x e,
  (subst_te Z P e) open_ee_var x = subst_te Z P (e open_ee_var x).
Proof.
  introv. unfold open_ee. generalize 0.
  induction e; intros; simpl; f_equal*. case_nat*.
Qed.

(** Interactions between term substitutions in terms and opening
  with type variables in terms. *)

Lemma subst_ee_open_te_var : forall z u e X, term u ->
  (subst_ee z u e) open_te_var X = subst_ee z u (e open_te_var X).
Proof.
  introv. unfold open_te. generalize 0.
  induction e; intros; simpl; f_equal*.
  case_var*. symmetry. autos* open_te_rec_term.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_tt_type : forall T Z P,
  type T -> type P -> type (subst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* type_all as X. rewrite* subst_tt_open_tt_var.
Qed.

Lemma subst_te_term : forall e Z P,
  term e -> type P -> term (subst_te Z P e).
Proof.
  lets: subst_tt_type. induction 1; intros; simpl; auto.
  apply_fresh* term_abs as x. rewrite* subst_te_open_ee_var.
  apply_fresh* term_tabs as x. rewrite* subst_te_open_te_var.
Qed.

Lemma subst_ee_term : forall e1 Z e2,
  term e1 -> term e2 -> term (subst_ee Z e2 e1).
Proof.
  induction 1; intros; simpl; auto.
  case_var*.
  apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
  apply_fresh* term_tabs as Y. rewrite* subst_ee_open_te_var.
Qed.

Hint Resolve subst_tt_type subst_te_term subst_ee_term.

(* ********************************************************************** *)
(** * Properties of well-formedness of a type in an environment *)

(** If a type is well-formed in an environment then it is locally closed. *)

Lemma wft_type : forall E T,
  wft E T -> type T.
Proof.
  induction 1; eauto.
Qed.

(** Through weakening *)

Lemma wft_weaken : forall G T E F,
  wft (E & G) T ->
  ok (E & F & G) ->
  wft (E & F & G) T.
Proof.
  intros. gen_eq K: (E & G). gen E F G.
  induction H; intros; subst; eauto.
  (* case: var *)
  apply (@wft_var (E0&F&G)). apply* binds_weaken.
  (* case: all *)
  apply_fresh* wft_all as Y. apply_ih_bind* H0.
Qed.

(** Through strengthening *)

Lemma wft_strengthen : forall E F x U T,
 wft (E & x ~: U & F) T -> wft (E & F) T.
Proof.
  intros. gen_eq G: (E & x ~: U & F). gen F. assert (wft G T). { auto. }
  induction H; intros F EQ; subst; auto.
  apply wft_var. destruct (binds_concat_inv H) as [?|[? ?]].
    apply* binds_concat_right.
    destruct (binds_push_inv H2) as [[? ?]|[? ?]].
      subst. false.
      apply~ binds_concat_left.
  (* todo: binds_cases tactic *)
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

(** Through type substitution *)

Lemma wft_subst_tb : forall F E Z P T,
  wft (E & Z !: & F) T ->
  wft E P ->
  ok (E & map (subst_tb Z P) F) ->
  wft (E & map (subst_tb Z P) F) (subst_tt Z P T).
Proof.
  introv WT WP. gen_eq G: (E & Z !: & F). gen F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt; auto.
  case_var*.
    apply_empty* wft_weaken.
    destruct (binds_concat_inv H) as [?|[? ?]].
      apply wft_var.
       apply~ binds_concat_right. replace (bind_tvr) with (subst_tb Z P bind_tvr).
       apply binds_map. auto. auto.
      destruct (binds_push_inv H1) as [[? ?]|[? ?]].
        subst. false~.
        applys wft_var. apply* binds_concat_left.
  apply_fresh* wft_all as Y.
   unsimpl ((subst_tb Z P) bind_tvr).
   lets: wft_type.
   rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(** Through type reduction *)

Lemma wft_open : forall E U T,
  ok E ->
  wft E (typ_all T) ->
  wft E U ->
  wft E (open_tt T U).
Proof.
  introv Ok WA WU. inversions WA. pick_fresh X.
  autos* wft_type. rewrite* (@subst_tt_intro X).
  lets K: (@wft_subst_tb empty).
  specializes_vars K. clean_empty K. apply* K.
  (* todo: apply empty ? *)
Qed.

(* ********************************************************************** *)
(** * Relations between well-formed environment and types well-formed
  in environments *)

(** If an environment is well-formed, then it does not contain duplicated keys. *)

Lemma ok_from_okt : forall E,
  okt E -> ok E.
Proof.
  induction 1; auto.
Qed.

Hint Extern 1 (ok _) => apply ok_from_okt.

(** Extraction from a typing assumption in a well-formed environments *)

Lemma wft_from_env_has_typ : forall x U E,
  okt E -> binds x (bind_typ U) E -> wft E U.
Proof.
  induction E using env_ind; intros Ok B.
  false* binds_empty_inv.
  inversions Ok.
    false (empty_push_inv H0).
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H2.
       apply_empty* wft_weaken.
    destruct (eq_push_inv H) as [? [? ?]]. subst. clear H.
     destruct (binds_push_inv B) as [[? ?]|[? ?]]. subst.
       inversions H3. apply_empty* wft_weaken.
       apply_empty* wft_weaken.
Qed.

(** Extraction from a well-formed environment *)

Lemma wft_from_okt_typ : forall x T E,
  okt (E & x ~: T) -> wft E T.
Proof.
  intros. inversions* H.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [? ?]]. false.
  destruct (eq_push_inv H0) as [? [? ?]]. inversions~ H4.
Qed.

Lemma wft_weaken_right : forall T E F,
  wft E T ->
  ok (E & F) ->
  wft (E & F) T.
Proof.
  intros. apply_empty* wft_weaken.
Qed.

Hint Resolve wft_weaken_right.
Hint Resolve wft_from_okt_typ.
Hint Immediate wft_from_env_has_typ.
Hint Resolve wft_subst_tb.

(** Extraction from a subtyping assumption in a well-formed environments *)

(* ********************************************************************** *)
(** ** Properties of well-formedness of an environment *)

(** Inversion lemma *)

Lemma okt_push_inv : forall E X B,
  okt (E & X ~ B) -> B = bind_tvr \/ exists T, B = bind_typ T.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&?&?): (eq_push_inv H). subst*.
    lets (?&?&?): (eq_push_inv H). subst*.
Qed.

Lemma okt_push_tvr_inv : forall E X,
  okt (E & X !:) -> okt E /\ X # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&M&?): (eq_push_inv H). subst. inverts~ M.
    lets (?&?&?): (eq_push_inv H). false.
Qed.

Lemma okt_push_typ_inv : forall E x T,
  okt (E & x ~: T) -> okt E /\ wft E T /\ x # E.
Proof.
  introv O. inverts O.
    false* empty_push_inv.
    lets (?&?&?): (eq_push_inv H). false.
    lets (?&M&?): (eq_push_inv H). subst. inverts~ M.
Qed.

Lemma okt_push_typ_type : forall E X T,
  okt (E & X ~: T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_typ_inv. Qed.

Hint Immediate okt_push_typ_type.
(** Through strengthening *)

Lemma okt_strengthen : forall x T (E F:env),
  okt (E & x ~: T & F) ->
  okt (E & F).
Proof.
 introv O. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_typ_inv O).
  rewrite concat_assoc in *.
   lets: okt_push_inv O. destruct H; subst.
     lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_tvr. destruct H; subst*. apply okt_typ.
     lets (?&?): (okt_push_typ_inv O). apply* IHF. applys* wft_strengthen.
    lets (?&?): (okt_push_typ_inv O). destruct* H0.
Qed.

Lemma okt_strengthen_l : forall E F,
  okt (E&F) ->
  okt E.
Proof. introv OKC. induction F using env_ind.
  rewrite concat_empty_r in *. auto.
  rewrite concat_assoc in *.
   lets: okt_push_inv OKC. destruct H; subst.
     lets (?&?): (okt_push_tvr_inv OKC). apply IHF. apply H.
     destruct H; subst. lets (?&?): (okt_push_typ_inv OKC). apply* IHF.
Qed.

Lemma okt_subst_tb : forall Z P (E F:env),
  okt (E & Z!: & F) ->
  wft E P ->
  okt (E & map (subst_tb Z P) F).
Proof.
 introv O W. induction F using env_ind.
  rewrite map_empty. rewrite concat_empty_r in *.
   lets*: (okt_push_tvr_inv O).
  rewrite map_push. rewrite concat_assoc in *.
   lets : okt_push_inv O. destruct H; subst.
     lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_tvr.
     destruct H; subst.
      lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ.
Qed.

(** Automation *)

Hint Resolve okt_subst_tb wft_weaken.
Hint Immediate okt_strengthen.

(* ********************************************************************** *)
(** ** Environment is unchanged by substitution from a fresh name *)

Lemma notin_fv_tt_open : forall Y X T,
  X \notin fv_tt (T open_tt_var Y) ->
  X \notin fv_tt T.
Proof.
 introv. unfold open_tt. generalize 0.
 induction T; simpl; intros k Fr; auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 specializes IHT (S k). auto.
 specializes IHT1 k. specializes IHT2 k. auto.
 specializes IHT1 k. specializes IHT2 k. auto.
Qed.

Lemma notin_fv_wf : forall E X T,
  wft E T -> X # E -> X \notin fv_tt T.
Proof.
  induction 1; intros Fr; simpl.
  eauto.
  rewrite notin_singleton. intro. subst. applys binds_fresh_inv H Fr.
  notin_simpl; auto.
  notin_simpl; auto. apply* notin_union_l.
 pick_fresh Y. apply* (@notin_fv_tt_open Y).
Qed.

Lemma map_subst_tb_id : forall G Z P,
  okt G -> Z # G -> G = map (subst_tb Z P) G.
Proof.
  induction 1; intros Fr; autorewrite with rew_env_map; simpl.
  auto.
  rewrite* <- IHokt.
  rewrite* <- IHokt. rewrite* subst_tt_fresh. apply* notin_fv_wf.
Qed.
(* ********************************************************************** *)
(** ** Regularity of relations *)

(** The subtyping relation is restricted to well-formed objects. *)

(** The typing relation is restricted to well-formed objects. *)

Lemma typing_regular : forall E e T,
  typing E e T -> okt E /\ term e /\ wft E T.
Proof.
  induction 1.
  splits*.
  splits*.
  splits*.
  splits*.
  splits*.
  splits.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_typ_inv.
   apply_fresh* term_abs as y.
     pick_fresh y. specializes H0 y. destructs~ H0.
      forwards*: okt_push_typ_inv.
     specializes H0 y. destructs~ H0.
   pick_fresh y. specializes H0 y. destructs~ H0.
    apply* wft_arrow.
      forwards*: okt_push_typ_inv.
      apply_empty* wft_strengthen.
  splits*. destructs IHtyping1. inversion* H3.
  splits.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_tvr_inv.
   apply_fresh* term_tabs as y.
      forwards~ K: (H0 y). destructs K.
       forwards*: okt_push_tvr_inv.
   apply_fresh* wft_all as Y.
     pick_fresh y. forwards~ K: (H0 y). destructs K.
      forwards*: okt_push_tvr_inv.
     forwards~ K: (H0 Y). destructs K.
      forwards*: okt_push_tvr_inv.
  splits*. apply term_tapp; autos*. eapply wft_type. apply H0.
  destruct IHtyping. destruct H2. inversion H3.  subst.
   applys* wft_open T1.
  splits*.
Qed.

(** The value relation is restricted to well-formed objects. *)

Lemma value_regular : forall t,
  value t -> term t.
Proof.
  induction 1; autos*.
Qed.

(** The reduction relation is restricted to well-formed objects. *)

Lemma red_regular : forall t t',
  red t t' -> term t /\ term t'.
Proof.
  induction 1; split; autos* value_regular.
  inversions H. pick_fresh y. rewrite* (@subst_ee_intro y).
  inversions H. pick_fresh Y. rewrite* (@subst_te_intro Y).
Qed.

(** Automation *)

Hint Extern 1 (okt ?E) =>
  match goal with
  | H: typing _ _ _ |- _ => apply (proj31 (typing_regular H))
  end.

Hint Extern 1 (term ?e) =>
  match goal with
  | H: typing _ ?e _ |- _ => apply (proj32 (typing_regular H))
  | H: red ?e _ |- _ => apply (proj1 (red_regular H))
  | H: red _ ?e |- _ => apply (proj2 (red_regular H))
  end.

(** In parentheses are given the label of the corresponding
  lemma in the description of the POPLMark Challenge. *)

(* ********************************************************************** *)
(** * Properties of Subtyping *)

(* ********************************************************************** *)
(** Reflexivity (1) *)

Require Import Program.Equality.

Lemma invBound : forall m C, R m (mode_to_sub m) C -> forall A, R m A C.
  intros m C r.
  destruct m; dependent induction r; intros; eauto.
Defined.

Lemma invBound2 : forall m A, R m A (mode_to_sub (flip m)) -> forall C, R m A C.
  intros m A r.
  destruct m; dependent induction r; intros; eauto.
Defined.

(* ********************************************************************** *)
(** Symmetry*)

Lemma sym1 : forall A B m, R m A B -> R (flip m) B A.
  intros. induction H; eauto.
  - destruct m; apply* STB2.
  - destruct m; simpl in *; constructor; auto.
  - destruct m; simpl in *; apply SRight2; auto.
  - destruct m; simpl in *; apply SBoth2; auto.
Defined.

Corollary sym2 : forall A B m, R m A B <-> R (flip m) B A.
destruct m; split; apply sym1.
Defined.

Corollary sym : forall A B, R Sub A B <-> R Sup B A.
  intros. split; apply sym1.
Defined.

Lemma refl : forall (*E*) m A, type A (*wft E A*) -> R m A A.
  intros.
  induction H; eauto.
  - destruct m. apply STB1. apply STB2.
  - destruct m. apply STB2. apply STB1.
  - apply SFun; auto. apply sym1. auto.
Defined.

(* ********************************************************************** *)
(** Transitivity (3) *)

Require Import Program.Equality.

Hint Resolve invBound.

Lemma invChoose : forall m A B C, R m A (choose m B C) -> R m A B /\ R m A C.
  intros m A B C r.
  dependent induction r; eauto; try (destruct m; inversion x).
  - destruct (IHr _ _ eq_refl). split; apply SLeft1; auto.
  - destruct (IHr _ _ eq_refl). split; apply SRight1; auto.
  - subst; split; auto.
  - subst; split; auto.
  - destruct (IHr1 _ _ eq_refl).
    destruct (IHr2 _ _ eq_refl).
    split; apply SBoth2; eauto.
Defined.

Lemma flip_flip : forall m A C, R (flip (flip m)) A C -> R m A C.
  intros.
  destruct m; simpl in *; eauto.
Defined.

Lemma invChoose2 : forall m A B C, R m (choose (flip m) A B) C -> R m A C /\ R m B C.
  intros.
  apply sym1 in H. apply invChoose in H. destruct H.
  apply sym1 in H. apply sym1 in H0.
  apply flip_flip in H. apply flip_flip in H0.
  split; auto.
Defined.

Lemma trans : forall A B m, R m A B -> forall C, R m B C -> R m A C.
  intros A B m s.
  induction s; intros; eauto.
  - dependent induction H; simpl in *; auto; try (destruct m; inversion x).
    apply SLeft2. eapply IHR; eauto.
    apply SRight2. eapply IHR; eauto.
    apply SBoth1; eauto.
  - dependent induction H1; simpl in *; auto; try (destruct m; inversion x).
    + apply SAll with (L := L \u L0); intros; auto.
    +  apply SLeft2. eapply IHR; eauto.
    + apply SRight2. eapply IHR; eauto.
    + apply SBoth1; eauto.
  - apply invChoose2 in H. destruct H. apply IHs. auto.
  - apply invChoose2 in H. destruct H. apply IHs. auto.
  - dependent induction H; simpl in *; auto; try (destruct m; inversion x; fail).
    destruct m; simpl in x; inversion x; subst; eauto.
    apply SLeft2; apply (IHR B C); eauto.
    destruct m; simpl in x; inversion x; subst; eauto.
    apply SRight2; apply (IHR B C); eauto.
    apply SBoth1.
    eapply (IHR1 B C); eauto.
    eapply (IHR2 B C); eauto.
Defined.

(* ********************************************************************** *)
(** Type substitution preserves subtyping (10) *)

Lemma sub_through_subst_tt : forall m E Z S T P,
  R m S T ->
  wft E P->
  R m (subst_tt Z P S) (subst_tt Z P T).
Proof.
  introv SsubT PWFT.
  induction SsubT; subst; simpl subst_tt.
  apply* SInt.
  destruct m; apply* STB1.
  destruct m; apply* STB2.
  apply* SFun.
  case_var.
    apply* refl.
    apply wft_type in PWFT. auto.
    apply* SVarRefl.
  apply_fresh* SAll as X.
  rewrite* subst_tt_open_tt_var. rewrite* subst_tt_open_tt_var.
  apply wft_type in PWFT. auto. apply wft_type in PWFT. auto.
  destruct m. simpl. apply* SLeft1. simpl. apply* SLeft1.
  destruct m. simpl. apply* SLeft2. simpl. apply* SLeft2.
  destruct m. simpl. apply* SRight1. simpl. apply* SRight1.
  destruct m. simpl. apply* SRight2. simpl. apply* SRight2.
  destruct m. simpl. apply* SBoth1. simpl. apply* SBoth1.
  destruct m. simpl. apply* SBoth2. simpl. apply* SBoth2.
Qed.

(* TODO: BABER Finish this - Done *)

(* ********************************************************************** *)
(** * Properties of Typing *)

(* ********************************************************************** *)
(** Weakening (5) *)

Lemma typing_weakening : forall E F G e T,
   typing (E & G) e T ->
   okt (E & F & G) ->
   typing (E & F & G) e T.
Proof.
  introv Typ. gen F. inductions Typ; introv Ok.
  apply* typing_unit.
  apply* typing_var. apply* binds_weaken.
  apply* typing_nval.
  apply* typing_nsucc.
  apply* typing_nind.
  apply_fresh* typing_abs as x. forwards~ K: (H x).
   apply_ih_bind (H0 x); eauto.
  apply* typing_app.
  apply_fresh* typing_tabs as X. forwards~ K : (H X).
   apply_ih_bind (H0 X); eauto.
  apply* typing_tapp.
  apply* typing_sub.
Qed.

(************************************************************************ *)
(** Preservation by Term Substitution (8) *)

Lemma typing_through_subst_ee : forall U E F x T e u,
  typing (E & x ~: U & F) e T ->
  typing E u U ->
  typing (E & F) (subst_ee x u e) T.
Proof.
  introv TypT TypU. inductions TypT; introv; simpl.
  apply* typing_unit.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply* typing_nval.
  apply* typing_nsucc.
  apply* typing_nind.
  apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih_bind* H0.
  lets M:TypU. apply typing_regular in M. destruct M. auto.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    rewrite* subst_ee_open_te_var.
    apply_ih_bind* H0.
  apply* typing_tapp.
  apply* wft_strengthen.
  apply* typing_sub. apply* wft_strengthen.
Qed.

(************************************************************************ *)
(** Preservation by Type Substitution (11) *)

Lemma typing_through_subst_te : forall E F Z e T P,
  typing (E & Z!: & F) e T ->
  wft E P ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Typ WFT.
  inductions Typ; simpls subst_tt; simpls subst_te; autos*.
  subst. apply* typing_unit.
  subst. apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
  binds_cases H0; unsimpl_map_bind*. apply okt_strengthen_l in H.
   apply okt_strengthen_l in H. auto.
  (* case abs *)
  apply_fresh* typing_abs as y.
    unsimpl (subst_tb Z P (bind_typ V)).
   rewrite* subst_te_open_ee_var.
   apply_ih_map_bind* H0.
  (* case tabs *)
  apply_fresh* typing_tabs as Y.
   unsimpl (subst_tb Z P (bind_tvr)).
    rewrite* subst_te_open_te_var.
    rewrite* subst_tt_open_tt_var.
    apply_ih_map_bind* H0.
  apply wft_type in WFT. auto.
  apply wft_type in WFT. auto.
  subst. rewrite* subst_tt_open_tt. apply wft_type in WFT. auto.
  subst. apply* typing_sub. apply* sub_through_subst_tt.
Qed.

(* ********************************************************************** *)
(** * Preservation *)

(* ********************************************************************** *)
(** Inversions for Typing (13) *)

Lemma typing_inv_abs : forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  (forall U1 U2, R Sub T (typ_arrow U1 U2) ->
     R Sub U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ R Sup U2 S2).
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 R; inversions EQ.
  inversions* R. split.
  rewrite <- sym2 in H5. auto.
  exists T1. exists L. split; autos.
  rewrite sym2. apply H7.
  apply IHTyp. auto.
  eapply trans. apply H. apply R.
Qed.

Fact typing_inv_abs_not_sup : ~(forall E S1 e1 T,
  typing E (trm_abs S1 e1) T ->
  (forall U1 U2, R Sup T (typ_arrow U1 U2) ->
     R Sup U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ R Sub U2 S2)).
Proof.
  intros contra.
  assert (R Sup typ_int typ_top).
  { specialize (@contra empty typ_top (trm_nval 0) typ_top).
    assert (typing empty (trm_abs typ_top (trm_nval 0)) typ_top).
    { eapply typing_sub. apply typing_abs with (L:=\{}). introv X.
      assert (trm_nval 0 open_ee_var x = trm_nval 0).
      { unfold open_ee. simpl. reflexivity. }
      rewrite H. apply typing_nval.
      autos. apply STB1. auto.   }
    apply contra with (U1 := typ_int) (U2 := typ_top) in H.
    destruct H. apply H. apply STB2.
  }
  inversion H. Qed.

Lemma typing_inv_tabs : forall E e T,
  typing E (trm_tabs e) T ->
  forall U, R Sub T (typ_all U) ->
  exists S, exists L, forall X, X \notin L ->
     typing (E & X!:) (e open_te_var X) (S open_tt_var X)
     /\ R Sub (S open_tt_var X) (U open_tt_var X).
Proof.
  introv Ty Sub. remember (trm_tabs e) as trm. remember (typ_all U) as ty.
  induction Ty; inversion Heqtrm; subst; clear H0.
  - exists T. inversion Sub. subst. exists (L \u L0).
    introv NI. apply notin_union_r in NI. destruct NI. split.
    apply* H. apply* H3.
  - apply* IHTy. eapply trans. apply H. auto.
Qed.

(* ********************************************************************** *)
(** Preservation Result (20) *)

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  - inversion Red. apply* typing_nval.
    apply* typing_nsucc.
  - inversion Red; try solve [apply* typing_nind].
    subst. auto.
    subst. apply* typing_app.
  (* case: app *)
  - inversions Red; try solve [ apply* typing_app ].
  destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply refl (*with (E:=E)*). apply typing_regular in Typ1. destruct Typ1.
    destruct H0. apply wft_type in H2. auto.
    pick_fresh X. (*apply wft_type in H2. auto. pick_fresh X.*) forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_ee_intro X).
     apply_empty (@typing_through_subst_ee V).
       apply* (@typing_sub S2). apply* sym2. apply typing_regular in Typ1.
       destruct Typ1. destruct H4. inversion H5. subst. apply* wft_weaken_right.
       inversion Typ1. subst. apply Typ2. subst. eapply typing_sub. apply Typ2. auto.
       clear Fr. apply typing_regular in H. destruct H.
       apply wft_from_okt_typ in H. auto.
  (* case: tapp *)
  - inversions Red; try solve [ apply* typing_tapp ].
   destruct (typing_inv_tabs Typ (U:=T1)). apply typing_regular in Typ.
   apply refl. (*with (E:=E)*) destruct Typ. destruct H1. apply wft_type in H3. auto.
   apply typing_regular in Typ. destruct Typ.
    destruct H3.  inversion H5; subst. destruct H0. pick_fresh X. forwards~ K : ( H0 X). destruct K.
   rewrite* (@subst_te_intro X). rewrite* (@subst_tt_intro X).
   replace E with (E & map (subst_tb X T2) empty).
   replace (E & X!:) with (E & X!: & empty) in H6.
    eapply typing_sub.
   apply (typing_through_subst_te H6) .
    auto.
   apply* (@sub_through_subst_tt Sub E X).
   apply* wft_subst_tb.
   apply* concat_empty_r.
   rewrite map_empty. apply* concat_empty_r.
  (* case sub *)
  - apply* typing_sub.
Qed.

(* ********************************************************************** *)
(** * Progress *)

(* ********************************************************************** *)
(** Canonical Forms (14) *)

Lemma canonical_form_abs : forall t U1 U2,
  value t -> typing empty t (typ_arrow U1 U2) ->
  exists V, exists e1, t = trm_abs V e1.
Proof.
  introv Val Typ.
  gen_eq T: (typ_arrow U1 U2). intro st. assert (R Sub T (typ_arrow U1 U2)).
{ rewrite st.
    apply refl; (*with (E:=empty);*) auto. subst. apply typing_regular in Typ.
    destruct Typ. destruct H0. apply wft_type in H1. auto. }
  clear st. gen_eq E: (@empty typ). gen U1 U2.
  induction Typ; introv EQT EQE;
   try solve [ inversion Val | inversion EQT | eauto ].
    subst. assert (R Sub S (typ_arrow U1 U2)). { eapply trans.
    apply H. apply EQT. } eapply IHTyp. apply Val. apply H1. reflexivity. Qed.

Lemma canonical_form_nat : forall t,
  value t -> typing empty t typ_int ->
  exists v, t = trm_nval v.
Proof.
  introv Val Typ.
  gen_eq T: typ_int. intro st. assert (R Sub T typ_int). { rewrite* st.  }
  clear st. gen_eq E: (@empty typ).
  induction Typ; introv EQE;
   try solve [ inversion Val | inversion EQE | eauto | inversion H ].
  eapply IHTyp. apply Val. eapply trans. apply H0. apply H. apply EQE. Qed.

Lemma canonical_form_tabs : forall t U,
  value t -> typing empty t (typ_all U) ->
  exists e1, t = trm_tabs e1.
Proof.
  introv Val Typ.
  gen_eq T: (typ_all U). intro st. assert (R Sub T (typ_all U)). { rewrite* st.
  apply refl (*with (E:=empty)*); auto. subst. apply typing_regular in Typ. destruct Typ.
      destruct H0. apply wft_type in H1. auto. }
  clear st. gen_eq E: (@empty typ).
  induction Typ; introv EQE;
   try solve [ inversion Val | inversion EQE | eauto | inversion H ].
  subst. apply* IHTyp. eapply trans. apply H0. apply H. Qed.
(* ********************************************************************** *)
(** Progress Result (16) *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty typ). lets Typ': Typ. remember empty as Env.
  induction Typ; intros EQ; subst.
  left*.
  (* case: var *)
  false* binds_empty_inv.
  (* case: nval *)
  left*.
  (* case: succ *)
  right*.
  destruct* IHTyp as [Val1 | R1].
    destruct (canonical_form_nat Val1 Typ) as [ v ].
    subst. exists (trm_nval (S v)). auto.
    destruct R1. exists (trm_nsucc x). auto.
  (* case : ind *)
  right*.
  {
    assert (value t1 \/ (exists e', red t1 e')). { auto. }
    assert (value t2 \/ (exists e', red t2 e')). { auto. }
    assert (value t3 \/ (exists e', red t3 e')). { auto. }
    clear IHTyp1 IHTyp2 IHTyp3. destruct H0; subst.
    - destruct (canonical_form_nat H0 Typ1) as [ v ].
     destruct H2.
      + subst. destruct v.
        * exists t2. apply red_ind_izero; auto.
        * exists (trm_app t3 (trm_nind (trm_nval v) t2 t3)).
        apply red_ind_isucc. apply* typing_regular. auto.
      + destruct* H2.
    - destruct* H0.  }
  (* case: abs *)
  left*.
  (* case: app *)
  right. destruct* IHTyp1 as [Val1 | [e1' Rede1']].
    destruct* IHTyp2 as [Val2 | [e2' Rede2']].
      destruct (canonical_form_abs Val1 Typ1) as [S [e3 EQ]].
        subst. exists* (open_ee e3 e2).
  left*.
  right. destruct* IHTyp as [Val | [e1 Red]].
      destruct (canonical_form_tabs Val Typ).
        subst. exists* (open_te x T2). apply* red_tabs.
        apply wft_type in H. auto.
      exists (trm_tapp e1 T2). apply* red_tapp. apply wft_type in H. auto.
  autos*.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export List.
Require Export Bintree.
Require Import Bool BinPos.

Declare ML Module "rtauto_plugin".

Ltac clean:=try (simpl;congruence).

Inductive form:Set:=
  Atom : positive -> form
| Arrow : form -> form -> form
| Bot
| Conjunct : form -> form -> form
| Disjunct : form -> form -> form.

Notation "[ n ]":=(Atom n).
Notation "A =>> B":= (Arrow A B) (at level 59, right associativity).
Notation "#" := Bot.
Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity).
Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity).

Definition ctx := Store form.

Fixpoint pos_eq (m n:positive) {struct m} :bool :=
match m with
  xI mm => match n with xI nn => pos_eq mm nn | _ => false end
| xO mm => match n with xO nn => pos_eq mm nn | _ => false end
| xH => match n with xH => true | _ => false end
end.

Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
induction m;simpl;destruct n;congruence ||
(intro e;apply f_equal;auto).
Qed.

Fixpoint form_eq (p q:form) {struct p} :bool :=
match p with
  Atom m => match q with Atom n => pos_eq m n | _ => false end
| Arrow p1 p2 =>
match q with
  Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2
| _ => false end
| Bot => match q with Bot => true | _ => false end
| Conjunct p1 p2 =>
match q with
  Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
| _ => false
end
| Disjunct p1 p2 =>
match q with
  Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
| _ => false
end
end.

Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q.
induction p;destruct q;simpl;clean.
intro h;generalize (pos_eq_refl _ _ h);congruence.
case_eq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
case_eq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
case_eq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
Qed.

Arguments form_eq_refl [p q] _.

Section with_env.

Variable env:Store Prop.

Fixpoint interp_form (f:form): Prop :=
match f with
[n]=> match get n env with PNone => True | PSome P => P end
| A =>> B => (interp_form A) -> (interp_form B)
| # => False
| A //\\ B => (interp_form A) /\ (interp_form B)
| A \\// B => (interp_form A) \/ (interp_form B)
end.

Notation "[[ A ]]" := (interp_form A).

Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop :=
match F with
  F_empty => G
| F_push H hyps0 F0 =>  interp_ctx hyps0 F0  ([[H]] -> G)
end.

Ltac wipe := intros;simpl;constructor.

Lemma compose0 :
forall hyps F (A:Prop),
 A ->
 (interp_ctx hyps F A).
induction F;intros A H;simpl;auto.
Qed.

Lemma compose1 :
forall hyps F (A B:Prop),
 (A -> B) ->
 (interp_ctx hyps F A) ->
 (interp_ctx hyps F B).
induction F;intros A B H;simpl;auto.
apply IHF;auto.
Qed.

Theorem compose2 :
forall hyps F (A B C:Prop),
 (A -> B -> C) ->
 (interp_ctx hyps F A) ->
 (interp_ctx hyps F B) ->
 (interp_ctx hyps F C).
induction F;intros A B C H;simpl;auto.
apply IHF;auto.
Qed.

Theorem compose3 :
forall hyps F (A B C D:Prop),
 (A -> B -> C -> D) ->
 (interp_ctx hyps F A) ->
 (interp_ctx hyps F B) ->
 (interp_ctx hyps F C) ->
 (interp_ctx hyps F D).
induction F;intros A B C D H;simpl;auto.
apply IHF;auto.
Qed.

Lemma weaken : forall hyps F f G,
 (interp_ctx hyps F G) ->
 (interp_ctx (hyps\f)  (F_push f hyps F) G).
induction F;simpl;intros;auto.
apply compose1 with ([[a]]-> G);auto.
Qed.

Theorem project_In : forall hyps F g,
In g hyps F ->
interp_ctx hyps F [[g]].
induction F;simpl.
contradiction.
intros g H;destruct H.
subst;apply compose0;simpl;trivial.
apply compose1 with [[g]];auto.
Qed.

Theorem project : forall hyps F p g,
get  p hyps = PSome g->
interp_ctx hyps F [[g]].
intros hyps F p g e; apply project_In.
apply get_In with p;assumption.
Qed.

Arguments project [hyps] F [p g] _.

Inductive proof:Set :=
  Ax : positive -> proof
| I_Arrow : proof -> proof
| E_Arrow : positive -> positive -> proof -> proof
| D_Arrow : positive -> proof -> proof -> proof
| E_False : positive -> proof
| I_And: proof -> proof -> proof
| E_And: positive -> proof -> proof
| D_And: positive -> proof -> proof
| I_Or_l: proof -> proof
| I_Or_r: proof -> proof
| E_Or: positive -> proof -> proof -> proof
| D_Or: positive -> proof -> proof
| Cut: form -> proof -> proof -> proof.

Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).

Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
 match P with
   Ax i =>
     match get i hyps with
         PSome F => form_eq F gl
 | _ => false
    end
| I_Arrow p =>
   match gl with
      A  =>> B  => check_proof (hyps \ A) B p
   | _ => false
    end
| E_Arrow i j p =>
   match get i hyps,get j hyps with
       PSome A,PSome (B =>>C) =>
         form_eq A B && check_proof (hyps \ C) (gl) p
    | _,_ => false
    end
| D_Arrow i p1 p2 =>
   match get i hyps with
      PSome  ((A =>>B)=>>C) =>
     (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2)
    | _ => false
  end
| E_False i =>
  match get i hyps with
    PSome # => true
  | _ => false
  end
| I_And p1 p2 =>
   match gl with
      A //\\ B =>
      check_proof hyps A p1 && check_proof hyps B p2
      | _ => false
      end
| E_And i p =>
   match get i hyps with
      PSome  (A //\\ B) => check_proof (hyps \ A \ B) gl p
    | _=> false
   end
| D_And i p =>
   match get i hyps with
      PSome  (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p
    | _=> false
   end
| I_Or_l p =>
   match gl with
      (A \\// B) => check_proof hyps A p
      | _ => false
      end
| I_Or_r p =>
   match gl with
      (A \\// B) => check_proof hyps B p
      | _ => false
      end
| E_Or i p1 p2 =>
  match get i hyps with
  PSome (A \\// B) =>
  check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2
  | _=> false
  end
| D_Or i p =>
   match get i hyps with
      PSome  (A \\// B =>> C) =>
      (check_proof (hyps \ A=>>C \ B=>>C) gl p)
    | _=> false
   end
| Cut A p1 p2 =>
  check_proof hyps A p1 && check_proof (hyps \ A) gl p2
end.

Theorem interp_proof:
forall p hyps F gl,
check_proof hyps gl p = true -> interp_ctx hyps F [[gl]].

induction p; intros hyps F gl.

- (* Axiom *)
  simpl;case_eq (get p hyps);clean.
  intros f nth_f e;rewrite <- (form_eq_refl e).
  apply project with p;trivial.

- (* Arrow_Intro *)
  destruct gl; clean.
  simpl; intros.
  change (interp_ctx (hyps\gl1)  (F_push gl1 hyps F) [[gl2]]).
  apply IHp; try constructor; trivial.

- (* Arrow_Elim *)
  simpl check_proof; case_eq (get p hyps); clean.
  intros f ef; case_eq (get p0 hyps); clean.
  intros f0 ef0; destruct f0; clean.
  case_eq (form_eq f f0_1); clean.
  simpl; intros e check_p1.
  generalize  (project  F ef) (project  F ef0)
              (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
    clear check_p1 IHp p p0 p1 ef ef0.
  simpl.
  apply compose3.
  rewrite (form_eq_refl e).
  auto.

- (* Arrow_Destruct *)
  simpl; case_eq (get p1 hyps); clean.
  intros f ef; destruct f; clean.
  destruct f1; clean.
  case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2); clean.
  intros check_p1 check_p2.
  generalize (project F ef)
             (IHp1 (hyps \ f1_2 =>> f2 \ f1_1)
                   (F_push f1_1 (hyps \ f1_2 =>> f2)
                           (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
             (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
  simpl; apply compose3; auto.

- (* False_Elim *)
  simpl; case_eq (get p hyps); clean.
  intros f ef; destruct f; clean.
  intros _; generalize (project F ef).
  apply compose1; apply False_ind.

- (* And_Intro *)
  simpl; destruct gl; clean.
  case_eq (check_proof hyps gl1 p1); clean.
  intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
  apply compose2 ; simpl; auto.

- (* And_Elim *)
  simpl; case_eq (get p hyps); clean.
  intros f ef; destruct f; clean.
  intro check_p;
    generalize  (project F ef)
                (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
  simpl; apply compose2; intros [h1 h2]; auto.

- (* And_Destruct*)
  simpl; case_eq (get p hyps); clean.
  intros f ef; destruct f; clean.
  destruct f1; clean.
  intro H;
    generalize (project F ef)
               (IHp (hyps \ f1_1 =>> f1_2 =>> f2)
                    (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);
    clear H; simpl.
  apply compose2; auto.

- (* Or_Intro_left *)
  destruct gl; clean.
  intro Hp; generalize (IHp hyps F gl1 Hp).
  apply compose1; simpl; auto.

- (* Or_Intro_right *)
  destruct gl; clean.
  intro Hp; generalize (IHp hyps F gl2 Hp).
  apply compose1; simpl; auto.

- (* Or_elim *)
  simpl; case_eq (get p1 hyps); clean.
  intros f ef; destruct f; clean.
  case_eq (check_proof (hyps \ f1) gl p2); clean.
  intros check_p1 check_p2;
    generalize (project F ef)
               (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
               (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
    simpl; apply compose3; simpl; intro h; destruct h; auto.

- (* Or_Destruct *)
  simpl; case_eq (get p hyps); clean.
  intros f ef; destruct f; clean.
  destruct f1; clean.
  intro check_p0;
    generalize (project F ef)
               (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
                    (F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2)
                            (F_push (f1_1 =>> f2) hyps F)) gl check_p0);
    simpl.
  apply compose2; auto.

- (* Cut *)
  simpl; case_eq (check_proof hyps f p1); clean.
  intros check_p1 check_p2;
    generalize (IHp1 hyps F f check_p1)
               (IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
    simpl; apply compose2; auto.
Qed.

Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True.
intros gl prf;case_eq (check_proof empty gl prf);intro check_prf.
change (interp_ctx empty F_empty [[gl]]) ;
apply interp_proof with prf;assumption.
trivial.
Qed.

End with_env.

(*
(* A small example *)
Parameters A B C D:Prop.
Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
exact (Reflect (empty \ A \ B \ C)
([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3])
(I_Arrow (E_And 1 (E_Or 3
  (I_Or_l (I_And (Ax 2) (Ax 4)))
  (I_Or_r (I_And (Ax 2) (Ax 4))))))).
Qed.
Print toto.
*)


(** * Classical reasoning on decidable propositions.
  There are two principal type classes used here:
  - Computable P means that we can decide {P} + {~P},
  - Decidable P is the same thing in Prop (P \/ ~P).

  Given an instance of Decidable P we can transform a goal
  T |- P into T, ~P |- False and use tauto to get a complete
  decision procedure for classical logic by Glivenko's theorem.
  This is implemented in the dtauto tactic.

  Furthermore there are two tactics dleft, dright which correspond
  to classical_left and classical_right. *)
Require Extraction.
Require Import Coq.Program.Tactics.
Require Export Bool.

Class Computable (P : Prop) := decision_procedure : { P } + { ~P }.
Opaque decision_procedure.

Arguments decision_procedure P {Computable}.

Local Obligation Tactic := firstorder.

(** Propositional formulas over computable atoms are computable. *)
Section ComputableInstances.
  Global Program Instance inst_true_cm  : Computable True.
  Global Program Instance inst_false_cm : Computable False.

  Variable P : Prop.
  Variable H : Computable P.

  Global Program Instance inst_not_cm : Computable (~P).

  Variable Q  : Prop.
  Variable H' : Computable Q.

  Global Program Instance inst_and_cm  : Computable (P /\ Q).
  Global Program Instance inst_or_cm   : Computable (P \/ Q).
  Global Program Instance inst_impl_cm : Computable (P -> Q).
  Global Program Instance inst_iff_cm  : Computable (P <-> Q).
End ComputableInstances.

Extraction Inline inst_true_cm_obligation_1 inst_false_cm_obligation_1
  inst_not_cm_obligation_1 inst_and_cm_obligation_1 inst_or_cm_obligation_1
  inst_impl_cm_obligation_1 inst_iff_cm_obligation_1
  inst_and_cm inst_or_cm inst_impl_cm inst_iff_cm.

(** Lift boolean predicates to computable Props. *)

Coercion Is_true : bool >-> Sortclass.

Global Instance inst_Is_true_cm (b : bool) : Computable (Is_true b).
  destruct b; simpl; firstorder.
Defined.

Extraction Inline inst_Is_true_cm.

(** Classical axioms for decidable predicates. *)
Lemma decidable_xm P `(Computable P) : P \/ ~P.  destruct H; tauto. Qed.
Lemma decidable_dn P `(Computable P) : ~~P -> P. destruct H; tauto. Qed.

Lemma dleft (P Q : Prop) `(Computable Q) :
  (~Q -> P) -> P \/ Q.
Proof.
  destruct H; tauto.
Qed.

Lemma dright (P Q : Prop) `(Computable P) :
  (~P -> Q) -> P \/ Q.
Proof.
  destruct H; tauto.
Qed.

(** dcontra applies double negation to the current goal if it is decidable. *)
Ltac dcontra :=
  (match goal with
     | |- ?H => apply (decidable_dn H _)
   end) || fail "Could not prove that the goal is a decidable proposition.".

(** dtauto does the same thing as tauto with classical the goal is decidable. *)
Ltac dtauto := tauto || (intros; dcontra; tauto) || fail "dtauto failed".

(** Similarly, dleft and dright are the analogs to classical_left/right. *)
Ltac dleft :=
  match goal with
    | |- ?P \/ ?Q => apply (dleft P Q _)
  end.

Ltac dright :=
  match goal with
    | |- ?P \/ ?Q => apply (dright P Q _)
  end.

(** destruct [P] does case analysis on decidable propositions. *)
(* More concretely, if the goal is in Prop then P has to be decidable,
   otherwise P should be computable. *)
Ltac decide_tac P :=
  match goal with
    | |- ?H =>
      match type of H with
        | _    => destruct (@decision_procedure P _) || fail 2 "not a computable proposition."
      end
  end.

Tactic Notation "decide" constr(P) := decide_tac P.

Tactic Notation "decide_goal" :=
  match goal with
    [ |- ?s ] => decide s
  end.

(** Programming with computable Props. *)
Notation "'if' [ P ] 'then' s 'else' t" :=
  (if (@decision_procedure P _) then s else t) (at level 200, right associativity, format
  "'if'  [ P ]  'then'  s  'else'  t").

Extraction Inline decision_procedure.

Instance computable_if (A B C:Prop) `{Computable A} `{Computable B} `{Computable C}
  : Computable (if [A] then B else C).
Proof.
  destruct (@decision_procedure A _); eauto.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)

(** * Mapping Cylinders *)

Require Import HoTT.Basics Cubical.DPath Cubical.PathSquare.
Require Import Colimits.Pushout.
Local Open Scope path_scope.

(** As in topology, the mapping cylinder of a function [f : A -> B] is a way to replace it with an equivalent cofibration (dually to how [hfiber] replaces it with an equivalent fibration).  We can't talk *internally* in type theory about cofibrations, but we can say metatheoretically what they are: functions with the isomorphism extension property.  So while we can't literally say "let [f] be a cofibration" we can do a mostly equivalent thing and say "let [f] be a map and consider its mapping cylinder".  Replacing a map by a cofibration can be useful because it allows us to make more equalities true definitionally. *)

(** ** Definitions *)

(** We define the mapping cylinder as the pushout of [f] and an identity map.  Peter Lumsdaine has given a definition of HIT mapping cylinders that are dependent on the codomain, so that the second factor is not just an equivalence but a trivial fibration.  However, at the moment we don't have a need for that.  *)

Definition Cyl {A B : Type} (f : A -> B) : Type
  := Pushout idmap f.

Section MappingCylinder.
  Context {A B : Type} {f : A -> B}.

  Definition cyl (a : A) : Cyl f
    := pushl a.
  Definition cyr (b : B) : Cyl f
    := pushr b.

  Definition cyglue (a : A)
    : cyl a = cyr (f a)
    := pglue a.

  Section CylInd.
    Context (P : Cyl f -> Type)
            (cyla : forall a, P (cyl a))
            (cylb : forall b, P (cyr b))
            (cylg : forall a, DPath P (cyglue a) (cyla a) (cylb (f a))).

    Definition Cyl_ind_dp : forall c, P c.
    Proof.
      srapply Pushout_ind.
      - apply cyla.
      - apply cylb.
      - intros a; apply dp_path_transport^-1, cylg.
    Defined.

    Definition Cyl_ind_dp_beta_cyglue (a : A)
      : dp_apD Cyl_ind_dp (cyglue a) = cylg a.
    Proof.
      unfold Cyl_ind_dp.
      refine ((dp_path_transport_apD _ _)^ @ _).
      apply moveR_equiv_M.
      rapply Pushout_ind_beta_pglue.
    Defined.

  End CylInd.

  Section CylRec.
    Context {P : Type} (cyla : A -> P) (cylb : B -> P) (cylg : cyla == cylb o f).

    Definition Cyl_rec : Cyl f -> P.
    Proof.
      srapply Pushout_rec.
      - apply cyla.
      - apply cylb.
      - apply cylg.
    Defined.

    Definition Cyl_rec_beta_cyglue (a : A)
      : ap Cyl_rec (cyglue a) = cylg a.
    Proof.
      rapply Pushout_rec_beta_pglue.
    Defined.

  End CylRec.

  Definition pr_cyl : Cyl f <~> B.
  Proof.
    (** Rather than adjointifying, we give all parts of the equivalence explicitly, so we can be sure of retaining the computational behavior of [eissect] and [eisretr].  However, it's easier to prove [eisadj] on the other side, so we reverse the equivalence first. *)
    symmetry.
    srapply Build_Equiv.
    1:apply cyr.
    srapply Build_IsEquiv.
    - srapply Cyl_rec.
      + exact f.
      + exact idmap.
      + reflexivity.
    - srapply Cyl_ind_dp.
      + intros a; cbn.
        symmetry; apply cyglue.
      + intros b; reflexivity.
      + intros a; cbn.
        apply dp_paths_FFlr.
        rewrite Cyl_rec_beta_cyglue.
        apply concat_pV_p.
    - intros b; reflexivity.
    - intros b; reflexivity.
  Defined.

  Definition ap_pr_cyl_cyglue (a : A)
    : ap pr_cyl (cyglue a) = 1
    := Cyl_rec_beta_cyglue _ _ _ a.

  (** The original map [f] factors definitionally through [Cyl f]. *)
  Definition pr_cyl_cyl (a : A) : pr_cyl (cyl a) = f a
    := 1.

End MappingCylinder.

(** Sometimes we have to specify the map explicitly. *)
Definition cyl' {A B} (f : A -> B) : A -> Cyl f := cyl.
Definition pr_cyl' {A B} (f : A -> B) : Cyl f -> B := pr_cyl.

(** ** Functoriality *)

Section FunctorCyl.
  Context {A B A' B': Type} {f : A -> B} {f' : A' -> B'}
          {ga : A -> A'} {gb : B -> B'}
          (g : f' o ga == gb o f).

  Definition functor_cyl : Cyl f -> Cyl f'.
  Proof.
    srapply Cyl_rec.
    - exact (cyl o ga).
    - exact (cyr o gb).
    - intros a.
      refine (_ @ ap cyr (g a)).
      exact (cyglue (ga a)).
  Defined.

  Definition ap_functor_cyl_cyglue (a : A)
    : ap functor_cyl (cyglue a) = cyglue (ga a) @ ap cyr (g a)
    := Cyl_rec_beta_cyglue _ _ _ a.

  (** The benefit of passing to the mapping cylinder is that it makes a square commute definitionally. *)
  Definition functor_cyl_cyl (a : A) : cyl (ga a) = functor_cyl (cyl a)
    := 1.

  (** The other square also commutes, though not definitionally. *)
  Definition pr_functor_cyl (c : Cyl f)
    : pr_cyl (functor_cyl c) = gb (pr_cyl c)
    := ap (pr_cyl o functor_cyl) (eissect pr_cyl c)^.

  Definition pr_functor_cyl_cyl (a : A)
    : pr_functor_cyl (cyl a) = g a.
  Proof.
    (** Here we need [eissect pr_cyl (cyl a)] to compute. *)
    refine (ap _ (inv_V _) @ _).
    refine (ap_compose functor_cyl pr_cyl (cyglue a) @ _).
    refine (ap _ (ap_functor_cyl_cyglue a) @ _).
    refine (ap_pp _ _ _ @ _).
    refine (whiskerR (ap_pr_cyl_cyglue (ga a)) _ @ concat_1p _ @ _).
    refine ((ap_compose cyr _ (g a))^ @ _).
    apply ap_idmap.
  Defined.

End FunctorCyl.

(** ** Coequalizers *)

(** A particularly useful application is to replace a map of coequalizers with one where both squares commute definitionally. *)

Section CylCoeq.
  Context {B A f g B' A' f' g'}
          {h : B -> B'} {k : A -> A'}
          (p : k o f == f' o h) (q : k o g == g' o h).

  Definition CylCoeq : Type
    := Coeq (functor_cyl p) (functor_cyl q).

  Definition cyl_cylcoeq : Coeq f g -> CylCoeq
    := functor_coeq cyl cyl (functor_cyl_cyl p) (functor_cyl_cyl q).

  Definition ap_cyl_cylcoeq_cglue (b : B)
    : ap cyl_cylcoeq (cglue b) = cglue (cyl b).
  Proof.
    etransitivity.
    1:rapply functor_coeq_beta_cglue.
    exact (concat_p1 _ @ concat_1p _).
  Defined.

  Definition pr_cylcoeq : CylCoeq <~> Coeq f' g'
    := equiv_functor_coeq pr_cyl pr_cyl (pr_functor_cyl p) (pr_functor_cyl q).

  Definition ap_pr_cylcoeq_cglue (x : Cyl h)
    : PathSquare (ap pr_cylcoeq (cglue x)) (cglue (pr_cyl x))
                 (ap coeq (pr_functor_cyl p x))
                 (ap coeq (pr_functor_cyl q x)).
  Proof.
    apply sq_path.
    apply moveR_pM.
    rewrite <- (ap_V coeq).
    rapply functor_coeq_beta_cglue.
  Defined.

  Definition pr_cyl_cylcoeq
    : functor_coeq h k p q == pr_cylcoeq o cyl_cylcoeq.
  Proof.
    intros c.
    refine (_ @ functor_coeq_compose cyl cyl (functor_cyl_cyl p) (functor_cyl_cyl q)
              pr_cyl pr_cyl (pr_functor_cyl p) (pr_functor_cyl q) c).
    srapply functor_coeq_homotopy.
    1-2:reflexivity.
    all:intros b; cbn.
    all:refine (concat_1p _ @ concat_1p _ @ _ @ (concat_p1 _)^).
    all:apply pr_functor_cyl_cyl.
  Defined.

End CylCoeq.


Set Warnings "-notation-overridden".

From Coq Require Eqdep_dec Extraction Setoid Vector ZArith.

Module Classes.

Export Setoid Morphisms.

(* Definition relation (A : Type) : Type :=
  A -> A -> Prop.

Definition respectful {A B : Type}
  (R : relation A) (S : relation B) (f g : A -> B) : Prop :=
  forall x y : A, R x y -> S (f x) (g y).

Definition Proper {A : Type} (R : relation A) (x : A) : Prop :=
  R x x.

Reserved Notation "R '==>' S" (at level 55, right associativity).
Notation "R '==>' S" := (respectful R S) : signature_scope. *)
Reserved Notation "x '::>' R" (at level 60, right associativity).
Notation "x '::>' R" := (Proper R x) : signature_scope.

Class Eqv (A : Type) : Type := eqv : A -> A -> Prop.
Class Opr (A : Type) : Type := opr : A -> A -> A.
Class Idn (A : Type) : Type := idn : A.
Class Inv (A : Type) : Type := inv : A -> A.
Class Add (A : Type) : Type := add : A -> A -> A.
Class Zero (A : Type) : Type := zero : A.
Class Neg (A : Type) : Type := neg : A -> A.
Class Mul (A : Type) : Type := mul : A -> A -> A.
Class One (A : Type) : Type := one : A.
Class Recip (A : Type) : Type := recip : A -> A.
Class LSMul (S A : Type) : Type := lsmul : S -> A -> A.
Class RSMul (S A : Type) : Type := rsmul : S -> A -> A.

Delimit Scope group_scope with group.
Delimit Scope field_scope with field.
Delimit Scope module_scope with module.

Reserved Notation "x '==' y" (at level 70, no associativity).
Notation "x '==' y" := (eqv x y) : type_scope.
Notation "x '+' y" := (add x y) : field_scope.
Notation "'0'" := zero : field_scope.
Notation "'-' x" := (neg x) : field_scope.
Notation "x '-' y" := (add x (neg y)) : field_scope.
Notation "x '*' y" := (mul x y) : field_scope.
Notation "'1'" := one : field_scope.
Notation "'/' x" := (recip x) : field_scope.
Notation "x '/' y" := (mul x (recip y)) : field_scope.
Reserved Notation "a '<*' x" (at level 45, left associativity).
Notation "a '<*' x" := (lsmul a x) : module_scope.
Reserved Notation "x '*>' a" (at level 45, left associativity).
Notation "x '*>' a" := (rsmul a x) : module_scope.

Module AdditiveNotations.

Notation "x '+' y" := (opr x y) : group_scope.
Notation "'0'" := idn : group_scope.
Notation "'-' x" := (inv x) : group_scope.
Notation "x '-' y" := (opr x (inv y)) : group_scope.

End AdditiveNotations.

Module MultiplicativeNotations.

Notation "x '*' y" := (opr x y) : group_scope.
Notation "'1'" := idn : group_scope.
Notation "'/' x" := (inv x) : group_scope.
Notation "x '/' y" := (opr x (inv y)) : group_scope.

End MultiplicativeNotations.

Class Setoid (A : Type) {eqv : Eqv A} : Prop := {
  ref : forall x : A, x == x;
  sym : forall x y : A, x == y -> y == x;
  tra : forall x y z : A, x == y -> y == z -> x == z;
}.

Section Additive.

Import AdditiveNotations.

Open Scope signature_scope.
Open Scope group_scope.

Class Semigroup (A : Type) {eqv : Eqv A} {opr : Opr A} : Prop := {
  setoid :> Setoid A;
  opr_pro : opr ::> eqv ==> eqv ==> eqv;
  ass : forall x y z : A, (x + y) + z == x + (y + z);
}.

Class Monoid (A : Type) {eqv : Eqv A} {opr : Opr A} {idn : Idn A} : Prop := {
  semigroup :> Semigroup A;
  idn_l : forall x : A, 0 + x == x;
  idn_r : forall x : A, x + 0 == x;
}.

Class Group (A : Type) {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} : Prop := {
  monoid :> Monoid A;
  inv_pro : inv ::> eqv ==> eqv;
  inv_l : forall x : A, (- x) + x == 0;
  inv_r : forall x : A, x + (- x) == 0;
}.

Class AbelianGroup (A : Type) {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} : Prop := {
  group :> Group A;
  add_com : forall x y : A, x + y == y + x;
}.

End Additive.

Section Arbitrary.

Open Scope field_scope.

Class Ring (A : Type) {eqv : Eqv A} {add : Add A} {zero : Zero A} {neg : Neg A}
  {mul : Mul A} {one : One A} : Prop := {
  add_agroup :> AbelianGroup A (opr := add) (idn := zero) (inv := neg);
  mul_monoid :> Monoid A (opr := mul) (idn := one);
  dis_l : forall x y z : A, x * (y + z) == x * y + x * z;
  dis_r : forall x y z : A, (x + y) * z == x * z + y * z;
}.

End Arbitrary.

Section Additive.

Import AdditiveNotations.

Open Scope signature_scope.
Open Scope module_scope.
Open Scope field_scope.
Open Scope group_scope.

Class LeftModule (S A : Type)
  {seqv : Eqv S} {sadd : Add S} {szero : Zero S} {sneg : Neg S}
  {smul : Mul S} {sone : One S}
  {eqv : Eqv A} {opr : Opr A} {idn : Idn A} {inv : Inv A}
  {lsmul : LSMul S A} : Prop := {
  lsring :> Ring S (add := sadd) (zero := szero) (neg := sneg)
    (mul := smul) (one := sone);
  lagroup :> AbelianGroup A (opr := opr) (idn := idn) (inv := inv);
  lsmul_pro : lsmul ::> seqv ==> eqv ==> eqv;
  lsmul_smul_cpt : forall (a b : S) (x : A), (a * b) <* x == a <* (b <* x);
  lsmul_idn : forall x : A, 1 <* x == x;
  lsmul_add_dis : forall (a : S) (x y : A), a <* (x + y) == a <* x + a <* y;
  lsmul_sadd_dis : forall (a b : S) (x : A),
    (a + b)%field <* x == a <* x + b <* x;
}.

Class RightModule (S A : Type)
  {seqv : Eqv S} {sadd : Add S} {szero : Zero S} {sneg : Neg S}
  {smul : Mul S} {sone : One S}
  {eqv : Eqv A} {opr : Opr A} {idn : Idn A} {inv : Inv A}
  {rsmul : RSMul S A} : Prop := {
  rsring :> Ring S (add := sadd) (zero := szero) (neg := sneg)
    (mul := smul) (one := sone);
  ragroup :> AbelianGroup A (opr := opr) (idn := idn) (inv := inv);
  rsmul_pro : rsmul ::> seqv ==> eqv ==> eqv;
  rsmul_smul_cpt : forall (a b : S) (x : A), x *> (a * b) == (x *> a) *> b;
  rsmul_idn : forall x : A, x *> 1 == x;
  rsmul_add_dis : forall (a : S) (x y : A), (x + y) *> a == x *> a + y *> a;
  rsmul_sadd_dis : forall (a b : S) (x : A),
    x *> (a + b)%field == x *> a + x *> b;
}.

Class Bimodule (LS RS A : Type)
  {lseqv : Eqv LS} {lsadd : Add LS} {lszero : Zero LS} {lsneg : Neg LS}
  {lsmul : Mul LS} {lsone : One LS}
  {rseqv : Eqv RS} {rsadd : Add RS} {rszero : Zero RS} {rsneg : Neg RS}
  {rsmul : Mul RS} {rsone : One RS}
  {eqv : Eqv A} {opr : Opr A} {idn : Idn A} {inv : Inv A}
  {lsmul : LSMul LS A} {rsmul : RSMul RS A} : Prop := {
  lmodule :> LeftModule LS A;
  rmodule :> RightModule RS A;
  smul_cpt : forall (a : LS) (b : RS) (x : A), (a <* x) *> b == a <* (x *> b);
}.

Class HomoBimodule (S A : Type)
  {seqv : Eqv S} {sadd : Add S} {szero : Zero S} {sneg : Neg S}
  {smul : Mul S} {sone : One S}
  {eqv : Eqv A} {opr : Opr A} {idn : Idn A} {inv : Inv A}
  {lsmul : LSMul S A} {lsmul : RSMul S A} : Prop := {
  bimodule :> Bimodule S S A;
}.

End Additive.

Add Parametric Relation {A : Type} {eqv' : Eqv A}
  {std' : Setoid A} : A eqv
  reflexivity proved by ref
  symmetry proved by sym
  transitivity proved by tra
  as eqv_relation.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {opr' : Opr A} {sgr' : Semigroup A} : opr
  with signature eqv ==> eqv ==> eqv
  as eqv_opr_morphism.
Proof.
  intros x y p z w q.
  destruct sgr' as [_ opr_pro _].
  cbv in opr_pro. apply opr_pro.
  - apply p.
  - apply q. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {opr' : Opr A} {idn' : Idn A} {inv' : Inv A} {grp' : Group A} : inv
  with signature eqv ==> eqv
  as eqv_inv_morphism.
Proof.
  intros x y p.
  destruct grp' as [_ inv_pro _ _].
  cbv in inv_pro. apply inv_pro. apply p. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {add' : Add A} {zero' : Zero A} {neg' : Neg A}
  {mul' : Mul A} {one' : One A} {rng' : Ring A} : add
  with signature eqv ==> eqv ==> eqv
  as eqv_add_morphism.
Proof.
  intros x y p z w q.
  destruct rng' as [[[[[_ add_pro _] _ _] _ _ _] _] _ _ _].
  cbv in add_pro. apply add_pro.
  - apply p.
  - apply q. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {add' : Add A} {zero' : Zero A} {neg' : Neg A}
  {mul' : Mul A} {one' : One A} {rng' : Ring A} : neg
  with signature eqv ==> eqv
  as eqv_neg_morphism.
Proof.
  intros x y p.
  destruct rng' as [[[[_ _ _] neg_pro _ _] _] _ _ _].
  cbv in neg_pro. apply neg_pro. apply p. Qed.

Add Parametric Morphism {A : Type} {eqv' : Eqv A}
  {add' : Add A} {zero' : Zero A} {neg' : Neg A}
  {mul' : Mul A} {one' : One A} {rng' : Ring A} : mul
  with signature eqv ==> eqv ==> eqv
  as eqv_mul_morphism.
Proof.
  intros x y p z w q.
  destruct rng' as [_ [[_ mul_pro _] _ _] _ _].
  cbv in mul_pro. apply mul_pro.
  - apply p.
  - apply q. Qed.

Add Parametric Morphism {S A : Type}
  {seqv' : Eqv S} {sadd' : Add S} {szero' : Zero S} {sneg' : Neg S}
  {smul' : Mul S} {sone' : One S}
  {eqv' : Eqv A} {opr' : Opr A} {idn' : Idn A} {inv' : Inv A}
  {lsmul' : LSMul S A} {lmod' : LeftModule S A} : lsmul
  with signature eqv ==> eqv ==> eqv
  as eqv_lsmul_morphism.
Proof.
  intros x y p z w q.
  destruct lmod' as [_ _ lsmul_pro _ _ _ _].
  cbv in lsmul_pro. apply lsmul_pro.
  - apply p.
  - apply q. Qed.

Add Parametric Morphism {S A : Type}
  {seqv' : Eqv S} {sadd' : Add S} {szero' : Zero S} {sneg' : Neg S}
  {smul' : Mul S} {sone' : One S}
  {eqv' : Eqv A} {opr' : Opr A} {idn' : Idn A} {inv' : Inv A}
  {rsmul' : RSMul S A} {rmod' : RightModule S A} : rsmul
  with signature eqv ==> eqv ==> eqv
  as eqv_rsmul_morphism.
Proof.
  intros x y p z w q.
  destruct rmod' as [_ _ rsmul_pro _ _ _ _].
  cbv in rsmul_pro. apply rsmul_pro.
  - apply p.
  - apply q. Qed.

End Classes.

Module Properties.

Import Classes AdditiveNotations.

Open Scope group_scope.

Theorem ivl : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x : A, - (- x) == x.
Proof.
  intros A eqv opr idn inv grp x.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnr (- (- x))). rewrite <- (pvl x).
  rewrite <- (pa (- (- x)) (- x) x). rewrite (pvl (- x)). rewrite (pnl x).
  reflexivity. Qed.

Lemma inj_l : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, z + x == z + y -> x == y.
Proof.
  intros A eqv opr idn inv grp x y z p.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnl x). rewrite <- (pvl z). rewrite (pa (- z) z x).
  rewrite p. rewrite <- (pa (- z) z y). rewrite (pvl z). rewrite (pnl y).
  reflexivity. Qed.

Lemma inj_r : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y z : A, x + z == y + z -> x == y.
Proof.
  intros A eqv opr idn inv grp x y z p.
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite <- (pnr x). rewrite <- (pvr z). rewrite <- (pa x z (- z)).
  rewrite p. rewrite (pa y z (- z)). rewrite (pvr z). rewrite (pnr y).
  reflexivity. Qed.

Theorem dis : forall {A : Type} {eqv : Eqv A}
  {opr : Opr A} {idn : Idn A} {inv : Inv A} {grp : Group A},
  forall x y : A, - (y + x) == (- x) + (- y).
Proof.
  intros A eqv opr idn inv grp x y.
  apply (inj_l (- (y + x)) ((- x) + (- y)) (y + x)).
  destruct grp as [[[ps pop pa] pnl pnr] pvp pvl pvr] eqn : pg.
  rewrite (pvr (y + x)). rewrite <- (pa (y + x) (- x) (- y)).
  rewrite (pa y x (- x)). rewrite (pvr x). rewrite (pnr y). rewrite (pvr y).
  reflexivity. Qed.

End Properties.

Module Instances.

Import ZArith Z Classes.

Open Scope Z_scope.

Instance Z_Eqv : Eqv Z := fun x y : Z => x = y.

Instance Z_Setoid : Setoid Z := {
  ref := _;
  sym := _;
  tra := _;
}.
Proof.
  all: cbv [eqv].
  all: cbv [Z_Eqv].
  - apply eq_refl.
  - apply eq_sym.
  - apply eq_trans. Qed.

Instance Z_MulOpr : Opr Z := fun x y : Z => x * y.

Instance Z_MulSemigroup : Semigroup Z := {
  opr_pro := _;
  ass := _;
}.
Proof.
  all: cbv [eqv opr].
  all: cbv [Z_Eqv Z_MulOpr].
  - apply mul_wd.
  - intros x y z. rewrite mul_assoc. reflexivity. Qed.

Instance Z_MulIdn : Idn Z := 1.

Instance Z_MulMonoid : Monoid Z := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [eqv opr idn].
  all: cbv [Z_Eqv Z_MulOpr Z_MulIdn].
  - intros x. rewrite mul_1_l. reflexivity.
  - intros x. rewrite mul_1_r. reflexivity. Qed.

Instance Z_AddOpr : Opr Z := fun x y : Z => x + y.

Instance Z_AddSemigroup : Semigroup Z := {
  opr_pro := _;
  ass := _;
}.
Proof.
  all: cbv [eqv opr].
  all: cbv [Z_Eqv Z_AddOpr].
  - apply add_wd.
  - intros x y z. rewrite add_assoc. reflexivity. Qed.

Instance Z_AddIdn : Idn Z := 0.

Instance Z_AddMonoid : Monoid Z := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [eqv opr idn].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn].
  - intros x. rewrite add_0_l. reflexivity.
  - intros x. rewrite add_0_r. reflexivity. Qed.

Instance Z_AddInv : Inv Z := fun x => - x.

Instance Z_AddGroup : Group Z := {
  inv_pro := _;
  inv_l := _; inv_r := _;
}.
Proof.
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv].
  - apply opp_wd.
  - intros x. rewrite add_opp_diag_l. reflexivity.
  - intros x. rewrite add_opp_diag_r. reflexivity. Qed.

Instance Z_AddAbelianGroup : AbelianGroup Z := {
  add_com := _;
}.
Proof.
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv].
  - intros x y. rewrite add_comm. reflexivity. Qed.

Instance Z_Add : Add Z := Z_AddOpr.
Instance Z_Zero : Zero Z := Z_AddIdn.
Instance Z_Neg : Neg Z := Z_AddInv.
Instance Z_Mul : Mul Z := Z_MulOpr.
Instance Z_One : One Z := Z_MulIdn.

Instance Z_Ring : Ring Z := {
  dis_l := _; dis_r := _;
}.
Proof.
  all: cbv [eqv add zero neg mul one].
  all: cbv [Z_Eqv Z_Add Z_Zero Z_Neg Z_Mul Z_One].
  all: cbv [eqv add zero neg mul one].
  all: cbv [Z_AddOpr Z_AddIdn Z_AddInv Z_MulOpr Z_MulIdn].
  - intros x y z. rewrite mul_add_distr_l. reflexivity.
  - intros x y z. rewrite mul_add_distr_r. reflexivity. Qed.

Import Vector VectorNotations.

Section VectorLemmas.

Import Eqdep_dec PeanoNat.

Lemma case_nil : forall {A : Type} (xs : t A O),
  xs = [].
Proof.
  intros A xs. set (P (xs : t A O) := xs = []).
  apply (case0 P). reflexivity. Qed.

Lemma case_cons : forall {A : Type} {n : nat} (xs : t A (S n)),
  exists (y : A) (ys : t A n), xs = y :: ys.
Proof.
  intros A n xs. set (P (n : nat) (xs : t A (S n)) :=
    exists (y : A) (ys : t A n), xs = y :: ys).
  apply (caseS P). intros y p ys. exists y, ys. reflexivity. Qed.

Lemma Forall2_inversion : forall {A B : Type} (f : A -> B -> Prop)
  {n : nat} (x : A) (xs : t A n) (y : B) (ys : t B n),
  Forall2 f (x :: xs) (y :: ys) -> f x y /\ Forall2 f xs ys.
Proof.
  intros A B f n x xs y ys p.
  inversion p as [| n' x' y' xs' ys' phd ptl pn' [px' pxs'] [py' pys']].
  apply (inj_pair2_eq_dec nat Nat.eq_dec) in pxs'.
  apply (inj_pair2_eq_dec nat Nat.eq_dec) in pys'.
  subst. split.
  - apply phd.
  - apply ptl. Qed.

End VectorLemmas.

Instance Z_VectorEqv {n : nat} : Eqv (t Z n) := Forall2 eqv.

(** There exists an easier way to carry out these proofs
    by first showing that [Forall2 eq] is equivalent to [eq],
    but we pretend this is not the case here. *)

Instance Z_VectorSetoid {n : nat} : Setoid (t Z n) := {
  ref := _;
  sym := _;
  tra := _;
}.
Proof.
  all: cbv [eqv].
  all: cbv [Z_VectorEqv].
  all: cbv [Z_Eqv].
  all: set (P (x y : Z) := x = y).
  - intros xs. induction n as [| n p].
    + pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs. apply Forall2_cons.
      * reflexivity.
      * apply p.
  - intros xs ys. induction n as [| n p].
    + intros q.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      subst. apply Forall2_nil.
    + intros q.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys.
      apply Forall2_inversion in q. destruct q as [qhd qtl].
      apply Forall2_cons.
      * symmetry. apply qhd.
      * apply p. apply qtl.
  - intros xs ys zs. induction n as [| n p].
    + intros q r.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      pose proof case_nil zs as pzs'.
      subst. apply Forall2_nil.
    + intros q r.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      pose proof case_cons zs as pzs'. destruct pzs' as [z' [zs' pzs']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys,
        z' into z, zs' into zs.
      apply Forall2_inversion in q. destruct q as [qhd qtl].
      apply Forall2_inversion in r. destruct r as [rhd rtl].
      apply Forall2_cons.
      * etransitivity.
        -- apply qhd.
        -- apply rhd.
      * eapply p.
        -- apply qtl.
        -- apply rtl. Qed.

Instance Z_VectorOpr {n : nat} : Opr (t Z n) := map2 Z_AddOpr.

Instance Z_VectorSemigroup {n : nat} : Semigroup (t Z n) := {
  opr_pro := _;
  ass := _;
}.
Proof.
  all: cbv [eqv opr].
  all: cbv [Z_VectorEqv Z_VectorOpr].
  all: cbv [Z_Eqv Z_AddOpr].
  all: set (P (x y : Z) := x = y).
  - induction n as [| n p].
    + intros xs ys q zs ws r.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      pose proof case_nil zs as pzs'.
      pose proof case_nil ws as pws'.
      subst. apply Forall2_nil.
    + intros xs ys q zs ws r.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      pose proof case_cons zs as pzs'. destruct pzs' as [z' [zs' pzs']].
      pose proof case_cons ws as pws'. destruct pws' as [w' [ws' pws']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys,
        z' into z, zs' into zs, w' into w, ws' into ws.
      apply Forall2_inversion in q. destruct q as [qhd qtl].
      apply Forall2_inversion in r. destruct r as [rhd rtl].
      cbn -[Z.add]. apply Forall2_cons.
      * apply add_wd.
        -- apply qhd.
        -- apply rhd.
      * apply p.
        -- apply qtl.
        -- apply rtl.
  - induction n as [| n p].
    + intros xs ys zs.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      pose proof case_nil zs as pzs'.
      subst. apply Forall2_nil.
    + intros xs ys zs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      pose proof case_cons zs as pzs'. destruct pzs' as [z' [zs' pzs']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys,
        z' into z, zs' into zs.
      cbn -[Z.add]. apply Forall2_cons.
      * cbv -[Z.add]. rewrite add_assoc. reflexivity.
      * apply p. Qed.

Instance Z_VectorIdn {n : nat} : Idn (t Z n) := const Z_AddIdn n.

Instance Z_VectorMonoid {n : nat} : Monoid (t Z n) := {
  idn_l := _; idn_r := _;
}.
Proof.
  all: cbv [eqv opr idn].
  all: cbv [Z_VectorEqv Z_VectorOpr Z_VectorIdn].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn].
  all: set (P (x y : Z) := x = y).
  - induction n as [| n p].
    + intros xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.add Z.zero]. apply Forall2_cons.
      * rewrite add_0_l. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.add Z.zero]. apply Forall2_cons.
      * rewrite add_0_r. reflexivity.
      * apply p. Qed.

Instance Z_VectorInv {n : nat} : Inv (t Z n) := map Z_AddInv.

Instance Z_VectorGroup {n : nat} : Group (t Z n) := {
  inv_pro := _;
  inv_l := _; inv_r := _;
}.
Proof.
  all: cbv [eqv opr idn inv].
  all: cbv [Z_VectorEqv Z_VectorOpr Z_VectorIdn Z_VectorInv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv].
  all: set (P (x y : Z) := x = y).
  - induction n as [| n p].
    + intros xs ys q.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      subst. apply Forall2_nil.
    + intros xs ys q.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys.
      apply Forall2_inversion in q. destruct q as [qhd qtl].
      cbn -[Z.add Z.zero Z.opp]. apply Forall2_cons.
      * apply opp_wd. apply qhd.
      * apply p. apply qtl.
  - induction n as [| n p].
    + intros xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.add Z.zero Z.opp]. apply Forall2_cons.
      * cbv -[Z.add Z.zero Z.opp]. rewrite add_opp_diag_l. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.add Z.zero Z.opp]. apply Forall2_cons.
      * cbv -[Z.add Z.zero Z.opp]. rewrite add_opp_diag_r. reflexivity.
      * apply p. Qed.

Instance Z_VectorAbelianGroup {n : nat} : AbelianGroup (t Z n) := {
  add_com := _;
}.
Proof.
  all: cbv [eqv opr idn inv].
  all: cbv [Z_VectorEqv Z_VectorOpr Z_VectorIdn Z_VectorInv].
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv].
  all: set (P (x y : Z) := x = y).
  - induction n as [| n p].
    + intros xs ys.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      subst. apply Forall2_nil.
    + intros xs ys.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys.
      cbn -[Z.add Z.zero Z.opp]. apply Forall2_cons.
      * cbn -[Z.add Z.zero Z.opp]. rewrite add_comm. reflexivity.
      * apply p. Qed.

Instance Z_LSMul {n : nat} : LSMul Z (t Z n) :=
  fun a : Z => map (fun x : Z => a * x).

Instance Z_LeftModule {n : nat} : LeftModule Z (t Z n) := {
  lsmul_pro := _;
  lsmul_smul_cpt := _;
  lsmul_idn := _;
  lsmul_add_dis := _;
  lsmul_sadd_dis := _;
}.
Proof.
  all: cbv [eqv opr idn inv lsmul].
  all: cbv [Z_VectorEqv Z_VectorOpr Z_VectorIdn Z_VectorInv Z_LSMul].
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv Z_MulOpr Z_MulIdn].
  all: set (P (x y : Z) := x = y).
  - induction n as [| n p].
    + intros a b q xs ys r.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      subst. apply Forall2_nil.
    + intros a b q xs ys r.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys.
      apply Forall2_inversion in r. destruct r as [rhd rtl].
      cbn -[Z.mul Z.one]. apply Forall2_cons.
      * apply mul_wd.
        -- apply q.
        -- apply rhd.
      * apply p.
        -- apply q.
        -- apply rtl.
  - induction n as [| n p].
    + intros a b xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros a b xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.mul Z.one]. apply Forall2_cons.
      * cbv -[Z.mul Z.one]. rewrite mul_assoc. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.mul Z.one]. apply Forall2_cons.
      * cbv -[Z.mul Z.one]. rewrite mul_1_l. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros a xs ys.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      subst. apply Forall2_nil.
    + intros a xs ys.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys.
      cbn -[Z.add Z.zero Z.opp Z.mul Z.one]. apply Forall2_cons.
      * cbn -[Z.add Z.zero Z.opp Z.mul Z.one].
        rewrite mul_add_distr_l. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros a b xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros a b xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.add Z.zero Z.opp Z.mul Z.one]. apply Forall2_cons.
      * cbn -[Z.add Z.zero Z.opp Z.mul Z.one].
        rewrite mul_add_distr_r. reflexivity.
      * apply p. Qed.

Instance Z_RSMul {n : nat} : RSMul Z (t Z n) :=
  fun a : Z => map (fun x : Z => x * a).

Instance Z_RightModule {n : nat} : RightModule Z (t Z n) := {
  rsmul_pro := _;
  rsmul_smul_cpt := _;
  rsmul_idn := _;
  rsmul_add_dis := _;
  rsmul_sadd_dis := _;
}.
Proof.
  all: cbv [eqv opr idn inv rsmul].
  all: cbv [Z_VectorEqv Z_VectorOpr Z_VectorIdn Z_VectorInv Z_RSMul].
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv Z_MulOpr Z_MulIdn].
  all: set (P (x y : Z) := x = y).
  - induction n as [| n p].
    + intros a b q xs ys r.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      subst. apply Forall2_nil.
    + intros a b q xs ys r.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys.
      apply Forall2_inversion in r. destruct r as [rhd rtl].
      cbn -[Z.mul Z.one]. apply Forall2_cons.
      * apply mul_wd.
        -- apply rhd.
        -- apply q.
      * apply p.
        -- apply q.
        -- apply rtl.
  - induction n as [| n p].
    + intros a b xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros a b xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.mul Z.one]. apply Forall2_cons.
      * cbv -[Z.mul Z.one]. rewrite mul_assoc. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.mul Z.one]. apply Forall2_cons.
      * cbv -[Z.mul Z.one]. rewrite mul_1_r. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros a xs ys.
      pose proof case_nil xs as pxs'.
      pose proof case_nil ys as pys'.
      subst. apply Forall2_nil.
    + intros a xs ys.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      pose proof case_cons ys as pys'. destruct pys' as [y' [ys' pys']].
      subst; rename x' into x, xs' into xs, y' into y, ys' into ys.
      cbn -[Z.add Z.zero Z.opp Z.mul Z.one]. apply Forall2_cons.
      * cbn -[Z.add Z.zero Z.opp Z.mul Z.one].
        rewrite mul_add_distr_r. reflexivity.
      * apply p.
  - induction n as [| n p].
    + intros a b xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros a b xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.add Z.zero Z.opp Z.mul Z.one]. apply Forall2_cons.
      * cbn -[Z.add Z.zero Z.opp Z.mul Z.one].
        rewrite mul_add_distr_l. reflexivity.
      * apply p. Qed.

Instance Z_Bimodule {n : nat} : Bimodule Z Z (t Z n) := {
  smul_cpt := _;
}.
Proof.
  all: cbv [eqv opr idn inv lsmul rsmul].
  all: cbv [Z_VectorEqv Z_VectorOpr Z_VectorIdn Z_VectorInv Z_LSMul Z_RSMul].
  all: cbv [eqv opr idn inv].
  all: cbv [Z_Eqv Z_AddOpr Z_AddIdn Z_AddInv Z_MulOpr Z_MulIdn].
  all: set (P (x y : Z) := x = y).
  - induction n as [| n p].
    + intros a b xs.
      pose proof case_nil xs as pxs'.
      subst. apply Forall2_nil.
    + intros a b xs.
      pose proof case_cons xs as pxs'. destruct pxs' as [x' [xs' pxs']].
      subst; rename x' into x, xs' into xs.
      cbn -[Z.mul Z.one]. apply Forall2_cons.
      * cbv -[Z.mul Z.one]. rewrite mul_assoc. reflexivity.
      * apply p. Qed.

Instance Z_HomoBimodule {n : nat} : HomoBimodule Z (t Z n) := {}.

End Instances.

Module Computations.

Section Input.

Import Vector VectorNotations ZArith Z.

Open Scope Z_scope.

Definition meaning := 42.
Definition luck := [13; 31].
Definition fortune := 7.
Definition hope := [69; 96].

End Input.

Section Output.

Import Classes AdditiveNotations.

Open Scope module_scope.
Open Scope field_scope.
Open Scope group_scope.

Example fate := (meaning * fortune) <* hope - luck *> one.

End Output.

Section Test.

Import Vector VectorNotations ZArith Z.

Open Scope Z_scope.

Compute if Vector.eq_dec _ eqb _ _ fate [20273; 28193] then true else false.

End Test.

End Computations.

Extraction "example.ml" Classes Properties Instances Computations.