(* Full safety for STLC *)

(* copied from nano0.v *)

(* This version prohibits recursion, and we prove that   *)
(* evaluation always terminates with a well-typed value. *)
(* From this follows both type soundness and strong      *)
(* normalization for STLC.                               *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
| vbool : bool -> vl
| vabs  : list vl -> tm -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint length {X: Type} (l : list X): nat :=
  match l with
    | [] => 0
    | _::l' => 1 + length l'
  end.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
           has_type env ttrue TBool
| t_false: forall env,
           has_type env tfalse TBool
| t_var: forall x env T1,
           index x env = Some T1 ->
           has_type env (tvar x) T1
| t_app: forall env f x T1 T2,
           has_type env f (TFun T1 T2) ->
           has_type env x T1 ->
           has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
           has_type (T1::env) y T2 ->
           has_type env (tabs y) (TFun T1 T2)
.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
*)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs y     => Some (Some (vabs env y))
        | tapp ef ex   =>
          match teval n env ef with
            | None => None
            | Some None => Some None
            | Some (Some (vbool _)) => Some None
            | Some (Some (vabs env2 ey)) =>
              match teval n env ex with
                | None => None
                | Some None => Some None
                | Some (Some vx) =>
                  teval n (vx::env2) ey
              end
          end
      end
  end.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

(* need to use Fixpoint because of positivity restriction *)
Fixpoint val_type (v:vl) (T:ty): Prop := match v, T with
| vbool b, TBool => True
| vabs env y, TFun T1 T2 =>
  (forall vx, val_type vx T1 ->
     exists v, tevaln (vx::env) y v /\ val_type v T2)
| _,_ => False
end.

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : wf_env nil nil
| wfe_cons : forall v t vs ts,
    val_type v t ->
    wf_env vs ts ->
    wf_env (cons v vs) (cons t ts)
.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
(* Hint Constructors val_type. *)
Hint Constructors wf_env.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

Lemma wf_length : forall vs ts,
                    wf_env vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_env in H1. auto.
Qed.

Hint Immediate wf_length.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto.  eauto.
Qed.

Lemma invert_abs: forall vf T1 T2,
  val_type vf (TFun T1 T2) ->
  exists env y,
    vf = (vabs env y) /\
    (forall vx, val_type vx T1 ->
       exists v, tevaln (vx::env) y v /\ val_type v T2).
Proof.
  intros. simpl in H. destruct vf. inversion H. eauto.
Qed.

(* if well-typed, then result is an actual value (not stuck and not a timeout),
   for large enough n *)

Theorem full_total_safety : forall e tenv T,
  has_type tenv e T -> forall venv, wf_env venv tenv ->
  exists v, tevaln venv e v /\ val_type v T.

Proof.
  intros ? ? ? W.
  induction W; intros ? WFE.

  - Case "True". eexists. split.
    exists 0. intros. destruct n. omega. simpl. eauto. simpl. eauto.
  - Case "False". eexists. split.
    exists 0. intros. destruct n. omega. simpl. eauto. simpl. eauto.

  - Case "Var".
    destruct (index_safe_ex venv0 env T1 x) as [v IV]. eauto. eauto.
    inversion IV as [I V].

    exists v. split. exists 0. intros. destruct n. omega. simpl. rewrite I. eauto. eapply V.

  - Case "App".
    destruct (IHW1 venv0 WFE) as [vf [IW1 HVF]].
    destruct (IHW2 venv0 WFE) as [vx [IW2 HVX]].

    eapply invert_abs in HVF.
    destruct HVF as [venv1 [y [HF IHF]]].

    destruct (IHF vx HVX) as [vy [IW3 HVY]].

    exists vy. split. {
      (* pick large enough n. nf+nx+ny will do. *)
      destruct IW1 as [nf IWF].
      destruct IW2 as [nx IWX].
      destruct IW3 as [ny IWY].
      exists (S (nf+nx+ny)). intros. destruct n. omega. simpl.
      rewrite IWF. subst vf. rewrite IWX. rewrite IWY. eauto.
      omega. omega. omega.
    }
    eapply HVY.

  - Case "Abs".
    eexists. split. exists 0. intros. destruct n. omega. simpl. eauto. simpl.
    intros. eapply IHW. eapply wfe_cons; eauto.
Qed.

End STLC.


(**************************************************************************************************
* Preservation and Progress for System-F kernel with Subtyping                                      *
* 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 pre-types *)

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

