Set Implicit Arguments.

Require Import Coq.Bool.Bool.
Require Import vecs_new.

Definition bool_le (x y : bool) : Prop :=
  match x with
    false => True
  | true => match y with
      false => False
    | true => True
    end
  end.

Fixpoint vec_le (n : nat) : vec bool n -> vec bool n -> Prop :=
  match n as n return vec bool n -> vec bool n -> Prop with
    0   => fun _ _ => True
  | S m => fun v w => bool_le (vhead v) (vhead w) /\ vec_le m (vtail v) (vtail w)
  end.

Lemma vec_le_correct (n : nat)(v w : vec bool n) :
  vec_le n v w -> forall i : fin n,
    bool_le (item_at bool n i v) (item_at bool n i w).
Proof.
  intros.
  induction n.
  destruct i.
  destruct v,w,i.
  destruct b,b0,u.
  simpl.
  reflexivity.
  simpl in H.
  destruct H.
  contradiction.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  simpl in H.
  apply IHn.
  apply H.
Qed.

Fixpoint index_eqb (n : nat) : fin n -> fin n -> bool :=
  match n as n return fin n -> fin n -> bool with
    0   => fun e e' => emptyf bool e
  | S n => fun i j =>
    match i , j with
      inl tt , inl tt => true
    | inl tt , inr l  => false
    | inr k  , inl tt => false
    | inr k  , inr l  => index_eqb n k l
    end
  end.

Definition conn (k : nat) :=
  vec bool k -> bool.

Definition conn_ext_eq (n : nat) (f g : conn n) :=
  forall v , f v = g v.

Notation "f [=] g" := (conn_ext_eq f g) (at level 38, right associativity).

Definition comp (n k : nat) (f : conn n) (gs : vec (conn k) n) : conn k :=
  fun xs => f (vec_ap bool n gs xs).
(*
Definition remove_component (n m : nat) (f : conn (n + m)) : conn (n + S m) :=
  fun x => f (rm_nth_vec Bool n m x).
*)
Definition ID  : conn 1 :=
  fun v => match v with
           |[ b ] => b
           end.

Definition NOT : conn 1 :=
  fun v => match v with
           |[ b ] => negb b
           end.

Definition AND : conn 2 :=
  fun v => match v with
           |[ b1 , b2 ] => andb b1 b2
           end.

Definition OR : conn 2 :=
  fun v => match v with
           |[ b1 , b2 ] => orb b1 b2
           end.

Definition IMPL : conn 2 :=
  fun v => match v with
           |[ b1 , b2 ] => implb b1 b2
           end.

Definition rIMPL : conn 2 :=
  fun v => match v with
           |[ b1 , b2 ] => match b1,b2 with
                           |false , false => true
                           |false , true  => false
                           |true  , false => true
                           |true  , true  => true
                           end
           end.

Definition const (k : nat)(x : bool) : conn k :=
  fun v => x.

Definition proj (n : nat) (i : fin n) : conn n :=
  fun v : vec bool n => item_at bool n i v .

Definition p1 : conn 2 :=
  proj 2 (inl tt).

Definition p2 : conn 2 :=
  proj 2 (inr (inl tt)).

(* Definition of definable from a set X of connectives *)
Inductive Definable(X : forall n:nat, conn n -> Prop) : forall k, conn k -> Prop :=
  | atom_def : forall (n : nat)(f : conn n), X n f -> Definable X f
  | null_def : forall x : bool, Definable X (const 1 x) -> Definable X (const 0 x)
  | project  : forall (n : nat) (i : fin n), Definable X (proj n i)
  | compose  : forall (n k : nat) (f : conn n) (gs : vec (conn k) n),
               Definable X f -> (forall i : fin n, Definable X (item_at (conn k) n i gs)) -> Definable X (comp k f gs)
  | def_ext  : forall (n : nat) (f g : conn n), Definable X f -> f [=] g -> Definable X g.

(*functionally complete*)
Definition FC(X : forall n:nat, conn n -> Prop) :=
  (forall (n : nat)(f : conn n), Definable X f).

Definition DeM_or :=
  comp 2 NOT [ comp 2 AND [ comp 2 NOT [ p1 ] , comp 2 NOT [ p2 ] ] ].

Lemma or_def : DeM_or [=] OR.
Proof.
  unfold DeM_or.
  unfold comp.
  intros v.
  destruct v as [b1 [b2 u]].
  destruct b1, b2, u; simpl; reflexivity.
Qed.

(* two lemmas which make the compose rule easier to use *)
Lemma unit_comp_def(X : forall n:nat, conn n -> Prop) : forall k, forall f : conn 1, forall g : conn k,
  Definable X f -> Definable X g -> Definable X (comp k f [ g ]).
Proof.
  intros.
  apply compose.
  exact H.
  intro.
  destruct i.
  destruct u.
  simpl.
  exact H0.
  destruct f0.
Qed.

Lemma bin_comp_def(X : forall n:nat, conn n -> Prop) : forall k, forall f : conn 2 , forall g1 g2 : conn k,
  Definable X f -> Definable X g1 -> Definable X g2 -> Definable X (comp k f [g1 , g2]).
Proof.
  intros.
  apply compose.
  exact H.
  destruct i.
  destruct u.
  simpl.
  exact H0.
  destruct f0.
  destruct u.
  simpl.
  exact H1.
  destruct f0.
Qed.

Lemma id_proj : proj 1 (inl tt) [=] ID.
Proof.
  unfold ID, proj.
  intro v.
  destruct v as [b u].
  destruct b,u; simpl; reflexivity.
Qed.

Lemma id_def(X : forall n:nat, conn n -> Prop) : Definable X ID.
Proof.
  assert (Definable X (proj 1 (inl tt))).
  apply project.
  apply (def_ext H).
  exact id_proj.
Qed.

Lemma or_from_and_not(X : forall n:nat, conn n -> Prop) : Definable X AND -> Definable X NOT -> Definable X OR.
Proof.
  intros.
  assert (Definable X DeM_or).
  apply unit_comp_def.
  exact H0.
  apply bin_comp_def.
  exact H.
  apply unit_comp_def.
  exact H0.
  apply project.
  apply unit_comp_def.
  exact H0.
  apply project.
  apply (def_ext H1).
  apply or_def.
Qed.

Definition DeM_and :=
  comp 2 NOT [ comp 2 OR [ comp 2 NOT [ p1 ] , comp 2 NOT [ p2 ] ] ].

Lemma and_DeM_def : DeM_and [=] AND.
Proof.
  unfold DeM_and.
  unfold comp.
  intros v.
  destruct v as [b1 [b2 u]].
  destruct b1, b2, u; simpl; reflexivity.
Qed.

Lemma and_from_or_not(X : forall n:nat, conn n -> Prop) : Definable X OR -> Definable X NOT -> Definable X AND.
Proof.
  intros.
  assert (Definable X DeM_and).
  apply unit_comp_def.
  exact H0.
  apply bin_comp_def.
  exact H.
  apply unit_comp_def.
  exact H0.
  apply project.
  apply unit_comp_def.
  exact H0.
  apply project.
  apply (def_ext H1).
  apply and_DeM_def.
Qed.

Definition DS_or :=
  comp 2 IMPL [comp 2 NOT [ p1 ] , p2].

Lemma or_DS_def : DS_or [=] OR.
Proof.
  unfold DS_or.
  unfold comp.
  intros v.
  destruct v as [b1 [b2 u]].
  destruct b1, b2, u; simpl; reflexivity.
Qed.

Lemma or_from_impl_not(X : forall n:nat, conn n -> Prop) : Definable X IMPL -> Definable X NOT -> Definable X OR.
Proof.
  intros.
  assert (Definable X DS_or).
  apply bin_comp_def.
  exact H.
  apply unit_comp_def.
  exact H0.
  apply project.
  apply project.
  apply (def_ext H1).
  apply or_DS_def.
Qed.

Definition rDS_or :=
  comp 2 rIMPL [p1 , comp 2 NOT [ p2 ]].

Lemma or_rDS_def : rDS_or [=] OR.
Proof.
  unfold rDS_or.
  unfold comp.
  intros v.
  destruct v as [b1 [b2 u]].
  destruct b1, b2, u; simpl; reflexivity.
Qed.

Lemma or_from_rimpl_not(X : forall n:nat, conn n -> Prop) : Definable X rIMPL -> Definable X NOT -> Definable X OR.
Proof.
  intros.
  assert (Definable X rDS_or).
  apply bin_comp_def.
  exact H.
  apply project.
  apply unit_comp_def.
  exact H0.
  apply project.
  apply (def_ext H1).
  apply or_rDS_def.
Qed.

Definition NonCon_F := comp 1 AND [ ID , NOT ].

Lemma f_def : NonCon_F [=] (const 1 false).
Proof.
  unfold NonCon_F.
  unfold comp.
  intro v.
  destruct v as [b u].
  destruct b, u; simpl; reflexivity.
Qed.

Lemma f_from_and_not(X : forall n:nat, conn n -> Prop) : Definable X AND -> Definable X NOT -> Definable X (const 1 false).
Proof.
  intros.
  assert (Definable X NonCon_F).
  apply bin_comp_def.
  exact H.
  apply id_def.
  exact H0.
  apply (def_ext H1).
  apply f_def.
Qed.

Definition LEM_T := comp 1 OR [ID , NOT].

Lemma t_def : LEM_T [=] (const 1 true).
Proof.
  unfold LEM_T.
  unfold comp.
  intro v.
  destruct v as [b u].
  destruct b,u; simpl; reflexivity.
Qed.

Lemma t_from_and_not(X : forall n:nat, conn n -> Prop) : Definable X AND -> Definable X NOT -> Definable X (const 1 true).
Proof.
  intros.
  assert (Definable X LEM_T).
  apply bin_comp_def.
  apply or_from_and_not.
  exact H.
  exact H0.
  apply id_def.
  exact H0.
  apply (def_ext H1).
  apply t_def.
Qed.

Lemma nullconn_is_constant : forall f : conn 0, (const 0 false) [=] f \/ (const 0 true) [=] f.
Proof.
  intro f.
  assert (f tt = false \/ f tt = true).
  destruct (f tt).
  right; reflexivity.
  left; reflexivity.
  destruct H.
  left.
  intro.
  destruct v.
  rewrite H; simpl; reflexivity.
  right.
  intro.
  destruct v.
  rewrite H; simpl; reflexivity.
Qed.

Lemma all_nullconn_from_and_not(X : forall n:nat, conn n -> Prop) : Definable X AND -> Definable X NOT ->
  (forall f:conn 0, Definable X f).
Proof.
  intros.
  destruct (nullconn_is_constant f).
  assert (Definable X (const 0 false)).
  apply null_def.
  apply f_from_and_not.
  exact H.
  exact H0.
  apply (def_ext H2).
  exact H1.
  assert (Definable X (const 0 true)).
  apply null_def.
  apply t_from_and_not.
  exact H.
  exact H0.
  apply (def_ext H2).
  exact H1.
Qed.

Lemma ext_unit_subst : forall (n : nat)(f : conn 1)(g h : conn n),
  g [=] h -> comp n f [ g ] [=] comp n f [ h ].
Proof.
  intros.
  intro v.
  unfold comp.
  simpl.
  rewrite H.
  reflexivity.
Qed.

Lemma ext_bin_subst : forall (n : nat)(f : conn 2)(g1 g2 h1 h2 : conn n),
  g1 [=] h1 -> g2 [=] h2 -> comp n f [ g1 , g2 ] [=] comp n f [ h1 , h2 ].
Proof.
  intros.
  intro v.
  unfold comp.
  simpl.
  rewrite H, H0.
  reflexivity.
Qed.

(* some lemmas for simplifying expressions with AND and OR *)

Lemma and_left_f : forall (n:nat)(g h : conn n)(v : vec bool n),
  g v = false -> comp n AND [g , h] v = false.
Proof.
  intros.
  unfold comp.
  simpl.
  rewrite H.
  apply andb_false_l.
Qed.

Lemma and_left_t : forall (n:nat)(g h : conn n)(v : vec bool n),
  g v = true -> comp n AND [g , h] v = h v.
Proof.
  intros.
  unfold comp.
  simpl.
  rewrite H.
  apply andb_true_l.
Qed.

Lemma or_left_f : forall (n:nat)(g h : conn n)(v : vec bool n),
  g v = false -> comp n OR [g , h] v = h v.
