(** Infrastructure lemmas and tactic definitions for [?].

    Based on work by Brian Aydemir and Arthur Chargu¨¦raud, with help from
    Aaron Bohannon, Jeffrey Vaughan, and Dimitrios Vytiniotis.

    This file contains a number of definitions, tactics, and lemmas
    that are based only on the syntax of the language at hand.  While
    the exact statements of everything here would change for a
    different language, the general structure of this file (i.e., the
    sequence of definitions, tactics, and lemmas) would remain the
    same.

    Table of contents:
      - #Free variables#
      - #Substitution#
      - #The "pick fresh" tactic#
      - #The "pick fresh and apply" tactic#
      - #Properties of opening and substitution#
      - #Local closure is preserved under substitution#
      - #Automation# *)

Require Export Concur_Definitions.

(*Axiom skip : False.
Ltac skip := assert False; [ apply skip | contradiction ].*)

(* ********************************************************************** *)
(** * ## Free variables *)

(** In this section, we define free variable functions.  The functions
    [fv_tt] and [fv_te] calculate the set of atoms used as free type
    variables in a type or expression, respectively.  The function
    [fv_ee] calculates the set of atoms used as free expression
    variables in an expression.  Cases involving binders are
    straightforward since bound variables are indices, not names, in
    locally nameless representation. *)

Definition fv_cc (C : chan) : atoms :=
  match C with
  | bchan J => {}
  | fchan X => singleton X
  end.

Fixpoint fv_ce (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => {}
  | exp_unit => {}
  | exp_seq e1 e2 => (fv_ce e1) `union` (fv_ce e2)
  | exp_abs V e1  => fv_ce e1
  | exp_app e1 e2 => (fv_ce e1) `union` (fv_ce e2)
  | exp_apair e1 e2 => (fv_ce e1) `union` (fv_ce e2)
  | exp_fst e1 => fv_ce e1
  | exp_snd e1 => fv_ce e1
  | exp_mpair e1 e2 => (fv_ce e1) `union` (fv_ce e2)
  | exp_let e1 e2 => (fv_ce e1) `union` (fv_ce e2)
  | exp_inl T e1 => fv_ce e1
  | exp_inr T e1 => fv_ce e1
  | exp_case e1 e2 e3 => (fv_ce e1) `union` (fv_ce e2) `union` (fv_ce e3)
  | exp_go T e1 => fv_ce e1
  | exp_yield e1 => fv_ce e1
  | exp_snk A T => fv_cc A
  | exp_src A T => fv_cc A
  | exp_done A => fv_cc A
  end.

Fixpoint fv_cp (P : proc) {struct P} : atoms :=
  match P with
  | proc_exp e => fv_ce e
  | proc_par P1 P2 => (fv_cp P1) `union` (fv_cp P2)
  | proc_new T P1 => fv_cp P1
  end.

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => singleton x
  | exp_unit => {}
  | exp_seq e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_abs V e1 => fv_ee e1
  | exp_app e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_apair e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_fst e1 => fv_ee e1
  | exp_snd e1 => fv_ee e1
  | exp_mpair e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_let e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_inl T e1 => fv_ee e1
  | exp_inr T e1 => fv_ee e1
  | exp_case e1 e2 e3 => (fv_ee e1) `union` (fv_ee e2) `union` (fv_ee e3)
  | exp_go T e1 => fv_ee e1
  | exp_yield e1 => fv_ee e1
  | exp_snk A T => {}
  | exp_src A T => {}
  | exp_done A => {}
  end.

Fixpoint fv_env (E : env) {struct E} : atoms :=
  match E with
  | nil => {}
  | (x, bind_kn) :: E' =>
      singleton x `union` fv_env E'
  end.

Fixpoint fv_lenv (D : lenv) {struct D} : atoms :=
  match D with
  | nil => {}
  | (x, lbind_typ T) :: D' =>
      singleton x `union` fv_lenv D'
  end.

Fixpoint fv_cenv (Q : cenv) {struct Q} : atoms :=
  match Q with
  | nil => {}
  | (x, cbind_proto d T) :: Q' =>
      singleton x `union` fv_cenv Q'
  end.

Fixpoint fv_cenvs (Qs : cenvs) {struct Qs} : atoms :=
  match Qs with
  | nil => {}
  | Q :: Qs' =>
      fv_cenv Q `union` fv_cenvs Qs'
  end.

(* ********************************************************************** *)
(** * ## Substitution *)

(** In this section, we define substitution for expression and type
    variables appearing in types, expressions, and environments.
    Substitution differs from opening because opening replaces indices
    whereas substitution replaces free variables.  The definitions
    below are relatively simple for two reasons.
      - We are using locally nameless representation, where bound
        variables are represented using indices.  Thus, there is no
        need to rename variables to avoid capture.
      - The definitions below assume that the term being substituted
        in, i.e., the second argument to each function, is locally
        closed.  Thus, there is no need to shift indices when passing
        under a binder. *)

Fixpoint subst_cc (Z : atom) (C : chan) (A : chan) {struct A} : chan :=
  match A with
  | bchan J => bchan J
  | fchan X => if X == Z then C else (fchan X)
  end.

Fixpoint subst_ce (Z : atom) (C : chan) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_unit => exp_unit
  | exp_seq e1 e2 => exp_seq (subst_ce Z C e1) (subst_ce Z C e2)
  | exp_abs V e1 => exp_abs V (subst_ce Z C e1)
  | exp_app e1 e2 => exp_app (subst_ce Z C e1) (subst_ce Z C e2)
  | exp_apair e1 e2 => exp_apair (subst_ce Z C e1) (subst_ce Z C e2)
  | exp_fst e1 => exp_fst (subst_ce Z C e1)
  | exp_snd e1 => exp_snd (subst_ce Z C e1)
  | exp_mpair e1 e2 => exp_mpair (subst_ce Z C e1) (subst_ce Z C e2)
  | exp_let e1 e2 => exp_let (subst_ce Z C e1) (subst_ce Z C e2)
  | exp_inl V e1 => exp_inl V (subst_ce Z C e1)
  | exp_inr V e1 => exp_inr V (subst_ce Z C e1)
  | exp_case e1 e2 e3 =>
      exp_case (subst_ce Z C e1) (subst_ce Z C e2) (subst_ce Z C e3)
  | exp_go V e1 => exp_go V (subst_ce Z C e1)
  | exp_yield e1 => exp_yield (subst_ce Z C e1)
  | exp_snk A T => exp_snk (subst_cc Z C A) T
  | exp_src A T => exp_src (subst_cc Z C A) T
  | exp_done A => exp_done (subst_cc Z C A)
  end.

Fixpoint subst_cp (Z : atom) (C : chan) (P : proc) {struct P} : proc :=
  match P with
  | proc_exp e => proc_exp (subst_ce Z C e)
  | proc_par P1 P2 => proc_par (subst_cp Z C P1) (subst_cp Z C P2)
  | proc_new T P1 => proc_new T (subst_cp Z C P1)
  end.

Fixpoint subst_ee (z : atom) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => if x == z then u else (exp_fvar x)
  | exp_unit => exp_unit
  | exp_seq e1 e2 => exp_seq (subst_ee z u e1) (subst_ee z u e2)
  | exp_abs V e1 => exp_abs V (subst_ee z u e1)
  | exp_app e1 e2 => exp_app (subst_ee z u e1) (subst_ee z u e2)
  | exp_apair e1 e2 => exp_apair (subst_ee z u e1) (subst_ee z u e2)
  | exp_fst e1 => exp_fst (subst_ee z u e1)
  | exp_snd e1 => exp_snd (subst_ee z u e1)
  | exp_mpair e1 e2 => exp_mpair (subst_ee z u e1) (subst_ee z u e2)
  | exp_let e1 e2 => exp_let (subst_ee z u e1) (subst_ee z u e2)
  | exp_inl V e1 => exp_inl V (subst_ee z u e1)
  | exp_inr V e1 => exp_inr V (subst_ee z u e1)
  | exp_case e1 e2 e3 =>
      exp_case (subst_ee z u e1) (subst_ee z u e2) (subst_ee z u e3)
  | exp_go V e1 => exp_go V (subst_ee z u e1)
  | exp_yield e1 => exp_yield (subst_ee z u e1)
  | exp_snk A T => exp_snk A T
  | exp_src A T => exp_src A T
  | exp_done A => exp_done A
  end.

(* ********************************************************************** *)
(** * ## The "[pick fresh]" tactic *)

(** The "[pick fresh]" tactic introduces a fresh atom into the context.
    We define it in two steps.

    The first step is to define an auxiliary tactic [gather_atoms],
    meant to be used in the definition of other tactics, which returns
    a set of atoms in the current context.  The definition of
    [gather_atoms] follows a pattern based on repeated calls to
    [gather_atoms_with].  The one argument to this tactic is a
    function that takes an object of some particular type and returns
    a set of atoms that appear in that argument.  It is not necessary
    to understand exactly how [gather_atoms_with] works.  If we add a
    new inductive datatype, say for kinds, to our language, then we
    would need to modify [gather_atoms].  On the other hand, if we
    merely add a new type, say products, then there is no need to
    modify [gather_atoms]; the required changes would be made in
    [fv_tt]. *)

Ltac gather_atoms :=
  let A := ltac_map (fun x : atoms => x) in
  let B := ltac_map (fun x : atom => singleton x) in
  let C := ltac_map (fun x : exp => fv_ce x) in
  let D := ltac_map (fun x : proc => fv_cp x) in
  let E := ltac_map (fun x : exp => fv_ee x) in
  let F := ltac_map (fun x : env => dom x) in
  let G := ltac_map (fun x : env => fv_env x) in
  let H := ltac_map (fun x : lenv => dom x) in
  let J := ltac_map (fun x : lenv => fv_lenv x) in
  let K := ltac_map (fun x : cenv => dom x) in
  let L := ltac_map (fun x : cenv => fv_cenv x) in
  let M := ltac_map (fun x : cenvs => doms cbinding x) in
  let N := ltac_map (fun x : cenvs => fv_cenvs x) in
  simplify_list_of_atom_sets
    (A ++ B ++ C ++ D ++ E ++ F ++ G ++ H ++ J ++ K ++ L ++ M ++ N).

(** The second step in defining "[pick fresh]" is to define the tactic
    itself.  It is based on the [(pick fresh ... for ...)] tactic
    defined in the [Atom] library.  Here, we use [gather_atoms] to
    construct the set [L] rather than leaving it to the user to
    provide.  Thus, invoking [(pick fresh x)] introduces a new atom
    [x] into the current context that is fresh for "everything" in the
    context. *)

Tactic Notation "pick" "fresh" ident(x) :=
  let L := gather_atoms in (pick fresh x for L).

(* *********************************************************************** *)
(** * ## The "[pick fresh and apply]" tactic *)

(** This tactic is implementation specific only because of its
    reliance on [gather_atoms], which is itself implementation
    specific.  The definition below may be copied between developments
    without any changes, assuming that the other other developments
    define an appropriate [gather_atoms] tactic.  For documentation on
    the tactic on which the one below is based, see the
    [Metatheory] library. *)

Tactic Notation
      "pick" "fresh" ident(atom_name) "and" "apply" constr(lemma) :=
  let L := gather_atoms in
  pick fresh atom_name excluding L and apply lemma.

(* ********************************************************************** *)
(** * ## Properties of opening and substitution *)

(** The following lemmas provide useful structural properties of
    substitution and opening.  While the exact statements are language
    specific, we have found that similar properties are needed in a
    wide range of languages.

    Below, we indicate which lemmas depend on which other lemmas.
    Since [te] functions depend on their [tt] counterparts, a similar
    dependency can be found in the lemmas.

    The lemmas are split into three sections, one each for the [tt],
    [te], and [ee] functions.  The most important lemmas are the
    following:
      - Substitution and opening commute with each other, e.g.,
        [subst_tt_open_tt_var].
      - Opening a term is equivalent to opening the term with a fresh
        name and then substituting for that name, e.g.,
        [subst_tt_intro].

    We keep the sections as uniform in structure as possible.  In
    particular, we state explicitly strengthened induction hypotheses
    even when there are more concise ways of proving the lemmas of
    interest. *)

(* ********************************************************************** *)
(** ** Properties of channel substitution in channels *)

(** The next lemma is the strengthened induction hypothesis for the
    lemma that follows, which states that opening a locally closed
    term is the identity.  This lemma is not otherwise independently
    useful.

    This should be easy for the channel/channel case... right? *)

Lemma open_cc_rec_channel_aux : forall A j B i C,
  i <> j ->
  open_cc_rec j B A = open_cc_rec i C (open_cc_rec j B A) ->
  A = open_cc_rec i C A.
Proof with try solve [congruence | eauto].
  induction A; intros j B i C Neq H; simpl in *; inversion H; f_equal...
  Case "bchan".
    destruct (j == n)... destruct (i == n)...
Qed.

(** Opening a locally closed channel is the identity.  This lemma depends
    on the immediately preceding lemma. *)

Lemma open_cc_rec_channel : forall A C k,
  channel A ->
  A = open_cc_rec k C A.
Proof with try solve [congruence | intuition].
  intros A C k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...
Qed.

(** If a name is fresh for a channel, then substituting for it is the
    identity. *)

Lemma subst_cc_fresh : forall Z C A,
   Z `notin` fv_cc A ->
   A = subst_cc Z C A.
Proof with try solve [congruence | intuition].
  induction A; simpl; intro H; f_equal...
  Case "fchan".
    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

(** Substitution commutes with opening under certain conditions.  This
    lemma depends on the fact that opening a locally closed term is
    the identity. *)

Lemma subst_cc_open_cc_rec : forall A1 A2 X C k,
  channel C ->
  subst_cc X C (open_cc_rec k A2 A1) =
    open_cc_rec k (subst_cc X C A2) (subst_cc X C A1).
Proof with try solve [congruence | intuition].
  intros A1 A2 X C k WC. revert k.
  induction A1; intros K; simpl; f_equal...
  Case "bchan".
    destruct (K == n); subst...
  Case "fchan".
    destruct (a == X); subst... apply open_cc_rec_channel...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero. *)

Lemma subst_cc_open_cc : forall A1 A2 (X:atom) C,
  channel C ->
  subst_cc X C (open_cc A1 A2) = open_cc (subst_cc X C A1) (subst_cc X C A2).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_cc.
  apply subst_cc_open_cc_rec...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---here, we're opening the term with a variable.  In
    practice, this lemma seems to be needed as a left-to-right rewrite
    rule, when stated in its current form. *)

Lemma subst_cc_open_cc_var : forall (X Y:atom) C A,
  Y <> X ->
  channel C ->
  open_cc (subst_cc X C A) Y = subst_cc X C (open_cc A Y).
Proof with try solve [congruence | intuition].
  intros X Y C A Neq Wu.
  unfold open_cc.
  rewrite subst_cc_open_cc_rec...
  simpl.
  destruct (Y == X)...
Qed.

(** The next lemma states that opening a term is equivalent to first
    opening the term with a fresh name and then substituting for the
    name.  This is actually the strengthened induction hypothesis for
    the version we use in practice. *)

Lemma subst_cc_intro_rec : forall X A2 C k,
  X `notin` fv_cc A2 ->
  open_cc_rec k C A2 = subst_cc X C (open_cc_rec k (fchan X) A2).
Proof with try solve [congruence | intuition].
  induction A2; intros C K Fr; simpl in *; f_equal...
  Case "bchan".
    destruct (K == n)... simpl. destruct (X == X)...
  Case "fchan".
    destruct (a == X)... contradict Fr; fsetdec.
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero.  *)

Lemma subst_cc_intro : forall (X : atom) A2 C,
  X `notin` fv_cc A2 ->
  open_cc A2 C = subst_cc X C (open_cc A2 X).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_cc.
  apply subst_cc_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of channel substitution in expressions *)

(** This section follows the structure of the previous section.  The
    one notable difference is that we require two auxiliary lemmas to
    show that substituting a channel in a locally-closed expression is
    the identity.  (Or do we?  I don't really know.) *)

Lemma open_ce_rec_expr_aux : forall e j u i C ,
  open_ee_rec j u e = open_ce_rec i C (open_ee_rec j u e) ->
  e = open_ce_rec i C e.
Proof with try solve [congruence | eauto].
  induction e; intros j u i C H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_ce_rec_channel_aux : forall e j A i C,
  i <> j ->
  open_ce_rec j A e = open_ce_rec i C (open_ce_rec j A e) ->
  e = open_ce_rec i C e.
Proof.
  induction e; intros j A i C Neq Heq; simpl in *; inversion Heq;
    f_equal; eauto using open_cc_rec_channel_aux.
Qed.

Lemma open_ce_rec_expr : forall e C k,
  expr e ->
  e = open_ce_rec k C e.
Proof with try solve [congruence | intuition].
  intros e C k WF. revert k.
  induction WF; intros k; simpl; f_equal; auto using open_cc_rec_channel;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_ce_rec_expr_aux with (j := 0) (u := exp_fvar x);
    try solve [congruence | intuition]
  | unfold open_ce in *;
    pick fresh X;
    eapply open_ce_rec_channel_aux with (j := 0) (A := fchan X);
    try solve [congruence | intuition]
  ].
(*  assert (exp_apair e1 e2 = open_ce_rec 0 C (exp_apair e1 e2)).
    apply IHWF.
  inversion H0.
  assert (exp_apair e1 e2 = open_ce_rec k C (exp_apair e1 e2)).
    apply IHWF.
  inversion H1.
  rewrite <- H5. rewrite <- H2. auto.
  assert (exp_apair e1 e2 = open_ce_rec 0 C (exp_apair e1 e2)).
    apply IHWF.
  inversion H0.
  assert (exp_apair e1 e2 = open_ce_rec k C (exp_apair e1 e2)).
    apply IHWF.
  inversion H1.
  rewrite <- H6. rewrite <- H3. auto. *)
Qed.

Lemma subst_ce_fresh : forall X C e,
  X `notin` fv_ce e ->
  e = subst_ce X C e.
Proof.
  induction e; simpl; intros; f_equal; auto using subst_cc_fresh.
Qed.

Lemma subst_ce_open_ce_rec : forall e A X C k,
  channel C ->
  subst_ce X C (open_ce_rec k A e) =
    open_ce_rec k (subst_cc X C A) (subst_ce X C e).
Proof.
  intros e A X C k WC. revert k.
  induction e; intros K; simpl; f_equal; auto using subst_cc_open_cc_rec.
Qed.

Lemma subst_ce_open_ce : forall e A X C,
  channel C ->
  subst_ce X C (open_ce e A) = open_ce (subst_ce X C e) (subst_cc X C A).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ce.
  apply subst_ce_open_ce_rec...
Qed.

Lemma subst_ce_open_ce_var : forall (X Y:atom) C e,
  Y <> X ->
  channel C ->
  open_ce (subst_ce X C e) Y = subst_ce X C (open_ce e Y).
Proof with try solve [congruence | intuition].
  intros X Y C e Neq WC.
  unfold open_ce.
  rewrite subst_ce_open_ce_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_ce_intro_rec : forall X e C k,
  X `notin` fv_ce e ->
  open_ce_rec k C e = subst_ce X C (open_ce_rec k (fchan X) e).
Proof.
  induction e; intros C K Fr; simpl in *; f_equal;
    auto using subst_cc_intro_rec.
Qed.

Lemma subst_ce_intro : forall (X : atom) e C,
  X `notin` fv_ce e ->
  open_ce e C = subst_ce X C (open_ce e X).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ce.
  apply subst_ce_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of channel substitution in processes *)

(** This section follows the structure of the previous section.  *)

Lemma open_cp_rec_channel_aux : forall P j A i C,
  i <> j ->
  open_cp_rec j A P = open_cp_rec i C (open_cp_rec j A P) ->
  P = open_cp_rec i C P.
Proof.
  induction P; intros j A i C Neq Heq; simpl in *; inversion Heq;
    f_equal; eauto using open_ce_rec_channel_aux.
Qed.

Lemma open_cp_rec_process : forall P C k,
  process P ->
  P = open_cp_rec k C P.
Proof with try solve [congruence | intuition].
  intros P C k WF. revert k.
  induction WF; intros k; simpl; f_equal; auto using open_ce_rec_expr;
  unfold open_cp in *; pick fresh X;
  eapply open_cp_rec_channel_aux with (j := 0) (A := fchan X);
  try solve [congruence | intuition].
Qed.

Lemma subst_cp_fresh : forall X C P,
  X `notin` fv_cp P ->
  P = subst_cp X C P.
Proof.
  induction P; simpl; intros; f_equal; auto using subst_ce_fresh.
Qed.

Lemma subst_cp_open_cp_rec : forall P A X C k,
  channel C ->
  subst_cp X C (open_cp_rec k A P) =
    open_cp_rec k (subst_cc X C A) (subst_cp X C P).
Proof.
  intros P A X C k WC. revert k.
  induction P; intros K; simpl; f_equal; auto using subst_ce_open_ce_rec.
Qed.

Lemma subst_cp_open_cp : forall P A X C,
  channel C ->
  subst_cp X C (open_cp P A) = open_cp (subst_cp X C P) (subst_cc X C A).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_cp.
  apply subst_cp_open_cp_rec...
Qed.

Lemma subst_cp_open_cp_var : forall (X Y:atom) C P,
  Y <> X ->
  channel C ->
  open_cp (subst_cp X C P) Y = subst_cp X C (open_cp P Y).
Proof with try solve [congruence | intuition].
  intros X Y C P Neq WC.
  unfold open_cp.
  rewrite subst_cp_open_cp_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_cp_intro_rec : forall X P C k,
  X `notin` fv_cp P ->
  open_cp_rec k C P = subst_cp X C (open_cp_rec k (fchan X) P).
Proof.
  induction P; intros C K Fr; simpl in *; f_equal;
    auto using subst_ce_intro_rec.
Qed.

Lemma subst_cp_intro : forall (X : atom) P C,
  X `notin` fv_cp P ->
  open_cp P C = subst_cp X C (open_cp P X).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_cp.
  apply subst_cp_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of expression substitution in expressions *)

(** This section follows the structure of the previous two sections. *)

Lemma open_ee_rec_expr_aux : forall e j v u i,
  i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof with try solve [congruence | eauto].
  induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...
  Case "exp_bvar".
    destruct (j==n)... destruct (i==n)...
Qed.

Lemma open_ee_rec_channel_aux : forall e j C u i,
  open_ce_rec j C e = open_ee_rec i u (open_ce_rec j C e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; intros j C u i H; simpl; inversion H; f_equal; eauto.
Qed.

Lemma open_ee_rec_expr : forall u e k,
  expr e ->
  e = open_ee_rec k u e.
Proof with try solve [congruence | intuition].
  intros u e k Hexpr. revert k.
  induction Hexpr; intro k; simpl; f_equal; try solve [congruence | intuition];
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_ee_rec_expr_aux with (j := 0) (v := exp_fvar x);
    try solve [congruence | intuition]
  | unfold open_te in *;
    pick fresh X;
    eapply open_ee_rec_channel_aux with (j := 0) (A := fchan X);
    try solve [congruence | intuition]
  ].
  (*assert (exp_apair e1 e2 = open_ee_rec k u (exp_apair e1 e2)); auto.
  inversion H0. rewrite <- H2. auto.
  assert (exp_apair e1 e2 = open_ee_rec k u (exp_apair e1 e2)); auto.
  inversion H0. rewrite <- H3. auto.*)
Qed.

Lemma subst_ee_fresh : forall (x: atom) u e,
  x `notin` fv_ee e ->
  e = subst_ee x u e.
Proof with try solve [congruence | intuition].
  intros x u e; induction e; simpl; intro H; f_equal...
  Case "exp_fvar".
    destruct (a==x)...
    contradict H; fsetdec.
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
  expr u ->
  subst_ee x u (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with try solve [congruence | intuition].
  intros e1 e2 x u k WP. revert k.
  induction e1; intros K; simpl; f_equal...
  Case "exp_bvar".
    destruct (K == n); subst...
  Case "exp_fvar".
    destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
  expr u ->
  subst_ee x u (open_ee e1 e2) =
    open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ee.
  apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall (x y:atom) u e,
  y <> x ->
  expr u ->
  open_ee (subst_ee x u e) y = subst_ee x u (open_ee e y).
Proof with try solve [congruence | intuition].
  intros x y u e Neq Wu.
  unfold open_ee.
  rewrite subst_ee_open_ee_rec...
  simpl.
  destruct (y == x)...
Qed.

Lemma subst_ce_open_ee_rec : forall e1 e2 Z C k,
  subst_ce Z C (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_ce Z C e2) (subst_ce Z C e1).
Proof with try solve [congruence | intuition].
  induction e1; intros e2 Z C K; simpl; f_equal...
  Case "exp_bvar".
    destruct (K == n)...
Qed.

Lemma subst_ce_open_ee : forall e1 e2 Z C,
  subst_ce Z C (open_ee e1 e2) = open_ee (subst_ce Z C e1) (subst_ce Z C e2).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ee.
  apply subst_ce_open_ee_rec...
Qed.

Lemma subst_ce_open_ee_var : forall Z (x:atom) C e,
  open_ee (subst_ce Z C e) x = subst_ce Z C (open_ee e x).
Proof with try solve [congruence | intuition].
  intros.
  rewrite subst_ce_open_ee...
Qed.

Lemma subst_ee_open_ce_rec : forall e C z u k,
  expr u ->
  subst_ee z u (open_ce_rec k C e) = open_ce_rec k C (subst_ee z u e).
Proof with try solve [congruence | intuition].
  induction e; intros C z u K H; simpl; f_equal...
  Case "exp_fvar".
    destruct (a == z)... apply open_ce_rec_expr...
Qed.

Lemma subst_ee_open_ce : forall e C z u,
  expr u ->
  subst_ee z u (open_ce e C) = open_ce (subst_ee z u e) C.
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ce.
  apply subst_ee_open_ce_rec...
Qed.

Lemma subst_ee_open_ce_var : forall z (X:atom) u e,
  expr u ->
  open_ce (subst_ee z u e) X = subst_ee z u (open_ce e X).
Proof with try solve [congruence | intuition].
  intros z X u e H.
  rewrite subst_ee_open_ce...
Qed.

Lemma subst_ee_intro_rec : forall x e u k,
  x `notin` fv_ee e ->
  open_ee_rec k u e = subst_ee x u (open_ee_rec k (exp_fvar x) e).
Proof with try solve [congruence | intuition].
  induction e; intros u K Fr; simpl in *; f_equal...
  Case "exp_bvar".
    destruct (K == n)... simpl. destruct (x == x)...
  Case "exp_fvar".
    destruct (a == x)... contradict Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall (x : atom) e u,
  x `notin` fv_ee e ->
  open_ee e u = subst_ee x u (open_ee e x).
Proof with try solve [congruence | intuition].
  intros.
  unfold open_ee.
  apply subst_ee_intro_rec...
Qed.

(* *********************************************************************** *)
(** * ## Local closure is preserved under substitution *)

(** While these lemmas may be considered properties of substitution, we
    separate them out due to the lemmas that they depend on. *)

(** The following lemma depends on [subst_cc_open_cc_var]. *)

Lemma subst_cc_channel : forall Z C A,
  channel A ->
  channel C ->
  channel (subst_cc Z C A).
Proof with auto.
  intros Z C A HA HC.
  induction HA; simpl...
  Case "fchan".
    destruct (x == Z)...
Qed.

(** The following lemma depends on [subst_cc_channel] and
    [subst_ce_open_ee_var]. *)

Lemma subst_ce_expr : forall Z C e,
  expr e ->
  channel C ->
  expr (subst_ce Z C e).
Proof with eauto using subst_cc_channel.
  intros Z C e He Hc.
  induction He; simpl; auto using subst_cc_channel;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton Z);
    intros;
    try rewrite subst_ce_open_ee_var;
    try rewrite subst_ce_open_ce_var;
    eauto using subst_cc_channel
  ].
Qed.

(** The following lemma depends on things. *)

Lemma subst_cp_process : forall Z C P,
  process P ->
  channel C ->
  process (subst_cp Z C P).
Proof with eauto using subst_ce_expr.
  intros Z C P Hp Hc.
  induction Hp; simpl; auto using subst_ce_expr.
  econstructor... instantiate (1 := L `union` singleton Z).
  intros. rewrite subst_cp_open_cp_var...
Qed.

(** The following lemma depends on [subst_ee_open_ee_var] and
    [subst_ee_open_ce_var]. *)

Lemma subst_ee_expr : forall z e1 e2,
  expr e1 ->
  expr e2 ->
  expr (subst_ee z e2 e1).
Proof with auto.
  intros z e1 e2 He1 He2.
  induction He1; simpl; auto;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton z);
    intros;
    try rewrite subst_ee_open_ee_var;
    try rewrite subst_ee_open_ce_var;
    auto
  ].
  Case "expr_var".
    destruct (x == z)...
