(***********************************************************************)
(** * Definition of LambdaJm *)
(***********************************************************************)

(** This file containes all of the definitions for a locally-nameless
    representation of the intuitionistic sequent calculus lambda-Jm .  *)

Require Import Metalib.Metatheory.
Require Export ELambda.Definitions. (* just for [typ] *)

(***********************************************************************)
(** * Syntax of LambdaJm *)
(***********************************************************************)

(** We use a locally nameless representation for the LambdaJm
    calculus, where bound variables are represented as natural numbers
    (de Bruijn indices) and free variables are represented as [atom]s.

    The type [atom], defined in the Metatheory library, represents names.
    Equality on names is decidable, and it is possible to generate an
    atom fresh for any given finite set of atoms ([atom_fresh]).

    Note: the type [var] is notation for [atom].  *)

Definition typ := ELambda.Definitions.typ.

Inductive term : Set :=    (*r proof terms *)
   | var_b (_:nat)
   | var_f (x:var)
   | abs (t:term)
   | app (t:term) (a:gmargs)
with gmargs : Set :=       (*r gm-arguments *)
   | args (u:term) (l:alist) (c:cont)
with alist : Set :=        (* lists *)
   | anil
   | acons (t:term) (l:alist)
with cont : Set :=         (*r continuations *)
   | cabs (v:term).

(** Coq's generation of T_ind principles is incomplete.
    We only get non-mutual induction principles generated by default.
    We must ask for mutual principles as we need them, using the Scheme command. *)

Scheme term_ind_4 := Induction for term Sort Prop
  with gmargs_ind_4 := Induction for gmargs Sort Prop
  with alist_ind_4 := Induction for alist Sort Prop
  with cont_ind_4 := Induction for cont Sort Prop.

Combined Scheme term_gmargs_alist_cont_mutind from
         term_ind_4, gmargs_ind_4, alist_ind_4, cont_ind_4.

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

(** Substitution replaces a free variable with a term.
    The definition below is simple for two reasons:
      - Because bound variables are represented using indices, there
        is no need to worry about variable capture.
      - We assume that the term being substituted in is locally
        closed.  Thus, there is no need to shift indices when
        passing under a binder.
*)

(** The [Fixpoint] keyword defines a Coq function.  As all functions in
    Coq must be total.  The annotation [{struct e}] indicates the
    termination metric---all recursive calls in this definition are made
    to arguments that are structurally smaller than [e].

    Note also that [subst_term] uses [x == y] for decidable equality.
    This operation is defined in the Metatheory library.  *)

Fixpoint subst_term (u:term) (y:var) (e:term) {struct e} : term :=
  match e with
  | (var_b n)  => var_b n
  | (var_f x)  => (if x == y then u else (var_f x))
  | (abs t)    => abs (subst_term u y t)
  | (app t a)  => app (subst_term u y t) (subst_args u y a)
  end
with subst_args (u:term) (y:var) (a:gmargs) {struct a} : gmargs :=
  match a with
  | (args t l c) => args (subst_term u y t) (subst_alist u y l) (subst_cont u y c)
  end
with subst_alist (u:term) (y:var) (l:alist) {struct l} : alist :=
  match l with
  | anil        => anil
  | acons t l1  => acons (subst_term u y t) (subst_alist u y l1)
  end
with subst_cont (u:term) (y:var) (c:cont) {struct c} : cont :=
  match c with
  | (cabs t)  => cabs (subst_term u y t)
  end.

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

(** The function [fv_term], defined below, calculates the set of free
    variables in an expression.  Because we are using a locally
    nameless representation, where bound variables are represented as
    indices, any name we see is a free variable of a term.  In
    particular, this makes the [abs] case simple.
 *)

Fixpoint fv_term (e:term) : vars :=
  match e with
  | (var_b n) => {}
  | (var_f x)   => {{x}}
  | (abs t)     => fv_term t
  | (app t a)   => fv_term t `union` fv_args a
  end
with fv_args (a:gmargs) : vars :=
  match a with
  | (args t l c)  =>  fv_term t `union` fv_alist l `union` fv_cont c
  end
with fv_alist (l:alist) {struct l} : vars :=
  match l with
  | anil     => {}
  | (acons t l1)  =>  (fv_term t) `union` (fv_alist l1)
  end
with fv_cont (c:cont) : vars :=
  match c with
  | (cabs t)  => fv_term t
  end.

(** the type [vars] represents a finite set of elements of type [atom].
    The notations for the finite set definitions (empty set `{}`,
    singleton `{{x}}` and union `\u`) is also defined in the Metatheory
    library.  *)

(***********************************************************************)
(** * Opening *)
(***********************************************************************)

(** Opening replaces an index with a term.  It corresponds to informal
    substitution for a bound variable, such as in the rule for beta
    reduction.  Note that only "dangling" indices (those that do not
    refer to any abstraction) can be opened.  Opening has no effect for
    terms that are locally closed.

    Natural numbers are just an inductive datatype with two constructors:
    [O] (as in the letter 'oh', not 'zero') and [S], defined in
    Coq.Init.Datatypes.  Coq allows literal natural numbers to be written
    using standard decimal notation, e.g., 0, 1, 2, etc.  The function
    [lt_eq_lt_dec] compares its two arguments for ordering.

    We do not assume that zero is the only unbound index in the term.
    Consequently, we must substract one when we encounter other unbound
    indices (i.e. the [inright] case).

    However, we do assume that the argument [u] is locally closed.  This
    assumption simplifies the implementation since we do not need to
    shift indices in [u] when passing under a binder. *)

Fixpoint open_term_wrt_term_rec (k:nat) (u:term) (e:term) {struct e}: term :=
  match e with
  | (var_b n) =>
      match lt_eq_lt_dec n k with
        | inleft (left _)  => var_b n
        | inleft (right _) => u
        | inright _        => var_b (n-1)
      end
  | (var_f x)   => var_f x
  | (abs t)     => abs (open_term_wrt_term_rec (S k) u t)
  | (app t a)   => app (open_term_wrt_term_rec k u t) (open_args_wrt_term_rec k u a)
  end
with open_args_wrt_term_rec (k:nat) (u:term) (a:gmargs) {struct a}: gmargs :=
  match a with
  | (args t l c) => args (open_term_wrt_term_rec k u t)
                         (open_alist_wrt_term_rec k u l)
                         (open_cont_wrt_term_rec k u c)        (*  ??????? *)
  end
with open_alist_wrt_term_rec (k:nat) (u:term) (l:alist) {struct l}: alist :=
  match l with
  | anil        => anil
  | acons t l1  => acons (open_term_wrt_term_rec k u t) (open_alist_wrt_term_rec k u l1)
  end
with open_cont_wrt_term_rec (k:nat) (u:term) (c:cont) {struct c}: cont :=
  match c with
  | (cabs t)  => cabs (open_term_wrt_term_rec (S k) u t)      (*  ??????? *)
  end.

Definition open_term_wrt_term t u := open_term_wrt_term_rec 0 u t.
Definition open_args_wrt_term a u := open_args_wrt_term_rec 0 u a.
Definition open_alist_wrt_term l u := open_alist_wrt_term_rec 0 u l.
Definition open_cont_wrt_term c u := open_cont_wrt_term_rec 0 u c.

(***********************************************************************)
(** * Closing *)
(***********************************************************************)

Require Import Arith.Bool_nat.

Fixpoint close_term_rec (n : nat) (x : var) (t : term) : term :=
  match t with
    | abs t => abs (close_term_rec (S n) x t)
    | var_f y => if x == y then var_b n else var_f y
    | var_b m => if lt_ge_dec m n then var_b m else var_b (S m)
    | app t (args u l (cabs v)) =>
      app (close_term_rec n x t)
          (args (close_term_rec n x u)
                (close_list_rec n x l)
                (cabs (close_term_rec (S n) x v)))
  end
with close_list_rec (n:nat) (x:var) (l: alist) : alist :=
       match l with
       | anil => anil
       | acons t l => acons (close_term_rec n x t) (close_list_rec n x l)
       end.

Definition close_term x e := close_term_rec 0 x e.

(***********************************************************************)
(** De Bruijn occurence Test *)
(***********************************************************************)

Fixpoint testINterm_rec (k:nat) (e:term) : bool :=
  match e with
  | (var_b n) =>
      match lt_eq_lt_dec n k with
        | inleft (left _)  => false
        | inleft (right _) => true
        | inright _        => false
      end
  | (var_f x)   => false
  | (abs t)     => testINterm_rec (S k) t
  | (app t a)   => (testINterm_rec k t) || (testINargs_rec k a)
  end
with testINargs_rec (k:nat) (a:gmargs) : bool :=
  match a with
  | (args t l c)  => (testINterm_rec k t) || (testINalist_rec k l) || (testINcont_rec k c)
  end
with testINalist_rec (k:nat) (l:alist) : bool :=
  match l with
  | anil        => false
  | acons t l1  => (testINterm_rec k t) || (testINalist_rec k l1)
  end
with testINcont_rec (k:nat) (c:cont) : bool :=
  match c with
  | (cabs t)  => testINterm_rec (S k) t
  end.

Definition in_term t  := testINterm_rec 0 t.
Definition in_args a  := testINargs_rec 0 a.
Definition in_alist l := testINalist_rec 0 l.
Definition in_cont c  := testINcont_rec 0 c.

Lemma testIN_var_b : forall k n, testINterm_rec k (var_b n) = false -> k <> n.
Proof.
  intros k n H. simpl in H. destruct (lt_eq_lt_dec n k).
  - destruct s.
    + intuition.
    + discriminate H.
  - intuition.
Qed.

Lemma testIN_open_rec_2 : forall e,
    (forall t k, testINterm_rec k t = false -> open_term_wrt_term_rec k e t = t) /\
    (forall a k, testINargs_rec k a = false -> open_args_wrt_term_rec k e a = a) /\
    (forall l k, testINalist_rec k l = false -> open_alist_wrt_term_rec k e l = l) /\
    (forall c k, testINcont_rec k c = false -> open_cont_wrt_term_rec k e c = c).
Proof.
  intros e.
  induction e using term_ind_4 with
  (P0 := fun a => forall k, testINargs_rec k a = false -> open_args_wrt_term_rec k _ a = a)
  (P1 := fun l => forall k, testINalist_rec k l = false -> open_alist_wrt_term_rec k _ l = l)
  (P2 := fun c => forall k, testINcont_rec k c = false -> open_cont_wrt_term_rec k _ c = c).

  repeat split.
  intros.
Admitted.

(* MJF: TODO ;) *)

Lemma testIN_open_rec : forall e,
    (forall t k, testINterm_rec k t = false -> open_term_wrt_term_rec k e t = t) /\
    (forall a k, testINargs_rec k a = false -> open_args_wrt_term_rec k e a = a) /\
    (forall l k, testINalist_rec k l = false -> open_alist_wrt_term_rec k e l = l) /\
    (forall c k, testINcont_rec k c = false -> open_cont_wrt_term_rec k e c = c).
Proof.
Admitted.
(*   intros e. *)
(*   apply (term_gmargs_alist_cont_mutind *)
(*            (fun t => forall k, testINterm_rec k t = false -> open_term_wrt_term_rec k e t = t)  *)
(*            (fun a => forall k, testINargs_rec k a = false -> open_args_wrt_term_rec k e a = a)  *)
(*            (fun l => forall k, testINalist_rec k l = false -> open_alist_wrt_term_rec k e l = l)  *)
(*            (fun c => forall k, testINcont_rec k c = false -> open_cont_wrt_term_rec k e c = c)); intros. *)
(*   - apply testIN_var_b in H. simpl. destruct (lt_eq_lt_dec n k). *)
(*     + destruct s. *)
(*       * reflexivity. *)
(*       * exfalso. auto. *)
(*     + reflexivity. *)
(*   - reflexivity. *)
(*   - simpl. f_equal. simpl in H0. apply H. assumption. *)
(*   - simpl. f_equal. *)
(*     + apply H. simpl in H1. apply orb_false_elim in H1. destruct H1. assumption. *)
(*     + apply H0. simpl in H1. apply orb_false_elim in H1; destruct H1; assumption.  *)
(*   - simpl. f_equal. *)
(*     + apply H. simpl in H2. apply orb_false_elim in H2. destruct H2. *)
(*       apply orb_false_elim in H2. destruct H2. assumption. *)
(*     + apply H0. simpl in H2. apply orb_false_elim in H2. destruct H2. *)
(*       apply orb_false_elim in H2. destruct H2. assumption. *)
(*     + apply H1. simpl in H2. apply orb_false_elim in H2. destruct H2. assumption. *)
(*   - reflexivity. *)
(*   - simpl. f_equal. *)
(*     + apply H. simpl in H1. apply orb_false_elim in H1. destruct H1. assumption. *)
(*     + apply H0. simpl in H1.  apply orb_false_elim in H1. destruct H1. assumption. *)
(*   - simpl. f_equal. apply H. simpl in H0. assumption. *)
(* Qed.     *)