Proof.
  intros.
  unfold comp.
  simpl.
  rewrite H.
  apply orb_false_l.
Qed.

Lemma or_left_t : forall (n:nat)(g h : conn n)(v : vec bool n),
  g v = true -> comp n OR [g , h] v = true.
Proof.
  intros.
  unfold comp.
  simpl.
  rewrite H.
  apply orb_true_l.
Qed.

Lemma or_right_f : forall (n:nat)(g h : conn n)(v : vec bool n),
  h v = false -> comp n OR [g , h] v = g v.
Proof.
  intros.
  unfold comp.
  simpl.
  rewrite H.
  apply orb_false_r.
Qed.

Lemma or_right_t : forall (n:nat)(g h : conn n)(v : vec bool n),
  h v = true -> comp n OR [g , h] v = true.
Proof.
  intros.
  unfold comp.
  simpl.
  rewrite H.
  apply orb_true_r.
Qed.

Definition change_first_arg (n : nat) (f : conn (S n)) (x : bool) : conn (S n) :=
  fun v => f (x,(vtail v)).

(*
Lemma remove_eq (n : nat)(f : conn (S n))(x : bool) :
  remove_component 0 n (fun v => f (x,v)) [=] (remove_first_arg f x).
Proof.
  intro v.
  simpl v; destruct v.
  simpl.
  unfold remove_component.
  unfold remove_first_arg.
  simpl.
  unfold vcons; reflexivity.
Qed.
*)
(* the idea: fun x,ybar => (x /\ (f T,ybar)) \/ (~x /\ (f F,ybar)) *)

Definition and_or_not_form (n : nat) (f : conn (S n)) : conn (S n) :=
  comp (S n) OR
    [
      (comp (S n) AND [ (proj (S n) (inl tt)) , (change_first_arg f true) ] ) ,
      (comp (S n) AND [ comp (S n) NOT [ proj (S n) (inl tt)] , change_first_arg f false ] )
    ].

Lemma first_proj_lemma : forall (n : nat)(x : bool)(v : vec bool n), proj (S n) (inl tt) (x,v) = x.
Proof.
  intros.
  unfold proj.
  simpl.
  reflexivity.
Qed.

Lemma un_comp_lemma : forall (n : nat)(f : conn 1)(g : conn (S n))(v : vec bool (S n)),
  comp (S n) f [ g ] v = f ( [ g v ] ).
Proof.
  intros.
  unfold comp.
  simpl.
  reflexivity.
Qed.

Lemma and_or_not_eq : forall (n : nat)(f : conn (S n)), and_or_not_form f [=] f.
Proof.
  intros n f v.
  destruct v.
  unfold and_or_not_form.
  unfold comp.
  unfold change_first_arg.
  destruct b.
  simpl.
  apply orb_false_r.
  simpl.
  reflexivity.
Qed.

Definition proj_vec(n : nat) : vec (conn n) n := to_vec n (fun i => proj n i).

Lemma proj_vec_correct : forall (n : nat)(v : vec bool n), vec_ap bool n (proj_vec n) v = v.
Proof.
  intros.
  unfold proj_vec.
  apply vec_ext.
  intro i.
  rewrite vec_ap_lemma.
  rewrite to_vec_correct.
  unfold proj.
  reflexivity.
Qed.

Lemma ignore_first_proj_def : forall (n : nat)(g : conn n),
  comp (S n) g (vtail (proj_vec (S n))) [=] (fun v => g (vtail v)).
Proof.
  intros.
  intro v.
  unfold comp.
  f_equal.
  rewrite vec_ap_vtail_comm.
  f_equal.
  apply proj_vec_correct.
Qed.

Lemma ignore_first_definable(X : forall n:nat, conn n -> Prop) :  forall (n : nat)(f : conn (S n)),
  (exists g : conn n, Definable X g /\  (fun v => g (vtail v)) [=] f) -> Definable X f.
Proof.
  intros.
  destruct H as [g [gDef Hfg]].
  assert (Definable X (fun v => g (vtail v))).
  assert (Definable X (comp (S n) g (vtail (proj_vec (S n))))).
  apply compose.
  exact gDef.
  intro i.
  simpl.
  rewrite to_vec_correct.
  apply project.
  apply (def_ext H).
  intro v.
  apply ignore_first_proj_def.
  apply (def_ext H).
  exact Hfg.
Qed.

Lemma and_not_func_complete(X : forall n:nat, conn n -> Prop) : Definable X AND -> Definable X NOT ->
  FC X.
Proof.
  intros.
  induction n.
  apply all_nullconn_from_and_not.
  exact H.
  exact H0.
  intro f.
  assert (Definable X (and_or_not_form f)).
  apply bin_comp_def.
  apply or_from_and_not.
  exact H.
  exact H0.
  apply bin_comp_def.
  exact H.
  apply project.
  apply ignore_first_definable.
  exists (fun v => f (true,v)).
  split.
  apply IHn.
  intro v.
  unfold change_first_arg.
  reflexivity.
  apply compose.
  exact H.
  intro i; destruct i.
  destruct u.
  simpl.
  apply compose.
  exact H0.
  intro i; destruct i.
  destruct u.
  simpl.
  apply project.
  destruct f0.
  destruct f0.
  destruct u.
  simpl.
  apply ignore_first_definable.
  exists (fun v => f (false,v)).
  split.
  apply IHn.
  intro v.
  unfold change_first_arg; reflexivity.
  destruct f0.
  apply (def_ext H1).
  apply and_or_not_eq.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Local Open Scope Z_scope.

Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Saturated.Core.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.LetIn Crypto.Util.Tuple.
Local Notation "A ^ n" := (tuple A n) : type_scope.

Section UniformWeight.
  Context (bound : Z) {bound_pos : bound > 0}.

  Definition uweight : nat -> Z := fun i => bound ^ Z.of_nat i.
  Lemma uweight_0 : uweight 0%nat = 1. Proof. reflexivity. Qed.
  Lemma uweight_positive i : uweight i > 0.
  Proof. apply Z.lt_gt, Z.pow_pos_nonneg; omega. Qed.
  Lemma uweight_nonzero i : uweight i <> 0.
  Proof. auto using Z.positive_is_nonzero, uweight_positive. Qed.
  Lemma uweight_multiples i : uweight (S i) mod uweight i = 0.
  Proof. apply Z.mod_same_pow; rewrite Nat2Z.inj_succ; omega. Qed.
  Lemma uweight_divides i : uweight (S i) / uweight i > 0.
  Proof.
    cbv [uweight]. rewrite <-Z.pow_sub_r by (rewrite ?Nat2Z.inj_succ; omega).
    apply Z.lt_gt, Z.pow_pos_nonneg; rewrite ?Nat2Z.inj_succ; omega.
  Qed.

  (* TODO : move to Positional *)
  Lemma eval_from_eq {n} (p:Z^n) wt offset :
    (forall i, wt i = uweight (i + offset)) ->
    B.Positional.eval wt p = B.Positional.eval_from uweight offset p.
  Proof. cbv [B.Positional.eval_from]. auto using B.Positional.eval_wt_equiv. Qed.

  Lemma uweight_eval_from {n} (p:Z^n): forall offset,
    B.Positional.eval_from uweight offset p = uweight offset * B.Positional.eval uweight p.
  Proof.
    induction n; intros; cbv [B.Positional.eval_from];
      [|rewrite (subst_append p)];
    repeat match goal with
           | _ => destruct p
           | _ => rewrite B.Positional.eval_unit; [ ]
           | _ => rewrite B.Positional.eval_step; [ ]
           | _ => rewrite IHn; [ ]
           | _ => rewrite eval_from_eq with (offset0:=S offset)
               by (intros; f_equal; omega)
           | _ => rewrite eval_from_eq with
                  (wt:=fun i => uweight (S i)) (offset0:=1%nat)
               by (intros; f_equal; omega)
           | _ => ring
           end.
    repeat match goal with
           | _ => cbv [uweight]; progress autorewrite with natsimplify
           | _ => progress (rewrite ?Nat2Z.inj_succ, ?Nat2Z.inj_0, ?Z.pow_0_r)
           | _ => rewrite !Z.pow_succ_r by (try apply Nat2Z.is_nonneg; omega)
           | _ => ring
           end.
  Qed.

  Lemma uweight_eval_step {n} (p:Z^S n):
    B.Positional.eval uweight p = hd p + bound * B.Positional.eval uweight (tl p).
  Proof.
    rewrite (subst_append p) at 1; rewrite B.Positional.eval_step.
    rewrite eval_from_eq with (offset := 1%nat) by (intros; f_equal; omega).
    rewrite uweight_eval_from. cbv [uweight]; rewrite Z.pow_0_r, Z.pow_1_r.
    ring.
  Qed.

  Lemma uweight_le_mono n m : (n <= m)%nat ->
    uweight n <= uweight m.
  Proof.
    unfold uweight; intro; Z.peel_le; omega.
  Qed.

  Lemma uweight_lt_mono (bound_gt_1 : bound > 1) n m : (n < m)%nat ->
    uweight n < uweight m.
  Proof.
    clear bound_pos.
    unfold uweight; intro; apply Z.pow_lt_mono_r; omega.
  Qed.

  Lemma uweight_succ n : uweight (S n) = bound * uweight n.
  Proof.
    unfold uweight.
    rewrite Nat2Z.inj_succ, Z.pow_succ_r by auto using Nat2Z.is_nonneg; reflexivity.
  Qed.

  Definition small {n} (p : Z^n) : Prop :=
    forall x, In x (to_list _ p) -> 0 <= x < bound.

End UniformWeight.


(******************************************************************************)
From Coq Require Import Wf_nat Arith Lists.List Peano_dec.

Require Import ListExt. (* todo: use stdlib? *)
Require Export fol.

Section Fol_Properties.

Variable L : Language.

Notation Formula := (Formula L) (only parsing).
Notation Formulas := (Formulas L) (only parsing).
Notation System := (System L) (only parsing).
Notation Term := (Term L) (only parsing).
Notation Terms := (Terms L) (only parsing).

Let lt_depth := lt_depth L.

Section Free_Variables.

Fixpoint freeVarTerm (s : fol.Term L) : list nat :=
  match s with
  | var v => v :: nil
  | apply f ts => freeVarTerms (arityF L f) ts
  end
with freeVarTerms (n : nat) (ss : fol.Terms L n) {struct ss} : list nat :=
       match ss with
       | Tnil => nil (A:=nat)
       | Tcons m t ts => freeVarTerm t ++ freeVarTerms m ts
       end.

Lemma freeVarTermApply :
  forall (f : Functions L) (ts : fol.Terms L _),
    freeVarTerm (apply f ts) = freeVarTerms _ ts.
Proof. reflexivity. Qed.

Fixpoint freeVarFormula (A : fol.Formula L) : list nat :=
  match A with
  | equal t s => freeVarTerm t ++ freeVarTerm s
  | atomic r ts => freeVarTerms _ ts
  | impH A B => freeVarFormula A ++ freeVarFormula B
  | notH A => freeVarFormula A
  | forallH v A => List.remove  eq_nat_dec v (freeVarFormula A)
  end.

Definition ClosedSystem (T : fol.System L) :=
  forall (v : nat) (f : fol.Formula L),
    mem _ T f -> ~ In v (freeVarFormula f).

Fixpoint closeList (l: list nat)(a : fol.Formula L) :=
 match l with
   nil => a
|  cons v l =>  (forallH v (closeList l a))
end.