Qed.

(* *********************************************************************** *)
(* more properties of fv *)

Lemma fv_in_open_ee:  forall x e1 e2 k,
   x `in` fv_ee e1 ->
   x `in` fv_ee (open_ee_rec k e2 e1).
Proof.
  intros x. induction e1; intros e2 k1 IN; simpl in IN; simpl;
    try solve [fsetdec |
               apply IHe1; auto |
  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H;
    [ fsetdec
    | destruct H as [H | H] ;
      [ assert (x `in` fv_ee (open_ee_rec k1 e2 e1_1));
        [ apply IHe1_1; auto
        | fsetdec ]
      | assert (x `in` fv_ee (open_ee_rec k1 e2 e1_2));
        [ apply IHe1_2; auto
        | fsetdec ]]]].
  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2) \/ (x `in` fv_ee e1_3)) as H.
    fsetdec.
  destruct H as [H | [H | H]].
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.
    assert (x `in` fv_ee (open_ee_rec k1 e2 e1_3)).
      apply IHe1_3; auto.
    fsetdec.
Qed.

Lemma fv_in_open_ce:  forall x e1 C2 k,
   x `in` fv_ee e1 ->
   x `in` fv_ee (open_ce_rec k C2 e1).
Proof.
  intros x. induction e1; intros C2 k1 IN; simpl in IN; simpl;
    try solve [fsetdec |
               apply IHe1; auto |
  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2)) as H;
    [ fsetdec
    | destruct H as [H | H];
      [ assert (x `in` fv_ee (open_ce_rec k1 C2 e1_1));
        [ apply IHe1_1; auto
        | fsetdec ]
      | assert (x `in` fv_ee (open_ce_rec k1 C2 e1_2));
        [ apply IHe1_2; auto
        | fsetdec ]]]].
  assert ((x `in` fv_ee e1_1) \/ (x `in` fv_ee e1_2) \/ (x `in` fv_ee e1_3)) as H.
    fsetdec.
  destruct H as [H | [H | H]].
    assert (x `in` fv_ee (open_ce_rec k1 C2 e1_1)).
      apply IHe1_1; auto.
    fsetdec.
    assert (x `in` fv_ee (open_ce_rec k1 C2 e1_2)).
      apply IHe1_2; auto.
    fsetdec.
    assert (x `in` fv_ee (open_ce_rec k1 C2 e1_3)).
      apply IHe1_3; auto.
    fsetdec.
