Require Import Eqdep_dec.
Require Import Coq.Logic.FunctionalExtensionality.
Import EqNotations.
Require Import Coq.Logic.JMeq.
Require Import ProofIrrelevance.
Require Import Classical.
Require Import Fin.

Require Import dec.
Require Import finite.
Require Import set.

(*
http://people.mpi-inf.mpg.de/~mvoigt/files/LICS2016_slides.pdf
http://web.cs.wpi.edu/~tn/publications/finite-model-osl-TR.pdf
https://hal.inria.fr/tel-02406821/document
http://people.mpi-inf.mpg.de/~mvoigt/files/Dissertation_with_hyperref.pdf
  => p 13
*)

SubClass SortT {Ts} := @Finite Ts.
SubClass VariableT {Tv} := @Finite Tv.
SubClass ConstantT {Tc} := @Finite Tc.
SubClass PredicateT {Tp} := @Finite Tp.

Class Sig {Ts: Type} {Tv: Ts->Type} {Tc: Ts->Type} {Tp} := {
  Sort: @SortT Ts;
  variable: forall (s:Sort), @VariableT (Tv s);
  constant: forall (s:Sort), @ConstantT (Tc s);
  predicate: @PredicateT Tp;
  pr_arity: predicate -> nat;
  pr_args: forall p, Fin.t (pr_arity p) -> Sort;
}.

Class Dom {Ts Tv Tc Tp} (Sg: @Sig Ts Tv Tc Tp) := {
  ssemT : Sort -> Type;
  ssem : forall s, @EqDec (ssemT s);
  domType: EqDec := DepPairDec Sort ssem;
  neDom: forall s, ssem s
}.
Coercion domType : Dom >-> EqDec.

Definition sem_eq `{Sg: Sig} {s1 s2: Sort} {D: Dom Sg}: ssem s1 -> ssem s2 -> Prop :=
  match eq_dec s1 s2 return ssem s1 -> ssem s2 -> Prop with
    left h =>
      match h in _=s2 return ssem _ -> ssem s2 -> Prop with
        eq_refl => fun d1 d2 => d1 = d2
      end
  | right _ => fun d1 d2 => False
  end.

Lemma sem_eq_s: forall `{Sg: Sig} s (D: Dom Sg) (d1 d2: ssem s),
  sem_eq d1 d2 <-> d1=d2.
Proof.
  intros.
  unfold sem_eq.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e eq_refl); tauto.
Qed.

Class Interp `{Sg: Sig} (D: Dom Sg) := {
  csem {s: Sort} (c: constant s): ssem s;
  psem (p: predicate): nat -> (forall i, ssem (pr_args p i)) -> Prop;
}.

Section FO.
  Context {Ts: Type} {Tv: Ts->Type} {Tc: Ts->Type} {Tp: Type}.
  Variable mySig: @Sig Ts Tv Tc Tp.
  Existing Instance mySig.

Definition Env (D: Dom mySig) := forall s, variable s -> ssem s.

Lemma veq_dec {s} (v: variable s) {s'} (w: variable s'):
  {existT variable s v = existT variable s' w}+{existT variable s v <> existT variable s' w}.
Proof.
  destruct (eq_dec s s').
  subst s'.
  destruct (eq_dec v w).
  subst w; left; reflexivity.
  right; intro.
  apply inj_pair2_eq_dec in H; try apply eq_dec.
  apply (n H).
  right; intro.
  injection H; clear H; intros.
  apply (n H0).
Qed.

Definition add {D: Dom mySig} {s} (v: variable s) (d: ssem s) (env: Env D): Env D:=
  fun s' =>
    match eq_dec s s' with
      left h =>
        match h in _=s' return variable s' -> _ with
          eq_refl => fun w => if eq_dec v w then d else env s w
        end
    | right _ => fun w => env s' w
    end.

(*
env |- ex x1,..,xn. f <-> ex di. add xn dn ... (add x1 d1 env) |- f
*)

(*
Definition addl {K:Finite} {D: Dom mySig} (sk: K-> Sort) (vk: forall k, variable (sk k)) (dk: forall k, ssem (sk k)) (env: Env D): Env D :=
  List.fold_left (fun e (k:K) => add (vk k) (dk k) e) fin_set env.
*)

Definition addl {D: Dom mySig} `(K: Finite)
  (sk: K->Sort) (vk: forall k:K, variable (sk k)) (dk: forall k:K, ssem (sk k)) (env: Env D): Env D :=
  fun (s: Sort) (v: variable s) =>
    match last_dec (fun k => isEq2 (U:=variable) (sk k) (vk k) s v) with
      inleft (exist _ k h) =>
        match h in _=sv return ssem (projT1 sv) with
          eq_refl => dk k
        end
    | inright h => env s v
    end.

Definition addr {D: Dom mySig} `(K: Finite)
  (sk: K->Sort) (vk: forall k:K, variable (sk k)) (dk: forall k:K, ssem (sk k)) (env: Env D): Env D :=
  fun (s: Sort) (v: variable s) =>
    match first_dec (fun k => isEq2 (U:=variable) (sk k) (vk k) s v) with
      inleft (exist _ k h) =>
        match h in _=sv return ssem (projT1 sv) with
          eq_refl => dk k
        end
    | inright h => env s v
    end.

Definition iadd {D: Dom mySig} `(K: Finite)
  (sk: K->Sort) (vk: forall k:K, variable (sk k)) (dk: forall k:K, ssem (sk k)) (env: Env D): Env D :=
  fun (s: Sort) (v: variable s) =>
    match ex_dec (fun k => isEq2 (U:=variable) (sk k) (vk k) s v) with
      inleft (exist _ k h) =>
        match h in _=sv return ssem (projT1 sv) with
          eq_refl => dk k
        end
    | inright h => env s v
    end.

Lemma iaddOne: forall (D: Dom mySig) s (v: variable s) (dk: OneFin -> ssem s) env,
  iadd OneFin (fun _ => s) (fun _ => v) dk env = add v (dk one) env.
Proof.
  intros.
  apply functional_extensionality_dep; intro s';
  apply functional_extensionality_dep; intro v'.
  unfold iadd.
  match goal with |- match ?cnd with _=>_ end=_ => destruct cnd end.
  destruct s0.
  injection d; intros; subst s'.
  generalize d; intro d'.
  apply inj_pair2_eq_dec in d; try apply eq_dec; subst v'.
  rewrite (proof_irrelevance _ d' eq_refl).
  unfold add.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e eq_refl).
  destruct (eq_dec v v); try tauto.
  destruct x; tauto.

  unfold add.
  destruct (eq_dec s s'); auto.
  subst s'.
  destruct (eq_dec v v'); auto.
  subst v'.
  exfalso; apply (n one); reflexivity.
Qed.

Lemma add_eq: forall (D: Dom mySig) (env: Env D) s v d,
  add v d env s v = d.
Proof.
  intros.
  unfold add.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e eq_refl).
  destruct (eq_dec v v); tauto.
Qed.

Lemma add_ne: forall (D: Dom mySig) (env: Env D) s v w d,
  v <> w -> add v d env s w = env s w.
Proof.
  intros.
  unfold add.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e eq_refl).
  destruct (eq_dec v w); tauto.
Qed.

Lemma add_ne2: forall (D: Dom mySig) (env: Env D) s v s' w d,
  ~ isEq2 s v s' w -> add v d env s' w = env s' w.
Proof.
  intros.
  unfold add.
  destruct (eq_dec s s'); auto.
  subst s'.
  destruct (eq_dec v w); auto.
  subst w.
  exfalso; apply H; reflexivity.
Qed.

Lemma add_upd: forall (D: Dom mySig) (env: Env D) s v w,
  add v (env s w) env s w = env s w.
Proof.
  intros.
  unfold add.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e eq_refl).
  destruct (eq_dec v w); tauto.
Qed.

Lemma add_id: forall (D: Dom mySig) (env: Env D) s v,
  add v (env s v) env = env.