(* Todo : use stdlib's nodup *)

Definition close (x : fol.Formula L) : fol.Formula L :=
  closeList (List.nodup eq_nat_dec (freeVarFormula x)) x.

Lemma freeVarClosedList1 :
  forall (l : list nat) (v : nat) (x : fol.Formula L),
    In v l -> ~ In v (freeVarFormula (closeList l x)).
Proof.
  intro l; induction l as [| a l Hrecl].
  - intros v x H; elim H.
  - intros v x H; induction H as [H| H].
    + simpl in |- *; rewrite H.
      unfold not in |- *; intros H0;
        elim (in_remove_neq _ _ _ _ _ H0); reflexivity.
    + simpl in |- *.  intro H0.
      assert (H1: In v (freeVarFormula (closeList l x))).
      { eapply in_remove.   apply H0. }
      apply (Hrecl _ _ H H1).
Qed.

Lemma freeVarClosedList2 :
  forall (l : list nat) (v : nat) (x : fol.Formula L),
    In v (freeVarFormula (closeList l x)) ->
    In v (freeVarFormula x).
Proof.
  intro l; induction l as [| a l Hrecl].
  - simpl; intros v x H; apply H.
  - simpl; intros v x H; apply Hrecl; eapply in_remove;  apply H.
Qed.

Lemma freeVarClosed :
  forall (x : fol.Formula L) (v : nat), ~ In v (freeVarFormula (close x)).
Proof.
  intros x v; unfold close;
  destruct (In_dec eq_nat_dec v (List.nodup eq_nat_dec (freeVarFormula x)))
    as [i | n].
  - apply freeVarClosedList1; assumption.
  - intro H; elim n. rewrite nodup_In.
    eapply freeVarClosedList2; apply H.
Qed.

Fixpoint freeVarListFormula (l : fol.Formulas L) : list nat :=
  match l with
  | nil => nil (A:=nat)
  | f :: l => freeVarFormula f ++ freeVarListFormula l
  end.

Lemma freeVarListFormulaApp :
  forall a b : fol.Formulas L,
    freeVarListFormula (a ++ b) =
      freeVarListFormula a ++ freeVarListFormula b.
Proof.
  intros a b; induction a as [| a a0 Hreca].
  - reflexivity.
  - simpl in |- *; rewrite Hreca; now rewrite List.app_assoc.
Qed.

Lemma In_freeVarListFormula :
  forall (v : nat) (f : fol.Formula L) (F : fol.Formulas L),
    In v (freeVarFormula f) -> In f F -> In v (freeVarListFormula F).
Proof.
  intros v f F H H0; induction F as [| a F HrecF].
  - elim H0.
  - destruct H0 as [H0| H0]; simpl in |- *.
    + apply in_or_app; left; now rewrite H0.
    + apply in_or_app; auto.
Qed.

Lemma In_freeVarListFormulaE :
  forall (v : nat) (F : fol.Formulas L),
    In v (freeVarListFormula F) ->
    exists f : fol.Formula L, In v (freeVarFormula f) /\ In f F.
Proof.
  intros v F H; induction F as [| a F HrecF].
  - destruct H.
  - destruct (in_app_or _ _ _ H) as [H0 | H0].
    + exists a; simpl in |- *; auto.
    + destruct (HrecF H0) as [x Hx]; exists x; cbn; tauto.
Qed.

Definition In_freeVarSys (v : nat) (T : fol.System L) :=
  exists f : fol.Formula L, List.In v (freeVarFormula f) /\ mem _ T f.

Lemma notInFreeVarSys :
  forall x, ~ In_freeVarSys x (Ensembles.Empty_set (fol.Formula L)).
Proof.
  intros x; unfold In_freeVarSys in |- *.
  intros [? [? H0]]; destruct H0.
Qed.

End Free_Variables.

Section Substitution.

Fixpoint substituteTerm (s : fol.Term L) (x : nat)
  (t : fol.Term L) {struct s} : fol.Term L :=
  match s with
  | var v =>
      match eq_nat_dec x v with
      | left _ => t
      | right _ => var v
      end
  | apply f ts => apply f (substituteTerms _ ts x t)
  end
with substituteTerms (n : nat) (ss : fol.Terms L n)
       (x : nat) (t : fol.Term L) {struct ss} : fol.Terms L n :=
       match ss in (fol.Terms _ n0) return (fol.Terms L n0) with
       | Tnil => Tnil
       | Tcons m s ts =>
           Tcons  (substituteTerm s x t)
             (substituteTerms m ts x t)
       end.

Lemma subTermVar1 :
  forall (v : nat) (s : fol.Term L), substituteTerm (var v) v s = s.
Proof.
  intros v s;  unfold substituteTerm in |- *.
  destruct  (eq_nat_dec v v) as [e | b].
  - reflexivity.
  - now destruct b.
Qed.

Lemma subTermVar2 :
  forall (v x : nat) (s : fol.Term L),
    v <> x -> substituteTerm (var x) v s = var x.
Proof.
  intros v x s H; unfold substituteTerm in |- *.
  destruct (eq_nat_dec v x).
  - contradiction.
  - reflexivity.
Qed.

Lemma subTermFunction :
  forall (f : Functions L) (ts : fol.Terms L (arityF L f))
         (v : nat) (s : fol.Term L),
    substituteTerm (apply f ts) v s = apply f (substituteTerms _ ts v s).
Proof. reflexivity. Qed.

Definition newVar (l : list nat) : nat := fold_right Nat.max 0 (map S l).

Lemma newVar2 : forall (l : list nat) (n : nat), In n l -> n < newVar l.
Proof.
  induction l as [| a l Hrecl].
  - destruct 1.
  - destruct 1 as [H| H].
    + rewrite H; unfold newVar in |- *; simpl in |- *.
      induction (fold_right Nat.max 0 (map S l)).
      * apply Nat.lt_succ_diag_r .
      * apply Nat.lt_succ_r;  apply Nat.le_max_l.
    + unfold newVar in Hrecl |- *; simpl.
      assert
        (H0: fold_right Nat.max 0 (map S l) = 0 \/
               (exists n : nat, fold_right Nat.max 0 (map S l) = S n)).
      { induction (fold_right Nat.max 0 (map S l)) as [| n0 IHn0].
        - auto.
        - right; now exists n0.
      }
      destruct H0 as [H0| [x0 H0]].
      * rewrite H0; rewrite H0 in Hrecl.
        elim (Nat.nlt_0_r n (Hrecl _ H)).
      * rewrite H0; rewrite H0 in Hrecl.
        -- apply Nat.lt_le_trans with (S x0).
           ++ now apply Hrecl.
           ++ apply le_n_S, Nat.le_max_r.
Qed.

Lemma newVar1 : forall l : list nat, ~ In (newVar l) l.
Proof.
  intros l ?; elim (Nat.lt_irrefl (newVar l)); now apply newVar2.
Qed.

Definition substituteFormulaImp (f : fol.Formula L)
  (frec : nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L f})
  (g : fol.Formula L)
  (grec : nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L g})
  (p : nat * fol.Term L) :
  {y : fol.Formula L | depth L y = depth L (impH f g)} :=
  match frec p with
  | exist f' prf1 =>
      match grec p with
      | exist g' prf2 =>
          exist
            (fun y : fol.Formula L =>
               depth L y = S (Nat.max (depth L f) (depth L g)))
            (impH f' g')
            (eq_ind_r
               (fun n : nat =>
                  S (Nat.max n (depth L g')) =
                    S (Nat.max (depth L f) (depth L g)))
               (eq_ind_r
                  (fun n : nat =>
                     S (Nat.max (depth L f) n) =
                       S (Nat.max (depth L f) (depth L g)))
                  (refl_equal (S (Nat.max  (depth L f) (depth L g))))
                  prf2) prf1)
      end
  end.

Remark substituteFormulaImpNice :
  forall (f g : fol.Formula L)
         (z1 z2 : nat * fol.Term L ->
                  {y : fol.Formula L | depth L y = depth L f}),
    (forall q : nat * fol.Term L, z1 q = z2 q) ->
    forall
      z3 z4 : nat * fol.Term L ->
              {y : fol.Formula L | depth L y = depth L g},
      (forall q : nat * fol.Term L, z3 q = z4 q) ->
      forall q : nat * fol.Term L,
        substituteFormulaImp f z1 g z3 q =
          substituteFormulaImp f z2 g z4 q.
Proof.
  intros f g z1 z2 H z3 z4 H0 q; unfold substituteFormulaImp in |- *.
  rewrite H, H0; reflexivity.
Qed.

Definition substituteFormulaNot (f : fol.Formula L)
  (frec : nat * fol.Term L ->
          {y : fol.Formula L | depth L y = depth L f})
  (p : nat * fol.Term L) :
  {y : fol.Formula L | depth L y = depth L (notH f)} :=
  match frec p with
  | exist f' prf1 =>
      exist (fun y : fol.Formula L => depth L y = S (depth L f))
        (notH f')
        (eq_ind_r (fun n : nat => S n = S (depth L f))
           (refl_equal (S (depth L f))) prf1)
  end.

Remark substituteFormulaNotNice :
  forall (f : fol.Formula L)
         (z1 z2 : nat * fol.Term L ->
                  {y : fol.Formula L | depth L y = depth L f}),
    (forall q : nat * fol.Term L, z1 q = z2 q) ->
    forall q : nat * fol.Term L,
      substituteFormulaNot f z1 q = substituteFormulaNot f z2 q.
Proof.
  intros ? ? ? H ?; unfold substituteFormulaNot in |- *;
    now rewrite H.
Qed.

Definition substituteFormulaForall (n : nat) (f : fol.Formula L)
  (frec : forall b : fol.Formula L,
      lt_depth b (forallH n f) ->
      nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L b})
  (p : nat * fol.Term L) :
  {y : fol.Formula L | depth L y = depth L (forallH n f)} :=
  match p with
  | (v, s) =>
      match eq_nat_dec n v with
      | left _ =>
          exist (fun y : fol.Formula L => depth L y = S (depth L f))
            (forallH n f) (refl_equal (depth L (forallH n f)))
      | right _ =>
          match In_dec eq_nat_dec n (freeVarTerm s) with
          | left _ =>
              let nv := newVar (v :: freeVarTerm s ++ freeVarFormula f) in
              match frec f (depthForall L f n) (n, var nv) with
              | exist f' prf1 =>
                  match
                    frec f'
                      (eqDepth L f' f (forallH n f)
                         (sym_eq prf1) (depthForall L f n)) p
                  with
                  | exist f'' prf2 =>
                      exist
                        (fun y : fol.Formula L => depth L y = S (depth L f))
                        (forallH nv f'')
                        (eq_ind_r (fun n : nat => S n = S (depth L f))
                           (refl_equal (S (depth L f)))
                           (trans_eq prf2 prf1))
                  end
              end
          | right _ =>
              match frec f (depthForall L f n) p with
              | exist f' prf1 =>
                  exist (fun y : fol.Formula L => depth L y = S (depth L f))
                    (forallH n f')
                    (eq_ind_r (fun n : nat => S n = S (depth L f))
                       (refl_equal (S (depth L f))) prf1)
              end
          end
      end
  end.

Remark substituteFormulaForallNice :
  forall (v : nat) (a : fol.Formula L)
         (z1 z2 : forall b : fol.Formula L,
             lt_depth b (forallH v a) ->
             nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L b}),
    (forall (b : fol.Formula L) (q : lt_depth b (forallH v a))
            (r : nat * fol.Term L), z1 b q r = z2 b q r) ->
    forall q : nat * fol.Term L,
      substituteFormulaForall v a z1 q = substituteFormulaForall v a z2 q.
Proof.
  intros v a z1 z2 H [a0 b]; unfold substituteFormulaForall in |- *.
  destruct (eq_nat_dec v a0) as [e | n] ; simpl in |- *.
  - reflexivity.
  - induction (In_dec eq_nat_dec v (freeVarTerm b)); simpl in |- *.
    + rewrite H;
        destruct
          (z2 a (depthForall L a v)
             (v, var (newVar
                        (a0 :: freeVarTerm b ++ freeVarFormula a)))).
         now rewrite H.
    + now rewrite H.
Qed.

Definition substituteFormulaHelp (f : fol.Formula L)
  (v : nat) (s : fol.Term L) : {y : fol.Formula L | depth L y = depth L f}.
Proof.
  apply
    (Formula_depth_rec2 L
       (fun f : fol.Formula L =>
          nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L f})).
  - intros t t0 H; induction H as (a, b).
    exists (equal (substituteTerm t a b) (substituteTerm t0 a b)); auto.
  - intros r t H; induction H as (a, b).
    exists (atomic r (substituteTerms _ t a b)); auto.
  - exact substituteFormulaImp.
  - exact substituteFormulaNot.
  - exact substituteFormulaForall.
  - exact (v, s).
Defined.

Definition substituteFormula (f : fol.Formula L) (v : nat) (s : fol.Term L) :
  fol.Formula L := proj1_sig (substituteFormulaHelp f v s).

Lemma subFormulaEqual :
  forall (t1 t2 : fol.Term L) (v : nat) (s : fol.Term L),
    substituteFormula (equal t1 t2) v s =
      equal (substituteTerm t1 v s) (substituteTerm t2 v s).
Proof. reflexivity. Qed.

Lemma subFormulaRelation :
  forall (r : Relations L) (ts : fol.Terms L (arityR L r))
         (v : nat) (s : fol.Term L),
    substituteFormula (atomic r ts) v s =
      atomic r (substituteTerms (arityR L r) ts v s).
Proof. reflexivity. Qed.

Lemma subFormulaImp :
  forall (f1 f2 : fol.Formula L) (v : nat) (s : fol.Term L),
    substituteFormula (impH f1 f2) v s =
      impH (substituteFormula f1 v s) (substituteFormula f2 v s).
Proof.
  intros f1 f2 v s.
  unfold substituteFormula, substituteFormulaHelp in |- *.
  rewrite
    (Formula_depth_rec2_imp L)
    with
    (Q :=
       fun _ : fol.Formula L =>
         (nat * fol.Term L)%type)
    (P :=
       fun x : fol.Formula L =>
         {y : fol.Formula L | depth L y = depth L x}).
  unfold substituteFormulaImp at 1 in |- *.
  - induction
      (Formula_depth_rec2 L
         (fun x : fol.Formula L =>
            nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L x})
         (fun (t t0 : fol.Term L) (H : nat * fol.Term L) =>
            prod_rec
              (fun _ : nat * fol.Term L =>
                 {y : fol.Formula L | depth L y = depth L (equal  t t0)})
              (fun (a : nat) (b : fol.Term L) =>
                 exist
                   (fun y : fol.Formula L =>
                      depth L y = depth L (equal t t0))
                   (equal (substituteTerm t a b) (substituteTerm t0 a b))
                   (refl_equal (depth L (equal t t0)))) H)
         (fun (r : Relations L)
              (t : fol.Terms L (arityR L r))
              (H : nat * fol.Term L) =>
            prod_rec
              (fun _ : nat * fol.Term L =>
                 {y : fol.Formula L | depth L y = depth L (atomic r t)})
              (fun (a : nat) (b : fol.Term L) =>
                 exist
                   (fun y : fol.Formula L => depth L y =
                                               depth L (atomic r t))
                   (atomic r (substituteTerms (arityR L r)
                                t a b))
                   (refl_equal (depth L (atomic r t)))) H)
         substituteFormulaImp
         substituteFormulaNot substituteFormulaForall f1
         (v, s)).
    induction
      (Formula_depth_rec2 L
         (fun x0 : fol.Formula L =>
            nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L x0})
         (fun (t t0 : fol.Term L) (H : nat * fol.Term L) =>
            prod_rec
              (fun _ : nat * fol.Term L =>
                 {y : fol.Formula L | depth L y = depth L (equal t t0)})
              (fun (a : nat) (b : fol.Term L) =>
                 exist
                   (fun y : fol.Formula L =>
                      depth L y = depth L (equal t t0))
                   (equal (substituteTerm t a b) (substituteTerm t0 a b))
                   (refl_equal (depth L (equal t t0)))) H)
         (fun (r : Relations L)
              (t : fol.Terms L (arityR L r))
              (H : nat * fol.Term L) =>
            prod_rec
              (fun _ : nat * fol.Term L =>
                 {y : fol.Formula L | depth L y = depth L (atomic r t)})
              (fun (a : nat) (b : fol.Term L) =>
                 exist
                   (fun y : fol.Formula L =>
                      depth L y = depth L (atomic r t))
                   (atomic r (substituteTerms (arityR L r)
                                t a b))
                   (refl_equal (depth L (atomic r t)))) H)
         substituteFormulaImp
         substituteFormulaNot substituteFormulaForall f2
         (v, s)).
    reflexivity.
  - apply substituteFormulaImpNice.
  - apply substituteFormulaNotNice.
  - apply substituteFormulaForallNice.