Lemma testIN_openT_rec : forall e t k, testINterm_rec k t = false -> open_term_wrt_term_rec k e t = t.
Proof. apply testIN_open_rec. Qed.

Lemma testIN_openA_rec : forall e a k, testINargs_rec k a = false -> open_args_wrt_term_rec k e a = a.
Proof. apply testIN_open_rec. Qed.

Lemma testIN_openL_rec : forall e l k, testINalist_rec k l = false -> open_alist_wrt_term_rec k e l = l.
Proof. apply testIN_open_rec. Qed.

Lemma testIN_openC_rec : forall e c k, testINcont_rec k c = false -> open_cont_wrt_term_rec k e c = c.
Proof. apply testIN_open_rec. Qed.

(***********************************************************************)
(** * Local closure *)
(***********************************************************************)

(** Recall that [term] admits terms that contain unbound indices.  We say
    that a term is locally closed when no indices appearing in it are
    unbound.  The proposition [lc_term t] holds when an expression [t] is
    locally closed.

    The inductive definition below formalizes local closure such that the
    resulting induction principle serves as the structural induction
    principle over (locally closed) terms.  In particular, unlike
    induction for type [term], there are no cases for bound variables.
    Thus, the induction principle corresponds more closely to informal
    practice than the one arising from the definition of pre-terms.  *)

Inductive lc_term : term -> Prop :=
 | lc_var_f : forall (x:var),
     lc_term (var_f x)
 | lc_abs : forall (t:term),
     (forall x , lc_term (open_term_wrt_term t (var_f x)))  ->
     lc_term (abs t)
 | lc_app : forall (t:term) (a:gmargs),
     lc_term t ->
     lc_gmargs a ->
     lc_term (app t a)
with lc_gmargs : gmargs -> Prop :=
 | lc_args : forall (u:term) (l:alist) (c:cont),
     lc_term u ->
     lc_alist l ->
     lc_cont c ->
     lc_gmargs (args u l c)
with lc_alist : alist -> Prop :=
 | lc_anil : lc_alist anil
 | lc_acons : forall (u:term) (l:alist),
     lc_term u ->
     lc_alist l ->
     lc_alist (acons u l)
with lc_cont : cont -> Prop :=
 | lc_cabs : forall (t:term),
     (forall x , lc_term (open_term_wrt_term t (var_f x)))  ->
     lc_cont (cabs t).

Scheme lc_term_ind_4 := Induction for lc_term Sort Prop
  with lc_gmargs_ind_4 := Induction for lc_gmargs Sort Prop
  with lc_alist_ind_4 := Induction for lc_alist Sort Prop
  with lc_cont_ind_4 := Induction for lc_cont Sort Prop.

Combined Scheme lc_mutind from
         lc_term_ind_4, lc_gmargs_ind_4, lc_alist_ind_4, lc_cont_ind_4.

Hint Constructors lc_term lc_gmargs lc_alist lc_cont.

(***********************************************************************)
(** * Notations *)
(***********************************************************************)

(** Many common applications of opening replace index zero with an
    expression or variable.  The following definition provides a
    convenient shorthand for such uses.  Note that the order of
    arguments is switched relative to the definition above.  For
    example, [(open t x)] can be read as "substitute the variable [x]
    for index [0] in [t]" and "open [t] with the variable [x]."
*)

Module LambdaJmNotations.
Notation "[ z ~> u ] e" := (subst_term u z e) (at level 0).
Notation substT u x t   := (subst_term u x t).
Notation substA u x a   := (subst_args u x a).
Notation substL u x l   := (subst_alist u x l).
Notation substC u x c   := (subst_cont u x c).

(*Notation open t1 t2     := (open_term_wrt_term t1 t2).*)
Notation "t ^ x"        := (open_term_wrt_term t (var_f x)).
Notation openT t1 t2    := (open_term_wrt_term t1 t2).
Notation openA a t      := (open_args_wrt_term a t).
Notation openL l t      := (open_alist_wrt_term l t).
Notation openC c t      := (open_cont_wrt_term c t).

Notation closeT x t    := (close_term x t).
Notation closeL x l      := (close_term x l).

Notation fvT t          := (fv_term t).
Notation fvA a          := (fv_args a).
Notation fvL l          := (fv_alist l).
Notation fvC c          := (fv_cont c).

Notation lcT t          := (lc_term t).
Notation lcA a          := (lc_gmargs a).
Notation lcL l          := (lc_alist l).
Notation lcC c          := (lc_cont c).

Notation "t ::: l"      := (acons t l) (at level 0, right associativity).

End LambdaJmNotations.

Include LambdaJmNotations.

(*************************************************************************)
(** ** about Substitution                                                *)
(*************************************************************************)

Lemma subst_eq_var: forall (x : var) u,
  [x ~> u](var_f x) = u.
Proof.
  intros x u. simpl. destruct (x==x) as [H1 | H1].
  - reflexivity.
  - apply False_ind. apply H1. exact (eq_refl x).
Qed.

Lemma subst_neq_var : forall (x y : var) u,
  y <> x -> [x ~> u](var_f y) = var_f y.
Proof.
  intros x y u H. simpl. destruct (y==x) as [H1|H1].
  - contradiction.
  - reflexivity.
Qed.

Lemma subst_same : forall y,
    (forall e, (subst_term (var_f y) y e) = e) /\
    (forall a, (subst_args (var_f y) y a) = a) /\
    (forall l, (subst_alist (var_f y) y l) = l) /\
    (forall c, (subst_cont (var_f y) y c) = c).
Proof.
  intros.
  apply (term_gmargs_alist_cont_mutind
        (fun e => (subst_term (var_f y) y e) = e)
        (fun a => (subst_args (var_f y) y a) = a)
        (fun l => (subst_alist (var_f y) y l) = l)
        (fun c => (subst_cont (var_f y) y c) = c)).
  - reflexivity.
  - simpl. intros. destruct (x==y) as [H | H].
    + rewrite <- H. reflexivity.
    + auto.
  - intros. simpl. rewrite -> H. reflexivity.
  - intros. simpl. rewrite -> H. rewrite -> H0. reflexivity.
  - intros. simpl. rewrite -> H, H0, H1. reflexivity.
  - reflexivity.
  - intros. simpl. rewrite -> H, H0. reflexivity.
  - intros. simpl. rewrite -> H. reflexivity.
Qed.

Lemma subst_term_same : forall y e, [y ~> var_f y] e = e.
Proof.  apply subst_same. Qed.

Lemma subst_args_same : forall y a, substA (var_f y) y a = a.
Proof. apply subst_same. Qed.

Lemma subst_alist_same : forall y l, substL (var_f y) y l = l.
Proof.  apply subst_same. Qed.

Lemma subst_cont_same : forall y c, substC (var_f y) y c = c.
Proof.  apply subst_same. Qed.

(*************************************************************************)
(** ** about Free variables                                              *)
(*************************************************************************)

(** The function [fv_exp] calculates the set of free variables in an
    expression.  This function returns a value of type `atoms` --- a finite
    set of variable names.  *)

(** Demo [fsetdec]

   The tactic [fsetdec] solves a certain class of propositions
   involving finite sets. See the documentation in [FSetWeakDecide]
   for a full specification.
*)

Lemma fsetdec_demo : forall (x : atom) (S : atoms),
  x `in` (singleton x `union` S).
Proof.
  fsetdec.
Qed.