Proof.
  intros.
  unfold add.
  apply functional_extensionality_dep; intro s'.
  apply functional_extensionality_dep; intro w.
  destruct (eq_dec s s'); try tauto.
  subst s'.
  destruct (eq_dec v w); try tauto.
  subst w; auto.
Qed.

Lemma add_add_eq: forall (D: Dom mySig) (env: Env D) s (v: variable s) d d',
  add v d (add v d' env) = add v d env.
Proof.
  intros.
  apply functional_extensionality_dep; intro s'.
  apply functional_extensionality_dep; intro w.

  unfold add.
  destruct (eq_dec s s'); try tauto.
  subst s'.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ e eq_refl).
  destruct (eq_dec v w); tauto.
Qed.

Lemma add_add_ne_swp: forall (D: Dom mySig) (env: Env D) {s1} (v1: variable s1) {s2} (v2: variable s2) d1 d2,
  not (isEq2 (U:=variable) s1 v1 s2 v2) ->
    add v1 d1 (add v2 d2 env) = add v2 d2 (add v1 d1 env).
Proof.
  intros.
  apply functional_extensionality_dep; intro s'.
  apply functional_extensionality_dep; intro w.

  unfold add.
  destruct (eq_dec s1 s'); try tauto.
  subst s'.
  destruct (eq_dec s2 s1); try tauto.
  subst s2.
  destruct (eq_dec s1 s1); try tauto.
  rewrite (proof_irrelevance _ e eq_refl).
  destruct (eq_dec v1 w); try tauto.
  subst w.
  destruct (eq_dec v2 v1); auto.
  subst v2.
  destruct (H eq_refl).

  destruct (eq_dec s2 s'); try tauto.
  subst s'.
  destruct (eq_dec s1 s2); tauto.
Qed.

Inductive term (s: Sort): Type :=
  Var: variable s -> term s
| Cst: constant s -> term s.

Lemma tm_dec: forall s, EqDecType (term s).
Proof.
  unfold EqDecType; intros.
  decide equality; apply eq_dec.
Qed.

Definition tmDec s := {| eq_dec := tm_dec s |}.

Definition tm_sem {D: Dom mySig} {Itp: Interp D} {s} (env: Env D) (tm: term s): ssem s :=
  match tm with
    Var _ v => env _ v
  | Cst _ c => csem c
  end.

Inductive literal: Type :=
  PApp: nat -> forall (p: predicate), (forall i, term (pr_args p i)) -> literal.

Lemma lt_dec: EqDecType literal.
Proof.
  unfold EqDecType; intros.
  destruct x; destruct y.
  destruct (eq_dec p p0).
  subst p0.
  destruct (PeanoNat.Nat.eq_dec n n0).
  subst n0.
  destruct (all_dec (F:=uptoFinite (pr_arity p)) (fun i => isEq (T:=tmDec (pr_args p i)) (t i) (t0 i))).
  left.
  f_equal.
  apply functional_extensionality_dep; intro i.
  apply d.
  right; intro.
  destruct s as [k h]; apply h; clear h.
  injection H; intros; subst.
  apply inj_pair2_eq_dec in H0; try apply eq_dec.
  subst t0; apply eq_refl.
  right; intro.
  injection H; intros; subst n0; tauto.
  right; intro.
  injection H; intros; subst p0; tauto.
Qed.

Definition ltDec := {| eq_dec := lt_dec |}.

Definition lt_sem {D: Dom mySig} {Itp: Interp D} (env: Env D) (lt: literal) (t:nat): Prop :=
  match lt with
  | PApp n p args => psem p (n+t) (fun i => tm_sem env (args i))
  end.

Inductive atom: Type :=
| Literal: literal -> atom
| NLiteral: literal -> atom
| Eq: forall s, term s -> term s -> atom
| NEq: forall s, term s -> term s -> atom.

Lemma at_dec: EqDecType atom.
Proof.
  unfold EqDecType; intros.
  destruct x; destruct y; try (right; discriminate).
  destruct (lt_dec l l0); [left; subst; tauto | right].
  intro h; apply n; injection h; intros; subst; now auto.

  destruct (lt_dec l l0); [left; subst; tauto | right].
  intro h; apply n; injection h; intros; subst; now auto.

  destruct (eq_dec s s0); [subst s0 | right; intro].
  destruct (tm_dec s t t1); [subst t1 | right; intro].
  destruct (tm_dec s t0 t2); [subst t2;left;auto | right; intro].
  injection H; intros; subst; auto.
  apply inj_pair2_eq_dec in H0; try apply eq_dec; subst; tauto.
  injection H; intros; subst; auto.
  apply inj_pair2_eq_dec in H1; try apply eq_dec; subst; tauto.
  injection H; intros; subst; auto.

  destruct (eq_dec s s0); [subst s0 | right; intro].
  destruct (tm_dec s t t1); [subst t1 | right; intro].
  destruct (tm_dec s t0 t2); [subst t2;left;auto | right; intro].
  injection H; intros; subst; auto.
  apply inj_pair2_eq_dec in H0; try apply eq_dec; subst; tauto.
  injection H; intros; subst; auto.
  apply inj_pair2_eq_dec in H1; try apply eq_dec; subst; tauto.
  injection H; intros; subst; auto.
Qed.

Definition atDec := {| eq_dec := at_dec |}.

Inductive formula: Type :=
  FTrue: formula
| FFalse: formula
| Atom: atom -> formula
| And: formula -> formula -> formula
| Or: formula -> formula -> formula
| Ex: forall s, variable s -> formula -> formula
| All: forall s, variable s -> formula -> formula
| F: formula -> formula
| G: formula -> formula.

Lemma fm_dec: EqDecType formula.
Proof.
  intros f1 f2.
  revert f1 f2; double induction f1 f2; clear f1 f2; try (right; intros; discriminate);
    try (left; reflexivity).
  - intros.
    destruct (at_dec a a0); [left|right].
    subst a0; now auto.
    intro h; injection h; intros; subst a0; tauto.
  - intros.
    destruct (X1 f); [subst f | right; intros].
    destruct (X2 f0); [subst f0; left; auto | right; intros].
    intro h; injection h; intros; subst; tauto.
    intro h; injection h; intros; subst; tauto.
  - intros.
    destruct (X1 f); [subst f | right; intros].
    destruct (X2 f0); [subst f0; left; auto | right; intros].
    intro h; injection h; intros; subst; tauto.
    intro h; injection h; intros; subst; tauto.
  - intros.
    destruct (eq_dec s s0); [subst s0 | right; intros].
    destruct (eq_dec e e0); [subst e0 | right; intros].
    destruct (X0 f); [subst f0; auto | right; intros].
    intro h; injection h; intros; subst; tauto.
    intro h.
    injection h; intros.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst e0; tauto.
    intro h; injection h; intros; subst; tauto.
  - intros.
    destruct (eq_dec s s0); [subst s0 | right; intros].
    destruct (eq_dec e e0); [subst e0 | right; intros].
    destruct (X0 f); [subst f0; auto | right; intros].
    intro h; injection h; intros; subst; tauto.
    intro h.
    injection h; intros.
    apply inj_pair2_eq_dec in H0; try apply eq_dec; subst e0; tauto.
    intro h; injection h; intros; subst; tauto.
  - intros.
    destruct (X0 f); [left; subst f0; auto | right; intros].
    intro h; injection h; intros; subst; tauto.
  - intros.
    destruct (X0 f); [left; subst f0; auto | right; intros].
    intro h; injection h; intros; subst; tauto.
Qed.

Definition fmDec := {| eq_dec := fm_dec |}.

Definition IAnd `(K: Finite) (fk: K -> formula): formula :=
  List.fold_right (fun k r => And (fk k) r) FTrue fin_set.

Definition IOr `(K: Finite) (fk: K -> formula): formula :=
  List.fold_right (fun k r => Or (fk k) r) FFalse fin_set.

Definition IEx `(K:Finite) (sk: K->Sort) (vk:forall k, variable (sk k)) (f: formula): formula :=
  List.fold_right (fun k r => Ex (sk k) (vk k) r) f fin_set.

Definition IAll `(K:Finite) (sk: K->Sort) (vk:forall k, variable (sk k)) (f: formula): formula :=
  List.fold_right (fun k r => All (sk k) (vk k) r) f fin_set.

Definition at_sem {D: Dom mySig} {Itp: Interp D} (env: Env D) (a: atom) t: Prop :=
  match a with
  | Literal a => lt_sem env a t
  | NLiteral a => not (lt_sem env a t)
  | Eq _ t1 t2 => tm_sem env t1 = tm_sem env t2
  | NEq _ t1 t2 => tm_sem env t1 <> tm_sem env t2
  end.

Fixpoint fm_sem {D: Dom mySig} {Itp: Interp D} (env: Env D) (f: formula) t: Prop :=
  match f with
  | FTrue => True
  | FFalse => False
  | Atom a => at_sem env a t
  | And f1 f2 => fm_sem env f1 t /\ fm_sem env f2 t
  | Or f1 f2 => fm_sem env f1 t \/ fm_sem env f2 t
  | Ex s v f => exists (d: ssem s), fm_sem (add v d env) f t
  | All s v f => forall (d: ssem s), fm_sem (add v d env) f t
  | F f => exists t', t' >= t /\ fm_sem env f t'
  | G f => forall t', t' >= t -> fm_sem env f t'
  end.

Ltac fm_semTac :=
    match goal with
      H: fm_sem ?e1 ?f ?t |- fm_sem ?e2 ?f ?t => assert (e1 = e2) as eeq;
        try (rewrite eeq in H; assumption);
        apply functional_extensionality_dep; intro;
        apply functional_extensionality_dep; intro
    end.

Lemma F_sem: forall {D: Dom mySig} {Itp: Interp D} (env: Env D) (f: formula) t,
  fm_sem env (F f) t <-> (exists t', t' >= t /\ fm_sem env f t').
Proof.
  intros; reflexivity.
Qed.

Lemma G_sem: forall {D: Dom mySig} {Itp: Interp D} (env: Env D) (f: formula) t,
  fm_sem env (G f) t <-> (forall t', t' >= t -> fm_sem env f t').
Proof.
  intros; reflexivity.
Qed.

Definition atNot (a: atom): atom :=
  match a with
    Literal a => NLiteral a
  | NLiteral a => Literal a
  | Eq s t1 t2 => NEq s t1 t2
  | NEq s t1 t2 => Eq s t1 t2
  end.

Fixpoint Not (f: formula): formula :=
  match f with
  | FTrue => FFalse
  | FFalse => FTrue
  | Atom a => Atom (atNot a)
  | And f1 f2 => Or (Not f1) (Not f2)
  | Or f1 f2 => And (Not f1) (Not f2)
  | Ex s v f => All s v (Not f)
  | All s v f => Ex s v (Not f)
  | F f => G (Not f)
  | G f => F (Not f)
  end.

Lemma atNot_sem: forall {D: Dom mySig} {Itp: Interp D} (a: atom) (env: Env D) t,
  at_sem env (atNot a) t <-> not (at_sem env a t).
Proof.
  intros.
  destruct a; simpl; tauto.
Qed.

Lemma Not_sem: forall {D: Dom mySig} {Itp: Interp D} (f: formula) (env: Env D) t,
  fm_sem env (Not f) t <-> not (fm_sem env f t).
Proof.
  induction f; simpl; intros; auto; try tauto.
 - apply atNot_sem.
 - rewrite IHf1, IHf2.
   tauto.
 - rewrite IHf1, IHf2.
   tauto.
 - setoid_rewrite IHf; split; intros.
   intro.
   destruct H0 as [k H0].
   apply (H k H0).
   intro; apply H; clear H.
   exists d; auto.
 - setoid_rewrite IHf; split; intros.
   destruct H as [d H].
   intro.
   apply (H (H0 d)).
   apply not_all_ex_not in H.
   destruct H as [d H].
   exists d; auto.
 - setoid_rewrite IHf; split; intros.
   intro.
   destruct H0 as [t' [h1 h2]].
   apply (H t' h1 h2).
   intro.
   apply H; exists t'; tauto.
 - setoid_rewrite IHf; split; intros.
   intro.
   destruct H as [t' [h1 h2]].
   apply (h2 (H0 t' h1)).
   apply not_all_ex_not in H.
   destruct H as [t' H].
   exists t'; tauto.
Qed.

Lemma IAnd_sem: forall D (Itp: Interp D) env `(K: Finite) fk t,
  fm_sem env (IAnd K fk) t <-> forall k, fm_sem env (fk k) t.
Proof.
  intros; simpl.
  unfold IAnd.
  assert ((forall k : K, fm_sem env (fk k) t) <-> (forall k : K, SV.set_In k fin_set -> fm_sem env (fk k) t)).
    generalize fin_all; repeat (split || intro); now auto.
  rewrite H; clear H.

  induction fin_set; simpl; intros; auto.
  - split; intros; tauto.
  - rewrite IHs; clear IHs.
    split; intros; try tauto.
    destruct H0; try subst a; try tauto.
    apply H; now auto.

    split; auto.
Qed.

Lemma IOr_sem: forall D (Itp: Interp D) env `(K: Finite) fk t,
  fm_sem env (IOr K fk) t <-> exists k, fm_sem env (fk k) t.
Proof.
  intros; simpl.
  unfold IOr.
  assert ((exists k : K, fm_sem env (fk k) t) <-> (exists k : K, SV.set_In k fin_set /\ fm_sem env (fk k) t)).
    generalize fin_all; repeat (split || intro).
    destruct H0 as [k H0]; exists k; now auto.
    destruct H0 as [k H0]; exists k; now auto.
  rewrite H; clear H.

  induction fin_set; simpl; intros; auto.
  - split; intros; try tauto.
    destruct H as [k H]; tauto.
  - rewrite IHs; clear IHs.
    split; intros.
    destruct H.
    exists a; split; auto; left; now auto.
    destruct H as [k [h1 h2]].
    exists k; split; auto; right; now auto.

    destruct H as [k [h1 h2]].
    destruct h1; [subst;left|right;exists k]; auto.
Qed.

Definition ltX l :=
  match l with
    PApp n p args => PApp (S n) p args
  end.

Definition atX a :=
  match a with
    Literal l => Literal (ltX l)
  | NLiteral l => NLiteral (ltX l)
  | e => e
  end.

Fixpoint X (f: formula): formula :=
  match f with
  | FTrue => FTrue
  | FFalse => FFalse
  | Atom a => Atom (atX a)
  | And f1 f2 => And (X f1) (X f2)
  | Or f1 f2 => Or (X f1) (X f2)
  | Ex s v f => Ex s v (X f)
  | All s v f => All s v (X f)
  | F f => F (X f)
  | G f => G (X f)
  end.

Lemma ltX_sem: forall {D: Dom mySig} {Itp: Interp D} (l: literal) (env: Env D) t,
  lt_sem env (ltX l) t <-> lt_sem env l (S t).
Proof.
  intros.
  destruct l; simpl; try tauto.
  rewrite plus_n_Sm.
  reflexivity.
Qed.

Lemma atX_sem: forall {D: Dom mySig} {Itp: Interp D} (a: atom) (env: Env D) t,
  at_sem env (atX a) t <-> at_sem env a (S t).
Proof.
  intros.
  destruct a; simpl; try tauto.
  apply ltX_sem.
  apply not_iff_compat.
  apply ltX_sem.
Qed.

Lemma X_sem: forall {D: Dom mySig} {Itp: Interp D} (f: formula) (env: Env D) t,
  fm_sem env (X f) t <-> fm_sem env f (S t).
Proof.
  induction f; simpl; intros; try tauto;
    try (apply atX_sem);
    try (setoid_rewrite H; reflexivity);
    try (setoid_rewrite IHf; reflexivity).
  rewrite IHf1, IHf2; reflexivity.
  rewrite IHf1, IHf2; reflexivity.
  setoid_rewrite IHf.
  split; intro.
  destruct H as [t' [h1 h2]].
  exists (S t'); split; auto.
  apply Le.le_n_S; auto.

  destruct H as [t' [h1 h2]].
  destruct t'; try (now inversion h1).
  exists t'; split; simpl; auto.
  apply le_S_n in h1; apply h1.

  setoid_rewrite IHf.
  split; intros.
  destruct t'; try (now inversion H0).
  apply H; now auto with arith.

  apply H.
  auto with arith.
Qed.

Definition isX (f: formula) := (exists g, f = X g).

Lemma ltX_dec (l: literal) : { l' | l = ltX l'} + (forall l', l <> ltX l').
Proof.
  destruct l; simpl.
  destruct n; [right | left]; repeat intro.
  destruct l'; discriminate.
  exists (PApp n p t); reflexivity.
Qed.

Lemma atX_dec (a: atom) : { b | a = atX b} + (forall b, a <> atX b).
Proof.
  destruct a; simpl.
  destruct (ltX_dec l).
  left; auto.
  destruct s as [l' h]; subst.
  exists (Literal l'); reflexivity.
  right; repeat intro.
  destruct b; simpl in H; try discriminate.
  injection H; clear H; intros; subst.
  apply (n l0); now auto.

  destruct (ltX_dec l).
  destruct s as [l' h]; subst.
  left; exists (NLiteral l'); reflexivity.
  right; repeat intro.
  destruct b; simpl in H; try discriminate.
  injection H; clear H; intros; subst.
  apply (n l0); now auto.

  left; exists (Eq s t t0); reflexivity.
  left; exists (NEq s t t0); reflexivity.
Qed.

Lemma isX_dec (f: formula) : { g | f = X g} + (forall g, f <> X g).
Proof.
  induction f; intros.
  - left; exists FTrue; reflexivity.
  - left; exists FFalse; reflexivity.
  - destruct (atX_dec a); [left | right]; repeat intro.
   destruct s as [b H]; subst.
   exists (Atom b); reflexivity.
   destruct g; try discriminate; simpl in H.
   injection H; clear H; intros; subst.
   apply (n a0); now auto.
  - destruct IHf1.
    destruct s as [g1 H1]; subst.
    destruct IHf2.
    destruct s as [g2 H2]; subst.
    left; exists (And g1 g2); reflexivity.
    right; repeat intro.
    destruct g; try discriminate; simpl in H.
    injection H; clear H; intros; subst.
    apply (n g3); now auto.
    right; repeat intro.
    destruct g; try discriminate; simpl in H.
    injection H; clear H; intros; subst.
    apply (n g1); now auto.
  - destruct IHf1.
    destruct s as [g1 H1]; subst.
    destruct IHf2.
    destruct s as [g2 H2]; subst.
    left; exists (Or g1 g2); reflexivity.
    right; repeat intro.
    destruct g; try discriminate; simpl in H.
    injection H; clear H; intros; subst.
    apply (n g3); now auto.
    right; repeat intro.
    destruct g; try discriminate; simpl in H.
    injection H; clear H; intros; subst.
    apply (n g1); now auto.
  - destruct IHf.
    destruct s0 as [g h]; subst.
    left; exists (Ex s e g); reflexivity.
    right; repeat intro.
    destruct g; simpl in *; try discriminate.
    injection H; clear H; intros; subst.
    apply inj_pair2_eq_dec in H0; try apply eq_dec.
    apply (n g); now auto.
  - destruct IHf.
    destruct s0 as [g h]; subst.
    left; exists (All s e g); reflexivity.
    right; repeat intro.
    destruct g; simpl in *; try discriminate.
    injection H; clear H; intros; subst.
    apply inj_pair2_eq_dec in H0; try apply eq_dec.
    apply (n g); now auto.
  - destruct IHf.
    destruct s as [g h]; subst.
    left; exists (F g); reflexivity.
    right; repeat intro.
    destruct g; simpl in *; try discriminate.
    injection H; clear H; intros; subst.
    apply (n g); now auto.
  - destruct IHf.
    destruct s as [g h]; subst.
    left; exists (G g); reflexivity.
    right; repeat intro.
    destruct g; simpl in *; try discriminate.
    injection H; clear H; intros; subst.
    apply (n g); now auto.
Qed.

Lemma ltX_inj: forall l1 l2, ltX l1 = ltX l2 -> l1 = l2.
Proof.
  intros; destruct l1; destruct l2; try discriminate; auto.
  simpl in H.
  injection H; clear H; intros; subst.
  apply inj_pair2_eq_dec in H; try apply eq_dec; subst; auto.
Qed.

Lemma atX_inj: forall a1 a2, atX a1 = atX a2 -> a1 = a2.
Proof.
  intros; destruct a1; destruct a2; intros; try discriminate; simpl in *; auto.
  injection H; clear H; intros.
  apply ltX_inj in H; subst; auto.
  injection H; clear H; intros.
  apply ltX_inj in H; subst; auto.
Qed.

Lemma X_inj: forall f1 f2, X f1 = X f2 -> f1 = f2.
Proof.
  double induction f1 f2; intros; try discriminate; simpl in *; auto.
  injection H; clear H; intros.
  apply atX_inj in H; subst; now auto.

  injection H3; clear H3; intros.
  apply H2 in H3; apply H1 in H4; subst; now auto.

  injection H3; clear H3; intros.
  apply H2 in H3; apply H1 in H4; subst; now auto.

  injection H1; clear H1; intros; subst.
  apply H0 in H1; subst.
  apply inj_pair2_eq_dec in H2; try apply eq_dec; subst;now auto.

  injection H1; clear H1; intros; subst.
  apply H0 in H1; subst.
  apply inj_pair2_eq_dec in H2; try apply eq_dec; subst;now auto.

  injection H1; clear H1; intros; subst.
  apply H0 in H1; subst; now auto.

  injection H1; clear H1; intros; subst.
  apply H0 in H1; subst; now auto.
Qed.

Definition Imp (f1 f2: formula): formula := Or (Not f1) f2.
Definition Equiv (f1 f2: formula) := And (Imp f1 f2) (Imp f2 f1).

Lemma And_sem: forall {D: Dom mySig} {Itp: Interp D} (f1 f2: formula) (env: Env D) t,
  fm_sem env (And f1 f2) t <-> (fm_sem env f1 t /\ fm_sem env f2 t).
Proof.
  intros; reflexivity.
Qed.

Lemma Or_sem: forall {D: Dom mySig} {Itp: Interp D} (f1 f2: formula) (env: Env D) t,
  fm_sem env (Or f1 f2) t <-> (fm_sem env f1 t \/ fm_sem env f2 t).
Proof.
  intros; reflexivity.
Qed.

Lemma Imp_sem: forall {D: Dom mySig} {Itp: Interp D} (f1 f2: formula) (env: Env D) t,
  fm_sem env (Imp f1 f2) t <-> (fm_sem env f1 t -> fm_sem env f2 t).
Proof.
  intros.
  unfold Imp.
  rewrite Or_sem.
  rewrite Not_sem.
  tauto.
Qed.

Lemma Equiv_sem: forall {D: Dom mySig} {Itp: Interp D} (f1 f2: formula) (env: Env D) t,
  fm_sem env (Equiv f1 f2) t <-> (fm_sem env f1 t <-> fm_sem env f2 t).
Proof.
  intros.
  unfold Equiv.
  rewrite And_sem.
  do 2 rewrite Imp_sem.
  tauto.
Qed.

Lemma Ex_sem: forall D (Itp: Interp D) env s v f t,
  fm_sem env (Ex s v f) t <-> exists (d: ssem s), fm_sem (add v d env) f t.
Proof.
  intros; reflexivity.
Qed.

Lemma All_sem: forall D (Itp: Interp D) env s v f t,
  fm_sem env (All s v f) t <-> forall (d: ssem s), fm_sem (add v d env) f t.
Proof.
  intros; reflexivity.
Qed.

Definition tm_subst {s s'} (x : variable s) (tm: term s) (t: term s'): term s' :=
  match t with
    Var _ y =>
      match eq_dec s' s return term s' with
        left e =>
          match e in _ = s return variable s -> term s -> term s' with
            eq_refl => fun x tm => if eq_dec x y then tm else Var _ y
          end x tm
      | right _ => t
      end
  | Cst _ c => Cst _ c
  end.

Definition tm_swap {s s'} (x y: variable s) (t: term s'): term s' :=
  match t with
    Var _ v =>
      match eq_dec s' s return term s' with
        left e =>
          match e in _ = s return variable s' -> variable s -> variable s -> term s' with
            eq_refl => fun v x y =>
               if eq_dec x v then Var _ y
               else if eq_dec y v then Var _ x
               else Var _ v
          end v x y
      | right _ => t
      end
  | Cst _ c => Cst _ c
  end.

Definition lt_subst {s} (v : variable s) (tm: term s) (l: literal) :=
  match l with
    PApp x r args => PApp x r (fun i => tm_subst v tm (args i))
  end.

Definition lt_swap {s} (v w : variable s) (l: literal) :=
  match l with
    PApp x r args => PApp x r (fun i => tm_swap v w (args i))
  end.

Definition at_subst {s} (x : variable s) (tm: term s) (a: atom) :=
  match a with
    Literal l => Literal (lt_subst x tm l)
  | NLiteral l => NLiteral (lt_subst x tm l)
  | Eq s' t1 t2 => Eq s' (tm_subst x tm t1) (tm_subst x tm t2)
  | NEq s' t1 t2  => NEq s' (tm_subst x tm t1) (tm_subst x tm t2)
  end.

Definition at_swap {s} (x y: variable s) (a: atom) :=
  match a with
    Literal l => Literal (lt_swap x y l)
  | NLiteral l => NLiteral (lt_swap x y l)
  | Eq s' t1 t2 => Eq s' (tm_swap x y t1) (tm_swap x y t2)
  | NEq s' t1 t2  => NEq s' (tm_swap x y t1) (tm_swap x y t2)
  end.

Definition esubst {s} (x : variable s) (tm: term s) (P: formula) :=
  Ex s x (And (Atom (Eq s (Var s x) tm)) P).

Definition asubst {s} (x : variable s) (tm: term s) (P: formula) :=
  All s x (Imp (Atom (Eq s (Var s x) tm)) P).

Fixpoint subst {s} (x: variable s) (tm: term s) (f: formula) :=
  match f with
  | FTrue => FTrue
  | FFalse => FFalse
  | Atom a => Atom (at_subst x tm a)
  | And f1 f2 => And (subst x tm f1) (subst x tm f2)
  | Or f1 f2 => Or (subst x tm f1) (subst x tm f2)
  | Ex s' w f' => esubst x tm f
  | All s' w f' => asubst x tm f
  | F f => F (subst x tm f)
  | G f => G (subst x tm f)
  end.

Fixpoint csubst {s} (x: variable s) (c: constant s) (f: formula) :=
  match f with
  | FTrue => FTrue
  | FFalse => FFalse
  | Atom a => Atom (at_subst x (Cst s c) a)
  | And f1 f2 => And (csubst x c f1) (csubst x c f2)
  | Or f1 f2 => Or (csubst x c f1) (csubst x c f2)
  | Ex s' w f' => if veq_dec x w then Ex s' w f' else Ex s' w (csubst x c f')
  | All s' w f' => if veq_dec x w then All s' w f' else All s' w (csubst x c f')
  | F f => F (csubst x c f)
  | G f => G (csubst x c f)
  end.

Fixpoint vswap {s} (x y: variable s) (f: formula) :=
  match f with
  | FTrue => FTrue
  | FFalse => FFalse
  | Atom a => Atom (at_swap x y a)
  | And f1 f2 => And (vswap x y f1) (vswap x y f2)
  | Or f1 f2 => Or (vswap x y f1) (vswap x y f2)
  | Ex s' w f' =>
    if veq_dec x w then Ex s y (vswap x y f')
    else if veq_dec y w then Ex s x (vswap x y f')
    else Ex s' w (vswap x y f')
  | All s' w f' =>
    if veq_dec x w then All s y (vswap x y f')
    else if veq_dec y w then All s x (vswap x y f')
    else All s' w (vswap x y f')
  | F f => F (vswap x y f)
  | G f => G (vswap x y f)
  end.

Fixpoint vsubst {s} (x y: variable s) (f: formula) :=
  match f with
  | FTrue => FTrue
  | FFalse => FFalse
  | Atom a => Atom (at_subst x (Var s y) a)
  | And f1 f2 => And (vsubst x y f1) (vsubst x y f2)
  | Or f1 f2 => Or (vsubst x y f1) (vsubst x y f2)
  | Ex s' w f' =>
    if veq_dec x w then Ex s' w f'
    else if veq_dec y w then vswap x y (Ex s' w f')
    else Ex s' w (vsubst x y f')
  | All s' w f' =>
    if veq_dec x w then All s' w f'
    else if veq_dec y w then vswap x y (All s' w f')
    else All s' w (vsubst x y f')
  | F f => F (vsubst x y f)
  | G f => G (vsubst x y f)
  end.

Ltac psemTac :=
    match goal with
      H:psem _ _ ?sa |- psem _ _ ?sa' => assert (sa' = sa) as ae;
          try (rewrite ae; assumption); (apply functional_extensionality_dep; intros)
    end.

Lemma tm_csubst_sem: forall  D (Itp: Interp D) env s v c s' (tm: term s'),
  tm_sem (add v (csem c) env) tm =
    tm_sem env (tm_subst v (Cst s c) tm).
Proof.
  intros; destruct tm; simpl; auto.
  unfold add; destruct (eq_dec s' s).
  subst s'.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ _ eq_refl).
  destruct (eq_dec v e); reflexivity.
  destruct (eq_dec s s'); try (subst s'; tauto); reflexivity.
Qed.

Lemma tm_vsubst_sem: forall  D (Itp: Interp D) env s v w s' (tm: term s'),
  tm_sem (add v (env s  w) env) tm =
    tm_sem env (tm_subst v (Var s w) tm).
Proof.
  intros; destruct tm; simpl; auto.
  unfold add; destruct (eq_dec s' s).
  subst s'.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ _ eq_refl).
  destruct (eq_dec v e); reflexivity.
  destruct (eq_dec s s'); try (subst s'; tauto); reflexivity.
Qed.

Lemma tm_swap_sem: forall  D (Itp: Interp D) env s v w s' (tm: term s'),
  tm_sem (add v (env s w) (add w (env s v) env)) tm =
    tm_sem env (tm_swap v w tm).
Proof.
  intros; destruct tm; simpl; auto.
  unfold add; destruct (eq_dec s' s).
  subst s'.
  destruct (eq_dec s s); try tauto.
  rewrite (proof_irrelevance _ _ eq_refl).
  destruct (eq_dec v e); try reflexivity.
  destruct (eq_dec w e); reflexivity.
  destruct (eq_dec s s'); try (subst s'; tauto); reflexivity.
Qed.

Lemma lt_csubst_sem: forall  D (Itp: Interp D) l env s v c t,
  lt_sem (add v (csem c) env) l t <-> lt_sem env (lt_subst v (Cst s c) l) t.
Proof.
  intros until l; destruct l; simpl; intros; auto.
  split; intro.
  psemTac.
  rewrite tm_csubst_sem.
  reflexivity.
  psemTac.
  rewrite tm_csubst_sem.
  reflexivity.
Qed.

Lemma lt_vsubst_sem: forall  D (Itp: Interp D) l env s v w t,
  lt_sem (add v (env s w) env) l t <-> lt_sem env (lt_subst v (Var s w) l) t.
Proof.
  intros until l; destruct l; simpl; intros; auto.
  split; intro.
  psemTac.
  rewrite tm_vsubst_sem.
  reflexivity.
  psemTac.
  rewrite tm_vsubst_sem.
  reflexivity.
Qed.

Lemma lt_swap_sem: forall  D (Itp: Interp D) l env s v w t,
  lt_sem (add v (env s w) (add w (env s v) env)) l t <-> lt_sem env (lt_swap v w l) t.
Proof.
  intros until l; destruct l; simpl; intros; auto.
  split; intro.
  psemTac.
  rewrite tm_swap_sem.
  reflexivity.
  psemTac.
  rewrite tm_swap_sem.
  reflexivity.
Qed.

Lemma at_csubst_sem: forall  D (Itp: Interp D) a env s v (c: constant s) t,
  at_sem (add v (csem c) env) a t <->
    at_sem env (at_subst v (Cst s c) a) t.
Proof.
  intros until a; destruct a; simpl; intros; auto.
  rewrite lt_csubst_sem; reflexivity.
  rewrite lt_csubst_sem; reflexivity.
  do 2 rewrite tm_csubst_sem; reflexivity.
  do 2 rewrite tm_csubst_sem; reflexivity.
Qed.

Lemma at_vsubst_sem: forall  D (Itp: Interp D) a env s v (w: variable s) t,
  at_sem (add v (env s w) env) a t <->
    at_sem env (at_subst v (Var s w) a) t.
Proof.
  intros until a; destruct a; simpl; intros; auto.
  rewrite lt_vsubst_sem; reflexivity.
  rewrite lt_vsubst_sem; reflexivity.
  do 2 rewrite tm_vsubst_sem; reflexivity.
  do 2 rewrite tm_vsubst_sem; reflexivity.
Qed.

Lemma at_swap_sem: forall  D (Itp: Interp D) a env s (v w: variable s) t,
  at_sem (add v (env s w) (add w (env s v) env)) a t <->
    at_sem env (at_swap v w a) t.
Proof.
  intros until a; destruct a; simpl; intros; auto.
  rewrite lt_swap_sem; reflexivity.
  rewrite lt_swap_sem; reflexivity.
  do 2 rewrite tm_swap_sem; reflexivity.
  do 2 rewrite tm_swap_sem; reflexivity.
Qed.

Lemma csubst_sem: forall  D (Itp: Interp D) f env s (v: variable s) (c: constant s) t,
  fm_sem (add v (csem c) env) f t <-> fm_sem env (csubst v c f) t.
Proof.
  induction f; simpl; intros; try tauto.
  - apply at_csubst_sem.
  - rewrite IHf1, IHf2; reflexivity.
  - rewrite IHf1, IHf2; reflexivity.
  - destruct (veq_dec v e).
    injection e0; clear e0; intros; subst s0.
    apply inj_pair2_eq_dec in H; try apply eq_dec; subst e.
    setoid_rewrite add_add_eq.
    setoid_rewrite Ex_sem.
    reflexivity.
    setoid_rewrite Ex_sem.
    setoid_rewrite <-IHf; clear IHf.
    split; intro H; destruct H as [d H]; exists d.
    setoid_rewrite add_add_ne_swp; try apply H.
    intro.
    inversion H0; tauto.
    setoid_rewrite add_add_ne_swp; try apply H.
    intro.
    inversion H0.
    symmetry in H3; tauto.
  - destruct (veq_dec v e).
    injection e0; clear e0; intros; subst s0.
    apply inj_pair2_eq_dec in H; try apply eq_dec; subst e.
    setoid_rewrite add_add_eq.
    setoid_rewrite All_sem.
    reflexivity.
    setoid_rewrite All_sem.
    setoid_rewrite <-IHf; clear IHf.
    split; intros H d; specialize (H d).
    setoid_rewrite add_add_ne_swp in H; try apply H.
    intro.
    inversion H0; symmetry in H3; tauto.
    setoid_rewrite add_add_ne_swp in H; try apply H.
    intro.
    inversion H0; tauto.
  - setoid_rewrite IHf; reflexivity.
  - setoid_rewrite IHf; reflexivity.
Qed.

Lemma vswap_sem: forall  D (Itp: Interp D) f env s (v w: variable s) t,
  fm_sem (add v (env s w) (add w (env s v) env)) f t <-> fm_sem env (vswap v w f) t.
Proof.
  induction f; simpl; intros; try tauto.
  - apply at_swap_sem.
  - rewrite IHf1, IHf2; reflexivity.
  - rewrite IHf1, IHf2; reflexivity.
  - destruct (veq_dec v e).
    injection e0; clear e0; intros; subst s0.
    apply inj_pair2_eq_dec in H; try apply eq_dec; subst e.
    setoid_rewrite add_add_eq.
    setoid_rewrite Ex_sem.
    setoid_rewrite <-IHf.
    setoid_rewrite add_add_eq.
    setoid_rewrite add_eq.
    destruct (eq_dec v w).
    subst w.
    repeat setoid_rewrite add_eq.
    setoid_rewrite add_add_eq.
    reflexivity.
    assert (w<>v) by (intro; subst w; tauto); clear n.
    split; intro h; destruct h as [d h]; exists d; revert h;
      setoid_rewrite (add_ne D env s w v); now auto.

    destruct (veq_dec w e).
    injection e0; clear e0; intros; subst s0.
    apply inj_pair2_eq_dec in H; try apply eq_dec; subst e.
    assert (v <> w) by (intro; subst w; tauto); clear n.
    setoid_rewrite add_add_ne_swp.
    setoid_rewrite add_add_eq.
    setoid_rewrite Ex_sem.
    setoid_rewrite <-IHf.
    setoid_rewrite add_eq.
    split; intro h; destruct h as [d h]; exists d; revert h.
    rewrite add_ne; auto.
    rewrite (add_add_ne_swp D (add v d env) v w); auto.
    rewrite add_add_eq; now auto.
    intro e; apply inj_pair2_eq_dec in e; try apply eq_dec; tauto.
    rewrite add_ne; auto.
    rewrite (add_add_ne_swp D (add v d env) v w); auto.
    rewrite add_add_eq; now auto.
    intro e; apply inj_pair2_eq_dec in e; try apply eq_dec; tauto.
    intro e; apply inj_pair2_eq_dec in e; try apply eq_dec; tauto.

    setoid_rewrite Ex_sem.
    setoid_rewrite <-IHf.
    split; intro h; destruct h as [d h]; exists d; revert h.
    rewrite add_ne2; auto.
    rewrite add_ne2; auto.
    rewrite (add_add_ne_swp D _ w e); auto.
    rewrite (add_add_ne_swp D _ v e); now auto.

    rewrite add_ne2; auto.
    rewrite add_ne2; auto.
    rewrite (add_add_ne_swp D _ w e); auto.
    rewrite (add_add_ne_swp D _ v e); now auto.

  - destruct (veq_dec v e).
    injection e0; clear e0; intros; subst s0.
    apply inj_pair2_eq_dec in H; try apply eq_dec; subst e.
    setoid_rewrite add_add_eq.
    setoid_rewrite All_sem.
    setoid_rewrite <-IHf.
    setoid_rewrite add_add_eq.
    setoid_rewrite add_eq.
    destruct (eq_dec v w).
    subst w.
    repeat setoid_rewrite add_eq.
    setoid_rewrite add_add_eq.
    reflexivity.
    assert (w<>v) by (intro; subst w; tauto); clear n.
    split; intros h d; specialize (h d); revert h;
      setoid_rewrite (add_ne D env s w v); now auto.

    destruct (veq_dec w e).
    injection e0; clear e0; intros; subst s0.
    apply inj_pair2_eq_dec in H; try apply eq_dec; subst e.
    setoid_rewrite All_sem.
    setoid_rewrite <-IHf.
    setoid_rewrite add_eq.
    assert (w<>v) by (intro; subst w; tauto); clear n.
    split; intros h d; specialize (h d); revert h;
      setoid_rewrite (add_ne D env s v w); auto.
    rewrite (add_add_ne_swp D _ w v); auto.
    rewrite add_add_eq.
    rewrite (add_add_ne_swp D env w v); auto.
    rewrite add_add_eq; now auto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.
    rewrite (add_add_ne_swp D _ w v); auto.
    rewrite add_add_eq.
    rewrite (add_add_ne_swp D (add w (env s v) env) w v); auto.
    rewrite add_add_eq; auto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.

    setoid_rewrite All_sem.
    setoid_rewrite <-IHf.
    split; intros h d; specialize (h d); revert h.
    rewrite add_ne2; auto.
    rewrite add_ne2; auto.
    rewrite (add_add_ne_swp D _ w e); auto.
    rewrite (add_add_ne_swp D _ v e); now auto.

    rewrite add_ne2; auto.
    rewrite add_ne2; auto.
    rewrite (add_add_ne_swp D _ w e); auto.
    rewrite (add_add_ne_swp D _ v e); now auto.
  - setoid_rewrite IHf; reflexivity.
  - setoid_rewrite IHf; reflexivity.
Qed.

Lemma vsubst_sem: forall  D (Itp: Interp D) f env s (v w: variable s) t,
  fm_sem (add v (env s w) env) f t <-> fm_sem env (vsubst v w f) t.
Proof.
  induction f; intros; try (simpl; auto; tauto); simpl.
  - rewrite at_vsubst_sem; reflexivity.
  - rewrite IHf1, IHf2; reflexivity.
  - rewrite IHf1, IHf2; reflexivity.
  - destruct (veq_dec v e).
    injection e0; intros; subst s0.
    apply inj_pair2_eq_dec in e0; try apply eq_dec; subst e.
    rewrite Ex_sem.
    split; intro h; destruct h as [d h]; exists d; revert h;
      rewrite add_add_eq; now auto.
    destruct (veq_dec w e); auto.
    injection e0; intros; subst s0.
    apply inj_pair2_eq_dec in e0; try apply eq_dec; subst e.
    rewrite Ex_sem.
    setoid_rewrite <-vswap_sem.
    assert (v <> w) by (intro; subst w; tauto); clear n H.
    split; intro h; destruct h as [d h]; exists d; revert h.
    rewrite add_eq.
    rewrite add_ne; auto.
    rewrite (add_add_ne_swp D (add v d env) v w); auto.
    rewrite add_add_eq; now auto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.

    rewrite add_eq.
    rewrite add_ne; auto.
    rewrite (add_add_ne_swp D (add v d env) v w); auto.
    rewrite add_add_eq; now auto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.

    rewrite Ex_sem.
    setoid_rewrite <-IHf.
    split; intro h; destruct h as [d h]; exists d; revert h.
    rewrite (add_ne2 _ _ _ e _ w); auto.
    rewrite add_add_ne_swp; now auto.
    rewrite (add_ne2 _ _ _ e _ w); auto.
    rewrite add_add_ne_swp; now auto.

  - destruct (veq_dec v e).
    injection e0; intros; subst s0.
    apply inj_pair2_eq_dec in e0; try apply eq_dec; subst e.
    rewrite All_sem.
    split; intros h d; specialize (h d); revert h;
      rewrite add_add_eq; now auto.
    destruct (veq_dec w e); auto.
    injection e0; intros; subst s0.
    apply inj_pair2_eq_dec in e0; try apply eq_dec; subst e.
    rewrite All_sem.
    setoid_rewrite <-vswap_sem.
    assert (v <> w) by (intro; subst w; tauto); clear n H.
    split; intros h d; specialize (h d); revert h.
    rewrite add_eq.
    rewrite add_ne; auto.
    rewrite (add_add_ne_swp D (add v d env) v w); auto.
    rewrite add_add_eq; now auto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.

    rewrite add_eq.
    rewrite add_ne; auto.
    rewrite (add_add_ne_swp D (add v d env) v w); auto.
    rewrite add_add_eq; now auto.
    intro h; apply inj_pair2_eq_dec in h; try apply eq_dec; tauto.

    rewrite All_sem.
    setoid_rewrite <-IHf.
    split; intros h d; specialize (h d); revert h.
    rewrite (add_ne2 _ _ _ e _ w); auto.
    rewrite add_add_ne_swp; now auto.
    rewrite (add_ne2 _ _ _ e _ w); auto.
    rewrite add_add_ne_swp; now auto.
  - setoid_rewrite <-IHf; reflexivity.
  - setoid_rewrite <-IHf; reflexivity.
Qed.

Notation "'[' x ':=' y ']'" := (subst x y).

Lemma Not_IAll: forall `(K:Finite) (sk: K->Sort) (vk:forall k, variable (sk k)) (f: formula),
  Not (IAll K sk vk f) = IEx K sk vk (Not f).
Proof.
  intros.
  unfold IAll, IEx.
  revert f; induction fin_set; simpl; intros; auto.
  rewrite IHs.
  reflexivity.
Qed.

Lemma Not_IEx: forall `(K:Finite) (sk: K->Sort) (vk:forall k, variable (sk k)) (f: formula),
  Not (IEx K sk vk f) = IAll K sk vk (Not f).
Proof.
  intros.
  unfold IAll, IEx.
  revert f; induction fin_set; simpl; intros; auto.
  rewrite IHs.
  reflexivity.
Qed.

Definition isSat f :=
  exists D, exists (Itp: Interp D), exists env, exists t, fm_sem env f t.

Definition equi_sat f1 f2 := isSat f1 <-> isSat f2.

Notation "f1 =s= f2" := (equi_sat f1 f2) (at level 50, no associativity).

Lemma isSat_And_elim: forall (f1 f2: formula),
  isSat (And f1 f2) -> isSat f1 /\ isSat f2.
Proof.
  intros.
  destruct H as [D [itp [env [t h]]]].
  apply And_sem in h; destruct h as [h1 h2].
  split.
  exists D; exists itp; exists env; exists t; apply h1.
  exists D; exists itp; exists env; exists t; apply h2.
Qed.

Fixpoint noEx f :=
  match f with
  | And f1 f2 | Or f1 f2 => noEx f1 /\ noEx f2
  | Ex s v f => False
  | All s v f => noEx f
  | F f | G f => noEx f
  | _ => True
  end.

Fixpoint noFO f :=
  match f with
  | And f1 f2 | Or f1 f2 => noFO f1 /\ noFO f2
  | Ex s v f | All s v f => False
  | F f | G f => noFO f
  | _ => True
  end.

Definition lt_noX l :=
  match l with
    PApp n p args => n = 0
  end.

Definition at_noX a :=
  match a with
  | Literal l => lt_noX l
  | NLiteral l => lt_noX l
  | _ => True
  end.

Fixpoint isFO f :=
  match f with
  | And f1 f2 | Or f1 f2 => isFO f1 /\ isFO f2
  | Ex s v f | All s v f => isFO f
  | F f | G f => False
  | Atom a => at_noX a
  | _ => True
  end.

Lemma lt_noX_dec: forall l, {lt_noX l}+{not (lt_noX l)}.
Proof.
  intro l; destruct l; simpl.
  destruct n; [left|right]; auto.
Qed.

Lemma at_noX_dec: forall a, {at_noX a}+{not (at_noX a)}.
Proof.
  intro a; destruct a; simpl; try (left; tauto).
  apply lt_noX_dec.
  apply lt_noX_dec.
Qed.

Lemma isFO_dec: forall f, {isFO f}+{not (isFO f)}.
Proof.
  induction f; simpl; intros; auto; try (left; tauto); try (right; tauto).
  apply at_noX_dec.
  destruct IHf1; try (right; tauto); destruct IHf2; try (right; tauto); left; tauto.
  destruct IHf1; try (right; tauto); destruct IHf2; try (right; tauto); left; tauto.
Qed.

Fixpoint isProp f :=
  match f with
  | And f1 f2 | Or f1 f2 => isProp f1 /\ isProp f2
  | Ex s v f | All s v f => False
  | F f | G f => False
  | _ => True
  end.

Lemma isFO_Not: forall f, isFO (Not f) <-> isFO f.
Proof.
  induction f; simpl; intros; try tauto.
  destruct a; simpl; tauto.
Qed.

Lemma isFO_And: forall f1 f2, isFO (And f1 f2) <-> isFO f1 /\ isFO f2.
Proof.
  intros.
  reflexivity.
Qed.

Lemma isFO_Or: forall f1 f2, isFO (Or f1 f2) <-> isFO f1 /\ isFO f2.
Proof.
  intros.
  reflexivity.
Qed.

Lemma isFO_IAnd: forall `(K: Finite) (fk: K -> formula), isFO (IAnd K fk) <-> (forall k, isFO (fk k)).
Proof.
  intros.
  unfold IAnd.
  assert ((forall k : K, isFO (fk k)) <-> (forall k : K, SV.set_In k fin_set -> isFO (fk k))).
    generalize (fin_all); intro.
    split; intros; now auto.
  rewrite H; clear H.
  induction fin_set; simpl; intros; auto.
  split; intros; tauto.
  rewrite IHs; clear IHs.
  split; intros; auto.
  destruct H0; try subst; try tauto.
  apply H; auto.
Qed.

Lemma isFO_IOr: forall `(K: Finite) (fk: K -> formula), isFO (IOr K fk) <-> (forall k, isFO (fk k)).
Proof.
  intros.
  unfold IOr.
  assert ((forall k : K, isFO (fk k)) <-> (forall k : K, SV.set_In k fin_set -> isFO (fk k))).
    generalize (fin_all); intro.
    split; intros; auto; tauto.
  setoid_rewrite H; clear H.
  induction fin_set; simpl; intros; auto.
  split; intros; tauto.
  rewrite IHs; clear IHs.
  split; intros; auto.
  destruct H0; try subst; try tauto.
  apply H; auto.
Qed.

Lemma isFO_Ex: forall s (v: variable s) f, isFO (Ex s v f) <-> isFO f.
Proof.
  intros.
  reflexivity.
Qed.

Lemma isFO_IEx: forall `(K:Finite) (sk: K->Sort) (vk:forall k, variable (sk k)) (f: formula),
  isFO (IEx K sk vk f) <-> isFO f.
Proof.
  intros.
  unfold IEx.
  induction fin_set; simpl; intros; auto; tauto.
Qed.

Lemma isFO_All: forall s (v: variable s) f, isFO (All s v f) <-> isFO f.
Proof.
  intros.
  reflexivity.
Qed.

Lemma isFO_Imp: forall f1 f2, isFO (Imp f1 f2) <-> isFO f1 /\ isFO f2.
Proof.
  intros.
  unfold Imp.
  rewrite isFO_Or.
  simpl.
  rewrite isFO_Not.
  reflexivity.
Qed.

Fixpoint isAll f :=
  match f with
  | All s v f => isAll f
  | _ => isProp f
  end.

Fixpoint isExAll f :=
  match f with
  | Ex s v f => isExAll f
  | f => isAll f
  end.

Lemma isProp_dec f : {isProp f}+{not (isProp f)}.
Proof.
  induction f; simpl; intros; try (left; now auto); try (right; tauto).
  destruct IHf1; [idtac | right; tauto].
  destruct IHf2; [left | right]; tauto.

  destruct IHf1; [idtac | right; tauto].
  destruct IHf2; [left | right]; tauto.
Defined.

Lemma isAll_dec f : {isAll f}+{not (isAll f)}.
Proof.
  induction f; simpl; intros; try (left; now auto); try (right; tauto); auto.
  destruct (isProp_dec f1); [idtac | right; tauto].
  destruct (isProp_dec f2); [left | right]; tauto.

  destruct (isProp_dec f1); [idtac | right; tauto].
  destruct (isProp_dec f2); [left | right]; tauto.
Defined.

Lemma isExAll_dec f : {isExAll f}+{not (isExAll f)}.
Proof.
  induction f; simpl; intros; try (left; now auto); try (right; tauto); auto.
  destruct (isProp_dec f1); [idtac | right; tauto].
  destruct (isProp_dec f2); [left | right]; tauto.

  destruct (isProp_dec f1); [idtac | right; tauto].
  destruct (isProp_dec f2); [left | right]; tauto.

  apply (isAll_dec f).
Defined.

End FO.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e291m19_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e488m17_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e206m5_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Specification DemonicComposition Statement Predicative.

Require Import Lia.

Open Scope stmt_scope.

Definition spec : Stmt (nat * nat) := ⟨fun '(x,y) '(x',y') => x >= y /\ x' = y /\ y' = x⟩.

Definition prog : Stmt (nat*nat) := $(x,y) := (x - y, y); $(x,y) := (x, x + y); $(x,y) := (y - x, y).

Theorem correctness : prog ⊑ spec.
Proof.
  unfold refines.
  intros (x,y) ((u,v),(HHxy,_)).
  split.
  { intros (x',y').
    intros (((a,b), (HH11,(((c,d),(HH,HH')),HH122))),HH2).
    simpl in HH11,HH,HH'.
    simpl in *.
    inversion HH11; subst a b; clear HH11.
    inversion HH; subst c d; clear HH.
    inversion HH'; subst x' y'; clear HH'.
    repeat split; try lia.
  }
  { exists (y,x).
    split.
    { exists (x - y,y); split.
      { reflexivity. }
      { split.
        { exists (x - y, x - y + y); split.
          { reflexivity. }
          { simpl; f_equal; lia. }
        }
        { intros (a,b) HHpred; simpl in HHpred.
          inversion_clear HHpred.
          exists (x - y + y - (x - y), x - y + y); reflexivity.
        }
      }
    }
    { intros (a,b) HHpred.
      inversion HHpred; subst a b; clear HHpred.
      exists ((x-y) + y - (x - y), (x - y) + y).
      split.
      { exists (x - y, x - y + y); split; reflexivity. }
      { intros (a,b) HHab.
        inversion HHab; subst a b; clear HHab.
        exists ((x - y + y) - (x - y), x - y + y); reflexivity.
      }
    }
  }
Qed.

Print Assumptions correctness.

Close Scope stmt_scope.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e266m3_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(***************************************************************************
* Target language definitions From Ahmed & Blume ICFP 2011                 *
* William J. Bowman, Phillip Mates & James T. Perconti                     *
***************************************************************************)

Require Import Core_Definitions LibWfenv.

(* ********************************************************************** *)

(* Locally-closed types and terms  *)

(* Target Types *)

Inductive t_type : typ -> Prop :=
  | t_type_var : forall x, t_type (t_typ_fvar x)
  | t_type_bool : t_type t_typ_bool
  | t_type_pair : forall t1 t2,
      t_type t1 -> t_type t2 -> t_type (t_typ_pair t1 t2)
  | t_type_arrow : forall L t1 t2,
      (forall X, X \notin L -> t_type (open_tt_var t1 X)) ->
      (forall X, X \notin L -> t_type (open_tt_var t2 X)) ->
      t_type (t_typ_arrow t1 t2).

Hint Constructors t_type.

(* Target Terms *)

Inductive t_term : trm -> Prop :=
  | t_term_value : forall u, t_value u -> t_term u
  | t_term_if : forall u m1 m2,
      t_value u -> t_term m1 -> t_term m2 -> t_term (t_trm_if u m1 m2)
  | t_term_let_fst : forall L u m,
      t_value u ->
      (forall x, x \notin L -> t_term (t_open_ee_var m x)) ->
      t_term (t_trm_let_fst u m)
  | t_term_let_snd : forall L u m,
      t_value u ->
      (forall x, x \notin L -> t_term (t_open_ee_var m x)) ->
      t_term (t_trm_let_snd u m)
  | t_term_app : forall u1 t u2,
      t_value u1 -> t_type t -> t_value u2 -> t_term (t_trm_app u1 t u2)

with t_value : trm -> Prop :=
  | t_value_var : forall x, t_value (t_trm_fvar x)
  | t_value_true : t_value t_trm_true
  | t_value_false : t_value t_trm_false
  | t_value_pair : forall u1 u2,
      t_value u1 -> t_value u2 -> t_value (t_trm_pair u1 u2)
  | t_value_abs  : forall L t m,
      (forall X, X \notin L -> t_type (open_tt_var t X)) ->
      (forall x X, x \notin L -> X \notin L ->
        t_term (open_te_var (t_open_ee_var m x) X)) ->
      t_value (t_trm_abs t m).

Scheme t_term_mut := Induction for t_term Sort Prop
with t_value_mut := Induction for t_value Sort Prop.

Hint Constructors t_term t_value.

(* Type System *)

(* Delta |- tau *)
Inductive t_wft : env_type -> typ -> Prop :=
  | t_wft_var : forall D X, ok D -> binds X star D -> t_wft D (t_typ_fvar X)
  | t_wft_bool : forall D, ok D -> t_wft D t_typ_bool
  | t_wft_pair : forall D t1 t2,
      t_wft D t1 -> t_wft D t2 -> t_wft D (t_typ_pair t1 t2)
  | t_wft_arrow : forall L D t1 t2,
      (forall X, X \notin L -> t_wft (D & X ~ star) (open_tt_var t1 X)) ->
      (forall X, X \notin L -> t_wft (D & X ~ star) (open_tt_var t2 X)) ->
      t_wft D (t_typ_arrow t1 t2).

Hint Constructors t_wft.

(** Typing relation *)
(* Delta;Gamma |- m:t *)
Inductive t_typing : env_type -> env_term -> trm -> typ -> Prop :=
  | t_typing_value : forall D G u t,
      t_value_typing D G u t -> t_typing D G u t
  | t_typing_if : forall D G u m1 m2 t,
      t_value_typing D G u t_typ_bool ->
      t_typing D G m1 t -> t_typing D G m2 t ->
      t_typing D G (t_trm_if u m1 m2) t
  | t_typing_let_fst : forall L D G u m t1 t2 t,
      t_value_typing D G u (t_typ_pair t1 t2) ->
      (forall x, x \notin L -> t_typing D (G & x ~ t1) (t_open_ee_var m x) t) ->
      t_typing D G (t_trm_let_fst u m) t
  | t_typing_let_snd : forall L D G u m t1 t2 t,
      t_value_typing D G u (t_typ_pair t1 t2) ->
      (forall x, x \notin L -> t_typing D (G & x ~ t2) (t_open_ee_var m x) t) ->
      t_typing D G (t_trm_let_snd u m) t
  | t_typing_app : forall D G u1 u2 t t1 t2,
      t_value_typing D G u1 (t_typ_arrow t1 t2) ->
      t_wft D t ->
      t_value_typing D G u2 (open_tt t1 t) ->
      t_typing D G (t_trm_app u1 t u2) (open_tt t2 t)

with t_value_typing : env_type -> env_term -> trm -> typ -> Prop :=
  | t_value_typing_var : forall D G x t,
      ok D -> wfenv (t_wft D) G -> binds x t G ->
      t_value_typing D G (t_trm_fvar x) t
  | t_value_typing_true : forall D G,
      ok D -> wfenv (t_wft D) G -> t_value_typing D G t_trm_true t_typ_bool
  | t_value_typing_false : forall D G,
      ok D -> wfenv (t_wft D) G -> t_value_typing D G t_trm_false t_typ_bool
  | t_value_typing_pair : forall D G u1 u2 t1 t2,
      t_value_typing D G u1 t1 -> t_value_typing D G u2 t2 ->
      t_value_typing D G (t_trm_pair u1 u2) (t_typ_pair t1 t2)
  | t_value_typing_abs : forall L D G m t1 t2,
      wfenv (t_wft D) G ->
      (forall x X, x \notin L -> X \notin L ->
        t_typing (D & X ~ star)
                 (G & x ~ (open_tt_var t1 X))
                 (open_te_var (t_open_ee_var m x) X)
                 (open_tt_var t2 X)) ->
      t_value_typing D G (t_trm_abs t1 m) (t_typ_arrow t1 t2).

Scheme t_typing_mut := Induction for t_typing Sort Prop
with t_value_typing_mut := Induction for t_value_typing Sort Prop.

Hint Constructors t_typing t_value_typing.

(* CPS makes evaluation context of target lang simple *)
Inductive t_eval_context : ctx -> Prop :=
  | t_eval_context_hole : t_eval_context t_ctx_hole.

(* Well-formed context *)
Inductive t_context : bool (* accept only values? *) -> ctx -> Prop :=
  | t_context_value_context : forall b C,
      t_value_context b C -> t_context b C
  | t_context_hole : forall b, t_context b t_ctx_hole
  | t_context_if : forall b C m1 m2,
      t_value_context b C -> t_term m1 -> t_term m2 ->
      t_context b (t_ctx_if C m1 m2)
  | t_context_if_true : forall u b C m2,
      t_value u -> t_context b C -> t_term m2 ->
      t_context b (t_ctx_if_true u C m2)
  | t_context_if_false : forall u m1 b C,
      t_value u -> t_term m1 -> t_context b C ->
      t_context b (t_ctx_if_false u m1 C)
  | t_context_let_fst : forall L b C m,
      t_value_context b C ->
      (forall x, x \notin L -> t_term (t_open_ee_var m x)) ->
      t_context b (t_ctx_let_fst C m)
  | t_context_let_fst_k : forall L u b C,
      t_value u ->
      (forall x, x \notin L -> t_context b (t_ctx_open_ee_var C x)) ->
      t_context b (t_ctx_let_fst_k u C)
  | t_context_let_snd : forall L b C m,
      t_value_context b C ->
      (forall x, x \notin L -> t_term (t_open_ee_var m x)) ->
      t_context b (t_ctx_let_snd C m)
  | t_context_let_snd_k : forall L u b C,
      t_value u ->
      (forall x, x \notin L -> t_context b (t_ctx_open_ee_var C x)) ->
      t_context b (t_ctx_let_snd_k u C)
  | t_context_app1 : forall b C t u,
      t_value_context b C -> t_type t -> t_value u ->
      t_context b (t_ctx_app1 C t u)
  | t_context_app2 : forall u t b C,
      t_value u -> t_type t -> t_value_context b C ->
      t_context b (t_ctx_app2 u t C)

with t_value_context : bool (* accept only values? *) -> ctx -> Prop :=
  | t_value_context_hole : t_value_context true t_ctx_hole
  | t_value_context_pair_left : forall b C u,
      t_value_context b C -> t_value u ->
      t_value_context b (t_ctx_pair_left C u)
  | t_value_context_pair_right : forall b C u,
      t_value u -> t_value_context b C ->
      t_value_context b (t_ctx_pair_right u C)
  | t_value_context_abs : forall L t b C,
      (forall X, X \notin L -> t_type (open_tt_var t X)) ->
      (forall x X, x \notin L -> X \notin L ->
        t_context b (ctx_open_te_var (t_ctx_open_ee_var C x) X)) ->
      t_value_context b (t_ctx_abs t C).

Scheme t_context_mut := Induction for t_context Sort Prop
with t_value_context_mut := Induction for t_value_context Sort Prop.

Hint Constructors t_context t_value_context.

(* typing for contexts *)

Inductive t_context_typing (* |- C : ( D ; G |- t ) ~> ( D' ; G' |- t' ) *)
  : bool (* accept only values? *) -> ctx ->
    env_type -> env_term -> typ -> env_type -> env_term -> typ -> Prop :=
  | t_context_typing_hole : forall b D_hole G_hole t_hole D G,
      wfenv (t_wft D_hole) G_hole -> wfenv (t_wft (D_hole & D)) (G_hole & G) ->
      t_wft D_hole t_hole -> ok (D_hole & D) ->
      t_context_typing b t_ctx_hole D_hole G_hole t_hole
                                    (D_hole & D) (G_hole & G) t_hole
  | t_context_typing_if : forall b Cv D_hole G_hole t_hole D G m1 m2 t,
      t_value_context_typing b Cv D_hole G_hole t_hole D G t_typ_bool ->
      t_typing D G m1 t -> t_typing D G m2 t ->
      t_context_typing b (t_ctx_if Cv m1 m2) D_hole G_hole t_hole D G t
  | t_context_typing_if_true : forall b C D_hole G_hole t_hole D G u m2 t,
      t_value_typing D G u t_typ_bool ->
      t_context_typing b C D_hole G_hole t_hole D G t -> t_typing D G m2 t ->
      t_context_typing b (t_ctx_if_true u C m2) D_hole G_hole t_hole D G t
  | t_context_typing_if_false : forall b C D_hole G_hole t_hole D G u m1 t,
      t_value_typing D G u t_typ_bool ->
      t_typing D G m1 t -> t_context_typing b C D_hole G_hole t_hole D G t ->
      t_context_typing b (t_ctx_if_false u m1 C) D_hole G_hole t_hole D G t
  | t_context_typing_let_fst : forall b L Cv D_hole G_hole t_hole D G m t1 t2 t,
      t_value_context_typing b Cv D_hole G_hole t_hole D G (t_typ_pair t1 t2) ->
      (forall x, x \notin L ->
        t_typing D (G & x ~ t1) (t_open_ee_var m x) t) ->
      t_context_typing b (t_ctx_let_fst Cv m) D_hole G_hole t_hole D G t
  | t_context_typing_let_fst_k
    : forall b L C D_hole G_hole t_hole D G u t1 t2 t,
      t_value_typing D G u (t_typ_pair t1 t2) ->
      (forall x, x \notin L ->
        t_context_typing b (t_ctx_open_ee_var C x) D_hole G_hole t_hole
                                                   D (G & x ~ t1) t) ->
      t_context_typing b (t_ctx_let_fst_k u C) D_hole G_hole t_hole D G t
  | t_context_typing_let_snd : forall b L Cv D_hole G_hole t_hole D G m t1 t2 t,
      t_value_context_typing b Cv D_hole G_hole t_hole D G (t_typ_pair t1 t2) ->
      (forall x, x \notin L ->
        t_typing D (G & x ~ t2) (t_open_ee_var m x) t) ->
      t_context_typing b (t_ctx_let_snd Cv m) D_hole G_hole t_hole D G t
  | t_context_typing_let_snd_k
    : forall b L C D_hole G_hole t_hole D G u t1 t2 t,
      t_value_typing D G u (t_typ_pair t1 t2) ->
      (forall x, x \notin L ->
        t_context_typing b (t_ctx_open_ee_var C x) D_hole G_hole t_hole
                                                   D (G & x ~ t2) t) ->
      t_context_typing b (t_ctx_let_snd_k u C) D_hole G_hole t_hole D G t
  | t_context_typing_app1 : forall b Cv D_hole G_hole t_hole D G u t t1 t2,
      t_value_context_typing b Cv D_hole G_hole t_hole
                                  D G (t_typ_arrow t1 t2) ->
      t_wft D t ->
      t_value_typing D G u (open_tt t1 t) ->
      t_context_typing b (t_ctx_app1 Cv t u) D_hole G_hole t_hole
                       D G (open_tt t2 t)
  | t_context_typing_app2 : forall b Cv D_hole G_hole t_hole D G u t t1 t2,
      t_value_typing D G u (t_typ_arrow t1 t2) ->
      t_wft D t ->
      t_value_context_typing b Cv D_hole G_hole t_hole D G (open_tt t1 t) ->
      t_context_typing b (t_ctx_app2 u t Cv) D_hole G_hole t_hole
                                             D G (open_tt t2 t)

with t_value_context_typing (* |- Cv : ( D ; G |- t ) ~> ( D' ; G' |- t' ) *)
  : bool (* accept only values? *) -> ctx ->
    env_type -> env_term -> typ -> env_type -> env_term -> typ -> Prop :=
  | t_value_context_typing_hole : forall D_hole G_hole t_hole D G,
      wfenv (t_wft D_hole) G_hole -> wfenv (t_wft (D_hole & D)) (G_hole & G) ->
      t_wft D_hole t_hole -> ok (D_hole & D) ->
      t_value_context_typing true t_ctx_hole D_hole G_hole t_hole
                                             (D_hole & D) (G_hole & G) t_hole
  | t_value_context_typing_pair_left
    : forall b Cv D_hole G_hole t_hole D G u t1 t2,
      t_value_context_typing b Cv D_hole G_hole t_hole D G t1 ->
      t_value_typing D G u t2 ->
      t_value_context_typing b (t_ctx_pair_left Cv u) D_hole G_hole t_hole
                                                      D G (t_typ_pair t1 t2)
  | t_value_context_typing_pair_right
    : forall b Cv D_hole G_hole t_hole D G u t1 t2,
      t_value_context_typing b Cv D_hole G_hole t_hole D G t2 ->
      t_value_typing D G u t1 ->
      t_value_context_typing b (t_ctx_pair_right u Cv) D_hole G_hole t_hole
                                                       D G (t_typ_pair t1 t2)
  | t_value_context_typing_abs : forall b L C D_hole G_hole t_hole D G t1 t2,
      wfenv (t_wft D) G ->
      (forall x X, x \notin L -> X \notin L ->
        t_context_typing b (ctx_open_te_var (t_ctx_open_ee_var C x) X)
                       D_hole G_hole t_hole
                       (D & X ~ star) (G & x ~ (open_tt_var t1 X))
                       (open_tt_var t2 X)) ->
      t_value_context_typing b (t_ctx_abs t1 C) D_hole G_hole t_hole
                                                D G (t_typ_arrow t1 t2).

Scheme t_context_typing_mut := Induction for t_context_typing Sort Prop
with t_value_context_typing_mut
  := Induction for t_value_context_typing Sort Prop.

Hint Constructors t_context_typing t_value_context_typing.

(** reduction *)

(** one step *)
Inductive t_red_base : trm -> trm -> Prop :=
  | t_red_if_true : forall m1 m2,
      t_term m1 -> t_term m2 -> t_red_base (t_trm_if t_trm_true m1 m2) m1
  | t_red_if_false : forall m1 m2,
      t_term m1 -> t_term m2 -> t_red_base (t_trm_if t_trm_false m1 m2) m2
  | t_red_let_fst : forall u1 u2 m,
      t_value u1 -> t_value u2 -> t_term m ->
      t_red_base (t_trm_let_fst (t_trm_pair u1 u2) m) (t_open_ee m u1)
  | t_red_let_snd : forall u1 u2 m,
      t_value u1 -> t_value u2 -> t_term m ->
      t_red_base (t_trm_let_snd (t_trm_pair u1 u2) m) (t_open_ee m u2)
  | t_red_app : forall t1 m t u,
      t_value (t_trm_abs t1 m) -> t_type t -> t_value u ->
      t_red_base (t_trm_app (t_trm_abs t1 m) t u) (open_te (t_open_ee m u) t).

(** context step *)
Inductive t_red : trm -> trm -> Prop :=
  | t_red_ctx : forall E m m',
      t_red_base m m' -> t_eval_context E -> t_red (plug E m) (plug E m').

(** multi-step step *)
Inductive t_red_star : trm -> trm -> Prop :=
  | t_red_refl : forall m, t_term m -> t_red_star m m
  | t_red_step : forall m1 m2 m3,
      t_red m1 m2 -> t_red_star m2 m3 -> t_red_star m1 m3.

Inductive t_eval : trm -> trm -> Prop :=
  | t_eval_red : forall m u,
      t_red_star m u -> t_value u -> t_eval m u.

(* contextual equivalence *)

Definition t_ctx_approx (D : env_type) (G : env_term) (m1 m2 : trm) (t : typ) :=
  t_typing D G m1 t /\ t_typing D G m2 t /\
  forall C u,
    t_context_typing false C D G t empty empty t_typ_bool ->
    t_eval (plug C m1) u ->
    t_eval (plug C m2) u.

Definition t_ctx_equiv (D : env_type) (G : env_term) (m1 m2 : trm) (t : typ) :=
  t_ctx_approx D G m1 m2 t /\ t_ctx_approx D G m2 m1 t.

(* CIU equivalence *)
(* This definition isn't actually useful: it only handles terms of type bool *)

Definition ciu_approx (D : env_type) (G : env_term) (m1 m2 : trm) (t : typ) :=
  t_typing D G m1 t /\ t_typing D G m2 t /\
  forall E d g u,
    t_eval_context E ->
    t_context_typing false E empty empty (subst_tt d t)
                             empty empty t_typ_bool ->
    relenv t_type d (fun _ => True) D (fun t _ => t_wft empty t) ->
    relenv t_value g t_type G (t_typing D empty) ->
    t_eval (plug E (subst_te d (t_subst_ee g m1))) u ->
    t_eval (plug E (subst_te d (t_subst_ee g m2))) u.


Require Import Coq.Reals.Rdefinitions.
Require Import ExtLib.Tactics.
Require Import Logic.Logic.
Require Import Logic.BasicProofRules.
Require Import Logic.Stability.
Require Import Logic.LyapunovFunctions.
Require Import Logic.ArithFacts.
Require Import Coq.Lists.List.
Require Import Examples.DiffEqSolutions.

Local Open Scope HP_scope.
Local Open Scope string_scope.

Module Type Params.

  Parameter d : R.
  Axiom d_gt_0 : (d > 0)%R.

End Params.

Module Stability (Import P : Params).

  Definition Abs (x : Term) : Term :=
    MAX(x,--x).

  Definition World : Evolution :=
    fun st' =>
      st' "y" = "v" //\\ st' "t" = 1 //\\
      st' "v" = 0 //\\ st' "T" = 0 //\\ "t" - "T" < d.

  Definition Ctrl (v : Term) : Formula :=
    v = --"y"/d.

  Definition Next : Formula :=
    Continuous World \\//
   (Ctrl "v"! //\\ "T"! = "t" //\\
    Unchanged ("t"::"y"::nil)).

  Definition Init : Formula :=
    "t" = 0 //\\ "T" = "t" //\\ Ctrl "v".

  Definition Spec : Formula :=
    Init //\\ []Next.

  Definition AbstractWorld : Evolution :=
    fun st' =>
      st' "y" = --"y"/(d + "T" - "t") //\\  st' "t" = 1 //\\
      st' "T" = 0 //\\ "t" - "T" < d.

  Definition AbstractNext : Formula :=
    Continuous AbstractWorld \\// "T"! = "t" //\\
    Unchanged ("t"::"y"::nil).

  Definition velocity_formula : Formula :=
    "v" = --"y"/(d + "T" - "t").

  Lemma world_abstraction_ind :
    velocity_formula //\\ Continuous World |--
    next velocity_formula.
  Proof.
    zero_deriv_tac "v".
    zero_deriv_tac "T".
    tlaAssert ("t"! - "T"! < d).
    { rewrite ContinuousProofRules.Continuous_st_formula
      with (F:="t"-"T" < d).
      - simpl next. restoreAbstraction. charge_assumption.
      - tlaIntuition.
      - tlaIntuition.
      - solve_linear. }
    assert (World |-- sgl_int)
      by (apply Evolution_lentails_lentails; red; red; solve_linear).
    rewrite H. clear H. rewrite solve_sgl.
    reason_action_tac. intuition.
    rewrite H1 in *. rewrite H2 in *. rewrite H3 in *.
    rewrite H in *. clear H1 H2 H H3.
    admit. (* A version of Z3 can prove this. *)
  Admitted.

  Lemma abstraction :
    Spec |-- Init //\\ []AbstractNext.
  Proof.
    tlaAssert ([]velocity_formula).
    - eapply discr_indX.
      + tlaIntuition.
      + charge_assumption.
      + solve_linear. rewrite H0. rewrite H. rewrite H3.
        rewrite_real_zeros. solve_linear.
      + unfold Next. rewrite Lemmas.land_lor_distr_R.
        apply lorL.
        * apply world_abstraction_ind.
        * solve_linear. rewrite H1. rewrite H2. rewrite H3.
          rewrite H.
          admit. (* A version of Z3 can prove this. *)
    - charge_intros.
      charge_split.
      + charge_tauto.
      + unfold Spec. tlaRevert. tlaRevert.
        apply Lemmas.forget_prem.
        charge_intros. rewrite Always_and.
        tlaRevert. apply Always_imp. charge_intros.
        unfold Next. rewrite Lemmas.land_lor_distr_R.
        apply lorL.
        * apply lorR1.
          eapply Lemmas.lcut.
          apply continuous_strengthen with (H:=velocity_formula).
          { tlaIntuition. }
          { charge_assumption. }
          { charge_assumption. }
          { apply world_abstraction_ind. }
          { apply Lemmas.forget_prem.
            charge_intros. apply Proper_Continuous_entails.
            red. red. red. solve_linear. }
        * apply lorR2.
          charge_tauto.
  Admitted.

  Theorem lyapunov_stability :
    |-- Spec -->> LyapunovStable "y".
  Proof.
    charge_intros.
    apply Lemmas.lcut with (R:=Init //\\ []AbstractNext).
    { apply abstraction. }
    apply Lemmas.forget_prem. charge_intros.
    apply lyapunov_fun_stability
    with (V:="y"*"y") (V':=fun st' => st' "y"*"y" + "y"*st' "y")
                      (cp:=AbstractWorld).
    - reflexivity.
    - reflexivity.
    - tlaIntuition.
    - breakAbstraction. intros. congruence.
    - tlaRevert. apply Lemmas.forget_prem.
      apply Always_imp. charge_intros.
      apply lorL.
      + charge_tauto.
      + apply lorR2. simpl Unchanged. restoreAbstraction.
        charge_assumption.
    - breakAbstraction. intros.
      forward_reason.
      generalize dependent (Stream.hd tr "y").
      generalize dependent (Stream.hd tr "t").
      generalize dependent (Stream.hd tr "T").
      generalize dependent (x "y"). clear.
      intros.
      assert ((0 - v2) * v2 <= 0)%R.
      { solve_nonlinear. }
      assert (v * v2 <= 0)%R.
      { subst.
        match goal with
        | |- Rle (_ * ?X * _)%R _ =>
          assert (0 <= X)%R by (eapply inv_0_le; solve_linear) ; generalize dependent X
        end.
        intros.
        cutrewrite (eq ((0 - v2) * r * v2) (((0 - v2) * v2) * r))%R.
        { generalize dependent ((0 - v2) * v2)%R.
          intros. rewrite Raxioms.Rmult_comm. eapply Rmult_le_0; auto. }
        solve_linear. }
      solve_linear.
    - breakAbstraction. intros.
      apply RIneq.Rlt_gt.
      apply RIneq.Rlt_0_sqr.
      assumption.
    - solve_linear.
  Qed.

End Stability.


Theorem proof : forall A , A -> A.
intros.
auto. Show Proof.
Qed.


Require Export core.

Inductive labeledType : Type :=
  | larr :  label -> labeledType
  | lnat :  label -> labeledType.

Definition environment: Type := variable -> (option labeledType).

Inductive TracePat : Type :=
  | Read       : variable -> TracePat
  | Write      : variable -> TracePat
  | Readarr    : variable -> TracePat
  | Writearr   : variable -> TracePat
  | Loop       : location -> TracePat -> TracePat -> TracePat
  | Fetch      : location -> TracePat
  | Orambank   : orambank -> TracePat
  | Concat     : TracePat -> TracePat -> TracePat
  | TracePplus : TracePat -> TracePat -> TracePat
  | Epsilon    : TracePat.

Fixpoint tracepat_len (tp : TracePat) : nat :=
  match tp with
  | Epsilon => 0
  | Concat tp1 tp2 => plus (tracepat_len tp1) (tracepat_len tp2)
  | _ => 1
  end.

Fixpoint ithelement_tp (tp:TracePat) (i:nat) : TracePat:=
  match i with
  | O   => Epsilon
  | S O =>
      match tp with
      | Concat tp1 tp2 =>
         match tp1 with
         | Epsilon => ithelement_tp tp2 i
         | _ => ithelement_tp tp1 i
         end
      | Epsilon        => Epsilon
      |              _ => tp
      end
  | S (S n) =>
      match tp with
      | Concat tp1 tp2 => Epsilon
      | _ => Epsilon
      end
  end.

Inductive TracePatEquiv: TracePat -> TracePat -> Prop:=
  | Epsilon_equiv: TracePatEquiv Epsilon Epsilon
  | O_equiv : forall n, TracePatEquiv (Orambank n) (Orambank n)
  | Read_equiv : forall x, TracePatEquiv (Read x) (Read x)
  | Fetch_equiv: forall p, TracePatEquiv (Fetch p) (Fetch p)
  | Assoc_equiv: forall t1 t2 t3, TracePatEquiv (Concat (Concat t1 t2) t3) (Concat t1 (Concat t2 t3))
  | Trans_equiv: forall t1 t2 t3, (TracePatEquiv t1 t2) -> (TracePatEquiv t2 t3) -> (TracePatEquiv t1 t3)
  | Epsilon_ident_equivl: forall T, (TracePatEquiv T T) -> TracePatEquiv T (Concat Epsilon T)
  | Epsilon_ident_equivr: forall T, (TracePatEquiv T T) -> TracePatEquiv T (Concat T Epsilon)
  | Concat_decomp_equiv: forall T11 T21 T12 T22,
      (TracePatEquiv T11 T12) -> (TracePatEquiv T21 T22) ->
      (TracePatEquiv (Concat T11 T21) (Concat T12 T22)).

Lemma TracePatEquiv_sym : forall T1 T2, (TracePatEquiv T1 T2) -> (TracePatEquiv T2 T1).
Proof.
Admitted.

Definition evtTracePat l t:  TracePat :=
  match l with
  | low => t
  | o_high a => Orambank a
  end.

Inductive exprTyping: environment -> expression -> labeledType -> TracePat -> Prop :=
  | TVar : forall (gamma:environment) (x:variable) l,
      ((gamma x) = (Some (lnat l))) ->
      (exprTyping gamma (exvar x) (lnat l) (evtTracePat l (Read x)))

  | TCon : forall (gamma:environment) n, exprTyping gamma (exnum n) (lnat low) Epsilon

  | TOp : forall (gamma:environment) e1 e2 l1 l2 T1 T2 op,
      (exprTyping gamma e1 (lnat l1) T1) ->
      (exprTyping gamma e2 (lnat l2) T2) ->
      (exprTyping gamma (exop e1 op e2) (lnat (mtojoin l1 l2)) (Concat T1 T2))

  | TArr : forall (gamma:environment) x e l l2 T,
      ((gamma x) =(Some (larr l))) ->
      (exprTyping gamma e (lnat l2) T) ->
      (label_le l2 l) ->
      (exprTyping gamma (exarr x e) (lnat (mtojoin l l2)) (Concat T (evtTracePat l (Readarr x)))).

Inductive select : TracePat -> TracePat -> TracePat -> Prop :=
  | equiv : forall t1 t2, (TracePatEquiv t1 t2) -> (select t1 t2 t1)
  | inequiv : forall t1 t2, (~(TracePatEquiv t1 t2)) -> (select t1 t2 (TracePplus t1 t2)).

Inductive statementTyping: environment -> label -> labeledstatement -> TracePat -> Prop :=
  | TSkip : forall gamma p l, statementTyping gamma l (labline p skip) Epsilon
  | TAsn : forall gamma e l p T x l0 l1, (exprTyping gamma e (lnat l) T) ->
      (gamma x = Some (lnat l1)) -> (label_le (mtojoin l0 l) l1) ->
      (statementTyping gamma l0 (labline p (assign x e)) (Concat T (evtTracePat l1 (Write x))))
  | TAAsn : forall gamma e1 e2 l1 l2 T1 T2 l0 l x p,
      (exprTyping gamma e1 (lnat l1) T1) -> (exprTyping gamma e2 (lnat l2) T2) ->
      ((gamma x) = Some (larr l)) -> (label_le (mtojoin l1 (mtojoin l2 l0)) l) ->
      (statementTyping gamma l0 (labline p (arrassign x e1 e2)) (Concat T1 (Concat T2 (evtTracePat l (Writearr x)))))
  | TCond : forall gamma e l l0 T1 T2 T S1 S2 T3 p,
      (exprTyping gamma e (lnat l) T) ->
      (progTyping gamma (mtojoin l l0) S1 T1) ->
      (progTyping gamma (mtojoin l l0) S2 T2) ->
      (((mtojoin l l0) <> low) -> (TracePatEquiv T1 T2)) -> (select T1 T2 T3) ->
      (statementTyping gamma l0 (labline p (stif e S1 S2)) (Concat T T3))
  | TWhile : forall gamma e l l0 T1 T2 S p,
      (exprTyping gamma e (lnat l) T1) ->
      (progTyping gamma l0 S T2) ->
      (label_le (mtojoin l l0) low) ->
      (statementTyping gamma l0 (labline p (stwhile e S )) (Loop p T1 T2))

with progTyping: environment -> label -> program -> TracePat -> Prop :=

(***
  for this rule, they require that l0 (elle zero, not ten)
  is less/equal p (where
    l0 is a label and
    p is a location,
  We use a special relation called label_le_rhslocation for this.
***)

  | TLab : forall gamma l0 s T p,  (statementTyping gamma l0 (labline p s) T) -> (label_le_rhslocation l0 p) ->
      (progTyping gamma l0 (oneLineProg( labline p s)) (Concat (Fetch p) T))
  | TSeq : forall gamma l0 S1 T1 S2 T2, ((progTyping gamma l0 S1 T1) ->
      (progTyping gamma l0 S2 T2) ->
      (progTyping gamma l0 (progcat S1 S2) (Concat T1 T2))).


Require Import primRec.
Require Import cPair.
Require Import Coq.Lists.List.
Require Import ListExt.
Require Import Arith.
Require Export codeList.
Require Import folProp.
Require Import code.

Section Code_Free_Vars.

Variable L : Language.
Variable codeF : Functions L -> nat.
Variable codeR : Relations L -> nat.

Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let var := var L.
Let apply := apply L.
Let equal := equal L.
Let atomic := atomic L.
Let impH := impH L.
Let notH := notH L.
Let forallH := forallH L.
Let orH := orH L.
Let andH := andH L.
Let existH := existH L.
Let iffH := iffH L.
Let ifThenElseH := ifThenElseH L.

Definition codeFreeVarTermTerms : nat -> nat :=
  evalStrongRec 0
    (fun t recs : nat =>
     cPair
       (switchPR (cPairPi1 t) (cPairPi2 (codeNth (t - S (cPairPi2 t)) recs))
          (S (cPair (cPairPi2 t) 0)))
       (switchPR t
          (codeApp (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
             (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs))) 0)).

Definition codeFreeVarTerm (t : nat) : nat :=
  cPairPi1 (codeFreeVarTermTerms t).

Definition codeFreeVarTerms (t : nat) : nat :=
  cPairPi2 (codeFreeVarTermTerms t).

Lemma codeFreeVarTermCorrect :
 forall t : Term,
 codeFreeVarTerm (codeTerm L codeF t) = codeList (freeVarTerm L t).
Proof.
intros.
elim t using
 Term_Terms_ind
  with
    (P0 := fun (n : nat) (ts : fol.Terms L n) =>
           codeFreeVarTerms (codeTerms L codeF n ts) =
           codeList (freeVarTerms L n ts)); intros.
simpl in |- *.
unfold codeTerm in |- *.
unfold codeFreeVarTerm in |- *.
unfold codeFreeVarTermTerms in |- *.
unfold evalStrongRec in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
simpl in |- *.
reflexivity.
unfold freeVarTerm in |- *.
fold (freeVarTerms L (arity L (inr (Relations L) f)) t0) in |- *.
rewrite <- H.
clear H.
unfold codeTerm in |- *.
fold (codeTerms L codeF (arity L (inr (Relations L) f)) t0) in |- *.
generalize (codeTerms L codeF (arity L (inr (Relations L) f)) t0).
intros.
unfold codeFreeVarTerm in |- *.
unfold codeFreeVarTermTerms in |- *.
set
 (g :=
  fun t1 recs : nat =>
  cPair
    (switchPR (cPairPi1 t1) (cPairPi2 (codeNth (t1 - S (cPairPi2 t1)) recs))
       (S (cPair (cPairPi2 t1) 0)))
    (switchPR t1
       (codeApp (cPairPi1 (codeNth (t1 - S (cPairPi1 (pred t1))) recs))
          (cPairPi2 (codeNth (t1 - S (cPairPi2 (pred t1))) recs))) 0))
 in *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
rewrite computeEvalStrongRecHelp.
unfold compose2 in |- *.
unfold evalComposeFunc in |- *.
unfold g at 1 in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
rewrite (evalStrongRecHelp1 g (cPair (S (codeF f)) n) n).
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold codeFreeVarTerms in |- *.
unfold codeFreeVarTermTerms in |- *.
fold g in |- *.
reflexivity.
apply cPairLt2.
simpl in |- *.
unfold codeTerms in |- *.
unfold codeFreeVarTerms in |- *.
unfold codeFreeVarTermTerms in |- *.
unfold evalStrongRec in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
unfold freeVarTerms in |- *.
fold (freeVarTerm L t0) in |- *.
fold (freeVarTerms L n t1) in |- *.
rewrite <- codeAppCorrect.
rewrite <- H.
rewrite <- H0.
clear H H0.
unfold codeTerms in |- *.
fold (codeTerm L codeF t0) in |- *.
fold (codeTerms L codeF n t1) in |- *.
generalize (codeTerm L codeF t0) (codeTerms L codeF n t1).
clear t0 t1.
intros.
unfold codeFreeVarTerms at 1 in |- *.
unfold codeFreeVarTermTerms in |- *.
unfold evalStrongRec in |- *.
set
 (g :=
  fun t0 recs : nat =>
  cPair
    (switchPR (cPairPi1 t0) (cPairPi2 (codeNth (t0 - S (cPairPi2 t0)) recs))
       (S (cPair (cPairPi2 t0) 0)))
    (switchPR t0
       (codeApp (cPairPi1 (codeNth (t0 - S (cPairPi1 (pred t0))) recs))
          (cPairPi2 (codeNth (t0 - S (cPairPi2 (pred t0))) recs))) 0))
 in *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
rewrite computeEvalStrongRecHelp.
unfold compose2 in |- *.
unfold evalComposeFunc in |- *.
unfold g at 1 in |- *.
rewrite
 (evalStrongRecHelp1 g (S (cPair n0 n1)) (cPairPi1 (pred (S (cPair n0 n1)))))
 .
rewrite
 (evalStrongRecHelp1 g (S (cPair n0 n1)) (cPairPi2 (pred (S (cPair n0 n1)))))
 .
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
simpl in |- *.
rewrite cPairProjections2.
apply le_lt_n_Sm.
apply cPairLe2.
simpl in |- *.
rewrite cPairProjections1.
apply le_lt_n_Sm.
apply cPairLe1.
Qed.

Lemma codeFreeVarTermsCorrect :
 forall (n : nat) (ts : Terms n),
 codeFreeVarTerms (codeTerms L codeF n ts) = codeList (freeVarTerms L n ts).
Proof.
intros.
induction ts as [| n t ts Hrects].
simpl in |- *.
unfold codeTerms in |- *.
unfold codeFreeVarTerms in |- *.
unfold codeFreeVarTermTerms in |- *.
unfold evalStrongRec in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
unfold freeVarTerms in |- *.
fold (freeVarTerm L t) in |- *.
fold (freeVarTerms L n ts) in |- *.
rewrite <- codeAppCorrect.
rewrite <- Hrects.
rewrite <- codeFreeVarTermCorrect.
clear Hrects.
unfold codeTerms in |- *.
fold (codeTerm L codeF t) in |- *.
fold (codeTerms L codeF n ts) in |- *.
generalize (codeTerm L codeF t) (codeTerms L codeF n ts).
clear t ts.
intros.
unfold codeFreeVarTerms at 1 in |- *.
unfold codeFreeVarTermTerms in |- *.
unfold evalStrongRec in |- *.
set
 (g :=
  fun t0 recs : nat =>
  cPair
    (switchPR (cPairPi1 t0) (cPairPi2 (codeNth (t0 - S (cPairPi2 t0)) recs))
       (S (cPair (cPairPi2 t0) 0)))
    (switchPR t0
       (codeApp (cPairPi1 (codeNth (t0 - S (cPairPi1 (pred t0))) recs))
          (cPairPi2 (codeNth (t0 - S (cPairPi2 (pred t0))) recs))) 0))
 in *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
rewrite computeEvalStrongRecHelp.
unfold compose2 in |- *.
unfold evalComposeFunc in |- *.
unfold g at 1 in |- *.
rewrite
 (evalStrongRecHelp1 g (S (cPair n0 n1)) (cPairPi1 (pred (S (cPair n0 n1)))))
 .
rewrite
 (evalStrongRecHelp1 g (S (cPair n0 n1)) (cPairPi2 (pred (S (cPair n0 n1)))))
 .
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
simpl in |- *.
rewrite cPairProjections2.
apply le_lt_n_Sm.
apply cPairLe2.
simpl in |- *.
rewrite cPairProjections1.
apply le_lt_n_Sm.
apply cPairLe1.
Qed.

Lemma codeFreeVarTermTermsIsPR : isPR 1 codeFreeVarTermTerms.
Proof.
intros.
unfold codeFreeVarTermTerms in |- *.
apply evalStrongRecIsPR.
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat =>
          switchPR (cPairPi1 t)
            (cPairPi2 (codeNth (t - S (cPairPi2 t)) recs))
            (S (cPair (cPairPi2 t) 0)))
    (g := fun t recs : nat =>
          switchPR t
            (codeApp (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
               (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs))) 0).
apply
 compose2_3IsPR
  with
    (f1 := fun t recs : nat => cPairPi1 t)
    (f2 := fun t recs : nat => cPairPi2 (codeNth (t - S (cPairPi2 t)) recs))
    (f3 := fun t recs : nat => S (cPair (cPairPi2 t) 0)).
apply filter10IsPR.
apply cPairPi1IsPR.
apply
 compose2_1IsPR
  with (f := fun t recs : nat => codeNth (t - S (cPairPi2 t)) recs).
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat => t - S (cPairPi2 t))
    (g := fun t recs : nat => recs).
apply filter10IsPR with (g := fun t : nat => t - S (cPairPi2 t)).
apply
 compose1_2IsPR
  with (f := fun t : nat => t) (f' := fun t : nat => S (cPairPi2 t)).
apply idIsPR.
apply compose1_1IsPR.
apply cPairPi2IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply cPairPi2IsPR.
apply filter10IsPR with (g := fun t : nat => S (cPair (cPairPi2 t) 0)).
apply compose1_1IsPR with (f := fun t : nat => cPair (cPairPi2 t) 0).
apply compose1_2IsPR with (f := cPairPi2) (f' := fun _ : nat => 0).
apply cPairPi2IsPR.
apply const1_NIsPR.
apply cPairIsPR.
apply succIsPR.
apply switchIsPR.
apply
 compose2_3IsPR
  with
    (f1 := fun t recs : nat => t)
    (f2 := fun t recs : nat =>
           codeApp (cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
             (cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs)))
    (f3 := fun t recs : nat => 0).
apply pi1_2IsPR.
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat =>
          cPairPi1 (codeNth (t - S (cPairPi1 (pred t))) recs))
    (g := fun t recs : nat =>
          cPairPi2 (codeNth (t - S (cPairPi2 (pred t))) recs)).
apply
 compose2_1IsPR
  with (f := fun t recs : nat => codeNth (t - S (cPairPi1 (pred t))) recs).
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat => t - S (cPairPi1 (pred t)))
    (g := fun t recs : nat => recs).
apply filter10IsPR with (g := fun t : nat => t - S (cPairPi1 (pred t))).
apply
 compose1_2IsPR
  with (f := fun t : nat => t) (f' := fun t : nat => S (cPairPi1 (pred t))).
apply idIsPR.
apply compose1_1IsPR with (f := fun t : nat => cPairPi1 (pred t)).
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi1IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply cPairPi1IsPR.
apply
 compose2_1IsPR
  with (f := fun t recs : nat => codeNth (t - S (cPairPi2 (pred t))) recs).
apply
 compose2_2IsPR
  with
    (f := fun t recs : nat => t - S (cPairPi2 (pred t)))
    (g := fun t recs : nat => recs).
apply filter10IsPR with (g := fun t : nat => t - S (cPairPi2 (pred t))).
apply
 compose1_2IsPR
  with (f := fun t : nat => t) (f' := fun t : nat => S (cPairPi2 (pred t))).
apply idIsPR.
apply compose1_1IsPR with (f := fun t : nat => cPairPi2 (pred t)).
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi2IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply cPairPi2IsPR.
apply codeAppIsPR.
exists (composeFunc 2 0 (PRnil _) zeroFunc).
simpl in |- *.
auto.
apply switchIsPR.
apply cPairIsPR.
Qed.

Lemma codeFreeVarTermIsPR : isPR 1 codeFreeVarTerm.
Proof.
unfold codeFreeVarTerm in |- *.
apply compose1_1IsPR.
apply codeFreeVarTermTermsIsPR.
apply cPairPi1IsPR.
Qed.

Lemma codeFreeVarTermsIsPR : isPR 1 codeFreeVarTerms.
Proof.
unfold codeFreeVarTerms in |- *.
apply compose1_1IsPR.
apply codeFreeVarTermTermsIsPR.
apply cPairPi2IsPR.
Qed.

Definition codeFreeVarFormula : nat -> nat :=
  evalStrongRec 0
    (fun f recs : nat =>
     switchPR (cPairPi1 f)
       (switchPR (pred (cPairPi1 f))
          (switchPR (pred (pred (cPairPi1 f)))
             (switchPR (pred (pred (pred (cPairPi1 f))))
                (codeFreeVarTerms (cPairPi2 f))
                (codeListRemove (cPairPi1 (cPairPi2 f))
                   (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
             (codeNth (f - S (cPairPi2 f)) recs))
          (codeApp (codeNth (f - S (cPairPi1 (cPairPi2 f))) recs)
             (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
       (codeApp (codeFreeVarTerm (cPairPi1 (cPairPi2 f)))
          (codeFreeVarTerm (cPairPi2 (cPairPi2 f))))).

Lemma codeFreeVarFormulaCorrect :
 forall f : Formula,
 codeFreeVarFormula (codeFormula L codeF codeR f) =
 codeList (freeVarFormula L f).
Proof.
intros.
set
 (g :=
  fun f recs : nat =>
  switchPR (cPairPi1 f)
    (switchPR (pred (cPairPi1 f))
       (switchPR (pred (pred (cPairPi1 f)))
          (switchPR (pred (pred (pred (cPairPi1 f))))
             (codeFreeVarTerms (cPairPi2 f))
             (codeListRemove (cPairPi1 (cPairPi2 f))
                (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
          (codeNth (f - S (cPairPi2 f)) recs))
       (codeApp (codeNth (f - S (cPairPi1 (cPairPi2 f))) recs)
          (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
    (codeApp (codeFreeVarTerm (cPairPi1 (cPairPi2 f)))
       (codeFreeVarTerm (cPairPi2 (cPairPi2 f)))))
 in *.
induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf].
simpl in |- *.
rewrite <- codeAppCorrect.
repeat rewrite <- codeFreeVarTermCorrect.
generalize (codeTerm L codeF t) (codeTerm L codeF t0).
clear t t0.
intros.
unfold codeFreeVarFormula in |- *.
unfold evalStrongRec in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
simpl in |- *.
reflexivity.
simpl in |- *.
rewrite <- codeFreeVarTermsCorrect.
generalize (codeTerms L codeF (arity L (inl (Functions L) r)) t).
clear t.
intros.
unfold codeFreeVarFormula in |- *.
unfold evalStrongRec in |- *.
unfold evalStrongRecHelp in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
unfold evalPrimRecFunc in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
simpl in |- *.
rewrite <- codeAppCorrect.
rewrite <- Hrecf1.
rewrite <- Hrecf0.
clear Hrecf0 Hrecf1.
unfold codeFreeVarFormula in |- *.
fold g in |- *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
rewrite computeEvalStrongRecHelp.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold g at 1 in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
rewrite
 (evalStrongRecHelp1 g
    (cPair 1
       (cPair (codeFormula L codeF codeR f1) (codeFormula L codeF codeR f0)))
    (codeFormula L codeF codeR f1)).
rewrite
 (evalStrongRecHelp1 g
    (cPair 1
       (cPair (codeFormula L codeF codeR f1) (codeFormula L codeF codeR f0)))
    (codeFormula L codeF codeR f0)).
simpl in |- *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
simpl in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
reflexivity.
eapply lt_le_trans.
apply cPairLt2.
apply cPairLe3.
apply le_n.
apply cPairLe2.
eapply lt_le_trans.
apply cPairLt2.
apply cPairLe3.
apply le_n.
apply cPairLe1.
simpl in |- *.
rewrite <- Hrecf.
clear Hrecf.
generalize (codeFormula L codeF codeR f).
clear f.
intros.
unfold codeFreeVarFormula at 1 in |- *.
fold g in |- *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
rewrite computeEvalStrongRecHelp.
unfold evalComposeFunc in |- *.
unfold compose2 in |- *.
unfold evalList in |- *.
unfold pred in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold g at 1 in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
rewrite (evalStrongRecHelp1 g (cPair 2 n) n).
simpl in |- *.
reflexivity.
apply cPairLt2.
simpl in |- *.
rewrite <- codeListRemoveCorrect.
rewrite <- Hrecf.
generalize (codeFormula L codeF codeR f).
clear Hrecf f.
intros.
unfold codeFreeVarFormula at 1 in |- *.
fold g in |- *.
unfold evalStrongRec in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
unfold evalList in |- *.
rewrite computeEvalStrongRecHelp.
unfold evalComposeFunc in |- *.
unfold compose2 in |- *.
unfold evalList in |- *.
unfold pred in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
unfold g at 1 in |- *.
repeat rewrite cPairProjections1 || rewrite cPairProjections2.
rewrite (evalStrongRecHelp1 g (cPair 3 (cPair n n0)) n0).
simpl in |- *.
reflexivity.
eapply lt_le_trans.
apply cPairLt2.
apply cPairLe3.
apply le_n.
apply cPairLe2.
Qed.

Lemma codeFreeVarFormulaIsPR : isPR 1 codeFreeVarFormula.
Proof.
unfold codeFreeVarFormula in |- *.
apply evalStrongRecIsPR.
assert (isPR 1 (fun x : nat => pred (cPairPi1 x))).
apply compose1_1IsPR.
apply cPairPi1IsPR.
apply predIsPR.
assert (isPR 1 (fun x : nat => pred (pred (cPairPi1 x)))).
apply compose1_1IsPR with (f := fun x : nat => pred (cPairPi1 x)).
auto.
apply predIsPR.
assert (isPR 1 (fun x : nat => pred (pred (pred (cPairPi1 x))))).
apply compose1_1IsPR with (f := fun x : nat => pred (pred (cPairPi1 x))).
auto.
apply predIsPR.
apply
 compose2_3IsPR
  with
    (f1 := fun f recs : nat => cPairPi1 f)
    (f2 := fun f recs : nat =>
           switchPR (pred (cPairPi1 f))
             (switchPR (pred (pred (cPairPi1 f)))
                (switchPR (pred (pred (pred (cPairPi1 f))))
                   (codeFreeVarTerms (cPairPi2 f))
                   (codeListRemove (cPairPi1 (cPairPi2 f))
                      (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
                (codeNth (f - S (cPairPi2 f)) recs))
             (codeApp (codeNth (f - S (cPairPi1 (cPairPi2 f))) recs)
                (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
    (f3 := fun f recs : nat =>
           codeApp (codeFreeVarTerm (cPairPi1 (cPairPi2 f)))
             (codeFreeVarTerm (cPairPi2 (cPairPi2 f)))).
apply filter10IsPR.
apply cPairPi1IsPR.
apply
 compose2_3IsPR
  with
    (f1 := fun f recs : nat => pred (cPairPi1 f))
    (f2 := fun f recs : nat =>
           switchPR (pred (pred (cPairPi1 f)))
             (switchPR (pred (pred (pred (cPairPi1 f))))
                (codeFreeVarTerms (cPairPi2 f))
                (codeListRemove (cPairPi1 (cPairPi2 f))
                   (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
             (codeNth (f - S (cPairPi2 f)) recs))
    (f3 := fun f recs : nat =>
           codeApp (codeNth (f - S (cPairPi1 (cPairPi2 f))) recs)
             (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)).
apply filter10IsPR with (g := fun x : nat => pred (cPairPi1 x)).
auto.
apply
 compose2_3IsPR
  with
    (f1 := fun f recs : nat => pred (pred (cPairPi1 f)))
    (f2 := fun f recs : nat =>
           switchPR (pred (pred (pred (cPairPi1 f))))
             (codeFreeVarTerms (cPairPi2 f))
             (codeListRemove (cPairPi1 (cPairPi2 f))
                (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)))
    (f3 := fun f recs : nat => codeNth (f - S (cPairPi2 f)) recs).
apply filter10IsPR with (g := fun x : nat => pred (pred (cPairPi1 x))).
auto.
apply
 compose2_3IsPR
  with
    (f1 := fun f recs : nat => pred (pred (pred (cPairPi1 f))))
    (f2 := fun f recs : nat => codeFreeVarTerms (cPairPi2 f))
    (f3 := fun f recs : nat =>
           codeListRemove (cPairPi1 (cPairPi2 f))
             (codeNth (f - S (cPairPi2 (cPairPi2 f))) recs)).
apply filter10IsPR with (g := fun x : nat => pred (pred (pred (cPairPi1 x)))).
auto.
apply filter10IsPR with (g := fun f : nat => codeFreeVarTerms (cPairPi2 f)).
apply compose1_1IsPR.
apply cPairPi2IsPR.
apply codeFreeVarTermsIsPR.
apply
 compose2_2IsPR
  with
    (f := fun f recs : nat => cPairPi1 (cPairPi2 f))
    (g := fun f recs : nat => codeNth (f - S (cPairPi2 (cPairPi2 f))) recs).
apply filter10IsPR with (g := fun f : nat => cPairPi1 (cPairPi2 f)).
apply compose1_1IsPR.
apply cPairPi2IsPR.
apply cPairPi1IsPR.
apply
 compose2_2IsPR
  with
    (f := fun f recs : nat => f - S (cPairPi2 (cPairPi2 f)))
    (g := fun f recs : nat => recs).
apply filter10IsPR with (g := fun f : nat => f - S (cPairPi2 (cPairPi2 f))).
apply
 compose1_2IsPR
  with
    (f := fun f : nat => f)
    (f' := fun f : nat => S (cPairPi2 (cPairPi2 f))).
apply idIsPR.
apply compose1_1IsPR with (f := fun f : nat => cPairPi2 (cPairPi2 f)).
apply compose1_1IsPR; apply cPairPi2IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply codeListRemoveIsPR.
apply switchIsPR.
apply
 compose2_2IsPR
  with
    (f := fun f recs : nat => f - S (cPairPi2 f))
    (g := fun f recs : nat => recs).
apply filter10IsPR with (g := fun f : nat => f - S (cPairPi2 f)).
apply
 compose1_2IsPR
  with (f := fun f : nat => f) (f' := fun f : nat => S (cPairPi2 f)).
apply idIsPR.
apply compose1_1IsPR.
apply cPairPi2IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply switchIsPR.
apply
 compose2_2IsPR
  with
    (f := fun f recs : nat => codeNth (f - S (cPairPi1 (cPairPi2 f))) recs)
    (g := fun f recs : nat => codeNth (f - S (cPairPi2 (cPairPi2 f))) recs).
apply
 compose2_2IsPR
  with
    (f := fun f recs : nat => f - S (cPairPi1 (cPairPi2 f)))
    (g := fun f recs : nat => recs).
apply filter10IsPR with (g := fun f : nat => f - S (cPairPi1 (cPairPi2 f))).
apply
 compose1_2IsPR
  with
    (f := fun f : nat => f)
    (f' := fun f : nat => S (cPairPi1 (cPairPi2 f))).
apply idIsPR.
apply compose1_1IsPR with (f := fun f : nat => cPairPi1 (cPairPi2 f)).
apply compose1_1IsPR.
apply cPairPi2IsPR.
apply cPairPi1IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply
 compose2_2IsPR
  with
    (f := fun f recs : nat => f - S (cPairPi2 (cPairPi2 f)))
    (g := fun f recs : nat => recs).
apply filter10IsPR with (g := fun f : nat => f - S (cPairPi2 (cPairPi2 f))).
apply
 compose1_2IsPR
  with
    (f := fun f : nat => f)
    (f' := fun f : nat => S (cPairPi2 (cPairPi2 f))).
apply idIsPR.
apply compose1_1IsPR with (f := fun f : nat => cPairPi2 (cPairPi2 f)).
apply compose1_1IsPR; apply cPairPi2IsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply codeAppIsPR.
apply switchIsPR.
apply
 filter10IsPR
  with
    (g := fun f : nat =>
          codeApp (codeFreeVarTerm (cPairPi1 (cPairPi2 f)))
            (codeFreeVarTerm (cPairPi2 (cPairPi2 f)))).
apply
 compose1_2IsPR
  with
    (f := fun f : nat => codeFreeVarTerm (cPairPi1 (cPairPi2 f)))
    (f' := fun f : nat => codeFreeVarTerm (cPairPi2 (cPairPi2 f))).
apply compose1_1IsPR with (f := fun f : nat => cPairPi1 (cPairPi2 f)).
apply compose1_1IsPR.
apply cPairPi2IsPR.
apply cPairPi1IsPR.
apply codeFreeVarTermIsPR.
apply compose1_1IsPR with (f := fun f : nat => cPairPi2 (cPairPi2 f)).
apply compose1_1IsPR; apply cPairPi2IsPR.
apply codeFreeVarTermIsPR.
apply codeAppIsPR.
apply switchIsPR.
Qed.

Definition codeFreeVarListFormula : nat -> nat :=
  evalStrongRec 0
    (fun l recs : nat =>
     switchPR l
       (codeApp (codeFreeVarFormula (cPairPi1 (pred l)))
          (codeNth (l - S (cPairPi2 (pred l))) recs)) 0).

Lemma codeFreeVarListFormulaCorrect :
 forall l : list Formula,
 codeFreeVarListFormula (codeList (map (codeFormula L codeF codeR) l)) =
 codeList (freeVarListFormula L l).
Proof.
intros.
unfold codeFreeVarListFormula in |- *.
set
 (A :=
  fun l0 recs : nat =>
  switchPR l0
    (codeApp (codeFreeVarFormula (cPairPi1 (pred l0)))
       (codeNth (l0 - S (cPairPi2 (pred l0))) recs)) 0)
 in *.
induction l as [| a l Hrecl];
 unfold evalStrongRec, evalComposeFunc, evalOneParamList, evalList in |- *;
 rewrite computeEvalStrongRecHelp;
 unfold compose2, evalComposeFunc, evalOneParamList, evalList in |- *.
simpl in |- *.
rewrite cPairProjections1.
reflexivity.
unfold A at 1 in |- *.
rewrite evalStrongRecHelp1.
simpl in |- *.
repeat first [ rewrite cPairProjections1 | rewrite cPairProjections2 ].
rewrite Hrecl.
rewrite codeFreeVarFormulaCorrect.
apply codeAppCorrect.
simpl in |- *.
apply le_lt_n_Sm.
apply cPairLe2A.
Qed.

Lemma codeFreeVarListFormulaIsPR : isPR 1 codeFreeVarListFormula.
Proof.
unfold codeFreeVarListFormula in |- *.
apply evalStrongRecIsPR.
apply
 compose2_3IsPR
  with
    (f1 := fun l recs : nat => l)
    (f2 := fun l recs : nat =>
           codeApp (codeFreeVarFormula (cPairPi1 (pred l)))
             (codeNth (l - S (cPairPi2 (pred l))) recs))
    (f3 := fun l recs : nat => 0).
apply pi1_2IsPR.
apply
 compose2_2IsPR
  with
    (f := fun l recs : nat => codeFreeVarFormula (cPairPi1 (pred l)))
    (g := fun l recs : nat => codeNth (l - S (cPairPi2 (pred l))) recs).
apply
 filter10IsPR
  with (g := fun l : nat => codeFreeVarFormula (cPairPi1 (pred l))).
apply compose1_1IsPR with (f := fun l : nat => cPairPi1 (pred l)).
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi1IsPR.
apply codeFreeVarFormulaIsPR.
apply callIsPR with (g := fun l : nat => cPairPi2 (pred l)).
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi2IsPR.
apply codeAppIsPR.
apply filter10IsPR with (g := fun _ : nat => 0).
apply const1_NIsPR.
apply switchIsPR.
Qed.

End Code_Free_Vars.