Qed.

Lemma subFormulaNot :
  forall (f : fol.Formula L) (v : nat) (s : fol.Term L),
    substituteFormula (notH f) v s = notH (substituteFormula f v s).
Proof.
  intros f v s;
  unfold substituteFormula, substituteFormulaHelp.
  rewrite (Formula_depth_rec2_not L) with
    (Q := fun _ : fol.Formula L => (nat * fol.Term L)%type)
    (P := fun x : fol.Formula L =>
         {y : fol.Formula L | depth L y = depth L x}).
  - unfold substituteFormulaNot at 1 in |- *.
    induction
      (Formula_depth_rec2 L
         (fun x : fol.Formula L =>
            nat * fol.Term L -> {y : fol.Formula L | depth L y = depth L x})
         (fun (t t0 : fol.Term L) (H : nat * fol.Term L) =>
            prod_rec
              (fun _ : nat * fol.Term L =>
                 {y : fol.Formula L | depth L y = depth L (equal t t0)})
              (fun (a : nat) (b : fol.Term L) =>
                 exist
                   (fun y : fol.Formula L => depth L y =
                                               depth L (equal t t0))
                   (equal (substituteTerm t a b) (substituteTerm t0 a b))
                   (refl_equal (depth L (equal t t0)))) H)
         (fun (r : Relations L)
              (t : fol.Terms L (arityR L r))
              (H : nat * fol.Term L) =>
            prod_rec
              (fun _ : nat * fol.Term L =>
                 {y : fol.Formula L | depth L y = depth L (atomic r t)})
              (fun (a : nat) (b : fol.Term L) =>
                 exist
                   (fun y : fol.Formula L =>
                      depth L y = depth L (atomic r t))
                   (atomic r
                      (substituteTerms (arityR L r) t a b))
                   (refl_equal (depth L (atomic r t)))) H)
         substituteFormulaImp
         substituteFormulaNot substituteFormulaForall f
         (v, s)); reflexivity.
  - apply substituteFormulaImpNice.
  - apply substituteFormulaNotNice.
  - apply substituteFormulaForallNice.
Qed.

Lemma subFormulaForall :
  forall (f : fol.Formula L) (x v : nat) (s : fol.Term L),
    let nv := newVar (v :: freeVarTerm s ++ freeVarFormula f) in
    substituteFormula (forallH x f) v s =
      match eq_nat_dec x v with
      | left _ => forallH x f
      | right _ =>
          match In_dec eq_nat_dec x (freeVarTerm s) with
          | right _ => forallH x (substituteFormula f v s)
          | left _ =>
              forallH nv (substituteFormula
                            (substituteFormula f x (var nv)) v s)
          end
      end.
Proof.
  intros f x v s nv.
  unfold substituteFormula at 1 in |- *.
  unfold substituteFormulaHelp in |- *.
  rewrite (Formula_depth_rec2_forall L)
    with
    (Q :=
       fun _ : fol.Formula L =>
         (nat * fol.Term L)%type)
    (P :=
       fun x : fol.Formula L =>
         {y : fol.Formula L | depth L y = depth L x}).
  - simpl in |- *; induction (eq_nat_dec x v); simpl in |- *.
    + reflexivity.
    + induction (In_dec eq_nat_dec x (freeVarTerm s)); simpl in |- *.
      fold nv in |- *.
      unfold substituteFormula at 2 in |- *;
        unfold substituteFormulaHelp in |- *;
        simpl in |- *.
      * induction
          (Formula_depth_rec2 L
             (fun x0 : fol.Formula L =>
                nat * fol.Term L ->
                {y : fol.Formula L | depth L y = depth L x0})
             (fun (t t0 : fol.Term L) (H : nat * fol.Term L) =>
                prod_rec
                  (fun _ : nat * fol.Term L =>
                     {y : fol.Formula L | depth L y = 0})
                  (fun (a0 : nat) (b0 : fol.Term L) =>
                     exist (fun y : fol.Formula L => depth L y = 0)
                       (equal (substituteTerm t a0 b0)
                          (substituteTerm t0 a0 b0))
                       (refl_equal 0)) H)
             (fun (r : Relations L)
                  (t : fol.Terms L (arityR L r))
                  (H : nat * fol.Term L) =>
                prod_rec
                  (fun _ : nat * fol.Term L =>
                     {y : fol.Formula L | depth L y = 0})
                  (fun (a0 : nat) (b0 : fol.Term L) =>
                     exist (fun y : fol.Formula L => depth L y = 0)
                       (atomic r (substituteTerms
                                    (arityR L r) t a0 b0))
                       (refl_equal 0)) H) substituteFormulaImp
             substituteFormulaNot
             substituteFormulaForall f (x, var nv)).
        unfold substituteFormula in |- *; unfold substituteFormulaHelp in |- *;
          simpl in |- *.
        induction
          (Formula_depth_rec2 L
             (fun x1 : fol.Formula L =>
                nat * fol.Term L ->
                {y : fol.Formula L | depth L y = depth L x1})
             (fun (t t0 : fol.Term L) (H : nat * fol.Term L) =>
                prod_rec
                  (fun _ : nat * fol.Term L =>
                     {y : fol.Formula L | depth L y = 0})
                  (fun (a0 : nat) (b0 : fol.Term L) =>
                     exist (fun y : fol.Formula L => depth L y = 0)
                       (equal (substituteTerm t a0 b0)
                          (substituteTerm t0 a0 b0))
                       (refl_equal 0)) H)
             (fun (r : Relations L)
                  (t : fol.Terms L (arityR L r))
                  (H : nat * fol.Term L) =>
                prod_rec
                  (fun _ : nat * fol.Term L =>
                     {y : fol.Formula L | depth L y = 0})
                  (fun (a0 : nat) (b0 : fol.Term L) =>
                     exist (fun y : fol.Formula L => depth L y = 0)
                       (atomic r (substituteTerms
                                    (arityR L r) t a0 b0))
                       (refl_equal 0)) H) substituteFormulaImp
             substituteFormulaNot
             substituteFormulaForall x0 (v, s)).
        simpl in |- *; reflexivity.
      * unfold substituteFormula in |- *; unfold substituteFormulaHelp in |- *;
          simpl in |- *.
        induction
          (Formula_depth_rec2 L
             (fun x0 : fol.Formula L =>
                nat * fol.Term L ->
                {y : fol.Formula L | depth L y = depth L x0})
             (fun (t t0 : fol.Term L) (H : nat * fol.Term L) =>
                prod_rec
                  (fun _ : nat * fol.Term L =>
                     {y : fol.Formula L | depth L y = 0})
                  (fun (a : nat) (b1 : fol.Term L) =>
                     exist (fun y : fol.Formula L => depth L y = 0)
                       (equal (substituteTerm t a b1) (substituteTerm t0 a b1))
                       (refl_equal 0)) H)
             (fun (r : Relations L)
                  (t : fol.Terms L (arityR L r))
                  (H : nat * fol.Term L) =>
                prod_rec
                  (fun _ : nat * fol.Term L =>
                     {y : fol.Formula L | depth L y = 0})
                  (fun (a : nat) (b1 : fol.Term L) =>
                     exist (fun y : fol.Formula L => depth L y = 0)
                       (atomic r (substituteTerms
                                    (arityR L r) t a b1))
                       (refl_equal 0)) H) substituteFormulaImp
             substituteFormulaNot
             substituteFormulaForall f (v, s)).
        simpl in |- *; reflexivity.
  - apply substituteFormulaImpNice.
  - apply substituteFormulaNotNice.
  - apply substituteFormulaForallNice.
Qed.

Section Extensions.

Lemma subFormulaOr :
  forall (f1 f2 : fol.Formula L) (v : nat) (s : fol.Term L),
    substituteFormula (orH f1 f2) v s =
      orH (substituteFormula f1 v s) (substituteFormula f2 v s).
Proof.
  intros f1 f2 v s; unfold orH;
    now rewrite subFormulaImp, subFormulaNot.
Qed.

Lemma subFormulaAnd :
  forall (f1 f2 : fol.Formula L) (v : nat) (s : fol.Term L),
    substituteFormula (andH f1 f2) v s =
      andH (substituteFormula f1 v s) (substituteFormula f2 v s).
Proof.
  intros ? ? ? ?; unfold andH in |- *.
  rewrite subFormulaNot, subFormulaOr; now repeat rewrite subFormulaNot.
Qed.