(** Representation of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : typ -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_tabs : typ -> 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_top         => typ_top
  | 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_all T1 T2   => typ_all (open_tt_rec K U T1) (open_tt_rec (S K) U T2)
  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_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | 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 V e1 => trm_tabs (open_tt_rec K U V)  (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_bvar i    => If k = i then f else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | 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 V e1 => trm_tabs V (open_ee_rec k f e1)
  | trm_tapp e1 V => trm_tapp (open_ee_rec k f e1) V
  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_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 T1 T2,
      type T1 ->
      (forall X, X \notin L -> type (T2 open_tt_var X)) ->
      type (typ_all T1 T2).

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

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | 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 V e1,
      type V ->
      (forall X, X \notin L -> term (e1 open_te_var X)) ->
      term (trm_tabs V e1)
  | term_tapp : forall e1 V,
      term e1 ->
      type V ->
      term (trm_tapp e1 V).

(** Binding are either mapping type or term variables.
 [X ~<: T] is a subtyping asumption and [x ~: T] is
 a typing assumption *)

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

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

(** Environment is an associative list of bindings. *)

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 U E X,
      binds X (bind_sub U) E ->
      wft E (typ_fvar X)
  | wft_arrow : forall E T1 T2,
      wft E T1 ->
      wft E T2 ->
      wft E (typ_arrow T1 T2)
  | wft_all : forall L E T1 T2,
      wft E T1 ->
      (forall X, X \notin L ->
        wft (E & X ~<: T1) (T2 open_tt_var X)) ->
      wft E (typ_all T1 T2).

(** A environment E is well-formed if it contains no duplicate bindings
  and if each type in it is well-formed with respect to the environment
  it is pushed on to. *)

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

(** Subtyping relation *)

Inductive sub : env -> typ -> typ -> Prop :=
  | sub_top : forall E S,
      okt E ->
      wft E S ->
      sub E S typ_top
  | sub_refl_tvar : forall E X,
      okt E ->
      wft E (typ_fvar X) ->
      sub E (typ_fvar X) (typ_fvar X)
  | sub_trans_tvar : forall U E T X,
      binds X (bind_sub U) E ->
      sub E U T ->
      sub E (typ_fvar X) T
  | sub_arrow : forall E S1 S2 T1 T2,
      sub E T1 S1 ->
      sub E S2 T2 ->
      sub E (typ_arrow S1 S2) (typ_arrow T1 T2)
  | sub_all : forall L E T1 T2 T3,
      (forall X, X \notin L ->
          sub (E & X ~<: T1) (T2 open_tt_var X) (T3 open_tt_var X)) ->
      sub E (typ_all T1 T2) (typ_all T1 T3).

(** Typing relation *)

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      okt E ->
      binds x (bind_typ T) E ->
      typing E (trm_fvar x) T
  | 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 V e1 T1,
      (forall X, X \notin L ->
        typing (E & X ~<: V) (e1 open_te_var X) (T1 open_tt_var X)) ->
      typing E (trm_tabs V e1) (typ_all V T1)
  | typing_tapp : forall T1 E e1 T T2,
      typing E e1 (typ_all T1 T2) ->
      sub E T T1 ->
      typing E (trm_tapp e1 T) (open_tt T2 T)
  | typing_sub : forall S E e T,
      typing E e S ->
      sub E S T ->
      typing E e T.

(** Values *)

Inductive value : trm -> Prop :=
  | value_abs  : forall V e1, term (trm_abs V e1) ->
                 value (trm_abs V e1)
  | value_tabs : forall V e1, term (trm_tabs V e1) ->
                 value (trm_tabs V e1).

(** 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_tapp : forall e1 e1' V,
      type V ->
      red e1 e1' ->
      red (trm_tapp e1 V) (trm_tapp e1' V)
  | 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_tabs : forall V1 e1 V2,
      term (trm_tabs V1 e1) ->
      type V2 ->
      red (trm_tapp (trm_tabs V1 e1) V2) (open_te e1 V2).

(** 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'.

(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Infrastructure   *
* Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1                 *
***************************************************************************)

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

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

Fixpoint fv_tt (T : typ) {struct T} : vars :=
  match T with
  | typ_top         => \{}
  | typ_bvar J      => \{}
  | typ_fvar X      => \{X}
  | typ_arrow T1 T2 => (fv_tt T1) \u (fv_tt T2)
  | typ_all 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_bvar i    => \{}
  | trm_fvar x    => \{}
  | trm_abs V e1  => (fv_tt V) \u (fv_te e1)
  | trm_app e1 e2 => (fv_te e1) \u (fv_te e2)
  | trm_tabs V e1 => (fv_tt V) \u (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_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs V e1  => (fv_ee e1)
  | trm_app e1 e2 => (fv_ee e1) \u (fv_ee e2)
  | trm_tabs V e1 => (fv_ee e1)
  | trm_tapp e1 V => (fv_ee e1)
  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_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_all T1 T2   => typ_all (subst_tt Z U T1) (subst_tt Z U T2)
  end.

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

Fixpoint subst_te (Z : var) (U : typ) (e : trm) {struct e} : trm :=
  match e with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => trm_fvar x
  | 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 V e1 => trm_tabs (subst_tt Z U V)  (subst_te Z U e1)
  | 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_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | 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 V e1 => trm_tabs V (subst_ee z u e1)
  | trm_tapp e1 V => trm_tapp (subst_ee z u e1) V
  end.

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

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

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

(** Constructors as hints. *)

Hint Constructors type term wft ok okt value red.

Hint Resolve
  sub_top sub_refl_tvar sub_arrow
  typing_var typing_app typing_tapp typing_sub.

(** 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
  | |- sub ?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 *)

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

(** 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 T2 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*.
  case_var*.
Qed.

(** 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.

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

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 U). apply* binds_weaken.
  (* case: all *)
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
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.
  induction H; intros F EQ; subst; auto.
  apply* (@wft_var U0). binds_cases H; try discriminate; autos*.
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
Qed.

(** Through type substitution *)

Lemma wft_subst_tb : forall F Q E Z P T,
  wft (E & Z ~<: Q & 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 ~<: Q & F). gen F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt; auto.
  case_var*.
    apply_empty* wft_weaken.
    binds_cases H.
      apply* wft_var.
      apply (@wft_var (subst_tt Z P U)). unsimpl_map_bind*.
  apply_fresh* wft_all as Y.
   unsimpl ((subst_tb Z P) (bind_sub T1)).
   lets: wft_type.
   rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(** Through type reduction *)

Lemma wft_open : forall E U T1 T2,
  ok E ->
  wft E (typ_all T1 T2) ->
  wft E U ->
  wft E (open_tt T2 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.
Qed.

(** Through narrowing *)

Lemma wft_narrow : forall V F U T E X,
  wft (E & X ~<: V & F) T ->
  ok (E & X ~<: U & F) ->
  wft (E & X ~<: U & F) T.
Proof.
  intros. gen_eq K: (E & X ~<: V & F). gen E F.
  induction H; intros; subst; eauto.
  destruct (binds_middle_inv H) as [K|[K|K]]; try destructs K.
    applys wft_var. apply* binds_concat_right.
    subst. applys wft_var. apply~ binds_middle_eq.
    applys wft_var. apply~ binds_concat_left.
     apply* binds_concat_left.
  apply_fresh* wft_all as Y. apply_ih_bind* H1.
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 subtyping 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 [[? ?]|[? ?]]. inversion H3.
       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.

Lemma wft_from_env_has_sub : forall x U E,
  okt E -> binds x (bind_sub 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 H3. apply_empty* wft_weaken.
       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.
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_from_okt_sub : 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 [? [? ?]]. inversions~ H4.
  destruct (eq_push_inv H0) as [? [? ?]]. false.
Qed.

(** Inversion lemma *)

Lemma okt_push_inv : forall E X B,
  okt (E & X ~ B) -> (exists T, B = bind_sub T) \/ 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 T,
  okt (E & X ~<: T) -> okt E /\ wft E T /\ 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_sub_type : forall E X T,
  okt (E & X ~<: T) -> type T.
Proof. intros. applys wft_type. forwards*: okt_push_tvr_inv. 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.

(** Automation *)

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 Immediate wft_from_env_has_sub wft_from_env_has_typ.
Hint Resolve wft_subst_tb.
Hint Resolve wft_from_okt_typ wft_from_okt_sub.

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

(** Through narrowing *)

Lemma okt_narrow : forall V E F U X,
  okt (E & X ~<: V & F) ->
  wft E U ->
  okt (E & X ~<: U & F).
Proof.
  introv O W. induction F using env_ind.
  rewrite concat_empty_r in *. lets*: (okt_push_tvr_inv O).
  rewrite concat_assoc in *.
   lets [(?&?)|(?&?)]: okt_push_inv O; subst.
     lets (?&?&?): (okt_push_tvr_inv O).
      applys~ okt_sub. applys* wft_narrow.
     lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. applys* wft_narrow.
Qed.

(** Through strengthening *)

Lemma okt_strengthen : forall x T E F,
  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.
     destruct H. subst.
     lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_sub. applys* wft_strengthen. destruct* H0.
    destruct H. subst. lets (?&?): (okt_push_typ_inv O).
    applys~ okt_typ. applys* wft_strengthen. 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; try destruct H; subst.
     lets (?&?): (okt_push_tvr_inv OKC). apply IHF. apply H.
      lets (?&?): (okt_push_typ_inv OKC). apply* IHF.
Qed.

(** Through type substitution *)

Lemma okt_subst_tb : forall Q Z P E F,
  okt (E & Z ~<: Q & 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; try destruct H; subst.
   lets (?&?): (okt_push_tvr_inv O).
      applys~ okt_sub. destruct* H0. autos*.
      lets (?&?&?): (okt_push_typ_inv O).
      applys~ okt_typ. apply* wft_subst_tb.
Qed.

(** Automation *)

Hint Resolve okt_narrow 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 IHT1 k. specializes IHT2 (S 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. 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* subst_tt_fresh. apply* notin_fv_wf.
  rewrite* <- IHokt. rewrite* subst_tt_fresh. apply* notin_fv_wf.
Qed.

(* ********************************************************************** *)
(** ** Regularity of relations *)

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

Lemma sub_regular : forall E S T,
  sub E S T -> okt E /\ wft E S /\ wft E T.
Proof.
  induction 1. autos*. autos*. autos*. autos*. (* Coq bug here? *)
  split.
  pick_fresh X.
  assert (X \notin L). eauto. destruct (H0 X H1).
    apply okt_push_tvr_inv in H2. autos*.
  split; apply_fresh* wft_all as Y.
  pick_fresh X.
  assert (X \notin L). eauto. destruct (H0 X H1).
    apply okt_push_tvr_inv in H2. autos*.
    destruct~ (H0 Y); apply_empty* (@wft_narrow T1).
  pick_fresh X.
  assert (X \notin L). eauto. destruct (H0 X H1).
    apply okt_push_tvr_inv in H2. autos*.
    destruct~ (H0 Y); apply_empty* (@wft_narrow T1).
Qed.

(** 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*.
   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. destruct H3.
      destruct H4. apply wft_type in H4. auto.
     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.
  destructs IHtyping1. inversion* H3.
   pick_fresh y. specializes H0 y. destructs~ H0.
    forwards*: okt_push_tvr_inv.
  apply term_tabs with (L:=L).
   pick_fresh X. destruct H0 with (X:=X).
  autos. apply okt_push_tvr_inv in H1. destruct H1. destruct H3.
  apply wft_type in H3. auto.
   intros.
      forwards~ K: (H0 X). 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.
  apply term_tapp; autos*. eapply wft_type. apply sub_regular in H0.
  destruct* H0.
  destruct IHtyping. destruct H2. inversion H3.  subst.
   applys* wft_open T1. apply sub_regular in H0. destruct* H0.
   apply sub_regular in H0. destruct* H0.
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: sub _ _ _ |- _ => apply (proj31 (sub_regular H))
  | H: typing _ _ _ |- _ => apply (proj31 (typing_regular H))
  end.

Hint Extern 1 (wft ?E ?T) =>
  match goal with
  | H: typing E _ T |- _ => apply (proj33 (typing_regular H))
  | H: sub E T _ |- _ => apply (proj32 (sub_regular H))
  | H: sub E _ T |- _ => apply (proj33 (sub_regular H))
  end.

Hint Extern 1 (type ?T) =>
  let go E := apply (@wft_type E); auto in
  match goal with
  | H: typing ?E _ T |- _ => go E
  | H: sub ?E T _ |- _ => go E
  | H: sub ?E _ T |- _ => go E
  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.

(***************************************************************************
* Preservation and Progress for System-F with Subtyping - Proofs           *
* Brian Aydemir & Arthur Charguéraud, March 2007, Coq v8.1                 *
***************************************************************************)

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

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

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

Lemma sub_reflexivity : forall E T,
  okt E ->
  wft E T ->
  sub E T T .
Proof.
  introv Ok WFT. lets W:(wft_type WFT). gen E.
  induction W; intros; inversions WFT; eauto.
  apply_fresh* sub_all as Y.
Qed.

(* ********************************************************************** *)
(** Weakening (2) *)

Lemma sub_weakening : forall E F G S T,
   sub (E & G) S T ->
   okt (E & F & G) ->
   sub (E & F & G) S T.
Proof.
  introv Typ. gen_eq H: (E & G). gen G.
  induction Typ; introv EQ Ok; subst; auto.
  (* case: fvar trans *)
  apply* sub_trans_tvar. apply* binds_weaken.
  (* case: all *)
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
  pick_fresh X.
  assert (X \notin L). eauto.
  eapply sub_regular in H; eauto. autos*.
Qed.

(* ********************************************************************** *)
(** Narrowing and transitivity (3) *)

Section NarrowTrans.

Definition transitivity_on Q := forall E S T,
  sub E S Q -> sub E Q T -> sub E S T.

Hint Unfold transitivity_on.

Hint Resolve wft_narrow.

Require Import Program.Equality.

Lemma Var_binds : forall E C X,
    sub E C (typ_fvar X) ->
    forall T, wft E T -> binds X (bind_sub T) E -> sub E C T.
  introv r.
  dependent induction r; intros; try (destruct m; inversion x; fail); eauto.
  + eapply sub_trans_tvar; eauto. apply sub_reflexivity; auto.
  + eapply sub_trans_tvar; eauto.
Defined.

Lemma sub_narrowing_aux : forall Q F E Z P S T,
  transitivity_on Q ->
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & Z ~<: P & F) S T.
Proof.
  introv TransQ SsubT PsubQ.
  gen_eq G: (E & Z ~<: Q & F). gen F.
  induction SsubT; introv EQ; subst.
  apply* sub_top.
  apply* sub_refl_tvar.
  tests EQ: (X = Z); subst.
    apply (@sub_trans_tvar P); autos* (@okt_narrow Q).
    apply binds_concat_left_ok; eauto.
      apply TransQ.
        do_rew* concat_assoc (apply_empty* sub_weakening).
        binds_get H. autos*.
    apply* (@sub_trans_tvar U).
    binds_cases H; auto.
  apply* sub_arrow.
  apply_fresh* sub_all as Y. apply_ih_bind* H0.
Qed.

Lemma sub_transitivity : forall Q,
  transitivity_on Q.
Proof.
  unfold transitivity_on.
  intros Q E S T SsubQ QsubT.
  assert (W : type Q) by auto.
  generalize dependent T.
  generalize dependent S.
  generalize dependent E.
  remember Q as Q' in |- *.
  generalize dependent Q'.
  induction W;
    intros Q' EQ E S SsubQ;
    induction SsubQ; try discriminate; inversion EQ; subst;
    intros T' QsubT;
    inversion QsubT; subst; eauto 4 using sub_trans_tvar.
  (*sub_all / sub_top*)
    assert (sub E (typ_all T1 T3) (typ_all T1 T2)).
      (*proof of assertion*)
      pick_fresh y; apply* sub_all...
    auto.
    (*sub_all / sub_all*)
  apply_fresh sub_all as X; autos*.
  lapply (H0 X); [ intros K | auto ];
  apply (K (T2 open_tt_var X)); auto.
Qed.

Lemma sub_narrowing : forall Q E F Z P S T,
  sub E P Q ->
  sub (E & Z ~<: Q & F) S T ->
  sub (E & Z ~<: P & F) S T.
Proof.
  intros.
  apply* sub_narrowing_aux.
  apply* sub_transitivity.
Qed.

End NarrowTrans.

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

Lemma sub_through_subst_tt : forall Q E F Z S T P,
  sub (E & Z ~<: Q & F) S T ->
  sub E P Q ->
  sub (E & map (subst_tb Z P) F) (subst_tt Z P S) (subst_tt Z P T).
Proof.
  introv SsubT PsubQ.
  gen_eq G: (E & Z ~<: Q & F). gen F.
  induction SsubT; introv EQ; subst; simpl subst_tt.
  apply* sub_top.
  case_var.
    apply* sub_reflexivity.
    apply* sub_reflexivity.
     inversions H0. binds_cases H3. (* wf *)
      apply* (@wft_var U).
      apply* (@wft_var (subst_tt Z P U)). unsimpl_map_bind*.
   case_var.
    apply (@sub_transitivity Q).
      apply_empty* sub_weakening.
      rewrite* <- (@subst_tt_fresh Z P Q).
        binds_get H. autos*.
        apply* (@notin_fv_wf E).
    apply* (@sub_trans_tvar (subst_tt Z P U)).
      rewrite* (@map_subst_tb_id E Z P).
        binds_cases H; unsimpl_map_bind*.
  apply* sub_arrow.
  apply_fresh* sub_all as X.
   unsimpl (subst_tb Z P (bind_sub T1)).
   do 2 rewrite* subst_tt_open_tt_var.
   apply_ih_map_bind* H0.
Qed.

(* ********************************************************************** *)
(** * 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_eq H: (E & G). gen G.
  induction Typ; introv EQ Ok; subst.
  apply* typing_var. apply* binds_weaken.
  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* sub_weakening.
  apply* typing_sub. apply* sub_weakening.
Qed.

(* ********************************************************************** *)
(** Strengthening (6) *)

Lemma sub_strengthening : forall x U E F S T,
  sub (E & x ~: U & F) S T ->
  sub (E & F) S T.
Proof.
  intros x U E F S T SsubT.
  gen_eq G: (E & x ~: U & F). gen F.
  induction SsubT; introv EQ; subst; autos* wft_strengthen.
  (* case: fvar trans *)
  apply* (@sub_trans_tvar U0). binds_cases H; autos*.
  (* case: all *)
  apply_fresh* sub_all as X. apply_ih_bind* H0.
Qed.

(************************************************************************ *)
(** Preservation by Type Narrowing (7) *)

Lemma typing_narrowing : forall Q E F X P e T,
  sub E P Q ->
  typing (E & X ~<: Q & F) e T ->
  typing (E & X ~<: P & F) e T.
Proof.
  introv PsubQ Typ. gen_eq E': (E & X ~<: Q & F). gen F.
  induction Typ; introv EQ; subst.
  binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y. apply_ih_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y. apply_ih_bind* H0.
  apply* typing_tapp. apply* (@sub_narrowing Q).
  apply* typing_sub. apply* (@sub_narrowing Q).
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. gen_eq E': (E & x ~: U & F). gen F.
  induction TypT; introv EQ; subst; simpl.
  case_var.
    binds_get H0. apply_empty* typing_weakening.
    binds_cases H0; apply* typing_var.
  apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih_bind* H0.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    rewrite* subst_ee_open_te_var.
    apply_ih_bind* H0.
  apply* typing_tapp. apply* sub_strengthening.
  apply* typing_sub. apply* sub_strengthening.
Qed.

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

Lemma typing_through_subst_te : forall Q E F Z e T P,
  typing (E & Z ~<: Q & F) e T ->
  sub E P Q ->
  typing (E & map (subst_tb Z P) F) (subst_te Z P e) (subst_tt Z P T).
Proof.
  introv Typ PsubQ. gen_eq G: (E & Z ~<: Q & F). gen F.
  induction Typ; introv EQ; subst; simpls subst_tt; simpls subst_te.
  apply* typing_var. rewrite* (@map_subst_tb_id E Z P).
   binds_cases H0; unsimpl_map_bind*.
  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.
  apply* typing_app.
  apply_fresh* typing_tabs as Y.
    unsimpl (subst_tb Z P (bind_sub V)).
    rewrite* subst_te_open_te_var.
    rewrite* subst_tt_open_tt_var.
    apply_ih_map_bind* H0.
  rewrite* subst_tt_open_tt. apply* typing_tapp.
    apply* sub_through_subst_tt.
  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, sub E T (typ_arrow U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall x, x \notin L ->
     typing (E & x ~: S1) (e1 open_ee_var x) S2 /\ sub E S2 U2.
Proof.
  introv Typ. gen_eq e: (trm_abs S1 e1). gen S1 e1.
  induction Typ; intros S1 b1 EQ U1 U2 Sub; inversions EQ.
  inversions* Sub. autos* (@sub_transitivity T).
Qed.

Lemma typing_inv_tabs : forall E S1 e1 T,
  typing E (trm_tabs S1 e1) T ->
  forall U1 U2, sub E T (typ_all U1 U2) ->
     sub E U1 S1
  /\ exists S2, exists L, forall X, X \notin L ->
     typing (E & X ~<: U1) (e1 open_te_var X) (S2 open_tt_var X)
     /\ sub (E & X ~<: U1) (S2 open_tt_var X) (U2 open_tt_var X).
Proof.
  intros E S1 e1 T H. gen_eq e: (trm_tabs S1 e1). gen S1 e1.
  induction H; intros S1 b EQ U1 U2 Sub; inversion EQ.
  inversions Sub. splits.
  apply sub_reflexivity.
  pick_fresh X.
  assert (X \notin L ). eauto.
  eapply typing_regular in H; eauto.
  destruct H. apply okt_strengthen_l in H. auto.
  pick_fresh X.
  assert (X \notin L). eauto.
  eapply typing_regular in H; eauto.
  destruct H. destruct H2. autos*.
   exists T1. let L1 := gather_vars in exists L1.
   intros Y Fr. splits.
    apply_empty* (@typing_narrowing U1).
  apply sub_reflexivity.
  pick_fresh X.
  assert (X \notin L ). eauto.
  eapply typing_regular in H; eauto.
  destruct H. apply okt_strengthen_l in H. auto.
  pick_fresh X.
  assert (X \notin L). eauto.
  eapply typing_regular in H; eauto.
  destruct H. destruct H2. autos*.
  auto. autos* (@sub_transitivity T).
Qed.

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

Lemma preservation_result : preservation.
Proof.
  introv Typ. gen e'. induction Typ; introv Red;
   try solve [ inversion Red ].
  (* case: app *)
  inversions Red; try solve [ apply* typing_app ].
  destruct~ (typing_inv_abs Typ1 (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    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_empty* sub_weakening.
       autos*.
  (* case: tapp *)
  inversions Red; try solve [ apply* typing_tapp ].
  destruct~ (typing_inv_tabs Typ (U1:=T1) (U2:=T2)) as [P1 [S2 [L P2]]].
    apply* sub_reflexivity.
    pick_fresh X. forwards~ K: (P2 X). destruct K.
     rewrite* (@subst_te_intro X).
     rewrite* (@subst_tt_intro X).
     replace E with (E & map (subst_tb X T) empty).
     apply* (@typing_through_subst_te T1).
    assert (typing (E & X ~<: T1) (e0 open_te_var X) (T2 open_tt_var X)).
    eapply typing_sub; eauto.
    replace (E & X ~<: T1 & empty) with (E & X ~<: T1); auto.
    symmetry. 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 (sub empty T (typ_arrow U1 U2)).
{ rewrite st.
    apply sub_reflexivity with (E:=empty); auto. subst. apply typing_regular in Typ.
    destruct Typ. destruct H0. 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 (sub E0 S (typ_arrow U1 U2)). {
    eapply sub_transitivity. apply H. apply EQT. }
   eapply IHTyp. apply Val. apply H0. reflexivity.
Qed.

Lemma tall_inv : forall E T1 T2 M N,
sub E (typ_all T1 M) (typ_all T2 N) -> T1=T2.
Proof. intros.
- inversion H. subst. autos*.
Qed.

Lemma canonical_form_tabs : forall t T U,
  value t -> typing empty t (typ_all T U) ->
  exists e1, t = trm_tabs T e1.
Proof.
  introv Val Typ.
  gen_eq Ty: (typ_all T U). intro st.
  assert (sub empty Ty (typ_all T U)). { rewrite* st.
  apply sub_reflexivity with (E:=empty); auto. subst. apply typing_regular in Typ. destruct Typ.
   destruct H0. auto. }
  clear st. gen_eq E: (@empty typ).
  induction Typ; introv EQE;
   try solve [ inversion Val | inversion EQE | eauto | inversion H ].
  exists e1. lets Q:(tall_inv H). destruct Q. subst*.
  subst. apply* IHTyp. eapply sub_transitivity. apply H0. apply H.
Qed.

(* ********************************************************************** *)
(** Progress Result (16) *)

Lemma progress_result : progress.
Proof.
  introv Typ. gen_eq E: (@empty bind). lets Typ': Typ.
  induction Typ; intros EQ; subst.
  (* case: var *)
  false* binds_empty_inv.
  (* 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).
  (* case: tabs *)
  left*.
  (* case: tapp *)
  right. destruct* IHTyp as [Val1 | [e1' Rede1']].
    destruct (canonical_form_tabs Val1 Typ).
      subst. exists* (open_te x T).
  (* case: sub *)
  autos*.
Qed.


Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Merges.List.List.
Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.
Require Import Coq.Logic.FunctionalExtensionality.

Module Base.
Section Goto.
 Variable Var : Set.
 Variable VarEqDec : EqDec Var.
 Variable Label : Set.

 Definition Value := nat.
 Definition Heap := Map Var Value.
 Definition Pred := Heap -> Prop.

 Let varUpdate := Map.update Var Value VarEqDec.
 Let predUpdate v f (p : Pred)
    := fun s => p (varUpdate v (f (s v)) s).

 Let predImplies (p1 p2 : Pred)
    := forall s, p1 s -> p2 s.

  Inductive Instr : Type :=
   | IInc : Var -> Instr
   | IDec : Var -> Instr
   | INop : Instr
  .
  Hint Constructors Instr.

  Let InstrPre (i : Instr) (post : Pred) : Pred :=
   match i with
   | IInc v => predUpdate v (fun n => S n)    post
   | IDec v => predUpdate v (fun n => pred n) post
   | INop   => post
   end.

  Inductive Block : Type :=
     BlockJump : Label -> Instr -> Block
   | BlockJZ   : Var -> Label -> Label -> Block
   | BlockExit : Block.
  Hint Constructors Block.

  Variable Blocks : Label -> Block.
  Variable LabelPre  : Label -> Pred.

  Definition BlockPre (l : Label) (b : Block) : Prop :=
    match b with
     | BlockJump l' i
     => predImplies (LabelPre l) (InstrPre i (LabelPre l'))
     /\ predImplies (InstrPre i (LabelPre l')) (LabelPre l')

     | BlockJZ v lz lnz
     => predImplies (fun s => LabelPre l s /\ s v  = 0) (LabelPre lz)
     /\ predImplies (fun s => LabelPre l s /\ s v <> 0) (LabelPre lnz)

     | BlockExit
     => True
    end.
  Hint Unfold BlockPre.

  Hypothesis BlocksPre: forall l, BlockPre l (Blocks l).

  Inductive EvalI : Heap -> Instr -> Heap -> Prop :=
   | EvalIInc v s
      : EvalI s (IInc v) (varUpdate v (S (s v)) s)
   | EvalIDec v s
      : EvalI s (IDec v) (varUpdate v (pred (s v)) s)
   | EvalINop s
      : EvalI s INop s.
  Hint Constructors EvalI.

  Inductive EvalB : Heap -> Label -> Heap -> Label -> Prop :=
   | EvalBJump l l' i s s'
      : Blocks l = BlockJump l' i
     -> EvalI s i s'
     -> EvalB s l s' l'
   | EvalBJZ'Z v l lz lnz s
      : Blocks l = BlockJZ v lz lnz
     -> s v = 0
     -> EvalB s l s lz
   | EvalBJZ'NZ v l lz lnz s
      : Blocks l = BlockJZ v lz lnz
     -> s v <> 0
     -> EvalB s l s lnz.

  Theorem EvalI_Hoare i s s' post
   (hPre : InstrPre i post s)
   (hEvI : EvalI s i s')
         : post s'.
  Proof.
   !induction hEvI.
  Qed.

  Theorem BlockPre_Get l b
   (hBlock : Blocks l = b)
           : BlockPre l b.
  Proof.
    !rewrite <- hBlock.
  Qed.
  Hint Immediate BlockPre_Get.

  Theorem EvalB_Hoare l l' s s'
   (hPre : LabelPre l s)
   (hEvB : EvalB s l s' l')
         : LabelPre l' s'.
  Proof.
   !induction hEvB; destructs (BlockPre_Get H).
   !eapply EvalI_Hoare.
  Qed.

  Inductive EvalBs : Heap -> Label -> Heap -> Label -> Prop :=
   | EvalBs0 l s
      : Blocks l = BlockExit
     -> EvalBs s l s l
   | EvalBs1 l s l' s' l'' s''
      : EvalB  s l s' l'
     -> EvalBs s' l' s'' l''
     -> EvalBs s l s'' l''.

  Theorem EvalBs_Hoare l l' s s'
   (hPre : LabelPre l s)
   (hEvB : EvalBs s l s' l')
         : LabelPre l' s'.
  Proof.
   hint EvalB_Hoare.
   !induction hEvB.
  Qed.
End Goto.

Section Functor.
  Definition Instr_map_V {A B : Set} (f : A -> B) (i : Instr A) : Instr B :=
   match i with
   | IInc v => IInc (f v)
   | IDec v => IDec (f v)
   | INop _ => INop _
   end.

  Theorem Instr_map_V_id:
    forall A i, @Instr_map_V A A id i = i.
  Proof.
   !destruct i.
  Qed.

  Definition Block_map_V {L A B : Set} (f : A -> B) (b : Block A L) : Block B L :=
   match b with
   | BlockJump l i    => BlockJump l (Instr_map_V f i)
   | BlockJZ v lz lnz => BlockJZ (f v) lz lnz
   | BlockExit _ _    => BlockExit _ _
   end.
  Definition Block_map_L {V A B : Set} (f : A -> B) (b : Block V A) : Block V B :=
   match b with
   | BlockJump l i    => BlockJump (f l) i
   | BlockJZ v lz lnz => BlockJZ v (f lz) (f lnz)
   | BlockExit _ _    => BlockExit _ _
   end.

  Theorem Heap_comap_V {A B : Set} (f : B -> A) (h : Heap A) : Heap B.
    firstorder.
  Defined.

  Theorem Pred_map_V {A B : Set}
      (f : A -> B)
      (p : Pred A):
    Pred B.
  Proof.
   firstorder.
  Qed.
End Functor.
End Base.

Module Program.
 Module B := Base.

 Record Program (Var Label : Set) : Type
  := mkProgram
   { VarEqDec : EqDec Var
   ; Blocks   : Label -> B.Block Var Label
   ; LabelPre : Label -> B.Pred Var
   ; BlocksPre: (forall l : Label, B.BlockPre VarEqDec LabelPre l (Blocks l))
   }.

 Theorem LabelPre_rewrite V L (P : Program V L) l H H' :
    LabelPre P l H
  -> H' = H
  -> LabelPre P l H'.
 Proof. !intros; subst. Qed.

  Ltac Program_Block_destruct p l :=
    let pre := fresh "block_pre" in
    let eq  := fresh "block_eq" in
    destruct (Blocks p l) eqn:eq;
    lets pre: (BlocksPre p l);
    simpl;
    rewrite eq in *.

End Program.

Module Nowt.
  Inductive V0 : Set :=.
  Inductive L := L1.

  Definition LabelPre (l : L) (h : Base.Heap V0) := True.

  Module P := Program.
  Program Definition r := {| P.Blocks := (fun _ => Base.BlockExit V0 L); P.LabelPre := LabelPre |}.
  Next Obligation.
    decides_equality.
  Defined.
End Nowt.

Module Zero.
  Inductive V : Set := V1.
  Inductive L := L0 | L1 | L2.

  Module B := Base.
  Definition Blocks (l : L) :=
   match l with
   | L0 => B.BlockJump L1 (B.IDec V1)
   | L1 => B.BlockJZ V1 L2 L0
   | L2 => B.BlockExit V L
   end.
  Definition LabelPre (l : L) : B.Pred V :=
   match l with
   | L0 => fun h => True
   | L1 => fun h => True
   | L2 => fun h => h V1 = 0
   end.

  Program Definition r := {| Program.Blocks := Blocks; Program.LabelPre := LabelPre |}.
  Next Obligation.
    decides_equality.
  Defined.
  Next Obligation.
   destruct l; firstorder.
  Qed.
End Zero.

Module Seq.
 Module P := Program.
 Section Seq.
  Variable V L1 L2 : Set.
  Variable P1 : P.Program V L1.
  Variable P2 : P.Program V L2.
  Inductive L' := L'1 (l : L1) | L'2 (l : L2).

  Variable L2Start : L2.

  Hypothesis L2Pre:
    forall (l : L1),
    P.Blocks P1 l = Base.BlockExit _ _ ->
    (forall (h : Base.Heap V), (P.LabelPre P1 l h) -> (P.LabelPre P2 L2Start h)).

  Let Jumpy
   := Base.BlockJump (L'2 L2Start) (Base.INop V).

  Definition Blocks (l : L') :=
   match l with
   | L'1 l1
   => match P.Blocks P1 l1 with
      | Base.BlockExit _ _ => Jumpy
      | b => Base.Block_map_L (L'1) b
      end
   | L'2 l2 => Base.Block_map_L (L'2) (P.Blocks P2 l2)
   end.

  Definition LabelPre (l : L') :=
   match l with
   | L'1 l1 => P.LabelPre P1 l1
   | L'2 l2 => P.LabelPre P2 l2
   end.

  Program Definition r := {| P.VarEqDec := P.VarEqDec P1; P.Blocks := Blocks; P.LabelPre := LabelPre |}.
  Next Obligation.
    hint EqDec_Eq.

    !destruct l.
      !P.Program_Block_destruct P1 l.
        !unfold Jumpy; simpls.
      !P.Program_Block_destruct P2 l.
        !cuts_rewrite (P.VarEqDec P1 = P.VarEqDec P2).
   Qed.

 End Seq.
End Seq.

Module Alt.
 Module P := Program.
 Section Alt.
  Variable V1 V2 L1 L2 : Set.
  Variable P1 : P.Program V1 L1.
  Variable P2 : P.Program V2 L2.
  Inductive L' :=
    | L'1 (l1 : L1) (l2 : L2)
    | L'2 (l1 : L1) (l2 : L2).
  Inductive V' := V'1 (v : V1) | V'2 (v : V2).

  Definition Blocks (l : L') :=
   match l with
   | L'1 l1 l2
   => Base.Block_map_L (fun l1' => L'2 l1' l2)
     (Base.Block_map_V (V'1)
       (P.Blocks P1 l1))

   | L'2 l1 l2
   => Base.Block_map_L (fun l2' => L'1 l1 l2')
     (Base.Block_map_V (V'2)
       (P.Blocks P2 l2))
   end.

  Definition PredAnd (p1 : Base.Pred V1) (p2 : Base.Pred V2) : Base.Pred V' :=
   fun (h : Base.Heap V')
   => p1 (fun v1 => h (V'1 v1))
   /\ p2 (fun v2 => h (V'2 v2)).

  Definition LabelPreAnd (l1 : L1) (l2 : L2) : Base.Pred V' :=
    PredAnd (P.LabelPre P1 l1) (P.LabelPre P2 l2).

  Definition LabelPre (l : L') :=
   match l with
   | L'1 l1 l2 => LabelPreAnd l1 l2
   | L'2 l1 l2 => LabelPreAnd l1 l2
   end.

  Definition Heapjoin (h1 : Base.Heap V1) (h2 : Base.Heap V2) (v : V') :=
   match v with
   | V'1 v1 => h1 v1
   | V'2 v2 => h2 v2
   end.

  Theorem LabelPre__LabelPre l1 l2 h1 h2:
     P.LabelPre P1 l1 h1
  -> P.LabelPre P2 l2 h2
  -> PredAnd (P.LabelPre P1 l1) (P.LabelPre P2 l2) (Heapjoin h1 h2).
  Proof.
   firstorder.
  Qed.
  Print LabelPre__LabelPre.

  Program Definition r := {| P.Blocks := Blocks; P.LabelPre := LabelPre |}.
  Next Obligation.
    remember (P.VarEqDec P1).
    remember (P.VarEqDec P2).
    decides_equality.
  Qed.
  Next Obligation.
    Ltac SOLVEUPDATE :=
      eapply P.LabelPre_rewrite; eauto;
        extensionality x;
        unfold update;
        destruct r_obligation_1;
        try destruct P.VarEqDec; congruence.
    Ltac TICKY := !simpls; unfolds LabelPreAnd; unfolds PredAnd;
                   splits; intros; jauto_set.

    Ltac APPLIES:=
        try match goal with
        | [ F : _ |- _ ]
        => match goal with
          | [ X : _ |- _ ]
          => apply F in X
          end
        | [ F : _ |- _ ]
        => apply F
        end.

   destruct l.
    !P.Program_Block_destruct P1 l1.
      destruct i; TICKY; APPLIES; SOLVEUPDATE.
      TICKY.

    !P.Program_Block_destruct P2 l2.
      destruct i; TICKY; APPLIES; SOLVEUPDATE.
      TICKY.
 Qed.
End Alt.
End Alt.

(*

Module Plus2.
  Module Var <: Var.
    Inductive Var' := VIn1 | VIn2 | VOut.
    Definition Var := Var'.
    Definition VarEqDec : EqDec Var.
    Proof. prove_eqdec. Qed.
    Definition update t := Map.update Var t VarEqDec.
  End Var.

  Module Label <: Label.
    Inductive Var' := VIn1 | VIn2 | VOut.
    Definition Var := Var'.
    Definition VarEqDec : EqDec Var.
    Proof. prove_eqdec. Qed.
    Definition update t := Map.update Var t VarEqDec.
*)


(** * Pushout of a Monic is Monic, Pullback of an Epi is Epi *)
(** Contents
- Pushout of a Monic is Monic
- Pushout of a Monic is Pullback
- Pullback of an Epi is Epi
- Pullback of an Epi is Pushout
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.pushouts.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.coequalizers.
Require Import UniMath.CategoryTheory.limits.Opp.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.opp_precat.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.Morphisms.
Require Import UniMath.CategoryTheory.CategoriesWithBinOps.
Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops.
Require Import UniMath.CategoryTheory.PreAdditive.
Require Import UniMath.CategoryTheory.Additive.
Require Import UniMath.CategoryTheory.Abelian.
Require Import UniMath.CategoryTheory.AbelianToAdditive.

Require Import UniMath.CategoryTheory.limits.kernels.
Require Import UniMath.CategoryTheory.limits.cokernels.
Require Import UniMath.CategoryTheory.limits.BinDirectSums.

(** ** Introduction
We show that in abelian categories pushout of a Monic is a Monic and pullback of an Epi is an Epi.
Also, in this case the pushout diagram (resp. pullback diagram) is a pullback diagram (resp. pushout
diagram).

More precisely, let f : x --> y and g : x --> z be morphisms in an abelian category. Consider the
following pushout diagram
                            x ----g----> z
                          f |        in2 |
                            y ---in1---> w
If f is a Monic, then in2 is a Monic, [AbelianPushoutMonic2]. If g is a Monic, then in1 is a Monic,
[AbelianPushoutMonic1]. In both of the cases the above diagram is a pullback diagram,
[AbelianPushoutMonicisPullback1], [AbelianPushoutMonicisPullback2].

Let f : x --> z and g : y --> z be morphisms in an abelian category. Consider the following pullback
diagram
                            w ---pr1---> x
                       pr2  |          f |
                            y ----g----> z
If f is an Epi, then pr2 is an Epi, [AbelianPushoutEpi2], and if g is an Epi, then pr1 is an Epi,
[AbelianPushoutEpi1]. In both of the cases the above diagram is a pushout diagram,
[AbelianPullbackEpiisPushout1], [AbelianPullbackEpiisPushout2].

 *)
Section pushout_monic_pullback_epi.

  Context {A : AbelianPreCat}.
  (* Let hs : has_homsets A := homset_property A. *)

  Local Opaque Abelian.Equalizer.
  Local Opaque Abelian.Coequalizer.
  Local Opaque to_BinDirectSums.
  Local Opaque to_binop to_inv.

  (** ** Pushout of a Monic is Monic *)

  Lemma AbelianPushoutMonic2 {x y z : A} (f : Monic A x y) (g : x --> z) (Po : Pushout f g) :
    Monics.isMonic (PushoutIn2 Po).
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) y z).
    set (Po' := Pushout_from_Coequalizer_BinCoproduct
                  A _ _ _ f g (BinDirectSum_BinCoproduct _ DS)
                  (Abelian.Coequalizer
                     A
                     (f · (to_In1 DS))
                     (g · (to_In2 DS)))).
    (* Transform the statement to a statement about other pushout *)
    set (iso := z_iso_from_Pushout_to_Pushout Po Po').
    apply (isMonic_postcomp
             A _ (PushoutArrow Po Po' (PushoutIn1 Po') (PushoutIn2 Po')
                               (PushoutSqrCommutes Po'))).
    rewrite (PushoutArrow_PushoutIn2
               Po _ (PushoutIn1 Po') (PushoutIn2 Po')
               (PushoutSqrCommutes Po')).
    (* Prove that the arrow isMonic *)
    set (CE := Coequalizer A (f · to_In1 (A:=AbelianToPreAdditive A) DS)
                           (g · to_In2 (A:=AbelianToPreAdditive A) DS)).
    set (CK := AdditiveCoequalizerToCokernel (AbelianToAdditive A) _ _ CE).
    set (M1 := @isMonic_to_binop_BinDirectSum1' (AbelianToAdditive A) x y z f g DS).
    set (K := MonicToKernel' A (make_Monic _ _ M1) CK).
    use (@to_isMonic (AbelianToAdditive A)).
    intros z0 g0 H. cbn in H. rewrite assoc in H.
    set (φ := KernelIn _ K z0 (g0 · to_In2 (A:=AbelianToPreAdditive A) DS) H).
    set (KComm := KernelCommutes (to_Zero A) K z0 (g0 · to_In2 (A:=AbelianToPreAdditive A) DS) H).
    fold φ in KComm.
    (* The result follows from KComm and the fact that φ = ZeroArrow *)
    assert (e1 : φ = ZeroArrow (to_Zero A) _ _).
    {
      use (MonicisMonic _ f).
      rewrite ZeroArrow_comp_left. cbn in KComm.
      assert (e2 : (MonicArrow _ f) =
                   (@to_binop (AbelianToAdditive A) _ _
                              (f · to_In1 (A:=AbelianToPreAdditive A) DS)
                              (@to_inv (AbelianToAdditive A) _ _
                                       (g · to_In2 (A:=AbelianToPreAdditive A) DS)))
                     · to_Pr1 DS).
      {
        rewrite to_postmor_linear'. rewrite <- assoc.
        rewrite PreAdditive_invlcomp. rewrite <- assoc.
        set (tmp := to_IdIn1 DS). cbn in tmp. cbn. rewrite tmp. clear tmp.
        set (tmp := to_Unel2' DS). cbn in tmp. rewrite tmp. clear tmp.
        rewrite ZeroArrow_comp_right. rewrite id_right. apply pathsinv0.
        set (tmp := @to_runax'' (AbelianToAdditive A) (to_Zero A) _ _ f). exact tmp.
      }
      rewrite e2. clear e2. rewrite assoc. cbn in KComm. cbn. rewrite KComm.
      rewrite <- assoc. set (tmp := to_Unel2' DS). cbn in tmp. rewrite tmp. clear tmp.
      apply ZeroArrow_comp_right.
    }
    use (to_In2_isMonic _ DS). cbn in KComm. use (pathscomp0 (! KComm)).
    rewrite e1. rewrite ZeroArrow_comp_left. rewrite ZeroArrow_comp_left. apply idpath.
  Qed.

  Lemma AbelianPushoutMonic1 {x y z : A} (f : x --> y) (g : Monic A x z) (Po : Pushout f g) :
    Monics.isMonic (PushoutIn1 Po).
  Proof.
    set (Po' := make_Pushout _ _ _ _ _ _ (is_symmetric_isPushout _ (isPushout_Pushout Po))).
    use (AbelianPushoutMonic2 g f Po').
  Qed.

  (** ** Pushout of Monic is Pullback *)

  Local Lemma AbelianPushoutMonicisPullback_eq {x y z : A} (f : Monic A x y) (g : x --> z)
        {e : A} {h : A ⟦ e, y ⟧} {k : A ⟦ e, z ⟧}
        (Hk : let DS := to_BinDirectSums (AbelianToAdditive A) y z in
              let Po' := Pushout_from_Coequalizer_BinCoproduct
                           A _ _ _ f g (BinDirectSum_BinCoproduct _ DS)
                           (Abelian.Coequalizer A (f · (to_In1 DS)) (g · (to_In2 DS))) in
              h · PushoutIn1 Po' = k · PushoutIn2 Po') :
    let DS := to_BinDirectSums (AbelianToAdditive A) y z in
    let Po' := Pushout_from_Coequalizer_BinCoproduct
                 A _ _ _ f g (BinDirectSum_BinCoproduct _ DS)
                 (Abelian.Coequalizer A (f · (to_In1 DS)) (g · (to_In2 DS))) in
    h · CokernelArrow (Abelian.Cokernel f) = ZeroArrow (to_Zero A) e (Abelian.Cokernel f).
  Proof.
    intros DS Po'. cbn zeta in Hk. fold DS in Hk. fold Po' in Hk.
    set (CK := Abelian.Cokernel f).
    assert (e1 : f · CokernelArrow CK = g · ZeroArrow (to_Zero A) z CK).
    {
      rewrite CokernelCompZero. rewrite ZeroArrow_comp_right. apply idpath.
    }
    rewrite <- (PushoutArrow_PushoutIn1 Po' CK (CokernelArrow CK) (ZeroArrow (to_Zero A) _ _) e1).
    rewrite assoc. rewrite Hk. clear Hk. rewrite <- assoc.
    rewrite (PushoutArrow_PushoutIn2 Po' CK (CokernelArrow CK) (ZeroArrow (to_Zero A) _ _) e1).
    apply ZeroArrow_comp_right.
  Qed.

  Lemma AbelianPushoutMonicisPullback1 {x y z : A} (f : Monic A x y) (g : x --> z)
        (Po : Pushout f g) : isPullback (*(PushoutIn1 Po) (PushoutIn2 Po) f g*) (PushoutSqrCommutes Po).
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) y z).
    set (Po' := Pushout_from_Coequalizer_BinCoproduct
                  A _ _ _ f g (BinDirectSum_BinCoproduct _ DS)
                  (Abelian.Coequalizer
                     A
                     (f · (to_In1 DS))
                     (g · (to_In2 DS)))).
    set (i := z_iso_from_Pushout_to_Pushout Po Po').
    use isPullback_up_to_z_iso.
    - exact Po'.
    - exact i.
    - use isPullback_mor_paths.
      + exact (PushoutIn1 Po').
      + exact (PushoutIn2 Po').
      + exact f.
      + exact g.
      + apply pathsinv0.
        exact (PushoutArrow_PushoutIn1
                 Po Po' (PushoutIn1 Po') (PushoutIn2 Po') (PushoutSqrCommutes Po')).
      + apply pathsinv0.
        exact (PushoutArrow_PushoutIn2
                 Po Po' (PushoutIn1 Po') (PushoutIn2 Po') (PushoutSqrCommutes Po')).
      + apply idpath.
      + apply idpath.
      + exact (PushoutSqrCommutes _ ).
      + set (K := MonicToKernel f).
        set (CK := Abelian.Cokernel f). fold CK in K.
        use make_isPullback.
        intros e h k Hk.
        use unique_exists.
        * use (KernelIn (to_Zero A) K).
          -- exact h.
          -- exact (AbelianPushoutMonicisPullback_eq f g Hk).
        * cbn. split.
          -- use (KernelCommutes (to_Zero A) K).
          -- assert (Hk' : h · PushoutIn1 Po' = k · PushoutIn2 Po') by apply Hk.
             set (comm := KernelCommutes
                            (to_Zero A) K _ h (AbelianPushoutMonicisPullback_eq f g Hk)).
             cbn in comm. rewrite <- comm in Hk'. clear comm.
             apply (AbelianPushoutMonic2 f g Po'). rewrite <- Hk'.
             cbn. rewrite <- assoc. rewrite <- assoc. apply cancel_precomposition.
             rewrite assoc. rewrite assoc. apply pathsinv0.
             use CoequalizerEqAr.
        * intros y0. apply isapropdirprod; apply (homset_property A).
        * intros y0 X. cbn in X.
          use (KernelArrowisMonic (to_Zero A) K). rewrite KernelCommutes. exact (dirprod_pr1 X).
  Qed.

  Lemma AbelianPushoutMonicisPullback2 {x y z : A} (f : x --> y) (g : Monic A x z)
        (Po : Pushout f g) : isPullback (*(PushoutIn1 Po) (PushoutIn2 Po) f g*) (PushoutSqrCommutes Po).
  Proof.
    set (Po' := make_Pushout _ _ _ _ _ _ (is_symmetric_isPushout _ (isPushout_Pushout Po))).
    use is_symmetric_isPullback.
    - exact (! (PushoutSqrCommutes _ )).
    - exact (AbelianPushoutMonicisPullback1 g f Po').
  Qed.

  (** ** Pullback of an Epi is Epi *)

  Lemma AbelianPullbackEpi2 {x y z : A} (f : Epi A x z) (g : y --> z) (Pb : Pullback f g) :
    Epis.isEpi (PullbackPr2 Pb).
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) x y).
    set (Pb' := Pullback_from_Equalizer_BinProduct
                  A  _ _ _ f g (BinDirectSum_BinProduct _ DS)
                  (Abelian.Equalizer
                     A
                     ((to_Pr1 DS) · f)
                     ((to_Pr2 DS) · g))).
    (* Transform the statement to a statement about other pullback *)
    set (iso := z_iso_from_Pullback_to_Pullback Pb Pb').
    apply (isEpi_precomp
             A (PullbackArrow Pb Pb' (PullbackPr1 Pb') (PullbackPr2 Pb')
                              (PullbackSqrCommutes Pb'))).
    rewrite (PullbackArrow_PullbackPr2
               Pb _ (PullbackPr1 Pb') (PullbackPr2 Pb')
               (PullbackSqrCommutes Pb')).
    (* Prove that the arrow isEpi *)
    set (E := Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g)).
    set (K := AdditiveEqualizerToKernel (AbelianToAdditive A) _ _ E).
    set (E1 := @isEpi_to_binop_BinDirectSum1' (AbelianToAdditive A) x y z f g DS).
    set (CK := EpiToCokernel' A (make_Epi _ _ E1) K).
    use (@to_isEpi (AbelianToAdditive A)).
    intros z0 g0 H. cbn in H. cbn. rewrite <- assoc in H.
    set (φ := CokernelOut _ CK z0 (to_Pr2 DS · g0) H).
    set (CKComm := CokernelCommutes (to_Zero A) CK z0 (to_Pr2 DS · g0) H).
    fold φ in CKComm.
    (* The result follows from CKComm and the fact that φ = ZeroArrow *)
    assert (e1 : φ = ZeroArrow (to_Zero A) _ _).
    {
      use (EpiisEpi _ f).
      rewrite ZeroArrow_comp_right. cbn in CKComm.
      assert (e2 : (EpiArrow _ f) =
                   (to_In1 DS)
                     · (@to_binop (AbelianToAdditive A) _ _
                                   (to_Pr1 DS · f)
                                   (@to_inv (AbelianToAdditive A) _ _ (to_Pr2 DS · g)))).
      {
        rewrite to_premor_linear'. rewrite assoc.
        rewrite PreAdditive_invrcomp. rewrite assoc.
        set (tmp := to_IdIn1 DS). cbn in tmp. cbn. rewrite tmp. clear tmp.
        set (tmp := to_Unel1' DS). cbn in tmp. rewrite tmp. clear tmp.
        rewrite ZeroArrow_comp_left. rewrite id_left. apply pathsinv0.
        set (tmp := @to_runax'' (AbelianToAdditive A) (to_Zero A) _ _ f). exact tmp.
      }
      rewrite e2. clear e2. rewrite <- assoc. cbn in CKComm. cbn. rewrite CKComm.
      rewrite assoc. set (tmp := to_Unel1' DS). cbn in tmp. rewrite tmp. clear tmp.
      apply ZeroArrow_comp_left.
    }
    use (to_Pr2_isEpi _ DS). cbn in CKComm. use (pathscomp0 (! CKComm)).
    rewrite e1. rewrite ZeroArrow_comp_right. rewrite ZeroArrow_comp_right. apply idpath.
  Qed.

  Lemma AbelianPullbackEpi1 {x y z : A} (f : x --> z) (g : Epi A y z) (Pb : Pullback f g) :
    Epis.isEpi (PullbackPr1 Pb).
  Proof.
    set (Pb' := make_Pullback _ (is_symmetric_isPullback _ (isPullback_Pullback Pb))).
    use (AbelianPullbackEpi2 g f Pb').
  Qed.

  (** ** Pullback of Epi is Pushout *)

  Local Lemma AbelianPullbackEpiisPushout1_eq {x y z : A} (f : Epi A x z) (g : y --> z)
        {e : A} {h : A ⟦ x, e ⟧} {k : A ⟦ y, e ⟧}
        (Hk : let DS := to_BinDirectSums (AbelianToAdditive A) x y in
              let Pb' := Pullback_from_Equalizer_BinProduct
                           A _ _ _ f g (BinDirectSum_BinProduct _ DS)
                           (Abelian.Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g)) in
              PullbackPr1 Pb' · h = PullbackPr2 Pb' · k) :
    let DS := to_BinDirectSums (AbelianToAdditive A) x y in
    let Pb' := Pullback_from_Equalizer_BinProduct
                           A _ _ _ f g (BinDirectSum_BinProduct _ DS)
                           (Abelian.Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g)) in
    let K := Abelian.Kernel f in
    KernelArrow K · h = ZeroArrow (to_Zero A) K e.
  Proof.
    intros DS Pb' K. cbn zeta in Hk. fold DS in Hk. fold Pb' in Hk.
    assert (e1 : KernelArrow K · f = ZeroArrow (to_Zero A) _ _ · g).
    {
      rewrite KernelCompZero. rewrite ZeroArrow_comp_left. apply idpath.
    }
    rewrite <- (PullbackArrow_PullbackPr1 Pb' K (KernelArrow K) (ZeroArrow (to_Zero A) _ _) e1).
    rewrite <- assoc. rewrite Hk. clear Hk. rewrite assoc.
    rewrite (PullbackArrow_PullbackPr2 Pb' K (KernelArrow K) (ZeroArrow (to_Zero A) _ _) e1).
    apply ZeroArrow_comp_left.
  Qed.

  Lemma AbelianPullbackEpiisPushout1 {x y z : A} (f : Epi A x z) (g : y --> z) (Pb : Pullback f g) :
    isPushout (PullbackPr1 Pb) (PullbackPr2 Pb) f g (PullbackSqrCommutes Pb).
  Proof.
    set (DS := to_BinDirectSums (AbelianToAdditive A) x y).
    set (Pb' := Pullback_from_Equalizer_BinProduct
                  A _ _ _ f g (BinDirectSum_BinProduct _ DS)
                  (Abelian.Equalizer A ((to_Pr1 DS) · f) ((to_Pr2 DS) · g))).
    set (i := z_iso_from_Pullback_to_Pullback Pb' Pb).
    use isPushout_up_to_z_iso.
    - exact Pb'.
    - exact i.
    - use isPushout_mor_paths.
      + exact (PullbackPr1 Pb').
      + exact (PullbackPr2 Pb').
      + exact f.
      + exact g.
      + apply pathsinv0.
        exact (PullbackArrow_PullbackPr1
                 Pb Pb' (PullbackPr1 Pb') (PullbackPr2 Pb') (PullbackSqrCommutes Pb')).
      + apply pathsinv0.
        exact (PullbackArrow_PullbackPr2
                 Pb Pb' (PullbackPr1 Pb') (PullbackPr2 Pb') (PullbackSqrCommutes Pb')).
      + apply idpath.
      + apply idpath.
      + exact (PullbackSqrCommutes _ ).
      + set (CK := EpiToCokernel f).
        set (K := Abelian.Kernel f). fold K in CK.
        use make_isPushout.
        intros e h k Hk.
        use unique_exists.
        * use (CokernelOut (to_Zero A) CK).
          -- exact h.
          -- exact (AbelianPullbackEpiisPushout1_eq f g Hk).
        * cbn. split.
          -- use (CokernelCommutes (to_Zero A) CK).
          -- assert (Hk' : PullbackPr1 Pb' · h = PullbackPr2 Pb' · k) by apply Hk.
             set (comm := CokernelCommutes
                            (to_Zero A) CK _ h (AbelianPullbackEpiisPushout1_eq f g Hk)).
             cbn in comm. rewrite <- comm in Hk'. clear comm.
             apply (AbelianPullbackEpi2 f g Pb'). rewrite <- Hk'.
             cbn. rewrite assoc. rewrite assoc. apply cancel_postcomposition.
             rewrite <- assoc. rewrite <- assoc. apply pathsinv0.
             use EqualizerEqAr.
        * intros y0. apply isapropdirprod; apply (homset_property A).
        * intros y0 X. cbn in X.
          use (CokernelArrowisEpi (to_Zero A) CK). rewrite CokernelCommutes. exact (dirprod_pr1 X).
  Qed.

  Lemma AbelianPullbackEpiisPushout2 {x y z : A} (f : x --> z) (g : Epi A y z) (Pb : Pullback f g) :
    isPushout (PullbackPr1 Pb) (PullbackPr2 Pb) f g (PullbackSqrCommutes Pb).
  Proof.
    set (Pb' := make_Pullback  _ (is_symmetric_isPullback _ (isPullback_Pullback Pb))).
    use is_symmetric_isPushout.
    - exact (! (PullbackSqrCommutes _ )).
    - exact (AbelianPullbackEpiisPushout1 g f Pb').
  Qed.

End pushout_monic_pullback_epi.


Add LoadPath "~/fcf/src".
Add LoadPath "./Dist".
Require Import FCF.EqDec.
Require Import Dist.
Require Import CpdtTactics.
Require Import List.
Require Import Bool.
Require Import SetLems.

Section PIOADef.
  Context {Lab : Set}.
  Context `{eqLab : EqDec Lab}.

Record PIOA :=
mkPIOA {
    pQ : Set;
    pI : Lab -> bool;
    pO : Lab -> bool;
    pH : Lab -> bool;
    start : pQ;
    trans : pQ -> Lab -> option (Dist pQ);
    }.

Definition disjoint (f g : Lab -> bool) := forall x,
    (f x = true -> g x = false) /\
    (g x = true -> f x = false).

Definition pairwise_disjoint (f g h : Lab -> bool) := forall x,
    (f x = true -> (g x = false /\ h x = false)) /\
    (g x = true -> (h x = false /\ g x = false)) /\
    (h x = true -> (f x = false /\ f x = false)).

Class wfPIOA (P : PIOA) :=
  {
    disjoint_labs : pairwise_disjoint (pI P) (pO P) (pH P);
    input_enabled : forall q l, (pI P) l = true -> exists c, (trans P) q l = Some c;
    trans_wf : forall q l c, ((trans P) q l = Some c ->
                              (pI P l = true \/ pO P l = true \/ pH P l = true)) /\
                             ((pI P l = false /\ pO P l = false /\ pH P l = false) -> trans P q l = None)
  }.

Definition action (P : PIOA) (l : Lab) :=
  (pI P l || pO P l) || pH P l.

Definition ext_action (P : PIOA) l :=
  pI P l || pO P l.

Definition loc_action (P : PIOA) l :=
  pO P l || pH P l.

Section SecPIOA.
  Context (P : PIOA).
  Context `{EqDec (pQ P)}.

    Inductive Frag :=
    | FragStart : pQ P -> Frag
    | FragStep : Lab -> pQ P -> Frag  -> Frag .

  Global Instance frag_eq : EqDec Frag.
  apply dec_EqDec; unfold eq_dec; decide equality; apply EqDec_dec; auto; try apply eqd_lab.
  Defined.

    Definition lastState (f : Frag) :=
    match f with
    | FragStart  q => q
    | FragStep _ q _ => q
    end.

    Fixpoint firstState (f : Frag) :=
      match f with
      | FragStart  q => q
      | FragStep _ _ f' => firstState f'
      end.

    Fixpoint wf_Frag (f : Frag) : Prop :=
    match f with
    | FragStart  _ => True
    | FragStep  a q f' =>
      (wf_Frag f') /\
      (exists c, trans P (lastState f') a = Some c /\ In q (distSupport c))
    end.

    Definition loc_lab := {x : Lab | (loc_action P) x = true}.
    Definition act_lab := {x : Lab | (action P) x = true}.

    (* In the paper they use loc_lab below where I use act_lab. is this an important difference? *)

    (* the label only gets added to the frag if the process accepts it. *)
    Definition appAction (a : act_lab) (c : Dist Frag) : Dist Frag :=
      f <- c;
      match (trans P (lastState f) (proj1_sig a)) with
        | Some mu =>
            q <- mu;
            ret (FragStep (proj1_sig a) q f)
        | Nothing => ret f
      end.

    (* Earlier actions are applied later *)
    Fixpoint appList (c : Dist Frag) (acts : list (act_lab)) :=
      match acts with
      | nil => c
      | l :: acts' =>
        appAction l (appList c acts')
                  end.

    Definition run (acts : list act_lab) : Dist Frag := appList (ret (FragStart (start P))) acts.

    Lemma run_cons : forall a acts, run (a :: acts) = appAction a (run acts).
      unfold run; simpl; auto.
      Qed.

    Lemma run_app : forall acts acts', run (acts ++ acts') = appList (run acts') acts.
      induction acts; simpl.
      auto.
      intro.
      rewrite run_cons.
      rewrite IHacts.
      auto.
    Qed.

    Fixpoint traceOf (f : Frag) :=
      match f with
      | FragStart q => nil
      | FragStep a q f' =>
        if ((ext_action P) a) then a :: (traceOf f') else traceOf f'
      end.

End SecPIOA.

Class Compatible (P1 P2 : PIOA) :=
  {
    disjoint_outs : disjoint (pO P1) (pO P2);
    disjoint_ins : disjoint (pI P1) (pI P2);
    disjoint_h_l : disjoint (pH P1) (action P2);
    disjoint_h_r : disjoint (pH P2) (action P1)
  }.

Class Comparable (P1 P2 : PIOA) :=
  {
    equal_ins : forall l, pI P1 l = pI P2 l;
    equal_outs : forall l, pO P1 l = pO P2 l;
    disjoint_hiddens_l : disjoint (pH P1) (action P2);
    disjoint_hiddens_r : disjoint (pH P2) (action P1);
    }.

Lemma compatible_comparable : forall P1 P2 P3,
    Compatible P1 P3 ->
    Comparable P1 P2 ->
    Compatible P2 P3.

Admitted.

Section CompPIOA.
  Context (P1 P2 : PIOA).
  Context `{Compatible P1 P2}.

  Definition comp_start := (start P1, start P2).

  Definition comp_ins l :=
    (pI P1 l || pI P2 l) && (negb (pO P1 l || pO P2 l)).

  Definition comp_outs l :=
    (pO P1 l || pO P2 l) && (negb (pI P1 l || pI P2 l)).

  Definition comp_hiddens l :=
    pH P1 l || pH P2 l || (pI P1 l && pO P2 l) || (pO P1 l && pI P2 l).

  Definition comp_trans p l :=
    match (trans P1 (fst p) l, trans P2 (snd p) l) with
    | (None, None) => None
    | (Some mu1, None) => Some (
      x <- mu1;
      ret (x, snd p))
    | (None, Some mu2) => Some (
        x <- mu2;
        ret (fst p, x))
    | (Some mu1, Some mu2) => Some (
        x <- mu1;
        y <- mu2;
        ret (x,y))
    end.

  Definition compPIOA : PIOA :=
    mkPIOA ((pQ P1) * (pQ P2)) comp_ins comp_outs comp_hiddens comp_start comp_trans.

  Hint Rewrite negb_false_iff.
  Hint Rewrite negb_true_iff.
  Hint Rewrite negb_orb.
  Hint Rewrite negb_andb.
  Hint Rewrite negb_involutive.
  Hint Rewrite orb_false_elim.
  Hint Rewrite andb_true_iff.
  Hint Rewrite andb_false_iff.
  Hint Rewrite orb_true_iff.
  Hint Rewrite orb_false_iff.

  Ltac exists_some := match goal with
                      | [ |- exists c, Some ?b = Some c] => exists ?b
                      | [ |- exists c, Some c = Some ?b] => exists ?b
                      end.

  Instance compWf : forall (w1 : wfPIOA P1) (w2 : wfPIOA P2), wfPIOA compPIOA.
  econstructor.
  simpl.
  unfold pairwise_disjoint.
  intro x.
  destruct H; unfold disjoint in *.
  destruct w1 as [w1 _ _]; unfold pairwise_disjoint in w1; pose proof (w1 x); clear w1.
  destruct w2 as [w2 _ _]; unfold pairwise_disjoint in w2; pose proof (w2 x); clear w2.
  unfold comp_ins, comp_outs, comp_hiddens.
  admit.

  intros.
  destruct w1 as [_ w1 _].
  destruct w2 as [_ w2 _].
  simpl in H0.
  unfold comp_ins in H0.
  unfold trans; simpl.
  unfold comp_trans.

  rewrite andb_true_iff in H0; destruct H0.
  remember (pI P1 l) as b1.
  remember (pI P2 l) as b2.
  destruct b1; destruct b2; symmetry in Heqb1; symmetry in Heqb2.

  destruct (w1 (fst q) _ Heqb1).
  destruct (w2 (snd q) _ Heqb2).
  rewrite H2; rewrite H3; simpl.
  exists (x1 <- x; y <- x0; ret (x1, y)); crush.

  destruct (w1 (fst q) _ Heqb1).
  rewrite H2.
  destruct (trans P2 (snd q) l).
  exists (x0 <- x; y <- d; ret (x0, y)); crush.
  exists (x0 <- x; ret (x0, snd q)); crush.

  destruct (w2 (snd q) _ Heqb2).
  rewrite H2.
  destruct (trans P1 (fst q) l).
  exists (x0 <- d; y <- x; ret (x0, y)); crush.
  exists (x0 <- x; ret (fst q, x0)); crush.
  simpl in H0.
  crush.

  intros.
  destruct w1 as [wf1 ia1 w1].
  destruct w2 as [wf2 ia2 w2].
  destruct H.
  split; intros.
  simpl in H0.
  unfold comp_trans in H0.

  remember (trans P1 (fst q) l); symmetry in Heqo.
  destruct o.
  apply w1 in Heqo.
  destruct Heqo.
  remember (pO P2 l) as b; destruct b.
  right; right; simpl.
  unfold comp_hiddens.
  cut (pI P1 l && pO P2 l = true).
  intro HH; rewrite HH; crush.
  crush.
  left; simpl; unfold comp_ins.
  rewrite H1. rewrite <- Heqb.
  simpl.
  cut (pO P1 l = false).
  intro HH; crush.
  destruct (wf1 l).
  crush.
  destruct H1.
  remember (pI P2 l) as b; destruct b.
  right; right; simpl; unfold comp_hiddens.
  cut (pO P1 l && pI P2 l = true); crush.
  right; left; simpl; unfold comp_outs.
  rewrite H1. rewrite <- Heqb.
  simpl.
  destruct (wf1 l).
  cut (pI P1 l = false); crush.
  right; right; simpl; unfold comp_hiddens; rewrite H1; crush.

  remember (trans P2 (snd q) l); symmetry in Heqo0.
  destruct o.
  apply w2 in Heqo0.
  destruct Heqo0.
  remember (pO P1 l) as b; destruct b.
  right; right; simpl.
  unfold comp_hiddens.
  cut (pO P1 l && pI P2 l = true); crush.
  left; simpl; unfold comp_ins.

  rewrite H1; rewrite <- Heqb.
  rewrite orb_true_r.
  simpl.
  destruct (wf2 l).
  cut (pO P2 l = false); crush.
  destruct H1.
  remember (pI P1 l) as b; destruct b.
  right; right; simpl; unfold comp_hiddens; simpl.
  cut (pI P1 l && pO P2 l = true); crush.
  right; left; simpl; unfold comp_outs.
  rewrite H1; rewrite <- Heqb.
  rewrite orb_true_r.
  simpl.
  destruct (wf2 l); crush.
  right; right; simpl; unfold comp_hiddens; crush.
  crush.
  simpl; unfold comp_trans.
  destruct H0.
  destruct H1.
  simpl in *.
  unfold comp_ins, comp_outs, comp_hiddens in *.
  cut (trans P1 (fst q) l = None /\ trans P2 (snd q) l = None).
  crush.
  split.

  apply w1.
  apply (x <- c; ret (fst x)).
  split.
  remember (pI P1 l) as b; destruct b; symmetry in Heqb.
  remember (pO P2 l) as b2; destruct b2; symmetry in Heqb2.
  simpl in *.
  crush.
  simpl in *.
  remember (pO P1 l) as b3; destruct b3; symmetry in Heqb3.

  destruct (wf1 l); crush.
  simpl in *.
  crush.
  crush.
  split.

  remember (pO P1 l) as b; destruct b; symmetry in Heqb.
  remember (pO P2 l) as b2; destruct b2; symmetry in Heqb2.
  crush.
  simpl in *.
  remember (pI P1 l) as b3; destruct b3; symmetry in Heqb3.
  destruct (wf1 l); crush.
  crush.
  crush.
  destruct (pH P1 l).
  simpl in H2.
  crush.
  crush.

  apply w2.
  apply (x <- c; ret (snd x)).
  split.
  remember (pI P2 l) as b; destruct b; symmetry in Heqb.
  remember (pO P1 l) as b2; destruct b2; symmetry in Heqb2.
  simpl in *.
  crush.
  simpl in *.
  remember (pO P2 l) as b3; destruct b3; symmetry in Heqb3.

  destruct (wf2 l); crush.
  simpl in *.
  crush.
  crush.
  split.

  remember (pO P2 l) as b; destruct b; symmetry in Heqb.
  remember (pO P1 l) as b2; destruct b2; symmetry in Heqb2.
  crush.
  simpl in *.
  remember (pI P2 l) as b3; destruct b3; symmetry in Heqb3.
  destruct (wf2 l); crush.
  crush.
  crush.
  destruct (pH P2 l).
  simpl in H2.
  crush.
  crush.
  Admitted.

End CompPIOA.

End PIOADef.

Section PIOALabExt.
  Context (L L' : Set).
  Context (P : @PIOA L).
  Context (Lsur : L' -> option L).

  Definition lab_ext : PIOA :=
    @mkPIOA L' (pQ P) (fun l' =>  match Lsur l' with | Some l => pI P l  | None => false end)
                      (fun l' =>  match Lsur l' with | Some l => pO P l  | None => false end)
                      (fun l' => match Lsur l' with | Some l => pH P l | None => false end)
                      (start P)
                      (fun s l' =>
                         match Lsur l' with
                         | Some l => trans P s l
                         | None => None
                      end).

End PIOALabExt.

Notation "x |+| y" := (@compPIOA _ x y) (at level 51, right associativity).


Require Import Coq.Lists.List.
Require Import Io.All.
Require Import Io.System.All.
Require Import ListString.All.
Require Import Coq.Strings.Ascii.

Set Implicit Arguments.
Require Import mathcomp.ssreflect.ssrnat.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.all_ssreflect.

Require Import SparseMatrix.
Require Import SeqSet.
Require Import ParsingTools.
Require Import LineParser.
Require Import GenChvatalMatrix.
Require Import GenChvatalMatrixRevised.
Require Import ZArith.Znat.
Set Warnings "-extraction-reserved-identifier".
Import LString.
Import ListNotations.
Import C.Notations.

Local Open Scope char_scope.

(** Return if string (line) is relevant. Currently relevant lines are constraints (C) or bounds (B) *)
Definition is_relevant (str : LString.t) :  bool :=
 if str is h :: t then (h == "C") || (h == "B") else false.

(** Check if input has the correct format *)
Definition check_input (input : seq LString.t) : bool :=
  all is_relevant input.

(** Extracts the varsec from an LString. This starts with a line beginning with "VAR" and ends with a line beginning with "OBJ" *)
Definition getVarSec (input : list LString.t) (b : bool ) : list LString.t :=
  let start := find (subseq ["V";"A";"R"]) input in
  let sseq := drop start.+1 input in
  let ending := find (subseq ["O";"B";"J"]) sseq in
  take ending sseq .

(** Extracts the constraint sections from an LString. This starts with a line beginning with "CON" and ends with a line beginning with "RTP" *)
Definition getConsSec (input : list LString.t)(b : bool) : list LString.t :=
  let start := find (subseq ["C";"O";"N"]) input in
  let startseq := drop start.+1 input in
  let ending := find (subseq ["R";"T";"P"]) startseq in
  let theseq := take ending startseq in
  [seq x <- theseq | false == ( ["0"] ==  (nth [" "] (tokenize  x) 3))].

(** Create sparse matrix from vipr-input *)
Definition create_matrix (input : list LString.t) (vartable : list nat) : smat :=
  [seq ordervec (parseline vartable  h) | h <- input].

Definition a := [["t";"_";"y";"#";"1"];["t";"_";"x";"#";"6"];["t";"_";"y";"#";"3"];["t";"_";"x";"#";"4"]].

(** Create a vartable (convert between zimpl-numbering of sets in powerset and canonical ordering) *)
Definition create_vartable (input : list LString.t) (card : nat) : list nat :=
  let s := input in
  let f := (fun (x : LString.t) => if "y" \in x then (extractNumber (drop 4 x)) + pow2_min1 card
                                else if "z" \in x then (2 * pow2_min1 card)
                                else (extractNumber (drop 4 x) )) in
  [seq f x | x <- s].

(*Compute toStringNat( create_vartable a 3).*)

(** parse the content of an LString into a sparse matrix. Create the correct chvatal-matrix and check if they are the same. Print some logging information *)
  Definition parse_content (content : LString.t) (card : nat)(fixes : LString.t) : C.t System.effect unit :=
    (* extract variable section and print it to shell *)
    let varsec := getVarSec (LString.split content (Char.n)) true in
    do! System.log (LString.s "Variable section:") in
        do! System.log (LString.join ([Char.n]) varsec) in
        (* extract problem description and print it to shell *)
        let inplist := getConsSec (LString.split content (Char.n)) true in
        do! System.log (LString.s "Relevant input:") in
            do! System.log ( LString.join ([Char.n])  inplist ) in
            (*create ordered input matrix*)
            let vartable := (create_vartable varsec card) in
            let matrix := order (create_matrix inplist vartable) in
            do! System.log (LString.s "Ordered input:") in
                do! System.log (toString (matrix)) in
                do! System.log (LString.s "coq-created matrix:") in
                (*create check-matrix*)
                let ch_matrix := if eqb fixes (of_string("y"))
                                 then order(create_mat_rev card)
                                 else  order(create_mat card) in
                do! System.log (toString (ch_matrix) ) in
                (*Check if both matrices are the same*)
                if  (matrix == ch_matrix)
                then System.log (LString.s "The matrices are the same.")
                else  do! System.log (LString.s "The matrices are not the same, first different vectors:.") in
                      System.log (toString (diffvec matrix ch_matrix))
                .

(** Read vipr file and parse the content. *)
Definition read_file (argv : list LString.t) : C.t System.effect unit :=
  do! System.log (LString.s "Enter file-name of VIPR certificate to be checked:") in
    let! file_name := System.read_line in
    match file_name with
    | None => ret tt
    | Some name =>
    let! content := System.read_file name in
    do! System.log (LString.s "What is [n]?") in
        let! n := System.read_line in
        match n with
        | None => ret tt
        | Some number =>
          do! System.log (LString.s "Is this an instance with fixings (y/n)?") in
              let! fixings := System.read_line in
              match fixings with
              | None => ret tt
              | Some fixes =>
                match content with
                | None => System.log (LString.s "Cannot read the file")
                | Some content => parse_content content (extractNumber  number) fixes
                end
              end
        end
    end.

(** Extract into compilable Ocaml code *)
Definition main := Extraction.launch read_file.
Extraction "bin/checkvipr" main.

Close Scope char_scope.