(* Termination for D<> with intersection type and recursive type *)

(*
 DSub (D<:) + Bot + /\ + { z => ... }
 T ::= Top | Bot | x.Type | { Type: S..U } | (z: T) -> T^z | T1 /\ T2 | { z => T^z }
 t ::= x | { Type = T } | lambda x:T.t | t t
 *)

(* NEGATIVE result:
    show that indexed vset types with precise indexes
    alone do not support t_var_unpack.
*)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.

(* ### Syntax ### *)

Definition id := nat.

(* term variables occurring in types *)
Inductive var : Type :=
| varF : id -> var (* free, in concrete environment *)
| varH : id -> var (* free, in abstract environment  *)
| varB : id -> var (* locally-bound variable *)
.

Inductive ty : Type :=
| TTop : ty
| TBot : ty
(* (z: T) -> T^z *)
| TAll : ty -> ty -> ty
(* x.Type *)
| TSel : var -> ty
(* { Type: S..U } *)
| TMem : ty(*S*) -> ty(*U*) -> ty
| TBind  : ty -> ty (* Recursive binder: { z => T^z },
                         where z is locally bound in T *)
| TAnd : ty -> ty -> ty (* Intersection Type: T1 /\ T2 *)
.

Inductive tm : Type :=
(* x -- free variable, matching concrete environment *)
| tvar : id -> tm
(* { Type = T } *)
| ttyp : ty -> tm
(* lambda x:T.t *)
| tabs : ty -> tm -> tm
(* t t *)
| tapp : tm -> tm -> tm
(* unpack(e) { x => ... } *)
| tunpack : tm -> tm -> tm
.

Inductive vl : Type :=
(* a closure for a lambda abstraction *)
| vabs : list vl (*H*) -> ty -> tm -> vl
(* a closure for a first-class type *)
| vty : list vl (*H*) -> ty -> vl
.

Definition tenv := list ty. (* Gamma environment: static *)
Definition venv := list vl. (* H environment: run-time *)

(* ### Representation of Bindings ### *)

(* An environment is a list of values, indexed by decrementing ids. *)

Fixpoint indexr {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 indexr n l'
  end.

Inductive closed: nat(*B*) -> nat(*H*) -> nat(*F*) -> ty -> Prop :=
| cl_top: forall i j k,
    closed i j k TTop
| cl_bot: forall i j k,
    closed i j k TBot
| cl_all: forall i j k T1 T2,
    closed i j k T1 ->
    closed (S i) j k T2 ->
    closed i j k (TAll T1 T2)
| cl_sel: forall i j k x,
    k > x ->
    closed i j k (TSel (varF x))
| cl_selh: forall i j k x,
    j > x ->
    closed i j k (TSel (varH x))
| cl_selb: forall i j k x,
    i > x ->
    closed i j k (TSel (varB x))
| cl_mem: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TMem T1 T2)
| cl_bind: forall i j k T,
    closed (S i) j k T ->
    closed i j k (TBind T)
| cl_and: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TAnd T1 T2)
.

(* open define a locally-nameless encoding wrt to TVarB type variables. *)
(* substitute var u for all occurrences of (varB k) *)
Fixpoint open_rec (k: nat) (u: var) (T: ty) { struct T }: ty :=
  match T with
    | TTop        => TTop
    | TBot        => TBot
    | TAll T1 T2  => TAll (open_rec k u T1) (open_rec (S k) u T2)
    | TSel (varF x) => TSel (varF x)
    | TSel (varH i) => TSel (varH i)
    | TSel (varB i) => if beq_nat k i then TSel u else TSel (varB i)
    | TMem T1 T2  => TMem (open_rec k u T1) (open_rec k u T2)
    | TBind T => TBind (open_rec (S k) u T)
    | TAnd T1 T2 => TAnd (open_rec k u T1) (open_rec k u T2)
  end.

Definition open u T := open_rec 0 u T.

(* Locally-nameless encoding with respect to varH variables. *)
Fixpoint subst (U : var) (T : ty) {struct T} : ty :=
  match T with
    | TTop         => TTop
    | TBot         => TBot
    | TAll T1 T2   => TAll (subst U T1) (subst U T2)
    | TSel (varB i) => TSel (varB i)
    | TSel (varF i) => TSel (varF i)
    | TSel (varH i) => if beq_nat i 0 then TSel U else TSel (varH (i-1))
    | TMem T1 T2     => TMem (subst U T1) (subst U T2)
    | TBind T       => TBind (subst U T)
    | TAnd T1 T2    => TAnd (subst U T1)(subst U T2)
  end.

Fixpoint nosubst (T : ty) {struct T} : Prop :=
  match T with
    | TTop         => True
    | TBot         => True
    | TAll T1 T2   => nosubst T1 /\ nosubst T2
    | TSel (varB i) => True
    | TSel (varF i) => True
    | TSel (varH i) => i <> 0
    | TMem T1 T2    => nosubst T1 /\ nosubst T2
    | TBind T       => nosubst T
    | TAnd T1 T2    => nosubst T1 /\ nosubst T2
  end.

(* ### Static Subtyping ### *)
(*
The first env is for looking up varF variables.
The first env matches the concrete runtime environment, and is
extended during type assignment.
The second env is for looking up varH variables.
The second env matches the abstract runtime environment, and is
extended during subtyping.
*)
Inductive stp: tenv -> tenv -> ty -> ty -> Prop :=
| stp_top: forall G1 GH T1,
    closed 0 (length GH) (length G1) T1 ->
    stp G1 GH T1 TTop
| stp_bot: forall G1 GH T2,
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH TBot T2
| stp_mem: forall G1 GH S1 U1 S2 U2,
    stp G1 GH U1 U2 ->
    stp G1 GH S2 S1 ->
    stp G1 GH (TMem S1 U1) (TMem S2 U2)
| stp_sel1: forall G1 GH TX T2 x,
    indexr x G1 = Some TX ->
    closed 0 0 (length G1) TX ->
    stp G1 GH TX (TMem TBot T2) ->
    stp G1 GH (TSel (varF x)) T2
| stp_sel2: forall G1 GH TX T1 x,
    indexr x G1 = Some TX ->
    closed 0 0 (length G1) TX ->
    stp G1 GH TX (TMem T1 TTop) ->
    stp G1 GH T1 (TSel (varF x))
| stp_selx: forall G1 GH v x,
    indexr x G1 = Some v ->
    stp G1 GH (TSel (varF x)) (TSel (varF x))
| stp_sela1: forall G1 GH TX T2 x,
    indexr x GH = Some TX ->
    closed 0 x (length G1) TX ->
    stp G1 GH TX (TMem TBot T2) ->
    stp G1 GH (TSel (varH x)) T2
| stp_sela2: forall G1 GH TX T1 x,
    indexr x GH = Some TX ->
    closed 0 x (length G1) TX ->
    stp G1 GH TX (TMem T1 TTop) ->
    stp G1 GH T1 (TSel (varH x))
| stp_selax: forall G1 GH v x,
    indexr x GH = Some v  ->
    stp G1 GH (TSel (varH x)) (TSel (varH x))

(* stp for recursive type and inersection type *)
(*
| stp_bind1: forall GH G1 T1 T1' T2,
    stp G1 (T1'::GH) T1' T2 ->
    T1' = (open (varH (length GH)) T1) ->
    closed 1 (length GH) (length G1) T1 ->
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH (TBind T1) T2

| stp_bind2: forall GH G1 T1 T1' T2,
    stp G1 (T1'::GH) T2 T1' ->
    T1' = (open (varH (length GH)) T1) ->
    closed 1 (length GH) (length G1) T1 ->
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH T2 (TBind T1)
*)
| stp_bindx: forall GH G1 T1 T1' T2 T2',
    stp G1 (T1'::GH) T1' T2' ->
    T1' = (open (varH (length GH)) T1) ->
    T2' = (open (varH (length GH)) T2) ->
    closed 1 (length GH) (length G1) T1 ->
    closed 1 (length GH) (length G1) T2 ->
    stp G1 GH (TBind T1) (TBind T2)

| stp_and11: forall GH G1 T1 T2 T,
    stp G1 GH T1 T ->
    closed 0 (length GH) (length G1) T2 ->
    stp G1 GH (TAnd T1 T2) T

| stp_and12: forall GH G1 T1 T2 T,
    stp G1 GH T2 T ->
    closed 0 (length GH) (length G1) T1 ->
    stp G1 GH (TAnd T1 T2) T

| stp_and2: forall GH G1 T1 T2 T,
    stp G1 GH T T1 ->
    stp G1 GH T T2 ->
    stp G1 GH T (TAnd T1 T2)

| stp_all: forall G1 GH T1 T2 T3 T4 x,
    stp G1 GH T3 T1 ->
    x = length GH ->
    closed 1 (length GH) (length G1) T2 ->
    closed 1 (length GH) (length G1) T4 ->
    stp G1 (T3::GH) (open (varH x) T2) (open (varH x) T4) ->
    stp G1 GH (TAll T1 T2) (TAll T3 T4)
| stp_trans: forall G1 GH T1 T2 T3,
    stp G1 GH T1 T2 ->
    stp G1 GH T2 T3 ->
    stp G1 GH T1 T3
.

(* ### Type Assignment ### *)
Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_var: forall x env T1,
           indexr x env = Some T1 ->
           stp env [] T1 T1 ->
           has_type env (tvar x) T1
(* recursive typing  *)
| t_var_pack : forall G1 x T1 T1',
           (* has_type G1 (tvar x) T1' -> *)
      indexr x G1 = Some (open (varF x) T1) ->
      T1' = (open (varF x) T1) ->
      closed 1 0 (length G1) T1 ->
      has_type G1 (tvar x) (TBind T1)
| t_var_unpack : forall G1 x T1 T1',
      (* has_type G1 (tvar x) (TBind T1) -> *)
      indexr x G1 = Some (TBind T1) ->
      T1' = (open (varF x) T1) ->
      closed 0 0 (length G1) T1' ->
      has_type G1 (tvar x) T1'

(* unpack a recursive type: unpack(x:{z=>T^z}) { x:T^x => ... }  *)
| t_unpack: forall env x y T1 T1' T2,
           has_type env x (TBind T1) ->
           T1' = (open (varF (length env)) T1) ->
           has_type (T1'::env) y T2 ->
           closed 0 0 (length env) T2 ->
           has_type env (tunpack x y) T2

(* intersection typing *)
| t_and : forall env x T1 T2,
           has_type env (tvar x) T1 ->
           has_type env (tvar x) T2 ->
           has_type env (tvar x) (TAnd T1 T2)

| t_typ: forall env T1,
           closed 0 0 (length env) T1 ->
           has_type env (ttyp T1) (TMem T1 T1)

| t_app: forall env f x T1 T2,
           has_type env f (TAll T1 T2) ->
           has_type env x T1 ->
           closed 0 0 (length env) T2 ->
           has_type env (tapp f x) T2
| t_dapp:forall env f x T1 T2 T,
           has_type env f (TAll T1 T2) ->
           has_type env (tvar x) T1 ->
           T = open (varF x) T2 ->
           closed 0 0 (length env) T ->
           has_type env (tapp f (tvar x)) T
| t_abs: forall env y T1 T2,
           has_type (T1::env) y (open (varF (length env)) T2) ->
           closed 0 0 (length env) (TAll T1 T2) ->
           has_type env (tabs T1 y) (TAll T1 T2)
| t_sub: forall env e T1 T2,
           has_type env e T1 ->
           stp env [] T1 T2 ->
           has_type env e T2
.

(* ### Evaluation (Big-Step Semantics) ### *)

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
Could use do-notation to clean up syntax.
*)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | tvar x       => Some (indexr x env)
        | ttyp T       => Some (Some (vty env T))
        | tabs T y     => Some (Some (vabs env T y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vabs env2 _ ey)) =>
                  teval n (vx::env2) ey
              end
          end
        | tunpack ex ey =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              teval n (vx::env) ey
          end
      end
  end.

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

(* ------------------------- NOTES -------------------------
Define value typing (val_type)
val_type0 cannot straightforwardly be defined as inductive
family, because the (forall vx, val_type0 env vx T1 -> ... )
occurrence violates the positivity restriction.
--------------------------------------------------------- *)

Fixpoint tsize_flat(T: ty) :=
  match T with
    | TTop => 1
    | TBot => 1
    | TAll T1 T2 => S (tsize_flat T1 + tsize_flat T2)
    | TSel _ => 1
    | TMem T1 T2 => S (tsize_flat T1 + tsize_flat T2)
    | TBind T => S (tsize_flat T)
    | TAnd T1 T2 => S (tsize_flat T1 + tsize_flat T2)
  end.

Lemma open_preserves_size: forall T x j,
  tsize_flat T = tsize_flat (open_rec j (varH x) T).
Proof.
  intros T. induction T; intros; simpl; eauto.
  - destruct v; simpl; destruct (beq_nat j i); eauto.
Qed.

(* NEW DESIGN IDEA:

   The required invariants about runtime evaluation rely in crucial
   ways on transporting properties from the creation site of
   type objects to their use sites -- in particular the fact
   that only type aliased can be created (TMem T T), and that these
   cannot be recursive.

   This suggests that in the proof, we should pair each (vty T) value
   with the semantic interpretation of the type member [[ T ]].

   So [[ T ]] in general is no longer a set of values, but a set of
   (vl, vset) pairs. This leads to some complication as the type vset
   is now recursive:

      Definition vset := vset -> vl -> Prop.

   which Coq wouldn't let us do (for good reasons).

   It seems like the best we can do is an indexed variant such that

    vset (S n) := vset n -> vl -> Prop

   and quantify over n to denote all finite ones.

   As it turns out, we no longer need the previuos l/u bound selectors,
   and the TMem case can ensure that the *actual* type member of an
   object is inbetween the given bounds. This enables the case for
   intersection types.

   For TBind, there is still some uncertainty.

*)

Fixpoint vset n := match n with
                     | 0 => vl -> Prop
                     | S n => vset n -> vl -> Prop
                   end.

Definition vseta := forall n, vset n.

(* this is just a helper for pattern matching *)
Inductive vset_match : nat -> Type :=
| vsmatch: forall n, vset n -> list (vset (S n)) -> list (vset (S n)) -> vset_match n
.

Require Coq.Program.Wf.

Lemma minus1 {k} : k < (S k). omega. Qed.

Lemma approx {j k} (a: j < k): vset k -> vset j.
Proof. admit. Qed.

Lemma approx_env { j k } (a: j < k) :  list (vset k) ->  list (vset j).
Proof. admit. Qed.

Program Fixpoint val_type n (env: list (vset (S n))) (GH:list (vset (S n))) (T:ty) (dd: vset n) (v:vl) {measure (tsize_flat T)}: Prop :=
  match v,T with
    | vabs env1 T0 y, TAll T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 1 (length GH) (length env) T2 /\
      forall jj vx,
        (forall kx (a: (S kx < S n)),
           val_type kx (approx_env a env) (approx_env a GH) T1 (jj kx) vx) ->
        exists (jj2:vseta) v, tevaln (vx::env1) y v /\
          (forall k (a: (S k < S n)),
             val_type k (approx_env a env) (jj (S k)::(approx_env a GH)) (open (varH (length GH)) T2) (jj2 k) v)

    | vty env1 TX, TMem T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 0 (length GH) (length env) T2 /\
      match (vsmatch n dd env GH) with
        | vsmatch 0 _ _ _ => True
        | vsmatch (S n0) dd env GH  => forall dy vy,
                      (val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T1 dy vy -> dd dy vy) /\
                      (dd dy vy -> val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T2 dy vy)
      end

    | _, TSel (varF x) =>
      match indexr x env with
        | Some jj => jj dd v
        | _ => False
      end
    | _, TSel (varH x) =>
      match indexr x GH with
        | Some jj => jj dd v
        | _ => False
      end

    | _, TAnd T1 T2 =>
      val_type n env GH T1 dd v /\ val_type n env GH T2 dd v

    | _, TBind T1 =>
       closed 1 (length GH) (length env) T1 /\
      (* NOTE: need to investigate this more. Ideally we would like to express:

          val_type env (dd::GH) (open (varH (length GH)) T1) n (dd n) v

         But this would require dd to be of type vseta instead of vset n.
         If we change the signature to dd:vseta, however, then we run into
         trouble with lemma valtp_to_vseta.

      *)

      exists jj:vset (S n), approx minus1 jj = dd /\ val_type n env (jj::GH) (open (varH (length GH)) T1) dd v
    | _, TTop =>
      True
    | _,_ =>
      False
  end.

Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. unfold open. rewrite <-open_preserves_size. omega. Qed. (* TApp case: open *)
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. omega. Qed.
Next Obligation. simpl. unfold open. rewrite <-open_preserves_size. omega. Qed. (* TApp case: open *)

Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.
Next Obligation. compute. repeat split; intros; destruct H; inversion H; inversion H0; inversion H1. Qed.

(*
   The expansion of val_type, val_type_func is incomprehensible.
   We cannot (easily) unfold and reason about it. Therefore, we prove unfolding of
   val_type to its body as a lemma.
   (Note that the unfold_sub tactic relies on
   functional extensionality)
*)

Import Coq.Program.Wf.
Import WfExtensionality.

Lemma val_type_unfold: forall n env GH T dd v, val_type n env GH T dd v =
  match v,T with
    | vabs env1 T0 y, TAll T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 1 (length GH) (length env) T2 /\
      forall jj vx,
        (forall kx (a: (S kx < S n)),
           val_type kx (approx_env a env) (approx_env a GH) T1 (jj kx) vx) ->
        exists (jj2:vseta) v, tevaln (vx::env1) y v /\
          (forall k (a: (S k < S n)),
             val_type k (approx_env a env) (jj (S k)::(approx_env a GH)) (open (varH (length GH)) T2) (jj2 k) v)

    | vty env1 TX, TMem T1 T2 =>
      closed 0 (length GH) (length env) T1 /\ closed 0 (length GH) (length env) T2 /\
      match (vsmatch n dd env GH) with
        | vsmatch 0 _ _ _ => True
        | vsmatch (S n0) dd env GH  => forall dy vy,
                      (val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T1 dy vy -> dd dy vy) /\
                      (dd dy vy -> val_type n0 (approx_env minus1 env) (approx_env minus1 GH) T2 dy vy)
      end

    | _, TSel (varF x) =>
      match indexr x env with
        | Some jj => jj dd v
        | _ => False
      end
    | _, TSel (varH x) =>
      match indexr x GH with
        | Some jj => jj dd v
        | _ => False
      end

    | _, TAnd T1 T2 =>
      val_type n env GH T1 dd v /\ val_type n env GH T2 dd v

    | _, TBind T1 =>
       closed 1 (length GH) (length env) T1 /\
      (* NOTE: need to investigate this more. Ideally we would like to express:

          val_type env (dd::GH) (open (varH (length GH)) T1) n (dd n) v

         But this would require dd to be of type vseta instead of vset n.
         If we change the signature to dd:vseta, however, then we run into
         trouble with lemma valtp_to_vseta.

      *)

      exists jj:vset (S n), approx minus1 jj = dd /\ val_type n env (jj::GH) (open (varH (length GH)) T1) dd v
    | _, TTop =>
      True
    | _,_ =>
      False
  end.

Proof. admit.
Qed.

(* this is just to accelerate Coq -- val_type in the goal is slooow *)
Inductive vtp: forall n, list (vset (S n)) -> list (vset (S n)) -> ty -> vset n -> vl -> Prop :=
| vv: forall n G H T dd v, val_type n G H T dd v -> vtp n G H T dd v.

Lemma unvv: forall n G H T dd v,
  vtp G H T n dd v -> val_type G H T n dd v.
Proof. admit. (*PERF

Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Arith.Peano_dec.

intros. inversion H0. apply inj_pair2_eq_dec in H2. subst. assumption.
apply eq_nat_dec. *)
Qed.

(* consistent environment *)
Definition R_env n venv genv tenv :=
  length venv = length tenv /\
  length genv = length tenv /\
  forall x TX, indexr x tenv = Some TX ->
    (exists jj vx,
       indexr x venv = Some vx /\
       indexr x genv = Some jj /\
       vtp n genv [] TX (approx minus1 jj) vx).

(* automation *)
Hint Unfold venv.
Hint Unfold tenv.

Hint Unfold open.
Hint Unfold indexr.
Hint Unfold length.

(* Hint Unfold R. *)
Hint Unfold R_env.

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

Hint Constructors closed.
Hint Constructors has_type.
Hint Constructors stp.

Hint Constructors option.
Hint Constructors list.

Hint Resolve ex_intro.

(* ############################################################ *)
(* Proofs *)
(* ############################################################ *)

Lemma invert_var : forall x tenv T,
  has_type tenv (tvar x) T -> forall n venv renv, R_env n venv renv tenv ->
  exists d v, tevaln venv (tvar x) v /\ indexr x venv = Some v /\ indexr x renv = Some d/\ val_type n renv [] T (approx minus1 d) v.
Proof.
  intros ? ? ? W. remember (tvar x) as e.
  induction W; intros ? ? ? WFE; inversion Heqe; try subst x0.

  - Case "Var".
    unfold R_env in WFE. destruct WFE as [? [? F]].
    destruct (F _ _ H) as [d [v [I [D V]]]].

    exists d. exists v. split. exists 0. intros. destruct n0. omega. simpl. rewrite I. eauto. split. apply I. split. apply D. eapply unvv. eapply V.

  - Case "VarPack".
    unfold R_env in WFE. destruct WFE as [? [? F]].
    destruct (F _ _ H) as [d [v [I [D V]]]].
    exists d. exists v. split. exists 0. intros. destruct n0. omega. simpl. rewrite I. reflexivity.
    split. assumption. split. assumption.
    rewrite val_type_unfold.
    destruct v. split. rewrite H3. assumption.
    exists d. eapply unvv in V. admit. (* subst *)
    admit. (* vty like vabs *)

  - Case "VarUnpack".
    unfold R_env in WFE. destruct WFE as [? [? F]].
    destruct (F _ _ H) as [d [v [I [D V]]]].
    exists d. exists v. split. exists 0. intros. destruct n0. omega. simpl. rewrite I. reflexivity.
    split. assumption. split. assumption.
    eapply unvv in V. rewrite val_type_unfold in V. eapply unvv.
    destruct v. destruct V as [? [d2 V]].

    (* HAVE *)
    assert (val_type n renv [d2] (open (varH 0) T1) (approx minus1 d) (vabs l t t0)). apply V. clear H5.
    (* NEED *)
    assert (val_type n renv [d] (open (varH 0) T1) (approx minus1 d) (vabs l t t0)).

    assert (open (varH 0) T1 = (TSel (varH 0))). admit. (* problem case *)
    simpl in V. rewrite H5 in *. rewrite val_type_unfold in V.
    rewrite val_type_unfold. simpl in V. simpl. destruct V as [V1 V2].

    (* HAVE *)
    assert (approx minus1 d2 = approx minus1 d). apply V1. clear H6.
    assert (d2 (approx minus1 d) (vabs l t t0)). apply V2. clear H6.
    (* NEED *)
    assert (d (approx minus1 d) (vabs l t t0)). admit.

    (* UNCLEAR how to do this, unless we could derive d2 = d1 from (approx d2) = (approx d1) *)
    admit.
    admit.
    admit.

  - Case "And".
    admit.

  - Case "Sub".
    admit.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia Max.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils enumerable
                 fol_ops fo_sig fo_terms fo_logic fo_enum decidable
                 fo_sat fo_sat_dec red_utils.

Set Default Proof Using "Type".

Set Implicit Arguments.

(* * Collection of high-level enumerability results *)

Section FSAT_enumerable.

  Variable (Σ : fo_signature).

  Implicit Type (A : fol_form Σ).

  Theorem FSAT_FSAT_in_pos A : FSAT Σ A <-> exists n, fo_form_fin_dec_SAT_in A (pos n).
  Proof.
    rewrite fo_form_fin_dec_SAT_discr_equiv.
    apply fo_form_fin_discr_dec_SAT_pos.
  Qed.

  Hypothesis (H1 : discrete (syms Σ))
             (H2 : discrete (rels Σ)).

  Let dec n A : decidable (fo_form_fin_dec_SAT_in A (pos n)).
  Proof. apply FSAT_in_dec; auto; apply finite_t_pos. Qed.

  Theorem FSAT_rec_enum_t : rec_enum_t (FSAT Σ).
  Proof using H2 H1.
    exists (fun n A => if dec n A then true else false).
    intros A.
    rewrite FSAT_FSAT_in_pos.
    apply exists_equiv; intros n.
    destruct (dec n A); split; auto; discriminate.
  Qed.

  Hypothesis (H3 : type_enum_t (syms Σ)).
  Hypothesis (H4 : type_enum_t (rels Σ)).

  Theorem FSAT_opt_enum_t : opt_enum_t (FSAT Σ).
  Proof using H4 H3 H2 H1.
    generalize FSAT_rec_enum_t.
    apply rec_enum_opt_enum_type_enum_t.
    apply type_enum_t_fol_form; auto.
  Qed.

End FSAT_enumerable.


(** Solutions to "Elements of Set Theory" Chapter 7 **)
(** Coq coding by choukh, Dec 2020 **)

Require Import ZFC.Elements.EST7_4.
Require Import ZFC.Lib.FuncFacts.
Require Import ZFC.Lib.Real.
Require Import ZFC.Lib.NatIsomorphism.
Close Scope Real_scope.

(* ex7_10 see EST7_3 Example α_nat, α_ω *)

Module EX7_11.
Open Scope Int_scope.

Definition IntLtWo := BinRel ℤ (λ a b,
  match (ixm (intNeg a)) with
    | inl _ =>
      match (ixm (intNeg b)) with
        | inl _ => b <𝐳 a
        | inr _ => False
      end
    | inr _ =>
      match (ixm (intNeg b)) with
        | inl _ => True
        | inr _ => a <𝐳 b
      end
  end
).

Lemma intLtWo_irrefl : irrefl IntLtWo.
Proof.
  intros a Haa.
  apply binRelE3 in Haa.
  destruct (ixm (intNeg a));
  eapply intLt_irrefl; eauto.
Qed.

Lemma intLtWo_trans : tranr IntLtWo.
Proof.
  intros a b c Hab Hbc.
  apply binRelE2 in Hab as [Ha [Hb Hab]].
  apply binRelE2 in Hbc as [_  [Hc Hbc]].
  apply binRelI; auto;
  destruct (ixm (intNeg a));
  destruct (ixm (intNeg b));
  destruct (ixm (intNeg c)); try tauto;
  eapply intLt_trans; eauto.
Qed.

Lemma intLtWo_connected : connected IntLtWo ℤ.
Proof with auto; try congruence.
  intros a Ha b Hb Hnq.
  destruct (classic (intNeg a)) as [Hna|Hpa];
  destruct (classic (intNeg b)) as [Hnb|Hpb].
  - apply intLt_connected in Hnq as []...
    + right. apply binRelI...
      destruct (ixm (intNeg a)); destruct (ixm (intNeg b))...
    + left. apply binRelI...
      destruct (ixm (intNeg a)); destruct (ixm (intNeg b))...
  - right. apply binRelI...
    destruct (ixm (intNeg a)); destruct (ixm (intNeg b))...
  - left. apply binRelI...
    destruct (ixm (intNeg a)); destruct (ixm (intNeg b))...
  - apply intLt_connected in Hnq as []...
    + left. apply binRelI...
      destruct (ixm (intNeg a)); destruct (ixm (intNeg b))...
    + right. apply binRelI...
      destruct (ixm (intNeg a)); destruct (ixm (intNeg b))...
Qed.

Lemma intLtWo_trich : trich IntLtWo ℤ.
Proof.
  eapply trich_iff. apply binRel_is_binRel.
  apply intLtWo_trans. split.
  apply intLtWo_irrefl. apply intLtWo_connected.
Qed.

Lemma intLtWo_loset : loset ℤ IntLtWo.
Proof.
  split. apply binRel_is_binRel. split.
  apply intLtWo_trans. apply intLtWo_trich.
Qed.

Definition NonNegInt := {a ∊ ℤ | Int 0 ≤ a}.
Notation "ℤ⁰⁺" := NonNegInt.

Definition PosInt := {a ∊ ℤ | intPos a}.
Notation "ℤ⁺" := PosInt.

Definition NegInt := {a ∊ ℤ | intNeg a}.
Notation "ℤ⁻" := NegInt.

Section ImportOrderedStruct.
Import OrderedStruct.

Definition LtStruct :=
  constr ω Lt (memberRel_is_binRel _).
Definition NonNegIntLtStruct :=
  constr ℤ⁰⁺ (IntLt ⥏ ℤ⁰⁺) (subRel_is_binRel _ _).

Definition PosIntLtStruct :=
  constr ℤ⁺ (IntLt ⥏ ℤ⁺) (subRel_is_binRel _ _).
Definition NegIntLtStruct :=
  constr ℤ⁻ (IntLt ⥏ ℤ⁻)⁻¹ (inv_binRel _ _ (subRel_is_binRel _ _)).

Lemma ω_embed_ran_nn : ∀n ∈ ω, ω_Embed[n] ∈ ℤ⁰⁺.
Proof with eauto.
  intros n Hn. apply SepI.
  - eapply ap_ran... apply ω_embed_function.
  - ω_destruct n.
    + right. rewrite <- zero, ω_embed...
    + left. rewrite suc_isomorphic_ω, ω_embed... apply intPos_sn.
Qed.

Lemma ω_embed_bijective : ω_Embed: ω ⟺ ℤ⁰⁺.
Proof with neauto; try congruence.
  apply bijection_is_func.
  destruct ω_embed_function as [Hf [Hd Hr]].
  assert (Hrz: ran ω_Embed ⊆ ℤ⁰⁺). {
    intros a Ha.
    apply ranE in Ha as [n Hp]. apply domI in Hp as Hn.
    apply func_ap in Hp... subst a. rewrite Hd in Hn.
    apply ω_embed_ran_nn...
  }
  split. split... split. apply ω_embed_injective.
  apply sub_antisym... intros a Ha.
  apply SepE in Ha as [Ha [Hp|H0]].
  + apply pQuotE in Ha as [m [Hm [n [Hn Ha]]]]. subst a.
    rewrite ω_embed_subtr in Hp...
    rewrite <- (intAddInv_annih (ω_Embed[n])) in Hp;
      [|apply ω_embed_ran]...
    apply intAdd_preserve_lt in Hp;
      [..|apply intAddInv_ran]; [|apply ω_embed_ran..]...
    apply ω_embed_lt in Hp...
    apply nat_subtr' in Hp as [d [Hdz [Hsum _]]]...
    apply (ranI _ d). apply func_point...
    rewrite ω_embed_n... apply int_ident...
    rewrite add_comm, add_0_r...
  + subst a. apply (ranI _ 0). apply func_point...
    rewrite Hd... rewrite ω_embed...
Qed.

Lemma iso_Lt_nonNegIntLt : LtStruct ≅ NonNegIntLtStruct.
Proof with auto.
  exists ω_Embed. simpl. split. apply ω_embed_bijective.
  intros n Hn m Hm. split; intros Hlt.
  - apply SepI. apply binRelE3 in Hlt.
    apply ω_embed_lt in Hlt...
    apply CPrdI; apply ω_embed_ran_nn...
  - apply binRelI... apply ω_embed_lt...
    apply SepE1 in Hlt...
Qed.

Lemma nonNegInt_woset : woset ℤ⁰⁺ (IntLt ⥏ ℤ⁰⁺).
Proof.
  cut (wo NonNegIntLtStruct). auto.
  eapply iso_wo. apply iso_Lt_nonNegIntLt.
  apply Lt_wellOrder.
Qed.

Lemma posInt_woset : woset ℤ⁺ (IntLt ⥏ ℤ⁺).
Proof with auto.
  assert (Hsub: ℤ⁺ ⊆ ℤ⁰⁺). {
    intros a Ha. apply SepE in Ha as [Ha Hpa]. apply SepI...
  }
  replace (IntLt ⥏ ℤ⁺) with (IntLt ⥏ ℤ⁰⁺ ⥏ ℤ⁺).
  eapply subRel_woset. apply nonNegInt_woset. apply Hsub.
  rewrite subRel_absorption...
Qed.

Lemma intAddInv_bijective : (Func ℤ⁺ ℤ⁻ IntAddInv): ℤ⁺ ⟺ ℤ⁻.
Proof with auto; try congruence.
  apply meta_bijection.
  - intros a Ha. apply SepE in Ha as [Ha Hpos].
    apply SepI. apply intAddInv_ran... apply intPos_neg...
  - intros a Ha b Hb Heq.
    apply SepE1 in Ha. apply SepE1 in Hb.
    rewrite <- (intAddInv_double a), <- (intAddInv_double b)...
  - intros b Hb. apply SepE in Hb as [Hb Hneg].
    exists (-b). split. apply SepI. apply intAddInv_ran...
    apply intNeg_pos... apply intAddInv_double...
Qed.

Lemma iso_posIntLt_negIntLt : PosIntLtStruct ≅ NegIntLtStruct.
Proof with auto; try congruence.
  set (Func ℤ⁺ ℤ⁻ IntAddInv) as f.
  pose proof intAddInv_bijective as Hf.
  exists f. simpl. split...
  intros a Ha b Hb. split; intros Hlt.
  - apply SepE in Hlt as [Hlt _].
    unfold relLt, NegIntLtStruct.
    simpl. rewrite <- inv_op.
    unfold f. rewrite meta_func_ap, meta_func_ap;
      auto; [|apply bijection_is_func..]...
    apply SepE in Ha as [Ha Hpa].
    apply SepE in Hb as [Hb Hpb].
    apply SepI. apply intLt_addInv in Hlt...
    apply CPrdI; (apply SepI;
      [apply intAddInv_ran|apply intPos_neg])...
  - unfold relLt, NegIntLtStruct in Hlt.
    simpl in Hlt. rewrite <- inv_op in Hlt.
    apply SepE in Hlt as [Hlt _].
    unfold f in Hlt. rewrite meta_func_ap, meta_func_ap in Hlt;
      auto; [|apply bijection_is_func..]...
    apply SepE in Ha as [Ha Hpa].
    apply SepE in Hb as [Hb Hpb].
    apply SepI. apply intLt_addInv...
    apply CPrdI; apply SepI...
Qed.

Lemma negInt_woset : woset ℤ⁻ (IntLt ⥏ ℤ⁻)⁻¹.
Proof with auto.
  cut (wo NegIntLtStruct)...
  eapply iso_wo. apply iso_posIntLt_negIntLt.
  apply posInt_woset.
Qed.

Theorem intLtWo_woset : woset ℤ IntLtWo.
Proof with neauto; try congruence.
  split. apply intLtWo_loset.
  intros Z Hne Hsub.
  set {a ∊ Z | Int 0 ≤ a} as Z'.
  destruct (classic (⦿ Z')) as [Hne'|He].
  - destruct nonNegInt_woset as [_ Hmin].
    specialize Hmin with Z' as [m [Hm Hmin]]... {
      intros a Ha. apply SepE in Ha as [Ha Hnn].
      apply Hsub in Ha. apply SepI...
    }
    apply SepE in Hm as [Hm Hnn].
    exists m. split... intros a Ha.
    apply Hsub in Hm as Hmz. apply Hsub in Ha as Haz.
    destruct (classic (m = a)) as [Heqm|Hnqm]. right... left.
    apply binRelI; [apply Hsub..|]...
    destruct (ixm (intNeg m));
    destruct (ixm (intNeg a))...
    + exfalso. apply intNonNeg_iff in Hnn...
    + apply intNonNeg_iff in Hnn...
    + assert (a ∈ Z'). { apply SepI... apply intNonNeg_iff... }
      apply Hmin in H as []... apply SepE1 in H...
  - assert (Hneg: Z ⊆ ℤ⁻). {
      intros a Ha. apply Hsub in Ha as Haz.
      destruct (classic (intNeg a))... apply SepI...
      exfalso. apply He. exists a. apply SepI... apply intNonNeg_iff...
    }
    destruct negInt_woset as [_ Hmin].
    specialize Hmin with Z as [m [Hm Hmin]]...
    exists m. split... intros a Ha.
    apply Hsub in Hm as Hmz. apply Hsub in Ha as Haz.
    apply Hneg in Ha as Ha'. apply SepE2 in Ha'.
    destruct (classic (m = a)) as [Heqm|Hnqm]. right... left.
    apply binRelI; [apply Hsub..|]...
    destruct (ixm (intNeg m));
    destruct (ixm (intNeg a))...
    apply Hmin in Ha as []...
    rewrite <- inv_op in H. apply SepE1 in H...
Qed.

End ImportOrderedStruct.

Lemma int_0_not_neg : intNeg (Int 0) → False.
Proof. intros. eapply intLt_irrefl; eauto. Qed.

Lemma int_1_not_neg : intNeg (Int 1) → False.
Proof.
  intros. assert (intPos (Int 1)) by apply intPos_sn.
  eapply intLt_irrefl; eapply intLt_trans; eauto.
Qed.

Lemma int_sn_not_neg : ∀ n, intNeg (Int (S n)) → False.
Proof.
  intros. assert (intPos (Int (S n))) by apply intPos_sn.
  eapply intLt_irrefl; eapply intLt_trans; eauto.
Qed.

Lemma int_n_not_neg : ∀ n, intNeg (Int n) → False.
Proof with eauto.
  intros. destruct n.
  apply int_0_not_neg... eapply int_sn_not_neg...
Qed.

Lemma int_0_minimum : ∀a ∈ ℤ, ¬ (a <ᵣ Int 0) IntLtWo.
Proof.
  intros a Ha Hlt.
  apply binRelE3 in Hlt.
  destruct (ixm (intNeg a)); destruct (ixm (intNeg (Int 0)));
  auto; apply int_0_not_neg; auto.
Qed.

Import WoStruct.
Import WoStruct.EpsilonImage.

Definition ℤWoS := constr ℤ IntLtWo intLtWo_woset.
Definition E := E ℤWoS.

Fact e_int_0 : E[Int 0] = 0.
Proof with neauto.
  ext Hx; [|exfalso0].
  apply e_elim in Hx...
  destruct Hx as [s [Hs [Hlt _]]].
  exfalso. eapply int_0_minimum...
Qed.

Fact e_int_1 : E[Int 1] = 1.
Proof with neauto; try congruence.
  pose proof int_0_not_neg as H0nn.
  pose proof int_1_not_neg as H1nn.
  ext Hx.
  - apply e_elim in Hx...
    destruct Hx as [s [Hs [Hlt [Heq _]]]].
    destruct (classic (s = Int 0)). {
      subst. fold E. rewrite e_int_0. apply BUnionI2...
    }
    apply intLtWo_connected in H as []... {
      exfalso. eapply int_0_minimum...
    }
    apply binRelE2 in H. apply binRelE2 in Hlt.
    destruct (ixm (intNeg (Int 0)));
    destruct (ixm (intNeg (Int 1)));
    destruct (ixm (intNeg s))... tauto.
    destruct Hlt as [_ [_ H1]]. destruct H as [_ [_ H2]].
    exfalso. apply intLt_iff_le_suc in H2...
    rewrite intAdd_0_l in H2...
    destruct H2; eapply intLt_irrefl.
    eapply intLt_trans... subst...
  - apply BUnionE in Hx as []. exfalso0.
    apply SingE in H. subst x.
    eapply (e_intro _ _ (Int 0))...
    + apply binRelI...
      destruct (ixm (intNeg (Int 0)));
      destruct (ixm (intNeg (Int 1)))... apply intPos_sn.
    + fold E. rewrite e_int_0...
Qed.

Fact e_int_n : ∀ n, E[Int n] = n.
Proof with neauto; try congruence; try tauto.
  induction n. apply e_int_0.
  pose proof (int_n_not_neg n) as Hnnn.
  pose proof (int_sn_not_neg n) as Hnnsn.
  ext Hx.
  - apply e_elim in Hx...
    destruct Hx as [s [Hs [Hlt [Heq _]]]]. subst x. fold E.
    apply binRelE3 in Hlt.
    destruct (ixm (intNeg s));
    destruct (ixm (intNeg (Int (S n))))...
    destruct ω_embed_bijective as [[Hf _] [Hd Hr]].
    assert (Hsr: s ∈ ran ω_Embed). {
      rewrite Hr. apply SepI... apply intNonNeg_iff...
    }
    apply ranE in Hsr as [m Hp].
    apply domI in Hp as Hm. apply func_ap in Hp... subst s.
    rewrite <- ω_embed in Hlt... apply ω_embed_lt in Hlt...
    rewrite suc_isomorphic_n, embed_proj_id in *;
      [|apply ω_inductive; apply embed_ran..].
    apply BUnionE in Hlt as [].
    + apply BUnionI1.
      rewrite <- (embed_proj_id m), ω_embed, <- IHn...
      apply e_ap_order... apply binRelI...
      destruct (ixm (intNeg (Int m)));
      destruct (ixm (intNeg (Int n)))...
      eapply int_n_not_neg... eapply intLtI...
      rewrite add_0_r, add_0_r, (embed_proj_id m)...
    + apply SingE in H. rewrite H, ω_embed, IHn...
  - assert (Hnsn: Int n <𝐳 Int (S n)). {
      apply intLtI... rewrite add_0_r, add_0_r...
      rewrite suc_isomorphic_n, embed_proj_id...
      apply ω_inductive. apply embed_ran.
    }
    rewrite suc_isomorphic_n, embed_proj_id in Hx;
      [|apply ω_inductive; apply embed_ran].
    apply BUnionE in Hx as [].
    + rewrite <- IHn in H.
      apply e_elim in H...
      destruct H as [s [Hs [Hlt [Heq _]]]].
      eapply e_intro...
      apply binRelE3 in Hlt.
      apply binRelI...
      destruct (ixm (intNeg s));
      destruct (ixm (intNeg (Int n)));
      destruct (ixm (intNeg (Int (S n))))...
      eapply intLt_trans...
    + apply SingE in H. subst x. rewrite <- IHn.
      apply (e_intro _ _ (Int n))...
      apply binRelI...
      destruct (ixm (intNeg (Int n)));
      destruct (ixm (intNeg (Int (S n))))...
Qed.

Fact e_int_n1 : E[-Int 1] = ω.
Proof with neauto.
  ext Hx.
  - apply e_elim in Hx...
    destruct Hx as [s [Hs [Hlt [Heq _]]]]. fold E in Heq.
    apply binRelE3 in Hlt.
    destruct (ixm (intNeg s)) as [Hns|Hnns];
    destruct (ixm (intNeg (-Int 1))) as [Hnn1|Hnnn1].
    + apply intLt_iff_le_suc in Hlt...
      rewrite intAdd_comm, intAddInv_annih in Hlt...
      apply intNonNeg_iff in Hlt...
      apply intNonNeg_ex_nat in Hlt as [n Heqs]... subst s.
      rewrite e_int_n in Heq. subst x...
    + tauto.
    + apply intNonNeg_ex_nat in Hnns as [n Heqs]... subst s.
      rewrite e_int_n in Heq. subst x...
    + exfalso. assert (intNeg (-Int 1)) by nauto...
  - eapply (e_intro _ _ (Int x))...
    + apply binRelI...
      destruct (ixm (intNeg (Int x))) as [Hnx|Hnnx];
      destruct (ixm (intNeg (-Int 1))) as [Hnn1|Hnnn1]...
      * exfalso. apply intLt in Hnx...
        rewrite add_0_r, add_0_r in Hnx... exfalso0.
      * exfalso. assert (intNeg (-Int 1)) by nauto...
    + rewrite e_int_n, embed_proj_id...
Qed.

Lemma intAdd_n2_n : - Int 2 + Int 1 = - Int 1.
Proof with nauto.
  unfold Int. rewrite intAddInv, intAddInv,
    intAdd_m_n_p_q, add_0_r, add_0_l...
  apply int_ident... rewrite add_0_l, add_1_1...
Qed.

Fact e_int_n2 : E[-Int 2] = ω⁺.
Proof with neauto; try congruence.
  pose proof intLtWo_woset as Hwo.
  ext Hx.
  - apply e_elim in Hx...
    destruct Hx as [s [Hs [Hlt [Heq _]]]]. fold E in Heq.
    apply binRelE3 in Hlt.
    destruct (ixm (intNeg s)) as [Hns|Hnns];
    destruct (ixm (intNeg (-Int 2))) as [Hnn2|Hnnn2].
    + apply intLt_iff_le_suc in Hlt as []; nauto;
      rewrite intAdd_n2_n in H.
      * apply intLt_iff_le_suc in H...
        rewrite intAdd_comm, intAddInv_annih in H...
        apply intNonNeg_iff in H...
      * subst s x. rewrite e_int_n1...
    + tauto.
    + apply intNonNeg_ex_nat in Hnns as [n Heqs]...
      subst s x. rewrite e_int_n. apply BUnionI1...
    + assert (intNeg (- Int 2))...
  - apply BUnionE in Hx as [Hx|Hx].
    + eapply (e_intro _ _ (Int x)); revgoals...
      fold E. rewrite e_int_n, embed_proj_id... apply binRelI...
      destruct (ixm (intNeg (Int x))) as [Hnx|Hnnx];
      destruct (ixm (intNeg (-Int 2))) as [Hnn2|Hnnn2]...
      * exfalso. eapply int_n_not_neg...
      * assert (intNeg (- Int 2))...
    + apply SingE in Hx. subst x.
      eapply (e_intro _ _ (-Int 1)); revgoals...
      fold E. rewrite e_int_n1... apply binRelI...
      destruct (ixm (intNeg (-Int 1))) as [Hnn1|Hnnn1];
      destruct (ixm (intNeg (-Int 2))) as [Hnn2|Hnnn2]...
      * unfold Int. rewrite intAddInv, intAddInv...
        apply intLt... rewrite add_0_l, add_0_l...
        apply suc_has_n.
      * assert (intNeg (- Int 2))...
Qed.

End EX7_11.

(* ex7_12 see EST7_3 Module ImageRel *)
(* ex7_13 see EST7_3 Theorem wo_iso_unique *)

Section EX7_14.
Import OrderedStruct.

Let head := λ x S, head x (A S) (R S).

Example ex7_14 : ∀ S, po S →
  let F := Func (A S) (𝒫 (A S)) (λ x, head x S) in
  let T := constr (ran F) (SubsetRel (ran F)) (subsetRel_is_binRel _) in
  F:ₒₑ S ⟺ T.
Proof with eauto.
  intros * [_ [_ [Htr Hir]]] F T.
  assert (HfP: F: A S ⇔ (𝒫 (A S))). {
    apply meta_injection.
    + intros x Hx. apply PowerAx. intros t Ht.
      apply SepE1 in Ht...
    + intros x1 Hx1 x2 Hx2 Heq.
      assert (H1: x1 ∈ head x1 S). { apply SepI... right... }
      assert (H2: x2 ∈ head x2 S). { apply SepI... right... }
      rewrite Heq in H1. apply SepE2 in H1 as []...
      rewrite <- Heq in H2. apply SepE2 in H2 as []...
      exfalso. eapply Hir. eapply Htr...
  }
  assert (HfS: F: A S ⟺ A T). {
    destruct HfP as [Hif [Hd _]]. split...
  }
  split...
  apply bijection_is_func in HfS as [HfS _].
  apply injection_is_func in HfP as [HfP _].
  intros x Hx y Hy. split; intros Hxy.
  - apply binRelI. eapply ap_ran... eapply ap_ran... split.
    + intros a Ha. unfold F.
      rewrite meta_func_ap... apply SepI.
      * destruct HfP as [Hf [Hd Hr]]. rewrite <- Hd in Hx.
        apply func_correct in Hx... apply ranI in Hx.
        apply Hr in Hx. apply PowerAx in Hx. apply Hx...
      * unfold F in Ha. rewrite meta_func_ap in Ha...
        apply SepE2 in Ha. left. eapply relLe_lt_trans...
    + unfold F. rewrite meta_func_ap, meta_func_ap... intros Heq.
      assert (y ∈ head y S). { apply SepI... right... }
      rewrite <- Heq in H. apply SepE2 in H as []...
      * eapply Hir. eapply Htr...
      * eapply Hir. subst...
  - apply binRelE3 in Hxy as [Hsub Hnq].
    assert (x ∈ F[x]). {
      unfold F. rewrite meta_func_ap...
      apply SepI... right...
    }
    apply Hsub in H.
    unfold F in H. rewrite meta_func_ap in H...
    apply SepE in H as [_ []]... exfalso. congruence.
Qed.

End EX7_14.

Import WoStruct.
Import WoStruct.EpsilonImage.

(* ex7_15_a 良序结构不与自身的任意前节同构 *)
Lemma wo_not_iso_seg : ∀ S, ∀t ∈ A S, S ≇ Seg t S.
Proof with eauto.
  intros S t Ht Hiso.
  apply ord_well_defined in Hiso.
  apply (ord_irrefl (ord S))...
  rewrite Hiso at 1. eapply ordI...
  symmetry. apply seg_α...
Qed.

(* ex7_15_b 良序结构的同构关系具有至多三歧性 *)
Theorem wo_iso_at_most_trich : ∀ S T,
  at_most_trich (∃t ∈ A S, Seg t S ≅ T) (S ≅ T) (∃t ∈ A T, S ≅ Seg t T).
Proof with eauto.
  repeat split.
  - intros [[t [Ht H1]] H2].
    eapply wo_not_iso_seg... rewrite H1...
  - intros [[t [Ht H1]] H2].
    eapply wo_not_iso_seg... rewrite <- H1. symmetry...
  - intros [[s [Hs H1]] [t [Ht H2]]].
    apply ord_well_defined in H1.
    apply ord_well_defined in H2.
    rewrite seg_α in H1, H2...
    apply ordI in H1... symmetry in H2.
    apply ordI in H2...
    apply (ord_irrefl (ord S))... eapply ord_trans...
Qed.

(* ex7_16_1 see EST7_4 Lemma ord_suc_preserve_lt *)
(* ex7_16_2 see EST7_4 Lemma ord_suc_injective *)

(* ex7_17 子结构的序数小于等于原结构的序数 *)
Theorem ord_of_sub_struct_le : ∀ S T, S ⊑ T → ord S ⋸ ord T.
Proof with eauto.
  intros * [Has Hrs].
  destruct (classic (ord S = ord T))...
  apply ord_connected in H as []... exfalso.
  apply ord_lt_elim in H as [t [Ht [f [Hf Hoe]]]].
  apply bijection_is_func in Hf as [Hf _].
  destruct (wo S) as [Hlo Hmin].
  set {x ∊ A S | (f[x] <ᵣ x) (R S)} as B.
  pose proof (Hmin B) as [m [Hm Hle]].
  - exists t. apply SepI...
    assert (Hft: f[t] ∈ A (Seg t S)). eapply ap_ran...
    apply SepE2 in Hft...
  - intros x Hx. apply SepE1 in Hx...
  - apply SepE in Hm as [Hm Hlt]. apply Has in Hm.
    assert (Hsub: A (Seg t S) ⊆ A S). {
      intros x Hx. apply SepE1 in Hx...
    }
    assert (Hfm: f[m] ∈ A S). {
      apply Hsub. eapply ap_ran...
    }
    assert (Hfmb: f[m] ∈ B). {
      apply SepI... rewrite Hrs in Hlt. apply SepE1 in Hlt.
      apply Hoe in Hlt... apply SepE1 in Hlt...
    }
    apply Hle in Hfmb. eapply lo_not_le_gt...
Qed.

(* ex7_18 see EST7_4 limit ordinal *)
(* ex7_19 see EX7_1 Section EX7_19 *)
(* ex7_20 see EX7_1 Section EX7_20 *)
(* ex7_21 see lib/ZornsLemma Lemma Zorn's *)
(* ex7_22 see lib/ZornsLemma Theorem Zorn_to_WO *)
(* ex7_23 see lib/Cardinal Theorem hartogs_is_card_suc *)
(* ex7_24 see lib/Cardinal Theorem all_ord_ex_larger_card *)
(* ex7_25 see EST7_4 Theorem transfinite_induction_schema_on_ordinals *)


(* CRpi_fast is better for computation, but CRpi_slow is faster to compile,
and may be prefered for development. *)
(* Require Export CRpi_slow. *)
Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Export CoRN.reals.fast.CRpi_fast.
Require Import CoRN.reals.fast.CRsign.

Lemma CRpi_pos : (0 < CRpi)%CR.
Proof. CR_solve_pos (1#10)%Qpos. Qed.


Require Export Iron.Language.SystemF2Cap.Kind.
Require Export Iron.Language.SystemF2Cap.Type.Exp.TyCon.
Require Export Iron.Language.SystemF2Cap.Type.Exp.TyCap.

(********************************************************************)
(* Type Expressions. *)
Inductive ty  : Type  :=
 | TVar      : nat    -> ty
 | TForall   : ki     -> ty -> ty
 | TApp      : ty     -> ty -> ty
 | TSum      : ty     -> ty -> ty
 | TBot      : ki     -> ty

 (* Primitive constructed types. *)
 | TCon0     : tycon0 -> ty
 | TCon1     : tycon1 -> ty -> ty
 | TCon2     : tycon2 -> ty -> ty -> ty

 (* Primitive capabilities. *)
 | TCap      : tycap  -> ty.
Hint Constructors ty.

(********************************************************************)
(* Notations for baked in types *)
(* Region handles *)
Notation TRgn   P    := (TCap (TyCapRegion P)).

(* Effect types *)
Notation TRead  R    := (TCon1 TyConRead  R).
Notation TWrite R    := (TCon1 TyConWrite R).
Notation TAlloc R    := (TCon1 TyConAlloc R).

(* Suspension type *)

(* Function type. *)
Notation TFun A E B  := (TApp (TApp (TApp (TCon0 TyConFun) A) E) B).

(* Primitive data types. *)
Notation TUnit       := (TCon0 TyConUnit).
Notation TBool       := (TCon0 TyConBool).
Notation TNat        := (TCon0 TyConNat).

(* Reference to a value in some region. *)
Notation TRef  R T   := (TCon2 TyConRef  R T).
Notation TSusp E T   := (TCon2 TyConSusp E T).

(********************************************************************)
(* Predicates to test whether types have specific forms. *)

(* Check whether a type is a variable with the given index. *)
Definition isTVar   (n : nat) (t : ty) :=
 match t with
 | TVar n' => beq_nat n n'
 | _       => false
 end.

Definition IsTVar  (n : nat) (t : ty)
 := isTVar n t = true.

(* If we know a type is a variable, then it is one.. *)
Lemma isTVar_form
 :  forall i t
 ,  IsTVar i t
 -> t    = TVar i.
Proof.
 intros.
 destruct t; snorm; try nope.
 unfold IsTVar in *. snorm.
Qed.
Hint Resolve isTVar_form.

(* Check whether a type is a region handle with the given index. *)
Definition isTRgn (p : nat) (t : ty) :=
 match t with
 | TRgn p' => beq_nat p p'
 | _       => false
 end.

Definition IsTRgn   (p : nat) (t : ty)
 := isTRgn p t = true.
Hint Unfold IsTRgn.

(* If we know a tpye is a region handle, then it is one.. *)
Lemma isTRgn_form
 :  forall p t
 ,  IsTRgn p t
 -> t    = TRgn p.
Proof.
 intros.
 destruct t; snorm; try nope.
 destruct t. unfold IsTRgn in *. snorm. subst. auto.
Qed.
Hint Resolve isTRgn_form.

(* Check whether a type is an effect on the given region variable. *)
Definition isEffectOnVar (n : nat) (t : ty) :=
 match t with
 | TCon1 tc t1 => andb (isEffectTyCon_b tc) (isTVar n t1)
 | _           => false
 end.

(* Check whether a type is an effect on the given region handle. *)
Definition isEffectOnCap (p : nat) (t : ty) :=
 match t with
 | TCon1 tc t1 => andb (isEffectTyCon_b tc) (isTRgn p t1)
 | _           => false
 end.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Lists.List.
Require Import ExtLib.Data.Member.

(** This should really go elsewhere *)
Arguments MZ {_ _ _}.
Arguments MN [_ _ _ _] _.

Section with_t.
  Context {T : Type}.
  Context {t : T}.
  Fixpoint member_weaken ls' {ls}
  : member t ls -> member t (ls' ++ ls) :=
    match ls' as ls'
          return member t ls -> member t (ls' ++ ls)
    with
    | nil => fun x => x
    | l :: ls' => fun x => MN (member_weaken ls' x)
    end.

  Fixpoint member_lift ls ls' ls''
  : member t (ls'' ++ ls) -> member t (ls'' ++ ls' ++ ls) :=
    match ls'' as ls''
          return member t (ls'' ++ ls) -> member t (ls'' ++ ls' ++ ls)
    with
    | nil => member_weaken ls'
    | l :: ls'' => fun m =>
                    match m in member _ (x :: xs)
                          return forall xs', (member t xs -> member t xs') ->
                                        member t (x :: xs')
                    with
                    | MZ => fun _ _ => MZ
                    | MN m => fun _ rec => MN (rec m)
                    end _ (member_lift  ls ls' ls'')
    end.
End with_t.

Section del_member.
  Context {T : Type}.
  Context {t : T}.

  Fixpoint del_member {ls} (m : member t ls) : list T :=
    match m with
    | @MZ _ _ ls => ls
    | @MN _ _ l _ m' => l :: del_member m'
    end.

End del_member.

Section member_heq.
  Context {T : Type}.
  Fixpoint member_heq {l r : T} {ls} (m : member l ls)
    : member r ls -> member r (del_member m) + (l = r).
    refine
      match m as m in member _ ls
            return member r ls -> member r (del_member m) + (l = r)
      with
      | @MZ _ _ ls => fun b : member r (l :: ls) =>
                       match b in member _ (z :: ls)
                             return l = z -> member r (del_member (@MZ _ _ ls)) + (l = r)
                       with
                       | MZ => @inr _ _
                       | MN m' => fun pf => inl m'
                       end eq_refl
      | @MN _ _ l' ls' mx => fun b : member r (l' :: ls') =>
                               match b in member _ (z :: ls)
                                     return (member _ ls -> member _ (del_member mx) + (_ = r)) ->
                                            member r (del_member (@MN _ _ _ _ mx)) + (_ = r)
                               with
                               | MZ => fun _ => inl MZ
                               | MN m' => fun f => match f m' with
                                               | inl m => inl (MN m)
                                               | inr pf => inr pf
                                               end
                               end (fun x => @member_heq _ _ _ mx x)
      end.
  Defined.

End member_heq.

Section with_univ.
  Variable T' : Set.
  (** A simple type language since type constructors are not injective *)
  Inductive T : Set :=
  | Arr : T -> T -> T
  | Prod : T -> T -> T
  | Inj : T' -> T
  | Unit.

  (** Categorical morphisms (as syntax) *)
  Inductive CMor : T -> T -> Set :=
  | MId : forall {t}, CMor t t
  | MCompose : forall {a b c}, CMor b c -> CMor a b -> CMor a c
    (* Cartesian *)
  | MFst : forall {a b}, CMor (Prod a b) a
  | MSnd : forall {a b}, CMor (Prod a b) b
  | MFork : forall {a b c}, CMor a b -> CMor a c -> CMor a (Prod b c)
    (* Closed *)
  | MCurry : forall {a b c}, CMor (Prod a b) c -> CMor a (Arr b c)
  | MUncurry : forall {a b c}, CMor a (Arr b c) -> CMor (Prod a b) c
  | MApply : forall {a b}, CMor (Prod (Arr a b) a) b.

  (** Categorical laws (as syntax) *)
  Inductive CMor_eq : forall {d c}, CMor d c -> CMor d c -> Prop :=
  | LUnit : forall {a b} {c : CMor a b}, CMor_eq (MCompose MId c) c
  | RUnit : forall {a b} {c : CMor a b}, CMor_eq (MCompose c MId) c
  | CAssoc : forall {a b c d} (f : CMor a b) (g : CMor b c) (h : CMor c d),
      CMor_eq (MCompose h (MCompose g f)) (MCompose (MCompose h g) f)
  | Proper_MCompose : forall {a b c}, Proper (CMor_eq ==> CMor_eq ==> CMor_eq) (@MCompose a b c)
    (* Cartesian *)
  | Fst_Fork : forall a b c l r, CMor_eq (MCompose MFst (@MFork a b c l r)) l
  | Snd_Fork : forall a b c l r, CMor_eq (MCompose MSnd (@MFork a b c l r)) r
  | Fork_Fst_Snd : forall a b, CMor_eq (@MFork (Prod a b) a b MFst MSnd) MId
  | Proper_MFork : forall {a b c}, Proper (CMor_eq ==> CMor_eq ==> CMor_eq) (@MFork a b c)
    (* Closed *)
  | Curry_Uncurry : forall {a b c} (x : CMor a (Arr b c)), CMor_eq (MCurry (MUncurry x)) x
  | Uncurry_Curry : forall {a b c} (x : CMor (Prod a b) c), CMor_eq (MUncurry (MCurry x)) x
  | Curry_Apply   : forall {a b}, CMor_eq (MCurry (@MApply a b)) MId
  | Proper_MCurry : forall {a b c}, Proper (CMor_eq ==> CMor_eq) (@MCurry a b c)
  | Proper_MUncurry : forall {a b c}, Proper (CMor_eq ==> CMor_eq) (@MUncurry a b c)
  (* Refl and Trans *)
  | Refl_CMor_eq : forall {a b} (x : CMor a b), CMor_eq x x
  | Sym_CMor_eq : forall {a b} (x y : CMor a b), CMor_eq x y -> CMor_eq y x
  | Trans_CMor_eq : forall {a b} (x y z : CMor a b), CMor_eq x y -> CMor_eq y z -> CMor_eq x z.

  Existing Instance Proper_MCompose.
  Existing Instance Proper_MFork.
  Existing Instance Proper_MCurry.
  Existing Instance Proper_MUncurry.

  Hint Rewrite @Fork_Fst_Snd @LUnit @RUnit @CAssoc @Fst_Fork @Snd_Fork @Curry_Uncurry @Uncurry_Curry : rw_cmor.

  Instance Reflexive_CMor_eq {a b} : Reflexive (@CMor_eq a b).
  constructor.
  Defined.

  Instance Symmetric_CMor_eq {a b} : Symmetric (@CMor_eq a b).
  constructor; auto.
  Defined.

  Instance Transtive_CMor_eq {a b} : Transitive (@CMor_eq a b).
  red. intros; eapply Trans_CMor_eq; eauto.
  Defined.

(*
  Definition optCompose {a b c} (g : CMor b c) : CMor a b -> CMor a c.
  refine
    match g in CMor b c return CMor a b -> CMor a c with
    | MId => fun x => x
    | MFst => fun x => match x in CMor a b return CMor a b -> CMor a c with
                   | MFork l _ => _
                   | _ => _
                   end
    | x => MCompose x
    end.

  Fixpoint optCat {t t'} (m : CMor t t') : CMor t t'.
  refine
    match m in CMor t t' return CMor t t' with
    | MId => MId
    | MCompose g f => _
    | MFst => MFst
    | MSnd => MSnd
    | MFork l r => _
    end.
*)

  (** A more categorical representation of terms
   ** - Here, the context is represented by a `T`
   **)
  Inductive Expr' : T -> T -> Set :=
  | EApp' : forall {g t t'}, Expr' g (Arr t t') -> Expr' g t -> Expr' g t'
  | EAbs' : forall {g t t'}, Expr' (Prod t g) t' -> Expr' g (Arr t t')
  | ELiftL' : forall {a b c}, Expr' a c -> Expr' (Prod a b) c
  | ELiftR' : forall {a b c}, Expr' b c -> Expr' (Prod a b) c
  | EHere'  : forall {a}, Expr' a a
  | EFst' : forall {g a b}, Expr' g (Arr (Prod a b) a)
  | ESnd' : forall {g a b}, Expr' g (Arr (Prod a b) b)
  | EPair' : forall {g a b}, Expr' g (Arr a (Arr b (Prod a b))).

  (** Compilation of Expressions to Categorical morphisms *)
  Fixpoint expr'2cat {a b} (e : Expr' a b) : CMor a b :=
    match e in (Expr' t t0) return (CMor t t0) with
    | EApp' e1 e2 => MCompose MApply (MFork (expr'2cat e1) (expr'2cat e2))
    | EAbs' e0 => MCurry (MCompose (expr'2cat e0) (MFork MSnd MFst))
    | ELiftL' e0 => MCompose (expr'2cat e0) MFst
    | ELiftR' e0 => MCompose (expr'2cat e0) MSnd
    | EHere' => MId
    | EFst' => MCurry (MCompose MFst MSnd)
    | ESnd' => MCurry (MCompose MSnd MSnd)
    | EPair' => MCurry (MCurry (MFork (MCompose MSnd MFst) MSnd))
    end.

  (** Pairing operator *)
  Definition Epair' {g a b} (e1 : Expr' g a) (e2 : Expr' g b) : Expr' g (Prod a b) :=
    EApp' (EApp' EPair' e1) e2.

  (** Simultaneous substitution
   ** - Note, this actually implements Compose
   **)
  Fixpoint expr'subst {a b c} (s : Expr' c a) (e : Expr' a b) {struct e} : Expr' c b :=
    match e in (Expr' t t0) return (Expr' c t -> Expr' c t0) with
   | @EApp' g t t' e1 e2 =>
       fun s0 : Expr' c g => EApp' (expr'subst s0 e1) (expr'subst s0 e2)
   | @EAbs' g t t' e0 =>
       fun s0 : Expr' c g =>
       EAbs'
         (expr'subst
            (EApp'
               (EApp' (EAbs' (EAbs' (ELiftR' (ELiftR' (Epair' (ELiftL' EHere') (ELiftR' s0))))))
                  (ELiftR' s0)) (ELiftL' EHere')) e0)
   | @ELiftL' a0 b0 c0 e0 => fun s0 : Expr' c (Prod a0 b0) => expr'subst (EApp' EFst' s0) e0
   | @ELiftR' a0 b0 c0 e0 => fun s0 : Expr' c (Prod a0 b0) => expr'subst (EApp' ESnd' s0) e0
   | @EHere' a0 => fun s0 : Expr' c a0 => s0
   | @EFst' g a0 b0 => fun _ : Expr' c g => EFst'
   | @ESnd' g a0 b0 => fun _ : Expr' c g => ESnd'
   | @EPair' g a0 b0 => fun _ : Expr' c g => EPair'
   end s.

  (** Compilation of Categorical morphisms to expressions.
   **)
  Fixpoint cat2expr' {a b} (m : CMor a b) : Expr' a b :=
    match m in (CMor t t0) return (Expr' t t0) with
    | @MId t => EHere'
    | @MCompose a0 b0 c m1 m2 => expr'subst (cat2expr' m2) (cat2expr' m1)
    | @MFst a0 b0 => ELiftL' EHere'
    | @MSnd a0 b0 => ELiftR' EHere'
    | @MFork a0 b0 c m1 m2 => EApp' (EApp' EPair' (cat2expr' m1)) (cat2expr' m2)
    | @MCurry a0 b0 c m0 =>
      EAbs' (expr'subst (Epair' (ELiftR' EHere') (ELiftL' EHere')) (cat2expr' m0))
    | @MUncurry a0 b0 c m0 =>
      EApp' (expr'subst (ELiftL' EHere') (cat2expr' m0)) (ELiftR' EHere')
    | @MApply a0 b0 => EApp' (ELiftL' EHere') (ELiftR' EHere')
    end.

  (** One direction of the isomorphism *)
  Theorem cat2expr'_expr'2cat : forall a b (e : Expr' a b),
      cat2expr' (expr'2cat e) = e.
  Proof.
    (** Only true in the equational theory of Expr'. **)
  Admitted.

  (** The other direction of the isomorphism *)
  Theorem expr'2cat_cat2expr' : forall a b (e : CMor a b),
      CMor_eq (expr'2cat (cat2expr' e)) e.
  Proof.
    induction e; simpl.
    { reflexivity. }
    { admit. }
    { eapply LUnit. }
    { eapply LUnit. }
    { rewrite IHe1. rewrite IHe2. clear.
      admit. }
    { admit. }
  Admitted.

  (****************************************************)
  (** Standard term representation                   **)
  (****************************************************)

  (** Basic definition of expressions *)
  Inductive Expr (g : list T) : T -> Set :=
  | EApp : forall t t', Expr g (Arr t t') -> Expr g t -> Expr g t'
  | EAbs : forall t t', Expr (t :: g) t' -> Expr g (Arr t t')
  | EVar : forall t, member t g -> Expr g t
    (* Cartesian *)
  | EFst : forall a b, Expr g (Arr (Prod a b) a)
  | ESnd : forall a b, Expr g (Arr (Prod a b) b)
  | EPair : forall a b, Expr g (Arr a (Arr b (Prod a b))).

  Arguments EVar {_ _} _.
  Arguments EAbs {_ _ _} _.
  Arguments EApp {_ _ _} _ _.
  Arguments EFst {_ _ _}.
  Arguments ESnd {_ _ _}.
  Arguments EPair {_ _ _}.

  Fixpoint lift {g} g' g'' {t} (e : Expr (g'' ++ g) t)
  : Expr (g'' ++ g' ++ g) t :=
    match e in Expr _ t return Expr (g'' ++ g' ++ g) t with
    | EApp f x => EApp (@lift g g' g'' _ f) (@lift g g' g'' _ x)
    | EAbs e' => EAbs (@lift g g' (_ :: g'') _ e')
    | EVar m => EVar (member_lift _ _ _ m)
    | EFst => EFst
    | ESnd => ESnd
    | EPair => EPair
    end.

  Fixpoint subst {t t'} {g} (m : member t' g) (w : Expr (del_member m) t') (e : Expr g t)
  : Expr (del_member m) t :=
    match e in Expr _ t return Expr (del_member m) t with
    | EApp f x => EApp (subst m w f) (subst m w x)
    | EAbs e => EAbs (subst (MN m) (lift (_::nil) nil w) e)
    | EVar v =>
      match member_heq m v with
      | inl v' => EVar v'
      | inr pf => match pf with
                 | eq_refl => w
                 end
      end
    | EFst => EFst
    | ESnd => ESnd
    | EPair => EPair
    end.

  Inductive Expr_eq : forall {g t}, Expr g t -> Expr g t -> Prop :=
  | Beta : forall {g t t'} (x : Expr (t :: g) t') y,
      Expr_eq (EApp (EAbs x) y) (subst MZ y x)
    (* Cartesian *)
  | Fst_Pair : forall {g t t'} x y, Expr_eq (EApp (@EFst g t t') (EApp (EApp EPair x) y)) x
  | Snd_Pair : forall {g t t'} x y, Expr_eq (EApp (@ESnd g t t') (EApp (EApp EPair x) y)) y.

  Fixpoint cat2expr {g} {t} (c : CMor g t) : Expr nil (Arr g t).
  refine
    (match c in CMor ts' t'
           return Expr nil (Arr ts' t') with
     | MId => EAbs (EVar MZ)
     | MCompose g f =>
       EAbs (EApp (lift (_ :: nil) nil (cat2expr _ _ g))
                  (EApp (lift (_ :: nil) nil (cat2expr _ _ f)) (EVar MZ)))
     | MFst => EFst
     | MSnd => ESnd
     | MFork l r =>
       EAbs (EApp
               (EApp EPair (EApp (lift (_::nil) nil (cat2expr _ _ l)) (EVar MZ)))
                     (EApp (lift (_::nil) nil (cat2expr _ _ r)) (EVar MZ)))
     | MCurry e =>
       EAbs (EAbs (EApp (lift (_::_::nil) nil (cat2expr _ _ e))
                        (EApp (EApp EPair (EVar (MN MZ))) (EVar MZ))))
     | MUncurry e =>
       EAbs (EApp (EApp (lift (_::nil) nil (cat2expr _ _ e)) (EApp EFst (EVar MZ)))
                  (EApp ESnd (EVar MZ)))
     | MApply =>
       EAbs (EApp (EApp EFst (EVar MZ)) (EApp ESnd (EVar MZ)))
     end).
  Defined.

  Fixpoint Prods (ts : list T) (l : T) : T :=
    match ts with
    | nil => l
    | t :: ts => Prod t (Prods ts l)
    end.

  Fixpoint var_to_mor {t} {g} (v : member t g) : CMor (Prods g Unit) t :=
    match v in member _ g return CMor (Prods g Unit) t with
    | MZ => MFst
    | MN v' => MCompose (var_to_mor v') MSnd
    end.

  Fixpoint expr2cat {g} {t} (e : Expr g t) : CMor (Prods g Unit) t :=
    match e in (Expr _ t0) return (CMor (Prods g Unit) t0) with
    | EApp f x => MCompose MApply (MFork (expr2cat f) (expr2cat x))
    | EAbs e0 => MCurry (MCompose (expr2cat e0) (MFork MSnd MFst))
    | EVar v => var_to_mor v
    | EFst => MCurry (MCompose MFst MSnd)
    | ESnd => MCurry (MCompose MSnd MSnd)
    | EPair => MCurry (MCurry (MFork (MCompose MSnd MFst) MSnd))
    end.

  Fixpoint cat2expr1 {t g} (m : CMor g t) : Expr (g :: nil) t.
    destruct m.
    { apply EVar. eapply MZ. }
    { eapply EApp.
      eapply (lift (_::nil) nil (EAbs (cat2expr1 _ _ m1))).
      eapply cat2expr1. assumption. }
    { eapply EApp. eapply EFst. eapply (EVar MZ). }
    { eapply EApp. eapply ESnd. eapply (EVar MZ). }
    { eapply EApp. eapply EApp. eapply EPair.
      eapply cat2expr1; assumption.
      eapply cat2expr1; assumption. }
    { eapply EAbs.
      refine (EApp (lift (b::a::nil) nil (EAbs (cat2expr1 _ _ m))) _); clear. simpl.
      refine (EApp (EApp EPair (EVar (MN MZ))) (EVar MZ)). }
    { refine (EApp (EApp (lift (_::nil) nil (EAbs (cat2expr1 _ _ m))) (EApp EFst (EVar MZ))) (EApp ESnd (EVar MZ))). }
    { eapply EApp.
      eapply (EApp EFst (EVar MZ)).
      eapply (EApp ESnd (EVar MZ)). }
  Defined.

  Definition fixup {a b} (m : Expr (a :: nil) b) : Expr (Prod a Unit :: nil) b.
    eapply EApp. eapply (lift (_::nil) nil (EAbs m)).
    refine (EApp EFst (EVar MZ)).
  Defined.

  Theorem cat2expr_expr2cat : forall a b (m : Expr (a :: nil) b),
      Expr_eq (cat2expr1 (expr2cat m)) (fixup m).
  Proof.
  Abort.
End with_univ.


Require Import FP.Data.TwoThreeTrees.
Require Import FP.Structures.WellFormed.
Require Import FP.Data.N.
Require Import FP.Data.Unit.
Require Import FP.Data.Sum.
Require Import FP.Data.Ext.
Require Import FP.Structures.Peano.
Require Import FP.Structures.Lattice.
Require Import FP.Structures.Injection.
Require Import FP.Structures.Ord.
Require Import FP.Structures.Eqv.
Require Import FP.Structures.Additive.
Require Import FP.Structures.Alternative.
Require Import FP.Structures.Functor.
Require Import FP.Structures.Monad.
Require Import FP.Relations.RelDec.

Import MonadNotation.
Import NNotation.
Import EqvNotation.
Import OrdNotation.
Import AdditiveNotation.
Import AlternativeNotation.

Module TwoThreeTreesWF.
  Import TwoThreeTrees.

  Section Context.
    Context {K:Type}.
    Context {E:Eqv K} {EWF:EqvWF K}.
    Context {O:Ord K} {OWF:OrdWF K}.
    Context {L:Lattice K} {LWF:LatticeWF K}.
    Context {B:BoundedLattice K} {BWF:BoundedLatticeWF K}.
    Context {OD:OrdDec K} {ODC:OrdDecCorrect K}.
    Context {V:Type}.

    Inductive in_tree : K -> tree K V -> Prop :=
      | InTwoLeftTree :
          forall k tl pm tr,
            in_tree k tl -> in_tree k (Two_t tl pm tr)
      | InTwoRightTree :
          forall k tl pm tr,
            in_tree k tr -> in_tree k (Two_t tl pm tr)
      | InTwoNode :
          forall k tl km vm tr,
            k ~= km -> in_tree k (Two_t tl (km,vm) tr)
      | InThreeLeftTree :
          forall k tl pl tm pr tr,
            in_tree k tl -> in_tree k (Three_t tl pl tm pr tr)
      | InThreeMiddleTree :
          forall k tl pl tm pr tr,
            in_tree k tm -> in_tree k (Three_t tl pl tm pr tr)
      | InThreeRightTree :
          forall k tl pl tm pr tr,
            in_tree k tr -> in_tree k (Three_t tl pl tm pr tr)
      | InThreeLeftNode :
          forall k tl kl vl tm pr tr,
            k ~= kl -> in_tree k (Three_t tl (kl,vl) tm pr tr)
      | InThreeRightNode :
          forall k tl pl tm kr vr tr,
            k ~= kr -> in_tree k (Three_t tl pl tm (kr,vr) tr).
    Hint Constructors in_tree.
    Definition in_two_node_lib :
      forall tl km vm tr, in_tree km (Two_t tl (km,vm) tr).
    Proof. intros ; eapply InTwoNode ; reflexivity. Qed.
    Hint Resolve in_two_node_lib.
    Definition in_three_left_node_lib :
      forall tl kl vl tm pr tr,
        in_tree kl (Three_t tl (kl,vl) tm pr tr).
    Proof. intros ; eapply InThreeLeftNode ; reflexivity. Qed.
    Hint Resolve in_three_left_node_lib.
    Definition in_three_right_node_lib :
      forall tl pl tm kr vr tr,
        in_tree kr (Three_t tl pl tm (kr,vr) tr).
    Proof. intros ; eapply InThreeRightNode ; reflexivity. Qed.
    Hint Resolve in_three_right_node_lib.

    Inductive tree_iwf : ext_top_bot K -> ext_top_bot K -> N -> tree K V -> Prop :=
      | NullWF :
          forall
            t_lower_bound t_upper_bound,
              tree_iwf t_lower_bound t_upper_bound 0 Null_t
      | TwoWF :
          forall
            tl tl_lower_bound tl_upper_bound
            tr tr_lower_bound tr_upper_bound
            t_height
            km vm,
              tree_iwf tl_lower_bound tl_upper_bound t_height tl
           -> tree_iwf tr_lower_bound tr_upper_bound t_height tr
           -> tl_upper_bound < inject km < tr_lower_bound
           -> tree_iwf tl_lower_bound tr_upper_bound (t_height+1)
                       (Two_t tl (km,vm) tr)
      | ThreeWF :
          forall
            tl tl_lower_bound tl_upper_bound
            tm tm_lower_bound tm_upper_bound
            tr tr_lower_bound tr_upper_bound
            t_height
            kl vl kr vr,
              tree_iwf tl_lower_bound tl_upper_bound t_height tl
           -> tree_iwf tm_lower_bound tm_upper_bound t_height tm
           -> tree_iwf tr_lower_bound tr_upper_bound t_height tr
           -> tl_upper_bound < inject kl < tm_lower_bound
           -> tm_upper_bound < inject kr < tr_lower_bound
           -> tree_iwf tl_lower_bound tr_upper_bound (t_height+1)
                       (Three_t tl (kl,vl) tm (kr,vr) tr).
    Hint Constructors tree_iwf.

    Inductive in_context : K -> context K V -> Prop :=
      | InTwoLeftHoleContext :
          forall k pm tr c,
            in_context k c -> in_context k (TwoLeftHole_c pm tr c)
      | InTwoLeftHoleTree :
          forall k pm tr c,
            in_tree k tr -> in_context k (TwoLeftHole_c pm tr c)
      | InTwoLeftHoleNode :
          forall k km vm tr c,
            k ~= km -> in_context k (TwoLeftHole_c (km,vm) tr c)
      | InTwoRightHoleContext :
          forall k tl pm c,
            in_context k c -> in_context k (TwoRightHole_c tl pm c)
      | InTwoRightHoleTree :
          forall k tl pm c,
            in_tree k tl -> in_context k (TwoRightHole_c tl pm c)
      | InTwoRightHoleNode :
          forall k tl km vm c,
            k ~= km -> in_context k (TwoRightHole_c tl (km,vm) c)
      | InThreeLeftHoleContext :
          forall k pl tm pr tr c,
            in_context k c -> in_context k (ThreeLeftHole_c pl tm pr tr c)
      | InThreeLeftHoleMiddleTree :
          forall k pl tm pr tr c,
            in_tree k tm -> in_context k (ThreeLeftHole_c pl tm pr tr c)
      | InThreeLeftHoleRightTree :
          forall k pl tm pr tr c,
            in_tree k tr -> in_context k (ThreeLeftHole_c pl tm pr tr c)
      | InThreeLeftHoleLeftNode :
          forall k kl vl tm pr tr c,
            k ~= kl -> in_context k (ThreeLeftHole_c (kl,vl) tm pr tr c)
      | InThreeLeftHoleRightNode :
          forall k pl tm kr vr tr c,
            k ~= kr -> in_context k (ThreeLeftHole_c pl tm (kr,vr) tr c)
      | InThreeMiddleHoleContext :
          forall k tl pl pr tr c,
            in_context k c -> in_context k (ThreeMiddleHole_c tl pl pr tr c)
      | InThreeMiddleHoleLeftTree :
          forall k tl pl pr tr c,
            in_tree k tl -> in_context k (ThreeMiddleHole_c tl pl pr tr c)
      | InThreeMiddleHoleRightTree :
          forall k tl pl pr tr c,
            in_tree k tr -> in_context k (ThreeMiddleHole_c tl pl pr tr c)
      | InThreeMiddleHoleLeftNode :
          forall k tl kl vl pr tr c,
            k ~= kl -> in_context k (ThreeMiddleHole_c tl (kl,vl) pr tr c)
      | InThreeMiddleHoleRightNode :
          forall k tl pl kr vr tr c,
            k ~= kr -> in_context k (ThreeMiddleHole_c tl pl (kr,vr) tr c)
      | InThreeRightHoleContext :
          forall k tl pl tm pr c,
            in_context k c -> in_context k (ThreeRightHole_c tl pl tm pr c)
      | InThreeRightHoleLeftTree :
          forall k tl pl tm pr c,
            in_tree k tl -> in_context k (ThreeRightHole_c tl pl tm pr c)
      | InThreeRightHoleMiddleTree :
          forall k tl pl tm pr c,
            in_tree k tm -> in_context k (ThreeRightHole_c tl pl tm pr c)
      | InThreeRightHoleLeftNode :
          forall k tl kl vl tm pr c,
            k ~= kl -> in_context k (ThreeRightHole_c tl (kl,vl) tm pr c)
      | InThreeRightHoleRightNode :
          forall k tl pl tm kr vr c,
            k ~= kr -> in_context k (ThreeRightHole_c tl pl tm (kr,vr) c).
    Hint Constructors in_context.

    Inductive context_iwf
        : ext_top_bot K -> ext_top_bot K -> N (* bounds and height of hole *)
       -> ext_top_bot K -> ext_top_bot K -> N (* bounds and height when filled *)
       -> context K V
       -> Prop :=
      | TopWF :
          forall
            t_lower_bound t_upper_bound
            t_height,
              context_iwf t_lower_bound t_upper_bound t_height
                          t_lower_bound t_upper_bound t_height Top_c
      | TwoLeftHoleWF :
          forall
            h_lower_bound h_upper_bound h_height
            tr tr_lower_bound tr_upper_bound
            c c_lower_bound c_upper_bound c_height
            k v,
              context_iwf h_lower_bound tr_upper_bound (h_height+1)
                          c_lower_bound c_upper_bound c_height c
           -> tree_iwf tr_lower_bound tr_upper_bound h_height tr
           -> h_upper_bound < inject k < tr_lower_bound
           -> context_iwf h_lower_bound h_upper_bound h_height
                          c_lower_bound c_upper_bound c_height
                          (TwoLeftHole_c (k,v) tr c)
      | TwoRightHoleWF :
          forall
            h_lower_bound h_upper_bound h_height
            tl tl_lower_bound tl_upper_bound
            c c_lower_bound c_upper_bound c_height
            k v,
              context_iwf tl_lower_bound h_upper_bound (h_height+1)
                          c_lower_bound c_upper_bound c_height c
           -> tree_iwf tl_lower_bound tl_upper_bound h_height tl
           -> tl_upper_bound < inject k < h_lower_bound
           -> context_iwf h_lower_bound h_upper_bound h_height
                          c_lower_bound c_upper_bound c_height
                          (TwoRightHole_c tl (k,v) c)
      | ThreeLeftHoleWF :
          forall
            h_lower_bound h_upper_bound h_height
            tm tm_lower_bound tm_upper_bound
            tr tr_lower_bound tr_upper_bound
            c c_lower_bound c_upper_bound c_height
            kl vl kr vr,
              context_iwf h_lower_bound tr_upper_bound (h_height+1)
                          c_lower_bound c_upper_bound c_height c
           -> tree_iwf tm_lower_bound tm_upper_bound h_height tm
           -> tree_iwf tr_lower_bound tr_upper_bound h_height tr
           -> h_upper_bound < inject kl < tm_lower_bound
           -> tm_upper_bound < inject kr < tr_lower_bound
           -> context_iwf h_lower_bound h_upper_bound h_height
                          c_lower_bound c_upper_bound c_height
                          (ThreeLeftHole_c (kl,vl) tm (kr,vr) tr c)
      | ThreeMiddleHoleWF :
          forall
            h_lower_bound h_upper_bound h_height
            tl tl_lower_bound tl_upper_bound
            tr tr_lower_bound tr_upper_bound
            c c_lower_bound c_upper_bound c_height
            kl vl kr vr,
              context_iwf tl_lower_bound tr_upper_bound (h_height+1)
                          c_lower_bound c_upper_bound c_height c
           -> tree_iwf tl_lower_bound tl_upper_bound h_height tl
           -> tree_iwf tr_lower_bound tr_upper_bound h_height tr
           -> tl_upper_bound < inject kl < h_lower_bound
           -> h_upper_bound < inject kr < tr_lower_bound
           -> context_iwf h_lower_bound h_upper_bound h_height
                          c_lower_bound c_upper_bound c_height
                          (ThreeMiddleHole_c tl (kl,vl) (kr,vr) tr c)
      | ThreeRightHoleWF :
          forall
            h_lower_bound h_upper_bound h_height
            tl tl_lower_bound tl_upper_bound
            tm tm_lower_bound tm_upper_bound
            c c_lower_bound c_upper_bound c_height
            kl vl kr vr,
              context_iwf tl_lower_bound h_upper_bound (h_height+1)
                          c_lower_bound c_upper_bound c_height c
           -> tree_iwf tl_lower_bound tl_upper_bound h_height tl
           -> tree_iwf tm_lower_bound tm_upper_bound h_height tm
           -> tl_upper_bound < inject kl < tm_lower_bound
           -> tm_upper_bound < inject kr < h_lower_bound
           -> context_iwf h_lower_bound h_upper_bound h_height
                          c_lower_bound c_upper_bound c_height
                          (ThreeRightHole_c tl (kl,vl) tm (kr,vr) c).
    Hint Constructors context_iwf.

  Inductive in_location : K -> location K V -> Prop :=
    | InLocTwoHoleContext :
        forall k tl tr c,
          in_context k c -> in_location k (TwoHole_l tl tr c)
    | InLocTwoHoleLeftTree :
        forall k tl tr c,
          in_tree k tl -> in_location k (TwoHole_l tl tr c)
    | InLocTwoHoleRightTree :
        forall k tl tr c,
          in_tree k tr -> in_location k (TwoHole_l tl tr c)
    | InLocThreeLeftHoleContext :
        forall k tl tm pr tr c,
          in_context k c -> in_location k (ThreeLeftHole_l tl tm pr tr c)
    | InLocThreeLeftHoleLeftTree :
        forall k tl tm pr tr c,
          in_tree k tl -> in_location k (ThreeLeftHole_l tl tm pr tr c)
    | InLocThreeLeftHoleMiddleTree :
        forall k tl tm pr tr c,
          in_tree k tm -> in_location k (ThreeLeftHole_l tl tm pr tr c)
    | InLocThreeLeftHoleRightTree :
        forall k tl tm pr tr c,
          in_tree k tr -> in_location k (ThreeLeftHole_l tl tm pr tr c)
    | InLocThreeLeftHoleNode :
        forall k tl tm kr vr tr c,
          k ~= kr -> in_location k (ThreeLeftHole_l tl tm (kr,vr) tr c)
    | InLocThreeRightHoleContext :
        forall k tl pl tm tr c,
          in_context k c -> in_location k (ThreeRightHole_l tl pl tm tr c)
    | InLocThreeRightHoleLeftTree :
        forall k tl pl tm tr c,
          in_tree k tl -> in_location k (ThreeRightHole_l tl pl tm tr c)
    | InLocThreeRightHoleMiddleTree :
        forall k tl pl tm tr c,
          in_tree k tm -> in_location k (ThreeRightHole_l tl pl tm tr c)
    | InLocThreeRightHoleRightTree :
        forall k tl pl tm tr c,
          in_tree k tr -> in_location k (ThreeRightHole_l tl pl tm tr c)
    | InLocThreeRightHoleNode :
        forall k tl kl vl tm tr c,
          k ~= kl -> in_location k (ThreeRightHole_l tl (kl,vl) tm tr c).
  Hint Constructors in_location.

  Inductive location_iwf
      : ext_top_bot K -> ext_top_bot K (* bounds of hole *)
     -> ext_top_bot K -> ext_top_bot K -> N (* bounds and height when filled *)
     -> location K V
     -> Prop :=
    | LocTwoHoleWF :
        forall
          t_height
          tl tl_lower_bound tl_upper_bound
          tr tr_lower_bound tr_upper_bound
          c c_lower_bound c_upper_bound c_height,
            tree_iwf tl_lower_bound tl_upper_bound t_height tl
         -> tree_iwf tr_lower_bound tr_upper_bound t_height tr
         -> context_iwf tl_lower_bound tr_upper_bound (t_height+1)
                        c_lower_bound c_upper_bound c_height c
         -> location_iwf tl_upper_bound tr_lower_bound
                         c_lower_bound c_upper_bound c_height
                         (TwoHole_l tl tr c)
    | LocThreeLeftHoleWF :
        forall
          t_height
          tl tl_lower_bound tl_upper_bound
          tm tm_lower_bound tm_upper_bound
          tr tr_lower_bound tr_upper_bound
          c c_lower_bound c_upper_bound c_height
          kr vr,
            tree_iwf tl_lower_bound tl_upper_bound t_height tl
         -> tree_iwf tm_lower_bound tm_upper_bound t_height tm
         -> tree_iwf tr_lower_bound tr_upper_bound t_height tr
         -> tm_upper_bound < inject kr < tr_lower_bound
         -> context_iwf tl_lower_bound tr_upper_bound (t_height+1)
                        c_lower_bound c_upper_bound c_height c
         -> location_iwf tl_upper_bound tm_lower_bound
                         c_lower_bound c_upper_bound c_height
                         (ThreeLeftHole_l tl tm (kr,vr) tr c)
    | LocThreeRightHoleWF :
        forall
          t_height
          tl tl_lower_bound tl_upper_bound
          tm tm_lower_bound tm_upper_bound
          tr tr_lower_bound tr_upper_bound
          c c_lower_bound c_upper_bound c_height
          kl vl,
            tree_iwf tl_lower_bound tl_upper_bound t_height tl
         -> tree_iwf tm_lower_bound tm_upper_bound t_height tm
         -> tree_iwf tr_lower_bound tr_upper_bound t_height tr
         -> tl_upper_bound < inject kl < tm_lower_bound
         -> context_iwf tl_lower_bound tr_upper_bound (t_height+1)
                        c_lower_bound c_upper_bound c_height c
         -> location_iwf tm_upper_bound tr_lower_bound
                         c_lower_bound c_upper_bound c_height
                         (ThreeRightHole_l tl (kl,vl) tm  tr c).
  Hint Constructors location_iwf.

  Global Instance tree_WellFormed : WellFormed (tree K V) :=
    { wf :=
        fun (t:tree K V) =>
          exists (n:N) (lb:ext_top_bot K) (ub:ext_top_bot K),
            tree_iwf lb ub n t
    }.

  Local Ltac mysimp :=
  match goal with
    | [ |- forall  _, _ ] => intros
    | [ |- _ /\ _ ] => constructor
    | [ H : _ /\ _ |- _ ] => destruct H
    | [ H : inl _ = inr _ |- _ ] => discriminate H
    | [ H : inr _ = inr _ |- _ ] => inversion H ; subst ; clear H
    | [ H : ?a < ?b < ?c |- ?a < ?b ] => apply H
    | [ H : ?a < ?b < ?c |- ?b < ?c ] => apply H
    | [ H1 : ?X, H2 : ?X -> ?Y |- ?Y ] => apply (H2 H1)
    | [ |- match ?e with _ => _ end ] =>
        let x := fresh in
        remember e as x ; destruct x
    | [ H : forall c' k,
              (@?X c' k) c' k
           /\ (@?Y c' k) c' k
      |- _ ] =>
        let c' := fresh "c'" in
        let k := fresh "k" in
        let H1 := fresh in
        let H2 := fresh in
        assert (forall c' k, X c' k) as H1;
          [ intros c' k ; apply (proj1 (H c' k)) | idtac ] ;
        assert (forall c' k, Y c' k) as H2;
          [ intros c' k ; apply (proj2 (H c' k)) | idtac ] ;
        clear H ; simpl in H1 ; simpl in H2
    | [ |- context [ let (_,_) := ?p in _ ] ] => destruct p
    | [ H : context [ let (_,_) := ?p in _ ] |- _ ] => destruct p
    | [ H1 : ?x ~= ?z, H2 : ?y ~= ?z, H3 : ?x /~= ?y |- _ ] =>
        exfalso ; apply H3 ; transitivity z ; [ apply H1 | symmetry ; apply H2 ]
    | _ => auto
  end.

  Local Ltac rip :=
    match goal with
    | [ H : in_tree _ Null_t |- _ ] => inversion H
    | [ H : in_tree _ (Two_t _ _ _) |- _ ] => inversion H ; subst ; clear H
    | [ H : in_tree _ (Three_t _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
    | [ H : tree_iwf _ _ _ Null_t |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : tree_iwf _ _ _ (Two_t _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : tree_iwf _ _ _ (Three_t _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_context _ Top_c |- _ ] => inversion H
    | [ H : in_context _ (TwoLeftHole_c _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_context _ (TwoRightHole_c _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_context _ (ThreeLeftHole_c _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_context _ (ThreeMiddleHole_c _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_context _ (ThreeRightHole_c _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : context_iwf _ _ _ _ _ _ Top_c |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : context_iwf _ _ _ _ _ _ (TwoLeftHole_c _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : context_iwf _ _ _ _ _ _ (TwoRightHole_c _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : context_iwf _ _ _ _ _ _ (ThreeLeftHole_c _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : context_iwf _ _ _ _ _ _ (ThreeMiddleHole_c _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : context_iwf _ _ _ _ _ _ (ThreeRightHole_c _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_location _ (TwoHole_l _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_location _ (ThreeLeftHole_l _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : in_location _ (ThreeRightHole_l _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : location_iwf _ _ _ _ _ (TwoHole_l _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : location_iwf _ _ _ _ _ (ThreeLeftHole_l _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | [ H : location_iwf _ _ _ _ _ (ThreeRightHole_l _ _ _ _ _) |- _ ] =>
        inversion H ; subst ; clear H
    | _ => auto
    end.

  Opaque fplus fmap.

  Lemma locate_greatest_in :
    forall
      (t:tree K V) (c:context K V),
        match locate_greatest t c with
        | None => True
        | Some ((k,_),lM) =>
            let l :=
              match lM with
              | inl c => TwoHole_l Null_t Null_t c
              | inr (el,c) => ThreeRightHole_l Null_t el Null_t Null_t c
              end
            in
            forall k', k /~= k' ->
              (in_tree k' t -> in_location k' l)
           /\ (in_context k' c -> in_location k' l)
        end.
  Proof.
    intros t ; induction t ; intros.
    simpl ; auto.
    cbv beta iota delta [locate_greatest].
    fold (@locate_greatest K V).
  specialize (IHt2 (TwoRightHole_c t1 p c)).
  remember (locate_greatest t2 (TwoRightHole_c t1 p c)) as foo ; destruct foo.
  simpl.
  simpl.
  simp

  Lemma zip_in :
    forall (c:context K V) (t:tree K V) (k:K),
      (in_context k c -> in_tree k (zip t c))
   /\ (in_tree k t -> in_tree k (zip t c)).
  Proof.
    intros c ; induction c ; repeat mysimp ; repeat rip ; eauto.
  Qed.
  Lemma zip_in_context :
    forall (c:context K V) (t:tree K V) (k:K),
      in_context k c -> in_tree k (zip t c).
  Proof. apply zip_in. Qed.
  Hint Resolve zip_in_context.
  Lemma zip_in_tree :
    forall (c:context K V) (t:tree K V) (k:K),
      in_tree k t -> in_tree k (zip t c).
  Proof. apply zip_in. Qed.
  Hint Resolve zip_in_tree.

  Lemma zip_wf :
    forall
      (c:context K V) (t:tree K V)
      t_lower_bound t_upper_bound t_height
      c_lower_bound c_upper_bound c_height,
        tree_iwf t_lower_bound t_upper_bound t_height t
     -> context_iwf t_lower_bound t_upper_bound t_height
                    c_lower_bound c_upper_bound c_height c
     -> tree_iwf c_lower_bound c_upper_bound c_height (zip t c).
  Proof.
    intros c ; induction c ; repeat mysimp ; repeat rip ; eapply IHc ; eauto.
  Qed.
  Hint Resolve zip_wf.

  Lemma fuse_in :
    forall (c1:context K V) (c2:context K V) k,
      (in_context k c1 -> in_context k (fuse c1 c2))
   /\ (in_context k c2 -> in_context k (fuse c1 c2)).
  Proof.
    intros c ; induction c ; simpl ; repeat mysimp ; repeat rip.
  Qed.
  Lemma fuse_in_context1 :
    forall (c1:context K V) (c2:context K V) k,
      in_context k c1 -> in_context k (fuse c1 c2).
  Proof. apply fuse_in. Qed.
  Hint Resolve fuse_in_context1.
  Lemma fuse_in_context2 :
    forall (c1:context K V) (c2:context K V) k,
      in_context k c2 -> in_context k (fuse c1 c2).
  Proof. apply fuse_in. Qed.
  Hint Resolve fuse_in_context2.

  Lemma fuse_wf :
    forall
      (c1:context K V) (c2:context K V)
      c1h_lower_bound c1h_upper_bound c1h_height
      c1_lower_bound c1_upper_bound c1_height
      c2_lower_bound c2_upper_bound c2_height,
        context_iwf c1h_lower_bound c1h_upper_bound c1h_height
                    c1_lower_bound c1_upper_bound c1_height c1
     -> context_iwf c1_lower_bound c1_upper_bound c1_height
                    c2_lower_bound c2_upper_bound c2_height c2
     -> context_iwf c1h_lower_bound c1h_upper_bound c1h_height
                    c2_lower_bound c2_upper_bound c2_height (fuse c1 c2).
  Proof.
    intros c1 ; induction c1 ; simpl ; repeat mysimp ; repeat rip ; eauto.
  Qed.
  Hint Resolve fuse_wf.

  Lemma fill_location_in :
    forall (l:location K V) (k:K) (v:V),
      (in_tree k (fill_location (k,v) l))
   /\ (forall k', in_location k' l -> in_tree k' (fill_location (k,v) l)).
  Proof.
    intros l ; induction l ; simpl ; repeat mysimp ; repeat rip.
  Qed.
  Lemma fill_location_in_filled :
    forall (l:location K V) (k:K) (v:V),
      in_tree k (fill_location (k,v) l).
  Proof. intros ; apply (proj1 (fill_location_in _ _ _)). Qed.
  Hint Resolve fill_location_in_filled.
  Lemma fill_location_in_tree :
    forall (l:location K V) (k:K) (v:V) (k':K),
      in_location k' l -> in_tree k' (fill_location (k,v) l).
  Proof. intros * * * * H ; apply (proj2 (fill_location_in _ _ _) _ H). Qed.
  Hint Resolve fill_location_in_tree.

  Lemma fill_location_wf :
    forall
      (l:location K V) (k:K) (v:V)
      h_lower_bound h_upper_bound
      c_lower_bound c_upper_bound c_height,
        h_lower_bound < inject k < h_upper_bound
     -> location_iwf h_lower_bound h_upper_bound
                     c_lower_bound c_upper_bound c_height l
     -> tree_iwf c_lower_bound c_upper_bound c_height (fill_location (k,v) l).
  Proof.
    intros l ; induction l ; intros ; repeat mysimp ; repeat rip ; eapply zip_wf ;
      eauto.
  Qed.
  Hint Resolve fill_location_wf.

  Lemma locate_in :
    forall (t:tree K V) (k:K) (c:context K V),
      match locate k t c with
      | inl c' =>
          forall k',
            (in_tree k' t -> in_context k' c')
         /\ (in_context k' c -> in_context k' c')
      | inr ((k',_),l) =>
          k ~= k'
       /\ (forall k'', k /~= k'' ->
             (in_tree k'' t -> in_location k'' l)
          /\ (in_context k'' c -> in_location k'' l))
      end.
  Proof.
    intros t ; induction t ; intros ; simpl ; repeat mysimp ; repeat rip ;
      repeat
        match goal with
        | [ H : context[ ?a <=>! ?b ] |- _ ] =>
            let cmp := fresh "cmp" in
            remember (a <=>! b) as cmp eqn:cmp_eqn ; symmetry in cmp_eqn ;
              destruct cmp as [cmp|cmp|cmp] ;
              [ apply ord_dec_correct_eqv in cmp_eqn
              | apply ord_dec_correct_lt in cmp_eqn
              | apply ord_dec_correct_gt in cmp_eqn
              ]
        | [ H : context[ ?a <=>! ?b ] |- _ ] =>
            let cmp := fresh "cmp" in
            remember (a <=>! b) as cmp eqn:cmp_eqn2 ; symmetry in cmp_eqn2 ;
              destruct cmp as [cmp|cmp|cmp] ;
              [ apply ord_dec_correct_eqv in cmp_eqn2
              | apply ord_dec_correct_lt in cmp_eqn2
              | apply ord_dec_correct_gt in cmp_eqn2
              ]
        | [ H1 : forall k c, match locate k ?t c with _ => _ end
          , H2 : _ = locate ?k ?t ?c
          |- _ ] =>
            specialize (H1 k c) ; rewrite <- H2 in H1
        | [ H : forall k, _ /\ _
          |- context[ ?k ]
          ] => specialize (H k)
        end ; repeat mysimp.
  Qed.

  Lemma locate_wf :
    forall
      (t:tree K V) (k:K) (c:context K V)
      t_lower_bound t_upper_bound t_height
      c_lower_bound c_upper_bound c_height,
        tree_iwf t_lower_bound t_upper_bound t_height t
     -> context_iwf t_lower_bound t_upper_bound t_height
                    c_lower_bound c_upper_bound c_height c
     -> exists h_lower_bound h_upper_bound,
          match locate k t c with
          | inl c =>
              context_iwf h_lower_bound h_upper_bound 0
                          c_lower_bound c_upper_bound c_height c
          | inr ((_,_),l) =>
              location_iwf h_lower_bound h_upper_bound
                           c_lower_bound c_upper_bound c_height l
          end.
  Proof.
    intros t ; induction t ; intros ; simpl ; repeat mysimp ; repeat rip ;
      repeat
        match goal with
        | [ |- context[ ?a <=>! ?b ] ] =>
            let cmp := fresh "cmp" in
            remember (a <=>! b) as cmp eqn:cmp_eqn ; symmetry in cmp_eqn ;
              destruct cmp as [cmp|cmp|cmp] ;
              [ apply ord_dec_correct_eqv in cmp_eqn
              | apply ord_dec_correct_lt in cmp_eqn
              | apply ord_dec_correct_gt in cmp_eqn
              ]
        | [ |- context[ ?a <=>! ?b ] ] =>
            let cmp := fresh "cmp" in
            remember (a <=>! b) as cmp eqn:cmp_eqn2 ; symmetry in cmp_eqn2 ;
              destruct cmp as [cmp|cmp|cmp] ;
              [ apply ord_dec_correct_eqv in cmp_eqn2
              | apply ord_dec_correct_lt in cmp_eqn2
              | apply ord_dec_correct_gt in cmp_eqn2
              ]
        end ; eauto.
  Qed.

  Lemma locate_greatest_wf :
    forall
      (t:tree K V) (c:context K V)
      t_lower_bound t_upper_bound t_height
      c_lower_bound c_upper_bound c_height,
        tree_iwf t_lower_bound t_upper_bound t_height
     -> context_iwf t_lower_bound t_upper_bound t_height
                    c_lower_bound c_upper_bound c_height c
     -> exists h_lower_bound h_upper_bound,
          match locate_greatest t c with
          | None => t = Null_t
          | Some l

End TwoThreeTreesWF.


Require Import Logic.Class.Eq.

Require Import Logic.List.In.
Require Import Logic.List.Append.

Require Import Logic.Lam.Free.
Require Import Logic.Lam.Valid.
Require Import Logic.Lam.Syntax.

(* A map f:v -> v is admissible for a term t if and only if it is valid         *)
(* for t and keeps all its free variables unchanged. An admissible mapping      *)
(* has the property of not altering the alpha-equivalence class of a term       *)
Definition admissible (v:Type) (e:Eq v) (f:v -> v) (t:T v) : Prop :=
  valid f t /\ forall (x:v), x :: Fr t -> f x = x.

Arguments admissible {v} {e}.

Lemma admissible_valid : forall (v:Type) (e:Eq v) (f:v -> v) (t:T v),
  admissible f t -> valid f t.
Proof.
  intros v e f t H1. destruct H1 as [H1 H2]. assumption.
Qed.

Arguments admissible_valid {v} {e}.

Lemma admissible_free : forall (v:Type) (e:Eq v) (f:v -> v) (t:T v),
  admissible f t -> forall (x:v), x :: Fr t -> f x = x.
Proof.
  intros v e f p H1. destruct H1 as [H1 H2]. assumption.
Qed.

Arguments admissible_free {v} {e}.

Lemma admissible_app : forall (v:Type) (e:Eq v) (f:v -> v) (t1 t2:T v),
  admissible f (App t1 t2) <-> admissible f t1 /\ admissible f t2.
Proof.
  intros v e f t1 t2. split; intros H1.
  - split; unfold admissible in H1; destruct H1 as [H1 H3];
    apply valid_app in H1; destruct H1 as [H1 H2]; unfold admissible.
    + split.
      * assumption.
      * intros x H4. apply H3. simpl. apply app_charac. left. assumption.
    + split.
      * assumption.
      * intros x H4. apply H3. simpl. apply app_charac. right. assumption.
  - destruct H1 as [[H1 H2] [H3 H4]]. unfold admissible. split.
    + apply valid_app. split; assumption.
    + intros x H5. simpl in H5. apply app_charac in H5. destruct H5 as [H5|H5].
      * apply H2. assumption.
      * apply H4. assumption.
Qed.