Lemma subFormulaExist :
  forall (f : fol.Formula L) (x v : nat) (s : fol.Term L),
    let nv := newVar (v :: freeVarTerm s ++ freeVarFormula f) in
    substituteFormula (existH x f) v s =
      match eq_nat_dec x v with
      | left _ => existH x f
      | right _ =>
          match In_dec eq_nat_dec x (freeVarTerm s) with
          | right _ => existH x (substituteFormula f v s)
          | left _ =>
              existH nv (substituteFormula
                           (substituteFormula f x (var nv)) v s)
          end
      end.
Proof.
  intros ? ? ? ? nv; unfold existH.
  rewrite subFormulaNot, subFormulaForall.
  destruct (eq_nat_dec x v).
  - reflexivity.
  - induction (In_dec eq_nat_dec x (freeVarTerm s));
      now repeat rewrite subFormulaNot.
Qed.

Lemma subFormulaIff :
  forall (f1 f2 : fol.Formula L) (v : nat) (s : fol.Term L),
    substituteFormula (iffH f1 f2) v s =
      iffH (substituteFormula f1 v s) (substituteFormula f2 v s).
Proof.
  intros ? ? v s; unfold iffH in |- *.
  rewrite subFormulaAnd; now repeat rewrite subFormulaImp.
Qed.

Lemma subFormulaIfThenElse :
  forall (f1 f2 f3 : fol.Formula L) (v : nat) (s : fol.Term L),
    substituteFormula (ifThenElseH f1 f2 f3) v s =
      ifThenElseH (substituteFormula f1 v s) (substituteFormula f2 v s)
        (substituteFormula f3 v s).
Proof.
  intros ? ? ? ? ?; unfold ifThenElseH.
  now rewrite subFormulaAnd, !subFormulaImp,  subFormulaNot.
Qed.

End Extensions.

Lemma subFormulaDepth :
  forall (f : fol.Formula L) (v : nat) (s : fol.Term L),
    depth L (substituteFormula f v s) = depth L f.
Proof.
  intros f v s; unfold substituteFormula in |- *.
  induction (substituteFormulaHelp f v s) as [x p]; now simpl.
Qed.

Section Substitution_Properties.

Lemma subTermId :
  forall (t : fol.Term L) (v : nat), substituteTerm t v (var v) = t.
Proof.
  intros ? ?;
    elim t using Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
             substituteTerms n ts v (var v) = ts).
  - simpl in |- *; intros n.
    induction (eq_nat_dec v n) as [a | b].
    + now rewrite a.
    + reflexivity.
  -  intros f t0 H; simpl in |- *; now rewrite H.
  -  reflexivity.
  -  intros ? ? H t1 H0; simpl in |- *; now rewrite H, H0.
Qed.

Lemma subTermsId :
  forall (n : nat) (ts : fol.Terms L n) (v : nat),
    substituteTerms n ts v (var v) = ts.
Proof.
  intros n ts v; induction ts as [| n t ts Hrects].
  - reflexivity.
  - simpl in |- *;  now rewrite Hrects,  subTermId.
Qed.

Lemma subFormulaId :
  forall (f : fol.Formula L) (v : nat), substituteFormula f v (var v) = f.
Proof.
  intros f v.
  induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf].
  - now rewrite subFormulaEqual, !subTermId.
  - now rewrite subFormulaRelation, subTermsId.
  - now rewrite subFormulaImp, Hrecf1,  Hrecf0.
  - now rewrite subFormulaNot, Hrecf.
  - rewrite subFormulaForall; destruct  (eq_nat_dec n v) as [e|ne].
    + reflexivity.
    + induction (In_dec eq_nat_dec n (freeVarTerm (var v))) as [a|b].
      * elim ne; destruct a as [H| H].
        -- now subst.
        -- destruct H.
      * now rewrite Hrecf.
Qed.

Lemma subFormulaForall2 :
  forall (f : fol.Formula L) (x v : nat) (s : fol.Term L),
  exists nv : nat,
    ~ In nv (freeVarTerm s) /\
      nv <> v /\
      ~ In nv (List.remove  eq_nat_dec x (freeVarFormula f)) /\
      substituteFormula (forallH x f) v s =
        match eq_nat_dec x v with
        | left _ => forallH x f
        | right _ =>
            forallH nv (substituteFormula (substituteFormula f x (var nv)) v s)
        end.
Proof.
  intros f x v s; rewrite subFormulaForall.
  induction (eq_nat_dec x v) as [a | b].
  - set
      (A1 :=
         v :: freeVarTerm s ++ List.remove eq_nat_dec x (freeVarFormula f))
      in *.
    exists (newVar A1); repeat split.
    + unfold not in |- *; intros; elim (newVar1 A1).
      unfold A1 in |- *; right.
      apply in_or_app; auto.
    + unfold not in |- *; intros; elim (newVar1 A1).
      rewrite H; left; auto.
    + unfold not in |- *; intros; elim (newVar1 A1).
      right; apply in_or_app; auto.
  - induction (In_dec eq_nat_dec x (freeVarTerm s)) as [a | b0].
    + set (A1 := v :: freeVarTerm s ++ freeVarFormula f) in *.
      exists (newVar A1); repeat split.
      * unfold not in |- *; intros; elim (newVar1 A1); right.
        apply in_or_app; auto.
      * unfold not in |- *; intros; elim (newVar1 A1); rewrite H; left; auto.
      * unfold not in |- *; intros; elim (newVar1 A1); right;  apply in_or_app.
        right; eapply in_remove; apply H.
    + exists x; repeat split; auto.
      intro H; eapply (in_remove_neq _ _ _ _ _ H).
      * reflexivity.
      * now rewrite subFormulaId.
Qed.

Lemma subFormulaExist2 :
  forall (f : fol.Formula L) (x v : nat) (s : fol.Term L),
  exists nv : nat,
    ~ In nv (freeVarTerm s) /\
      nv <> v /\
      ~ In nv (List.remove eq_nat_dec x (freeVarFormula f)) /\
      substituteFormula (existH x f) v s =
        match eq_nat_dec x v with
        | left _ => existH x f
        | right _ =>
            existH nv (substituteFormula (substituteFormula f x (var nv)) v s)
        end.
Proof.
  intros f x v s; rewrite subFormulaExist.
  induction (eq_nat_dec x v) as [a | b].
  - set
      (A1 :=
         v :: freeVarTerm s ++ List.remove eq_nat_dec x (freeVarFormula f))
      in *.
    exists (newVar A1); repeat split.
    + unfold not in |- *; intros; elim (newVar1 A1).
      unfold A1 in |- *; right; apply in_or_app; auto.
    + unfold not in |- *; intros; elim (newVar1 A1); rewrite H; now left.
    + unfold not in |- *; intros; elim (newVar1 A1); right; apply in_or_app;
        auto.
  - induction (In_dec eq_nat_dec x (freeVarTerm s)) as [a | b0].
    + set (A1 := v :: freeVarTerm s ++ freeVarFormula f) in *.
      exists (newVar A1);  repeat split.
      * unfold not in |- *; intros; elim (newVar1 A1); right; apply in_or_app; auto.
      * unfold not in |- *; intros; elim (newVar1 A1); rewrite H; left; auto.
      * unfold not in |- *; intros; elim (newVar1 A1); right;  apply in_or_app.
        right; eapply in_remove; apply H.
    + exists x; repeat split; auto.
      intros H; eapply (in_remove_neq _ _ _ _ _ H).
      * reflexivity.
      * rewrite subFormulaId; auto.
Qed.

End Substitution_Properties.

End Substitution.

Definition Sentence (f:Formula) := (forall v : nat, ~ In v (freeVarFormula f)).

End Fol_Properties.


(** * Poly: Polymorphism and Higher-Order Functions *)