(** ***
    To show the ease of reasoning with these definitions, we will prove a
    standard result from lambda calculus: if a variable does not appear free
    in a term, then substituting for it has no effect.

    HINTS: Prove this lemma by induction on the terms.

    - You will need to use [simpl] in many cases.  You can [simpl] everything
      everywhere (including hypotheses) with the pattern [simpl in *].

    - Part of this proof includes a false assumption about free variables.
      Destructing this hypothesis produces a goal about finite set membership
      that is solvable by [fsetdec].

    - The [f_equal] tactic converts a goal of the form [f e1 = f e1'] in to
      one of the form [e1 = e1'], and similarly for [f e1 e2 = f e1' e2'],
      etc.  *)

Lemma subst_fresh_eq : forall (x : var),
    (forall e u, x `notin` fv_term e -> (subst_term u x e) = e) /\
    (forall a u, x `notin` fv_args a -> (subst_args u x a) = a) /\
    (forall l u, x `notin` fv_alist l -> (subst_alist u x l) = l) /\
    (forall c u, x `notin` fv_cont c -> (subst_cont u x c) = c).
Proof.
  intros.
  apply (term_gmargs_alist_cont_mutind
        (fun e => (forall u, x `notin` fv_term e -> (subst_term u x e) = e))
        (fun a => (forall u, x `notin` fv_args a -> (subst_args u x a) = a))
        (fun l => (forall u, x `notin` fv_alist l -> (subst_alist u x l) = l))
        (fun c => (forall u, x `notin` fv_cont c -> (subst_cont u x c) = c)));
    intros; simpl in *.
  - reflexivity.
  - destruct (x0==x) as [H1|H1].
    + destruct H. auto.
    + reflexivity.
  - apply (H u) in H0. f_equal. assumption. (*rewrite -> H0. reflexivity.*)
  - assert (H': (x `notin` (fv_term t)) /\ (x `notin` (fv_args a))).
    + fsetdec.
    + destruct H'. apply (H u) in H2. apply (H0 u) in H3. f_equal; assumption.
  - assert (H': (x `notin` fv_term u) /\ (x `notin` fv_alist l) /\ (x `notin` fv_cont c)).
    + fsetdec.
    + destruct H'. destruct H4.
      apply (H u0) in H3. apply (H0 u0) in H4. apply (H1 u0) in H5.
      f_equal; assumption.
  - reflexivity.
  - assert (H': (x `notin` (fv_term t)) /\ (x `notin` (fv_alist l))).
    + fsetdec.
    + destruct H'. apply (H u) in H2. apply (H0 u) in H3. f_equal; assumption.
  - apply (H u) in H0. f_equal; assumption.
Qed.

Lemma subst_term_fresh_eq : forall x e u,  x `notin` fvT e -> [x ~> u] e = e.
Proof. apply subst_fresh_eq. Qed.

Lemma subst_args_fresh_eq : forall x a u,  x `notin` fvA a -> substA u x a = a.
Proof. apply subst_fresh_eq. Qed.

Lemma subst_alist_fresh_eq : forall x l u,  x `notin` fvL l -> substL u x l = l.
Proof. apply subst_fresh_eq. Qed.

Lemma subst_cont_fresh_eq : forall x c u,  x `notin` fvC c -> substC u x c = c.
Proof. apply subst_fresh_eq. Qed.

(**
   Step through the proof that free variables are not introduced by substitution.

   This proof actually is very automatable ([simpl in *; auto.] takes care of
   all but the var_f case), but the explicit proof below demonstrates two
   parts of the finite set library. These two parts are the tactic
   [destruct_notin] and the lemma [notin_union], both defined in the module
   [FSetWeakNotin].

   Before stepping through this proof, you should go to that module to read
   about those definitions and see what other finite set reasoning is
   available.

 *)

Lemma fv_subst_term_notin : forall x y u,
   (forall e, x `notin` fv_term e -> x `notin` fv_term u ->
                x `notin` fv_term (subst_term u y e)) /\
   (forall a, x `notin` fv_args a -> x `notin` fv_term u ->
                x `notin` fv_args (subst_args u y a)) /\
   (forall l, x `notin` fv_alist l -> x `notin` fv_term u ->
                x `notin` fv_alist (subst_alist u y l)) /\
   (forall c, x `notin` fv_cont c -> x `notin` fv_term u ->
                x `notin` fv_cont (subst_cont u y c)).
Proof.
  intros.
  apply (term_gmargs_alist_cont_mutind
           (fun e => x `notin` fv_term e -> x `notin` fv_term u ->
                                x `notin` fv_term (subst_term u y e))
           (fun a => x `notin` fv_args a -> x `notin` fv_term u ->
                                x `notin` fv_args (subst_args u y a))
           (fun l => x `notin` fv_alist l -> x `notin` fv_term u ->
                                x `notin` fv_alist (subst_alist u y l))
           (fun c => x `notin` fv_cont c -> x `notin` fv_term u ->
                                x `notin` fv_cont (subst_cont u y c)));
    intros; simpl in *.
  - Case "var_b".
    assumption.
  - Case "var_f".
    destruct (x0 == y).
    + assumption.
    + simpl. assumption.
  - Case "abs".
    auto.
  - Case "app".
    destruct_notin. auto.
  - Case "args".
    destruct_notin. auto.
  - Case "anil".
    assumption.
  - Case "acons".
    destruct_notin. auto.
  - Case "cabs".
    destruct_notin. auto.
Qed.

Lemma fv_term_subst_term_notin : forall x y u t,
    x `notin` fvT t -> x `notin` fvT u -> x `notin` fvT (subst_term u y t).
Proof. apply fv_subst_term_notin. Qed.

Lemma fv_args_subst_term_notin : forall x y u a,
    x `notin` fvA a -> x `notin` fvT u -> x `notin` fvA (substA u y a).
Proof. apply fv_subst_term_notin. Qed.

Lemma fv_alist_subst_term_notin : forall x y u l,
    x `notin` fvL l -> x `notin` fvT u -> x `notin` fvL (substL u y l).
Proof. apply fv_subst_term_notin. Qed.

Lemma fv_cont_subst_term_notin : forall x y u c,
    x `notin` fvC c -> x `notin` fvT u -> x `notin` fvC (substC u y c).
Proof. apply fv_subst_term_notin. Qed.

Lemma subst_fresh_same : forall u x,
    (forall e, x `notin` fv_term e ->  x `notin` fv_term (subst_term u x e)) /\
    (forall a, x `notin` fv_args a ->  x `notin` fv_args (subst_args u x a)) /\
    (forall l, x `notin` fv_alist l -> x `notin` fv_alist (subst_alist u x l)) /\
    (forall c, x `notin` fv_cont c ->  x `notin` fv_cont (subst_cont u x c)).
Proof.
  intros.
  apply (term_gmargs_alist_cont_mutind
           (fun e => x `notin` fv_term e ->  x `notin` fv_term (subst_term u x e))
           (fun a => x `notin` fv_args a ->  x `notin` fv_args (subst_args u x a))
           (fun l => x `notin` fv_alist l -> x `notin` fv_alist (subst_alist u x l))
           (fun c => x `notin` fv_cont c ->  x `notin` fv_cont (subst_cont u x c)));
    intros; simpl in *; auto.
  destruct (x0 == x).
  - destruct_notin. contradiction.
  - simpl. assumption.
Qed.

Lemma subst_term_fresh_same : forall u x t,  x `notin` fvT t ->
                                        x `notin` fvT (subst_term u x t).
Proof. apply subst_fresh_same. Qed.

Lemma subst_args_fresh_same : forall u x a,  x `notin` fvA a ->
                                        x `notin` fvA (substA u x a).
Proof. apply subst_fresh_same. Qed.

Lemma subst_alist_fresh_same : forall u x l,  x `notin` fvL l ->
                                         x `notin` fvL (substL u x l).
Proof. apply subst_fresh_same. Qed.

Lemma subst_cont_fresh_same : forall u x c,  x `notin` fvC c ->
                                        x `notin` fvC (substC u x c).
Proof. apply subst_fresh_same. Qed.

Lemma fv_subst_term_fresh : forall x u,
    (forall e, x `notin` fv_term e -> fv_term (subst_term u x e) [=] fv_term e) /\
    (forall a, x `notin` fv_args a -> fv_args (subst_args u x a) [=] fv_args a) /\
    (forall l, x `notin` fv_alist l -> fv_alist (subst_alist u x l) [=] fv_alist l) /\
    (forall c, x `notin` fv_cont c -> fv_cont (subst_cont u x c) [=] fv_cont c).
Proof.
  intros.
  apply (term_gmargs_alist_cont_mutind
    (fun e => x `notin` fv_term e -> fv_term (subst_term u x e) [=] fv_term e)
    (fun a => x `notin` fv_args a -> fv_args (subst_args u x a) [=] fv_args a)
    (fun l => x `notin` fv_alist l -> fv_alist (subst_alist u x l) [=] fv_alist l)
    (fun c => x `notin` fv_cont c -> fv_cont (subst_cont u x c) [=] fv_cont c));
    intros; simpl in *; auto.
  - reflexivity.
  - destruct (x0==x).
    + destruct_notin. contradiction.
    + simpl. reflexivity.
  - destruct_notin. apply H in H1. apply H0 in NotInTac.
    rewrite -> H1, NotInTac. reflexivity.
  - destruct_notin. apply H in H2. apply H0 in NotInTac. apply H1 in NotInTac0.
    rewrite -> H2, NotInTac, NotInTac0. reflexivity.
  - reflexivity.
  - destruct_notin. apply H in H1. apply H0 in NotInTac.
    rewrite -> H1, NotInTac. reflexivity.
Qed.

Lemma fv_term_subst_term_fresh : forall x u t,  x `notin` fvT t ->
                                           fvT (subst_term u x t) [=] fvT t.
Proof. apply fv_subst_term_fresh. Qed.

Lemma fv_args_subst_term_fresh : forall x u a,  x `notin` fvA a ->
                                           fvA (substA u x a) [=] fvA a.
Proof. apply fv_subst_term_fresh. Qed.

Lemma fv_alist_subst_term_fresh : forall x u l,  x `notin` fvL l ->
                                            fvL (substL u x l) [=] fvL l.
Proof. apply fv_subst_term_fresh. Qed.

Lemma fv_cont_subst_term_fresh : forall x u c,   x `notin` fvC c ->
                                            fvC (substC u x c) [=] fvC c.
Proof. apply fv_subst_term_fresh. Qed.

Lemma fv_subst_exp_upper : forall x u,
    (forall t, fv_term (subst_term u x t) [<=] fv_term u `union` remove x (fv_term t)) /\
    (forall a, fv_args (subst_args u x a) [<=] fv_term u `union` remove x (fv_args a)) /\
    (forall l, fv_alist (subst_alist u x l) [<=] fv_term u `union` remove x (fv_alist l)) /\
    (forall c, fv_cont (subst_cont u x c) [<=] fv_term u `union` remove x (fv_cont c)).
Proof.
  intros.
  apply (term_gmargs_alist_cont_mutind
    (fun t => fv_term (subst_term u x t) [<=] fv_term u `union` remove x (fv_term t))
    (fun a => fv_args (subst_args u x a) [<=] fv_term u `union` remove x (fv_args a))
    (fun l => fv_alist (subst_alist u x l) [<=] fv_term u `union` remove x (fv_alist l))
    (fun c => fv_cont (subst_cont u x c) [<=] fv_term u `union` remove x (fv_cont c)));
    intros; simpl in *; auto.
  - fsetdec.
  - destruct (x0==x).
    + fsetdec.
    + simpl. fsetdec.
  - fsetdec.
  - fsetdec.
  - fsetdec.
  - fsetdec.
Qed.

Lemma fv_term_subst_term_upper : forall x u t,
    fvT (substT u x t) [<=] fvT u `union` remove x (fvT t).
Proof. apply fv_subst_exp_upper. Qed.

Lemma fv_args_subst_args_upper : forall x u a,
    fvA (substA u x a) [<=] fvT u `union` remove x (fvA a).
Proof. apply fv_subst_exp_upper. Qed.

Lemma fv_alist_subst_alist_upper : forall x u l,
    fvL (substL u x l) [<=] fvT u `union` remove x (fvL l).
Proof. apply fv_subst_exp_upper. Qed.

Lemma fv_cont_subst_cont_upper : forall x u c,
    fvC (substC u x c) [<=] fvT u `union` remove x (fvC c).
Proof. apply fv_subst_exp_upper. Qed.

Lemma subst_open_wrt_term : forall u v x,  lcT u ->
  (forall e, substT u x (openT e v) = openT (substT u x e) (substT u x v)) /\
  (forall a, substA u x (openA a v) = openA (substA u x a) (substT u x v)) /\
  (forall l, substL u x (openL l v) = openL (substL u x l) (substT u x v)) /\
  (forall c, substC u x (openC c v) = openC (substC u x c) (substT u x v)) .
Proof.
  intros u v x H.
  apply (term_gmargs_alist_cont_mutind
         (fun e => substT u x (openT e v) = openT (substT u x e) (substT u x v))
         (fun a => substA u x (openA a v) = openA (substA u x a) (substT u x v))
         (fun l => substL u x (openL l v) = openL (substL u x l) (substT u x v))
         (fun c => substC u x (openC c v) = openC (substC u x c) (substT u x v)));
    intros; simpl in *; auto.

     (* Require Export Metalib.LibDefaultSimp. *)
     (* unfold open_exp_wrt_exp; default_simp. *)
(* unfold open_term_wrt_term; default_step. *)

  - destruct n.
    + reflexivity.
    + reflexivity.
  - destruct (x0==x).
    + admit.
    + reflexivity.

Admitted.

Lemma subst_term_open_term_wrt_term : forall t e1 e2 x1,
    lcT e1 ->
    [x1 ~> e1] (openT t e2) = openT ([x1 ~> e1] t) ([x1 ~> e1] e2).
Proof.
  intros. apply (subst_open_wrt_term e1 e2 x1) in H.  apply H.
Qed.

Lemma subst_args_open_args_wrt_term :  forall a e1 e2 x1,
    lcT e1 ->
    substA e1 x1 (openA a e2) = openA (substA e1 x1 a) ([x1 ~> e1] e2).
Proof.
  intros. apply (subst_open_wrt_term e1 e2 x1) in H. apply H.
Qed.

Lemma subst_alist_open_alist_wrt_term :  forall l e1 e2 x1,
    lcT e1 ->
    substL e1 x1 (openL l e2) = openL (substL e1 x1 l) ([x1 ~> e1] e2).
Proof.
  intros. apply (subst_open_wrt_term e1 e2 x1) in H. apply H.
Qed.

Lemma subst_cont_open_cont_wrt_term :  forall c e1 e2 x1,
    lcT e1 ->
    substC e1 x1 (openC c e2) = openC (substC e1 x1 c) ([x1 ~> e1] e2).
Proof.
  intros. apply (subst_open_wrt_term e1 e2 x1) in H. apply H.
Qed.

(** The lemma above is most often used with [e2] as some fresh
    variable. Therefore, it simplifies matters to define the following useful
    corollary.

    HINT: Do not use induction.  Rewrite with [subst_term_open_term_wrt_term] and
    [subst_neq_var].
*)

Lemma subst_term_var : forall x y u e,   y <> x -> lcT u ->
                                    ([x ~> u] e) ^ y = [x ~> u] (e ^ y).
Proof.
  intros. rewrite (subst_term_open_term_wrt_term e u (var_f y) x H0).
  apply (subst_neq_var x y u) in H. rewrite H. reflexivity.
Qed.

Lemma subst_args_var : forall (x y : var) u a,  y <> x -> lcT u ->
    openA (substA u x a) (var_f y) =  substA u x (openA a (var_f y)).
Proof.
  intros. rewrite (subst_args_open_args_wrt_term a u (var_f y) x H0).
  apply (subst_neq_var x y u) in H. rewrite H. reflexivity.
Qed.

Lemma subst_alist_var : forall (x y : var) u l,  y <> x -> lcT u ->
    openL (substL u x l) (var_f y) = substL u x (openL l (var_f y)).
Proof.
  intros. rewrite (subst_alist_open_alist_wrt_term l u (var_f y) x H0).
  apply (subst_neq_var x y u) in H. rewrite H. reflexivity.
Qed.

Lemma subst_cont_var : forall (x y : var) u c,  y <> x -> lcT u ->
    openC (substC u x c) (var_f y) = substC u x (openC c (var_f y)).
Proof.
  intros. rewrite (subst_cont_open_cont_wrt_term c u (var_f y) x H0).
  apply (subst_neq_var x y u) in H. rewrite H. reflexivity.
Qed.

(** This next lemma states that opening can be replaced with variable
    opening and substitution.

    This lemma, like many about [open_???_wrt_???], should be proven
    via induction on the term [e]. However, during this induction, the
    binding depth of the term changes, so to make sure that we have
    a flexible enough induction hypothesis, we must generalize the
    argument to [open_???_wrt_???_rec].  *)

Lemma subst_intro : forall (x : var) u,
    (forall e, x `notin` (fvT e) -> openT e u = substT u x (openT e (var_f x))) /\
    (forall a, x `notin` (fvA a) -> openA a u = substA u x (openA a (var_f x))) /\
    (forall l, x `notin` (fvL l) -> openL l u = substL u x (openL l (var_f x))) /\
    (forall c, x `notin` (fvC c) -> openC c u = substC u x (openC c (var_f x))).
Proof.
  intros x u; split;[ |split];[ | |split];
    [ intros e FV; unfold openT |
      intros a FV; unfold openA |
      intros l FV; unfold openL |
      intros c FV; unfold openC ];
    generalize 0.
 (* NOTE: The proofs of the 4 subgoals are equal.
          A better proof script should be possible. *)
  - (* terms *)
    apply (term_gmargs_alist_cont_mutind
    (fun e => x `notin` fvT e -> forall n, open_term_wrt_term_rec n u e =
                                  subst_term u x (open_term_wrt_term_rec n (var_f x) e))
    (fun a => x `notin` fvA a -> forall n, open_args_wrt_term_rec n u a =
                                  subst_args u x (open_args_wrt_term_rec n (var_f x) a))
    (fun l => x `notin` fvL l -> forall n, open_alist_wrt_term_rec n u l =
                                  subst_alist u x (open_alist_wrt_term_rec n (var_f x) l))
    (fun c => x `notin` fvC c -> forall n, open_cont_wrt_term_rec n u c =
                                  subst_cont u x (open_cont_wrt_term_rec n (var_f x) c)));
    intros; simpl.

    + destruct (lt_eq_lt_dec n n0).
      * destruct s.
        -- reflexivity.
        -- simpl. destruct (x==x).
           ++ reflexivity.
           ++ destruct n1.  reflexivity.
      * reflexivity.
    + simpl in H. destruct_notin. destruct (x0==x).
      * contradiction.
      * reflexivity.
    + f_equal. apply H. assumption.
    + simpl in H1. destruct_notin. f_equal.
      * apply H. assumption.
      * apply H0. assumption.
    + f_equal.
      * apply H. simpl in H2. destruct_notin. assumption.
      * apply H0. simpl in H2. destruct_notin. assumption.
      * apply H1. simpl in H2. destruct_notin. assumption.
    + reflexivity.
    + f_equal.
      * apply H. simpl in H1. destruct_notin. assumption.
      * apply H0. simpl in H1. destruct_notin. assumption.
    + f_equal. apply H. simpl in H0. assumption.
    + assumption.

  - (* gmargs *)
    apply (term_gmargs_alist_cont_mutind
    (fun e => x `notin` fvT e -> forall n, open_term_wrt_term_rec n u e =
                                  subst_term u x (open_term_wrt_term_rec n (var_f x) e))
    (fun a => x `notin` fvA a -> forall n, open_args_wrt_term_rec n u a =
                                  subst_args u x (open_args_wrt_term_rec n (var_f x) a))
    (fun l => x `notin` fvL l -> forall n, open_alist_wrt_term_rec n u l =
                                  subst_alist u x (open_alist_wrt_term_rec n (var_f x) l))
    (fun c => x `notin` fvC c -> forall n, open_cont_wrt_term_rec n u c =
                                  subst_cont u x (open_cont_wrt_term_rec n (var_f x) c)));
      intros; simpl.
    destruct (lt_eq_lt_dec n n0).
    + destruct s.
      * reflexivity.
      * simpl. destruct (x==x).
        -- reflexivity.
        -- destruct n1.  reflexivity.
    + reflexivity.
    + simpl in H. destruct_notin. destruct (x0==x).
      * contradiction.
      * reflexivity.
    + f_equal; apply H; simpl in H0; assumption.
    + f_equal; [apply H | apply H0]; simpl in H1; destruct_notin; assumption.
    + f_equal; [apply H | apply H0 |apply H1]; simpl in H2; destruct_notin; assumption.
    + reflexivity.
    + f_equal; [apply H | apply H0]; simpl in H1; destruct_notin; assumption.
    + f_equal; apply H; simpl in H0; assumption.
    + assumption.

  - (* alist *)
    apply (term_gmargs_alist_cont_mutind
    (fun e => x `notin` fv_term e -> forall n, open_term_wrt_term_rec n u e =
                                      subst_term u x (open_term_wrt_term_rec n (var_f x) e))
    (fun a => x `notin` fv_args a -> forall n, open_args_wrt_term_rec n u a =
                                      subst_args u x (open_args_wrt_term_rec n (var_f x) a))
    (fun l => x `notin` fv_alist l -> forall n, open_alist_wrt_term_rec n u l =
                                       subst_alist u x (open_alist_wrt_term_rec n (var_f x) l))
    (fun c => x `notin` fv_cont c -> forall n, open_cont_wrt_term_rec n u c =
                                      subst_cont u x (open_cont_wrt_term_rec n (var_f x) c)));
      intros; simpl.
    destruct (lt_eq_lt_dec n n0).
    + destruct s.
      * reflexivity.
      * simpl. destruct (x==x).
        -- reflexivity.
        -- destruct n1.  reflexivity.
    + reflexivity.
    + simpl in H. destruct_notin. destruct (x0==x).
      * contradiction.
      * reflexivity.
    + f_equal; apply H; simpl in H0; assumption.
    + f_equal; [apply H | apply H0]; simpl in H1; destruct_notin; assumption.
    + f_equal; [apply H | apply H0 |apply H1]; simpl in H2; destruct_notin; assumption.
    + reflexivity.
    + f_equal; [apply H | apply H0]; simpl in H1; destruct_notin; assumption.
    + f_equal; apply H; simpl in H0; assumption.
    + assumption.

  - (* cont *)
    apply (term_gmargs_alist_cont_mutind
    (fun e => x `notin` fv_term e -> forall n, open_term_wrt_term_rec n u e =
                                      subst_term u x (open_term_wrt_term_rec n (var_f x) e))
    (fun a => x `notin` fv_args a -> forall n, open_args_wrt_term_rec n u a =
                                      subst_args u x (open_args_wrt_term_rec n (var_f x) a))
    (fun l => x `notin` fv_alist l -> forall n, open_alist_wrt_term_rec n u l =
                                       subst_alist u x (open_alist_wrt_term_rec n (var_f x) l))
    (fun c => x `notin` fv_cont c -> forall n, open_cont_wrt_term_rec n u c =
                                      subst_cont u x (open_cont_wrt_term_rec n (var_f x) c)));
      intros; simpl.
    destruct (lt_eq_lt_dec n n0).
    + destruct s.
      * reflexivity.
      * simpl. destruct (x==x).
        -- reflexivity.
        -- destruct n1.  reflexivity.
    + reflexivity.
    + simpl in H. destruct_notin. destruct (x0==x).
      * contradiction.
      * reflexivity.
    + f_equal; apply H; simpl in H0; assumption.
    + f_equal; [apply H | apply H0]; simpl in H1; destruct_notin; assumption.
    + f_equal; [apply H | apply H0 |apply H1]; simpl in H2; destruct_notin; assumption.
    + reflexivity.
    + f_equal; [apply H | apply H0]; simpl in H1; destruct_notin; assumption.
    + f_equal; apply H; simpl in H0; assumption.
    + assumption.
Qed.

Lemma subst_term_intro : forall x u t,  x `notin` (fvT t) ->
                                   openT t u = subst_term u x (openT t (var_f x)).
Proof. apply subst_intro. Qed.

Lemma subst_args_intro : forall x u a,  x `notin` (fvA a) ->
                                   openA a u = substA u x (openA a (var_f x)).
Proof. apply subst_intro. Qed.

Lemma subst_alist_intro : forall x u l,  x `notin` (fvL l) ->
                                    openL l u = substL u x (openL l (var_f x)).
Proof. apply subst_intro. Qed.

Lemma subst_cont_intro : forall x u c,  x `notin` (fvC c) ->
                                   openC c u = substC u x (openC c (var_f x)).
Proof. apply subst_intro. Qed.

(** NLemmas about the free variables of an opened term.

    The structure of this proof follows that of the proof above. We
    prove this by induction on the term [e1], after appropriately
    generalizing the induction hypothesis. We use [fsetdec] for
    reasoning about properties of atom sets. Note that we can
    [rewrite] with atom set inequalities in the hypotheses list. *)

Lemma fv_open_wrt_term_upper :  forall u,
    (forall e, fvT (openT e u) [<=] fvT e `union` fvT u) /\
    (forall a, fvA (openA a u) [<=] fvA a `union` fvT u) /\
    (forall l, fvL (openL l u) [<=] fvL l `union` fvT u) /\
    (forall c, fvC (openC c u) [<=] fvC c `union` fvT u) .
Proof.
  intros u; split;[ |split];[ | |split];
    [ intros e; unfold openT |
      intros a; unfold openA |
      intros l; unfold openL |
      intros c; unfold openC ];
    generalize 0.
(* NOTE: The proofs of the 4 subgoals are equal.
         A better proof script should be possible. *)

  - (* terms *)
    apply (term_gmargs_alist_cont_mutind
             (fun e => forall n, fvT (open_term_wrt_term_rec n u e) [<=] fvT e `union` fvT u)
             (fun a => forall n, fvA (open_args_wrt_term_rec n u a) [<=] fvA a `union` fvT u)
             (fun l => forall n, fvL (open_alist_wrt_term_rec n u l) [<=] fvL l `union` fvT u)
             (fun c => forall n, fvC (open_cont_wrt_term_rec n u c) [<=] fvC c `union` fvT u));
      intros; simpl.
    + destruct (lt_eq_lt_dec n n0).
      * destruct s.
        -- simpl. fsetdec.
        -- fsetdec.
      * simpl. fsetdec.
    + fsetdec.
    + apply H.
    + rewrite H. rewrite H0. fsetdec.
    + rewrite H. rewrite H0. rewrite H1. fsetdec.
    + fsetdec.
    + rewrite H. rewrite H0. fsetdec.
    + rewrite H. fsetdec.

  - (* args *)
    apply (term_gmargs_alist_cont_mutind
             (fun e => forall n, fvT (open_term_wrt_term_rec n u e) [<=] fvT e `union` fvT u)
             (fun a => forall n, fvA (open_args_wrt_term_rec n u a) [<=] fvA a `union` fvT u)
             (fun l => forall n, fvL (open_alist_wrt_term_rec n u l) [<=] fvL l `union` fvT u)
             (fun c => forall n, fvC (open_cont_wrt_term_rec n u c) [<=] fvC c `union` fvT u));
      intros; simpl.
    + destruct (lt_eq_lt_dec n n0).
      * destruct s.
        -- simpl; fsetdec.
        -- fsetdec.
      * simpl; fsetdec.
    + fsetdec.
    + apply H.
    + rewrite H, H0; fsetdec.
    + rewrite H, H0, H1; fsetdec.
    + fsetdec.
    + rewrite H, H0; fsetdec.
    + rewrite H; fsetdec.

  - (* alist *)
    apply (term_gmargs_alist_cont_mutind
             (fun e => forall n, fvT (open_term_wrt_term_rec n u e) [<=] fvT e `union` fvT u)
             (fun a => forall n, fvA (open_args_wrt_term_rec n u a) [<=] fvA a `union` fvT u)
             (fun l => forall n, fvL (open_alist_wrt_term_rec n u l) [<=] fvL l `union` fvT u)
             (fun c => forall n, fvC (open_cont_wrt_term_rec n u c) [<=] fvC c `union` fvT u));
      intros; simpl.
    + destruct (lt_eq_lt_dec n n0).
      * destruct s.
        -- simpl; fsetdec.
        -- fsetdec.
      * simpl; fsetdec.
    + fsetdec.
    + apply H.
    + rewrite H, H0; fsetdec.
    + rewrite H, H0, H1; fsetdec.
    + fsetdec.
    + rewrite H, H0; fsetdec.
    + rewrite H; fsetdec.

  - (* cont *)
    apply (term_gmargs_alist_cont_mutind
             (fun e => forall n, fvT (open_term_wrt_term_rec n u e) [<=] fvT e `union` fvT u)
             (fun a => forall n, fvA (open_args_wrt_term_rec n u a) [<=] fvA a `union` fvT u)
             (fun l => forall n, fvL (open_alist_wrt_term_rec n u l) [<=] fvL l `union` fvT u)
             (fun c => forall n, fvC (open_cont_wrt_term_rec n u c) [<=] fvC c `union` fvT u));
      intros; simpl.
    + destruct (lt_eq_lt_dec n n0).
      * destruct s.
        -- simpl; fsetdec.
        -- fsetdec.
      * simpl; fsetdec.
    + fsetdec.
    + apply H.
    + rewrite H, H0; fsetdec.
    + rewrite H, H0, H1; fsetdec.
    + fsetdec.
    + rewrite H, H0; fsetdec.
    + rewrite H; fsetdec.
Qed.

Lemma fv_term_open_term_wrt_term_upper : forall u e,
    fvT (openT e u) [<=] fvT e `union` fvT u.
Proof.
  intro u. apply fv_open_wrt_term_upper.
Qed.

Lemma fv_args_open_args_wrt_term_upper : forall u a,
    fvA  (openA a u) [<=] fvA a `union` fvT u.
Proof.
  intro u. apply fv_open_wrt_term_upper.
Qed.

Lemma fv_alist_open_alist_wrt_term_upper : forall u l,
    fvL (openL l u) [<=] fvL l `union` fvT u.
Proof.
  intro u. apply fv_open_wrt_term_upper.
Qed.

Lemma fv_cont_open_cont_wrt_term_upper : forall u c,
    fvC (openC c u) [<=] fvC c `union` fvT u.
Proof.
  intro u. apply fv_open_wrt_term_upper.
Qed.

(*************************************************************************)
(** ** Forall quantification in [lc_???].                                *)
(*************************************************************************)

Lemma lc_abs_exists : forall (x : var) t,  lcT (t ^ x) -> lcT (abs t).
Admitted.

Lemma lc_cabs_exists : forall (x : var) v,  lcT (v ^ x) -> lcC (cabs v).
Admitted.

Lemma subst_lc : forall (x : var) u,
    (forall e, lc_term e -> lc_term u -> lc_term (subst_term u x e)) /\
    (forall a, lc_gmargs a -> lc_term u -> lc_gmargs (subst_args u x a)) /\
    (forall l, lc_alist l -> lc_term u -> lc_alist (subst_alist u x l)) /\
    (forall c, lc_cont c -> lc_term u -> lc_cont (subst_cont u x c)).
Proof.
  intros x u; split; [ |split];[ | |split].

  - (* terms *)
    apply (lc_mutind
             (fun e (_:lc_term e) => lc_term u -> lc_term (subst_term u x e))
             (fun a (_:lc_gmargs a) => lc_term u -> lc_gmargs (subst_args u x a))
             (fun l (_:lc_alist l) => lc_term u -> lc_alist (subst_alist u x l))
             (fun c (_:lc_cont c) => lc_term u -> lc_cont (subst_cont u x c))).
    + intros. simpl. destruct (x0==x); auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.  (* a tactic to generate x0 <> x *)
      apply (lc_abs_exists x0).
      rewrite subst_term_var.
      * apply H. assumption.
      * destruct_notin. auto.
      * assumption.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor.
    + simpl. intros. constructor; auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.
      apply (lc_cabs_exists x0).
      rewrite subst_term_var; auto.

  - (* gmargs *)
    apply (lc_mutind
             (fun e (_:lc_term e) => lc_term u -> lc_term (subst_term u x e))
             (fun a (_:lc_gmargs a) => lc_term u -> lc_gmargs (subst_args u x a))
             (fun l (_:lc_alist l) => lc_term u -> lc_alist (subst_alist u x l))
             (fun c (_:lc_cont c) => lc_term u -> lc_cont (subst_cont u x c))).
    + intros. simpl. destruct (x0==x); auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.
      apply (lc_abs_exists x0).
      rewrite subst_term_var; auto.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor.
    + simpl. intros. constructor; auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.
      apply (lc_cabs_exists x0).
      rewrite subst_term_var; auto.

  - (* alist *)
    apply (lc_mutind
             (fun e (_:lc_term e) => lc_term u -> lc_term (subst_term u x e))
             (fun a (_:lc_gmargs a) => lc_term u -> lc_gmargs (subst_args u x a))
             (fun l (_:lc_alist l) => lc_term u -> lc_alist (subst_alist u x l))
             (fun c (_:lc_cont c) => lc_term u -> lc_cont (subst_cont u x c))).
    + intros. simpl. destruct (x0==x); auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.
      apply (lc_abs_exists x0).
      rewrite subst_term_var; auto.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor.
    + simpl. intros. constructor; auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.
      apply (lc_cabs_exists x0).
      rewrite subst_term_var; auto.

  - (* cont *)
    apply (lc_mutind
             (fun e (_:lc_term e) => lc_term u -> lc_term (subst_term u x e))
             (fun a (_:lc_gmargs a) => lc_term u -> lc_gmargs (subst_args u x a))
             (fun l (_:lc_alist l) => lc_term u -> lc_alist (subst_alist u x l))
             (fun c (_:lc_cont c) => lc_term u -> lc_cont (subst_cont u x c))).
    + intros. simpl. destruct (x0==x); auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.
      apply (lc_abs_exists x0).
      rewrite subst_term_var; auto.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor; auto.
    + simpl. intros. constructor.
    + simpl. intros. constructor; auto.
    + simpl. intros.
      pick fresh x0 for {{x}}.
      apply (lc_cabs_exists x0).
      rewrite subst_term_var; auto.
Qed.

Lemma subst_lc_term : forall x u e,  lcT e -> lcT u -> lcT (subst_term u x e).
Proof. apply subst_lc. Qed.

Lemma subst_lc_args : forall x u a,  lc_gmargs a -> lcT u -> lcA (substA u x a).
Proof. apply subst_lc. Qed.

Lemma subst_lc_alist : forall x u l,  lcL l -> lcT u -> lcL (substL u x l).
Proof. apply subst_lc. Qed.

Lemma subst_lc_cont : forall x u c,  lcC c -> lcT u -> lcC (substC u x c).
Proof. apply subst_lc. Qed.

(*************************************************************************)
(** ** Local closure and relations                                       *)
(*************************************************************************)

(** All of our semantics only hold for locally closed terms, and we can
    prove that.
*)

(* Lemma open_app : forall u t a, openT (app t a) u = app (openT t u) (openA a u). *)
(* Proof. reflexivity. Qed. *)

(* Lemma open_args : forall u t l c, openA (args t l c) u = args (openT t u) (openL l u) (openC c u). *)
(* Proof. reflexivity. Qed. *)

(* Lemma  forall x a, lcA a -> lcA (openA a (var_f x)). *)
(* Proof. *)

(****************************** AQUI *********************************)

(* Lemma lc_open : forall u, lcT u -> *)
(*                      (forall t, lcT t -> lcT (openT t u)) /\ *)
(*                      (forall a, lcA a -> lcA (openA a u)) /\ *)
(*                      (forall l, lcL l -> lcL (openL l u)) /\ *)
(*                      (forall c, lcC c -> lcC (openC c u)) . *)
(* Proof. *)
(*     intros u H; split; [ |split]; [ | |split]; *)
(*     [ intros t; unfold openT | *)
(*       intros a; unfold openA | *)
(*       intros l; unfold openL | *)
(*       intros c; unfold openC ]; generalize 0; intros. *)
(*     apply (lc_mutind (fun t (_:lcT t) => lcT (open_term_wrt_term_rec n u t))  *)
(*                      (fun a (_:lcA a) => lcA (open_args_wrt_term_rec n u a)) *)
(*                      (fun l (_:lcL l) => lcL (open_alist_wrt_term_rec n u l)) *)
(*                      (fun c (_:lcC c) => lcC (open_cont_wrt_term_rec n u c))); *)
(*       intros; simpl; auto. *)
(*     - constructor. intros. unfold openT.  *)
(*       pick fresh x0 for {{x}}. *)
(*       apply (lc_abs_exists x0). *)

(*       pick fresh x0 for {{x}}.  (* a tactic to generate x0 <> x *) *)
(*       apply (lc_abs_exists x0). *)
(*       rewrite subst_term_var. *)

(*     - lc_abs_exists *)
(*       constructor. assumption. *)
(*   - intros. cbn. *)

(* Lemma mu_lc : forall a1 a2, muA a1 a2 -> lcA a1. *)
(* Proof. *)
(*   intros a1 a2 H. destruct H; auto. constructor.  *)
(*   - assumption. *)
(*   - assumption. *)
(*   - constructor. intros. rewrite open_app. constructor. *)
(*     + cbn. auto.  *)
(*     + rewrite open_args. constructor. *)

(*       Eval compute in fun t:term => *)
(*          (openT (app (var_b 0) (args (var_b 0) anil (cabs (var_b 0)))) t).  *)

(*     cbn. constructor. *)
(*     + auto.  *)
(*     + constructor. *)
(*       *  cbn. *)


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import fcf.FCF.
(* RndInList has a useful theorem (qam_count) about counting calls to an oracle. *)
Require Import fcf.RndInList.
Require Import fcf.Tactics.

Section OracleHybrid.

  Variable A B State S_A : Set.
  (* At one point in the proof, we need to know that B is inhabited *)
  Variable b : B.
  Hypothesis eqdb : EqDec B.
  Hypothesis eqdState : EqDec State.
  Hypothesis eqdS_A : EqDec S_A.

  (* Two oracles, which we want to show are indistinguishable *)
  Variable O1 O2 : State -> A -> Comp (B * State).
  Hypothesis O1_wf : forall s a, well_formed_comp (O1 s a).
  Hypothesis O2_wf : forall s a, well_formed_comp (O2 s a).

  (* The "adversary" that attempts to distinguish the oracles using at most q queries. *)
  Variable A0 : Comp (State * S_A).
  Variable A1 : S_A -> OracleComp A B bool.
  Hypothesis A0_wf : well_formed_comp A0.
  Hypothesis A1_wf : forall s_A, well_formed_oc (A1 s_A).
  Variable q : nat.
  Hypothesis A1_qam :
    forall s s_A,
      In (s, s_A) (getSupport A0) ->
      queries_at_most (A1 s_A) q.

  (* This proof will show that G1 and G2 are close *)
  Definition G1 :=
    [s, s_A] <-$2 A0;
    [b, _] <-$2 (A1 s_A) _ _ O1 s;
    ret b.

  Definition G2 :=
    [s, s_A] <-$2 A0;
    [b, _] <-$2 (A1 s_A) _ _ O2 s;
    ret b.

  (* The ith oracle responds to the first (i-1) queries using O1, and the remaining queries using O2. *)
  Definition Oi (i : nat)(s : (State * nat))(a : A) : Comp (B * (State * nat)) :=
    [s_s, s_i] <-2 s;
    let O_c := if (ge_dec s_i i) then O2 else O1 in
    [b, s_s'] <-$2 O_c s_s a;
      ret (b, (s_s', (S s_i))).

  (* The ith game uses the ith oracle.  We will show that G1 is the same as (Gi q) and that G2 is the same as (Gi 0).*)
  Definition Gi i :=
    [s, s_A] <-$2 A0;
    [b, _] <-$2 (A1 s_A) _ _ (Oi i) (s, 0%nat);
    ret b.

  (* We need an assumption that each adjacent pair of games are distant by at most some constant k. *)
  Variable k : Rat.
  Hypothesis Gi_Si_close :
    forall i,
      | Pr[Gi i] - Pr[Gi (S i)] | <= k.

  (* Step 1: show that G1 is the same as (Gi q).  This is actually the most complicated part of this proof. *)

  (* In order to show that G1 is the same as (Gi q), we need an intermediate game that is like G1 except the oracle also keeps track of how many times it was called.  We will use an "identical until bad" proof, in which the "bad" event is that the number of queries is greater than q.  The probability of this event is 0, so we end up with an equivalence. *)
  Definition O1_count (s : (State * nat))(a : A) : Comp (B * (State * nat)) :=
    [s_s, s_i] <-2 s;
    [b, s_s'] <-$2 O1 s_s a;
      ret (b, (s_s', (S s_i))).

  Definition G1_count  :=
    [s, s_A] <-$2 A0;
    [b, s] <-$2 (A1 s_A) _ _ O1_count (s, 0%nat);
    ret (b, if (gt_dec (snd s) q) then true else false).

  (* We also need a game like Gi that exposes the bad event in the same way as G1_count. Then we can show that G1_count and (Gi_count q) are "identical until bad" and the probability of the "bad" event is 0.  *)
  Definition Gi_count i :=
    [s, s_A] <-$2 A0;
    [b, s] <-$2 (A1 s_A) _ _ (Oi i) (s, 0%nat);
    ret (b, if (gt_dec (snd s) q) then true else false).

  Theorem G1_eq_G1_count :
    Pr[G1] == Pr[x <-$ G1_count; ret (fst x)].

    unfold G1, G1_count.
    fcf_inline_first.
    fcf_to_prhl_eq.
    fcf_skip.
    fcf_inline_first.
    fcf_skip.
    eapply (fcf_oracle_eq (fun x y => x = fst y)); trivial; intuition; subst.
    unfold O1_count.
    fcf_simp.
    fcf_ident_expand_l.
    fcf_skip.
    fcf_spec_ret; intuition.

    simpl in *; intuition; subst.
    fcf_simp.
    simpl.
    eapply comp_spec_eq_refl.

  Qed.

  Theorem Gi_eq_Gi_count :
    forall i,
      Pr[Gi i] == Pr[x <-$ Gi_count i; ret (fst x)].

    intuition.
    unfold Gi_count, Gi.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    simpl.
    intuition.
  Qed.

  Theorem O1_count_wf :
    forall a b,
    well_formed_comp (O1_count a b).

    intuition.
    unfold O1_count.
    fcf_well_formed.

  Qed.

  Theorem Oi_wf :
    forall i a b,
      well_formed_comp (Oi i a b).

    intuition.
    unfold Oi.
    fcf_well_formed.
    destruct (ge_dec b0 i); fcf_well_formed.

  Qed.

  (* We will need to know that the count increases by one after each call to O1_count and Oi. *)
  Theorem O1_count_increases :
    forall d1 b1 c1 a2 b2 c2,
      In (d1, (b1, c1)) (getSupport (O1_count (b2, c2) a2)) ->
      c1 = S c2.

    intuition.
    unfold O1_count in *.
    fcf_simp_in_support.
    destruct x.
    fcf_simp_in_support.
    trivial.

  Qed.

  Theorem Oi_count_increases :
    forall i d1 b1 c1 a2 b2 c2,
      In (d1, (b1, c1)) (getSupport (Oi i (b2, c2) a2)) ->
      c1 = S c2.

    intuition.
    unfold Oi in *.
    fcf_simp_in_support.
    destruct x.
    fcf_simp_in_support.
    trivial.

  Qed.

  (* The relational specification on O1_count and (Oi q).  As usual, I arrived at this by attempting some of the theorems below and then factoring out this theorem. *)
  Theorem O1_count_Oi_eq_until_bad :
    forall s s_A,
    comp_spec (fun a b => ((snd (snd a) > q) <-> (snd (snd b) > q)) /\ ((snd (snd a) <= q)%nat -> (fst a = fst b /\ fst (snd a) = fst (snd b))))
              ((A1 s_A) _ _ O1_count (s, 0)%nat)
              ((A1 s_A) _ _ (Oi q) (s, 0)%nat).

    intuition.
    eapply comp_spec_consequence.
    eapply (fcf_oracle_eq_until_bad (fun x => if (gt_dec (snd x) q) then true else false) (fun x => if (gt_dec (snd x) q) then true else false) eq); intuition; subst.
    apply O1_count_wf.
    apply Oi_wf.
    pairInv.

    unfold O1_count, Oi.
    destruct (ge_dec b1 q).
    fcf_irr_l.
    fcf_irr_r.
    fcf_simp.
    fcf_spec_ret;
      simpl in H2;
      destruct (gt_dec (S b1) q);
      try discriminate;
      try omega.

    fcf_skip.
    fcf_spec_ret; intuition.

    apply  O1_count_increases in H0.
    simpl in *.
    fcf_compute.

    apply  Oi_count_increases in H0.
    simpl in *.
    fcf_compute.

    intuition; simpl in *.
    fcf_compute.
    destruct (gt_dec b1 q); trivial.
    destruct (gt_dec (snd (snd b0)) q); intuition; discriminate.

    destruct (gt_dec b1 q).
    omega.
    intuition.

    destruct b0.
    destruct (gt_dec b1 q).
    omega.
    intuition.
    simpl in *.
    subst.
    trivial.

  Qed.

  Theorem G1_eq_Gi_q :
    Pr[G1] == Pr[Gi q].

    (* Use the fundamental lemma, where the "bad" event is that the counter in the oracle gets a value > q.  Then use the qam_count theorem from RndInList to show that the probability of this event is 0.  *)

    rewrite G1_eq_G1_count .
    rewrite Gi_eq_Gi_count.

    eapply ratIdentityIndiscernables.
    eapply leRat_impl_eqRat.
    eapply leRat_trans.
    eapply fundamental_lemma_h.

    (* bad events the same*)
    unfold G1_count, Gi_count.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    fcf_inline_first.
    fcf_to_prhl.
    comp_skip.

    apply O1_count_Oi_eq_until_bad.
    simpl in H1.
    intuition; subst.
    fcf_simp.
    simpl in *.
    fcf_spec_ret; fcf_compute.

    (* equal until bad *)
    intuition.
    unfold G1_count, Gi_count.
    fcf_skip.
    fcf_simp.
    fcf_to_prhl.
    comp_skip.
    eapply O1_count_Oi_eq_until_bad.
    simpl in *; intuition.
    fcf_simp.
    destruct p; simpl in *.
    fcf_spec_ret; fcf_compute;
    assert (b1 <= q)%nat by omega; intuition; subst; pairInv; trivial.

    (* probability of bad event is 0 *)
    unfold G1_count.
    fcf_inline_first.
    fcf_irr_l.
    fcf_simp.
    inline_first.
    fcf_irr_l.
    apply oc_comp_wf; intuition.
    eapply O1_count_wf.

    fcf_simp.
    unfold snd.
    fcf_compute.
    destruct p.
    (* The qam_count theorem takes a function that produces a "count" from the state of the oracle.  This theorem assumes this count increases by at most 1 in each call to the oracle, and that the number of queries is at most q.  Then the result is that the final count is at most q. *)
    eapply (qam_count (A1_qam s s0 _) (fun x => snd x)) in H0.
    simpl in *.
    omega.
    intuition.
    simpl.

    apply O1_count_increases in H1.
    omega.
    trivial.

    eapply rat0_le_all.

    Grab Existential Variables.
    eauto.

  Qed.

  (* Step 2: show that G2 is the same as (Gi 0).  This is much simpler. *)
  Theorem G2_eq_Gi_0 :
    Pr[G2] == Pr[Gi 0%nat].

    unfold G2, Gi.
    fcf_skip.
    fcf_simp.
    fcf_to_prhl_eq.
    comp_skip.
    eapply (fcf_oracle_eq (fun a b => a = fst b)); trivial; intuition; subst.
    unfold Oi.
    comp_simp.
    destruct (ge_dec n 0).
    simpl.
    fcf_ident_expand_l.
    comp_skip.
    eapply comp_spec_ret; intuition.
    omega.

    simpl in  H1.
    intuition; subst.
    comp_simp.
    simpl in *.
    intuition; subst.
    eapply comp_spec_eq_refl.

  Qed.

  (* Step 3: rewrite using the equalities in the previous steps, and then use some arithmetic to show that the distance between G1 and G2 is small. *)
  Theorem G1_G2_close :
    | Pr[G1] - Pr[G2] | <= (q / 1) * k.

    rewrite G1_eq_Gi_q.
    rewrite G2_eq_Gi_0.
    rewrite ratDistance_comm.
    specialize (distance_le_prod_f (fun i => Pr[Gi i])); intuition.

  Qed.

End OracleHybrid.

(* A specialization that uses OracleHybrid to produce a hybrid argument on non-adaptive oracle interactions *)
Require Import fcf.CompFold.
Require Import fcf.OracleCompFold.

(* oracleMap is defined in PRF.  We should probably find a better place for it. *)
Require Import fcf.PRF.

Section OracleMapHybrid.

  Variable A B C State S_A : Set.

  Variable b : B.

  Hypothesis eqdA : EqDec A.
  Hypothesis eqdB : EqDec B.
  Hypothesis eqdState : EqDec State.
  Hypothesis eqdS_A : EqDec S_A.

  Variable A1 : Comp (State * (list A * S_A)).
  Variable A2 : S_A -> list B -> Comp bool.

  Hypothesis A1_wf : well_formed_comp A1.
  Hypothesis A2_wf :
    forall s_A lsb, well_formed_comp (A2 s_A lsb).

  Variable q : nat.
  Variable k : Rat.

  Hypothesis max_queries :
    forall ls s s_A,
      In (s, (ls, s_A)) (getSupport A1) ->
      (length ls <= q)%nat.

  Variable O1 O2 : State -> A -> Comp (B * State).

  Hypothesis O1_wf :
    forall s a,
      well_formed_comp (O1 s a).

  Hypothesis O2_wf :
    forall s a,
      well_formed_comp (O2 s a).

  Definition OMH_G O :=
   [s, p] <-$2 A1;
    [lsa, s_A] <-2 p;
    [lsb, _] <-$2 oracleMap _ _ O s lsa;
    A2 s_A lsb.

  Definition OMH_G_i i :=
    [s, p] <-$2 A1;
    [lsa, s_A] <-2 p;
    [lsb1, s'] <-$2 oracleMap _ _ O1 s (firstn i lsa);
    [lsb2, _] <-$2 oracleMap _ _ O2 s' (skipn i lsa);
    A2 s_A (lsb1 ++ lsb2).

  Hypothesis adjacent_close :
    forall i,
      | Pr[OMH_G_i i] - Pr[OMH_G_i (S i)] | <= k.

  Definition OMH_G_oc (p : list A * S_A) :=
    [lsa, s_A] <-2 p;
    lsb <--$ oc_compMap _ (fun a => OC_Query _ a) lsa;
    $ A2 s_A lsb.

  Theorem OMH_G_oc_wf : forall p,
    well_formed_oc (OMH_G_oc p).

    intuition.
    econstructor.
    apply oc_compMap_wf.
    intuition.
    econstructor.
    intuition.
    econstructor.
    auto.
  Qed.

  Theorem OMH_G_oc_equiv :
    forall O,
      Pr[OMH_G O] ==
      Pr[
          [s, s_A] <-$2 A1;
          [b, _] <-$2 (OMH_G_oc s_A) _ _ O s;
          ret b
        ].

    intuition.
    unfold OMH_G, OMH_G_oc.
    fcf_skip.
    fcf_simp.

    fcf_to_prhl_eq.
    simpl.
    fcf_inline_first.
    fcf_skip.
    apply compFold_oc_equiv.

    subst.
    fcf_inline_first.
    fcf_ident_expand_l.
    fcf_skip.
    fcf_simp.
    fcf_spec_ret.
  Qed.

  Definition OMH_G1 := OMH_G O1.

  Definition OMH_G2 := OMH_G O2.

  Theorem OMH_G1_equiv:
    Pr[OMH_G1] == Pr[G1 _ O1 A1 OMH_G_oc].

    unfold OMH_G1.
    rewrite OMH_G_oc_equiv.
    unfold G1, OMH_G_oc.
    reflexivity.

  Qed.

  Theorem OMH_G2_equiv:
    Pr[OMH_G2] == Pr[G2 _ O2 A1 OMH_G_oc].

    unfold OMH_G2.
    rewrite OMH_G_oc_equiv.
    unfold G2, OMH_G_oc.
    reflexivity.

  Qed.

  Theorem OMH_G_oc_qam :
    forall p s,
      In (s, p) (getSupport A1) ->
      queries_at_most (OMH_G_oc p) q.

    intuition.
    unfold OMH_G_oc.
    econstructor.
    econstructor.
    eapply oc_compMap_qam.
    intuition.
    econstructor.
    intuition.
    econstructor.
    rewrite mult_1_r.
    rewrite plus_0_r.
    eapply max_queries.
    eauto.
  Qed.

  Definition Gi_oracleMap i :=
    [s, p] <-$2 A1;
    [lsa, s_A] <-2 p;
    p <-$ oracleMap _ _ (Oi _ _ O1 O2 i) (s, 0)%nat lsa;
    A2 s_A (fst p).

  Definition Gi_oracleMap' i :=
    [s, p] <-$2 A1;
    [lsa, s_A] <-2 p;
    p <-$ (
        [lsb1, s'] <-$2 oracleMap _ _ (Oi _ _ O1 O2 i) (s, 0)%nat (firstn i lsa);
        [lsb2, s''] <-$2 oracleMap _ _ (Oi _ _ O1 O2 i) s'%nat (skipn i lsa);
        ret (lsb1 ++ lsb2, s'')
      );
    A2 s_A (fst p).

  Theorem Gi_oracleMap_equiv :
    forall i,
      Pr[Gi _ _ O1 O2 A1 OMH_G_oc i] == Pr[Gi_oracleMap i].

    intuition.
    unfold Gi, OMH_G_oc, Gi_oracleMap.
    fcf_skip.
    fcf_simp.
    fcf_to_prhl_eq.
    simpl.
    fcf_inline_first.
    eapply comp_spec_eq_symm.
    fcf_skip.
    eapply compFold_oc_equiv.
    subst.
    simpl.
    fcf_ident_expand_l.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    fcf_spec_ret.

  Qed.

  Theorem Gi_oracleMap'_equiv :
    forall i,
      Pr[Gi_oracleMap i] == Pr[Gi_oracleMap' i].

    intuition.
    unfold Gi_oracleMap, Gi_oracleMap'.

    fcf_skip.
    fcf_simp.
    fcf_skip.
    cutrewrite (l = (firstn i l ++ skipn i l)).
    eapply eqRat_trans.
    eapply compFold_app.

    fcf_skip.
    rewrite firstn_skipn.
    reflexivity.

    fcf_simp.
    fcf_ident_expand_l.
    fcf_to_prhl_eq.
    rewrite firstn_skipn.
    fcf_skip.
    eapply (compFold_spec' (fun a b c d => a = b /\ snd c = snd d /\ l0++ (fst d) = (fst c)));
      intuition.
    simpl.
    eapply app_nil_r.
    simpl in *.
    subst.
    destruct d.
    simpl in *.
    subst.
    unfold Oi.
    inversion H2; clear H2; subst.
    fcf_inline_first.
    fcf_skip.
    fcf_simp.
    fcf_spec_ret.
    simpl.
    rewrite app_assoc.
    trivial.

    fcf_simp.
    simpl in H3.
    intuition.
    subst.
    fcf_spec_ret.
    rewrite firstn_skipn.
    trivial.
  Qed.

  Theorem OMH_G_i_equiv :
    forall i,
      Pr[Gi_oracleMap' i] == Pr[OMH_G_i i].

    intuition.
    unfold Gi_oracleMap', OMH_G_i.
    fcf_skip.
    fcf_simp.
    fcf_inline_first.
    fcf_to_prhl_eq.
    fcf_skip.
    eapply (compFold_spec' (fun a b c d => a = b /\ fst c = fst d /\ fst (snd c) = snd d /\ (snd (snd c) + length a = min i (length l))%nat)); intuition.
    simpl.
    apply firstn_length.

    fcf_simp.
    simpl in *.
    subst.
    inversion H1; clear H1; subst.
    fcf_inline_first.
    destruct (ge_dec b2 i).
    exfalso.
    destruct (le_dec i (length l)).
    rewrite min_l in H4.
    omega.
    trivial.
    rewrite min_r in H4.
    omega.
    omega.

    comp_skip.
    fcf_spec_ret.
    simpl.
    omega.

    simpl in H2.
    intuition.
    subst.
    fcf_inline_first.
    fcf_simp.

    rewrite plus_0_r in H6.
    destruct (ge_dec i (length l)).
    rewrite skipn_ge_nil; trivial.
    unfold oracleMap.
    simpl.
    fcf_simp.
    simpl.
    eapply comp_spec_eq_refl.

    fcf_skip.
    eapply (compFold_spec' (fun a b c d => a = b /\ fst c = fst d /\ fst (snd c) = snd d /\ (snd (snd c) >= i)%nat)); intuition.
    simpl.
    rewrite min_l; omega.
    simpl in *.
    subst.
    destruct (ge_dec b2 i); try omega.
    inversion H4; clear H4; subst.
    fcf_inline_first.
    fcf_simp.
    fcf_skip.
    simpl.
    fcf_spec_ret.
    simpl.
    omega.

    simpl in H5.
    intuition; subst.
    fcf_simp.
    simpl.
    eapply comp_spec_eq_refl.

  Qed.

  Theorem OMH_G1_G2_close :
    | Pr[OMH_G1] - Pr[OMH_G2] | <= (q / 1) * k.

    rewrite OMH_G1_equiv.
    rewrite OMH_G2_equiv.

    eapply G1_G2_close; intuition.

    apply OMH_G_oc_wf.

    eapply OMH_G_oc_qam.
    eauto.

    repeat rewrite Gi_oracleMap_equiv, Gi_oracleMap'_equiv, OMH_G_i_equiv.
    auto.

  Qed.

End OracleMapHybrid.


Require Import ZArith coqutil.Z.div_mod_to_equations.
Require Import bedrock2.NotationsCustomEntry.
Import Syntax BinInt String List.ListNotations ZArith.
Require Import coqutil.Z.Lia.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

(* Variant of "ipow" implementing multiplication in terms of addition instead
* of exponentiation in terms of multiplication. *)

Definition rpmul := func! (x, e) ~> ret {
  ret = $0;
  while (e) {
    if (e & $1) { ret = ret + x };
    e = e >> $1;
    x = x + x
  }
}.

From bedrock2 Require Import Semantics BasicC32Semantics WeakestPrecondition ProgramLogic.
From coqutil Require Import Word.Properties Word.Interface Tactics.letexists.

#[export] Instance spec_of_rpmul : spec_of "rpmul" := fnspec! "rpmul" x e ~> v,
  { requires t m := True;
    ensures t' m' := t=t' /\ m=m' /\
      (* TODO could be expressed as just word.mul *)
      word.unsigned v = word.unsigned x * word.unsigned e mod 2^32 }.

Module Z.
  Lemma mod2_nonzero x : x mod 2 <> 0 -> x mod 2 = 1.
  Proof. Z.div_mod_to_equations. blia. Qed.
End Z.

Require Import bedrock2.AbsintWordToZ coqutil.Z.Lia.

Ltac t :=
  repeat match goal with x := _ |- _ => subst x end;
  repeat match goal with |- context [word.unsigned ?e] => progress (idtac; let H := rbounded (word.unsigned e) in idtac) end;
  repeat match goal with G: context [word.unsigned ?e] |- _ => progress (idtac; let H := rbounded (word.unsigned e) in idtac) end;
  repeat match goal with |- context [word.unsigned ?e] => progress (idtac; let H := unsigned.zify_expr e in try rewrite H) end;
  repeat match goal with G: context [word.unsigned ?e] |- _ => progress (idtac; let H := unsigned.zify_expr e in try rewrite H in G) end;
  repeat match goal with H: absint_eq ?x ?x |- _ => clear H end;
  cbv [absint_eq] in *.

Lemma rpmul_ok : program_logic_goal_for_function! rpmul.
Proof.
  repeat straightline.
  repeat match goal with H : True |- _ => clear H end.

  refine ((Loops.tailrec
    (* types of ghost variables*) HList.polymorphic_list.nil
    (* program variables *) (["e";"ret";"x"] : list String.string))
    (fun v t m e ret x => PrimitivePair.pair.mk (v = word.unsigned e) (* precondition *)
    (fun   T M E RET X => T = t /\ M = m /\ (* postcondition *)
        word.unsigned RET = (word.unsigned ret + word.unsigned x * word.unsigned e) mod 2^32))
    (fun n m => 0 <= n < m) (* well_founded relation *)
    _ _ _ _ _);
    (* TODO wrap this into a tactic with the previous refine *)
    cbn [HList.hlist.foralls HList.tuple.foralls
         HList.hlist.existss HList.tuple.existss
         HList.hlist.apply  HList.tuple.apply
         HList.hlist
         List.repeat Datatypes.length
         HList.polymorphic_list.repeat HList.polymorphic_list.length
         PrimitivePair.pair._1 PrimitivePair.pair._2] in *.

  { repeat straightline. }
  { exact (Z.lt_wf _). }
  { repeat straightline. } (* init precondition *)
  { (* loop test *)
    repeat straightline; try show_program.
    { (* loop body *)
      letexists; split; [repeat straightline|]. (* if condition evaluation *)
      split. (* if cases, path-blasting *)
      {
        repeat (straightline || (split; trivial; [])). all:t.
        { (* measure decreases *)
          set (word.unsigned x0) in *. (* WHY does blia need this? *)
          Z.div_mod_to_equations; blia. }
        { (* invariant preserved *)
          rewrite H3; clear H3. rename H0 into Hbit.
          change (1+1) with 2 in *.
          eapply Z.mod2_nonzero in Hbit.
          epose proof (Z.div_mod _ 2 ltac:(discriminate)) as Heq; rewrite Hbit in Heq.
          rewrite Heq at 2. clear Hbit Heq.
          (* rewriting with equivalence modulo ... *)
          rewrite !word.unsigned_add.
          unfold word.wrap.
          change (2 ^ 1) with 2.
          do 2 rewrite <- Z.add_mod_idemp_r by discriminate.
          rewrite Z.mul_mod_idemp_l by discriminate.
          rewrite <- Z.add_mod by discriminate.
          rewrite Z.add_mod_idemp_r by discriminate.
          f_equal; ring. } }
      {
        repeat (straightline || (split; trivial; [])).
        all: t.
        { (* measure decreases *)
          set (word.unsigned x0) in *. (* WHY does blia need this? *)
          Z.div_mod_to_equations; blia. }
        { (* invariant preserved *)
          rewrite H3; clear H3. rename H0 into Hbit.
          change (1+1) with 2 in *.
          epose proof (Z.div_mod _ 2 ltac:(discriminate)) as Heq; rewrite Hbit in Heq.
          rewrite Heq at 2; clear Hbit Heq.
          rewrite word.unsigned_add.
          cbv [word.wrap].
          change (2 ^ 1) with 2.
          rewrite <- Z.add_mod_idemp_r by discriminate.
          rewrite Z.mul_mod_idemp_l by discriminate.
          rewrite Z.add_mod_idemp_r by discriminate.
          f_equal; ring. } } }
    { (* postcondition *) rewrite H, Z.mul_0_r, Z.add_0_r, word.wrap_unsigned; auto. } }

  repeat straightline.

  repeat (split || letexists || t || trivial).
Defined.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.ZArith.ZArith.
Require Import Bool.

Require Export util.
Require Export fun_util.
Require Export variables.
Require Import variables_fun_rules.
Require Export states.

Local Open Scope string_scope.

(* STATE *)

(* VALUE *)
Definition beq_value (v1 v2 : VALUE) : bool :=
  match v1,v2 with
  | b t1, b t2 => eqb t1 t2
  | i t1, i t2 => Z.eqb t1 t2
  | n t1, n t2 => t1 =? t2
  | _, _ => false
  end.

(* STATE *)
Definition fun_rules_state
(s : list (NAME * (VALUE * VALUE))) : bool :=
  bis_function
    (map (fun var : (NAME * (VALUE * VALUE)) => fst var) s)
    bstring_dec.

Definition bis_valid_value
(v : VALUE) (t : TYPE) : bool :=
  match v with
  | b _ => beq_type t Tbool
  | i _ => beq_type t Tint
  | n _ => beq_type t Tnat
  end.

Definition bwell_typed_var
(s : STATE) (n : NAME) (t : TYPE) : bool :=
  let v := find_var_state n s.(state) in
    match v with
    | None   => false
    | Some p => (bis_valid_value (fst (snd p)) t)
                && (bis_valid_value (snd (snd p)) t)
    end.

Fixpoint bwell_typed_state_var (s:STATE)
(l: list (NAME * TYPE)) : bool :=
    match l with
    | []     => true
    | h :: t => if bwell_typed_var s (fst h) (snd h)
                then bwell_typed_state_var s t
                else false
    end.

Definition bwell_typed_state (s : STATE)
(l : list (NAME * TYPE)) : bool :=
  let dom_s := map (fun x => fst x) s.(state) in
  let dom_l := map (fun x => fst x) l in
    bsame_list dom_s dom_l bstring_dec
    && bwell_typed_state_var s l.

Definition beq_state_element
(e1 e2 : (NAME * (VALUE * VALUE))) : bool :=
  bstring_dec (fst e1) (fst e2)
  && beq_value (fst (snd e1)) (fst (snd e2))
  && beq_value (snd (snd e1)) (snd (snd e2)).

Fixpoint beq_state_elements (s1 s2 : list (NAME * (VALUE * VALUE))) : bool :=
  match s1, s2 with
  | []      , []       => true
  | []      , _        => false
  | _       , []       => false
  | h1 :: t1, h2 :: t2 => beq_state_element h1 h2
  end.

Definition beq_state (s1 s2 : STATE) : bool :=
  bsame_list s1.(state) s2.(state) beq_state_element.

(* STATES *)

Definition fun_rules_states (l : list STATE) : bool :=
  0 <? List.length l.

(** Rules DFRS_STATES *)
Definition fun_rules_dfrs_states
  (s : STATE) (ss : STATES) : bool :=
    bin_list s ss.(states)
          (fun (s1 s2 : STATE) =>
              beq_state s1 s2).

Local Close Scope string_scope.


Require Import HTS.Overture Path_eq.
Set Universe Polymorphism.

Generalizable All Variables.

Module Export CylinderHIT.
  Private Inductive Cyl {X Y} (f: X -> Y) : Y -> Type :=
    | top : forall x, Cyl f (f x)
    | base : forall y, Cyl f y.

  Axiom fibrant_Cyl : forall {X Y} {f: X -> Y}, PFibrant (Cyl f).

  Axiom cyl_eq : forall {X Y} {f: X -> Y}, (base f) o f == top f.

  Global Arguments top {X Y f} x.
  Global Arguments base {X Y f} y.

  Definition Cyl_ind {X Y} {f: X -> Y}
             (P: forall y, Cyl f y -> Type) {FibP: forall x y, Fibrant (P x y)}
             (top': forall x, P (f x) (top x))
             (base': forall y, P y (base y))
             (cyl_eq' : forall x, (cyl_eq x) # (base' (f x)) = top' x)
  : forall y (w: Cyl f y), P y w
    := fun y w => match w with
                  | top x => top' x
                  | base x => base' x
                end.
End CylinderHIT.

Section Cylinder.
  Context {X Y} {f: X -> Y}.

  Definition Cyl_Contr (y: Y) : Contr (Cyl f y).
  Proof.
    exists (base y).
    revert y. use Cyl_ind.
    - exact cyl_eq.
    - intro. exact 1.
    - intros x; cbn.
      ref (transport_paths_r (x:= base (f x))_ (cyl_eq x) 1 @ _).
      exact (concat_1p _).
  Defined.

  (* ∃ y, Cyl f y  is the homotopy pushout of f and idmap *)
  Definition sig_cyl_ind (P: sigT (Cyl f) -> Type) {FibP: PFibrant P}
             (top': forall x, P (f x; top x))
             (base': forall y, P (y; base y))
             (cyl_eq': forall x,
                 transport (λ w, P (f x; w)) (cyl_eq x) (base' (f x)) = top' x)
    : forall w, P w.
  Proof.
    intros [y w].
    exact (Cyl_ind (λ y w, P (y; w)) top' base' cyl_eq' y w).
  Defined.

  Definition sig_cyl_rec P {FibP: Fibrant P}
             (top': X -> P) (base': Y -> P)
             (cyl_eq': forall x, base' (f x) = top' x)
    : (sigT (Cyl f)) -> P.
  Proof.
    intros [y w].
    ref (Cyl_ind (λ y w, P) top' base' _ y w); cbn.
    intro x. exact (transport_const _ _ @ cyl_eq' _).
  Defined.

  Definition top' : X -> sigT (Cyl f) := λ x, (f x; top x).
  Definition base' : Y -> sigT (Cyl f) := λ y, (y; base y).
  Definition cyl_eq' `{Fibrant Y} : ∀ x, base' (f x) = top' x
    := λ x, path_sigma (Cyl f) 1 (cyl_eq x).
End Cylinder.

Arguments cyl_eq'{_ _ _ _} !_.


Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Classes.EquivDec.

Section Classes.
  Context {A : Type}.
  Context {dec : EqDec A (@eq A)}.

  Theorem UIP_refl : forall {x : A} (p1 : x = x), p1 = refl_equal _.
    intros.
    eapply UIP_dec. apply equiv_dec.
  Qed.

  Theorem UIP_equal : forall {x y : A} (p1 p2 : x = y), p1 = p2.
    eapply UIP_dec. apply equiv_dec.
  Qed.

  Lemma inj_pair2 :
    forall (P:A -> Type) (p:A) (x y:P p),
      existT P p x = existT P p y -> x = y.
  Proof.
    intros. eapply inj_pair2_eq_dec; auto.
  Qed.

End Classes.

Global Instance option_eqdec T (_ : EqDec T (@eq T)) : EqDec (option T) (@eq (option T)).
  red; refine (
  fun a b =>
    match a, b with
      | None, None => left (refl_equal _)
      | Some a, Some b => match equiv_dec a b with
                            | left pf => left match (pf : a = b) in _ = t return Some a = Some t with
                                                | refl_equal => refl_equal
                                              end
                            | right pf => right (fun pf' => pf _)
                          end
      | None , Some _ => right _
      | Some _ , None => right _
    end).
  inversion pf'; reflexivity.
  abstract (intro; congruence).
  abstract (intro; congruence).
Defined.

(*
Global Instance list_eqdec T (_ : EqDec T (@eq T)) : EqDec (list T) (@eq (list T)).
  red; refine (
  fun a b =>
    match a, b with
      | None, None => left (refl_equal _)
      | Some a, Some b => match equiv_dec a b with
                            | left pf => left _
                            | right pf => right _
                          end
      | _ , _ => right _
    end).
  abstract (rewrite pf; reflexivity).
  abstract (intro H; apply pf; inversion H; reflexivity).
  abstract (intro; congruence).
  abstract (intro; congruence).
Defined.
*)

Ltac notVar X :=
  match X with
    | _ _ => idtac
    | _ _ _ => idtac
    | _ _ _ _ => idtac
    | _ _ _ _ _ => idtac
    | _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ _ => idtac
    | _ _ _ _ _ _ _ _ _ _ _ _ _ _ => idtac
  end.

Ltac uip_all :=
  repeat match goal with
           | [ H : _ = _ |- _ ] => rewrite H
           | [ |- context [ match ?X in _ = t return _ with
                              | refl_equal => _
                            end ] ] => notVar X; generalize X
           | [ |- context [ eq_rect_r _ _ ?X ] ] => notVar X; generalize X
         end;
  intros;
    repeat match goal with
             | [ H : ?X = ?X |- _ ] => rewrite (UIP_refl H) in *
           end.

Require Export Coq.Classes.EquivDec.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : AST for R.
  author    : ZhengPu Shi
  date      : 2022.08

  remark    :
  1. Why this module?
     In the inversion of symbol matrix, there are many redundant expressions such
     as "0 + 1 * a + b * 1 + 0", and it should be simplified to friendly "a + b".
     Althouth the former expression is equal to later, we still want to get the later.
     One way to do this job is using Abstract Syntax Tree (AST).
  2. motivation
     To simplify the expressions of symbol matrix with real number, we use AST to
     manipulate the expressions.
  3. How to do it?
     A simple encapsulate of usual operations of R.
     This is a light-weight AST for R, and the main type is named to "T"
  4. Thanks to...
     it is inspired by Marisa Kirisame<lolisa@marisa.moe>.
*)

Require Export BasicConfig.

Require Export RExt.
Require Import String.

(* ######################################################################### *)
(** * AST for R *)

(** Syntax of the AST *)
Inductive A :=
| A0 | A1
| ALit (r : R)
| Aadd (r1 r2 : A) | Aopp (r : A)
| Amul (r1 r2 : A) | Ainv (r : A)
| Afunc (f : string) (args : list A).

(** Simplify expression with R type *)
Global Hint Rewrite
  Rplus_0_l  (* 0 + r = r *)
  Rplus_0_r  (* r + 0 = r *)
  Rmult_0_l  (* 0 * r = 0 *)
  Rmult_0_r  (* r * 0 = 0 *)
  Rmult_1_l  (* 1 * r = r *)
  Rmult_1_r  (* r * 1 = r *)
.

(** New scope *)
Declare Scope A_scope.
Delimit Scope A_scope with A.
Open Scope A_scope.

Bind Scope A_scope with A.

(** Subtraction *)
Definition Asub a b := Aadd a (Aopp b).

(** Division *)
Definition Adiv a b := Amul a (Ainv b).

Notation "0" := A0 : A_scope.
Notation "1" := A1 : A_scope.
Infix "+" := Aadd : A_scope.
Infix "-" := Asub : A_scope.
Infix "*" := Amul : A_scope.
Infix "/" := Adiv : A_scope.
Notation "- a" := (Aopp a) : A_scope.
Notation "/ a" := (Ainv a) : A_scope.

(* Assumped rules for operations of A *)
Axiom Aadd_0_l : forall x, 0 + x = x.
Axiom Aadd_comm : forall x y, x + y = y + x.
Axiom Aadd_assoc : forall x y z, x + (y + z) = (x + y) + z.
Axiom Amul_1_l : forall x, 1 * x = x.
Axiom Amul_comm : forall x y, x * y = y * x.
Axiom Amul_assoc : forall x y z, x * (y * z) = (x * y) * z.
Axiom Adistr_l : forall x y z, (x + y) * z = x * z + y * z.
Axiom Aopp_def : forall x, x + (- x) = 0.
Axiom Ainv_l : forall x, x <> 0 -> (/ x) * x = 1.

(** We get a ring structure *)
Definition A_ring : ring_theory A0 A1 Aadd Amul Asub Aopp eq.
  constructor; auto.
  apply Aadd_0_l. apply Aadd_comm. apply Aadd_assoc.
  apply Amul_1_l. apply Amul_comm. apply Amul_assoc.
  apply Adistr_l. apply Aopp_def.
Defined.

Add Ring Ring_thy_inst : A_ring.

(** We get a field structure *)
Definition A_field : field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv eq.
  constructor; auto.
  apply A_ring. intro. easy.
  apply Ainv_l.
Defined.

Add Field Field_thy_inst : A_field.

(** Semantic of the AST *)
Fixpoint A2R (t : A) : R :=
  match t with
  | 0 => R0 | 1 => R1 | ALit r => r
  | t1 + t2 => Rplus (A2R t1) (A2R t2) | Aopp t => Ropp (A2R t)
  | t1 * t2 => Rmult (A2R t1) (A2R t2) | Ainv t => Rinv (A2R t)
  | Afunc f args => match f with
    | _ => R0
    end
  end.

(** Simplify an expression *)
Fixpoint simp (t : A) : A :=
  match t with
  | 0 + x => x
  | x + 0 => x
  | a + (b + c) => a + b + c
  | a + b => (simp a) + (simp b)
  | - 0 => 0
  | - - a => a
  | - (a + b) => - a + - b
  | - (a * b) => (-a) * b
  | - x => - (simp x)
  | 0 * _ => 0
  | _ * 0 => 0
  | 1 * x => x
  | x * 1 => x
  | (- (1)) * x => (-x)
  | x * (- (1)) => (-x)
  | a * (b + c) => (a * b) + (a * c)
  | (a + b) * c => (a * c) + (b * c)
  | a * (b * c) => a * b * c
  | a * b => (simp a) * (simp b)
  | / 1 => 1
  | / (a * b) => /a * /b
  | / x => / (simp x)
  | 0 => 0
  | 1 => 1
  | ALit _ => t
  | Afunc _ _ => t
  (* | _ => t *)
  end.

(** Multi-step simplification *)
Fixpoint nsimp (t : A) (n : nat) : A :=
  match n with
  | O => t
  | S n' => nsimp (simp t) n'
  end.

Section test.

  (* test of simp *)
  Let ex1 := 1 * 1 * (0 + 0).
  (* Compute simp ex1. *)
  (* Compute nsimp ex1 3. *)

  Let ex2 := 1 * 1 + 1 + (0 + 0 + 0).
  (* Compute simp ex2. *)
  (* Compute nsimp ex2 6. *)

  (* test of A2R *)
  Let f (t : A) : A := 1 * 1 * (t + 0 + 0).
  (* Compute f A0. *)
  (* Compute A2R (f A0). *)
  (* Compute A2R (nsimp (f A0) 5). *)

  (* test for simp + A2R *)
  Variable r11 r12 r13 r21 r22 r23 r31 r32 r33 : R.
  Let a11 := ALit r11. Let a12 := ALit r12. Let a13 := ALit r13.
  Let a21 := ALit r21. Let a22 := ALit r22. Let a23 := ALit r23.
  Let a31 := ALit r31. Let a32 := ALit r32. Let a33 := ALit r33.

  Let t1 := / (a11 * a12 + - a12 * a21) * -(1) * a12.
  (* Eval cbv in (A2R (nsimp t1 0)). *)
  (* Eval cbv in (A2R (nsimp t1 1)). *)
  (* Eval cbv in (A2R (nsimp t1 2)). *)

End test.

(** Aeq is decidable *)
Theorem Aeqdec : forall t1 t2 : A, {t1 = t2} + {t1 <> t2}.
Proof.
  induction t1; induction t2; auto;
  try (left; easy); try (right; easy).
  - destruct (Req_EM_T r r0); subst; auto. right. intro. inversion H. auto.
  - destruct (IHt1_1 t2_1),(IHt1_2 t2_2); subst; auto.
    + right. intro. inversion H. easy.
    + right. intro. inversion H. easy.
    + right. intro. inversion H. easy.
  - destruct (IHt1 t2); subst; auto. right. intro H; inversion H. easy.
  - destruct (IHt1_1 t2_1),(IHt1_2 t2_2); subst; auto.
    + right. intro. inversion H. easy.
    + right. intro. inversion H. easy.
    + right. intro. inversion H. easy.
  - destruct (IHt1 t2); subst; auto. right. intro H; inversion H. easy.
  - destruct (string_dec f f0); subst; auto.
    2:{ right. intro. inversion H. easy. }
    { assert ({args = args0} + {args <> args0}).
      2:{ destruct H; subst; auto. right. intro H; inversion H; auto. }
      apply List.list_eq_dec.
      (* Why lost this assupmption ? *)
Admitted.

Open Scope R.

(** simp keep the symantic *)
Theorem simp_ok : forall (t : A), A2R (simp t) = A2R t.
Proof.
(*   induction t; auto.
  - simpl. destruct (Aeqdec t1 0), (Aeqdec t2 0).
    + subst. simpl. ring.
    + subst. simpl. ring.
    + subst.
      replace (match t1 with 0 => 0 | _ => t1 end)%A with t1.
      * simpl. ring.
      * destruct t1; auto.
    + replace (match t2 with 0 => t1 | b + c => t1 + b + c |
        _ => simp t1 + simp t2 end)%A
      with (match t2 with b + c => t1 + b + c |
        _ => simp t1 + simp t2 end)%A.
      * replace (match t1 with 0 => t2 | _ => simp t1 + simp t2 end)%A
        with (simp t1 + simp t2)%A.
        { simpl. rewrite IHt1, IHt2. auto. }
        { destruct t1; auto. easy. }
      * destruct t2; auto. easy.
  - simpl. destruct (Aeqdec t 0); subst; simpl; try ring.
    replace (match t with 0 => 0 | _ => - simp t end)%A with (- simp t)%A.
    + simpl. rewrite IHt. auto.
    + destruct t; auto. easy.
  - simpl. destruct (Aeqdec t1 0), (Aeqdec t2 0).
    + subst. simpl. ring.
    + subst. simpl. ring.
    + subst. destruct t1; simpl; try ring.
    + destruct (Aeqdec t1 1); subst; auto.
      * replace (match t2 with 0 => 0 | _ => t2 end)%A with t2.
        simpl; try ring. destruct t2; auto.
      * destruct (Aeqdec t2 1); subst.
        { replace (match t1 with 0 => 0 | 1 => 1 | _ => t1 end)%A with t1.
          simpl; ring. destruct t1; auto. }
        { replace (match t2 with 0 => 0 | _ => t2 end)%A with t2.
          { replace (match t2 with 0=>0 | 1=>t1 | _=> simp t1 * simp t2
            end)%A with (simp t1 * simp t2)%A.
            { replace (match t1 with 0=>0 | 1=>t2 | _=> simp t1 * simp t2
              end)%A with (simp t1 * simp t2)%A.
              { simpl; rewrite IHt1,IHt2. auto. }
              { destruct t1; auto; try easy. } }
            { destruct t2; auto; try easy. } }
          { destruct t2; auto. }}
  - simpl. destruct (Aeqdec t 0); subst; simpl; try ring.
    destruct (Aeqdec t 1); subst. simpl. field.
    replace (match t with 1 => 1 | _ => / simp t end)%A with (/ simp t)%A.
    + simpl. rewrite IHt. auto.
    + destruct t; auto. easy.
Qed. *)
Admitted.

(** nsimp keep the symantic *)
Theorem nsimp_ok : forall (n : nat) (t : A), A2R (nsimp t n) = A2R t.
Proof.
  induction n; auto. simpl. intros. rewrite IHn. apply simp_ok.
Qed.

(** Boolean equality can be derived from T2R and Req_dec *)
Definition Aeqb (t1 t2 : A) : bool :=
  let r1 := A2R t1 in
  let r2 := A2R t2 in
    if Req_EM_T r1 r2 then true else false.

Infix     "=?"          := Aeqb           : A_scope.