 (*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

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

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

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export substc_more.
Require Export sequents_tacs.
Require Export per_props_product.
Require Export per_props_function.
Require Export per_props_squash.
Require Export per_props_equality.
Require Export per_props_nat2.
Require Export lsubstc_vars.

(*

   forall m : nat, squash (exists n : nat, P(m,n))

   implies

   squash (exists f : nat -> nat, forall m : nat, squash (P (m, f m)))

 *)
Lemma axiom_of_choice_00 {o} :
  forall lib f m n (P : @CTerm o),
    n <> m
    -> f <> m
    -> (forall a b,
          member lib a mkc_tnat
          -> member lib b mkc_tnat
          -> type lib (mkc_apply2 P a b))
    -> inhabited_type
         lib
         (mkc_forall
            mkc_tnat
            m
            (mkcv_squash
               [m]
               (mkcv_exists
                  [m]
                  (mkcv_tnat [m])
                  n
                  (mkcv_apply2 [n,m]
                               (mk_cv [n,m] P)
                               (mk_cv_app_l [n] [m] (mkc_var m))
                               (mk_cv_app_r [m] [n] (mkc_var n))))))
    -> inhabited_type
         lib
         (mkc_exists
            nat2nat
            f
            (mkcv_forall
               [f]
               (mk_cv [f] mkc_tnat)
               m
               (mkcv_squash
                  [m,f]
                  (mkcv_apply2 [m,f]
                               (mk_cv [m,f] P)
                               (mk_cv_app_r [f] [m] (mkc_var m))
                               (mkcv_apply [m,f]
                                           (mk_cv_app_l [m] [f] (mkc_var f))
                                           (mk_cv_app_r [f] [m] (mkc_var m))))))).
Proof.
  introv d1 d2 impp inh.

  unfold mkc_forall in inh.
  apply inhabited_function in inh.
  repnd.
  clear inh0 inh1.
  exrepnd.

  assert (forall k : CTerm,
            member lib k mkc_tnat
            -> inhabited_type
                 lib
                 (mkc_exists
                    mkc_tnat
                    n
                    (mkcv_apply2
                       [n]
                       (mk_cv [n] P)
                       (mk_cv [n] k)
                       (mkc_var n)))) as q.
  { introv mem.
    pose proof (inh0 k k) as h.
    autodimp h hyp.
    allrw @substc_mkcv_squash.
    rw @equality_in_mkc_squash in h.
    repnd.
    rw @mkcv_exists_substc in h; auto.
    allrw @mkcv_tnat_substc.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv_app_l.
    rw @substc2_mk_cv_app_r in h; auto.
    allrw @substc2_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear inh0.

  assert (forall k : CTerm,
            member lib k mkc_tnat
            -> {j : CTerm
                , member lib j mkc_tnat
                # inhabited_type lib (mkc_apply2 P k j)}) as h.
  { introv mem.
    apply q in mem; clear q.
    apply inhabited_exists in mem; repnd.
    clear mem0 mem1.
    exrepnd.
    exists a; dands; auto.
    allrw @mkcv_apply2_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear q.

  (* First use FunctionalChoice_on to get an existential (a Coq function from terms to terms) *)

  pose proof (FunctionalChoice_on
                {k : CTerm & member lib k mkc_tnat}
                (@CTerm o)
                (fun k j => member lib j mkc_tnat # inhabited_type lib (mkc_apply2 P (projT1 k) j)))
    as fc.
  simphyps.
  autodimp fc hyp; tcsp;[].
  exrepnd.
  clear h.
  rename fc0 into fc.

  assert {c : nat -> nat
          & forall a : CTerm,
              member lib a mkc_tnat
              -> (member lib (mkc_eapply (mkc_nseq c) a) mkc_tnat
                  # inhabited_type lib (mkc_apply2 P a (mkc_eapply (mkc_nseq c) a)))} as fs.
  { exists (fun n =>
              match member_tnat_implies_computes
                      lib
                      (f1 (existT _ (mkc_nat n) (nat_in_nat lib n)))
                      (fst (fc (existT _ (mkc_nat n) (nat_in_nat lib n)))) with
                | existT _ k _ => k
              end).
    introv mem.
    dands.

    - apply member_tnat_iff in mem; exrepnd.
      allrw @computes_to_valc_iff_reduces_toc; repnd.
      eapply member_respects_reduces_toc;[apply reduces_toc_eapply_nseq;exact mem1|].

      remember (member_tnat_implies_computes
                  lib
                  (f1 exI(mkc_nat k, nat_in_nat lib k))
                  (fst (fc exI(mkc_nat k, nat_in_nat lib k)))) as mt.
      exrepnd.

      apply (member_respects_reduces_toc _ _ (mkc_nat k0)).

      + unfold reduces_toc; simpl.
        apply reduces_to_if_step.
        csunf; allsimpl; dcwf h; simpl.
        boolvar; try omega.
        rw @Znat.Nat2Z.id.
        rewrite <- Heqmt; auto.

      + apply member_tnat_iff.
        exists k0.
        apply computes_to_valc_refl; eauto 3 with slow.

    - apply member_tnat_iff in mem; exrepnd.
      pose proof (nat_in_nat lib k) as mk.

      remember (member_tnat_implies_computes
                  lib
                  (f1 exI(mkc_nat k, nat_in_nat lib k))
                  (fst (fc exI(mkc_nat k, nat_in_nat lib k)))) as q.
      exrepnd.
      remember (fc exI(mkc_nat k, nat_in_nat lib k)) as fck.
      exrepnd.
      allsimpl.

      allunfold @inhabited_type; exrepnd.
      exists t.
      allsimpl.

      eapply member_respects_cequivc_type;[|exact fck1].
      apply implies_cequivc_apply2; auto.

      + apply cequivc_sym.
        apply computes_to_valc_implies_cequivc; auto.

      + apply cequivc_sym.
        allrw @computes_to_valc_iff_reduces_toc; repnd.
        eapply cequivc_trans;
          [apply reduces_toc_implies_cequivc;
            apply reduces_toc_eapply_nseq;exact mem1
          |].

        eapply cequivc_trans;
          [|apply cequivc_sym;
             apply computes_to_valc_implies_cequivc;
             exact q0].
        apply reduces_toc_implies_cequivc.
        unfold reduces_toc; simpl.
        apply reduces_to_if_step.
        csunf; simpl; dcwf h; simpl.
        boolvar; try omega.
        allrw @Znat.Nat2Z.id.
        allsimpl.
        rw <- Heqfck; simpl.
        rw <- Heqq; auto.
  }
  clear f1 fc.
  exrepnd.

  (* then "convert" the Coq function into a Nuprl function *)

  apply inhabited_product.

  dands.

  { apply type_nat2nat. }

  { introv eqf.
    unfold mkcv_forall.
    repeat (rw @substc_mkcv_function; auto).
    allrw @csubst_mk_cv.
    apply tequality_function.
    dands.
    { apply tnat_type. }

    introv eqn.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc_mkcv_squash.
    allrw @mkcv_apply2_substc.
    allrw @substc2_mk_cv.
    allrw @csubst_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @substc2_apply.
    repeat (rw @substc2_mk_cv_app_l; auto).
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @mkcv_apply_substc.
    allrw @mkc_var_substc.
    allrw @csubst_mk_cv.

    apply tequality_mkc_squash.
    apply type_respects_cequivc_left.

    { apply implies_cequivc_apply2; auto.
      { apply equality_int_nat_implies_cequivc; auto.
        apply equality_sym; auto. }
      { eapply equality_nat2nat_apply in eqf;[|exact eqn].
        apply equality_int_nat_implies_cequivc; auto.
        apply equality_sym; auto. }
    }

    { apply impp; eauto 3 with slow.
      { apply equality_sym in eqn; apply equality_refl in eqn; auto. }
      { eapply equality_nat2nat_apply in eqf;[|exact eqn].
        apply equality_sym in eqf; apply equality_refl in eqf; auto. }
    }
  }

  { exists (@mkc_nseq o c).
    unfold mkcv_forall.
    repeat (rw @substc_mkcv_function; auto).
    allrw @csubst_mk_cv.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @substc2_apply.
    repeat (rw @substc2_mk_cv_app_l; auto).
    repeat (rw @substc2_mk_cv_app_r; auto).
    allrw @mkc_var_substc.

    dands.

    { apply member_nseq_nat2nat. }

    { apply inhabited_function; dands; eauto 3 with slow.

      - introv eqn.
        allrw @substc_mkcv_squash.
        allrw @mkcv_apply2_substc.
        allrw @mkcv_apply_substc.
        allrw @csubst_mk_cv.
        allrw @mkc_var_substc.

        apply tequality_mkc_squash.
        apply type_respects_cequivc_left.

        { apply implies_cequivc_apply2; auto.
          { apply equality_int_nat_implies_cequivc; auto.
            apply equality_sym; auto. }
          { apply implies_cequivc_apply; auto.
            apply equality_int_nat_implies_cequivc; auto.
            apply equality_sym; auto. }
        }

        { apply impp; eauto 3 with slow.
          { apply equality_sym in eqn; apply equality_refl in eqn; auto. }
          { pose proof (member_nseq_nat2nat lib c) as eqf.
            eapply equality_nat2nat_apply in eqf;[|exact eqn].
            apply equality_sym in eqf; apply equality_refl in eqf; auto. }
        }

      - exists (@mkc_lam o nvarx (mkcv_axiom nvarx)).
        introv eqn.
        allrw @substc_mkcv_squash.
        allrw @mkcv_apply2_substc.
        allrw @mkcv_apply_substc.
        allrw @csubst_mk_cv.
        allrw @mkc_var_substc.

        applydup @equality_int_nat_implies_cequivc in eqn.
        apply equality_refl in eqn.
        eapply equality_respects_cequivc_right;
          [apply implies_cequivc_apply;
            [apply cequivc_refl
            |exact eqn0]
          |].
        rw @member_eq.

        eapply member_respects_cequivc;
          [apply cequivc_sym;
            apply cequivc_beta
          |].
        rw @substc_mkcv_axiom.

        apply equality_in_mkc_squash; dands; spcast;
        try (apply computes_to_valc_refl; eauto 3 with slow).

        pose proof (fs0 a eqn) as q; repnd.

        eapply inhabited_type_cequivc;[|exact q].
        apply implies_cequivc_apply2; auto.
        apply cequivc_sym.
        apply reduces_toc_implies_cequivc.
        destruct_cterms.
        unfold reduces_toc; simpl.
        apply reduces_to_if_step; csunf; simpl; auto.
    }
  }
Qed.

Definition rule_AC00 {o}
           (P e : @NTerm o)
           (f m n : NVar)
           (H : barehypotheses)
           (i : nat) :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_squash (mk_exists (mk_nat2nat) f (mk_forall mk_tnat n (mk_squash (mk_apply2 P (mk_var n) (mk_apply (mk_var f) (mk_var n)))))))))
      [ mk_baresequent H (mk_concl (mk_forall mk_tnat n (mk_squash (mk_exists mk_tnat m (mk_apply2 P (mk_var n) (mk_var m))))) e),
        mk_baresequent H (mk_conclax (mk_member P (mk_fun mk_tnat (mk_fun mk_tnat (mk_uni i))))) ]
      [].

Lemma rule_AC00_true {p} :
  forall lib
         (P e : NTerm)
         (f m n : NVar)
         (H : @barehypotheses p)
         (i : nat)
         (d1 : n <> m)
         (d2 : f <> n)
         (d3 : !LIn f (free_vars P))
         (d4 : !LIn m (free_vars P))
         (d5 : !LIn n (free_vars P)),
    rule_true lib (rule_AC00 P e f m n H i).
Proof.
  unfold rule_AC00, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  destruct hyp1 as [wc1 hyp1].
  rename Hyp0 into hyp2.
  destruct hyp2 as [wc2 hyp2].
  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  exists (@covered_axiom p (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as hh; exrepnd; clear hyp1.
  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as qq; exrepnd; clear hyp2.

  allunfold @mk_forall.
  allunfold @mk_exists.
  allunfold @mk_nat2nat.

  lsubst_tac.
  allapply @member_if_inhabited.
  apply tequality_mkc_member_implies_sp in qq0; auto;[].
  allrw @tequality_mkc_member; repnd.

  lsubst_tac.
  allrw @lsubstc_mkc_tnat.

  pose proof (axiom_of_choice_00 lib f n m (lsubstc P wt s1 ct1)) as ac.
  repeat (autodimp ac hyp).

  - (* from qq1 *)
    introv m1 m2.
    apply equality_in_fun in qq1; repnd.
    pose proof (qq1 a a) as h.
    autodimp h hyp.
    lsubst_tac.
    allrw @lsubstc_mkc_tnat.
    apply equality_in_fun in h; repnd.
    pose proof (h b b) as q.
    autodimp q hyp.
    apply equality_in_uni in q; auto.
    allrw <- @mkc_apply2_eq; auto.

  - (* from hh1 *)
    apply equality_refl in hh1.
    exists (lsubstc e wfce1 s1 pt0).

    repeat lsubstc_vars_as_mkcv.
    auto.

  - repeat lsubstc_vars_as_mkcv.

    dands;
      [|apply equality_in_mkc_squash; dands; spcast;
        try (apply computes_to_valc_refl; eauto 3 with slow);
        allunfold @mkc_exists; allunfold @mkcv_forall;
        eapply inhabited_type_respects_alphaeqc;[|exact ac];
        apply alphaeqc_mkc_product1;
        apply alphaeqc_sym; apply lsubstc_mk_nat2nat].

    apply tequality_mkc_squash.

    eapply tequality_respects_alphaeqc_left;
      [apply alphaeqc_mkc_product1;
        apply alphaeqc_sym;
        apply lsubstc_mk_nat2nat
      |].
    eapply tequality_respects_alphaeqc_right;
      [apply alphaeqc_mkc_product1;
        apply alphaeqc_sym;
        apply lsubstc_mk_nat2nat
      |].
    apply tequality_product; dands.
    { apply type_nat2nat. }

    introv eqf.
    repeat (rw @substc_mkcv_function; auto;[]).
    allrw @mkcv_tnat_substc.
    allrw @substcv_as_substc2.
    allrw @substc2_squash.
    allrw @substc2_apply2.
    allrw @substc2_apply.
    allrw @substc2_mk_cv.
    repeat (rw @substc2_mk_cv_app_r; auto;[]).
    repeat (rw @substc2_mk_cv_app_l; auto;[]).
    allrw @mkc_var_substc.

    apply tequality_function; dands.
    { apply tnat_type. }

    introv eqn.
    allrw @substc_mkcv_squash.
    allrw @mkcv_apply2_substc.
    allrw @mkcv_apply_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.

    apply tequality_mkc_squash.
    apply equality_in_fun in qq0; repnd.
    applydup qq0 in eqn.
    lsubst_tac.
    apply equality_in_fun in eqn0; repnd.
    pose proof (eqn0 (mkc_apply a a0) (mkc_apply a' a'0)) as q.
    allrw @lsubstc_mkc_tnat.
    autodimp q hyp.
    { apply equality_nat2nat_apply; auto. }
    allrw <- @mkc_apply2_eq.
    apply equality_in_uni in q; auto.
Qed.

(*

   forall f : nat -> nat, squash exists n : nat, P(f,n)

   implies

   squash exists F : (nat -> nat) -> nat, forall f : nat -> nat, P (f, F f)

 *)
Lemma axiom_of_choice_10 {o} :
  forall lib F f n (P : @CTerm o),
    n <> f
    -> inhabited_type
         lib
         (mkc_forall
            nat2nat
            f
            (mkcv_squash
               [f]
               (mkcv_exists
                  [f]
                  (mkcv_tnat [f])
                  n
                  (mkcv_apply2 [n,f]
                               (mk_cv [n,f] P)
                               (mk_cv_app_l [n] [f] (mkc_var f))
                               (mk_cv_app_r [f] [n] (mkc_var n))))))
    -> inhabited_type
         lib
         (mkc_squash
            (mkc_exists
               (mkc_fun nat2nat mkc_tnat)
               F
               (mkcv_forall
                  [F]
                  (mk_cv [F] nat2nat)
                  f
                  (mkcv_apply2 [f,F]
                               (mk_cv [f,F] P)
                               (mk_cv_app_r [F] [f] (mkc_var f))
                               (mkcv_apply [f,F]
                                           (mk_cv_app_l [f] [F] (mkc_var F))
                                           (mk_cv_app_r [F] [f] (mkc_var f))))))).
Proof.
  introv d1 inh.
  apply inhabited_squash.

  unfold mkc_forall in inh.
  apply inhabited_function in inh.
  repnd.
  clear inh0 inh1.
  exrepnd.

  assert (forall f : CTerm,
            member lib f nat2nat
            -> inhabited_type
                 lib
                 (mkc_exists
                    mkc_tnat
                    n
                    (mkcv_apply2
                       [n]
                       (mk_cv [n] P)
                       (mk_cv [n] f)
                       (mkc_var n)))) as q.
  { introv mem.
    pose proof (inh0 f1 f1) as h.
    autodimp h hyp.
    allrw @substc_mkcv_squash.
    rw @equality_in_mkc_squash in h.
    repnd.
    rw @mkcv_exists_substc in h; auto.
    allrw @mkcv_tnat_substc.
    allrw @substc2_apply2.
    allrw @substc2_mk_cv_app_l.
    rw @substc2_mk_cv_app_r in h; auto.
    allrw @substc2_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear inh0.

  assert (forall f : CTerm,
            member lib f nat2nat
            -> {k : CTerm
                , member lib k mkc_tnat
                # inhabited_type lib (mkc_apply2 P f k)}) as h.
  { introv mem.
    apply q in mem; clear q.
    apply inhabited_exists in mem; repnd.
    clear mem0 mem1.
    exrepnd.
    exists a; dands; auto.
    allrw @mkcv_apply2_substc.
    allrw @csubst_mk_cv.
    allrw @mkc_var_substc.
    auto.
  }
  clear q.

Abort.


(* TLC in Coq
 *
 * Module: tlc.syntax.constructor
 * Purpose: Contains the syntax of constructors.
 *)

Require Import mathcomp.ssreflect.choice.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.

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

(* Constructors for value terms *)
Inductive constructor :=
(* Unit *)
| CUnit
(* Maybe *)
| CNone
| CSome
(* Either *)
| CLeft
| CRight
(* Pair *)
| CPair
(* Boolean *)
| CFalse
| CTrue
(* Natural *)
| CZero
| CSucc
(* List *)
| CNil
| CCons
(* Orientation *)
| CRequest
| CIndication
| CPeriodic
(* PeriodicEvent *)
| CPE
(* FLRequest *)
| CFLSend
(* FLIndication *)
| CFLDeliver
(* SLRequest *)
| CSLSend
(* SLIndication *)
| CSLDeliver
(* PLRequest *)
| CPLSend
(* PLIndication *)
| CPLDeliver.

(* Equality *)
Section eq.

  (* Boolean equality *)
  Definition constructor_eq f1 f2 :=
    match f1, f2 with
    (* Unit *)
    | CUnit, CUnit => true
    (* Maybe *)
    | CNone, CNone => true
    | CSome, CSome => true
    (* Either *)
    | CLeft, CLeft => true
    | CRight, CRight => true
    (* Pair *)
    | CPair, CPair => true
    (* Boolean *)
    | CFalse, CFalse => true
    | CTrue, CTrue => true
    (* Natural *)
    | CZero, CZero => true
    | CSucc, CSucc => true
    (* List *)
    | CNil, CNil => true
    | CCons, CCons => true
    (* Orientation *)
    | CRequest, CRequest => true
    | CIndication, CIndication => true
    | CPeriodic, CPeriodic => true
    (* PeriodicEvent *)
    | CPE, CPE => true
    (* FLRequest *)
    | CFLSend, CFLSend => true
    (* FLIndication *)
    | CFLDeliver, CFLDeliver => true
    (* SLRequest *)
    | CSLSend, CSLSend => true
    (* SLIndication *)
    | CSLDeliver, CSLDeliver => true
    (* PLRequest *)
    | CPLSend, CPLSend => true
    (* PLIndication *)
    | CPLDeliver, CPLDeliver => true
    (* Unequal *)
    | _, _ => false
    end.

  (* Boolean equality reflection *)
  Lemma constructor_eqP : Equality.axiom constructor_eq.
  Proof.
    by case; case; constructor.
  Qed.

  (* EqType canonical structures *)
  Definition constructor_eqMixin := EqMixin constructor_eqP.
  Canonical constructor_eqType := EqType constructor constructor_eqMixin.

End eq.


From mathcomp
     Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div fintype
     tuple finfun bigop.
From mathcomp
     Require Import ssralg.
Add LoadPath "../mylib".
Require Export mylib mybig myalg.
Require Export NNet_sub_def NNet NNet_alg MPsolvable.

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

Export GRing NNetDef NNet_algDef.

(* ***************************** *)
Section zmodCNNet_lemma.
  Variable (S:zmodCNNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let activation := @NNactivation S.
  Let additivel := @NNadditivel S.
  Let parameter := @MP1parameter S.
  Let MPparameter := @MPparameter S.

  Lemma MPsolvableN1 Idim l Odim P (f:I ^ Idim -> O ^ Odim) j:
    MPsolvable l P f ->
    MPsolvable l P (fun input =>
                    [ffun i => if i == j then (- f input i)%R else f input i]).
  Proof.
    elim : l =>[|Hdim l IHl] in Idim P f *; case =>[p H].
    - exists ([ffun i => if i == j then [ffun k => (- p.1 i k)%R] else p.1 i],
              [ffun i => if i == j then (- p.2 i)%R else p.2 i])
      => input /H ->. apply /ffunP => i. rewrite !ffunE. case : eqP =>//_.
      by rewrite neuron1Nl.
    - apply : MPsolvable_cons=>[|input _|input /H ->].
      + apply : (@IHl _ predT (MPfunction p.2)). exact : MPfunction_solvable.
      + by rewrite unfold_in.
      apply /ffunP => i. by rewrite !ffunE.
  Qed.

End zmodCNNet_lemma.

(* ***************************** *)
Section zmod3NNet_lemma.
  Variable (S:zmod3NNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let actf := @NNactf S.
  Let activation := @NNactivation S.
  Let parameter := @MP1parameter S.
  Let MPparameter := @MPparameter S.

  Lemma MPsolvable_pred1 Idim l Odim (x:I ^ Idim) (f:I ^ Idim -> O ^ Odim):
    MPsolvable l (pred1 x) f.
  Proof.
    apply : MPsolvable_constant => y /=. by rewrite unfold_in =>/eqP ->.
  Qed.

  Let MPsolvable Idim l Odim s := @MPsolvable S Idim l Odim (pred_of_seq s).

  Lemma MPsolvable_nil Idim l Odim (f:I ^ Idim -> O ^ Odim):
    MPsolvable l ([::] : seq (I ^Idim)) f.
  Proof.
    exact : (MPsolvable_eql _ (@MPsolvable_pred0 _ 0%R 0%R _ _ _ _)).
  Qed.

  Lemma MPsolvable_seq1 Idim l Odim (x:I ^ Idim) (f:I ^ Idim -> O ^ Odim):
    MPsolvable l [:: x] f.
  Proof.
    apply : (MPsolvable_eql _ (MPsolvable_pred1 _ x _)) => y.
      by rewrite mem_seq1 unfold_in.
  Qed.

  Definition expressive_number Idim l Odim n :=
    forall (s:seq (I ^ Idim)) (f:I ^ Idim -> O ^ Odim),
      size s = n -> MPsolvable l s f.

  Lemma expressive_number0 Idim l Odim : expressive_number Idim l Odim 0.
  Proof. move =>[]// f _. exact : MPsolvable_nil. Qed.

  Lemma expressive_number1 Idim l Odim : expressive_number Idim l Odim 1.
  Proof. move => [|x []]// f _/=. exact : MPsolvable_seq1. Qed.

  Lemma expressive_number_le Idim l Odim n m :
    n <= m -> expressive_number Idim l Odim m ->
    expressive_number Idim l Odim n.
  Proof.
    move => Hle Hm s f Hsize.
    apply : (MPsolvable_subset
               _ (Hm (s ++ (mkseq (fun => [ffun => 0%R]) (m - n))) f _));
      last by rewrite size_cat Hsize size_mkseq (subnKC Hle).
    exact : (mem_subseq (prefix_subseq _ _)).
  Qed.

  Lemma expressive_number_Idim0 l Odim n : expressive_number 0 l Odim n.
  Proof. move => s f _. exact : MPsolvable_Idim0. Qed.

  Lemma expressive_number_Idim_le Idim1 Idim2 l Odim n :
    Idim1 <= Idim2 -> expressive_number Idim2 l Odim n ->
    expressive_number Idim1 l Odim n.
  Proof.
    move /subnKC =><- H2 s f Hsize.
    case : {H2} (H2 (map (fun x => index_app x [ffun => 0%R]) s)
                    (fun y => f (index_projl y)));
      first by rewrite size_map Hsize.
    case : l =>[|Hdim l]/= p Hp.
    - exists ([ffun i => index_projl (p.1 i)],p.2) => x Hx.
      move : (Hp _ (map_f _ Hx)). rewrite index_projl_app =>->.
        by rewrite MP1_appI index_projl_app index_projr_app MP1_input0.
    - exists (([ffun i => index_projl (p.1.1 i)],p.1.2),p.2) => x Hx.
      move : (Hp _ (map_f _ Hx)). rewrite index_projl_app =>->/=.
        by rewrite MP1_appI index_projl_app index_projr_app MP1_input0.
  Qed.

  Lemma expressive_number_Odim0 Idim l n : expressive_number Idim l 0 n.
  Proof. move => s f _. exact : (MPsolvable_Odim0 0%R 0%R). Qed.

  Lemma expressive_number_Odim_le Idim l Odim1 Odim2 n :
    Odim1 <= Odim2 -> expressive_number Idim l Odim2 n ->
    expressive_number Idim l Odim1 n.
  Proof.
    move /subnKC =><- H2 s f Hsize.
    case : {H2} (H2 _ (fun x => (index_app (f x) [ffun => 0%R])) Hsize).
    elim /last_ind : l =>[|l Hdim IHl] p Hp.
    - exists (index_projl p.1,index_projl p.2) => x /Hp /=.
      rewrite -{2}[f x](@index_projl_app _ _ (Odim2 - Odim1) _ [ffun=> 0%R])
      =>->. by rewrite MP1_appO index_projl_app.
    - exists (MPparameter_rcons (MPparameter_belast p)
                                (index_projl (MPparameter_last p).1,
                                 index_projl (MPparameter_last p).2))
      => x /Hp /=.
      rewrite -{2}[f x](@index_projl_app _ _ (Odim2 - Odim1) _ [ffun=> 0%R])
      =>->. rewrite !MPfunction_rcons /= !MP1_appO index_projl_app.
        by rewrite MPparameter_last_rcons MPparameter_belast_rcons.
  Qed.

  Definition maximum_expressive_number Idim l Odim n :=
    expressive_number Idim l Odim n /\ ~ expressive_number Idim l Odim n.+1.

  Lemma maximum_expressive_numberP Idim l Odim n:
    maximum_expressive_number Idim l Odim n <->
    (forall m, expressive_number Idim l Odim m <-> m <= n).
  Proof.
    split =>[[Hn Hn1] m|Hm]; split.
    - by case : ltnP =>// Hle /(expressive_number_le Hle) /Hn1.
    - move => Hle. exact : (expressive_number_le Hle).
    - exact /Hm.
    - move /Hm. by rewrite ltnn.
  Qed.

  Lemma maximum_expressive_number_not0 Idim l Odim:
    ~ maximum_expressive_number Idim l Odim 0.
  Proof. case =>_. apply. exact : expressive_number1. Qed.

  Lemma maximum_expressive_number_in0 (i0 i1:I) (o0 o1:O) Idim l Odim :
    0 < Idim -> 0 < Odim -> i0 <> i1 -> o0 <> o1 ->
    0 \in l -> maximum_expressive_number Idim l Odim 1.
  Proof.
    move => HIdim HOdim HI HO Hl.
    split =>[|H]; first exact : expressive_number1.
    move : (H [:: [ffun => i0]; [ffun => i1]]
              (fun x => if (x == [ffun => i0])
                        then [ffun => o0] else [ffun => o1]) erefl).
    case /(MPsolvable_in0 Hl) => y Hy. move : (erefl y) HI HO.
    rewrite -{1}(Hy [ffun => i0]) ?mem_head //.
    rewrite -(Hy [ffun => i1]) ?in_cons ?eq_refl ?orbT //.
    case : ifP =>[/eqP|_]/ffunP Heq.
    - move : (Heq (Ordinal HIdim)). by rewrite !ffunE =>->.
    - move : (Heq (Ordinal HOdim)). by rewrite !ffunE =>->.

  Qed.

  Lemma maximum_expressive_number_ex Idim l Odim n:
    ~ expressive_number Idim l Odim n ->
    classically (exists m, maximum_expressive_number Idim l Odim m).
  Proof.
    move => Hn. apply /classicP => Hm. move : Hn.
    elim : n =>[[]|n IHn]; first exact : expressive_number0.
    move => H. apply : IHn => Hn. apply : Hm. exists n. by split.
  Qed.

  Lemma maximum_expressive_number_ex' Idim l Odim n:
    ~ expressive_number Idim l Odim n ->
    ~ ~ exists m, maximum_expressive_number Idim l Odim m.
  Proof.
    move => Hn Hm. move : Hn.
    elim : n =>[[]|n IHn]; first exact : expressive_number0.
    move => H. apply : IHn => Hn. apply : Hm. exists n. by split.
  Qed.

  End zmod3NNet_lemma.


Require Import Common.Common.
Require Import UVal.UVal.
Require Import LogRel.LemmasPseudoType.
Require Import LogRel.PseudoType.
Require Import LogRel.LR.
Require Import Stlc.SpecSyntax.
Require Import Stlc.SpecEvaluation.
Require Import Stlc.LemmasEvaluation.
Require Import Stlc.LemmasTyping.
Require Import Stlc.SpecTyping.
Require Import Utlc.SpecSyntax.
Require Import Utlc.SpecEvaluation.
Require Import Utlc.LemmasEvaluation.
Require Import Utlc.LemmasScoping.
Require Import Utlc.Inst.

Require Import Omega.
Require Import Min.

Lemma lev_lateri {i W} : lev (lateri i W) = lev W - i.
Proof.
  induction i; unfold lev in *; simpl in *; eauto with arith.
  rewrite IHi. omega.
Qed.

Section Obs.
  Lemma obs_zero {d ts tu} : Obs d 0 ts tu.
  Proof.
    destruct d; simpl; intuition.
  Qed.

  Lemma S_Observe_Terminating_value {n ts} :
    S.Value ts → Observe (S n) (S.TerminatingN ts).
  Proof.
    intros vts. simpl. eauto using S.values_terminateN.
  Qed.

  Lemma U_Observe_Terminating_value {n tu} :
    U.Value tu → Observe (S n) (U.TerminatingN tu).
  Proof.
    intros vtu. simpl. eauto using U.values_terminateN.
  Qed.

  Lemma obs_value {d n ts tu} :
    S.Value ts → U.Value tu → Obs d n ts tu.
  Proof.
    intros vs vu.
    destruct d; simpl; intros _;
    eauto using S.values_terminate, U.values_terminate.
  Qed.

  Lemma obs_mono {d W' W ts tu} :
    lev W' ≤ lev W →
    Obs d W ts tu →
    Obs d W' ts tu.
  Proof.
    intros fw obs.
    destruct d; destruct W';
    simpl in *; intuition;
    destruct (S_le fw) as [W'' [eq fw']];
    replace (lev W) with (S W'') in *; simpl in *;
    eauto using S.TerminatingN_lt, U.TerminatingN_lt.
  Qed.

  Lemma S_ObserveTerminatingN_xor_evaln {t t' n} :
    S.evaln t t' n → False ↔ Observe n (S.TerminatingN t).
  Proof.
    destruct n; simpl in *; intuition; eauto using S.TerminatingN_xor_evaln.
  Qed.

  Lemma S_Observe_TerminatingN_evaln {t t' n } n' :
    S.evaln t t' n → Observe n' (S.TerminatingN t') ↔ Observe (n + n') (S.TerminatingN t).
  Proof.
    destruct n';
      [ replace (n + 0) with n by omega
      | replace (n + S n') with (S n + n') by omega ];
    simpl in *; eauto using S.TerminatingN_evaln, S_ObserveTerminatingN_xor_evaln.
  Qed.

  Lemma S_Observe_TerminatingN_lt {t n n'} :
    n ≤ n' → Observe n (S.TerminatingN t) → Observe n' (S.TerminatingN t).
  Proof.
    intros ineq obs.
    destruct n; simpl; intuition.
    destruct (S_le ineq) as [n'' [eq ineq']]; subst; simpl in *.
    eauto using S.TerminatingN_lt.
  Qed.

  Lemma U_ObserveTerminatingN_xor_evaln {t t' n} :
    U.evaln t t' n → False ↔ Observe n (U.TerminatingN t).
  Proof.
    destruct n; simpl in *; intuition; eauto using U.TerminatingN_xor_evaln.
  Qed.

  Lemma U_Observe_TerminatingN_evaln {t t' n } n' :
    U.evaln t t' n → Observe n' (U.TerminatingN t') ↔ Observe (n + n') (U.TerminatingN t).
  Proof.
    destruct n';
      [ replace (n + 0) with n by omega
      | replace (n + S n') with (S n + n') by omega ];
    simpl in *; eauto using U.TerminatingN_evaln, U_ObserveTerminatingN_xor_evaln.
  Qed.

  Lemma U_Observe_TerminatingN_lt {t n n'} :
    n ≤ n' → Observe n (U.TerminatingN t) → Observe n' (U.TerminatingN t).
  Proof.
    intros ineq obs.
    destruct n; simpl; intuition.
    destruct (S_le ineq) as [n'' [eq ineq']]; subst; simpl; simpl in obs.
    eauto using U.TerminatingN_lt.
  Qed.

  Lemma obs_antired {ts ts' tu tu' W' W d i j} :
    S.evaln ts ts' i →
    U.evaln tu tu' j →
    (* W' ≤ W → *)
    lev W' + min i j ≥ lev W →
    Obs d W' ts' tu' →
    Obs d W ts tu.
  Proof.
    intros es eu (* fw *) sge obs.
    destruct d; destruct W; simpl; simpl in obs; intuition.
    - cut (tu'⇓).
      + refine (U.termination_closed_under_antireductionStar _).
        eauto using evaln_to_evalStar.
      + apply obs; clear obs.
        rewrite -> (S_Observe_TerminatingN_evaln (lev W') es).
        assert (obs : Observe (S W) (S.TerminatingN ts)) by (simpl; intuition).
        refine (S_Observe_TerminatingN_lt _ obs).
        unfold lev in *.
        enough (min i j ≤ i) by omega.
        auto using le_min_l.
    - refine (S.termination_closed_under_antireductionStar _ _).
      + refine (stepRel_to_evalStar es).
      + apply obs; clear obs.
        assert (obs : Observe (S W) (U.TerminatingN tu)) by (simpl; intuition).
        rewrite -> (U_Observe_TerminatingN_evaln (lev W') eu).
        refine (U_Observe_TerminatingN_lt _ obs).
        unfold lev in *.
        enough (min i j ≤ j) by omega.
        auto using le_min_r.
  Qed.

  Lemma S_ObserveTerminating_Value {w vs} :
    S.Value vs →
    Observe (S w) (S.TerminatingN vs).
  Proof.
    intros vvs; simpl.
    apply S.values_terminateN; trivial.
  Qed.

  Lemma Diverge_Obs_lt {w ts tu} : not (S.Terminating ts) → Obs dir_lt w ts tu.
  Proof.
    intros div termobs.
    destruct w; try contradiction.
    apply S.TerminatingN_Terminating in termobs.
    exfalso; eauto.
  Qed.

  Lemma Diverge_Wrong_Obs {d w ts tu} :
    not (S.Terminating ts) →
    (not (U.Terminating tu) ∨ clos_refl_trans_1n UTm U.eval tu wrong) →
    Obs d w ts tu.
  Proof.
    intros div divw.
    destruct d; intros termobs.
    - destruct w; try contradiction.
      apply S.TerminatingN_Terminating in termobs.
      exfalso; eauto.
    - destruct w; try contradiction.
      apply U.TerminatingN_Terminating in termobs.
      exfalso; eauto using Terminating_not_div_wrong.
  Qed.

End Obs.

Section ClosedLR.
  Lemma valrel_implies_OfType {d W τ ts tu} :
    valrel d W τ ts tu → OfType τ ts tu.
  Proof.
    rewrite -> valrel_fixp. unfold valrel'. intuition.
  Qed.

  Lemma envrel_triv {d w γs γu} :
    envrel d w pempty γs γu.
  Proof.
    unfold envrel.
    intros i τ i_τ.
    depind i_τ.
  Qed.

  Lemma envrel_implies_WtSub {d W Γ γs γu} :
    envrel d W Γ γs γu → WtSub (repEmulCtx Γ) empty γs.
  Proof.
    intros er i τ vi_τ.
    destruct (getevar_repEmulCtx vi_τ) as [pτ [vi_pτ ?]].
    assert (vr : valrel d W pτ (γs i) (γu i)) by refine (er _ _ vi_pτ).
    destruct (valrel_implies_OfType vr) as [[_ ots] _].
    unfold OfTypeStlc in ots.
    subst. exact ots.
  Qed.

  Lemma envrel_implies_WsSub {d W Γ γs γu}:
    envrel d W Γ γs γu → WsSub (pdom Γ) 0 γu.
  Proof.
    intros er i wsi.
    destruct (pdom_works_inv wsi) as (τ & τinΓ).
    specialize (er i τ τinΓ).
    destruct (valrel_implies_OfType er) as (_ & ws & _).
    exact ws.
  Qed.

  Local Ltac crush :=
    crushOfType;
    repeat
      (cbn in *;
       subst*;
       repeat crushUtlcSyntaxMatchH;
       repeat crushStlcSyntaxMatchH;
       destruct_conjs;
       intuition).

  Lemma valrel_mono {d W τ ts tu W'} :
    W' ≤ W → valrel d W τ ts tu → valrel d W' τ ts tu.
  Proof with subst; intuition.
    rewrite -> ?valrel_fixp.
    revert ts tu W' W.
    induction τ;  unfold valrel';
    intros ts tu W' W fw [ot hyp];
    split; eauto; cbn in *.
    - (* ptarr _ _ *)
      destruct_conjs; subst.
      intros W'' fw'.
      apply hyp; try omega.
    - (* ptprod *)
      crush.
    - (* ptsum *)
      crush.
    - (* pEmulDV n p *)
      destruct n; [ assumption | idtac ].
      destruct hyp as [[eqs eqp]|[ts' hyp]];
        [ now left
        | right; exists ts'].
      repeat (destruct hyp as [[eqs hyp]|hyp]; [ left | right]);
        crush; destruct ts'; crush;
        try match goal with
            [ |- (∃ tub, U.abs ?tub' = U.abs tub ∧ _) ] => (exists tub')
            end; try destruct tu; crush;
        match goal with
            [ H : ∀ w' : nat, w' < ?W → False, _ : ?w' < _ |- False ] => eapply (H w')
        end; omega.
  Qed.

  Lemma envrel_mono {d W Γ γs γu W'} :
    W' ≤ W → envrel d W Γ γs γu → envrel d W' Γ γs γu.
  Proof.
    intros fw er i τ viτ.
    refine (valrel_mono fw _).
    apply er; auto.
  Qed.

  Lemma contrel_mono {d W τ Cs Cu W'} :
    W' ≤ W → contrel d W τ Cs Cu → contrel d W' τ Cs Cu.
  Proof.
    intros fw cr. simpl.
    intros W'' fw' vs vu vr.
    apply cr; try omega; auto.
  Qed.

  Lemma termrel_zero {d τ ts tu} : termrel d 0 τ ts tu.
  Proof.
    intros Cs Cu cr eCs eCu. eauto using obs_zero.
  Qed.

  Lemma termrel_antired {ts ts' tu tu' W d τ i j} W' :
    S.evaln ts ts' i →
    U.ctxevaln tu tu' j →
    W' ≤ W →
    lev W' + min i j ≥ lev W →
    termrel d W' τ ts' tu' →
    termrel d W τ ts tu.
  Proof.
    intros es eu fw sge tr.
    unfold termrel, termrel'.
    intros Cs Cu ecs ecu cr.
    refine (obs_antired _ _ sge _); eauto using S.evaln_ctx, U.ctxevaln_ctx.
    apply tr; auto.
    refine (contrel_mono fw cr).
  Qed.

  Lemma termrel_antired_star {ts ts' tu tu' W d τ} :
    clos_refl_trans_1n S.Tm S.eval ts ts' →
    U.ctxevalStar tu tu' →
    termrel d W τ ts' tu' →
    termrel d W τ ts tu.
  Proof.
    intros es eu tr.
    destruct (evalTrans_to_stepRel es) as [i esi].
    destruct (evalTrans_to_stepRel eu) as [j euj].
    refine (termrel_antired W esi euj _ _ tr); omega.
  Qed.

  Lemma termrel_antired_star_left {ts ts' tu W d τ} :
    clos_refl_trans_1n S.Tm S.eval ts ts' →
    termrel d W τ ts' tu →
    termrel d W τ ts tu.
  Proof.
    assert (U.ctxevalStar tu tu) by (simpl; eauto with eval).
    eauto using termrel_antired_star.
  Qed.

  Lemma termrel_antired_eval_left {ts ts' tu W d τ} :
    S.eval ts ts' →
    termrel d W τ ts' tu →
    termrel d W τ ts tu.
  Proof.
    eauto using termrel_antired_star_left with eval.
  Qed.

  (* Lemma termrel_antired' {ts ts' tu tu' W d τ i j} W' : *)
  (*   S.evaln ts ts' i → *)
  (*   U.evaln tu tu' j →  *)
  (*   tu' ≠ wrong → *)
  (*   W' ≤ W → *)
  (*   lev W' + min i j ≥ lev W → *)
  (*   termrel d W' τ ts' tu' → *)
  (*   termrel d W τ ts tu. *)
  (* Proof. *)
  (*   intros es eu nw. *)
  (*   apply termrel_antired; try assumption. *)
  (*   induction eu; eauto using evaln; econstructor; eauto using evaln. *)
  (*   apply eval_ctx; try assumption. *)
  (*   intro eq; depind eu; intuition. *)
  (*   destruct H0 as [C'|C' eq']; destruct C'; simpl in eq; destruct H0; inversion eq; intuition. *)
  (* Qed. *)

  Lemma valrel_in_termrel {ts tu W d τ} :
    valrel d W τ ts tu → termrel d W τ ts tu.
  Proof.
    intros vr Cs Cu eCs eCu contrel.
    apply contrel; auto.
  Qed.

  Lemma valrel_implies_Value {d w τ ts tu} :
    valrel d w τ ts tu →
    S.Value ts ∧ U.Value tu.
  Proof.
    intros vr.
    rewrite -> valrel_fixp in vr.
    destruct vr as [ot _].
    exact (OfType_implies_Value ot).
  Qed.

  Lemma contrel_triv {d w τ} :
    contrel d w τ S.phole U.phole.
  Proof.
    unfold contrel, contrel'; intros w' fw ts tu vr; simpl.
    destruct (valrel_implies_Value vr).
    apply obs_value; trivial.
  Qed.

  Lemma extend_envrel {d w Γ γs γu τ ts tu} :
    valrel d w τ ts tu →
    envrel d w Γ γs γu →
    envrel d w (Γ p▻ τ) (γs↑ >=> beta1 ts) (γu↑ >=> beta1 tu).
  Proof.
    intros vr er x τ' xτ'.
    depind xτ'; intuition.
    replace ((γs↑ >=> beta1 ts) (S i)) with (γs i).
    replace ((γu↑ >=> beta1 tu) (S i)) with (γu i).
    now refine (er _ _ xτ').
    + cbn; rewrite <- ap_liftSub;
      rewrite -> liftSub_wkm;
      rewrite -> apply_wkm_beta1_cancel; intuition.
    + cbn; rewrite <- ap_liftSub;
      rewrite -> liftSub_wkm;
      rewrite -> apply_wkm_beta1_cancel; intuition.
  Qed.

  Lemma termrel_adequacy_lt {w m ts tu τ} :
    termrel dir_lt w τ ts tu →
    S.TerminatingN ts m →
    lev w > m →
    U.Terminating tu.
  Proof.
    intros tr term ineq.
    specialize (tr S.phole U.phole I I contrel_triv).
    simpl in tr. unfold lev in *.
    destruct (le_inv_plus ineq) as [r eq]; subst.
    apply tr.
    change (S m + r) with (S (m + r)) in *.
    apply (S.TerminatingN_lt term); omega.
  Qed.

  Lemma termrel_adequacy_gt {w m tu ts τ} :
    termrel dir_gt w τ ts tu →
    U.TerminatingN tu m →
    lev w > m →
    S.Terminating ts.
  Proof.
    intros tr term ineq.
    specialize (tr S.phole U.phole I I contrel_triv).
    simpl in tr. unfold lev in *.
    destruct (le_inv_plus ineq) as [r eq]; subst.
    apply tr.
    change (S m + r) with (S (m + r)) in *.
    apply (U.TerminatingN_lt term); omega.
  Qed.

  Lemma termrel_div_lt {w τ ts tu} : not (S.Terminating ts) → termrel dir_lt w τ ts tu.
  Proof.
    intros div Cs Cu eCs eCu contrel.
    eauto using Diverge_Obs_lt, S.divergence_closed_under_evalcontext.
  Qed.

  Lemma termrel_div_wrong {d w τ ts tu} :
    not (S.Terminating ts) →
    (not (U.Terminating tu) ∨ clos_refl_trans_1n UTm U.eval tu U.wrong) →
    termrel d w τ ts tu.
  Proof.
    intros div divw Cs Cu eCs eCu _.
    eauto using Diverge_Wrong_Obs, S.divergence_closed_under_evalcontext.
    eapply Diverge_Wrong_Obs.
    - eauto using S.divergence_closed_under_evalcontext.
    - destruct divw as [divu | termwu]; [left|right].
      + eapply div_ectx; trivial.
      + eapply eval_to_wrong_ectx; trivial.
  Qed.
End ClosedLR.

Section OpenLR.

  Lemma compat_var {Γ d n τ i} :
    ⟪ i : τ p∈ Γ ⟫ →
    ⟪ Γ ⊩ S.var i ⟦ d , n ⟧ U.var i : τ ⟫.
  Proof.
    intros iτ. unfold OpenLRN.
    split;[|split].
    - crushTyping.
      eauto using repEmulCtx_works.
    - crushUtlcScoping.
      eauto using pdom_works.
    - intros ? _ ? ? er.
      apply valrel_in_termrel.
      refine (er _ _ iτ).
  Qed.

  Lemma adequacy_lt {n m ts tu τ} :
    ⟪ pempty ⊩ ts ⟦ dir_lt , n ⟧ tu : τ ⟫ →
    S.TerminatingN ts m →
    n > m →
    U.Terminating tu.
  Proof.
    intros lr term ineq.
    destruct lr as (tsty & tuscp & lr).
    set (w := n).
    assert (le_w : lev w ≤ n) by (unfold lev, w; omega).
    assert (er : envrel dir_lt w pempty (idm S.Tm) (idm U.UTm)) by apply envrel_triv.
    pose proof (lr w le_w (idm S.Tm) (idm U.UTm) er) as tr.
    rewrite -> ?ap_id in tr.
    eapply (termrel_adequacy_lt tr term); trivial.
  Qed.

  Lemma adequacy_gt {n m tu ts τ} :
    ⟪ pempty ⊩ ts ⟦ dir_gt , n ⟧ tu : τ ⟫ →
    U.TerminatingN tu m →
    n > m →
    S.Terminating ts.
  Proof.
    intros lr term ineq.
    destruct lr as (tsty & tuscp & lr).
    set (w := n).
    assert (le_w : lev w ≤ n) by (unfold lev, w; omega).
    assert (er : envrel dir_lt w pempty (idm S.Tm) (idm U.UTm)) by apply envrel_triv.
    pose proof (lr w le_w (idm S.Tm) (idm U.UTm) er) as tr.
    rewrite -> ?ap_id in tr.
    eapply (termrel_adequacy_gt tr term); trivial.
  Qed.

End OpenLR.

Section TermRelZero.

  Lemma valrel_in_termreli₀ {d dfc w τ ts tu} :
    valrel d w τ ts tu → termreli₀ d dfc w τ ts tu.
  Proof.
    intros vr.
    destruct (valrel_implies_OfType vr) as [[? ?] ?].
    unfold termrel₀. simpl.
    left. exists ts, tu.
    (* why isn't this enough? *)
    (* eauto using clos_refl_trans_1n with eval. *)
    split; [|split];
    eauto using clos_refl_trans_1n with eval; constructor.
  Qed.

  Lemma valrel_in_termrel₀ {d w τ ts tu} :
    valrel d w τ ts tu → termrel₀ d  w τ ts tu.
  Proof.
    unfold termrel₀.
    eauto using valrel_in_termreli₀.
  Qed.

  Lemma termrel₀_in_termrel {d w τ ts tu} :
    termrel₀ d w τ ts tu → termrel d w τ ts tu.
  Proof.
    destruct 1 as [(vs & vu & ess & esu & vr)|div].
    - eauto using termrel_antired_star, valrel_in_termrel.
    - unfold termrel, termrel'; eauto.
  Qed.

  Lemma termreli₀_antired {ts ts' tu tu' W d dfc τ i j} dfc' :
    dfc' + min i j ≥ dfc  →
    S.evaln ts ts' i →
    U.ctxevaln tu tu' j →
    termreli₀ d dfc W τ ts' tu' →
    termreli₀ d dfc' W τ ts tu.
  Proof.
    intros ineq es eu tzi.
    destruct tzi as [(vs & vu & es' & eu' & vr)|?].
    - left. exists vs, vu.
      eapply stepRel_to_evalStar in es.
      eapply stepRel_to_evalStar in eu.
      unfold U.ctxevalStar in *.
      eauto using evalStepTrans with eval.
    - right. intros Cs Cu eCs eCu.
      specialize (H Cs Cu eCs eCu).

      pose proof (ctxevaln_evaln_ctx eu Cu eCu) as eu'.
      pose proof (evaln_ctx eCs es) as es'.
      enough (lev (lateri dfc W) + Nat.min i j ≥ lev (lateri dfc' W)) as ineq' by
          eapply (obs_antired es' eu' ineq' H).
      rewrite ?lev_lateri; unfold lev.
      omega.
  Qed.

  Lemma termreli₀_antired_star {ts ts' tu tu' W d dfc τ} :
    clos_refl_trans_1n S.Tm S.eval ts ts' →
    U.ctxevalStar tu tu' →
    termreli₀ d dfc W τ ts' tu' →
    termreli₀ d dfc W τ ts tu.
  Proof.
    intros es eu tr.
    destruct tr as [(vs & vu & ess & esu & vr)|div].
    - left; exists vs, vu.
      simpl in *.
      eauto using evalStepTrans.
    - right. intros Cs Cu eCs eCu.
      destruct (evalTrans_to_stepRel (evalstar_ctx Cs eCs es)) as (? & es').
      destruct (evalTrans_to_stepRel eu) as (? & eu').
      pose proof (ctxevaln_evaln_ctx eu' Cu eCu) as eu''.
      specialize (div Cs Cu eCs eCu).
      eapply (obs_antired (W' := (lateri dfc W)) es' eu''); try assumption.
      rewrite ?lev_lateri.
      omega.
  Qed.

  Lemma termreli₀_div_lt {w dfc τ ts tu} : not (S.Terminating ts) → termreli₀ dir_lt dfc w τ ts tu.
  Proof.
    intros div. right. intros  Cs Cu eCs eCu.
    eauto using Diverge_Obs_lt, S.divergence_closed_under_evalcontext.
  Qed.

  Lemma termreli₀_div_wrong {d dfc w τ ts tu} :
    not (S.Terminating ts) →
    (not (U.Terminating tu) ∨ clos_refl_trans_1n UTm U.eval tu U.wrong) →
    termreli₀ d dfc w τ ts tu.
  Proof.
    intros div divw. right. intros Cs Cu eCs eCu.
    eauto using Diverge_Wrong_Obs, S.divergence_closed_under_evalcontext.
    eapply Diverge_Wrong_Obs.
    - eauto using S.divergence_closed_under_evalcontext.
    - destruct divw as [divu | termwu]; [left|right].
      + eapply div_ectx; trivial.
      + eapply eval_to_wrong_ectx; trivial.
  Qed.
  Lemma termrel₀_antired_star {ts ts' tu tu' W d τ} :
    clos_refl_trans_1n S.Tm S.eval ts ts' →
    U.ctxevalStar tu tu' →
    termrel₀ d W τ ts' tu' →
    termrel₀ d W τ ts tu.
  Proof.
    eapply termreli₀_antired_star.
  Qed.

  Lemma termrel₀_antired_star_left {ts ts' tu W d τ} :
    clos_refl_trans_1n S.Tm S.eval ts ts' →
    termrel₀ d W τ ts' tu →
    termrel₀ d W τ ts tu.
  Proof.
    assert (U.ctxevalStar tu tu) by (simpl; eauto with eval).
    eauto using termrel₀_antired_star.
  Qed.

  Lemma termrel₀_ectx {d dfc w τ₁ τ₂ ts Cs tu Cu} (eCs : S.ECtx Cs) (eCu : U.ECtx Cu) :
    termreli₀ d dfc w τ₁ ts tu →
    (∀ vs vu, valrel d w τ₁ vs vu → termreli₀ d dfc w τ₂ (S.pctx_app vs Cs) (U.pctx_app vu Cu)) →
    termreli₀ d dfc w τ₂ (S.pctx_app ts Cs) (U.pctx_app tu Cu).
  Proof.
    intros trtm trcont.
    destruct trtm as [(vs & vu & ess & esu & vr)|div].
    - specialize (trcont vs vu vr).
      refine (termreli₀_antired_star _ _ trcont);
        eauto using evalstar_ctx, extend_ctxevalStar.
    - right.
      intros Cs' Cu' eCs' eC'.
      rewrite <- S.pctx_cat_app.
      rewrite <- U.pctx_cat_app.
      eauto using S.ectx_cat, U.ectx_cat.
  Qed.

  Lemma termrel₀_ectx' {d dfc w τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termreli₀ d dfc w τ₁ ts tu →
    (∀ vs vu, valrel d w τ₁ vs vu → termreli₀ d dfc w τ₂ (S.pctx_app vs Cs) (U.pctx_app vu Cu)) →
    ts' = S.pctx_app ts Cs →
    tu' = U.pctx_app tu Cu →
    S.ECtx Cs → U.ECtx Cu →
    termreli₀ d dfc w τ₂ ts' tu'.
  Proof.
    intros. subst.
    eauto using termrel₀_ectx.
  Qed.

  Lemma termrel₀_zero {d τ ts tu} :
    termrel₀ d 0 τ ts tu.
  Proof.
    right.
    intros Cs Cu eCs eCu.
    eapply obs_zero.
  Qed.

  Lemma termrel₀_ectx'' {d w' w τ₁ τ₂ ts Cs tu Cu} (eCs : S.ECtx Cs) (eCu : U.ECtx Cu) :
    termrel₀ d w' τ₁ ts tu →
    (∀ vs vu, valrel d w' τ₁ vs vu → termrel₀ d w τ₂ (S.pctx_app vs Cs) (U.pctx_app vu Cu)) →
    w ≤ w' →
    termrel₀ d w τ₂ (S.pctx_app ts Cs) (U.pctx_app tu Cu).
  Proof.
    intros trtm trcont ineq.
    destruct trtm as [(vs & vu & ess & esu & vr)|div].
    - specialize (trcont vs vu vr).
      refine (termrel₀_antired_star _ _ trcont);
        eauto using evalstar_ctx, extend_ctxevalStar.
    - right.
      intros Cs' Cu' eCs' eC'.
      rewrite <- S.pctx_cat_app.
      rewrite <- U.pctx_cat_app.
      eauto using S.ectx_cat, U.ectx_cat, obs_mono.
  Qed.

  Lemma termrel₀_ectx''' {d w w' τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termrel₀ d w' τ₁ ts tu →
    (∀ vs vu, valrel d w' τ₁ vs vu → termrel₀ d w τ₂ (S.pctx_app vs Cs) (U.pctx_app vu Cu)) →
    ts' = S.pctx_app ts Cs →
    tu' = U.pctx_app tu Cu →
    S.ECtx Cs → U.ECtx Cu →
    w ≤ w' →
    termrel₀ d w τ₂ ts' tu'.
  Proof.
    intros. subst.
    eauto using termrel₀_ectx''.
  Qed.

  Lemma termreli₀_dfc_mono {d dfc dfc' w τ ts tu}:
    termreli₀ d dfc w τ ts tu →
    dfc ≤ dfc' →
    termreli₀ d dfc' w τ ts tu.
  Proof.
    destruct 1 as [(vs & vu & ess & esu & vr)|div]; intros ineq.
    - left. exists vs, vu. eauto.
    - right. intros Cs Cu eCs eCu.
      specialize (div Cs Cu eCs eCu).
      refine (obs_mono _ div).
      rewrite ?lev_lateri.
      omega.
  Qed.

  Lemma termreli₀_ectx {d dfc w τ₁ τ₂ ts Cs tu Cu} (eCs : S.ECtx Cs) (eCu : U.ECtx Cu) :
    termrel₀ d (lateri dfc w) τ₁ ts tu →
    lev w ≥ dfc →
    (∀ vs vu, valrel d (lateri dfc w) τ₁ vs vu → termreli₀ d dfc w τ₂ (S.pctx_app vs Cs) (U.pctx_app vu Cu)) →
    termreli₀ d dfc w τ₂ (S.pctx_app ts Cs) (U.pctx_app tu Cu).
  Proof.
    intros trtm ineq trcont.
    destruct trtm as [(vs & vu & ess & esu & vr)|div].
    - specialize (trcont vs vu vr).
      eapply termreli₀_antired_star in trcont;
        eauto using evalstar_ctx, extend_ctxevalStar.
    - right.
      intros Cs' Cu' eCs' eC'.
      rewrite <- S.pctx_cat_app.
      rewrite <- U.pctx_cat_app.
      eauto using S.ectx_cat, U.ectx_cat.
  Qed.

  Lemma termreli₀_ectx' {d dfc w τ₁ τ₂ ts Cs tu ts' tu' Cu} :
    termrel₀ d (lateri dfc w) τ₁ ts tu →
    lev w ≥ dfc →
    (∀ vs vu, valrel d (lateri dfc w) τ₁ vs vu → termreli₀ d dfc w τ₂ (S.pctx_app vs Cs) (U.pctx_app vu Cu)) →
    ts' = S.pctx_app ts Cs →
    tu' = U.pctx_app tu Cu →
    S.ECtx Cs → U.ECtx Cu →
    termreli₀ d dfc w τ₂ ts' tu'.
  Proof.
    intros. subst.
    eauto using termreli₀_ectx.
  Qed.

End TermRelZero.

Ltac crushLRMatch :=
  match goal with
      [ |- _ ∧ _ ] => split
    | [ |- context[ lev ]] => unfold lev
    | [ H : context[ lev ] |- _ ] => unfold lev in *
    | [ |- ⟪ _ ⊩ _ ⟦ _ , _ ⟧ _ : _ ⟫ ] => (unfold OpenLRN; split)
    | [ H : ⟪ _ ⊩ _ ⟦ _ , _ ⟧ _ : _ ⟫ |- _ ] => (unfold OpenLRN in H; destruct_conjs)
    | [ H : valrel ?d _ ?τ ?ts ?tu |- termrel ?d _ ?τ ?ts ?tu ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ (S.abs _ _) (U.abs _) ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ S.unit U.unit ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ S.false U.false ] => apply valrel_in_termrel
    | [ |- termrel _ _ _ S.true U.true ] => apply valrel_in_termrel
    | [ H : valrel ?d ?w ?τ ?ts ?tu |- valrel ?d ?w' ?τ ?ts ?tu ] => (refine (valrel_mono _ H); try omega)
    | [ H : envrel ?d ?w ?τ ?ts ?tu |- envrel ?d ?w' ?τ ?ts ?tu ] => (refine (envrel_mono _ H); try omega)
    | [ |- envrel ?d ?w (?Γ p▻ ?τ) (?γs↑ >=> beta1 ?ts) (?γu↑ >=> beta1 ?tu) ] => refine (extend_envrel _ _)
    | [ H : valrel _ _ ?τ ?ts ?tu |- OfType ?τ ?ts ?tu ] => refine (valrel_implies_OfType H)
    | [ |- valrel _ _ _ _ _] => rewrite -> valrel_fixp in |- *; unfold valrel' in |- *
    | [ |- S.ECtx (S.pctx_cat _ _) ] => apply S.ectx_cat
    | [ |- U.ECtx (U.pctx_cat _ _) ] => apply U.ectx_cat
  end.


Set Implicit Arguments.

Require Import Max.
Require Import Equality.
Require Import Eqdep_dec.
Require Import Variable_Sets.

Require Export DGP_Core.
Require Export Metatheory_Env.

(** Reference: ##Aydemir et. al. 2007## *)

(**********************************************************************)
(** * Importing Dgp for the locally nameless approach *)
(**********************************************************************)

Module Export LNameless := Dgp TwoNat Single.

(** [TwoNat] stands for the disjoint union of free variables (using inl)
   and bound variables (using inr).

   [Single] is a unit type and denotes the empty place holder
   for binding variables which are not written directly
   in de Bruijn style representation for abstraction. *)

(** Note that [atom] = [nat]. *)

(**********************************************************************)
(** * 1. Generic Definitions *)
(**********************************************************************)

(**********************************************************************)
(** ** Heterogeneous Substitution *)
(**********************************************************************)

(** The following definition deals with heterogeneous substitution;
   - [r0] is the representation of the variables to be substituted.

   - [Var] case: only the case [r = r0] is interesting.

   - [Bind] case: Note that, when [r1 = REC], [r0] is compared with [r]
     because [REC] denotes the representation of the abstraction
     body [r].

   - Note that the argument [r0] is the crucial point
     for the heterogeneous definition. *)

(** Substitution for parameters *)

Fixpoint fsubstRep r r0 s (T:InterpretRep r s)(a:atom)(U:Interpret r0) : InterpretRep r s :=
  match T with
    | Unit           => Unit
    | Const _ T0     => Const r T0
    | Repr _ T0      => Repr r (fsubst T0 a U)
    | InL _ _ T0     => InL _ (fsubstRep T0 a U)
    | InR _ _ T0     => InR _ (fsubstRep T0 a U)
    | Pair _ _ T0 T1 => Pair (fsubstRep T0 a U) (fsubstRep T1 a U)
    | Bind r1 _ _ T0 => Bind r1 tt (fsubstRep T0 a U)
    | Rec T0         => Rec (fsubst T0 a U)
  end
with fsubst r r0 (T:Interpret r)(a:atom)(U:Interpret r0) : Interpret r :=
  match T with
    | Var v  =>
      match Rep_dec r r0 with
        | left same =>
          match v with
            | inl b => if (AtomDT.eq_dec a b) then conv same U else T
            | inr _ => T
          end
        | right _ => T
      end
    | Term T0 => Term (fsubstRep T0 a U)
  end.

(** Substitution for (bound) variables *)

(*
Fixpoint bsubstRep r r0 s (T:InterpretRep r s)(m:atom)(U:Interpret r0) : InterpretRep r s :=
  match T with
    | Unit            => Unit
    | Const _ T0      => Const r T0
    | Repr _ T0       => Repr r (bsubst T0 m U)
    | InL _ _ T0      => InL _ (bsubstRep T0 m U)
    | InR _ _ T0      => InR _ (bsubstRep T0 m U)
    | Pair _ _ T0 T1  => Pair (bsubstRep T0 m U) (bsubstRep T1 m U)
    | Bind r1 _ _ T0  =>
      match Rep_dec (if Rep_dec r1 REC then r else r1) r0 with
        | left _ => Bind r1 tt (bsubstRep T0 (S m) U)
        | _      => Bind r1 tt (bsubstRep T0 m U)
      end

    | Rec T0          => Rec (bsubst T0 m U)
  end

with bsubst r r0 (T:Interpret r)(m:atom)(U:Interpret r0) : Interpret r :=
  match T with
    | Var v  =>
      match Rep_dec r r0 with
        | left same =>
          match v with
            | inl _ => T
            | inr k => if (AtomDT.eq_dec m k) then conv same U else T
          end
        | right _ => T
      end
    | Term T0 => Term (bsubstRep T0 m U)
  end.
*)

Fixpoint bsubstRep r r0 s (T:InterpretRep r s)(m:atom)(U:Interpret r0) : InterpretRep r s :=
  match T with
    | Unit            => Unit
    | Const _ T0      => Const r T0
    | Repr _ T0       => Repr r (bsubst T0 m U)
    | InL _ _ T0      => InL _ (bsubstRep T0 m U)
    | InR _ _ T0      => InR _ (bsubstRep T0 m U)
    | Pair _ _ T0 T1  => Pair (bsubstRep T0 m U) (bsubstRep T1 m U)
    | Bind r1 _ _ T0  =>
      match Rep_dec r1 REC with
        | left _ => match Rep_dec r r0 with
                      | left _ => Bind r1 tt (bsubstRep T0 (S m) U)
                      | _      => Bind r1 tt (bsubstRep T0 m U)
                    end
        | _      => match Rep_dec r1 r0 with
                      | left _ => Bind r1 tt (bsubstRep T0 (S m) U)
                      | _      => Bind r1 tt (bsubstRep T0 m U)
                    end
      end
    | Rec T0          => Rec (bsubst T0 m U)
  end

with bsubst r r0 (T:Interpret r)(m:atom)(U:Interpret r0) : Interpret r :=
  match T with
    | Var v  =>
      match Rep_dec r r0 with
        | left same =>
          match v with
            | inl _ => T
            | inr k => if (AtomDT.eq_dec m k) then conv same U else T
          end
        | right _ => T
      end
    | Term T0 => Term (bsubstRep T0 m U)
  end.

(**********************************************************************)
(** ** Heterogeneous sets of parameters *)
(**********************************************************************)

(** Note that [atoms] ~ [list nat] without redundancy.
   Cf. Coq.FSets.FSetWeakList.Make.slist.
   So we must work with the basic notations from Metatheory.v,
   that is, working with [nil], [app] won't work.

   [destruct_notin], [solve_notin] tactic from [FSetWeakNotin.v] is
   very useful in dealing with atoms.

   Note that the argument [r0] is the crucial point
   for the heterogeneous definition. *)

Fixpoint freevarsRep (r r0 s:Rep)(T:InterpretRep r s): atoms :=
  match T with
    | Unit          => {}
    | Const _ _     => {}
    | Repr s0 U     => @freevars s0 r0 U
    | InL _ _ U     => freevarsRep r0 U
    | InR _ _ U     => freevarsRep r0 U
    | Pair _ _ U U0 => (freevarsRep r0 U) `union` (freevarsRep r0 U0)
    | Bind _ _ _ U  => freevarsRep r0 U
    | Rec U         => freevars r0 U
  end

with freevars (r r0:Rep)(T:Interpret r) : atoms :=
  match T with
    | Var v  =>
      match Rep_dec r r0 with
        | left same =>
          match v with
            | inl a => {{ a }}
            | inr _ => {}
          end
        | right _ => {}
      end
    | Term U => freevarsRep r0 U
  end.

(**********************************************************************)
(** ** Heterogenesou well-formedness of a term or a type *)
(**********************************************************************)

(** Intuitive meaning of well-formedness is "no free occurrence
   of bound variables".

   - There are several equivalent ways to define well-formedness:
     -- Inductive definition of [wfT] which characterizes
        the set of well-formed terms;

     -- Defining [wf] and [wf_basic] directly;

   - [wf_basic] is a basic, but equivalent version of [wf].
     With [wf_basic], some lemmas are easier to prove.

   - Note that the argument [r0] is the crucial point
     for the heterogeneous definition.
     The well-formedness of a term is defined with respect to [r0].

   - Cofinite quantification style is used in the binder case. *)

(** [wfT] corresponds to [envT] in [LNameless_Meta_Env.v], but
   without using any environments.
   Notet that for the binding case, [cofinite quantification] is used. *)

Inductive wfTRep (r r0:Rep) : forall s, InterpretRep r s -> Prop :=
| wf_Unit  : wfTRep r0 Unit
| wf_Const : forall (s0:Rep)(T:Interpret s0),
  wfTRep r0 (Const r T)
| wf_Repr  : forall (s0:Rep)(T:Interpret s0),
  @wfT s0 r0 T -> wfTRep r0 (Repr r T)
| wf_InL   : forall s0 s1 (T:InterpretRep r s0),
  wfTRep r0 T -> wfTRep r0 (InL s1 T)
| wf_InR   : forall s0 s1 (T:InterpretRep r s1),
  wfTRep r0 T -> wfTRep r0 (InR s0 T)
| wf_Pair  : forall s0 s1 (T:InterpretRep r s0)(U:InterpretRep r s1),
  wfTRep r0 T -> wfTRep r0 U -> wfTRep r0 (Pair T U)
| wf_Bind_REC_homo  : forall s0 (T:InterpretRep r s0) L,
  r = r0 ->
  (forall (a:atom), a `notin` L -> wfTRep r0 (bsubstRep T 0 (Var r0 (inl a)))) ->
  wfTRep r0 (Bind REC tt T)
| wf_Bind_REC_hetero  : forall s0 (T:InterpretRep r s0),
  r <> r0 ->
  wfTRep r0 T ->
  wfTRep r0 (Bind REC tt T)
| wf_Bind_homo  : forall r1 s0 (T:InterpretRep r s0) L,
  r1 <> REC ->
  r1 = r0 ->
  (forall (a:atom), a `notin` L -> wfTRep r0 (bsubstRep T 0 (Var r0 (inl a)))) ->
  wfTRep r0 (Bind r1 tt T)
| wf_Bind_hetero  : forall r1 s0 (T:InterpretRep r s0),
  r1 <> REC ->
  r1 <> r0 ->
  wfTRep r0 T ->
  wfTRep r0 (Bind r1 tt T)
| wf_Rec   : forall T, wfT r0 T -> wfTRep r0 (Rec T)

with wfT (r r0:Rep) : Interpret r -> Prop :=
| wf_fvar : forall v, r = r0 -> wfT r0 (Var r (inl v))
| wf_Var  : forall v, r <> r0 -> wfT r0 (Var r v)
| wf_Term : forall T, wfTRep r0 T -> wfT r0 (Term T).

(** [wf] and [wf_basic] say directly that there are no free
   occurrence of a bound variable. *)

Definition wf r' (r:Rep)(T:Interpret r) :=
  forall (k:atom)(U:Interpret r'), T = bsubst T k U.

Definition wfRep r' (r s:Rep)(T:InterpretRep r s) :=
  forall (k:atom)(U:Interpret r'), T = bsubstRep T k U.

Definition wf_basic r' (r:Rep)(T:Interpret r) :=
  forall (k a:atom), T = bsubst T k (Var r' (inl a)).

Definition wfRep_basic r' (r s:Rep)(T:InterpretRep r s) :=
  forall (k a:atom), T = bsubstRep T k (Var r' (inl a)).

(** Parameters are well-formed. *)

Lemma wf_parameter : forall r' r (a:nat), wf r' (Var r (inl a)).
Proof.
  unfold wf; intros r' r a k U; simpl; case_rep; reflexivity.
Qed.

Hint Resolve wf_parameter.

(**********************************************************************)
(** * 2. Generic Properties *)
(**********************************************************************)

(**********************************************************************)
(** ** About the homomorphism [conv] *)
(**********************************************************************)

(** Note that [conv] is used to overcome Coq's restriction
   in dealing with dependent types for the definition of
   substitution for variables.

   The fact that [conv] deals with essentially the same terms/types
   should reflected in each use of [conv]. *)

(** [conv] and substitutions *)

Lemma conv_fsubst : forall r r0 r1 (e e0:r = r0)(T:Interpret r0)(U:Interpret r1) (a:atom),
  fsubst (conv e T) a U = conv e0 (fsubst T a U).
Proof.
  intros r r0 r1 e; case e.
  intro e0.
  rewrite (Rep_dec_unicity e0 refl).
  unfold conv, eq_rect_r; simpl; intuition.
Qed.

Lemma conv_bsubst : forall r r0 r1 (e e0:r = r0)(T:Interpret r0)(U:Interpret r1) (m:atom),
  bsubst (conv e T) m U = conv e0 (bsubst T m U).
Proof.
  intros r r0 r1 e; case e.
  intro e0.
  rewrite (Rep_dec_unicity e0 refl).
  unfold conv, eq_rect_r; simpl; intuition.
Qed.

(** [conv] and sets of free variables (parameters)  *)

Lemma conv_freevars_1 : forall r r0 r1 (e:r = r0) (T:Interpret r0),
  forall (a:atom), a `in` freevars r1 T -> a `in` freevars r1 (conv e T).
Proof.
  intros r r0 r1 e; case e; auto.
Qed.

Lemma conv_freevars_2 : forall r r0 r1 (e:r = r0) (T:Interpret r0),
  forall (a:atom), a `in` freevars r1 (conv e T) -> a `in` freevars r1 T.
Proof.
  intros r r0 r1 e; case e; auto.
Qed.

Lemma conv_freevars_3 : forall r r0 r1 (e:r = r0) (T:Interpret r0),
  forall (a:atom), a `notin` freevars r1 T -> a `notin` freevars r1 (conv e T).
Proof.
  do 6 intro; intro H; contra H; eauto using conv_freevars_2.
Qed.

Lemma conv_freevars_4 : forall r r0 r1 (e:r = r0) (T:Interpret r0),
  forall (a:atom), a `notin` freevars r1 (conv e T) -> a `notin` freevars r1 T.
Proof.
  do 6 intro; intro H; contra H; eauto using conv_freevars_1.
Qed.

(** [conv] and well-formedness *)

Lemma conv_wfT : forall r r0 (e:r = r0)(T:Interpret r0) r1,
  wfT r1 T -> wfT r1 (conv e T).
Proof.
  intros r r0 e; case e.
  unfold conv, eq_rect_r; simpl; tauto.
Qed.

(**********************************************************************)
(** ** About Substitution *)
(**********************************************************************)

(** Substitution and size:
   - Replacing a bound variable by a parameter does not change
     the size of a term. *)

Lemma bsubst_sizeRep : forall r r0 s (T:InterpretRep r s)(k a:atom),
  sizeRep T = sizeRep (bsubstRep T k (Var r0 (inl a)))

  with bsubst_size : forall r r0 (T:Interpret r)(k a:atom),
  size T = size (bsubst T k (Var r0 (inl a))).
Proof.
  induction T as [| | | | | | |]; simpl; intros;
    [reflexivity |
     reflexivity |
     auto 1|
     auto 1|
     auto 1|
     auto 3 with arith|
     repeat case_rep; simpl; auto 2|
     auto 1].

  induction T as [? v|]; simpl; intros;
    [case_rep; destruct v; simpl; auto 1|
     auto 1];
    case_var; simpl; [rewrite <- conv_size; simpl; reflexivity | reflexivity].
Qed.

(** Substitution of a parameter for itself is an identity. *)

Ltac q_destruct :=
  match goal with
    | q : QQ |- _ => destruct q
  end.

Lemma fsubstRep_self : forall r r0 s (a:atom) (T:InterpretRep r s),
  T = fsubstRep T a (Var r0 (inl a))

  with fsubst_self : forall r r0 (a:atom) (T:Interpret r),
  T = fsubst T a (Var r0 (inl a)).
Proof.
(* fsubstRep_self *)
  destruct T; simpl; func_equal;
    try q_destruct; eauto 1.
  (* fsubst_self *)
  destruct T as [ v|]; simpl;
    [case_rep; destruct v; try reflexivity|
     func_equal; auto 1];
    case_var; eauto using conv_Var.
Qed.

(** Substitution for a parameter which does not occur
   is an identity function. *)

Lemma fsubstRep_no_occur : forall (r r0 s:Rep)(T:InterpretRep r s)(a:atom)(U:Interpret r0),
  a `notin` (freevarsRep r0 T) -> T = fsubstRep T a U

  with fsubst_no_occur : forall (r r0:Rep)(T:Interpret r)(a:atom)(U:Interpret r0),
    a `notin` (freevars r0 T) -> T = fsubst T a U.
Proof.
  (* fsubstRep_no_occur *)
  destruct T; simpl; intros; func_equal; eauto; try destruct_notin; try destruct q; eauto.
  (* fsubst_no_occur *)
  destruct T; simpl; intros; func_equal; eauto;
  case_eq (Rep_dec r r0); intros; auto.
  destruct v as [b |]; try case_eq (a == b); intros; try reflexivity.
  destruct (Rep_dec r r0); [idtac | contradiction].
  destruct_notin; congruence.
Qed.

(** Substitution Lemma  *)

Lemma fsubstitutionRep : forall (r r0 r1 s:Rep)
  (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1)(a b : atom),
  a <> b ->
  a `notin` (freevars r0 V) ->
  fsubstRep (fsubstRep T a U) b V =
  fsubstRep (fsubstRep T b V) a (fsubst U b V)

  with fsubstitution : forall (r r0 r1:Rep)
    (T:Interpret r)(U:Interpret r0)(V:Interpret r1)(a b : atom),
    a <> b ->
    a `notin` (freevars r0 V) ->
    fsubst (fsubst T a U) b V =
      fsubst (fsubst T b V) a (fsubst U b V).
Proof.
(* fsubstitutionRep *)
  destruct T; simpl; intros; func_equal; auto.

  (* fsubstitution *)
  destruct T; simpl; intros.
  (* Var *)
  destruct (Rep_dec r r0).
  (* r = r0 *)
  destruct v as [b0 |]; simpl.
  case_var; case_rep; try case_var; simpl; try case_rep; try contradiction;
    try case_var; try contradiction; try case_rep; try contradiction;
      try case_var; try contradiction; try case_rep; try contradiction;
        try absurd_math; intuition; auto using conv_fsubst.

  rewrite conv_indep with (e0:=e0);  apply fsubst_no_occur;
    auto using conv_freevars_3.

  case_rep; simpl; case_rep; intuition.
  (* r <> r0 *)
  case_rep; simpl; case_rep; intuition; destruct v; simpl;
    try case_var; intuition; try case_rep; intuition; simpl;
      try case_rep; intuition.
  rewrite conv_indep with (e0:=e);  apply fsubst_no_occur;
    auto using conv_freevars_3.
  (* Rec *)
  func_equal; auto.
Qed.

(** [AtomSetImpl] includes basic library for [union], etc.
   Cf. [Coq.FSets.FsetWeakList.v] *)

Export AtomSetImpl.

(** Substitution of a (bound) variable extends the set of parameters. *)

Lemma freevarsRep_pass_binder : forall r r0 r1 s (T :InterpretRep r s) (U:Interpret r0) (a b:atom),
  a `in` (freevarsRep r1 T) -> a `in` (freevarsRep r1 (bsubstRep T b U))

  with freevars_pass_binder : forall r r0 r1 (T:Interpret r) (U:Interpret r0) (a b:atom),
  a `in` (freevars r1 T) -> a `in` (freevars r1 (bsubst T b U)).
Proof.
  destruct T; simpl; intros; auto.
  (* Pair *)
  elim (union_1 H); intros; auto using union_2, union_3.
  (* Bind *)
  case_rep; simpl; case_rep; simpl; auto using freevarsRep_pass_binder.

  destruct T; simpl; intros; try case_rep; simpl; auto; try case_rep; intuition;
    destruct v; simpl; try case_rep; intuition; intuition; simpl;
      try case_rep; intuition; inversion H.
Qed.

(** Substitution of a variable is equivalent to substitution
   of that variable by a parameter which will be substituted again. *)

Lemma bfsubstRep_var_intro : forall r r0 s (T:InterpretRep r s)(U:Interpret r0) (a:atom),
  a `notin` (freevarsRep r0 T) ->
  forall (k:atom), bsubstRep T k U = fsubstRep (bsubstRep T k (Var r0 (inl a))) a U

  with bfsubst_var_intro : forall r r0 (T:Interpret r)(U:Interpret r0) (a:atom),
    a `notin` (freevars r0 T) ->
    forall (k:atom), bsubst T k U = fsubst (bsubst T k (Var r0 (inl a))) a U.
Proof.
  induction T; simpl; intros; destruct_notin; func_equal; auto.
  repeat case_rep; simpl; func_equal; apply IHT; assumption.

  induction T; simpl; intros; destruct_notin; func_equal; auto.
  case_rep; destruct v; try case_var; simpl; try case_rep; try congruence;
    try case_var; try congruence; try solve_notin.
  rewrite conv_fsubst with (e0:=e); func_equal; simpl.
  case_rep; try case_var; try congruence.
  symmetry; apply conv_id.
Qed.

(** Consecutive substitution of the same (bound) variable has no effect. *)

(* bsubstitutionRep_var_twice_1 => bsubstitutionRep_var_twice_wf
   bsubstitution_var_twice_1 => bsubstitution_var_twice_wf *)
Lemma bsubstitutionRep_var_twice_wf : forall r s (T:InterpretRep r s) r0 (k:atom) (V U:Interpret r0),
  wf r0 V ->
  bsubstRep T k V
  = bsubstRep (bsubstRep T k V) k U

  with bsubstitution_var_twice_wf : forall r (T:Interpret r) r0 (k:atom) (V U:Interpret r0),
    wf r0 V ->
    bsubst T k V
    = bsubst (bsubst T k V) k U.
Proof.
  induction T; simpl; intros; try reflexivity.
  f_equal; apply bsubstitution_var_twice_wf; assumption.
  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.
  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.
  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.
  repeat case_rep; simpl; repeat case_rep; try congruence.
  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.
  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.
  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.
  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.

  f_equal; apply bsubstitution_var_twice_wf; assumption.

  induction T; simpl; intros.
  repeat case_rep; destruct v; repeat case_var; simpl;
    repeat case_rep; try congruence; simpl;
      repeat case_var; try congruence.
  rewrite conv_bsubst with (e0:=e).
  f_equal; apply H.

  f_equal; apply bsubstitutionRep_var_twice_wf; assumption.
Qed.

Lemma bsubstitutionRep_var_twice : forall r s (T:InterpretRep r s) r0 k a (U:Interpret r0),
  bsubstRep T k (Var r0 (inl a)) = bsubstRep (bsubstRep T k (Var r0 (inl a))) k U.
Proof.
  intros; apply bsubstitutionRep_var_twice_wf; auto.
Qed.

Lemma bsubstitution_var_twice : forall r (T:Interpret r) r0 k a (U:Interpret r0),
  bsubst T k (Var r0 (inl a)) = bsubst (bsubst T k (Var r0 (inl a))) k U.
Proof.
  intros; apply bsubstitution_var_twice_wf; auto.
Qed.

(* bsubstitutionRep_homo_1 => bsubstitutionRep_homo_wf
   bsubstitution_homo_1 => bsubstitution_homo_wf *)
Lemma bsubstitutionRep_homo_wf: forall r s (T:InterpretRep r s) r0 k l (U V:Interpret r0),
  k <> l ->
  wf r0 U ->
  wf r0 V ->
  bsubstRep (bsubstRep T k U) l V = bsubstRep (bsubstRep T l V) k U

  with bsubstitution_homo_wf: forall r (T:Interpret r) r0 k l (U V:Interpret r0),
    k <> l ->
    wf r0 U ->
    wf r0 V ->
    bsubst (bsubst T k U) l V = bsubst (bsubst T l V) k U.
Proof.
  induction T; simpl; intros; try reflexivity.
  f_equal; apply bsubstitution_homo_wf; assumption.
  f_equal; apply bsubstitutionRep_homo_wf; assumption.
  f_equal; apply bsubstitutionRep_homo_wf; assumption.
  f_equal; apply bsubstitutionRep_homo_wf; assumption.
  repeat case_rep; simpl;
    repeat case_rep; first [absurd_math | try congruence | try contradiction]; func_equal.

  apply bsubstitutionRep_homo_wf; auto with arith.
  apply bsubstitutionRep_homo_wf; assumption.
  apply bsubstitutionRep_homo_wf; auto with arith.
  apply bsubstitutionRep_homo_wf; assumption.

  f_equal; apply bsubstitution_homo_wf; assumption.

  induction T; simpl; intros.

  case_rep; destruct v; simpl; try case_rep; repeat case_var;
    try congruence; simpl;
      repeat case_rep; repeat case_var; try congruence.

  rewrite conv_bsubst with (e0:=e0); f_equal; symmetry; apply H0.
  rewrite conv_bsubst with (e0:=e0); f_equal; apply H1.

  f_equal; apply bsubstitutionRep_homo_wf; assumption.
Qed.

Lemma bsubstitutionRep_homo: forall r s (T:InterpretRep r s) r0 k l a b,
  k <> l ->
  bsubstRep (bsubstRep T k (Var r0 (inl a))) l (Var r0 (inl b))
  = bsubstRep (bsubstRep T l (Var r0 (inl b))) k (Var r0 (inl a)).
Proof.
  intros; apply bsubstitutionRep_homo_wf; auto.
Qed.

Lemma bsubstitution_homo: forall r (T:Interpret r) r0 k l a b,
  k <> l ->
  bsubst (bsubst T k (Var r0 (inl a))) l (Var r0 (inl b))
  = bsubst (bsubst T l (Var r0 (inl b))) k (Var r0 (inl a)).
Proof.
  intros; apply bsubstitution_homo_wf; auto.
Qed.

(* bsubstitutionRep_hetero_1 => bsubstitutionRep_hetero_wf
   bsubstitution_hetero_1 => bsubstitution_hetero_wf *)
Lemma bsubstitutionRep_hetero_wf : forall (r r0 r1 s:Rep) (T:InterpretRep r s)(k l: atom) (U:Interpret r0)(V:Interpret r1),
  r0 <> r1 ->
  wf r1 U ->
  wf r0 V ->
  bsubstRep (bsubstRep T k U) l V = bsubstRep (bsubstRep T l V) k U

  with bsubstitution_hetero_wf : forall (r r0 r1:Rep) (T:Interpret r)(k l : atom) (U:Interpret r0)(V:Interpret r1),
  r0 <> r1 ->
  wf r1 U ->
  wf r0 V ->
  bsubst (bsubst T k U) l V = bsubst (bsubst T l V) k U.
Proof.
  destruct T; simpl; intros;
    [ reflexivity
      | reflexivity
      | f_equal; apply bsubstitution_hetero_wf; assumption
      | f_equal; apply bsubstitutionRep_hetero_wf; assumption
      | f_equal; apply bsubstitutionRep_hetero_wf; assumption
      | f_equal; apply bsubstitutionRep_hetero_wf; assumption
      | repeat (case_rep; simpl); try congruence; f_equal;
        apply bsubstitutionRep_hetero_wf; assumption
      | f_equal; apply bsubstitution_hetero_wf; assumption ].

  destruct T; simpl; intros;
    [ repeat (repeat case_rep; try destruct v; simpl; repeat case_var; try congruence);
      erewrite conv_bsubst; f_equal*
      | f_equal; apply bsubstitutionRep_hetero_wf; assumption ].
Qed.

Lemma bsubstitutionRep_hetero : forall (r r0 r1 s:Rep) (T:InterpretRep r s)(k l a b : atom),
  r0 <> r1 ->
  bsubstRep (bsubstRep T k (Var r0 (inl a))) l (Var r1 (inl b)) =
  bsubstRep (bsubstRep T l (Var r1 (inl b))) k (Var r0 (inl a)).
Proof.
  intros; apply bsubstitutionRep_hetero_wf; auto.
Qed.

Lemma bsubstitution_hetero : forall (r r0 r1:Rep) (T:Interpret r)(k l a b : atom),
  r0 <> r1 ->
  bsubst (bsubst T k (Var r0 (inl a))) l (Var r1 (inl b)) =
  bsubst (bsubst T l (Var r1 (inl b))) k (Var r0 (inl a)).
Proof.
  intros; apply bsubstitution_hetero_wf; auto.
Qed.

(**************************************************************)
(** ** Well-formedness and substitution *)
(**************************************************************)

(** Equivalence of [wf] and [wf_basic] *)

Lemma wf_from_wf_basic : forall r' (r:Rep)(T:Interpret r),
  wf_basic r' T -> wf r' T.
Proof.
  unfold wf, wf_basic; intros.
  pick fresh a for (freevars r' T); destruct_notin.
  rewrite bfsubst_var_intro with (a:=a);
    [rewrite <- H; auto using fsubst_no_occur | assumption].
Qed.

(** Preparing lemmas *)

(* bsubstRep_wfT_core => bsubstRep_homo_core
   bsubst_wfT_core => bsubst_homo_core *)
Lemma bsubstRep_homo_core : forall r r0 s (T:InterpretRep r s) (U V:Interpret r0) k j,
  k <> j ->
  bsubstRep T j V = bsubstRep (bsubstRep T j V) k U ->
  T = bsubstRep T k U

  with bsubst_homo_core : forall r r0 (T :Interpret r) (U V:Interpret r0) k j,
    k <> j ->
    bsubst T j V = bsubst (bsubst T j V) k U ->
    T = bsubst T k U.
Proof.
  (* bsubstRep_homo_core *)
  destruct T; simpl; intros U V k j H H0;
    [ reflexivity
      | reflexivity
      | dependent destruction H0; f_equal; eapply bsubst_homo_core; eassumption
      | dependent destruction H0; f_equal; eapply bsubstRep_homo_core; eassumption
      | dependent destruction H0; f_equal; eapply bsubstRep_homo_core; eassumption
      | dependent destruction H0; f_equal; eapply bsubstRep_homo_core; eassumption
      | q_destruct; repeat (repeat case_rep; simpl in *; try congruence);
        dependent destruction H0; f_equal; eapply bsubstRep_homo_core;
          try eassumption; auto with arith
      | dependent destruction H0; f_equal; eapply bsubst_homo_core; eassumption ].
  (* bsubst_homo_core *)
  destruct T; simpl; intros U V k j H H0;
    [ repeat
      (repeat case_rep; try destruct v; repeat case_var; simpl in *; try congruence);
      erewrite conv_indep; eassumption
      | dependent destruction H0; func_equal; eapply bsubstRep_homo_core; eassumption ].
Qed.

(* bsubstRep_core => bsubstRep_hetero_core
   bsubst_core => bsubst_hetero_core *)
Lemma bsubstRep_hetero_core : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1) k j,
  r0 <> r1 ->
  bsubstRep T j V = bsubstRep (bsubstRep T j V) k U ->
  T = bsubstRep T k U

  with bsubst_hetero_core : forall r r0 r1 (T :Interpret r) (U:Interpret r0)(V:Interpret r1) k j,
    r0 <> r1 ->
    bsubst T j V = bsubst (bsubst T j V) k U ->
    T = bsubst T k U.
Proof.
  destruct T; simpl; intros U V k j H H0;
    [ reflexivity
      | reflexivity
      | dependent destruction H0; f_equal; eapply bsubst_hetero_core; eassumption
      | dependent destruction H0; f_equal; eapply bsubstRep_hetero_core; eassumption
      | dependent destruction H0; f_equal; eapply bsubstRep_hetero_core; eassumption
      | dependent destruction H0; f_equal; eapply bsubstRep_hetero_core; eassumption
      | q_destruct; repeat (repeat case_rep; simpl in *; try congruence);
        dependent destruction H0; f_equal; eapply bsubstRep_hetero_core;
          try eassumption; auto with arith
      | dependent destruction H0; f_equal; eapply bsubst_hetero_core; eassumption ].

  destruct T; simpl; intros U V k j H H0;
    [ repeat
      (repeat case_rep; try destruct v; repeat case_var; simpl in *; try congruence);
      erewrite conv_indep; eassumption
      | dependent destruction H0; func_equal; eapply bsubstRep_hetero_core; eassumption ].
Qed.

(** Well-formed terms contains no free occurring bound varibles. *)

(* wfTRep_bsubst_id => wfTRep_wfRep
   wfT_bsubst_id => wfT_wf *)
Lemma wfTRep_wfRep : forall r r0 s (T:InterpretRep r s),
  wfTRep r0 T ->
  forall k (U:Interpret r0), T = bsubstRep T k U

  with wfT_wf : forall r r0 (T:Interpret r),
    wfT r0 T ->
    forall k (U:Interpret r0), T = bsubst T k U.
Proof.
  induction 1; simpl; intros; try do 2 case_rep; intuition; func_equal; auto.
 (* wf_Bind_REC_homo *)
  case_rep; intuition; func_equal.
  pick fresh y for L.
  eapply bsubstRep_homo_core with (j:=0).
  omega.
  eapply H1; eauto.
  (* wf_Bind_REC_hetero *)
  case_rep; intuition; func_equal; auto.
 (* wf_Bind_homo *)
  pick fresh y for L.
  eapply bsubstRep_homo_core with (j:=0).
  omega.
  eapply H2; eauto.

  induction 1; intros.
  (* fvar *)
  simpl; destruct (Rep_dec r r0); reflexivity.
  (* Var *)
  simpl; destruct (Rep_dec r r0); [contradiction | reflexivity].

  (* Term *)
  simpl; f_equal; apply wfTRep_wfRep; auto.
Qed.

(**************************************************************)
(** ** Permutation of substitutions *)
(**************************************************************)

Lemma bfsubstRep_permutation_core : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1) a,
  wfT r1 U ->
  forall k, bsubstRep (fsubstRep T a U) k (fsubst V a U) = fsubstRep (bsubstRep T k V) a U

  with bfsubst_permutation_core : forall r r0 r1 (T:Interpret r)(U:Interpret r0)(V:Interpret r1) a,
    wfT r1 U ->
    forall k, bsubst (fsubst T a U) k (fsubst V a U) = fsubst (bsubst T k V) a U.
Proof.
  destruct T; simpl; intros U V a H k; try do 2 case_rep;
    intuition; simpl; func_equal; auto.

  destruct T; simpl; intros U V a H k; try case_rep; simpl; func_equal; eauto;
  try case_rep; destruct v; try case_var; simpl; try case_rep; intuition;
    try case_var; intuition; try case_rep; intuition.
  rewrite conv_bsubst with (e0:=e1); func_equal;
    symmetry; apply wfT_wf; auto.

  rewrite conv_fsubst with (e0:=e1); auto.

  rewrite conv_bsubst with (e0:=e0); f_equal;
    symmetry; apply wfT_wf; auto.

  rewrite conv_fsubst with (e0:=e); auto.
Qed.

Lemma bfsubstRep_permutation_core_wf : forall r r0 r1 s
  (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1) a,
  wf r1 U ->
  forall k, bsubstRep (fsubstRep T a U) k (fsubst V a U) = fsubstRep (bsubstRep T k V) a U

  with bfsubst_permutation_core_wf : forall r r0 r1
    (T:Interpret r)(U:Interpret r0)(V:Interpret r1) a,
    wf r1 U ->
    forall k, bsubst (fsubst T a U) k (fsubst V a U) = fsubst (bsubst T k V) a U.
Proof.
  destruct T; simpl; intros U V a Hwf k; func_equal; auto.
  do 2 case_rep; simpl; func_equal; auto.

  unfold wf_basic; destruct T; simpl; intros U V a Hwf k; func_equal; auto.
  repeat case_rep; try destruct v; try case_var; try congruence; simpl;
    repeat case_rep; repeat case_var; try congruence.
  rewrite conv_bsubst with (e0:=e1); func_equal; symmetry; auto.
  rewrite conv_fsubst with (e0:=e1); func_equal; symmetry; auto.
  rewrite conv_bsubst with (e0:=e0); func_equal; symmetry; auto.
  rewrite conv_fsubst with (e0:=e0); func_equal; symmetry; auto.
Qed.

Lemma bfsubstRep_permutation_ind : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1) a,
  wfT r1 U ->
  a `notin` (freevars r0 V) ->
  forall k, bsubstRep (fsubstRep T a U) k V = fsubstRep (bsubstRep T k V) a U.
Proof.
  intros; pattern V at 1;
    rewrite fsubst_no_occur with (a:=a) (U:=U);
      auto using bfsubstRep_permutation_core.
Qed.

Lemma bfsubst_permutation_ind : forall r r0 r1 (T:Interpret r)(U:Interpret r0)(V:Interpret r1) a,
  wfT r1 U ->
  a `notin` (freevars r0 V) ->
  forall k, bsubst (fsubst T a U) k V = fsubst (bsubst T k V) a U.
Proof.
  intros; pattern V at 1;
    rewrite fsubst_no_occur with (a:=a) (U:=U);
      auto using bfsubst_permutation_core.
Qed.

Lemma bfsubstRep_permutation_ind_wf : forall r r0 r1 s
  (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1) a,
  wf r1 U ->
  a `notin` (freevars r0 V) ->
  forall k,
    bsubstRep (fsubstRep T a U) k V = fsubstRep (bsubstRep T k V) a U.
Proof.
  intros; pattern V at 1;
    rewrite fsubst_no_occur with (a:=a) (U:=U);
      auto using bfsubstRep_permutation_core_wf.
Qed.

Lemma bfsubst_permutation_ind_wf : forall r r0 r1
  (T:Interpret r)(U:Interpret r0)(V:Interpret r1) a,
  wf r1 U ->
  a `notin` (freevars r0 V) ->
  forall k,
    bsubst (fsubst T a U) k V = fsubst (bsubst T k V) a U.
Proof.
  intros; pattern V at 1;
    rewrite fsubst_no_occur with (a:=a) (U:=U);
      auto using bfsubst_permutation_core_wf.
Qed.

Lemma bfsubstRep_permutation_wfT : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1) a,
  wfT r1 U ->
  a `notin` (freevars r0 V) ->
  bsubstRep (fsubstRep T a U) 0 V = fsubstRep (bsubstRep T 0 V) a U.
Proof.
  intros; eauto using bfsubstRep_permutation_ind.
Qed.

Lemma bfsubst_permutation_wfT : forall r r0 r1 (T:Interpret r)(U:Interpret r0)(V:Interpret r1) a,
  wfT r1 U ->
  a `notin` (freevars r0 V) ->
  bsubst (fsubst T a U) 0 V = fsubst (bsubst T 0 V) a U.
Proof.
  intros; eauto using bfsubst_permutation_ind.
Qed.

Lemma bfsubstRep_permutation_wf : forall r r0 r1 s
  (T:InterpretRep r s)(U:Interpret r0)(V:Interpret r1) a,
  wf r1 U ->
  a `notin` (freevars r0 V) ->
  bsubstRep (fsubstRep T a U) 0 V = fsubstRep (bsubstRep T 0 V) a U.
Proof.
  intros; eauto using bfsubstRep_permutation_ind_wf.
Qed.

Lemma bfsubst_permutation_wf : forall r r0 r1
  (T:Interpret r)(U:Interpret r0)(V:Interpret r1) a,
  wf r1 U ->
  a `notin` (freevars r0 V) ->
  bsubst (fsubst T a U) 0 V = fsubst (bsubst T 0 V) a U.
Proof.
  intros; eauto using bfsubst_permutation_ind_wf.
Qed.

Lemma bfsubstRep_permutation_var_wfT : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0) a b,
  a <> b ->
  wfT r1 U ->
  bsubstRep (fsubstRep T a U) 0 (Var r1 (inl b))
  = fsubstRep (bsubstRep T 0 (Var r1 (inl b))) a U.
Proof.
  intros; apply bfsubstRep_permutation_wfT; try solve_notin;
    simpl; case_rep; simpl; solve_notin.
Qed.

Lemma bfsubst_permutation_var_wfT : forall r r0 r1 (T:Interpret r) (U:Interpret r0) a b,
  a <> b ->
  wfT r1 U ->
  bsubst (fsubst T a U) 0 (Var r1 (inl b))
  = fsubst (bsubst T 0 (Var r1 (inl b))) a U.
Proof.
  intros; apply bfsubst_permutation_wfT; try solve_notin;
    simpl; case_rep; simpl; solve_notin.
Qed.

Lemma bfsubstRep_permutation_var_wf : forall r r0 r1 s
  (T:InterpretRep r s)(U:Interpret r0) a b,
  a <> b ->
  wf r1 U ->
  bsubstRep (fsubstRep T a U) 0 (Var r1 (inl b))
  = fsubstRep (bsubstRep T 0 (Var r1 (inl b))) a U.
Proof.
  introv Hneq Hwf.
  rewrite <- bfsubstRep_permutation_core_wf; auto.
  simpl; case_rep; auto; case_var; congruence.
Qed.

Lemma bfsubst_permutation_var_wf : forall r r0 r1
  (T:Interpret r) (U:Interpret r0) a b,
  a <> b ->
  wf r1 U ->
  bsubst (fsubst T a U) 0 (Var r1 (inl b))
  = fsubst (bsubst T 0 (Var r1 (inl b))) a U.
Proof.
  introv Hneq Hwf.
  rewrite <- bfsubst_permutation_core_wf; auto.
  simpl; case_rep; auto; case_var; congruence.
Qed.

Lemma bfsubst_permutation_var_wfT_hetero : forall r r0 r1 (T:Interpret r) (U:Interpret r0) a b,
  r0 <> r1 ->
  wfT r1 U ->
  bsubst (fsubst T a U) 0 (Var r1 (inl b))
  = fsubst (bsubst T 0 (Var r1 (inl b))) a U.
Proof.
  intros; apply bfsubst_permutation_wfT; try solve_notin;
    simpl; case_rep; simpl; solve_notin.
Qed.

(** Substitution preserves well-formedness *)

Lemma wfT_fsubstRep : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0) a,
  wfTRep r1 T ->
  wfT r1 U ->
  wfTRep r1 (fsubstRep T a U)

  with wfT_fsubst : forall r r0 r1 (T:Interpret r)(U:Interpret r0) a,
    wfT r1 T ->
    wfT r1 U ->
    wfT r1 (fsubst T a U).
Proof.
  destruct 1; simpl; intros;
    [ constructor 1
      | constructor 2
      | constructor 3; apply wfT_fsubst; auto
      | constructor 4; apply wfT_fsubstRep; auto
      | constructor 5; apply wfT_fsubstRep; auto
      | constructor 6; apply wfT_fsubstRep; auto
      | idtac
      | constructor 8; auto
      | idtac
      | constructor 10; auto
      | constructor 11; auto ].
  (* Bind_REC_homo *)
  constructor 7 with (L `union` {{ a }}); intros; auto.
  destruct_notin.
  assert
    (bsubstRep (fsubstRep T a U) 0%nat (Var r1 (inl a0 ))
      = fsubstRep (bsubstRep T 0%nat (Var r1 (inl a0))) a U).
    replace (Var r1 (inl a0)) with (fsubst (Var r1 (inl a0)) a U).
      simpl.
      case_rep.
        destruct (a == a0); intuition.
        apply bfsubstRep_permutation_ind; auto.
        rewrite <- e; simpl.
        destruct (Rep_dec r1 r1); try contradiction.
          solve_notin.
        intuition.
      apply bfsubstRep_permutation_ind; auto.
      simpl; case_rep; try contradiction.
      solve_notin.
    simpl; case_rep; try contradiction; auto; case_var; intuition.
  rewrite H3.
  apply wfT_fsubstRep; auto.

  (* Bind_homo *)
  constructor 9 with (L `union` {{ a }}); intros; auto.
  destruct_notin.
  assert
    (bsubstRep (fsubstRep T a U) 0%nat (Var r1 (inl a0))
      = fsubstRep (bsubstRep T 0%nat (Var r1 (inl a0))) a U).
    replace (Var r1 (inl a0)) with (fsubst (Var r1 (inl a0)) a U).
      simpl.
      destruct (Rep_dec r1 r0).
        destruct (a == a0); intuition.
        apply bfsubstRep_permutation_ind; auto.
        rewrite <- e; simpl.
        destruct (Rep_dec r1 r1); try contradiction.
          solve_notin.
        intuition.
      apply bfsubstRep_permutation_ind; auto.
      simpl; case_rep; try contradiction.
      solve_notin.
    simpl; case_rep; try contradiction; auto; case_var; intuition.
  rewrite H4.
  apply wfT_fsubstRep; auto.

  destruct 1; simpl; intros; destruct (Rep_dec r r0); simpl;
    try destruct (a == b); try destruct (a == v); simpl; intuition;
      auto using conv_wfT.
  constructor; auto.
  constructor; auto.
  constructor; auto.
    (* Var *)
  destruct v; auto; try case_var; auto; auto using conv_wfT; try constructor 2; auto.
  constructor 2; auto.

  constructor 3; auto using wfT_fsubstRep.
  constructor 3; auto using wfT_fsubstRep.
Qed.

(* Preparing lemma *)

Lemma wf_fsubstRep_ : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0)
  a k (V: Interpret r1),
  T = bsubstRep T k V ->
  wf r1 U ->
  fsubstRep T a U = bsubstRep (fsubstRep T a U) k V

  with wf_fsubst_ : forall r r0 r1 (T:Interpret r)(U:Interpret r0)
    a k (V:Interpret r1),
    T = bsubst T k V ->
    wf r1 U ->
    fsubst T a U = bsubst (fsubst T a U) k V.
Proof.
  induction T; unfold wfRep, wf in *; simpl; intros; func_equal; auto.

  apply wf_fsubst_; [idtac | assumption].
  dependent destruction H; assumption.

  apply wf_fsubstRep_; [idtac | assumption].
  dependent destruction H; assumption.

  apply wf_fsubstRep_; [idtac | assumption].
  dependent destruction H; assumption.

  apply wf_fsubstRep_; [idtac | assumption].
  dependent destruction H; assumption.

  apply wf_fsubstRep_; [idtac | assumption].
  dependent destruction H; assumption.

  repeat case_rep; func_equal; simpl;
  apply wf_fsubstRep_; try assumption;
    dependent destruction H; assumption.

  apply wf_fsubst_; [idtac | assumption].
  dependent destruction H; assumption.

  induction T; unfold wfRep, wf in *; simpl; intros; func_equal; auto.

  repeat case_rep; destruct v; simpl;
    repeat case_rep; try congruence;
      repeat case_var; try congruence; simpl;
        repeat case_rep; try congruence.

  rewrite conv_bsubst with (e0:=e); func_equal; symmetry; auto.
  rewrite H; apply conv_indep.
  rewrite conv_bsubst with (e0:=e); func_equal; symmetry; auto.
  rewrite H; apply conv_indep.

  apply wf_fsubstRep_; [idtac | assumption].
  dependent destruction H; assumption.
Qed.

Lemma wf_fsubstRep : forall r r0 r1 s (T:InterpretRep r s)(U:Interpret r0) a,
  wfRep r1 T -> wf r1 U -> wfRep r1 (fsubstRep T a U).
Proof.
  unfold wfRep; intros; auto using wf_fsubstRep_.
Qed.

Lemma wf_fsubst : forall r r0 r1 (T:Interpret r)(U:Interpret r0) a,
    wf r1 T -> wf r1 U -> wf r1 (fsubst T a U).
Proof.
  unfold wf at -2; intros; auto using wf_fsubst_.
Qed.

(**************************************************************)
(** ** Heterogeneous substitution and well-formedness *)
(**************************************************************)

(** Heterogeneous substitition has no effect on well-formedness  *)

(** Preparing lemma  *)

Lemma wfT_bsubstRep_hetero_ : forall r s (T:InterpretRep r s) r0,
  wfTRep r0 T ->
  forall (T0:InterpretRep r s) r1 k a,
    T = bsubstRep T0 k (Var r1 (inl a)) ->
    r0 <> r1 ->
    wfTRep r0 T0

  with wfT_bsubst_hetero_ : forall r (T:Interpret r) r0,
    wfT r0 T ->
    forall (T0:Interpret r) r1 k a,
      T = bsubst T0 k (Var r1 (inl a)) ->
      r0 <> r1 ->
      wfT r0 T0.
Proof.
  induction 1.

  dependent destruction T0; simpl; intros.
  apply wf_Unit.

  dependent destruction T0; simpl; intros.
  apply wf_Const.

  dependent destruction T0; simpl; intros.
  assert (T = bsubst i k (Var r1 (inl a))).
  dependent destruction H0; reflexivity.
  apply wf_Repr.
  apply wfT_bsubst_hetero_ with T r1 k a; assumption.

  dependent destruction T0; simpl; intros; [idtac | discriminate].
  assert (T = bsubstRep T0 k (Var r1 (inl a))).
  dependent destruction H0; reflexivity.
  apply wf_InL.
  apply wfT_bsubstRep_hetero_ with T r1 k a; assumption.

  dependent destruction T0; simpl; intros; [discriminate | idtac].
  assert (T = bsubstRep T0 k (Var r1 (inl a))).
  dependent destruction H0; reflexivity.
  apply wf_InR.
  apply wfT_bsubstRep_hetero_ with T r1 k a; assumption.

  dependent destruction T0; simpl; intros.
  assert (T = bsubstRep T0_1 k (Var r1 (inl a))).
  dependent destruction H1; reflexivity.
  assert (U = bsubstRep T0_2 k (Var r1 (inl a))).
  dependent destruction H1; reflexivity.
  apply wf_Pair.
  apply wfT_bsubstRep_hetero_ with T r1 k a; assumption.
  apply wfT_bsubstRep_hetero_ with U r1 k a; assumption.

  dependent destruction T0; simpl; intros; destruct q; case_rep.
  assert (T = bsubstRep T0 (S k) (Var r1 (inl a))).
  dependent destruction H2; reflexivity.
  apply wf_Bind_REC_homo with L; [assumption|idtac]; intros.
  apply wfT_bsubstRep_hetero_ with (bsubstRep T 0 (Var r0 (inl a0))) r1 (S k) a;
    [apply H0; assumption |
      rewrite H4; apply bsubstitutionRep_hetero; congruence |
        assumption].

  assert (T = bsubstRep T0 k (Var r1 (inl a))).
  dependent destruction H2; reflexivity.
  apply wf_Bind_REC_homo with L; [assumption|idtac]; intros.
  apply wfT_bsubstRep_hetero_ with (bsubstRep T 0 (Var r0 (inl a0))) r1 k a;
    [apply H0; assumption |
      rewrite H4; apply bsubstitutionRep_hetero; congruence |
        assumption].

  dependent destruction T0; simpl; intros; destruct q; case_rep.
  assert (T = bsubstRep T0 (S k) (Var r1 (inl a))).
  dependent destruction H1; reflexivity.
  apply wf_Bind_REC_hetero; [assumption|idtac].
  apply wfT_bsubstRep_hetero_ with T r1 (S k) a; assumption.

  assert (T = bsubstRep T0 k (Var r1 (inl a))).
  dependent destruction H1; reflexivity.
  apply wf_Bind_REC_hetero; [assumption|idtac].
  apply wfT_bsubstRep_hetero_ with T r1 k a; assumption.

  dependent destruction T0; simpl; intros; destruct q; repeat case_rep;
    try contradiction.
  assert (T = bsubstRep T0 (S k) (Var r2 (inl a))).
  dependent destruction H3; reflexivity.
  apply wf_Bind_homo with L; try tauto; intros.
  apply wfT_bsubstRep_hetero_ with (bsubstRep T 0 (Var r0 (inl a0))) r2 (S k) a;
    [apply H1; assumption |
      rewrite H5; apply bsubstitutionRep_hetero; congruence |
        assumption].

  assert (T = bsubstRep T0 k (Var r2 (inl a))).
  dependent destruction H3; reflexivity.
  apply wf_Bind_homo with L; try tauto; intros.
  apply wfT_bsubstRep_hetero_ with (bsubstRep T 0 (Var r0 (inl a0))) r2 k a;
    [apply H1; assumption |
      rewrite H5; apply bsubstitutionRep_hetero; congruence |
        assumption].

  dependent destruction T0; simpl; intros; destruct q; repeat case_rep;
    try contradiction.
  assert (T = bsubstRep T0 (S k) (Var r2 (inl a))).
  dependent destruction H2; reflexivity.
  apply wf_Bind_hetero; [assumption | assumption | idtac].
  apply wfT_bsubstRep_hetero_ with T r2 (S k) a; assumption.

  assert (T = bsubstRep T0 k (Var r2 (inl a))).
  dependent destruction H2; reflexivity.
  apply wf_Bind_hetero; [assumption | assumption | idtac].
  apply wfT_bsubstRep_hetero_ with T r2 k a; assumption.

  dependent destruction T0; simpl; intros.
  assert (T = bsubst i k (Var r1 (inl a))).
  dependent destruction H0; reflexivity.
  apply wf_Rec.
  apply wfT_bsubst_hetero_ with T r1 k a; assumption.

  induction 1; dependent destruction T0; simpl; intros;
    try case_rep; try destruct v0; try congruence; try discriminate.
  apply wf_fvar; tauto.
  apply wf_Var; tauto.
  apply wf_Var; tauto.
  apply wf_Var; tauto.
  apply wf_Var; tauto.
  destruct v; try discriminate.
  case_var; try rewrite <- conv_Var in H0; discriminate.

  assert (T = bsubstRep i k (Var r1 (inl a))).
  dependent destruction H0; reflexivity.
  apply wf_Term.
  apply wfT_bsubstRep_hetero_ with T r1 k a; assumption.
Qed.

Lemma wfT_bsubstRep_hetero : forall r s (T:InterpretRep r s) r0 r1 k a,
  wfTRep r0 (bsubstRep T k (Var r1 (inl a))) ->
  r0 <> r1 ->
  wfTRep r0 T.
Proof.
  intros; apply wfT_bsubstRep_hetero_ with (bsubstRep T k (Var r1 (inl a))) r1 k a; auto.
Qed.

Lemma wfT_bsubst_hetero : forall r (T:Interpret r) r0 r1 k a,
  wfT r0 (bsubst T k (Var r1 (inl a))) ->
  r0 <> r1 ->
  wfT r0 T.
Proof.
  intros; apply wfT_bsubst_hetero_ with (bsubst T k (Var r1 (inl a))) r1 k a; auto.
Qed.

Lemma wfT_bsubstRep_hetero_1 : forall r s (T:InterpretRep r s) r0 r1,
  wfTRep r0 T ->
  r0 <> r1 ->
  forall (k a:atom), wfTRep r0 (bsubstRep T k (Var r1 (inl a)))

  with wfT_bsubst_hetero_1 : forall r (T:Interpret r) r0 r1,
    wfT r0 T ->
    r0 <> r1 ->
    forall (k a:atom), wfT r0 (bsubst T k (Var r1 (inl a))).
Proof.
  induction 1; simpl; intros.
  apply wf_Unit.
  apply wf_Const.
  apply wf_Repr; auto.
  apply wf_InL; auto.
  apply wf_InR; auto.
  apply wf_Pair; auto.

  case_rep;
  apply wf_Bind_REC_homo with L; auto; intros;
    rewrite bsubstitutionRep_hetero; auto.

  case_rep;
  apply wf_Bind_REC_hetero; auto; intros.

  case_rep; try congruence.
  case_rep; try congruence.
  apply wf_Bind_homo with L; auto; intros;
    rewrite bsubstitutionRep_hetero; auto.

  case_rep; try congruence.
  case_rep; try congruence;
    apply wf_Bind_hetero; auto; intros.

  apply wf_Rec; auto.

  induction 1; simpl; intros.

  case_rep; try congruence.
  apply wf_fvar; auto.

  case_rep.
  destruct v.
  apply wf_Var; auto.
  case_var.
  rewrite <- conv_Var.
  apply wf_Var; auto.
  apply wf_Var; auto.
  apply wf_Var; auto.

  apply wf_Term; auto.
Qed.


(* Coq implementation of compiler/cmm/CmmExpr.hs *)
Require Import List.

Require Import BlockId.
Require Import Int.
Require Import Unique.
Require Import CmmMachOp.
Require Import CmmType.
Require Import CmmExpr.

Require Import CmmCore.CmmCoreType.

Require Import compcert.common.AST.

Inductive CC_LocalReg : Set :=
| CC_LR: Unique -> CC_CmmType -> CC_LocalReg.

Inductive GlobalReg : Set :=
| VanillaReg: Int -> VGcPtr -> GlobalReg
| FloatReg: Int -> GlobalReg
| DoubleReg: Int -> GlobalReg
| LongReg: Int -> GlobalReg
                    (* ... and some more *)
| BaseReg: GlobalReg
| PicBaseReg: GlobalReg
.

Inductive CC_CmmReg : Set :=
| CmmLocal: CC_LocalReg -> CC_CmmReg
| CmmGlobal: GlobalReg -> CC_CmmReg
.

Inductive CC_CmmLit : Set :=
| CmmInt: Integer -> { w : Width | isIntWidth w} -> CC_CmmLit
| CmmFloat: Rational -> {w : Width | isFloatWidth w} -> CC_CmmLit
| CmmLabel: CLabel -> CC_CmmLit
| CmmLabelOff: CLabel -> Int -> CC_CmmLit
| CmmLabelDiffOff: CLabel -> CLabel -> Int -> { w : Width | isIntWidth w} -> CC_CmmLit
.

Inductive CmmExpr : Set :=
| CE_CmmLit: CC_CmmLit -> CmmExpr
| CE_CmmLoad: CmmExpr -> CC_CmmType -> CmmExpr
| CE_CmmReg: CmmReg -> CmmExpr
| CE_CmmMachOp: MachOp -> list CmmExpr -> CmmExpr
| CE_CmmRegOff : CmmReg -> Int -> CmmExpr
.

Definition cmmLabelType (lbl:CLabel) : CC_CmmType := bWord.

Definition cmmLitType (l : CC_CmmLit) : CC_CmmType :=
  match l with
  | CmmInt _ width => CC_cmmBits width
  | CmmFloat _ width => CC_cmmFloat width
  | CmmLabel lbl => cmmLabelType lbl
  | CmmLabelOff lbl _ => cmmLabelType lbl
  | CmmLabelDiffOff _ _ _ width => CC_cmmBits width
  end.

Definition localRegType (l:CC_LocalReg) : CC_CmmType :=
  match l with
  | CC_LR _ rep => rep
  end.

Definition globalRegType (g:GlobalReg) : CC_CmmType :=
  match g with
  | VanillaReg _ _ => bWord (* we might want to look at the second parameter *)
  | FloatReg _ => CC_cmmFloat (exist _ W32 I)
  | DoubleReg _ => CC_cmmFloat (exist _ W64 I)
  | LongReg _ => b64
  | _ => bWord
  end.

Definition cmmRegType (r:CC_CmmReg) : CC_CmmType :=
  match r with
  | CmmLocal reg => localRegType reg
  | CmmGlobal reg => globalRegType reg
  end.

(*
Fixpoint cmmExprType (e : CmmExpr) : CC_CmmType :=
  match e with
  | CE_CmmLit lit => cmmLitType lit
  | CE_CmmLoad _ rep => rep
  | CE_CmmReg reg => cmmRegType reg
  | CE_CmmMachOp op args => machOpResultType op (List.map cmmExprType args)
  | CE_CmmRegOff reg _ => cmmRegType reg
  end.
*)