(* Final reminder: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)

   Require Export Lists.

   (* ################################################################# *)
   (** * Polymorphism *)

   (** In this chapter we continue our development of basic
       concepts of functional programming.  The critical new ideas are
       _polymorphism_ (abstracting functions over the types of the data
       they manipulate) and _higher-order functions_ (treating functions
       as data).  We begin with polymorphism. *)

   (* ================================================================= *)
   (** ** Polymorphic Lists *)

   (** For the last couple of chapters, we've been working just
       with lists of numbers.  Obviously, interesting programs also need
       to be able to manipulate lists with elements from other types --
       lists of strings, lists of booleans, lists of lists, etc.  We
       _could_ just define a new inductive datatype for each of these,
       for example... *)

   Inductive boollist : Type :=
     | bool_nil : boollist
     | bool_cons : bool -> boollist -> boollist.

   (** ... but this would quickly become tedious, partly because we
       have to make up different constructor names for each datatype, but
       mostly because we would also need to define new versions of all
       our list manipulating functions ([length], [rev], etc.) for each
       new datatype definition. *)

   (** To avoid all this repetition, Coq supports _polymorphic_
       inductive type definitions.  For example, here is a _polymorphic
       list_ datatype. *)

   Inductive list (X:Type) : Type :=
     | nil : list X
     | cons : X -> list X -> list X.

   (** This is exactly like the definition of [natlist] from the
       previous chapter, except that the [nat] argument to the [cons]
       constructor has been replaced by an arbitrary type [X], a binding
       for [X] has been added to the header, and the occurrences of
       [natlist] in the types of the constructors have been replaced by
       [list X].  (We can re-use the constructor names [nil] and [cons]
       because the earlier definition of [natlist] was inside of a
       [Module] definition that is now out of scope.)

       What sort of thing is [list] itself?  One good way to think
       about it is that [list] is a _function_ from [Type]s to
       [Inductive] definitions; or, to put it another way, [list] is a
       function from [Type]s to [Type]s.  For any particular type [X],
       the type [list X] is an [Inductive]ly defined set of lists whose
       elements are of type [X]. *)

   (** With this definition, when we use the constructors [nil] and
       [cons] to build lists, we need to tell Coq the type of the
       elements in the lists we are building -- that is, [nil] and [cons]
       are now _polymorphic constructors_.  Observe the types of these
       constructors: *)

   Check nil.
   (* ===> nil : forall X : Type, list X *)
   Check cons.
   (* ===> cons : forall X : Type, X -> list X -> list X *)

   (** (Side note on notation: In .v files, the "forall" quantifier
       is spelled out in letters.  In the generated HTML files and in the
       way various IDEs show .v files (with certain settings of their
       display controls), [forall] is usually typeset as the usual
       mathematical "upside down A," but you'll still see the spelled-out
       "forall" in a few places.  This is just a quirk of typesetting:
       there is no difference in meaning.) *)

   (** The "[forall X]" in these types can be read as an additional
       argument to the constructors that determines the expected types of
       the arguments that follow.  When [nil] and [cons] are used, these
       arguments are supplied in the same way as the others.  For
       example, the list containing [2] and [1] is written like this: *)

   Check (cons nat 2 (cons nat 1 (nil nat))).

   (** (We've written [nil] and [cons] explicitly here because we haven't
       yet defined the [ [] ] and [::] notations for the new version of
       lists.  We'll do that in a bit.) *)

   (** We can now go back and make polymorphic versions of all the
       list-processing functions that we wrote before.  Here is [repeat],
       for example: *)

   Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
     match count with
     | 0 => nil X
     | S count' => cons X x (repeat X x count')
     end.

   (** As with [nil] and [cons], we can use [repeat] by applying it
       first to a type and then to its list argument: *)

   Example test_repeat1 :
     repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
   Proof. reflexivity.  Qed.

   (** To use [repeat] to build other kinds of lists, we simply
       instantiate it with an appropriate type parameter: *)

   Example test_repeat2 :
     repeat bool false 1 = cons bool false (nil bool).
   Proof. reflexivity.  Qed.

   Module MumbleGrumble.

   (** **** Exercise: 2 starsM (mumble_grumble)  *)
   (** Consider the following two inductively defined types. *)

   Inductive mumble : Type :=
     | a : mumble
     | b : mumble -> nat -> mumble
     | c : mumble.

   Inductive grumble (X:Type) : Type :=
     | d : mumble -> grumble X
     | e : X -> grumble X.

  Check (d mumble (b a 5)).
  Check (d bool (b a 5)).
  Check (e bool true).
  Check (e mumble (b c 0)).
  Check c.

   (** Which of the following are well-typed elements of [grumble X] for
       some type [X]?
         - [d (b a 5)]
         - [d mumble (b a 5)]
         - [d bool (b a 5)]
         - [e bool true]
         - [e mumble (b c 0)]
         - [e bool (b c 0)]
         - [c]
   (* FILL IN HERE *)
   *)
   (** [] *)

   End MumbleGrumble.

   (* ----------------------------------------------------------------- *)
   (** *** Type Annotation Inference *)

   (** Let's write the definition of [repeat] again, but this time we
       won't specify the types of any of the arguments.  Will Coq still
       accept it? *)

   Fixpoint repeat' X x count : list X :=
     match count with
     | 0        => nil X
     | S count' => cons X x (repeat' X x count')
     end.

   (** Indeed it will.  Let's see what type Coq has assigned to [repeat']: *)

   Check repeat'.
   (* ===> forall X : Type, X -> nat -> list X *)
   Check repeat.
   (* ===> forall X : Type, X -> nat -> list X *)

   (** It has exactly the same type type as [repeat].  Coq was able
       to use _type inference_ to deduce what the types of [X], [x], and
       [count] must be, based on how they are used.  For example, since
       [X] is used as an argument to [cons], it must be a [Type], since
       [cons] expects a [Type] as its first argument; matching [count]
       with [0] and [S] means it must be a [nat]; and so on.

       This powerful facility means we don't always have to write
       explicit type annotations everywhere, although explicit type
       annotations are still quite useful as documentation and sanity
       checks, so we will continue to use them most of the time.  You
       should try to find a balance in your own code between too many
       type annotations (which can clutter and distract) and too
       few (which forces readers to perform type inference in their heads
       in order to understand your code). *)

   (* ----------------------------------------------------------------- *)
   (** *** Type Argument Synthesis *)

   (** To use a polymorphic function, we need to pass it one or
       more types in addition to its other arguments.  For example, the
       recursive call in the body of the [repeat] function above must
       pass along the type [X].  But since the second argument to
       [repeat] is an element of [X], it seems entirely obvious that the
       first argument can only be [X] -- why should we have to write it
       explicitly?

       Fortunately, Coq permits us to avoid this kind of redundancy.  In
       place of any type argument we can write the "implicit argument"
       [_], which can be read as "Please try to figure out for yourself
       what belongs here."  More precisely, when Coq encounters a [_], it
       will attempt to _unify_ all locally available information -- the
       type of the function being applied, the types of the other
       arguments, and the type expected by the context in which the
       application appears -- to determine what concrete type should
       replace the [_].

       This may sound similar to type annotation inference -- indeed, the
       two procedures rely on the same underlying mechanisms.  Instead of
       simply omitting the types of some arguments to a function, like

         repeat' X x count : list X :=

       we can also replace the types with [_]

         repeat' (X : _) (x : _) (count : _) : list X :=

       to tell Coq to attempt to infer the missing information.

       Using implicit arguments, the [count] function can be written like
       this: *)

   Fixpoint repeat'' X x count : list X :=
     match count with
     | 0        => nil _
     | S count' => cons _ x (repeat'' _ x count')
     end.

   (** In this instance, we don't save much by writing [_] instead of
       [X].  But in many cases the difference in both keystrokes and
       readability is nontrivial.  For example, suppose we want to write
       down a list containing the numbers [1], [2], and [3].  Instead of
       writing this... *)

   Definition list123 :=
     cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

   (** ...we can use argument synthesis to write this: *)

   Definition list123' :=
     cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

   (* ----------------------------------------------------------------- *)
   (** *** Implicit Arguments *)

   (** We can go further and even avoid writing [_]'s in most cases by
       telling Coq _always_ to infer the type argument(s) of a given
       function.  The [Arguments] directive specifies the name of the
       function (or constructor) and then lists its argument names, with
       curly braces around any arguments to be treated as implicit.  (If
       some arguments of a definition don't have a name, as is often the
       case for constructors, they can be marked with a wildcard pattern
       [_].) *)

   Arguments nil {X}.
   Arguments cons {X} _ _.
   Arguments repeat {X} x count.

   (** Now, we don't have to supply type arguments at all: *)

   Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

   (** Alternatively, we can declare an argument to be implicit
       when defining the function itself, by surrounding it in curly
       braces instead of parens.  For example: *)

   Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
     match count with
     | 0        => nil
     | S count' => cons x (repeat''' x count')
     end.

   (** (Note that we didn't even have to provide a type argument to the
       recursive call to [repeat''']; indeed, it would be invalid to
       provide one!)

       We will use the latter style whenever possible, but we will
       continue to use use explicit [Argument] declarations for
       [Inductive] constructors.  The reason for this is that marking the
       parameter of an inductive type as implicit causes it to become
       implicit for the type itself, not just for its constructors.  For
       instance, consider the following alternative definition of the
       [list] type: *)

   Inductive list' {X:Type} : Type :=
     | nil' : list'
     | cons' : X -> list' -> list'.

   (** Because [X] is declared as implicit for the _entire_ inductive
       definition including [list'] itself, we now have to write just
       [list'] whether we are talking about lists of numbers or booleans
       or anything else, rather than [list' nat] or [list' bool] or
       whatever; this is a step too far. *)

   (** Let's finish by re-implementing a few other standard list
       functions on our new polymorphic lists... *)

   Fixpoint app {X : Type} (l1 l2 : list X)
                : (list X) :=
     match l1 with
     | nil      => l2
     | cons h t => cons h (app t l2)
     end.

   Fixpoint rev {X:Type} (l:list X) : list X :=
     match l with
     | nil      => nil
     | cons h t => app (rev t) (cons h nil)
     end.

   Fixpoint length {X : Type} (l : list X) : nat :=
     match l with
     | nil => 0
     | cons _ l' => S (length l')
     end.

   Example test_rev1 :
     rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
   Proof. reflexivity.  Qed.

   Example test_rev2:
     rev (cons true nil) = cons true nil.
   Proof. reflexivity.  Qed.

   Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
   Proof. reflexivity.  Qed.

   (* ----------------------------------------------------------------- *)
   (** *** Supplying Type Arguments Explicitly *)

   (** One small problem with declaring arguments [Implicit] is
       that, occasionally, Coq does not have enough local information to
       determine a type argument; in such cases, we need to tell Coq that
       we want to give the argument explicitly just this time.  For
       example, suppose we write this: *)

   Fail Definition mynil := nil.

   (** (The [Fail] qualifier that appears before [Definition] can be
       used with _any_ command, and is used to ensure that that command
       indeed fails when executed. If the command does fail, Coq prints
       the corresponding error message, but continues processing the rest
       of the file.)

       Here, Coq gives us an error because it doesn't know what type
       argument to supply to [nil].  We can help it by providing an
       explicit type declaration (so that Coq has more information
       available when it gets to the "application" of [nil]): *)

   Definition mynil : list nat := nil.

   (** Alternatively, we can force the implicit arguments to be explicit by
      prefixing the function name with [@]. *)

   Check @nil.

   Definition mynil' := @nil nat.

   (** Using argument synthesis and implicit arguments, we can
       define convenient notation for lists, as before.  Since we have
       made the constructor type arguments implicit, Coq will know to
       automatically infer these when we use the notations. *)

   Notation "x :: y" := (cons x y)
                        (at level 60, right associativity).
   Notation "[ ]" := nil.
   Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
   Notation "x ++ y" := (app x y)
                        (at level 60, right associativity).

   (** Now lists can be written just the way we'd hope: *)

   Definition list123''' := [1; 2; 3].

   (* ----------------------------------------------------------------- *)
   (** *** Exercises *)

   (** **** Exercise: 2 stars, optional (poly_exercises)  *)
   (** Here are a few simple exercises, just like ones in the [Lists]
       chapter, for practice with polymorphism.  Complete the proofs below. *)

   Theorem app_nil_r : forall (X:Type), forall l:list X,
     l ++ [] = l.
   Proof.
     intros X l.
     induction l as [| h t IHl'].
     - simpl. reflexivity.
     - simpl.  rewrite -> IHl'. reflexivity.
    Qed.

   Theorem app_assoc : forall A (l m n:list A),
     l ++ m ++ n = (l ++ m) ++ n.
   Proof.
     intros A l m n.
     induction l as [| h t IHl].
     - simpl. reflexivity.
     - simpl. rewrite <- IHl. reflexivity.
    Qed.

   Lemma app_length : forall (X:Type) (l1 l2 : list X),
     length (l1 ++ l2) = length l1 + length l2.
   Proof.
     intros X l1 l2.
     induction l1 as [| h t IHl'].
     - simpl. reflexivity.
     - simpl. rewrite <- IHl'. reflexivity.
    Qed.
   (** [] *)

   (** **** Exercise: 2 stars, optional (more_poly_exercises)  *)
   (** Here are some slightly more interesting ones... *)

   Theorem rev_app_distr: forall X (l1 l2 : list X),
     rev (l1 ++ l2) = rev l2 ++ rev l1.
   Proof.
     intros X l1 l2.
     induction l1 as [| h t IHl].
     - simpl. rewrite -> app_nil_r. reflexivity.
     - simpl. rewrite -> IHl. rewrite -> app_assoc. reflexivity.
    Qed.

   Theorem rev_involutive : forall X : Type, forall l : list X,
     rev (rev l) = l.
   Proof.
     intros X l.
     induction l as [| h t IHl].
     - simpl. reflexivity.
     - simpl. rewrite -> rev_app_distr. rewrite -> IHl. simpl. reflexivity.
    Qed.
   (** [] *)

   (* ================================================================= *)
   (** ** Polymorphic Pairs *)

   (** Following the same pattern, the type definition we gave in
       the last chapter for pairs of numbers can be generalized to
       _polymorphic pairs_, often called _products_: *)

   Inductive prod (X Y : Type) : Type :=
   | pair : X -> Y -> prod X Y.

   Arguments pair {X} {Y} _ _.

   (** As with lists, we make the type arguments implicit and define the
       familiar concrete notation. *)

   Notation "( x , y )" := (pair x y).

   (** We can also use the [Notation] mechanism to define the standard
       notation for product _types_: *)

   Notation "X * Y" := (prod X Y) : type_scope.

   (** (The annotation [: type_scope] tells Coq that this abbreviation
       should only be used when parsing types.  This avoids a clash with
       the multiplication symbol.) *)

   (** It is easy at first to get [(x,y)] and [X*Y] confused.
       Remember that [(x,y)] is a _value_ built from two other values,
       while [X*Y] is a _type_ built from two other types.  If [x] has
       type [X] and [y] has type [Y], then [(x,y)] has type [X*Y]. *)

   (** The first and second projection functions now look pretty
       much as they would in any functional programming language. *)

   Definition fst {X Y : Type} (p : X * Y) : X :=
     match p with
     | (x, y) => x
     end.

   Definition snd {X Y : Type} (p : X * Y) : Y :=
     match p with
     | (x, y) => y
     end.

   (** The following function takes two lists and combines them
       into a list of pairs.  In other functional languages, it is often
       called [zip]; we call it [combine] for consistency with Coq's
       standard library. *)

   Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
              : list (X*Y) :=
     match lx, ly with
     | [], _ => []
     | _, [] => []
     | x :: tx, y :: ty => (x, y) :: (combine tx ty)
     end.

   (** **** Exercise: 1 star, optionalM (combine_checks)  *)
   (** Try answering the following questions on paper and
       checking your answers in coq:
       - What is the type of [combine] (i.e., what does [Check
         @combine] print?)
       - What does

           Compute (combine [1;2] [false;false;true;true]).

         print? *)
   (** combine :: forall X Y : type, list X->list Y->list (X * Y) *)
   Check combine.
   (** [(1,false),(2,false)] *)
   Compute (combine [1;2] [false;false;true;true]).
   (** **** Exercise: 2 stars, recommended (split)  *)
   (** The function [split] is the right inverse of [combine]: it takes a
       list of pairs and returns a pair of lists.  In many functional
       languages, it is called [unzip].

       Fill in the definition of [split] below.  Make sure it passes the
       given unit test. *)

   Fixpoint split {X Y : Type} (l : list (X*Y))
                  : (list X) * (list Y) :=
      match l with
      | nil => (nil, nil)
      | h :: t => ((fst h) :: fst (split t), (snd h) :: snd (split t))
      end.

   Example test_split:
     split [(1,false);(2,false)] = ([1;2],[false;false]).
   Proof.
    simpl.
    reflexivity.
  Qed.
   (** [] *)

   (* ================================================================= *)
   (** ** Polymorphic Options *)

   (** One last polymorphic type for now: _polymorphic options_,
       which generalize [natoption] from the previous chapter: *)

   Inductive option (X:Type) : Type :=
     | Some : X -> option X
     | None : option X.

   Arguments Some {X} _.
   Arguments None {X}.

   (** We can now rewrite the [nth_error] function so that it works
       with any type of lists. *)

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

   Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
   Proof. reflexivity. Qed.
   Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
   Proof. reflexivity. Qed.
   Example test_nth_error3 : nth_error [true] 2 = None.
   Proof. reflexivity. Qed.

   (** **** Exercise: 1 star, optional (hd_error_poly)  *)
   (** Complete the definition of a polymorphic version of the
       [hd_error] function from the last chapter. Be sure that it
       passes the unit tests below. *)

   Definition hd_error {X : Type} (l : list X) : option X :=
     match l with
     | nil => None
     | h :: t => Some h
    end.

   (** Once again, to force the implicit arguments to be explicit,
       we can use [@] before the name of the function. *)

   Check @hd_error.

   Example test_hd_error1 : hd_error [1;2] = Some 1.
   Proof.
     simpl.
     reflexivity.
    Qed.
   Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
   Proof.
     simpl.
     reflexivity.
    Qed.
   (** [] *)

   (* ################################################################# *)
   (** * Functions as Data *)

   (** Like many other modern programming languages -- including
       all functional languages (ML, Haskell, Scheme, Scala, Clojure,
       etc.) -- Coq treats functions as first-class citizens, allowing
       them to be passed as arguments to other functions, returned as
       results, stored in data structures, etc.*)

   (* ================================================================= *)
   (** ** Higher-Order Functions *)

   (** Functions that manipulate other functions are often called
       _higher-order_ functions.  Here's a simple one: *)

   Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
     f (f (f n)).

   (** The argument [f] here is itself a function (from [X] to
       [X]); the body of [doit3times] applies [f] three times to some
       value [n]. *)

   Check @doit3times.
   (* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

   Example test_doit3times: doit3times minustwo 9 = 3.
   Proof. reflexivity.  Qed.

   Example test_doit3times': doit3times negb true = false.
   Proof. reflexivity.  Qed.

   (* ================================================================= *)
   (** ** Filter *)

   (** Here is a more useful higher-order function, taking a list
       of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
       and "filtering" the list, returning a new list containing just
       those elements for which the predicate returns [true]. *)

   Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                   : (list X) :=
     match l with
     | []     => []
     | h :: t => if test h then h :: (filter test t)
                           else       filter test t
     end.

   (** For example, if we apply [filter] to the predicate [evenb]
       and a list of numbers [l], it returns a list containing just the
       even members of [l]. *)

   Example test_filter1: filter evenb [1;2;3;4] = [2;4].
   Proof. reflexivity.  Qed.

   Definition length_is_1 {X : Type} (l : list X) : bool :=
     beq_nat (length l) 1.

   Example test_filter2:
       filter length_is_1
              [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
     = [ [3]; [4]; [8] ].
   Proof. reflexivity.  Qed.

   (** We can use [filter] to give a concise version of the
       [countoddmembers] function from the [Lists] chapter. *)

   Definition countoddmembers' (l:list nat) : nat :=
     length (filter oddb l).

   Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4.
   Proof. reflexivity.  Qed.
   Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0.
   Proof. reflexivity.  Qed.
   Example test_countoddmembers'3:   countoddmembers' nil = 0.
   Proof. reflexivity.  Qed.

   (* ================================================================= *)
   (** ** Anonymous Functions *)

   (** It is arguably a little sad, in the example just above, to
       be forced to define the function [length_is_1] and give it a name
       just to be able to pass it as an argument to [filter], since we
       will probably never use it again.  Moreover, this is not an
       isolated example: when using higher-order functions, we often want
       to pass as arguments "one-off" functions that we will never use
       again; having to give each of these functions a name would be
       tedious.

       Fortunately, there is a better way.  We can construct a function
       "on the fly" without declaring it at the top level or giving it a
       name. *)

   Example test_anon_fun':
     doit3times (fun n => n * n) 2 = 256.
   Proof. reflexivity.  Qed.

   (** The expression [(fun n => n * n)] can be read as "the function
       that, given a number [n], yields [n * n]." *)

   (** Here is the [filter] example, rewritten to use an anonymous
       function. *)

   Example test_filter2':
       filter (fun l => beq_nat (length l) 1)
              [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
     = [ [3]; [4]; [8] ].
   Proof. reflexivity.  Qed.

   (** **** Exercise: 2 stars (filter_even_gt7)  *)
   (** Use [filter] (instead of [Fixpoint]) to write a Coq function
       [filter_even_gt7] that takes a list of natural numbers as input
       and returns a list of just those that are even and greater than
       7. *)

   Definition filter_even_gt7 (l : list nat) : list nat :=
     filter (fun n => (negb (oddb n) && (leb 8 n))) l.

   Example test_filter_even_gt7_1 :
     filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
   Proof.
     reflexivity.
   Qed.

   Example test_filter_even_gt7_2 :
     filter_even_gt7 [5;2;6;19;129] = [].
  Proof.
    reflexivity.
  Qed.
   (** [] *)

   (** **** Exercise: 3 stars (partition)  *)
   (** Use [filter] to write a Coq function [partition]:

         partition : forall X : Type,
                     (X -> bool) -> list X -> list X * list X

      Given a set [X], a test function of type [X -> bool] and a [list
      X], [partition] should return a pair of lists.  The first member of
      the pair is the sublist of the original list containing the
      elements that satisfy the test, and the second is the sublist
      containing those that fail the test.  The order of elements in the
      two sublists should be the same as their order in the original
      list. *)

   Definition partition {X : Type}
                        (test : X -> bool)
                        (l : list X)
                      : list X * list X :=
   (filter test l, filter (fun x => negb (test x)) l).

   Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
   Proof. reflexivity. Qed.
   Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
   Proof. reflexivity. Qed.
   (** [] *)

   (* ================================================================= *)
   (** ** Map *)

   (** Another handy higher-order function is called [map]. *)

   Fixpoint map {X Y:Type} (f:X->Y) (l:list X) : (list Y) :=
     match l with
     | []     => []
     | h :: t => (f h) :: (map f t)
     end.

   (** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
       and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
       been applied to each element of [l] in turn.  For example: *)

   Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
   Proof. reflexivity.  Qed.

   (** The element types of the input and output lists need not be
       the same, since [map] takes _two_ type arguments, [X] and [Y]; it
       can thus be applied to a list of numbers and a function from
       numbers to booleans to yield a list of booleans: *)

   Example test_map2:
     map oddb [2;1;2;5] = [false;true;false;true].
   Proof. reflexivity.  Qed.

   (** It can even be applied to a list of numbers and
       a function from numbers to _lists_ of booleans to
       yield a _list of lists_ of booleans: *)

   Example test_map3:
       map (fun n => [evenb n;oddb n]) [2;1;2;5]
     = [[true;false];[false;true];[true;false];[false;true]].
   Proof. reflexivity.  Qed.

   (* ----------------------------------------------------------------- *)
   (** *** Exercises *)

   (** **** Exercise: 3 stars (map_rev)  *)
   (** Show that [map] and [rev] commute.  You may need to define an
       auxiliary lemma. *)

   Lemma map_dis : forall (X Y : Type) (f : X -> Y) (l : list X) (x : X),
    map f (l ++ [x]) = map f l ++ [f x].
   Proof.
     intros X Y f l x.
     induction l as [| h t IHl].
     - simpl. reflexivity.
     - simpl. rewrite -> IHl. reflexivity.
   Qed.

   Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
     map f (rev l) = rev (map f l).
   Proof.
     intros X Y f l.
     induction l as [| h t IHl].
     - simpl. reflexivity.
     - simpl. rewrite <- IHl. rewrite <- map_dis. reflexivity.
    Qed.

   (** [] *)

   (** **** Exercise: 2 stars, recommended (flat_map)  *)
   (** The function [map] maps a [list X] to a [list Y] using a function
       of type [X -> Y].  We can define a similar function, [flat_map],
       which maps a [list X] to a [list Y] using a function [f] of type
       [X -> list Y].  Your definition should work by 'flattening' the
       results of [f], like so:

           flat_map (fun n => [n;n+1;n+2]) [1;5;10]
         = [1; 2; 3; 5; 6; 7; 10; 11; 12].
   *)

   Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                      : (list Y) :=
    match l with
    | [] => []
    | h :: t => (f h) ++ (flat_map f t)
    end.

   Example test_flat_map1:
     flat_map (fun n => [n;n;n]) [1;5;4]
     = [1; 1; 1; 5; 5; 5; 4; 4; 4].
   Proof.
    simpl.
    reflexivity.
   Qed.
   (** [] *)

   (** Lists are not the only inductive type that we can write a
       [map] function for.  Here is the definition of [map] for the
       [option] type: *)

   Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                         : option Y :=
     match xo with
       | None => None
       | Some x => Some (f x)
     end.

   (** **** Exercise: 2 stars, optional (implicit_args)  *)
   (** The definitions and uses of [filter] and [map] use implicit
       arguments in many places.  Replace the curly braces around the
       implicit arguments with parentheses, and then fill in explicit
       type parameters where necessary and use Coq to check that you've
       done so correctly.  (This exercise is not to be turned in; it is
       probably easiest to do it on a _copy_ of this file that you can
       throw away afterwards.)  [] *)

   (* ================================================================= *)
   (** ** Fold *)

   (** An even more powerful higher-order function is called
       [fold].  This function is the inspiration for the "[reduce]"
       operation that lies at the heart of Google's map/reduce
       distributed programming framework. *)

   Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y)
                            : Y :=
     match l with
     | nil => b
     | h :: t => f h (fold f t b)
     end.

   (** Intuitively, the behavior of the [fold] operation is to
       insert a given binary operator [f] between every pair of elements
       in a given list.  For example, [ fold plus [1;2;3;4] ] intuitively
       means [1+2+3+4].  To make this precise, we also need a "starting
       element" that serves as the initial second input to [f].  So, for
       example,

          fold plus [1;2;3;4] 0

       yields

          1 + (2 + (3 + (4 + 0))).

       Some more examples: *)

   Check (fold andb).
   (* ===> fold andb : list bool -> bool -> bool *)

   Example fold_example1 :
     fold mult [1;2;3;4] 1 = 24.
   Proof. reflexivity. Qed.

   Example fold_example2 :
     fold andb [true;true;false;true] true = false.
   Proof. reflexivity. Qed.

   Example fold_example3 :
     fold app  [[1];[];[2;3];[4]] [] = [1;2;3;4].
   Proof. reflexivity. Qed.

   (** **** Exercise: 1 star, advancedM (fold_types_different)  *)
   (** Observe that the type of [fold] is parameterized by _two_ type
       variables, [X] and [Y], and the parameter [f] is a binary operator
       that takes an [X] and a [Y] and returns a [Y].  Can you think of a
       situation where it would be useful for [X] and [Y] to be
       different? *)

   (* FILL IN HERE *)
   (** [] *)

   (* ================================================================= *)
   (** ** Functions That Construct Functions *)

   (** Most of the higher-order functions we have talked about so
       far take functions as arguments.  Let's look at some examples that
       involve _returning_ functions as the results of other functions.
       To begin, here is a function that takes a value [x] (drawn from
       some type [X]) and returns a function from [nat] to [X] that
       yields [x] whenever it is called, ignoring its [nat] argument. *)

   Definition constfun {X: Type} (x: X) : nat->X :=
     fun (k:nat) => x.

   Definition ftrue := constfun true.

   Example constfun_example1 : ftrue 0 = true.
   Proof. reflexivity. Qed.

   Example constfun_example2 : (constfun 5) 99 = 5.
   Proof. reflexivity. Qed.

   (** In fact, the multiple-argument functions we have already
       seen are also examples of passing functions as data.  To see why,
       recall the type of [plus]. *)

   Check plus.
   (* ==> nat -> nat -> nat *)

   (** Each [->] in this expression is actually a _binary_ operator
       on types.  This operator is _right-associative_, so the type of
       [plus] is really a shorthand for [nat -> (nat -> nat)] -- i.e., it
       can be read as saying that "[plus] is a one-argument function that
       takes a [nat] and returns a one-argument function that takes
       another [nat] and returns a [nat]."  In the examples above, we
       have always applied [plus] to both of its arguments at once, but
       if we like we can supply just the first.  This is called _partial
       application_. *)

   Definition plus3 := plus 3.
   Check plus3.

   Example test_plus3 :    plus3 4 = 7.
   Proof. reflexivity.  Qed.
   Example test_plus3' :   doit3times plus3 0 = 9.
   Proof. reflexivity.  Qed.
   Example test_plus3'' :  doit3times (plus 3) 0 = 9.
   Proof. reflexivity.  Qed.

   (* ################################################################# *)
   (** * Additional Exercises *)

   Module Exercises.

   (** **** Exercise: 2 stars (fold_length)  *)
   (** Many common functions on lists can be implemented in terms of
      [fold].  For example, here is an alternative definition of [length]: *)

   Definition fold_length {X : Type} (l : list X) : nat :=
     fold (fun _ n => S n) l 0.

   Example test_fold_length1 : fold_length [4;7;0] = 3.
   Proof. reflexivity. Qed.

   (** Prove the correctness of [fold_length]. *)

   Theorem fold_length_correct : forall X (l : list X),
     fold_length l = length l.
   Proof.
     intros X l.
     induction l as [| h t IHl].
     - simpl. reflexivity.
     - simpl. rewrite <- IHl. reflexivity.
    Qed.

   (** [] *)

   (** **** Exercise: 3 starsM (fold_map)  *)
   (** We can also define [map] in terms of [fold].  Finish [fold_map]
       below. *)

   Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
     fold (fun n p => ((f n) :: p)) l [].

   (** Write down a theorem [fold_map_correct] in Coq stating that
      [fold_map] is correct, and prove it. *)

   (* FILL IN HERE *)
   Theorem fold_map_correct : forall (X Y : Type) (f : X -> Y) (l : list X),
    fold_map f l = map f l.
   Proof.
     intros X Y f l.
     induction l as [| h t IHl].
     - simpl. reflexivity.
     - simpl. rewrite <- IHl. reflexivity.
   Qed.

   (** **** Exercise: 2 stars, advanced (currying)  *)
   (** In Coq, a function [f : A -> B -> C] really has the type [A
       -> (B -> C)].  That is, if you give [f] a value of type [A], it
       will give you function [f' : B -> C].  If you then give [f'] a
       value of type [B], it will return a value of type [C].  This
       allows for partial application, as in [plus3].  Processing a list
       of arguments with functions that return functions is called
       _currying_, in honor of the logician Haskell Curry.

       Conversely, we can reinterpret the type [A -> B -> C] as [(A *
       B) -> C].  This is called _uncurrying_.  With an uncurried binary
       function, both arguments must be given at once as a pair; there is
       no partial application. *)

   (** We can define currying as follows: *)

   Definition prod_curry {X Y Z : Type}
     (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

   (** As an exercise, define its inverse, [prod_uncurry].  Then prove
       the theorems below to show that the two are inverses. *)

   Definition prod_uncurry {X Y Z : Type}
     (f : X -> Y -> Z) (p : X * Y) : Z :=
     f (fst p) (snd p).

   (** As a (trivial) example of the usefulness of currying, we can use it
       to shorten one of the examples that we saw above: *)

   Example test_map2: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
   Proof. reflexivity.  Qed.

   (** Thought exercise: before running the following commands, can you
       calculate the types of [prod_curry] and [prod_uncurry]? *)

   Check @prod_curry.
   Check @prod_uncurry.

   Theorem uncurry_curry : forall (X Y Z : Type)
                           (f : X -> Y -> Z)
                           x y,
     prod_curry (prod_uncurry f) x y = f x y.
   Proof.
     intros X Y Z f x y.
     reflexivity.
    Qed.

   Theorem curry_uncurry : forall (X Y Z : Type)
                           (f : (X * Y) -> Z) (p : X * Y),
     prod_uncurry (prod_curry f) p = f p.
   Proof.
     intros X Y Z f p.
     destruct p.
     - reflexivity.
    Qed.

   (** **** Exercise: 2 stars, advancedM (nth_error_informal)  *)
   (** Recall the definition of the [nth_error] function:

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

      Write an informal proof of the following theorem:

      forall X n l, length l = n -> @nth_error X l n = None

   (* FILL IN HERE *)
   *)

   (** Informal Proof: length l = n means that there are only n elements in the list
      so the nth element will be None. The valid element index is from 0 to n - 1 *)

   (** [] *)

   (** **** Exercise: 4 stars, advanced (church_numerals)  *)
   (** This exercise explores an alternative way of defining natural
       numbers, using the so-called _Church numerals_, named after
       mathematician Alonzo Church.  We can represent a natural number
       [n] as a function that takes a function [f] as a parameter and
       returns [f] iterated [n] times. *)

   Module Church.
   Definition nat := forall X : Type, (X -> X) -> X -> X.

   (** Let's see how to write some numbers with this notation. Iterating
       a function once should be the same as just applying it.  Thus: *)

   Definition one : nat :=
     fun (X : Type) (f : X -> X) (x : X) => f x.

   (** Similarly, [two] should apply [f] twice to its argument: *)

   Definition two : nat :=
     fun (X : Type) (f : X -> X) (x : X) => f (f x).

   (** Defining [zero] is somewhat trickier: how can we "apply a function
       zero times"?  The answer is actually simple: just return the
       argument untouched. *)

   Definition zero : nat :=
     fun (X : Type) (f : X -> X) (x : X) => x.

   (** More generally, a number [n] can be written as [fun X f x => f (f
       ... (f x) ...)], with [n] occurrences of [f].  Notice in
       particular how the [doit3times] function we've defined previously
       is actually just the Church representation of [3]. *)

   Definition three : nat := @doit3times.

   (** Complete the definitions of the following functions. Make sure
       that the corresponding unit tests pass by proving them with
       [reflexivity]. *)

   (** Successor of a natural number: *)

   Definition succ (n : nat) : nat :=
    fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

   Example succ_1 : succ zero = one.
   Proof.
     reflexivity.
   Qed.

   Example succ_2 : succ one = two.
   Proof.
     reflexivity.
   Qed.

   Example succ_3 : succ two = three.
   Proof.
     reflexivity.
   Qed.

   (** Addition of two natural numbers: *)

   Definition plus (n m : nat) : nat :=
     fun (X : Type) (f : X -> X) (x : X) => n X f (m X f x).

   Example plus_1 : plus zero one = one.
   Proof.
     reflexivity.
   Qed.

   Example plus_2 : plus two three = plus three two.
   Proof.
     reflexivity.
   Qed.

   Example plus_3 :
     plus (plus two two) three = plus one (plus three three).
   Proof.
     reflexivity.
   Qed.

   (** Multiplication: *)

   Definition mult (n m : nat) : nat :=
     fun (X : Type) (f : X -> X) (x : X) => n X (m X f) x.

   Example mult_1 : mult one one = one.
   Proof.
     reflexivity.
   Qed.

   Example mult_2 : mult zero (plus three three) = zero.
   Proof.
     reflexivity.
   Qed.

   Example mult_3 : mult two three = plus three three.
   Proof.
     reflexivity.
   Qed.

   (** Exponentiation: *)

   (** (_Hint_: Polymorphism plays a crucial role here.  However,
       choosing the right type to iterate over can be tricky.  If you hit
       a "Universe inconsistency" error, try iterating over a different
       type: [nat] itself is usually problematic.) *)

   Definition exp (n m : nat) : nat :=
     fun (X : Type) (f : X -> X) (x : X) =>
        m (X -> X) (n X) f x.

   Example exp_1 : exp two two = plus two two.
   Proof.
     reflexivity.
    Qed.

   Example exp_2 : exp three two = plus (mult two (mult two two)) one.
   Proof.
     reflexivity.
    Qed.

   Example exp_3 : exp three zero = one.
   Proof.
     reflexivity.
    Qed.

   End Church.
   (** [] *)

   End Exercises.

   (** $Date: 2016-10-07 15:11:04 -0400 (Fri, 07 Oct 2016) $ *)


From CReal.MetricSpace Require Export M_pack.
Theorem PNP : forall p : Prop, ~(p /\ ~p) .
Proof.
  unfold not. intros. destruct H. apply H0 in H. apply H.
Qed.

Lemma le_one : forall (m n : nat), (m <= n)%nat \/ (n <= m)%nat.
Proof.
  intro m. induction m.
  -intros. left. induction n. apply le_n. apply le_S. apply IHn.
  -intros. destruct n. +right. apply le_0_n. +destruct IHm with (n := n).
  {left. apply le_n_S. auto. } {right. apply le_n_S. auto. }
Qed.

Lemma le_equ : forall (m n : nat), (m <= n)%nat -> (n <= m)%nat -> m = n.
Proof.
  intro m. induction m as [| m' IH]. -intros. destruct n. auto. inversion H0.
  -intros. destruct n. +inversion H. +apply le_S_n in H. apply le_S_n in H0.
    assert (m' = n). apply IH. apply H. apply H0. auto.
Qed.

Lemma always_greater : forall (m n : nat), exists N, (m < N)%nat /\ (n < N)%nat.
Proof.
    intro m. induction m. -intros. exists (S n).
    split. apply neq_0_lt. unfold not. intros. inversion H. unfold lt. apply le_n.
    -intros. destruct IHm with (n :=n) as [N']. destruct H. exists (S N').
    split. apply lt_n_S. auto. unfold lt. unfold lt in H0. apply (le_trans (S n) N' (S N')).
    auto. apply le_S. apply le_n.
Qed.


Module NatList.

Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
  | nil, l2' => l2'
  | l1', nil => l1'
  | h1 :: t1, h2 :: t2 => h1 :: h2 :: (alternate t1 t2)
  end.

Example test_alternate1: alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. simpl. reflexivity.  Qed.
Example test_alternate2: alternate [1] [4;5;6] = [1;4;5;6].
Proof. simpl. reflexivity.  Qed.
Example test_alternate3: alternate [1;2;3] [4] = [1;4;2;3].
Proof. simpl. reflexivity.  Qed.
Example test_alternate4: alternate [] [20;30] = [20;30].
Proof. simpl. reflexivity.  Qed.


(** Calculation of an abstract machine for arithmetic expressions. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Val (n : nat) : Expr
| Add (x y: Expr) : Expr.

(** * Semantics *)

Fixpoint eval (e: Expr) : nat :=
  match e with
    | Val n => n
    | Add x y => eval x + eval y
  end.

(** * Abstract machine *)

Inductive CONT : Set :=
| NEXT : Expr -> CONT -> CONT
| ADD : nat -> CONT -> CONT
| HALT : CONT
.

Inductive Conf : Set :=
| eval'' : Expr -> CONT -> Conf
| apply : CONT -> nat -> Conf.

Notation "⟨ x , c ⟩" := (eval'' x c).
Notation "⟪ c , v ⟫" := (apply c v).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive AM : Conf -> Conf -> Prop :=
| am_val n c : ⟨Val n, c⟩ ==> ⟪c, n⟫
| am_add x y c : ⟨Add x y, c⟩ ==> ⟨x, NEXT y c⟩
| am_NEXT y c n : ⟪NEXT y c, n⟫ ==> ⟨y, ADD n c⟩
| am_ADD c n m : ⟪ADD n c, m⟫ ==> ⟪c, n+m⟫
where "x ==> y" := (AM x y).

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module AM <: Preorder.
Definition Conf := Conf.
Definition VM := AM.
End AM.
Module AMCalc := Calculation AM.
Import AMCalc.

(** Specification of the abstract machine *)

Theorem spec x c : ⟨x, c⟩ =>> ⟪c, eval x⟫.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  induction x;intros.

(** Calculation of the abstract machine *)

  begin
  ⟪c, eval (Val n)⟫.
  =   {reflexivity}
  ⟪c, n⟫.
  <== { apply am_val }
  ⟨Val n, c⟩.
  [].

  begin
    ⟪c, eval (Add x1 x2) ⟫.
  =   {reflexivity}
    ⟪c, eval x1 + eval x2 ⟫.
  <== { apply am_ADD }
      ⟪ADD (eval x1) c, eval x2⟫.
  <<= { apply IHx2 }
      ⟨x2, ADD (eval x1) c⟩.
  <== { apply am_NEXT }
      ⟪NEXT x2 c, eval x1⟫.
  <<= { apply IHx1 }
      ⟨x1, NEXT x2 c⟩.
  <== {apply am_add}
      ⟨Add x1 x2, c ⟩.
  [].

Qed.