Qed.

Lemma notin_open_cc_rec_fv : forall (Y X : atom) A n,
  X `notin` fv_cc A ->
  X <> Y ->
  X `notin` fv_cc (open_cc_rec n Y A).
Proof.
  intros.
  generalize dependent n. generalize dependent X.
  induction A; simpl; intros X Nin Neq n0; simpl; auto.
    destruct (n0 == n); simpl; auto.
Qed.

Lemma notin_open_cc_fv : forall (Y X : atom) A,
  X `notin` fv_cc A ->
  X <> Y ->
  X `notin` fv_cc (open_cc A Y).
Proof.
  intros. unfold open_cc.
  apply (notin_open_cc_rec_fv Y X A 0); auto.
Qed.

Lemma notin_fv_cc_open : forall (Y X : atom) A,
  X `notin` fv_cc (open_cc A Y) ->
  X `notin` fv_cc A.
Proof.
 intros Y X A. unfold open_cc.
 generalize 0.
 induction A; simpl; intros K Fr; destruct_notin; try apply notin_union; eauto.
Qed.

(* *********************************************************************** *)
(** * ## Properties about close *)

Lemma close_open_cc_rec : forall  (K:nat) (X:atom) (A:chan) ,
  X `notin` fv_cc A ->
  close_cc_rec K X (open_cc_rec K (fchan X) A) = A.
Proof.
  intros K X A NI.
  destruct A; simpl.
  destruct (K == n).
  simpl. (destruct (X == X)). inversion e. auto. tauto.
  simpl. auto.

  destruct (X == a). auto. subst. simpl in NI. fsetdec. auto.
Qed.

Lemma close_open_cc :forall (X:atom) (A:chan),
  X `notin` fv_cc A ->
  close_cc (open_cc A X) X = A.
Proof.
  intros X A NI.
  unfold close_cc. unfold open_cc. apply close_open_cc_rec; auto.
Qed.

Lemma open_close_cc_rec : forall (K:nat) (X:atom) (A:chan),
  channel A ->
  open_cc_rec K (fchan X) (close_cc_rec K X A) = A.
Proof.
  intros K X A CH.
  destruct A. inversion CH.
  simpl. destruct (X == a). simpl. destruct (K == K). inversion e. auto.
  tauto.  simpl. auto.
Qed.

Lemma open_close_cc : forall (X:atom) (A:chan),
  channel A ->
  open_cc (close_cc A X) (fchan X) = A.
Proof.
  intros X A CH.
  unfold open_cc. unfold close_cc. apply open_close_cc_rec. auto.
Qed.

Lemma close_open_ce_rec : forall (K:nat) (X:atom) (e:exp),
  X `notin` fv_ce e ->
  close_ce_rec K X (open_ce_rec K (fchan X) e) = e.
Proof.
 intros K X e.
 induction e; intros; simpl in *; auto;
   try (rewrite IHe; auto; fsetdec);
   try (rewrite IHe1; try fsetdec; try rewrite IHe2; auto; try fsetdec);
   try (rewrite IHe1; try fsetdec; try rewrite IHe2; try fsetdec; try rewrite IHe3; auto; try fsetdec); try (rewrite close_open_cc_rec; auto); auto.

   rewrite IHe3. auto. fsetdec.
Qed.

Lemma open_ee_rec_inj : forall e1 e2 (Z:atom) i,
  Z `notin` fv_ee e1 ->
  Z `notin` fv_ee e2 ->
  open_ee_rec i Z e1 = open_ee_rec i Z e2 ->
  e1 = e2.
Proof.
  intros e1.
  (exp_cases (induction e1) Case); intros e2 Z i NI1 NI2 EQ;
    destruct e2; simpl in *; subst; (
    try (destruct (i == n); inversion EQ; auto);
    try (inversion EQ; subst; rewrite (IHe1 e2 Z i); auto);
    try (inversion EQ; (rewrite (IHe1_1 e2_1 Z i); try rewrite (IHe1_2 e2_2 Z i))); auto
   ); auto.

  destruct (i == n0).
  subst; auto. inversion EQ.
  destruct (i == n0).
  inversion EQ. auto.
  subst. fsetdec. subst. fsetdec.

  rewrite (IHe1 e2 Z (S i)); auto.

  rewrite (IHe1_3 e2_3 Z i); auto.
Qed.

Lemma fv_ee_open_ce: forall e (X:atom) i,
  fv_ee (open_ce_rec i X e) = fv_ee e.
Proof.
  induction e; intros X i; simpl in *; (
    try rewrite IHe;
    try rewrite IHe1;
    try rewrite IHe2;
    try rewrite IHe3
  ); auto.
Qed.

Lemma fv_ee_close_ce: forall e (X:atom) i,
  fv_ee (close_ce_rec i X e) = fv_ee e.
Proof.
  induction e; intros X i; simpl in *; (
    try rewrite IHe;
    try rewrite IHe1;
    try rewrite IHe2;
    try rewrite IHe3
  ); auto.
Qed.

Lemma close_ce_open_ee_comm: forall e (X Y:atom) i j,
  close_ce_rec i X (open_ee_rec j Y e) = open_ee_rec j Y (close_ce_rec i X e).
Proof.
  induction e; intros X Y i j; simpl in *; (
    try rewrite (IHe X Y i j);
    try rewrite (IHe1 X Y i j);
    try rewrite (IHe2 X Y i j);
    try rewrite (IHe3 X Y i j)
  ); auto.

  destruct (j == n). simpl. auto.
  simpl. auto.

  rewrite (IHe X Y i (S j)); auto.
Qed.

Lemma close_open_cp_rec : forall P X i,
  X `notin` fv_cp P ->
  close_cp_rec i X (open_cp_rec i X P) = P.
Proof.
  induction P; intros X i NI; simpl in *; subst; auto.
  rewrite close_open_ce_rec; auto.
  rewrite (IHP1 X i); auto.
  rewrite (IHP2 X i); auto.
  rewrite (IHP X (S i)); auto.
Qed.

Lemma close_cc_open_cc_comm : forall C i j X v,
  channel v ->
  X `notin` fv_cc v ->
  i <> j ->
  close_cc_rec i X (open_cc_rec j v C) = open_cc_rec j v (close_cc_rec i X C).
Proof.
  destruct C; intros i j X v CH NI NE; simpl in *; auto.
  destruct (j == n); simpl in *.
  destruct v. simpl. auto. simpl.
  destruct (X == a). subst. simpl in *. fsetdec. auto. auto.

  destruct (X == a). subst. destruct v. simpl in*.
  destruct (j == i). subst. tauto. auto. simpl.
  destruct (j == i). subst. tauto. auto.
  simpl. auto.
Qed.

Lemma close_ce_open_ce_comm : forall e i j X v,
  channel v ->
  X `notin` fv_cc v ->
  i <> j ->
  close_ce_rec i X (open_ce_rec j v e) = open_ce_rec j v (close_ce_rec i X e).
Proof.
  induction e; intros i j X v C1 NI NE; simpl in *; (
    try rewrite IHe;
    try rewrite IHe1;
    try rewrite IHe2;
    try rewrite IHe3;
    try rewrite close_cc_open_cc_comm
  ); auto.
Qed.

Lemma close_cp_open_cp_comm : forall P i j X v,
  channel v ->
  X `notin` fv_cc v ->
  i <> j ->
  close_cp_rec i X (open_cp_rec j v P) = open_cp_rec j v (close_cp_rec i X P).
Proof.
  induction P; intros i j X v C1 NI NE; simpl in *; (
    try rewrite IHP;
    try rewrite IHP1;
    try rewrite IHP2;
    try rewrite close_ce_open_ce_comm
  ); auto.
Qed.

Lemma fv_cc_close_cc : forall Z C (X:atom) i,
  Z `notin` fv_cc C ->
  Z `notin` fv_cc (close_cc_rec i X C).
Proof.
  intros Z C.
  destruct C; intros X i NI; simpl in *; auto.
  destruct (X == a).
  subst. simpl. fsetdec. simpl. auto.
Qed.

Lemma fv_ce_close_ce : forall Z e (X:atom) i,
  Z `notin` fv_ce e ->
  Z `notin` fv_ce (close_ce_rec i X e).
Proof.
  intros Z e.
  induction e; intros X i NI; simpl in *; try (apply fv_cc_close_cc); auto.
Qed.

Lemma fv_cp_close_cp: forall Z P (X:atom) i,
  Z `notin` fv_cp P ->
  Z `notin` fv_cp (close_cp_rec i X P).
Proof.
  intros Z P.
  induction P; intros X i NI; simpl in *; auto.
  apply fv_ce_close_ce; auto.
Qed.

Lemma notin_close_cc: forall Y C i X,
  Y `notin` fv_cc C ->
  Y `notin` fv_cc (close_cc_rec i X C).
Proof.
  intros Y C.
  induction C; intros i X NI; simpl in *; auto.
  destruct (X == a). simpl. fsetdec. simpl. auto.
Qed.

Lemma notin_close_ce: forall Y e i X,
  Y `notin` fv_ce e ->
  Y `notin` fv_ce (close_ce_rec i X e).
Proof.
  intros Y e.
  induction e; intros i X NI; simpl in *; try fsetdec; try apply notin_close_cc; auto.
Qed.

Lemma notin_close_cp: forall Y P i X,
  Y `notin` fv_cp P ->
  Y `notin` fv_cp (close_cp_rec i X P).
Proof.
  intros Y P.
  induction P; intros i X NI; simpl in *; auto.
  apply notin_close_ce; auto.
Qed.

Lemma fv_ce_close_ee: forall e i Z,
  fv_ce (close_ee_rec i Z e) = fv_ce e.
Proof.
  induction e; intros i Z; simpl in *; (
    try rewrite IHe;
    try rewrite IHe1;
    try rewrite IHe2;
    try rewrite IHe3
  ); auto.
  destruct (Z == a). simpl. auto. simpl. auto.
Qed.

Lemma fv_ce_open_ee: forall e i (Z:atom),
  fv_ce (open_ee_rec i Z e) = fv_ce e.
Proof.
  induction e; intros i Z; simpl in *; (
    try rewrite IHe;
    try rewrite IHe1;
    try rewrite IHe2;
    try rewrite IHe3
  ); auto.
  destruct (i == n). simpl. auto. simpl. auto.
Qed.

Lemma fv_close_cc_aux : forall K X A,
  X `notin` fv_cc (close_cc_rec K X A).
Proof.
  intros K X A.
  destruct A. simpl.  fsetdec. simpl.
  destruct (X == a). fsetdec. fsetdec.
Qed.

Lemma fv_close_ce_aux : forall K X e,
  X `notin` fv_ce (close_ce_rec K X e).
Proof.
  intros K X e.
  (exp_cases (induction e) Case); simpl; try fsetdec;
  try (assert (X `notin` fv_cc (close_cc_rec K X c)); try (apply fv_close_cc_aux); fsetdec).
Qed.

Lemma fv_close_cp_aux : forall X K P,
  X `notin` fv_cp (close_cp_rec K X P).
Proof.
  intros X K P.
  generalize K.
  (proc_cases (induction P) Case); intros; simpl.
  apply fv_close_ce_aux.

  assert (X `notin` fv_cp (close_cp_rec K0 X P1)); auto.

  auto.
Qed.

Lemma fv_close_cp : forall X P,
  X `notin` fv_cp (close_cp P X).
Proof.
  intros. unfold close_cp. apply fv_close_cp_aux.
Qed.

Lemma fv_ce_notin_open: forall X (u:atom) e i,
  X `notin` fv_cc u ->
  X `notin` fv_ce e ->
  X `notin` fv_ce (open_ce_rec i u e).
Proof.
  intros X u e.
  induction e; intros; simpl in *; try (eapply notin_open_cc_rec_fv); auto.
Qed.

Lemma fv_cp_notin_open: forall X (u:atom) P i,
  X `notin` fv_cc u ->
  X `notin` fv_cp P ->
  X `notin` fv_cp (open_cp_rec i u P).
Proof.
  intros X u P.
  induction P; intros; simpl in *; auto.

  apply fv_ce_notin_open; auto.
Qed.

Lemma open_cc_aux_inj : forall K X A1 A2,
  X `notin` (fv_cc A1) `union` (fv_cc A2) ->
  open_cc_rec K (fchan X) A1 = open_cc_rec K (fchan X) A2 ->
  A1 = A2.
Proof.
  intros K X A1 A2 NI EQ.
  destruct A1; destruct A2; simpl in *; subst; auto.
  destruct (K == n).
  destruct (K == n0).
  subst.  auto. inversion e. inversion EQ.
  destruct (K == n0). inversion EQ. auto.
  destruct (K == n). inversion EQ. subst. fsetdec. auto.
  destruct (K == n). inversion EQ. subst. fsetdec. auto.
Qed.

Lemma open_ce_aux_inj : forall K X e1 e2,
  X `notin` (fv_ce e1) `union` (fv_ce e2) ->
  open_ce_rec K X e1 = open_ce_rec K X e2 ->
  e1 = e2.
Proof.
  intros K X e1.
  generalize dependent K.
  (exp_cases (induction e1) Case); intros K e2 NI EQ; destruct e2;
      simpl in *; inversion EQ; subst;
   first [   rewrite (IHe1 K e2); auto
           | rewrite (IHe1_1 K e2_1); ( auto || rewrite (IHe1_2 K e2_2); auto)
           | idtac ]; (try rewrite (open_cc_aux_inj K X c c0)) ; auto.

  Case "exp_case".
  rewrite (IHe1_3 K e2_3); auto.
Qed.

Lemma open_cp_aux_inj : forall K X P1 P2,
  X `notin` (fv_cp P1) `union` (fv_cp P2) ->
  open_cp_rec K X P1 = open_cp_rec K X P2 ->
  P1 = P2.
Proof.
  intros K X P1.
  generalize dependent K. generalize dependent X.
  (proc_cases (induction P1) Case); intros X K P2 NI EQ; destruct P2;
  simpl in *; inversion EQ; subst.
  assert (e = e0). eapply open_ce_aux_inj; eauto. subst. auto.

  rewrite (IHP1_1 X K P2_1); auto.
  rewrite (IHP1_2 X K P2_2); auto.

  rewrite (IHP1 X (S K) P2); auto.
Qed.

Lemma open_cp_inj : forall X P1 P2,
  X `notin` (fv_cp P1) `union` (fv_cp P2) ->
  open_cp P1 X = open_cp P2 X ->
  P1 = P2.
Proof.
  intros. unfold open_cp in  H0.
  eapply open_cp_aux_inj. apply H.
  apply H0.
Qed.

Lemma open_cc_open_cc_comm : forall C i j u v,
  channel u ->
  channel v ->
  i <> j ->
  open_cc_rec i u (open_cc_rec j v C) = open_cc_rec j v (open_cc_rec i u C).
Proof.
  induction C; intros i j u v C1 C2 NE; simpl in *; auto.
  destruct (j == n). subst.
  destruct (i == n). subst. tauto.
  inversion C2. subst. simpl.
  destruct (n == n); tauto.
  destruct (i == n). subst.
  inversion C1. subst. simpl.
  destruct (n == n); tauto.
  simpl.
  destruct (i == n); subst.
  destruct (j == n); subst. tauto. tauto.
  destruct (j == n); subst. tauto. auto.
Qed.

Lemma open_ce_open_ce_comm : forall e i j u v,
  channel u ->
  channel v ->
  i <> j ->
  open_ce_rec i u (open_ce_rec j v e) = open_ce_rec j v (open_ce_rec i u e).
Proof.
  induction e; intros i j u v C1 C2 NE; simpl in *; (
    try rewrite IHe;
    try rewrite IHe1;
    try rewrite IHe2;
    try rewrite IHe3;
    try rewrite open_cc_open_cc_comm
  ); auto.
Qed.

Lemma open_cp_open_cp_comm : forall P i j u v,
  channel u ->
  channel v ->
  i <> j ->
  open_cp_rec i u (open_cp_rec j v P) = open_cp_rec j v (open_cp_rec i u P).
Proof.
  induction P; intros i j u v C1 C2 NE; simpl in *; auto.
  rewrite open_ce_open_ce_comm; auto.
  rewrite IHP1; auto. rewrite IHP2; auto.
  rewrite IHP; auto.
Qed.

Lemma open_ee_open_ce_comm: forall e f K J X,
  open_ee_rec K (open_ce_rec J X f) (open_ce_rec J X e) = open_ce_rec J X (open_ee_rec K f e).
Proof.
  (exp_cases (induction e) Case); intros f K J X; simpl in *;
  first [
          rewrite IHe1; rewrite IHe2; auto
         | rewrite IHe; auto
         | idtac ]; auto.

  destruct (K == n). auto. simpl. auto.

  rewrite IHe3. auto.
Qed.

Lemma open_close_ce_rec: forall (X:atom) e i,
  expr e ->
  open_ce_rec i X (close_ce_rec i X e) = e.
Proof.
  intros X e i EXP.
  generalize dependent i.
  induction EXP; intros i; simpl in *; subst; (
    try rewrite (IHEXP i);
    try rewrite (IHEXP1 i);
    try rewrite (IHEXP2 i);
    try rewrite (IHEXP3 i);
    try rewrite open_close_cc_rec
  ); auto.

  pick fresh Z.
  lapply (H1 Z); intros; auto.
  assert (open_ce_rec i X (close_ce_rec i X (open_ee e1 Z)) = open_ee e1 Z).
  apply H2; auto.
  unfold open_ee in H3.
  rewrite close_ce_open_ee_comm in H3.
  rewrite <- open_ee_open_ce_comm in H3.
  simpl in H3.
  rewrite (open_ee_rec_inj (open_ce_rec i X (close_ce_rec i X e1)) e1 Z 0); auto.
  rewrite fv_ee_open_ce. rewrite fv_ee_close_ce. fsetdec.
Qed.

Lemma open_close_cp_rec: forall (X:atom) P i,
  process P ->
  open_cp_rec i X (close_cp_rec i X P) = P.
Proof.
  intros X P i PR.
  generalize dependent i.
  (process_cases (induction PR) Case); intros i; simpl in *; auto.

  Case "process_exp".
  rewrite open_close_ce_rec; auto.

  Case "process_par".
  rewrite IHPR1; auto. rewrite IHPR2; auto.

  Case "process_new".
  pick fresh Z.
  assert (open_cp_rec (S i) X (close_cp_rec (S i) X (open_cp P1 Z)) = open_cp P1 Z).
  apply (H1 Z); auto.
  unfold open_cp in H2.
  rewrite close_cp_open_cp_comm in H2; auto.
  rewrite open_cp_open_cp_comm in H2; auto.
  rewrite (open_cp_aux_inj 0 Z (open_cp_rec (S i) X (close_cp_rec (S i) X P1)) P1); auto.
  assert (Z `notin` fv_cp (open_cp_rec (S i) X (close_cp_rec (S i) X P1))).
  apply fv_cp_notin_open. simpl. fsetdec.
  apply fv_cp_close_cp; auto.
  apply notin_union; auto.
Qed.

Lemma close_open_ee : forall e Z i,
  Z `notin` fv_ee e ->
  close_ee_rec i Z (open_ee_rec i Z e) = e.
Proof.
  induction e; intros Z i NI; simpl in *;  (
    try rewrite IHe;
    try rewrite IHe1;
    try rewrite IHe2;
    try rewrite IHe3
  );
  auto.
  destruct (i == n). simpl. destruct (Z == Z). subst. auto.
  tauto.
  simpl. auto.
  destruct (Z == a). subst. fsetdec. auto.
Qed.

Lemma open_ce_close_ee_comm : forall e i j u Z,
  open_ce_rec i u (close_ee_rec j Z e) = close_ee_rec j Z (open_ce_rec i u e).
Proof.
 induction e; intros i j u Z; simpl in *; (
   try rewrite IHe;
   try rewrite IHe1;
   try rewrite IHe2;
   try rewrite IHe3
 ); auto.
 destruct (Z == a). simpl. auto.
 simpl. auto.
Qed.

Lemma close_open_cp : forall P i X,
  X `notin` fv_cp P ->
  close_cp_rec i X (open_cp_rec i X P) = P.
Proof.
  induction P; intros i X NI; simpl in *.

  rewrite close_open_ce_rec; auto.

  rewrite (IHP1 i X); auto.
  rewrite (IHP2 i X); auto.

  rewrite (IHP (S i) X); auto.
Qed.

Lemma open_close_ce : forall (X:atom) (e:exp),
  expr e ->
  open_ce (close_ce e X) (fchan X) = e.
Proof.
  intros X e Expr. unfold open_ce. unfold close_ce.
  apply open_close_ce_rec. auto.
Qed.

Lemma open_close_cp : forall (X:atom) (P:proc),
  process P ->
  open_cp (close_cp P X) (fchan X) = P.
Proof.
  intros X P Proc. unfold open_cp. unfold close_cp.
  apply open_close_cp_rec. auto.
Qed.

(* *********************************************************************** *)
(** * ## Automation *)

(** We add as hints the fact that local closure is preserved under
    substitution.  This is part of our strategy for automatically
    discharging local-closure proof obligations. *)

Hint Resolve subst_cc_channel subst_ce_expr subst_cp_process subst_ee_expr.

(** When reasoning about the [binds] relation and [map], we
    occasionally encounter situations where the binding is
    over-simplified.  The following hint undoes that simplification,
    thus enabling [Hint]s from the [Environment] library. *)

(* These don't seem to make sense for us... *)

(*Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tb X U (F T)).

Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tlb X U (F T)).*)

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory") ***
*** End: ***
 *)


(** * 머리말 *)

(* ################################################################# *)
(** * 환영합니다 *)

(** _소프트웨어 기초_(신뢰성 있는 소프트웨어의 수학적 기초)의 다양한
    면들에 대한 전자책 시리즈의 시작점입니다. 강의 주제로 논리의 기본
    개념, 컴퓨터를 활용한 명제 증명(Computer-assisted theorem
    proving), 콕 증명 보조기 (Coq proof assistant), 함수형 언어
    (functional programming), 실행 과정 기반 의미 구조(operational
    semantics), 호어 논리(Hoare logic), 타입 시스템(static type
    system)을 다룬다. 고학년 학부생부터 박사과정 학생과 연구자들까지
    다양한 독자들을 대상으로 한다. 논리나 프로그래밍 언어에 대한 사전
    지식이 필요하지 않지만 수학을 많이 접했다면 도움이 될 것이다.

    이 강의의 특징은 백 퍼센트 형식화해서 컴퓨터로 검사하도록 구성된
    것이다. 즉, 전체 텍스트가 콕 스크립트다. 콕의 대화식 세션을 따라
    텍스트 내용을 읽도록 구성되어 있다. 텍스트의 모든 상세 내용은
    콕으로 완벽하게 형식화되어 있고, 대부분의 연습문제들을 콕을
    사용하여 풀어보도록 설계되었다.

    강의 파일들은 대략 한 학기 분량의 핵심적인 장들을 나열하도록
    구성되어 있고, 일관성 있고 단일 방향성의 이야기로 구성되어 있다.
    더불어 추가적인 주제들을 다루는 많은 파생된 장들도 있다.  모든
    핵심적인 장들은 고학년 학부생과 대학원생들에게 적합하다.

    이 책, _논리적 기초_,는 다른 책들을 위한 토대이고, 독자들에게
    함수형 프로그래밍, 건설적 논리(constructive logic), 콕 증명
    보조기를 소개한다. *)

(* ################################################################# *)
(** * 개요 *)

(** 신뢰성 있는 소프트웨어를 만드는 것은 어렵다. 현대 시스템들의 크기와
    복잡도, 개발에 참여하는 많은 개발자들, 다양한 시스템 요구사항들로
    인해 100%% 보다 훨씬 낮은 정확성이라도 대략 정확하게 소프트웨어를
    만드는 것조차도 매우 어렵다. 그리고 사회의 다양한 국면과 엮여
    정보를 처리함에 따라 버그와 위험으로 인한 비용이 확대된다.

    컴퓨터과학자들과 소프트웨어 공학자들은 이러한 문제들에 대응하기 위해
    소프트웨어 신뢰성을 높이기 위한 다양한 기법들을
    개발했다. 소프트웨어 프로젝트 팀들을 관리하는 방법(예를 들어
    익스트림 프로그래밍)에서부터 라이브러리(예를 들어 모델 뷰
    컨트롤러, 발행-가입, 등)와 프로그래밍 언어(예를 들어 객체지향
    프로그래밍, 관점 지향 프로그래밍,...) 설계 철학들, 소프트웨어의
    성질들을 기술하고 추론하는 수학적 기법과 이 성질들을 검증하기 위한
    도구들까지 다양하다. 이 강의는 마지막에 언급한 기법들에 초점을
    맞춘다.

    이 책은 세 가지 개념들을 엮어놓았다.

    (1) 프로그램에 대한 명제를 정밀하게 만들고 정당화하는 _논리_의
        기본 도구들

    (2) 논리적 주장을 엄밀하게 만들기 위하여 _증명 보조기_를 사용

    (3) 프로그램들에 대한 추론을 단순화하는 프로그래밍 방법으로
        그리고 프로그래밍과 논리를 연결하는 역할로써 _함수형 프로그래밍_

    [후기] 장에서 추가적으로 읽을만한 문헌을 소개한다.  모든
    참고문헌들에 대한 서지 정보는 [Bib] 파일에 있다.  *)

(* ================================================================= *)
(** ** 논리 *)

(** 논리는 _증명_을 주제로 하는 학문 분야다. 증명이란 특정 명제들이
    참인지 거짓인지에 대한 부정할 수 없는 주장이다. 컴퓨터과학에서
    논리의 중요한 역할에 대해 설명하는 많은 책들이 있다. 마나(Manna)와
    월딩거(Waldinger)는 논리를 "컴퓨터과학의 계산법"이라 불렀고,
    할러펜(Halpern)과 그 동료들의 논문 _컴퓨터과학에서 논리의 유별난
    효과_에서 논리가 어떻게 중요한 도구들과 통찰력들을 제공하는지
    수십 가지 사례들을 나열하였다. 정말로 "사실 논리는 수학에서 보다
    컴퓨터과학에서 훨씬 더 효과적임이 밝혀졌다. 특히 지난 백 년간 논리
    발전의 많은 자극이 수학으로부터 왔기 때문에 이 사실은 상당히
    주목할만하다."라고 보았다.

    특히 _귀납적 증명_이라는 기초적인 도구들은 컴퓨터과학의 모든 영역에
    사용된다. 독자 여러분은 분명히 이전에, 아마도 이산수학이나 알고리즘
    분석에 관한 강의에서 이것들을 보았을 것이다. 하지만 이 강의에서
    훨씬 더 깊이 이것들을 살펴볼 것이다. *)

(* ================================================================= *)
(** ** 증명 보조기 *)

(** 논리와 컴퓨터과학의 아이디어들은 서로 양쪽으로 주고받아왔다. 컴퓨터과학 또한
    논리에 중요한 기여들을 해왔다. 그중 하나는 논리 명제들을 증명하는 것을 도와주는
    소프트웨어 도구들을 개발해온 것이다. 이 도구들은 크게 두 가지로 분류할 수 있다.

       - _자동 정리 증명기_는 버튼만 누르면 제시한 명제가 _참_인지
         _거짓_인지 (또는 _시간이 너무 오래 걸려 모른다_)를
         리턴한다. 비록 특정 영역들에 국한되어 있지만 근래에 이 기술이
         크게 발전해왔고 이제 다양한 상황들에서 사용되고 있다. 이
         도구들의 예를 들면 에스에이티(SAT, boolean SATisfiability)
         도구들, 에스엠티(SMT, satisfiability modulo theores) 도구들,
         모델 검사기들이 있다.

       - _증명 보조기_는 어려운 부분들은 사람의 가이드에 의존하되 다소
         반복적인 부분들을 자동화하여 증명하는 혼합형 도구이다. 널리
         사용 중인 증명 보조기들로 이사벨(Isabelle), 아그다(Agda),
         트웰프(Twelf), 에이씨넬투(ACL2), 피브이에스(PVS), 콕(Coq) 등이
         있다.

    이 강의에서는 콕을 사용한다. 증명 보조기 콕은 1983년에 개발을
    시작했고 최근에 연구와 산업에 종사하는 다양한 커뮤니티에서 사용하고
    있다. 콕은 대화식으로 형식적 추론을 만들고 컴퓨터가 확인하는 방식을
    위한 다양한 기능을 제공하는 환경이다. 콕 시스템의 핵심부는 간단한
    증명 검사기로 구성되어 있는데, 이 검사기를 통해 오직 정확한 추론
    단계들만 수행하도록 보장한다. 콕 환경은 이 핵심부에 증명 개발을
    도와주는 고급 기능들을 제공한다. 방대한 공용 정의들과 보조 정리들
    라이브러리, 복잡한 증명들을 반자동으로 만들 수 있는 강력한
    전술(함수), 특정 상황에 맞추어 증명 자동화 전술을 새롭게 정의할 수
    있는 특별한 목적의 프로그래밍 언어 등이 포함되어 있다.

    콕은 컴퓨터과학과 수학을 넘나드는 거대하고 다양한 분야의 중요한
    성공 요소가 되고 있다.

    - _프로그래밍 언어를 모델링하는 플랫폼_으로써 복잡한 언어 정의들을
      기술하고 추론하는 표준 도구가 되었다. 자바카드(JavaCard) 플랫폼의
      보안성을 검사하는 데 사용되어 보안 분야 인증 표준 CC(Common
      Criteria)의 최고 등급을 받았다.  x86과 LLVM 어셈블리 언어와 C와
      같은 프로그래밍 언어의 형식 명세를 기술하는 데 사용되었다.

    - _형식적으로 검증된 소프트웨어와 하드웨어를 개발하기 위한
      환경_으로써 사용되고 있다. 콤써트(CompCert) 프로젝트에서 C언어
      최적화 컴파일러를 완벽하게 검증하였고, 써티코스(CertiKos)
      프로젝트에서 하이퍼바이저를 완전히 검증하였으며, 부동소수점
      숫자에 관한 알고리즘들의 정확성을 증명했고,
      써티크립트(CertiCrypt) 프로젝트에서 암호 알고리즘들의 보안성을
      추론하는 환경의 기초로 이용하고 있다. 오픈소스 리스크
      파이브(RISC-V) 프로세서의 구현을 검증하는 데에도 사용 중이다.

    - _종속 타입(dependent types)을 제공하는 함수형 프로그래밍을 위한
      제대로 된 환경_으로써 수많은 혁신들에 영향을 끼쳤다. 예를 들어
      와이놋(Ynot) 시스템은 "관계형 호어 추론" (_호어 논리_의 확장으로
      이 강의에서 다룰 것이다) 방법을 콕에 녹여냈다.

    - _고차원 논리(higher-order logic)를 위한 증명 보조기_로써 수학
      분야에서 많은 중요한 결과를 검증하는 데 사용되어 왔다. 증명 안에
      복잡한 계산을 포함하는 기능을 제공함으로써 네 가지 색
      정리(4-color theorem)의 증명을 처음으로 형식적으로
      검증해냈다. 이렇게 검증하기 전에 이 증명은 프로그램을 사용하여
      많은 상황들을 검사하는 부분이 포함되어 있기 때문에 수학자들
      사이에서 증명으로 인정할 지에 관하여 논쟁이 있었다. 콕으로
      형식화하여 프로그램을 실행하여 확인했던 부분의 정확성까지
      포함해서 모든 부분을 검사하였다. 더 최근에는 페이트 톰슨
      정리(Feit-Thompson theorem, 유한단순군의 분류에 관한 주요한
      첫번째 단계)을 콕으로 형식화하는데 더욱 방대한 양의 노력을
      기울이고 있다.

   만일 콕이라는 이름에 대해 궁금하다면 인리아(INRIA, 콕을 개발한
   프랑스 국립 연구소)에 있는 공식 웹 사이트에 언급된 설명을
   보자. "일부 프랑스 컴퓨터과학자들은 그들이 만든 소프트웨어에 동물
   종의 이름을 붙이는 전통을 가지고 있다. 카멜(Caml), 엘란(Elan),
   폭(Foc), 폭스(Phox)는 이런 암묵적인 전통의 예들이다. 프랑스어로
   '콕'은 수탉을 뜻하기도 하고, 콕이 기초로 하는 이론, 구성
   계산법(Calculus of Constructions, CoC)의 머리글자들처럼 발음한다."
   수탉은 프랑스의 국가 상징이기도 하며, 씨-오-큐(C-o-q)는 초기에 콕을
   개발한 사람들 중 티에리 코쿠아(Thierry Coquand)      이름에 포함된 첫
   번째 세 문자들이기도 하다. *)

(* ================================================================= *)
(** ** 함수형 프로그래밍 *)

(** _함수형 프로그래밍_이라는 용어는 거의 모든 프로그래밍 언어에서
    사용할 수 있는 프로그래밍 스타일들을 가리키기도 하고 이 스타일들을
    강조하여 설계된 프로그래밍 언어들을 말하기도
    한다. 하스켈(Haskell), 오캐멀(OCaml), 에스엠엘(Standrad ML),
    에프샵(F##), 스칼라(Scala), 스킴(Scheme), 라킷(Racket),
    리스프(Common Lisp), 클로져(Clojure), 얼랑(Erlang), 콕 등이 함수형
    프로그래밍 언어이다.

    함수형 프로그래밍은 수 십 년간 발전되어 왔다. 그 기원은
    처치(Church)가 1930년대에 발명한 람다 계산법(lambda
    calculus)이다. 이 시기는 초기 컴퓨터들(적어도 초기 전자 컴퓨터들)
    보다 앞선다! 하지만 90년대 초에 이르러서야 비로소 산업계
    엔지니어들과 언어 설계자들이 많은 관심을 보이기 시작했고 제인
    스트리트 캐피털(Jane St. Capital), 마이크로소프트(Microsoft),
    페이스북(Facebook), 에릭슨(Ericsson)과 같은 회사들의 고부가가치
    시스템들에서 중요한 역할을 담당하고 있다.

    함수형 프로그래밍의 가장 기본적인 생각은 가능한 계산은
    _순수(pure)_해야 한다는 것이다.  즉, 실행 결과는 오로지 결과를
    내는 것이라는 것이다. 입출력(I/O), 변수의 값을 할당, 포인터를
    변경하는 것과 같은 _부작용(side effects)_은 없어야 한다는
    생각이다. 예를 들어, _명령 기반(imperative)_ 정렬 함수는 숫자들
    리스트를 받아서 숫자들을 가리키는 포인터들을 배열해서 그 리스트
    안에 순서대로 놓도록 작성한다면, 순수한 정렬 함수는 원래 리스트를
    받아서 그 리스트의 숫자들을 정렬된 순서로 담고 있는 _새로운_
    리스트를 리턴한다.

    이런 스타일로 프로그래밍하면 프로그램을 이해하기 쉽고 추론하기
    쉬운 형태로 작성할 수 있는 혜택이 있다. 자료구조에 대해 연산할 때
    마다 항상 원래 자료구조는 변경하지 않은 채 두고 모두 새로운 자료
    구조를 결과로 낸다면 이 자료구조를 공유하는 방식을 고민할 필요가
    없고, 프로그램의 한 부분을 실행해서 변경이 발생함으로 인해
    프로그램의 다른 부분이 의존하는 불변 성질을 깨뜨리지 않을까 걱정할
    필요도 없다. 이러한 사항들은 동시성을 사용하는 시스템들에서 특히
    중요하다.  동시성 시스템(concurrent systems)에서 변경 가능한
    상태를 여러 스레드들이 공유하는 것은 치명적인 버그들의 잠재적
    원인이다. 산업계에서 최근에 함수형 프로그래밍에 관심을 보인 많은
    부분들이 동시성이 존재하는 상황에서 더 간단하게 동작하도록
    프로그래밍할 수 있기 때문이다.

    최근에 함수형 프로그래밍에 환호하는 또 다른 이유는 첫 번째 이유와
    연관되어 있는데, 보통 함수형 프로그램들은 명령 기반 프로그램들
    보다 병렬화가 훨씬 더 쉽기 때문이다.  만일 프로그램을 실행했을 때
    결과를 내는 것 말고 특별히 다른 효과가 없다면 이 프로그램을
    어디에서 실행하든 상관없다. 비슷한 얘기로, 프로그램을 실행하면서
    자료구조가 내부적으로 결코 변경되지 않는다면 프로세서 코어들 또는
    네트워크를 넘어서 이 자료구조를 자유롭게 복사할 수
    있다. 하둡(Hadoop)과 같은 대용량 분산 질의 처리기들의 핵심이고
    구글(Google)에서 전체 웹을 색인하는 데 사용하는
    "맵-리듀스(Map-Reduce)" 프로그래밍 스타일은 함수형 프로그래밍의
    고전적인 예이다.

    이 강의의 목적을 위하여 함수형 프로그래밍은 앞서 언급한 장점과
    더불어 또 다른 중요한 매력이 있다. 논리와 컴퓨터과학을 연결하는
    다리 역할을 하는 것이다.  정말로 콕은 그 자체로 작지만 매우
    표현력이 높은 함수형 프로그래밍 언어와 논리적 주장들을 서술하고
    증명하는 데 사용할 도구들의 집합을 조합해놓은 것이다.  더욱이 더
    자세히 들여다보면 콕의 논리에 관한 것과 프로그래밍에 관한 것은 콕
    시스템의 동일한 기초 원리(underlying machinery)를 보는 다른
    관점 들일뿐이라는 것을 발견한다. 즉, _증명과 프로그램_. *)

(* ================================================================= *)
(** ** 더 자세한 내용 *)

(** 이 책은 자체로 모든 내용을 담으려 했지만 특정 주제들을 더 깊이 탐구하고자 하는
    독자들은 [후기] 장에서 더 자세한 내용에 대한 제안을 참고할 수 있다.   *)

(* ################################################################# *)
(** * 강의 진행을 위한 참고 *)

(* ================================================================= *)
(** ** 책의 장들 간 의존성 *)

(** 이 책의 모든 장들 간의 의존성을 보여주는 다이어그램과 내용들을 연결하는 경로들을
    [deps.html] 파일에서 확인할 수 있다. *)

(* ================================================================= *)
(** ** 시스템 요구사항 *)

(** 윈도우, 리눅스, 맥 운영체제에서 콕을 실행할 수 있다. 필요한 사항은:

       - 콕 웹 사이트에서 제공하는 콕을 설치. 8.6 버전을 사용하면 된다.

       - 콕을 대화식으로 사용하기 위해 필요한 통합개발환경(IDE). 현재 두 가지 선택이 가능하다.

           - 프룹 제너럴(Proof General)은 이맥스 기반 통합개발환경이다. 이맥스에 익숙한
             사용자가 선호하는 선택이다. 콕과 별도의 설치가 필요하다 (구글링 "Proof General").

             이맥스를 사용하는 콕 사용자들 중 대범한 사용자라면 확장
             기능들 [company-coq]과 [control-lock]을 내려받아 사용할
             수도 있다.

           - CoqIDE는 간단한 독립적인 통합개발환경이다. 콕과 함께 배포되기 때문에 콕을 설치하면
             바로 사용 가능하다. 처음부터 컴파일해서 사용할 수도 있는데 어떤 환경에서는
             그래픽 사용자 인터페이스 라이브러리 등 추가 패키지들을 설치해야 컴파일 가능하다. *)

(* ================================================================= *)
(** ** 연습문제 *)

(** 각 장은 많은 연습문제들을 포함하고 있다. 각 연습문제에 별 등급을 매겨 놓았다.

       - 별 하나: 쉬운 연습문제로 등급을 표시해두었다. 대부분의 독자들은 1,2분 내에
         풀 수 있을 것이다. 이 별 등급의 연습문제들을 만날 때마다 풀어보는 습관을 갖기 바란다.

       - 별 두 개: 간단한 연습문제들 (5~10분).

       - 별 세 개: 다소 생각을 요구하는 연습문제들 (10분에서 30분).

       - 별 네 개와 다섯 개: 더 어려운 연습문제들 (30분 이상).

    어떤 연습문제들에는 "고급(Advanced)"을 붙여 놓았고 다른
    연습문제들은 "선택(optional)"을 붙여 놓았다. 선택 사항이 아니고
    고급 연습문제들이 아닌 연습문제들만 푸는 것만으로도 핵심적인
    내용을 잘 커버할 것이다. 선택적 연습문제들은 핵심 개념들과 함께
    다소 추가적인 연습을 제공하고 일부 독자들에게 흥미를 줄 수 있은
    부차적인 주제들을 소개한다. 고급 연습문제들은 도전적이고 깊은
    내용을 원하는 독자들을 위한 것이다.

    _이 연습문제들에 대한 풀이들을 공공장소에 공개하지 않을 것을
    부탁한다._ 소프트웨어 기초는 스스로 학습과 대학 강의에 널리
    사용되고 있다. 해답이 쉽게 노출된다면 과제물을 가지고 성적을 주는
    일반 강의에 훨씬 덜 도움이 될 것이다. 특히 독자들에게 검색
    엔진으로 찾을 수 있는 어떠한 장소에도 연습문제들의 해답을 올리지
    않도록 요청한다.   *)

(* ================================================================= *)
(** ** 콕 파일들을 내려받기 *)

(** 이 책의 배포판에 대한 전체 소스를 포함하는 묶음(tar) 파일에 콕
    스크립트와 에이치티엠엘(HTML) 파일들이 있는데 아래 주소에서
    제공한다.

        http://www.cis.upenn.edu/~bcpierce/sf

    (만일 이 책을 강의의 일부로 사용한다면 그 강의를 담당하는 교수가
     이 파일들을 직접 수정한 버전을 제공할 수도 있다. 배포판 대신
     수정판을 사용하세요) *)

(* ================================================================= *)
(** ** 강의 비디오 *)

(** _논리적 기초_에 관한 집중 여름 강좌들_(2017년 딥스펙 여름 학교의 일부)을
    아래 주소에서 볼 수 있다. 처음 강의 동영상의 화질이 좋지 않지만 나중에는
    점점 나아질 것이다. *)

    - https://deepspec.org/event/dsss17/coq_intensive.html

(* ################################################################# *)
(** * 강사를 위한 메모  *)

(** 강사 본인의 강의에 이 책을 사용한다면, 내용 중에 변경하고,
    개선하고, 추가하고 싶은 것이 반드시 있을 것이다. 당신이 기여하는 것을 환영합니다!

    만일 라이센스 문구, 서브라이센스 등을 조정해야하는 상황이 발생하는
    경우 합법성 문제를 단순하게 유지하고 책임을 단일화하기 위해서 이
    책에 기여하는 모든 사람들(개발자 저장소를 접근하는 모든
    사람들)에게 각자의 기여한 바에 대한 저작권을 다음과 같이 적절한
    "기록의 저자(Author of Record)"에 부여할 것을 요청한다.

      - 나는 나의 과거와 미래에 기여했던 바에 대한 저작권을 소프트웨어
        기초 프로젝트에 각 권 또는 요소의 "기록의 저자"에 부여하고,
        소프트웨어 기초의 나머지와 동일한 조항하에 라이센스를
        부여한다. 현재 시점에 "기록의 저자"는 다음과 같음을 이해하고
        있다. 2016년까지 "소프트웨어 기초"로, 2016년부터 각각 "논리적
        기초"와 "프로그래밍 기초"로 알려진 1권과 2권에 대해 "기록의
        저자"는 벤자민 피어스이다. 3권 "함수형 알고리즘 검증"에 대해
        "기록의 저자"는 안드류 더블류 아펠이다. 이 범위 밖에 있는
        요소(예를 들어 타입 세팅, 채점 도구, 다른 기반 소프트웨어)들에
        대해 "Author of Record"는 벤자민 피어스이다.

    시작하려면 벤자민 피어스에게 본인 소개와 이 책을 사용할 계획을 서술한 이메일을 보내주세요. 그리고
    아래 내용도 함께 보내주세요.
       (1) 위의 저작권 위임 텍스트와
       (2) 명령어 "htpasswd -s -n NAME"를 실행한 결과
    원하는 사용자 이름을 정해서 NAME을 바꾸면 됩니다.

    서브버전 저장소와 개발자 메일 리스트에 접근할 수 있도록 설정할 것입니다. 이 저장소의
    [INSTRUCTORS] 파일에서 추가 지시 사항들을 확인할 수 있습니다. *)

(* ################################################################# *)
(** * 번역 *)

(** 번역을 자원해서 진행하는 팀의 노력 덕분에
    [http://proofcafe.org/sf]에서 일본어로 _소프트웨어 기초_를 읽을 수 있습니다.
    중국어 번역은 진행 중입니다. *)

(* ################################################################# *)
(** * 감사 *)

(** _소프트웨어 기초_ 시리즈를 개발하는 것을 국립과학재단 엔에스에프
    익스페디션 그란트 1521523, _딥 스펙에 관한 과학_으로부터 일부
    지원을 받았습니다.

(** $Date: 2017-08-24 17:13:02 -0400 (Thu, 24 Aug 2017) $ *)


(*! Language | Combinational primitives available in all Kôika programs !*)
Require Export Koika.Common Koika.Environments Koika.IndexUtils Koika.Types Koika.ErrorReporting.

Inductive bits_comparison :=
  cLt | cGt | cLe | cGe.

Inductive bits_display_style :=
  dBin | dDec | dHex | dFull.

Record display_options :=
  { display_strings : bool;
    display_newline : bool;
    display_style : bits_display_style }.

Module PrimUntyped.
  Inductive udisplay :=
  | UDisplayUtf8
  | UDisplayValue (opts: display_options).

  Inductive uconv :=
  | UPack
  | UUnpack (tau: type)
  | UIgnore.

  Inductive ubits1 :=
  | UNot
  | USExt (width: nat)
  | UZExtL (width: nat)
  | UZExtR (width: nat)
  | URepeat (times: nat)
  | USlice (offset: nat) (width: nat).

  Inductive ubits2 :=
  | UAnd
  | UOr
  | UXor
  | ULsl
  | ULsr
  | UAsr
  | UConcat
  | USel
  | USliceSubst (offset: nat) (width: nat)
  | UIndexedSlice (width: nat)
  | UPlus
  | UMinus
  | UMul
  | UCompare (signed: bool) (c: bits_comparison).

  Inductive ustruct1 :=
  | UGetField (f: string)
  | UGetFieldBits (sig: struct_sig) (f: string).

  Inductive ustruct2 :=
  | USubstField (f: string)
  | USubstFieldBits (sig: struct_sig) (f: string).

  Inductive uarray1 :=
  | UGetElement (pos: nat)
  | UGetElementBits (sig: array_sig) (pos: nat).

  Inductive uarray2 :=
  | USubstElement (pos: nat)
  | USubstElementBits (sig: array_sig) (pos: nat).

  Inductive ufn1 :=
  | UDisplay (fn: udisplay)
  | UConv (fn: uconv)
  | UBits1 (fn: ubits1)
  | UStruct1 (fn: ustruct1)
  | UArray1 (fn: uarray1).

  Inductive ufn2 :=
  | UEq (negate: bool)
  | UBits2 (fn: ubits2)
  | UStruct2 (fn: ustruct2)
  | UArray2 (fn: uarray2).
End PrimUntyped.

Module PrimTyped.
  Inductive fdisplay :=
  | DisplayUtf8 (len: nat)
  | DisplayValue (tau: type) (opts: display_options).

  Inductive fconv :=
    Pack | Unpack | Ignore.

  Inductive lowered1 :=
  | IgnoreBits (sz: nat)
  | DisplayBits (fn: fdisplay).

  Inductive fbits1 :=
  | Not (sz: nat)
  | SExt (sz: nat) (width: nat)
  | ZExtL (sz: nat) (width: nat)
  | ZExtR (sz: nat) (width: nat)
  | Repeat (sz: nat) (times: nat)
  | Slice (sz: nat) (offset: nat) (width: nat)
  | Lowered (fn: lowered1).

  Inductive fbits2 :=
  | And (sz: nat)
  | Or (sz: nat)
  | Xor (sz: nat)
  | Lsl (bits_sz: nat) (shift_sz: nat)
  | Lsr (bits_sz: nat) (shift_sz: nat)
  | Asr (bits_sz: nat) (shift_sz: nat)
  | Concat (sz1 sz2 : nat)
  | Sel (sz: nat)
  | SliceSubst (sz: nat) (offset: nat) (width: nat)
  | IndexedSlice (sz: nat) (width: nat)
  | Plus (sz : nat)
  | Minus (sz : nat)
  | Mul (sz1 sz2: nat)
  | EqBits (sz: nat) (negate: bool)
  | Compare (signed: bool) (c: bits_comparison) (sz: nat).

  Inductive fstruct1 :=
  | GetField.

  Inductive fstruct2 :=
  | SubstField.

  Inductive farray1 :=
  | GetElement.

  Inductive farray2 :=
  | SubstElement.

  Inductive fn1 :=
  | Display (fn: fdisplay)
  | Conv (tau: type) (fn: fconv)
  | Bits1 (fn: fbits1)
  | Struct1 (fn: fstruct1) (sig: struct_sig) (f: struct_index sig)
  | Array1 (fn: farray1) (sig: array_sig) (idx: array_index sig).

  Inductive fn2 :=
  | Eq (tau: type) (negate: bool)
  | Bits2 (fn: fbits2)
  | Struct2 (fn: fstruct2) (sig: struct_sig) (f: struct_index sig)
  | Array2 (fn: farray2) (sig: array_sig) (idx: array_index sig).

  Definition GetElementBits (sig: array_sig) (idx: array_index sig) : fbits1 :=
    Slice (array_sz sig) (element_offset_right sig idx) (element_sz sig).

  Definition SubstElementBits (sig: array_sig) (idx: array_index sig) : fbits2 :=
    SliceSubst (array_sz sig) (element_offset_right sig idx) (element_sz sig).

  Definition GetFieldBits (sig: struct_sig) (idx: struct_index sig) : fbits1 :=
    Slice (struct_sz sig) (field_offset_right sig idx) (field_sz sig idx).

  Definition SubstFieldBits (sig: struct_sig) (idx: struct_index sig) : fbits2 :=
    SliceSubst (struct_sz sig) (field_offset_right sig idx) (field_sz sig idx).
End PrimTyped.

Module PrimTypeInference.
  Import PrimUntyped PrimTyped.

  Definition find_field sig f : result _ fn_tc_error :=
    opt_result (List_assoc f sig.(struct_fields)) (Arg1, UnboundField f sig).

  Definition check_index sig pos : result (array_index sig) fn_tc_error :=
    opt_result (Vect.index_of_nat sig.(array_len) pos) (Arg1, OutOfBounds pos sig).

  Definition tc1 (fn: ufn1) (tau1: type): result fn1 fn_tc_error :=
    match fn with
    | UDisplay fn =>
      match fn with
      | UDisplayUtf8 =>
        let/res sig := assert_kind (kind_array None) Arg1 tau1 in
        Success (Display (DisplayUtf8 sig.(array_len)))
      | UDisplayValue opts =>
        Success (Display (DisplayValue tau1 opts))
      end
    | UConv fn =>
      Success (match fn with
               | UPack => Conv tau1 Pack
               | UUnpack tau => Conv tau Unpack
               | UIgnore => Conv tau1 Ignore
               end)
    | UBits1 fn =>
      let/res sz1 := assert_kind kind_bits Arg1 tau1 in
      Success (Bits1 match fn with
                     | UNot => Not sz1
                     | USExt width => SExt sz1 width
                     | UZExtL width => ZExtL sz1 width
                     | UZExtR width => ZExtR sz1 width
                     | URepeat times => Repeat sz1 times
                     | USlice offset width => Slice sz1 offset width
                     end)
    | UStruct1 fn =>
      match fn with
      | UGetField f =>
        let/res sig := assert_kind (kind_struct None) Arg1 tau1 in
        let/res idx := find_field sig f in
        Success (Struct1 GetField sig idx)
      | UGetFieldBits sig f =>
        let/res idx := find_field sig f in
        Success (Bits1 (GetFieldBits sig idx))
      end
    | UArray1 fn =>
      match fn with
      | UGetElement pos =>
        let/res sig := assert_kind (kind_array None) Arg1 tau1 in
        let/res idx := check_index sig pos in
        Success (Array1 GetElement sig idx)
      | UGetElementBits sig pos =>
        let/res idx := check_index sig pos in
        Success (Bits1 (GetElementBits sig idx))
      end
    end.

  Definition tc2 (fn: ufn2) (tau1: type) (tau2: type): result fn2 fn_tc_error :=
    match fn with
    | UEq negate => Success (Eq tau1 negate)
    | UBits2 fn =>
      let/res sz1 := assert_kind kind_bits Arg1 tau1 in
      let/res sz2 := assert_kind kind_bits Arg2 tau2 in
      Success (Bits2 match fn with
                     | USel => Sel sz1
                     | USliceSubst offset width => SliceSubst sz1 offset width
                     | UIndexedSlice width => IndexedSlice sz1 width
                     | UAnd => And sz1
                     | UOr => Or sz1
                     | UXor => Xor sz1
                     | ULsl => Lsl sz1 sz2
                     | ULsr => Lsr sz1 sz2
                     | UAsr => Asr sz1 sz2
                     | UConcat => Concat sz1 sz2
                     | UPlus => Plus sz1
                     | UMinus => Minus sz1
                     | UMul => Mul sz1 sz2
                     | UCompare signed c => Compare signed c sz1
                     end)
    | UStruct2 fn =>
      match fn with
      | USubstField f =>
        let/res sig := assert_kind (kind_struct None) Arg1 tau1 in
        let/res idx := find_field sig f in
        Success (Struct2 SubstField sig idx)
      | USubstFieldBits sig f =>
        let/res idx := find_field sig f in
        Success (Bits2 (SubstFieldBits sig idx))
      end
    | UArray2 fn =>
      match fn with
      | USubstElement pos =>
        let/res sig := assert_kind (kind_array None) Arg1 tau1 in
        let/res idx := check_index sig pos in
        Success (Array2 SubstElement sig idx)
      | USubstElementBits sig pos =>
        let/res idx := check_index sig pos in
        Success (Bits2 (SubstElementBits sig idx))
      end
    end.
End PrimTypeInference.

Module CircuitSignatures.
  Import PrimTyped.
  Import SigNotations.

  Definition DisplaySigma (fn: fdisplay) : Sig 1 :=
    {$ match fn with
       | DisplayUtf8 len => array_t {| array_len := len; array_type := bits_t 8 |}
       | DisplayValue tau _ => tau
       end ~> unit_t $}.

  Definition CSigma1 (fn: fbits1) : CSig 1 :=
    match fn with
    | Not sz => {$ sz ~> sz $}
    | SExt sz width => {$ sz ~> (Nat.max sz width) $}
    | ZExtL sz width => {$ sz ~> (Nat.max sz width) $}
    | ZExtR sz width => {$ sz ~> (Nat.max sz width) $}
    | Repeat sz times => {$ sz ~> times * sz $}
    | Slice sz offset width => {$ sz ~> width $}
    | Lowered fn =>
      match fn with
      | DisplayBits fn => CSig_of_Sig (DisplaySigma fn)
      | IgnoreBits sz => {$ sz ~> 0 $}
      end
    end.

  Definition CSigma2 (fn: PrimTyped.fbits2) : CSig 2 :=
    match fn with
    | Sel sz => {$ sz ~> (log2 sz) ~> 1 $}
    | SliceSubst sz offset width => {$ sz ~> width ~> sz $}
    | IndexedSlice sz width => {$ sz ~> (log2 sz) ~> width $}
    | And sz => {$ sz ~> sz ~> sz $}
    | Or sz => {$ sz ~> sz ~> sz $}
    | Xor sz => {$ sz ~> sz ~> sz $}
    | Lsl bits_sz shift_sz => {$ bits_sz ~> shift_sz ~> bits_sz $}
    | Lsr bits_sz shift_sz => {$ bits_sz ~> shift_sz ~> bits_sz $}
    | Asr bits_sz shift_sz => {$ bits_sz ~> shift_sz ~> bits_sz $}
    | Concat sz1 sz2 => {$ sz1 ~> sz2 ~> (sz2 + sz1) $}
    | EqBits sz _ => {$ sz ~> sz ~> 1 $}
    | Plus sz => {$ sz ~> sz ~> sz $}
    | Minus sz => {$ sz ~> sz ~> sz $}
    | Mul sz1 sz2 => {$ sz1 ~> sz2 ~> sz1 + sz2 $}
    | Compare _ _ sz => {$ sz ~> sz ~> 1 $}
    end.
End CircuitSignatures.

Module PrimSignatures.
  Import PrimUntyped PrimTyped CircuitSignatures.
  Import SigNotations.

  Definition Sigma1 (fn: fn1) : Sig 1 :=
    match fn with
    | Conv tau fn =>
      match fn with
      | Pack => {$ tau ~> bits_t (type_sz tau) $}
      | Unpack => {$ bits_t (type_sz tau) ~> tau $}
      | Ignore => {$ tau ~> unit_t $}
      end
    | Display fn => DisplaySigma fn
    | Bits1 fn => Sig_of_CSig (CSigma1 fn)
    | Struct1 GetField sig idx => {$ struct_t sig ~> field_type sig idx $}
    | Array1 GetElement sig idx => {$ array_t sig ~> sig.(array_type) $}
    end.

  Definition Sigma2 (fn: fn2) : Sig 2 :=
    match fn with
    | Eq tau _ => {$ tau ~> tau ~> bits_t 1 $}
    | Bits2 fn => Sig_of_CSig (CSigma2 fn)
    | Struct2 SubstField sig idx => {$ struct_t sig ~> field_type sig idx ~> struct_t sig $}
    | Array2 SubstElement sig idx => {$ array_t sig ~> sig.(array_type) ~> array_t sig $}
    end.
End PrimSignatures.

Module BitFuns.
  Definition bitfun_of_predicate {sz} (p: bits sz -> bits sz -> bool) (bs1 bs2: bits sz) :=
    Ob~(p bs1 bs2).

  Definition sel {sz} (bs: bits sz) (idx: bits (log2 sz)) :=
    Ob~match Bits.to_index sz idx with
       | Some idx => Bits.nth bs idx
       | _ => false (* TODO: x *)
       end.

  Definition lsl {bits_sz shift_sz} (bs: bits bits_sz) (places: bits shift_sz) :=
    Bits.lsl (Bits.to_nat places) bs.

  Definition lsr {bits_sz shift_sz} (bs: bits bits_sz) (places: bits shift_sz) :=
    Bits.lsr (Bits.to_nat places) bs.

  Definition asr {bits_sz shift_sz} (bs: bits bits_sz) (places: bits shift_sz) :=
    Bits.asr (Bits.to_nat places) bs.

  Definition _eq {tau} {EQ: EqDec tau} (v1 v2: tau) :=
    Ob~(beq_dec v1 v2).

  Definition _neq {tau} {EQ: EqDec tau} (v1 v2: tau) :=
    Ob~(negb (beq_dec v1 v2)).

  Fixpoint get_field fields
           (v: struct_denote fields)
           (idx: index (List.length fields))
           {struct fields}
    : type_denote (snd (List_nth fields idx)).
    destruct fields, idx, p; cbn.
    - apply (fst v).
    - apply (get_field fields (snd v) a).
  Defined.

  Fixpoint subst_field fields
           (v: struct_denote fields)
           (idx: index (List.length fields))
           (v': type_denote (snd (List_nth fields idx)))
           {struct fields}
    : (struct_denote fields).
    destruct fields, idx, p; cbn.
    - apply (v', snd v).
    - apply (fst v, subst_field fields (snd v) a v').
  Defined.
End BitFuns.

Module CircuitPrimSpecs.
  Import PrimTyped BitFuns.

  Definition sigma1 (fn: PrimTyped.fbits1) : CSig_denote (CircuitSignatures.CSigma1 fn) :=
    match fn with
    | Not _ => fun bs => Bits.neg bs
    | SExt sz width => fun bs => Bits.extend_end bs width (Bits.msb bs)
    | ZExtL sz width => fun bs => Bits.extend_end bs width false
    | ZExtR sz width => fun bs => Bits.extend_beginning bs width false
    | Repeat sz times => fun bs => Bits.repeat times bs
    | Slice _ offset width => Bits.slice offset width
    | Lowered (DisplayBits _) => fun bs => Ob
    | Lowered (IgnoreBits _) => fun bs => Ob
    end.

  Definition sigma2 (fn: PrimTyped.fbits2) : CSig_denote (CircuitSignatures.CSigma2 fn) :=
    match fn with
    | Sel _ => sel
    | SliceSubst _ offset width => Bits.slice_subst offset width
    | IndexedSlice _ width => fun bs offset => Bits.slice (Bits.to_nat offset) width bs
    | And _ => Bits.and
    | Or _ => Bits.or
    | Xor _ => Bits.xor
    | Lsl _ _ => lsl
    | Lsr _ _ => lsr
    | Asr _ _ => asr
    | Concat _ _ => Bits.app
    | Plus _ => Bits.plus
    | Minus _ => Bits.minus
    | Mul _ _ => Bits.mul
    | EqBits _ false => _eq
    | EqBits _ true => _neq
    | Compare true cLt _ => bitfun_of_predicate Bits.signed_lt
    | Compare true cGt _ => bitfun_of_predicate Bits.signed_gt
    | Compare true cLe _ => bitfun_of_predicate Bits.signed_le
    | Compare true cGe _ => bitfun_of_predicate Bits.signed_ge
    | Compare false cLt _ => bitfun_of_predicate Bits.unsigned_lt
    | Compare false cGt _ => bitfun_of_predicate Bits.unsigned_gt
    | Compare false cLe _ => bitfun_of_predicate Bits.unsigned_le
    | Compare false cGe _ => bitfun_of_predicate Bits.unsigned_ge
    end.
End CircuitPrimSpecs.

Module PrimSpecs.
  Import PrimTyped BitFuns.

  Definition sigma1 (fn: fn1) : Sig_denote (PrimSignatures.Sigma1 fn) :=
    match fn with
    | Display fn =>
      match fn with
      | DisplayUtf8 _ => fun _ => Ob
      | DisplayValue tau _ => fun _ => Ob
      end
    | Conv tau fn =>
      match fn with
      | Pack => fun v => bits_of_value v
      | Unpack => fun bs => value_of_bits bs
      | Ignore => fun _ => Ob
      end
    | Bits1 fn => CircuitPrimSpecs.sigma1 fn
    | Struct1 GetField sig idx => fun s => get_field sig.(struct_fields) s idx
    | Array1 GetElement sig idx => fun a => vect_nth a idx
    end.

  Definition sigma2 (fn: fn2) : Sig_denote (PrimSignatures.Sigma2 fn) :=
    match fn with
    | Eq tau false  => _eq
    | Eq tau true  => _neq
    | Bits2 fn => CircuitPrimSpecs.sigma2 fn
    | Struct2 SubstField sig idx => fun s v => subst_field sig.(struct_fields) s idx v
    | Array2 SubstElement sig idx => fun a e => vect_replace a idx e
    end.
End PrimSpecs.


From Coq Require Import ssreflect.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config BasicAst.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICLiftSubst
  PCUICSigmaCalculus.

#[global] Hint Extern 20 (#|?X| = #|?Y|) =>
  match goal with
  [ H : All2_fold _ ?X ?Y |- _ ] => apply (All2_fold_length H)
  | [ H : All2_fold _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H)
  | [ H : on_contexts_over _ _ _ ?X ?Y |- _ ] => apply (All2_fold_length H)
  | [ H : on_contexts_over _ _ _ ?Y ?X |- _ ] => symmetry; apply (All2_fold_length H)
   end : pcuic.

Ltac pcuic_core :=
  try (solve [ intuition auto; eauto with pcuic || (try lia || congruence) ]).

Ltac pcuic :=
  pcuic_core || ltac:(try (red; repeat red; cbn in *; pcuic_core)).

Definition lengths :=
  (@context_assumptions_expand_lets_ctx,
   @context_assumptions_subst_context,
   context_assumptions_fold,
   @context_assumptions_app,
   @context_assumptions_map,
   @context_assumptions_mapi,
   @context_assumptions_mapi_context,
   @context_assumptions_smash_context,
   @context_assumptions_subst_instance,
   @context_assumptions_lift_context,
   @inst_case_context_assumptions,
    @expand_lets_ctx_length, @subst_context_length,
    @subst_instance_length, @expand_lets_k_ctx_length, @inds_length, @lift_context_length,
    @app_length, @repeat_length, @List.rev_length, @extended_subst_length, @reln_length,
    Nat.add_0_r, @app_nil_r, @rev_map_length, @rev_length, @unfold_length,
    @map_length, @mapi_length, @mapi_rec_length, @map_InP_length,
    @fold_context_length,
    @fold_context_k_length, @cofix_subst_length, @fix_subst_length,
    fix_context_length,
    @smash_context_length,
    @arities_context_length,
    @forget_types_length,
    @PCUICCases.ind_predicate_context_length,
    @PCUICCases.cstr_branch_context_length,
    @PCUICCases.inst_case_branch_context_length,
    @PCUICCases.inst_case_predicate_context_length,
    @inst_case_context_length,
    @ind_predicate_context_length,
    @map_context_length, @skipn_map_length,
    @mapi_context_length, idsn_length,
    @projs_length, ren_ids_length).

Ltac len ::=
  repeat (rewrite !lengths /= //); try solve [lia_f_equal].

Tactic Notation "len" "in" hyp(id) :=
  repeat (rewrite !lengths /= // in id);
  try solve [lia_f_equal].

(* Can be used after [move] by ssr tactics, e.g. [rewrite foo => /lens] *)
Notation "'lens'" := ltac:(len) (only parsing).


From stdpp Require Import gmap.
From iris.heap_lang Require Export lang.
From iris.prelude Require Import options.

(* This file contains some metatheory about the heap_lang language,
  which is not needed for verifying programs. *)

(* Closed expressions and values. *)
Fixpoint is_closed_expr (X : list string) (e : expr) : bool :=
  match e with
  | Val v => is_closed_val v
  | Var x => bool_decide (x ∈ X)
  | Rec f x e => is_closed_expr (f :b: x :b: X) e
  | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Free e | Load e =>
     is_closed_expr X e
  | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | Store e1 e2 | FAA e1 e2 =>
     is_closed_expr X e1 && is_closed_expr X e2
  | If e0 e1 e2 | Case e0 e1 e2 | CmpXchg e0 e1 e2 | Resolve e0 e1 e2 =>
     is_closed_expr X e0 && is_closed_expr X e1 && is_closed_expr X e2
  | NewProph => true
  end
with is_closed_val (v : val) : bool :=
  match v with
  | LitV _ => true
  | RecV f x e => is_closed_expr (f :b: x :b: []) e
  | PairV v1 v2 => is_closed_val v1 && is_closed_val v2
  | InjLV v | InjRV v => is_closed_val v
  end.

Lemma is_closed_weaken X Y e : is_closed_expr X e → X ⊆ Y → is_closed_expr Y e.
Proof. revert X Y; induction e; naive_solver (eauto; set_solver). Qed.

Lemma is_closed_weaken_nil X e : is_closed_expr [] e → is_closed_expr X e.
Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed.

Lemma is_closed_subst X e x v :
  is_closed_val v → is_closed_expr (x :: X) e → is_closed_expr X (subst x v e).
Proof.
  intros Hv. revert X.
  induction e=> X /= ?; destruct_and?; split_and?; simplify_option_eq;
    try match goal with
    | H : ¬(_ ∧ _) |- _ => apply not_and_l in H as [?%dec_stable|?%dec_stable]
    end; eauto using is_closed_weaken with set_solver.
Qed.
Lemma is_closed_subst' X e x v :
  is_closed_val v → is_closed_expr (x :b: X) e → is_closed_expr X (subst' x v e).
Proof. destruct x; eauto using is_closed_subst. Qed.

(* Substitution *)
Lemma subst_is_closed X e x es : is_closed_expr X e → x ∉ X → subst x es e = e.
Proof.
  revert X. induction e=> X /=; rewrite ?bool_decide_spec ?andb_True=> ??;
    repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
Qed.

Lemma subst_is_closed_nil e x v : is_closed_expr [] e → subst x v e = e.
Proof. intros. apply subst_is_closed with []; set_solver. Qed.

Lemma subst_subst e x v v' :
  subst x v (subst x v' e) = subst x v' e.
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst' e x v v' :
  subst' x v (subst' x v' e) = subst' x v' e.
Proof. destruct x; simpl; auto using subst_subst. Qed.

Lemma subst_subst_ne e x y v v' :
  x ≠ y → subst x v (subst y v' e) = subst y v' (subst x v e).
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using eq_sym, subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst_ne' e x y v v' :
  x ≠ y → subst' x v (subst' y v' e) = subst' y v' (subst' x v e).
Proof. destruct x, y; simpl; auto using subst_subst_ne with congruence. Qed.

Lemma subst_rec' f y e x v :
  x = f ∨ x = y ∨ x = BAnon →
  subst' x v (Rec f y e) = Rec f y e.
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
Lemma subst_rec_ne' f y e x v :
  (x ≠ f ∨ f = BAnon) → (x ≠ y ∨ y = BAnon) →
  subst' x v (Rec f y e) = Rec f y (subst' x v e).
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.

Lemma bin_op_eval_closed op v1 v2 v' :
  is_closed_val v1 → is_closed_val v2 → bin_op_eval op v1 v2 = Some v' →
  is_closed_val v'.
Proof.
  rewrite /bin_op_eval /bin_op_eval_bool /bin_op_eval_int /bin_op_eval_loc;
    repeat case_match; by naive_solver.
Qed.

Lemma heap_closed_alloc σ l n w :
  (0 < n)%Z →
  is_closed_val w →
  map_Forall (λ _ v, from_option is_closed_val true v) (heap σ) →
  (∀ i : Z, (0 ≤ i)%Z → (i < n)%Z → heap σ !! (l +ₗ i) = None) →
  map_Forall (λ _ v, from_option is_closed_val true v)
             (heap_array l (replicate (Z.to_nat n) w) ∪ heap σ).
Proof.
  intros Hn Hw Hσ Hl.
  eapply (map_Forall_ind
            (λ k v, ((heap_array l (replicate (Z.to_nat n) w) ∪ heap σ)
                       !! k = Some v))).
  - apply map_Forall_empty.
  - intros m i x Hi Hix Hkwm Hm.
    apply map_Forall_insert_2; auto.
    apply lookup_union_Some in Hix; last first.
    { eapply heap_array_map_disjoint;
        rewrite replicate_length Z2Nat.id; auto with lia. }
    destruct Hix as [(?&?&?&?&?&[-> Hlt%inj_lt]%lookup_replicate_1)%heap_array_lookup|
                     [j Hj]%elem_of_map_to_list%elem_of_list_lookup_1].
    + simplify_eq/=. rewrite !Z2Nat.id in Hlt; eauto with lia.
    + apply map_Forall_to_list in Hσ.
      by eapply Forall_lookup in Hσ; eauto; simpl in *.
  - apply map_Forall_to_list, Forall_forall.
    intros [? ?]; apply elem_of_map_to_list.
Qed.

(* The stepping relation preserves closedness *)
Lemma head_step_is_closed e1 σ1 obs e2 σ2 es :
  is_closed_expr [] e1 →
  map_Forall (λ _ v, from_option is_closed_val true v) σ1.(heap) →
  head_step e1 σ1 obs e2 σ2 es →
  is_closed_expr [] e2 ∧ Forall (is_closed_expr []) es ∧
  map_Forall (λ _ v, from_option is_closed_val true v) σ2.(heap).
Proof.
  intros Cl1 Clσ1 STEP.
  induction STEP; simpl in *; split_and!;
    try apply map_Forall_insert_2; try by naive_solver.
  - subst. repeat apply is_closed_subst'; naive_solver.
  - unfold un_op_eval in *. repeat case_match; naive_solver.
  - eapply bin_op_eval_closed; eauto; naive_solver.
  - by apply heap_closed_alloc.
  - select (_ !! _ = Some _) ltac:(fun H => by specialize (Clσ1 _ _ H)).
  - select (_ !! _ = Some _) ltac:(fun H => by specialize (Clσ1 _ _ H)).
  - case_match; try apply map_Forall_insert_2; by naive_solver.
Qed.

Fixpoint subst_map (vs : gmap string val) (e : expr) : expr :=
  match e with
  | Val _ => e
  | Var y => if vs !! y is Some v then Val v else Var y
  | Rec f y e => Rec f y (subst_map (binder_delete y (binder_delete f vs)) e)
  | App e1 e2 => App (subst_map vs e1) (subst_map vs e2)
  | UnOp op e => UnOp op (subst_map vs e)
  | BinOp op e1 e2 => BinOp op (subst_map vs e1) (subst_map vs e2)
  | If e0 e1 e2 => If (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | Pair e1 e2 => Pair (subst_map vs e1) (subst_map vs e2)
  | Fst e => Fst (subst_map vs e)
  | Snd e => Snd (subst_map vs e)
  | InjL e => InjL (subst_map vs e)
  | InjR e => InjR (subst_map vs e)
  | Case e0 e1 e2 => Case (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | Fork e => Fork (subst_map vs e)
  | AllocN e1 e2 => AllocN (subst_map vs e1) (subst_map vs e2)
  | Free e => Free (subst_map vs e)
  | Load e => Load (subst_map vs e)
  | Store e1 e2 => Store (subst_map vs e1) (subst_map vs e2)
  | CmpXchg e0 e1 e2 => CmpXchg (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  | FAA e1 e2 => FAA (subst_map vs e1) (subst_map vs e2)
  | NewProph => NewProph
  | Resolve e0 e1 e2 => Resolve (subst_map vs e0) (subst_map vs e1) (subst_map vs e2)
  end.

Lemma subst_map_empty e : subst_map ∅ e = e.
Proof.
  assert (∀ x, binder_delete x (∅:gmap _ val) = ∅) as Hdel.
  { intros [|x]; by rewrite /= ?delete_empty. }
  induction e; simplify_map_eq; rewrite ?Hdel; auto with f_equal.
Qed.
Lemma subst_map_insert x v vs e :
  subst_map (<[x:=v]>vs) e = subst x v (subst_map (delete x vs) e).
Proof.
  revert vs. induction e=> vs; simplify_map_eq; auto with f_equal.
  - match goal with
    | |- context [ <[?x:=_]> _ !! ?y ] =>
       destruct (decide (x = y)); simplify_map_eq=> //
    end. by case (vs !! _); simplify_option_eq.
  - destruct (decide _) as [[??]|[<-%dec_stable|[<-%dec_stable ?]]%not_and_l_alt].
    + rewrite !binder_delete_insert // !binder_delete_delete; eauto with f_equal.
    + by rewrite /= delete_insert_delete delete_idemp.
    + by rewrite /= binder_delete_insert // delete_insert_delete
        !binder_delete_delete delete_idemp.
Qed.
Lemma subst_map_singleton x v e :
  subst_map {[x:=v]} e = subst x v e.
Proof. by rewrite subst_map_insert delete_empty subst_map_empty. Qed.

Lemma subst_map_binder_insert b v vs e :
  subst_map (binder_insert b v vs) e =
  subst' b v (subst_map (binder_delete b vs) e).
Proof. destruct b; rewrite ?subst_map_insert //. Qed.
Lemma subst_map_binder_insert_empty b v e :
  subst_map (binder_insert b v ∅) e = subst' b v e.
Proof. by rewrite subst_map_binder_insert binder_delete_empty subst_map_empty. Qed.

Lemma subst_map_binder_insert_2 b1 v1 b2 v2 vs e :
  subst_map (binder_insert b1 v1 (binder_insert b2 v2 vs)) e =
  subst' b2 v2 (subst' b1 v1 (subst_map (binder_delete b2 (binder_delete b1 vs)) e)).
Proof.
  destruct b1 as [|s1], b2 as [|s2]=> /=; auto using subst_map_insert.
  rewrite subst_map_insert. destruct (decide (s1 = s2)) as [->|].
  - by rewrite delete_idemp subst_subst delete_insert_delete.
  - by rewrite delete_insert_ne // subst_map_insert subst_subst_ne.
Qed.
Lemma subst_map_binder_insert_2_empty b1 v1 b2 v2 e :
  subst_map (binder_insert b1 v1 (binder_insert b2 v2 ∅)) e =
  subst' b2 v2 (subst' b1 v1 e).
Proof.
  by rewrite subst_map_binder_insert_2 !binder_delete_empty subst_map_empty.
Qed.

(* subst_map on closed expressions *)
Lemma subst_map_is_closed X e vs :
  is_closed_expr X e →
  (∀ x, x ∈ X → vs !! x = None) →
  subst_map vs e = e.
Proof.
  revert X vs. assert (∀ x x1 x2 X (vs : gmap string val),
    (∀ x, x ∈ X → vs !! x = None) →
    x ∈ x2 :b: x1 :b: X →
    binder_delete x1 (binder_delete x2 vs) !! x = None).
  { intros x x1 x2 X vs ??. rewrite !lookup_binder_delete_None. set_solver. }
  induction e=> X vs /= ? HX; repeat case_match; naive_solver eauto with f_equal.
Qed.

Lemma subst_map_is_closed_nil e vs : is_closed_expr [] e → subst_map vs e = e.
Proof. intros. apply subst_map_is_closed with []; set_solver. Qed.


From iris.proofmode Require Import proofmode.
From lrust.typing Require Import typing.
From iris.prelude Require Import options.

Section rebor.
  Context `{!typeGS Σ}.

  Definition rebor : val :=
    fn: ["t1"; "t2"] :=
       Newlft;;
       letalloc: "x" <- "t1" in
       let: "x'" := !"x" in let: "y" := "x'" +ₗ #0 in
       "x" <- "t2";;
       let: "y'" := !"y" in
       letalloc: "r" <- "y'" in
       Endlft ;; delete [ #2; "t1"] ;; delete [ #2; "t2"] ;;
                 delete [ #1; "x"] ;; return: ["r"].

  Lemma rebor_type :
    typed_val rebor (fn(∅; Π[int; int], Π[int; int]) → int).
  Proof.
    intros E L. iApply type_fn; [solve_typing..|]. iIntros "/= !>".
      iIntros ([] ϝ ret p). inv_vec p=>t1 t2. simpl_subst.
    iApply (type_newlft []). iIntros (α).
    iApply (type_letalloc_1 (&uniq{α}(Π[int; int]))); [solve_typing..|]. iIntros (x). simpl_subst.
    iApply type_deref; [solve_typing..|]. iIntros (x'). simpl_subst.
    iApply (type_letpath (&uniq{α}int)); [solve_typing|]. iIntros (y). simpl_subst.
    iApply (type_assign _ (&uniq{α}(Π[int; int]))); [solve_typing..|].
    iApply type_deref; [solve_typing..|]. iIntros (y'). simpl_subst.
    iApply type_letalloc_1; [solve_typing..|]. iIntros (r). simpl_subst.
    iApply type_endlft.
    iApply type_delete; [solve_typing..|].
    iApply type_delete; [solve_typing..|].
    iApply type_delete; [solve_typing..|].
    iApply type_jump; solve_typing.
  Qed.
End rebor.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Elab.Elab Tools.Matches Compilers.Compilers Elab.ElabCompilers.
From Pyrosome.Lang Require Import SimpleVSubst SimpleVSTLC SimpleEvalCtx SimpleVCPS.
Import Core.Notations.

Require Coq.derive.Derive.

Notation compiler := (compiler string).

(*TODO: repackage this in compilers*)
Import CompilerDefs.Notations.

Definition Ectx_cps_def : compiler :=
  match # from eval_ctx with
  | {{s #"Ectx" "G" "A" "B" }} =>
    {{s #"blk" (#"ext" (#"ext" "G" (#"neg" "B")) "A") }}
  | {{e #"[ ]" "G" "A"}} =>
    {{e #"jmp" {ovar 1} {ovar 0} }}
  | {{e #"plug" "G" "A" "B" "E" "e"}} =>
    bind_k 1 (var "e") (var "A") (var "E")
  end.

Derive Ectx_cps
       SuchThat (elab_preserving_compiler cps_subst
                                          (cps_lang
                                             ++ block_subst
                                             ++ value_subst)
                                          Ectx_cps_def
                                          Ectx_cps
                                          eval_ctx)
       As Ectx_cps_preserving.
Proof. auto_elab_compiler. Qed.
#[export] Hint Resolve cps_subst_preserving : elab_pfs.