Initial import of SMTCoq v1.2

3 files changed, 1174 insertions, 0 deletions

diff --git a/src/spl/Arithmetic.v b/src/spl/Arithmetic.v
new file mode 100644
index 0000000..a3e3162
--- /dev/null
+++ b/src/spl/Arithmetic.v
@@ -0,0 +1,94 @@
+(**************************************************************************)
+(*                                                                        *)
+(*     SMTCoq                                                             *)
+(*     Copyright (C) 2011 - 2015                                          *)
+(*                                                                        *)
+(*     Michaël Armand                                                     *)
+(*     Benjamin Grégoire                                                  *)
+(*     Chantal Keller                                                     *)
+(*                                                                        *)
+(*     Inria - École Polytechnique - MSR-Inria Joint Lab                  *)
+(*                                                                        *)
+(*   This file is distributed under the terms of the CeCILL-C licence     *)
+(*                                                                        *)
+(**************************************************************************)
+
+(*** Spl -- a small checker for simplifications ***)
+
+(* Add LoadPath ".." as SMTCoq. *)
+(* Add LoadPath "../lia" as SMTCoq.lia. *)
+Require Import List PArray Bool Int63 ZMicromega.
+Require Import Misc State SMT_terms.
+Require Lia.
+
+Local Open Scope array_scope.
+Local Open Scope int63_scope.
+
+
+(* Arbritrary arithmetic simplifications *)
+
+Section Arith.
+
+  Variable t_form : PArray.array Form.form.
+  Variable t_atom : PArray.array Atom.atom.
+
+  Local Notation build_clause := (Lia.build_clause t_form t_atom).
+
+
+  Definition check_spl_arith orig res l :=
+    match orig with
+      | li::nil =>
+        let cl := (Lit.neg li)::res::nil in
+        match build_clause Lia.empty_vmap cl with
+          | Some (_, bf) =>
+            if ZTautoChecker bf l then res::nil
+            else C._true
+          | None => C._true
+        end
+      | _ => C._true
+    end.
+
+
+  Section Valid.
+
+    Variables (t_i : array typ_eqb)
+              (t_func : array (Atom.tval t_i))
+              (ch_atom : Atom.check_atom t_atom)
+              (ch_form : Form.check_form t_form)
+              (wt_t_atom : Atom.wt t_i t_func t_atom).
+
+    Local Notation interp_form_hatom :=
+      (Atom.interp_form_hatom t_i t_func t_atom).
+    Local Notation rho :=
+      (Form.interp_state_var interp_form_hatom t_form).
+
+
+    Let wf_rho : Valuation.wf rho.
+    Proof. destruct (Form.check_form_correct interp_form_hatom _ ch_form); auto. Qed.
+
+    Hint Immediate wf_rho.
+
+
+    Lemma valid_check_spl_arith :
+      forall orig, C.valid rho orig ->
+        forall res l, C.valid rho (check_spl_arith orig res l).
+    Proof.
+      unfold check_spl_arith; intros [ |li [ |t q]].
+      (* Case nil *)
+      intros; apply C.interp_true; auto.
+      (* List with one element *)
+      intros H res l; case_eq (build_clause Lia.empty_vmap (Lit.neg li :: res :: nil)); [ |intros; apply C.interp_true; auto].
+      intros (vm1, bf) Heq; destruct (Lia.build_clause_correct _ _ _ t_func ch_atom ch_form wt_t_atom _ _ _ _ Heq) as [H1 H0].
+      red; simpl; auto.
+      decompose [and] H0; case_eq (ZTautoChecker bf l); [intros Heq3|intros; apply C.interp_true; auto].
+      unfold C.valid; replace (C.interp rho (res :: nil)) with (C.interp rho (Lit.neg li :: res :: nil)).
+      rewrite H6; apply ZTautoChecker_sound with l;trivial.
+      simpl; replace (Lit.interp rho (Lit.neg li)) with false; auto.
+      rewrite Lit.interp_neg; unfold C.valid in H; simpl in H; rewrite orb_false_r in H; rewrite H; auto.
+      (* List with at least two elements *)
+      intros; apply C.interp_true; auto.
+    Qed.
+
+  End Valid.
+
+End Arith.
diff --git a/src/spl/Operators.v b/src/spl/Operators.v
new file mode 100644
index 0000000..90483db
--- /dev/null
+++ b/src/spl/Operators.v
@@ -0,0 +1,549 @@
+(**************************************************************************)
+(*                                                                        *)
+(*     SMTCoq                                                             *)
+(*     Copyright (C) 2011 - 2015                                          *)
+(*                                                                        *)
+(*     Michaël Armand                                                     *)
+(*     Benjamin Grégoire                                                  *)
+(*     Chantal Keller                                                     *)
+(*                                                                        *)
+(*     Inria - École Polytechnique - MSR-Inria Joint Lab                  *)
+(*                                                                        *)
+(*   This file is distributed under the terms of the CeCILL-C licence     *)
+(*                                                                        *)
+(**************************************************************************)
+
+(*** Spl -- a small checker for simplifications ***)
+
+(* Add LoadPath ".." as SMTCoq. *)
+(* Add LoadPath "../lia" as SMTCoq.lia. *)
+Require Import List PArray Bool Int63 ZMicromega.
+Require Import Misc State SMT_terms.
+Require Lia.
+
+Local Open Scope array_scope.
+Local Open Scope int63_scope.
+
+
+(* Simplification of SMTLIB-2 operators *)
+
+Section Operators.
+
+  Import Form.
+
+  Variable t_form : PArray.array Form.form.
+  Variable t_atom : PArray.array Atom.atom.
+
+  Local Notation get_form := (PArray.get t_form).
+  Local Notation get_atom := (PArray.get t_atom).
+
+
+  Fixpoint check_in x l :=
+    match l with
+      | nil => false
+      | t::q => if x == t then true else check_in x q
+    end.
+
+
+  Lemma check_in_spec : forall x l, check_in x l = true <-> In x l.
+  Proof.
+    intro x; induction l as [ |t q IHq]; simpl.
+    split; intro H; try discriminate; elim H.
+    case_eq (x == t).
+    rewrite eqb_spec; intro; subst t; split; auto.
+    intro H; rewrite IHq; split; auto; intros [H1|H1]; auto; rewrite H1, eqb_refl in H; discriminate.
+  Qed.
+
+
+  Fixpoint check_diseqs_complete_aux a dist t :=
+    match dist with
+      | nil => true
+      | b::q => if PArray.existsb (fun (x:option (int*int)) =>
+        match x with
+          | Some (a',b') => ((a == a') && (b == b')) || ((a == b') && (b == a'))
+          | None => false
+        end
+      ) t then check_diseqs_complete_aux a q t else false
+    end.
+
+
+  Lemma check_diseqs_complete_aux_spec : forall a dist t,
+    check_diseqs_complete_aux a dist t = true <->
+    forall y, In y dist -> exists i, i < length t /\
+      (t.[i] = Some (a,y) \/ t.[i] = Some (y,a)).
+  Proof.
+    intros a dist t; induction dist as [ |b q IHq]; simpl; split; auto.
+    intros _ y H; inversion H.
+    case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); try discriminate; rewrite PArray.existsb_spec; intros [i [H1 H2]]; rewrite IHq; clear IHq; intros H3 y [H4|H4]; auto; subst y; exists i; split; auto; generalize H2; case (t .[ i]); try discriminate; intros [a' b']; rewrite orb_true_iff, !andb_true_iff, !Int63Properties.eqb_spec; intros [[H4 H5]|[H4 H5]]; subst a' b'; auto.
+    intro H1; case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t).
+    intros _; rewrite IHq; clear IHq; intros y Hy; apply H1; auto.
+    rewrite array_existsb_false_spec; destruct (H1 b (or_introl (refl_equal b))) as [i [H2 H3]]; intro H; rewrite <- (H _ H2); destruct H3 as [H3|H3]; rewrite H3; rewrite !eqb_refl; auto; rewrite orb_true_r; auto.
+  Qed.
+
+
+  Lemma check_diseqs_complete_aux_false_spec : forall a dist t,
+    check_diseqs_complete_aux a dist t = false <->
+    exists y, In y dist /\ forall i, i < length t ->
+      (t.[i] <> Some (a,y) /\ t.[i] <> Some (y,a)).
+  Proof.
+    intros a dist t; induction dist as [ |b q IHq]; simpl; split; try discriminate.
+    intros [y [H _]]; elim H.
+    case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t).
+    intros _; rewrite IHq; clear IHq; intros [y [H3 H4]]; exists y; auto.
+    rewrite array_existsb_false_spec; intros H _; exists b; split; auto; intros i Hi; split; intro H1; generalize (H _ Hi); rewrite H1, !eqb_refl; try discriminate; rewrite orb_true_r; discriminate.
+    intros [y [H1 H2]]; case_eq (PArray.existsb (fun x : option (int * int) => match x with | Some (a', b') => (a == a') && (b == b') || (a == b') && (b == a') | None => false end) t); auto; rewrite PArray.existsb_spec; intros [i [H3 H4]]; rewrite IHq; clear IHq; exists y; destruct H1 as [H1|H1]; auto; subst y; case_eq (t.[i]); [intros [a' b'] Heq|intro Heq]; rewrite Heq in H4; try discriminate; rewrite orb_true_iff, !andb_true_iff, !eqb_spec in H4; destruct H4 as [[H4 H5]|[H4 H5]]; subst a' b'; generalize (H2 _ H3); rewrite Heq; intros [H4 H5]; [elim H4|elim H5]; auto.
+  Qed.
+
+
+  Fixpoint check_diseqs_complete dist t :=
+    match dist with
+      | nil => true
+      | a::q => if check_diseqs_complete_aux a q t then check_diseqs_complete q t else false
+    end.
+
+
+  Lemma check_diseqs_complete_spec : forall dist t,
+    check_diseqs_complete dist t = true <->
+    forall x y, In2 x y dist -> exists i, i < length t /\
+      (t.[i] = Some (x,y) \/ t.[i] = Some (y,x)).
+  Proof.
+    intros dist t; induction dist as [ |a q IHq]; simpl; split; auto.
+    intros _ x y H; inversion H.
+    case_eq (check_diseqs_complete_aux a q t); try discriminate; rewrite check_diseqs_complete_aux_spec, IHq; clear IHq; intros H1 H2 x y H3; inversion H3; auto.
+    intro H; case_eq (check_diseqs_complete_aux a q t).
+    rewrite IHq; clear IHq; intros _ x y H1; apply H; constructor 2; auto.
+    rewrite check_diseqs_complete_aux_false_spec; clear IHq; intros [y [H1 H2]]; destruct (H _ _ (In2_hd _ a _ _ H1)) as [i [H3 [H4|H4]]]; elim (H2 _ H3); rewrite H4; intros H5 H6; [elim H5|elim H6]; auto.
+  Qed.
+
+
+  Lemma check_diseqs_complete_false_spec : forall dist t,
+    check_diseqs_complete dist t = false <->
+    exists x y, In2 x y dist /\ forall i, i < length t ->
+      (t.[i] <> Some (x,y) /\ t.[i] <> Some (y,x)).
+  Proof.
+    intros dist t; induction dist as [ |a q IHq]; simpl; split; try discriminate.
+    intros [x [y [H _]]]; inversion H.
+    case_eq (check_diseqs_complete_aux a q t).
+    rewrite IHq; clear IHq; intros _ [x [y [H2 H3]]]; inversion H2; clear H2; subst q; exists x; exists y; split; auto; constructor 2.
+    constructor 1; auto.
+    constructor 2; auto.
+    rewrite check_diseqs_complete_aux_false_spec; intros [y [H1 H2]] _; clear IHq; exists a; exists y; split; auto; constructor; auto.
+    intros [x [y [H1 H2]]]; case_eq (check_diseqs_complete_aux a q t); auto; rewrite IHq; clear IHq; inversion H1; clear H1.
+    subst x q; rewrite check_diseqs_complete_aux_spec; intro H; destruct (H _ H0) as [i [H1 H3]]; elim (H2 _ H1); intros H4 H5; destruct H3; [elim H4|elim H5]; auto.
+    subst k q; intros _; exists x; exists y; split; auto.
+  Qed.
+
+
+  Definition check_diseqs ty dist diseq :=
+    let t := PArray.mapi (fun _ t =>
+      if Lit.is_pos t then None else
+        match get_form (Lit.blit t) with
+          | Fatom a =>
+            match get_atom a with
+              | Atom.Abop (Atom.BO_eq A) h1 h2 =>
+                if (Typ.eqb ty A) && (negb (h1 == h2)) && (check_in h1 dist) && (check_in h2 dist) then
+                  Some (h1,h2)
+                else
+                  None
+              | _ => None
+            end
+          | _ => None
+        end
+    ) diseq in
+    PArray.forallb (fun x => match x with | None => false | _ => true end) t &&
+    check_diseqs_complete dist t.
+
+
+  Lemma check_diseqs_spec : forall A dist diseq,
+    check_diseqs A dist diseq = true <->
+    ((forall i, i < length diseq ->
+      let t := diseq.[i] in
+        ~ Lit.is_pos t /\
+        exists a, get_form (Lit.blit t) = Fatom a /\
+          exists h1 h2, get_atom a = Atom.Abop (Atom.BO_eq A) h1 h2 /\
+            h1 <> h2 /\ (In2 h1 h2 dist \/ In2 h2 h1 dist))
+    /\
+    (forall x y, In2 x y dist -> exists i, i < length diseq /\
+      let t := diseq.[i] in
+        ~ Lit.is_pos t /\
+        exists a, get_form (Lit.blit t) = Fatom a /\
+          x <> y /\
+          (get_atom a = Atom.Abop (Atom.BO_eq A) x y \/
+            get_atom a = Atom.Abop (Atom.BO_eq A) y x))).
+  Proof.
+    intros A dist diseq; unfold check_diseqs; rewrite andb_true_iff, PArray.forallb_spec, check_diseqs_complete_spec, length_mapi; split; intros [H1 H2]; split.
+    clear H2; intros i Hi; generalize (H1 _ Hi); rewrite get_mapi; auto; case_eq (Lit.is_pos (diseq .[ i])); try discriminate; intro Heq1; case_eq (get_form (Lit.blit (diseq .[ i]))); try discriminate; intros a Heq2; case_eq (get_atom a); try discriminate; intros [ | | | | | | |B]; try discriminate; intros h1 h2 Heq3; case_eq (Typ.eqb A B); try discriminate; change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec; intro; subst B; case_eq (h1 == h2); try discriminate; rewrite eqb_false_spec; intro H2; case_eq (check_in h1 dist); try discriminate; case_eq (check_in h2 dist); try discriminate; rewrite !check_in_spec; intros H3 H4 _; split; try discriminate; exists a; split; auto; exists h1, h2; repeat split; auto; rewrite <- In2_In; auto.
+    clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 H4]]; clear H2; rewrite get_mapi in H4; auto; exists i; split; auto; generalize H4; case_eq (Lit.is_pos (diseq .[ i])); intro Heq; try (intros [H|H]; discriminate); case_eq (get_form (Lit.blit (diseq .[ i]))); [intros a| | |intros a1 a2|intros a1|intros a1|intros a1|intros a1 a2|intros a1 a2|intros a1 a2 a3]; intro Heq2; try (intros [H|H]; discriminate); case_eq (get_atom a); [intros a1|intros a1 a2|intros [ | | | | | | |B] h1 h2|intros a1 a2|intros a1 a2]; intro Heq3; try (intros [H|H]; discriminate); case_eq (Typ.eqb A B); try (intros _ [H|H]; discriminate); change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec; intro; subst B; case_eq (h1 == h2); try (intros _ [H|H]; discriminate); rewrite eqb_false_spec; intro H10; case (check_in h1 dist); try (intros [H|H]; discriminate); case (check_in h2 dist); try (intros [H|H]; discriminate); simpl; intro H3; split; try discriminate; exists a; split; auto; destruct H3 as [H3|H3]; inversion H3; subst; auto.
+    clear H2; intros i Hi; rewrite get_mapi; auto; destruct (H1 _ Hi) as [H2 [a [H3 [h1 [h2 [H4 [H5 H6]]]]]]]; clear H1; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H3, H4, Typ.eqb_refl; simpl; replace (h1 == h2) with false by (case_eq (h1 == h2); auto; rewrite eqb_spec; intro H; elim H5; auto); simpl; rewrite <- In2_In, <- !check_in_spec in H6; auto; destruct H6 as [H6 H7]; rewrite H6, H7; auto.
+    clear H1; intros x y Hxy; destruct (H2 _ _ Hxy) as [i [H1 [H3 [a [H4 [H6 H5]]]]]]; clear H2; exists i; split; auto; rewrite get_mapi; auto; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); rewrite H4; assert (H7 := or_introl (In2 y x dist) Hxy); rewrite <- In2_In, <- !check_in_spec in H7; auto; destruct H7 as [H7 H8]; destruct H5 as [H5|H5]; rewrite H5, Typ.eqb_refl; [replace (x == y) with false by (case_eq (x == y); auto; rewrite eqb_spec; auto)|replace (y == x) with false by (case_eq (y == x); auto; rewrite eqb_spec; auto)]; simpl; rewrite H7, H8; auto.
+  Qed.
+
+
+  (* Definition check_diseqs ty dist diseq := *)
+  (*   PArray.forallb (fun t => *)
+  (*     if Lit.is_pos t then false else *)
+  (*       match get_form (Lit.blit t) with *)
+  (*         | Fatom a => *)
+  (*           match get_atom a with *)
+  (*             | Atom.Abop (Atom.BO_eq A) h1 h2 => *)
+  (*               (Typ.eqb ty A) && (negb (h1 == h2)) && (check_in h1 dist) && (check_in h2 dist) *)
+  (*             | _ => false *)
+  (*           end *)
+  (*         | _ => false *)
+  (*       end) diseq. *)
+
+
+  (* Lemma check_diseqs_spec : forall A dist diseq, *)
+  (*   check_diseqs A dist diseq <-> forall i, i < length diseq -> *)
+  (*     let t := diseq.[i] in *)
+  (*     ~ Lit.is_pos t /\ *)
+  (*     exists a, get_form (Lit.blit t) = Fatom a /\ *)
+  (*       exists h1 h2, get_atom a = Atom.Abop (Atom.BO_eq A) h1 h2 /\ *)
+  (*         (h1 <> h2) /\ ((In2 h1 h2 dist) \/ (In2 h2 h1 dist)). *)
+  (* Proof. *)
+  (*   intros A dist diseq; unfold check_diseqs; unfold is_true at 1; rewrite PArray.forallb_spec; split. *)
+  (*   intros H i Hi; generalize (H _ Hi); clear H; case (Lit.is_pos (diseq .[ i])); try discriminate; case (get_form (Lit.blit (diseq .[ i]))); try discriminate; intros a H1; split; try discriminate; exists a; split; auto; generalize H1; clear H1; case (get_atom a); try discriminate; intros [ | | | | | | |B] h1 h2; try discriminate; rewrite !andb_true_iff; change (check_in h1 dist = true) with (is_true (check_in h1 dist)); change (check_in h2 dist = true) with (is_true (check_in h2 dist)); rewrite !check_in_spec; intros [[[H1 H4] H2] H3]; change (is_true (Typ.eqb A B)) in H1; rewrite Typ.eqb_spec in H1; subst B; exists h1; exists h2; split; auto; assert (H5: h1 <> h2) by (intro H; rewrite H, eqb_refl in H4; discriminate); split; auto; rewrite <- In2_In; auto. *)
+  (*   intros H i Hi; generalize (H _ Hi); clear H; case (Lit.is_pos (diseq .[ i])); try (intros [H _]; elim H; reflexivity); intros [_ [a [H1 [h1 [h2 [H2 [H3 H4]]]]]]]; rewrite H1, H2; rewrite !andb_true_iff; rewrite <- (In2_In H3) in H4; destruct H4 as [H4 H5]; change (check_in h1 dist = true) with (is_true (check_in h1 dist)); change (check_in h2 dist = true) with (is_true (check_in h2 dist)); rewrite !check_in_spec; repeat split; auto; case_eq (h1 == h2); auto; try (rewrite Typ.eqb_refl; auto); rewrite eqb_spec; intro; subst h1; elim H3; auto. *)
+  (* Qed. *)
+
+
+  Definition check_distinct ha diseq :=
+    match get_atom ha with
+      | Atom.Anop (Atom.NO_distinct ty) dist =>
+        check_diseqs ty dist diseq
+      | _ => false
+    end.
+
+
+  Lemma check_distinct_spec : forall ha diseq,
+    check_distinct ha diseq = true <-> exists A dist,
+      get_atom ha = Atom.Anop (Atom.NO_distinct A) dist /\
+      check_diseqs A dist diseq = true.
+  Proof.
+    intros ha diseq; unfold check_distinct; split.
+    case (get_atom ha); try discriminate; intros [A] l H; exists A; exists l; auto.
+    intros [A [dist [H1 H2]]]; rewrite H1; auto.
+  Qed.
+
+
+  Definition check_distinct_two_args f1 f2 :=
+    match get_form f1, get_form f2 with
+      | Fatom ha, Fatom hb =>
+        match get_atom ha, get_atom hb with
+          | Atom.Anop (Atom.NO_distinct ty) (x::y::nil), Atom.Abop (Atom.BO_eq ty') x' y' => (Typ.eqb ty ty') && (((x == x') && (y == y')) || ((x == y') && (y == x')))
+          | _, _ => false
+        end
+      | _, _ => false
+    end.
+
+
+  Lemma check_distinct_two_args_spec : forall f1 f2,
+    check_distinct_two_args f1 f2 = true <-> exists ha hb ty x y,
+      get_form f1 = Fatom ha /\
+      get_form f2 = Fatom hb /\
+      get_atom ha = Atom.Anop (Atom.NO_distinct ty) (x::y::nil) /\
+      (get_atom hb = Atom.Abop (Atom.BO_eq ty) x y \/
+       get_atom hb = Atom.Abop (Atom.BO_eq ty) y x).
+  Proof.
+    intros f1 f2; unfold check_distinct_two_args; split.
+    case (get_form f1); try discriminate; intro ha; case (get_form f2); try discriminate; intro hb; case_eq (get_atom ha); try discriminate; intros [A] [ |x [ |y [ |l]]] Heq1; try discriminate; case_eq (get_atom hb); try discriminate; intros [ | | | | | | |B] x' y' Heq2; try discriminate; rewrite !andb_true_iff, orb_true_iff, !andb_true_iff; change (Typ.eqb A B = true) with (is_true (Typ.eqb A B)); rewrite Typ.eqb_spec, !Int63Properties.eqb_spec; intros [H1 [[H2 H3]|[H2 H3]]]; subst B x' y'; exists ha, hb, A, x, y; auto.
+    intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; rewrite H1, H2, H3, H4, Typ.eqb_refl, !eqb_refl; auto; rewrite orb_true_r; auto.
+  Qed.
+
+
+  Section Valid1.
+
+    Variables (t_i : array typ_eqb)
+              (t_func : array (Atom.tval t_i))
+              (ch_atom : Atom.check_atom t_atom)
+              (ch_form : Form.check_form t_form)
+              (wt_t_atom : Atom.wt t_i t_func t_atom).
+
+    Local Notation interp_form_hatom :=
+      (Atom.interp_form_hatom t_i t_func t_atom).
+    Local Notation rho :=
+      (Form.interp_state_var interp_form_hatom t_form).
+
+    Let wf_t_atom : Atom.wf t_atom.
+    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.
+
+    Let default_t_atom : default t_atom = Atom.Acop Atom.CO_xH.
+    Proof. destruct (Atom.check_atom_correct _ ch_atom); auto. Qed.
+
+    Lemma default_t_form : default t_form = Ftrue.
+    Proof. destruct (Form.check_form_correct interp_form_hatom _ ch_form) as [[H _] _]; auto. Qed.
+
+    Lemma wf_t_form : wf t_form.
+    Proof. destruct (Form.check_form_correct interp_form_hatom _ ch_form) as [[_ H] _]; auto. Qed.
+
+    Local Hint Immediate wf_t_atom default_t_atom default_t_form wf_t_form.
+
+    Lemma interp_check_distinct : forall ha diseq,
+      check_distinct ha diseq = true ->
+      interp_form_hatom ha = afold_left bool int true andb (Lit.interp rho) diseq.
+    Proof.
+      intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H2]]]; rewrite check_diseqs_spec in H2; destruct H2 as [H2 H3]; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl.
+      intros l H4; case_eq (distinct (Typ.i_eqb t_i A) (rev l)).
+      rewrite distinct_spec; intro H5; symmetry; apply afold_left_andb_true; intros i Hi; destruct (H2 _ Hi) as [H9 [a [H10 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H10; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H11: a < length t_atom).
+      case_eq (a < length t_atom); auto; intro H11; rewrite (get_outofbound _ _ _ H11) in H6; rewrite default_t_atom in H6; inversion H6.
+      generalize (wt_t_atom _ H11); rewrite H6; simpl; rewrite !andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h1) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) h2) A)); rewrite !Typ.eqb_spec; intros [[_ H13] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H13; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H5; auto; rewrite H4; [exists h2; exists h1|exists h1; exists h2]; auto.
+      rewrite distinct_false_spec; intros [v2 [v1 [H5 H6]]]; rewrite H4 in H5; destruct H5 as [a [b [H5 [H7 H8]]]]; clear H4; change (Typ.i_eqb t_i A v2 v1 = true) with (is_true (Typ.i_eqb t_i A v2 v1)) in H6; rewrite Typ.i_eqb_spec in H6; subst v2; clear H2; destruct (H3 _ _ H5) as [i [H2 [H4 [hb [H6 [H9 H10]]]]]]; clear H3; symmetry; apply (afold_left_andb_false _ i); auto; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H6; simpl; rewrite Atom.t_interp_wf; auto; destruct H10 as [H10|H10]; rewrite H10; simpl; rewrite H7, H8; simpl; rewrite Typ.cast_refl; simpl; replace (Typ.i_eqb t_i A v1 v1) with true; auto; symmetry; change (is_true (Typ.i_eqb t_i A v1 v1)); rewrite Typ.i_eqb_spec; auto.
+      intros [a [H20 H21]]; assert (H4: ha < length t_atom).
+      case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate.
+      unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H20); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H21; simpl in H21; elim H21; apply Typ.eqb_spec; auto.
+    Qed.
+
+    Lemma interp_check_distinct_two_args : forall f1 f2,
+      check_distinct_two_args f1 f2 = true ->
+      rho f1 = negb (rho f2).
+    Proof.
+      intros f1 f2; rewrite check_distinct_two_args_spec; intros [ha [hb [A [x [y [H1 [H2 [H3 [H4|H4]]]]]]]]]; unfold Form.interp_state_var; assert (H5: f1 < length t_form) by (case_eq (f1 < length t_form); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); assert (H6: f2 < length t_form) by (case_eq (f2 < length t_form); auto; intro Heq; generalize H2; rewrite get_outofbound; auto; rewrite default_t_form; discriminate); rewrite !Form.t_interp_wf; auto; rewrite H1, H2; simpl; unfold Atom.interp_form_hatom, Atom.interp_hatom; rewrite !Atom.t_interp_wf; auto; rewrite H3, H4; simpl; unfold Atom.wt,is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H7: hb < length t_atom) by (case_eq (hb < length t_atom); auto; intro Heq; generalize H4; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate); generalize (wt_t_atom _ H7); rewrite H4; simpl; case (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) hb); try discriminate; simpl; rewrite andb_true_iff; change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) x) A)); change (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A = true) with (is_true (Typ.eqb (Atom.get_type' t_i (Atom.t_interp t_i t_func t_atom) y) A)); rewrite !Typ.eqb_spec; intros [H8 H9]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom x), (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom y); rewrite H8, H9; intros [v1 HH1] [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; auto; rewrite Typ.i_eqb_sym; auto.
+    Qed.
+
+
+    (* Lemma interp_check_distinct : forall ha diseq, *)
+    (*   check_distinct ha diseq -> *)
+    (*   interp_form_hatom ha -> afold_left bool int true andb (Lit.interp rho) diseq. *)
+    (* Proof. *)
+  (*     intros ha diseq; rewrite check_distinct_spec; intros [A [dist [H1 H]]]; rewrite check_diseqs_spec in H; unfold Atom.interp_form_hatom, Atom.interp_bool, Atom.interp_hatom; rewrite Atom.t_interp_wf; auto; rewrite H1; simpl; generalize (Atom.compute_interp_spec_rev t_i (get (Atom.t_interp t_i t_func t_atom)) A dist); case (Atom.compute_interp t_i (get (Atom.t_interp t_i t_func t_atom)) A nil); simpl. *)
+  (*     intros l H2; unfold is_true; rewrite distinct_spec; intro H3; apply afold_left_andb_true; intros i Hi; destruct (H _ Hi) as [H4 [a [H5 [h1 [h2 [H6 [H7 H8]]]]]]]; unfold Lit.interp; replace (Lit.is_pos (diseq .[ i])) with false by (case_eq (Lit.is_pos (diseq .[ i])); auto); unfold Var.interp; rewrite Form.wf_interp_form; auto; rewrite H5; simpl; rewrite Atom.t_interp_wf; auto; rewrite H6; simpl; unfold Atom.apply_binop; unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; assert (H10: a < length t_atom). *)
+  (*     case_eq (a < length t_atom); auto; intro H10; rewrite (get_outofbound _ _ _ H10) in H6; rewrite default_t_atom in H6; inversion H6. *)
+  (*     generalize (wt_t_atom _ H10); rewrite H6; simpl; rewrite !andb_true_iff. change (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h1) A)); change (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A = true) with (is_true (Typ.eqb (Atom.get_type t_i t_func t_atom h2) A)); rewrite !Typ.eqb_spec; intros [[_ H11] H12]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h1); rewrite H11; intros [v1 HH1]; generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom h2); rewrite H12; intros [v2 HH2]; rewrite HH1, HH2; simpl; rewrite Typ.cast_refl; simpl; destruct H8 as [H8|H8]; [ |rewrite Typ.i_eqb_sym]; rewrite H3; auto; rewrite H2; [exists h2; exists h1|exists h1; exists h2]; auto. *)
+  (*     intros [a [H2 H3]] _; assert (H4: ha < length t_atom). *)
+  (*     case_eq (ha < length t_atom); auto; intro Heq; generalize H1; rewrite get_outofbound; auto; rewrite default_t_atom; discriminate. *)
+  (*     unfold Atom.wt in wt_t_atom; unfold is_true in wt_t_atom; rewrite forallbi_spec in wt_t_atom; generalize (wt_t_atom _ H4); rewrite H1; simpl; rewrite andb_true_iff, forallb_forall; intros [_ H5]; assert (H6 := H5 _ H2); generalize (Atom.check_aux_interp_hatom _ t_func _ wf_t_atom a); intros [va Ha]; rewrite Ha in H3; simpl in H3; elim H3; apply Typ.eqb_spec; auto. *)
+  (*   Qed. *)
+
+  End Valid1.
+
+
+  Section AUX.
+
+    Variable check_var : var -> var -> bool.
+
+    Definition check_lit l1 l2 :=
+      (l1 == l2) || ((Bool.eqb (Lit.is_pos l1) (Lit.is_pos l2)) && (check_var (Lit.blit l1) (Lit.blit l2))) || ((Bool.eqb (Lit.is_pos l1) (negb (Lit.is_pos l2))) && (check_distinct_two_args (Lit.blit l1) (Lit.blit l2))).
+
+    (* Definition check_lit l1 l2 := *)
+    (*   (l1 == l2) || ((Lit.is_pos l1) && (Lit.is_pos l2) && (check_var (Lit.blit l1) (Lit.blit l2))) || ((negb (Lit.is_pos l1)) && (negb (Lit.is_pos l2)) && (check_var (Lit.blit l2) (Lit.blit l1))). *)
+
+    Definition check_form_aux a b :=
+      match a, b with
+        | Fatom ha, Fand diseq => check_distinct ha diseq
+        | Fatom a, Fatom b => a == b
+        | Ftrue, Ftrue => true
+        | Ffalse, Ffalse => true
+        | Fnot2 i1 l1, Fnot2 i2 l2 => (i1 == i2) && (check_lit l1 l2)
+        | Fand a1, Fand a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1)
+        | For a1, For a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1)
+        | Fimp a1, Fimp a2 => (length a1 == length a2) && (forallbi (fun i l => check_lit l (a2.[i])) a1)
+          (* (length a1 == length a2) && (forallbi (fun i l => if i < length a1 - 1 then check_lit (a2.[i]) l else check_lit l (a2.[i])) a1) *)
+        | Fxor l1 l2, Fxor j1 j2 => check_lit l1 j1 && check_lit l2 j2
+          (* check_lit l1 j1 && check_lit j1 l1 && check_lit l2 j2 && check_lit j2 l2 *)
+          (* (* let a := check_lit l1 j1 in *) *)
+          (* (* let b := check_lit l2 j2 in *) *)
+          (* (* let c := check_lit l1 j2 in *) *)
+          (* (* let d := check_lit l2 j1 in *) *)
+          (* (* let e := check_lit j1 l1 in *) *)
+          (* (* let f := check_lit j1 l2 in *) *)
+          (* (*   negb (((negb a) && b && (negb c)) || (c && e && (negb f)) || (b && (negb e) && f) || (a && (negb b) && (negb d))) *) *)
+        | Fiff l1 l2, Fiff j1 j2 => check_lit l1 j1 && check_lit l2 j2
+          (* check_lit l1 j1 && check_lit j1 l1 && check_lit l2 j2 && check_lit j2 l2 *)
+        | Fite l1 l2 l3, Fite j1 j2 j3 => check_lit l1 j1 && check_lit l2 j2 && check_lit l3 j3
+          (* check_lit l1 j1 && check_lit j1 l1 && check_lit l2 j2 && check_lit l3 j3 *)
+        | _, _ => false
+      end.
+
+    Variables (t_i : array typ_eqb)
+              (t_func : array (Atom.tval t_i))
+              (ch_atom : Atom.check_atom t_atom)
+              (ch_form : Form.check_form t_form)
+              (wt_t_atom : Atom.wt t_i t_func t_atom).
+
+    Local Notation interp_form_hatom :=
+      (Atom.interp_form_hatom t_i t_func t_atom).
+    Local Notation rho :=
+      (Form.interp_state_var interp_form_hatom t_form).
+
+    Hypothesis interp_check_var : forall x y,
+      check_var x y -> Var.interp rho x = Var.interp rho y.
+
+    (* Hypothesis interp_check_var : forall x y, *)
+    (*   check_var x y -> Var.interp rho x -> Var.interp rho y. *)
+
+    (* Local Hint Resolve interp_check_var. *)
+
+    Lemma interp_check_lit : forall l1 l2,
+      check_lit l1 l2 -> Lit.interp rho l1 = Lit.interp rho l2.
+    Proof.
+      unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[H1 H2]]|[H1 H2]].
+      rewrite eqb_spec in H1; rewrite H1; auto.
+      rewrite Bool.eqb_true_iff in H1; unfold Lit.interp; rewrite H1, (interp_check_var _ _ H2); auto.
+      generalize H1; unfold Lit.interp; case (Lit.is_pos l1); case (Lit.is_pos l2); try discriminate; intros _; unfold Var.interp; rewrite (interp_check_distinct_two_args _ t_func ch_atom ch_form wt_t_atom _ _ H2); auto; case (rho (Lit.blit l2)); auto.
+    Qed.
+
+    (* Lemma interp_check_lit : forall l1 l2, *)
+    (*   check_lit l1 l2 -> Lit.interp rho l1 -> Lit.interp rho l2 = true. *)
+    (* Proof. *)
+    (*   unfold check_lit; intros l1 l2; unfold is_true; rewrite !orb_true_iff, !andb_true_iff; intros [[H1|[[H1 H2] H3]]|[[H1 H2] H3]]. *)
+    (*   rewrite Int63Properties.eqb_spec in H1; subst l1; auto. *)
+    (*   unfold Lit.interp; rewrite H1, H2; apply interp_check_var; auto. *)
+    (*   unfold Lit.interp; case_eq (Lit.is_pos l1); intro Heq; rewrite Heq in H1; try discriminate; clear Heq H1; case_eq (Lit.is_pos l2); intro Heq; rewrite Heq in H2; try discriminate; clear Heq H2; case_eq (Var.interp rho (Lit.blit l1)); try discriminate; intros H4 _; case_eq (Var.interp rho (Lit.blit l2)); auto; intro H5; rewrite (interp_check_var _ _ H3 H5) in H4; discriminate. *)
+    (* Qed. *)
+
+    (* Local Hint Resolve interp_check_lit. *)
+
+    Lemma interp_check_form_aux : forall a b,
+      check_form_aux a b ->
+      Form.interp interp_form_hatom t_form a = Form.interp interp_form_hatom t_form b.
+    Proof.
+      intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3]; simpl; try discriminate;auto.
+      (* Atom *)
+      unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto.
+      (* Interesting case *)
+      apply interp_check_distinct; auto.
+      (* Double negation *)
+      unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1. rewrite (interp_check_lit _ _ H2). auto.
+      (* Conjunction *)
+      unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto.
+      (* Disjunction *)
+      unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_left_eq; auto; intros i Hi; apply interp_check_lit; auto.
+      (* Implication *)
+      unfold is_true; rewrite andb_true_iff, eqb_spec, forallbi_spec; intros [H1 H2]; apply afold_right_eq; auto; intros i Hi; apply interp_check_lit; auto.
+      (* Xor *)
+      unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto.
+      (* Iff *)
+      unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2); auto.
+      (* Ite *)
+      unfold is_true; rewrite !andb_true_iff; intros [[H1 H2] H3]; rewrite (interp_check_lit _ _ H1), (interp_check_lit _ _ H2), (interp_check_lit _ _ H3); auto.
+    Qed.
+
+    (* Lemma interp_check_lit_equiv : forall l1 l2, *)
+    (*   check_lit l1 l2 -> check_lit l2 l1 -> *)
+    (*   Lit.interp rho l1 = Lit.interp rho l2. *)
+    (* Proof. *)
+    (*   intros l1 l2 H1 H2; generalize (interp_check_lit _ _ H1) (interp_check_lit _ _ H2); case (Lit.interp rho l1); case (Lit.interp rho l2); auto; symmetry; auto. *)
+    (* Qed. *)
+
+    (* Lemma interp_check_form_aux : forall a b, *)
+    (*   check_form_aux a b -> *)
+    (*   Form.interp interp_form_hatom t_form a -> Form.interp interp_form_hatom t_form b. *)
+    (* Proof. *)
+    (*   intros [a| | |i1 l1|a1|a1|a1|l1 l2|l1 l2|l1 l2 l3] [b| | |j1 m1|a2|a2|a2|j1 j2|j1 j2|j1 j2 j3]; simpl; try discriminate;auto. *)
+    (*   (* Atom *) *)
+    (*   unfold is_true; rewrite Int63Properties.eqb_spec; intro; subst a; auto. *)
+    (*   (* Interesting case *) *)
+    (*   apply interp_check_distinct; auto. *)
+    (*   (* Double negation *) *)
+    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; subst j1; apply (fold_ind2 _ _ (fun x y => x = true -> y = true)). *)
+    (*   apply interp_check_lit; auto. *)
+    (*   intros a b; case a; try discriminate; intros H _; rewrite H; auto. *)
+    (*   (* Conjunction *) *)
+    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_andb_true_inv _ _ _ H3); clear H3; apply afold_left_andb_true; rewrite <- H1; intros i Hi; eapply interp_check_lit; eauto. *)
+    (*   (* Disjunction *) *)
+    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; assert (H4 := afold_left_orb_true_inv _ _ _ H3); clear H3; destruct H4 as [i [H3 H4]]; eapply afold_left_orb_true. *)
+    (*   rewrite <- H1; eauto. *)
+    (*   eapply interp_check_lit; eauto. *)
+    (*   (* Implication *) *)
+    (*   unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H1 H2]; rewrite forallbi_spec in H2; intro H3; apply afold_right_implb_true; case_eq (length a1 == 0); intro Heq. *)
+    (*   left; rewrite eqb_spec in Heq; rewrite <- H1; auto. *)
+    (*   destruct (afold_right_implb_true_inv _ _ _ H3) as [H4|[[i [H4 H5]]|H4]]. *)
+    (*   rewrite H4 in Heq; discriminate. *)
+    (*   right; left; exists i; rewrite <- H1; split; auto; case_eq (Lit.interp rho (a2 .[ i])); auto; intro H6; assert (H7: i < length a1 = true). *)
+    (*   rewrite ltb_spec in *; rewrite eqb_false_spec in Heq; rewrite to_Z_sub_1_diff in H4; auto; omega. *)
+    (*   generalize (H2 _ H7); rewrite H4; intro H8; rewrite (interp_check_lit _ _ H8 H6) in H5; auto. *)
+    (*   right; case_eq (existsbi (fun i l => (i < length a2 - 1) && (negb (Lit.interp rho l))) a2). *)
+    (*   rewrite existsbi_spec; intros [i [_ H5]]; rewrite andb_true_iff in H5; destruct H5 as [H5 H6]; left; exists i; split; auto; generalize H6; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *)
+    (*   rewrite existsbi_false_spec; intro H; right; intros i Hi; assert (Hi' := Hi); rewrite <- H1 in Hi'; generalize (H2 _ Hi') (H _ Hi); rewrite <- H1; case (i < length a1 - 1); simpl. *)
+    (*   intros _; case (Lit.interp rho (a2 .[ i])); auto; discriminate. *)
+    (*   intros H5 _; apply (interp_check_lit _ _ H5); apply H4; auto. *)
+    (*   (* Xor *) *)
+    (*   unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *)
+    (*   (* Iff *) *)
+    (*   unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2), (interp_check_lit_equiv _ _ H3 H4); auto. *)
+    (*   (* Ite *) *)
+    (*   unfold is_true; rewrite !andb_true_iff; intros [[[H1 H2] H3] H4]; rewrite (interp_check_lit_equiv _ _ H1 H2); case (Lit.interp rho j1); apply interp_check_lit; auto. *)
+    (* Qed. *)
+
+  End AUX.
+
+  Definition check_hform h1 h2 :=
+    foldi_down_cont
+    (fun _ cont h1 h2 => (h1 == h2) || check_form_aux cont (get_form h1) (get_form h2))
+    (PArray.length t_form) 0 (fun h1 h2 => false) h1 h2.
+
+  Definition check_form := check_form_aux check_hform.
+
+  Definition check_lit' := check_lit check_hform.
+
+  Fixpoint check_distinct_elim input res :=
+    match input with
+      | nil => nil
+      | l::q => if check_lit' l res then res::q else l::(check_distinct_elim q res)
+    end.
+
+
+  Section Valid.
+
+    Variables (t_i : array typ_eqb)
+              (t_func : array (Atom.tval t_i))
+              (ch_atom : Atom.check_atom t_atom)
+              (ch_form : Form.check_form t_form)
+              (wt_t_atom : Atom.wt t_i t_func t_atom).
+
+    Local Notation interp_form_hatom :=
+      (Atom.interp_form_hatom t_i t_func t_atom).
+    Local Notation rho :=
+      (Form.interp_state_var interp_form_hatom t_form).
+
+
+    Let wf_rho : Valuation.wf rho.
+    Proof. destruct (Form.check_form_correct interp_form_hatom _ ch_form); auto. Qed.
+
+    Let default_t_form : default t_form = Ftrue.
+    Proof. destruct (Form.check_form_correct interp_form_hatom _ ch_form) as [[H _] _]; auto. Qed.
+
+    Let wf_t_form : wf t_form.
+    Proof. destruct (Form.check_form_correct interp_form_hatom _ ch_form) as [[_ H] _]; auto. Qed.
+
+    Local Hint Immediate wf_rho default_t_form wf_t_form.
+
+
+    Lemma interp_check_hform : forall h1 h2,
+      check_hform h1 h2 -> Var.interp rho h1 = Var.interp rho h2.
+    Proof.
+      unfold check_hform; apply foldi_down_cont_ind; try discriminate. intros i cont _ _ Hrec h1 h2. unfold is_true; rewrite orb_true_iff; intros [H|H].
+      rewrite Int63Properties.eqb_spec in H; rewrite H; auto.
+      unfold Var.interp; rewrite !wf_interp_form; auto; eapply interp_check_form_aux; eauto.
+    Qed.
+
+    Local Hint Resolve interp_check_hform.
+
+
+    Lemma interp_check_form : forall a b,
+      check_form a b ->
+      Form.interp interp_form_hatom t_form a = Form.interp interp_form_hatom t_form b.
+    Proof. apply interp_check_form_aux, interp_check_hform; auto. Qed.
+
+
+    Lemma interp_check_lit' : forall l res,
+      check_lit' l res -> Lit.interp rho l = Lit.interp rho res.
+    Proof. apply interp_check_lit, interp_check_hform; auto. Qed.
+
+
+    Lemma valid_check_distinct_elim :
+      forall input, C.valid rho input ->
+        forall res, C.valid rho (check_distinct_elim input res).
+    Proof.
+      induction input as [ |l c IHc]; auto; simpl; unfold C.valid; simpl; rewrite orb_true_iff; intros [H|H] res.
+      case_eq (check_lit' l res); intro Heq; simpl.
+      rewrite <- (interp_check_lit' _ _ Heq), H; auto.
+      rewrite H; auto.
+      case (check_lit' l res).
+      simpl; rewrite H, orb_true_r; auto.
+      simpl; rewrite (IHc H), orb_true_r; auto.
+    Qed.
+
+  End Valid.
+
+End Operators.
diff --git a/src/spl/Syntactic.v b/src/spl/Syntactic.v
new file mode 100644
index 0000000..d7d2594
--- /dev/null
+++ b/src/spl/Syntactic.v
@@ -0,0 +1,531 @@
+(**************************************************************************)
+(*                                                                        *)
+(*     SMTCoq                                                             *)
+(*     Copyright (C) 2011 - 2015                                          *)
+(*                                                                        *)
+(*     Michaël Armand                                                     *)
+(*     Benjamin Grégoire                                                  *)
+(*     Chantal Keller                                                     *)
+(*                                                                        *)
+(*     Inria - École Polytechnique - MSR-Inria Joint Lab                  *)
+(*                                                                        *)
+(*   This file is distributed under the terms of the CeCILL-C licence     *)
+(*                                                                        *)
+(**************************************************************************)
+
+(*** Spl -- a small checker for simplifications ***)
+
+(* Add LoadPath ".." as SMTCoq. *)
+(* Add LoadPath "../lia" as SMTCoq.lia. *)
+Require Import List PArray Bool Int63 ZMicromega.
+Require Import Misc State SMT_terms.
+Require Lia.
+
+Local Open Scope array_scope.
+Local Open Scope int63_scope.
+
+
+(* Flattening and small arithmetic simplifications *)
+
+Section CheckAtom.
+
+  Import Atom.
+
+  Variable t_i : PArray.array typ_eqb.
+  Variable t_func : PArray.array (tval t_i).
+  Variable t_atom : PArray.array atom.
+
+  Local Notation get_atom := (PArray.get t_atom).
+
+  Section AUX.
+
+    Variable check_hatom : hatom -> hatom -> bool.
+
+    Definition check_atom_aux a b :=
+      match a, b with
+        | Acop o1, Acop o2 => cop_eqb o1 o2
+
+        (* Two ways to define a negative integer *)
+        | Auop UO_Zopp p1, Auop UO_Zneg q =>
+          match get_atom p1 with
+            | Auop UO_Zpos p => check_hatom p q
+            | _ => false
+          end
+        | Auop UO_Zneg p, Auop UO_Zopp q1 =>
+          match get_atom q1 with
+            | Auop UO_Zpos q => check_hatom p q
+            | _ => false
+          end
+
+        | Auop o1 a, Auop o2 b => uop_eqb o1 o2 && check_hatom a b
+        | Abop o1 a1 a2, Abop o2 b1 b2 =>
+          match o1, o2 with
+            | BO_Zplus, BO_Zplus
+            | BO_Zmult, BO_Zmult => (check_hatom a1 b1 && check_hatom a2 b2) || (check_hatom a1 b2 && check_hatom a2 b1)
+            | BO_Zminus, BO_Zminus
+            | BO_Zlt, BO_Zlt
+            | BO_Zle, BO_Zle
+            | BO_Zge, BO_Zge
+            | BO_Zgt, BO_Zgt  => check_hatom a1 b1 && check_hatom a2 b2
+            | BO_Zge, BO_Zle
+            | BO_Zle, BO_Zge
+            | BO_Zgt, BO_Zlt
+            | BO_Zlt, BO_Zgt => check_hatom a1 b2 && check_hatom a2 b1
+            | BO_eq t1, BO_eq t2 =>
+              Typ.eqb t1 t2 &&
+              ((check_hatom a1 b1 && check_hatom a2 b2) ||
+                (check_hatom a1 b2 && check_hatom a2 b1))
+            | _, _ => false
+          end
+        | Anop o1 l1, Anop o2 l2 =>
+          match o1, o2 with
+            | NO_distinct t1, NO_distinct t2 => Typ.eqb t1 t2 && list_beq check_hatom l1 l2
+          end
+        | Aapp f1 aargs, Aapp f2 bargs =>(f1 == f2) && list_beq check_hatom aargs bargs
+
+        | _, _ => false
+      end.
+
+
+    Hypothesis check_hatom_correct : forall h1 h2, check_hatom h1 h2 ->
+      interp_hatom t_i t_func t_atom h1 = interp_hatom t_i t_func t_atom h2.
+    Hypothesis Hwf: wf t_atom.
+    Hypothesis Hd: default t_atom = Acop CO_xH.
+
+
+    Lemma list_beq_correct : forall l1 l2,
+      list_beq check_hatom l1 l2 = true ->
+      List.map (interp_hatom t_i t_func t_atom) l1 =
+      List.map (interp_hatom t_i t_func t_atom) l2.
+    Proof.
+      induction l1 as [ |h1 l1 IHl1]; intros [ |h2 l2]; simpl; try discriminate; auto; rewrite andb_true_iff; intros [H1 H2]; rewrite (IHl1 _ H2); rewrite (check_hatom_correct _ _ H1); auto.
+    Qed.
+
+
+    Lemma list_beq_compute_interp : forall t l1 l2,
+      list_beq check_hatom l1 l2 = true -> forall acc,
+      compute_interp t_i (interp_hatom t_i t_func t_atom) t acc l1 =
+      compute_interp t_i (interp_hatom t_i t_func t_atom) t acc l2.
+    Proof.
+      intro t; induction l1 as [ |h1 l1 IHl1]; intros [ |h2 l2]; simpl; try discriminate; auto; rewrite andb_true_iff; intros [H1 H2] acc; rewrite (check_hatom_correct _ _ H1); destruct (interp_hatom t_i t_func t_atom h2) as [ta va]; destruct (Typ.cast ta t) as [ka| ]; auto.
+    Qed.
+
+
+    Lemma check_atom_aux_correct : forall a1 a2, check_atom_aux a1 a2 ->
+      interp t_i t_func t_atom a1 = interp t_i t_func t_atom a2.
+    Proof.
+      intros [op1|op1 i1|op1 i1 j1|op1 li1|f1 args1]; simpl.
+      (* Constants *)
+      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; pose (H:=reflect_cop_eqb op1 op2); inversion H; try discriminate; subst op1; auto.
+      (* Unary operators *)
+      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; try (case op1; discriminate).
+      case op1; case op2; try discriminate; try (unfold is_true; rewrite andb_true_iff; intros [_ H]; rewrite (check_hatom_correct _ _ H); auto).
+      case_eq (get_atom i2); try discriminate; intros [ | | | | ] i Heq H; try discriminate; simpl; unfold apply_unop; rewrite (check_hatom_correct _ _ H); unfold interp_hatom; rewrite (t_interp_wf _ _ _ Hwf Hd i2), Heq; simpl; unfold apply_unop; destruct (t_interp t_i t_func t_atom .[ i]) as [A v]; destruct (Typ.cast A Typ.Tpositive) as [k| ]; auto.
+      case_eq (get_atom i1); try discriminate; intros [ | | | | ] i Heq H; try discriminate; simpl; unfold apply_unop; rewrite <- (check_hatom_correct _ _ H); unfold interp_hatom; rewrite (t_interp_wf _ _ _ Hwf Hd i1), Heq; simpl; unfold apply_unop; destruct (t_interp t_i t_func t_atom .[ i]) as [A v]; destruct (Typ.cast A Typ.Tpositive) as [k| ]; auto.
+      (* Binary operators *)
+      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; case op1; case op2; try discriminate; try (unfold is_true; rewrite andb_true_iff; intros [H1 H2]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); auto).
+      unfold is_true, interp_bop, apply_binop. rewrite orb_true_iff, !andb_true_iff. intros [[H1 H2]|[H1 H2]]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.add_comm; reflexivity.
+      unfold is_true, interp_bop, apply_binop. rewrite orb_true_iff, !andb_true_iff. intros [[H1 H2]|[H1 H2]]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.mul_comm; reflexivity.
+      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.gtb_ltb; auto.
+      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.geb_leb; auto.
+      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.geb_leb; auto.
+      unfold interp_bop, apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v2]; destruct (interp_hatom t_i t_func t_atom i2) as [A v1]; destruct (Typ.cast B Typ.TZ) as [k2| ]; destruct (Typ.cast A Typ.TZ) as [k1| ]; auto; rewrite Z.gtb_ltb; auto.
+      intros A B; unfold is_true; rewrite andb_true_iff, orb_true_iff; change (Typ.eqb B A = true) with (is_true (Typ.eqb B A)); rewrite Typ.eqb_spec; intros [H2 [H1|H1]]; subst B; rewrite andb_true_iff in H1; destruct H1 as [H1 H2]; rewrite (check_hatom_correct _ _ H1), (check_hatom_correct _ _ H2); auto; simpl; unfold apply_binop; destruct (interp_hatom t_i t_func t_atom j2) as [B v1]; destruct (interp_hatom t_i t_func t_atom i2) as [C v2]; destruct (Typ.cast B A) as [k1| ]; destruct (Typ.cast C A) as [k2| ]; auto; rewrite Typ.i_eqb_sym; auto.
+      (* N-ary operators *)
+      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; destruct op1 as [t1]; destruct op2 as [t2]; unfold is_true; rewrite andb_true_iff; change (Typ.eqb t1 t2 = true) with (is_true (Typ.eqb t1 t2)); rewrite Typ.eqb_spec; intros [H1 H2]; subst t2; rewrite (list_beq_compute_interp _ _ _ H2); auto.
+      (* Application *)
+      intros [op2|op2 i2|op2 i2 j2|op2 li2|f2 args2]; simpl; try discriminate; unfold is_true; rewrite andb_true_iff, Int63Properties.eqb_spec; intros [H2 H1]; subst f2; rewrite (list_beq_correct _ _ H1); auto.
+    Qed.
+
+  End AUX.
+
+  Definition check_hatom h1 h2 :=
+    foldi_down_cont
+    (fun _ cont h1 h2 => (h1 == h2) || check_atom_aux cont (t_atom.[h1]) (t_atom.[h2]))
+    (PArray.length t_atom) 0 (fun h1 h2 => false) h1 h2.
+
+  Definition check_atom := check_atom_aux check_hatom.
+
+  Definition check_neg_hatom h1 h2 :=
+    match get_atom h1, get_atom h2 with
+      | Abop op1 a1 a2, Abop op2 b1 b2 =>
+        match op1, op2 with
+          | BO_Zlt, BO_Zle => check_hatom a1 b2 && check_hatom a2 b1
+          | BO_Zlt, BO_Zge => check_hatom a1 b1 && check_hatom a2 b2
+          | BO_Zle, BO_Zlt => check_hatom a1 b2 && check_hatom a2 b1
+          | BO_Zle, BO_Zgt => check_hatom a1 b1 && check_hatom a2 b2
+          | BO_Zge, BO_Zlt => check_hatom a1 b1 && check_hatom a2 b2
+          | BO_Zge, BO_Zgt => check_hatom a1 b2 && check_hatom a2 b1
+          | BO_Zgt, BO_Zle => check_hatom a1 b1 && check_hatom a2 b2
+          | BO_Zgt, BO_Zge => check_hatom a1 b2 && check_hatom a2 b1
+          | _, _ => false
+        end
+      | _, _ => false
+    end.
+
+  (* TODO : move this *)
+  Lemma Zge_is_ge_bool : forall x y, (x >= y) <-> (Zge_bool x y = true).
+  Proof.
+    intros x y;assert (W:=Zge_cases x y);destruct (Zge_bool x y).
+    split;auto.
+    split;[intros;elimtype false;auto with zarith | discriminate].
+  Qed.
+
+
+  (* Correctness of check_atom *)
+
+  Lemma check_hatom_correct : wf t_atom ->
+    default t_atom = Acop CO_xH ->
+    forall h1 h2, check_hatom h1 h2 ->
+      interp_hatom t_i t_func t_atom h1 = interp_hatom t_i t_func t_atom h2.
+  Proof.
+   unfold check_hatom;intros Hwf Hdef.
+   apply foldi_down_cont_ind;try discriminate.
+   intros i cont _ _ Hrec h1 h2.
+   unfold is_true; rewrite orb_true_iff; intros [H|H].
+   rewrite Int63Properties.eqb_spec in H; rewrite H; reflexivity.
+   unfold interp_hatom;rewrite !t_interp_wf;trivial.
+   apply check_atom_aux_correct with cont;trivial.
+  Qed.
+
+
+   Lemma check_atom_correct : wf t_atom ->
+    default t_atom = Acop CO_xH ->
+    forall a1 a2, check_atom a1 a2 ->
+        interp t_i t_func t_atom a1 = interp t_i t_func t_atom a2.
+  Proof.
+   intros Hwf Hdef;unfold check_atom;apply check_atom_aux_correct; auto.
+   apply check_hatom_correct;trivial.
+  Qed.
+
+
+  Lemma check_hatom_correct_bool : wf t_atom ->
+    default t_atom = Acop CO_xH ->
+    forall h1 h2, check_hatom h1 h2 ->
+      interp_form_hatom t_i t_func t_atom h1 = interp_form_hatom t_i t_func t_atom h2.
+  Proof.
+    unfold interp_form_hatom; intros H1 H2 h1 h2 H3; rewrite (check_hatom_correct H1 H2 h1 h2 H3); auto.
+  Qed.
+
+
+  (* Correctness of check_neg_atom *)
+
+  Lemma check_neg_hatom_correct : wt t_i t_func t_atom ->
+    wf t_atom -> default t_atom = Acop CO_xH ->
+    forall h1 h2, check_neg_hatom h1 h2 ->
+      match interp_hatom t_i t_func t_atom h1, interp_hatom t_i t_func t_atom h2 with
+        | Val Typ.Tbool v1, Val Typ.Tbool v2 => v1 = negb v2
+        | Val _ _, Val _ _ => False
+      end.
+  Proof.
+    unfold wt; unfold is_true at 1; rewrite forallbi_spec; intros Hwt Hwf Hdef h1 h2; unfold check_neg_hatom; case_eq (get_atom h1); try discriminate; intros b1 t11 t12 H1; case_eq (get_atom h2); try discriminate; intros b2 t21 t22 H2; assert (H7: h1 < length t_atom) by (apply PArray.get_not_default_lt; rewrite H1, Hdef; discriminate); generalize (Hwt _ H7); rewrite H1; simpl; generalize H1; case b1; try discriminate; clear H1 b1; simpl; intro H1; case (get_type' t_i (t_interp t_i t_func t_atom) h1); try discriminate; simpl; rewrite andb_true_iff; intros [H30 H31]; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t11) Typ.TZ)) in H30; change (is_true (Typ.eqb (get_type' t_i (t_interp t_i t_func t_atom) t12) Typ.TZ)) in H31; rewrite Typ.eqb_spec in H30, H31; generalize (check_aux_interp_hatom _ t_func _ Hwf t11), (check_aux_interp_hatom _ t_func _ Hwf t12); rewrite H30, H31; intros [v1 Hv1] [v2 Hv2]; generalize H2; case b2; try discriminate; clear H2 b2; intro H2; unfold is_true; rewrite andb_true_iff; intros [H3 H4]; generalize (check_hatom_correct Hwf Hdef _ _ H3), (check_hatom_correct Hwf Hdef _ _ H4); unfold interp_hatom; intros H5 H6; rewrite t_interp_wf; auto; rewrite H1; simpl; rewrite Hv1, Hv2; simpl; rewrite t_interp_wf; auto; rewrite H2; simpl; rewrite <- H5; rewrite <- H6, Hv1, Hv2; simpl.
+    rewrite Z.ltb_antisym; auto.
+    rewrite Z.geb_leb, Z.ltb_antisym; auto.
+    rewrite Z.leb_antisym; auto.
+    rewrite Z.gtb_ltb, Z.leb_antisym; auto.
+    rewrite Z.geb_leb, Z.leb_antisym; auto.
+    rewrite Z.geb_leb, Z.gtb_ltb, Z.leb_antisym; auto.
+    rewrite Z.gtb_ltb, Z.ltb_antisym; auto.
+    rewrite Z.geb_leb, Z.gtb_ltb, Z.ltb_antisym; auto.
+  Qed.
+
+
+  Lemma check_neg_hatom_correct_bool : wt t_i t_func t_atom ->
+    wf t_atom -> default t_atom = Acop CO_xH ->
+    forall h1 h2, check_neg_hatom h1 h2 ->
+      interp_form_hatom t_i t_func t_atom h1 = negb (interp_form_hatom t_i t_func t_atom h2).
+  Proof.
+    unfold interp_form_hatom. intros Hwt H1 H2 h1 h2 H3. unfold interp_bool. generalize (check_neg_hatom_correct Hwt H1 H2 _ _ H3). case (interp_hatom t_i t_func t_atom h1). case (interp_hatom t_i t_func t_atom h2). simpl. intros [i| | | ] v1 [j| | | ] v2; intro H; inversion H. rewrite Typ.cast_refl. auto.
+  Qed.
+
+End CheckAtom.
+
+
+(* Flattening *)
+
+Section FLATTEN.
+
+  Import Form.
+
+  Variable t_form : PArray.array form.
+
+  Local Notation get_form := (PArray.get t_form).
+
+  Definition remove_not l :=
+    match get_form (Lit.blit l) with
+      | Fnot2 _ l' => if Lit.is_pos l then l' else Lit.neg l'
+      | _ => l
+    end.
+
+  Definition get_and l :=
+    let l := remove_not l in
+      if Lit.is_pos l then
+        match get_form (Lit.blit l) with
+          | Fand args => Some args
+          | _ => None
+        end
+        else None.
+
+  Definition get_or l :=
+    let l := remove_not l in
+      if Lit.is_pos l then
+        match get_form (Lit.blit l) with
+          | For args => Some args
+          | _ => None
+        end
+        else None.
+
+  Definition flatten_op_body (get_op:_lit -> option (array _lit))
+    (frec : list _lit -> _lit -> list _lit)
+    (largs:list _lit) (l:_lit) : list _lit :=
+    match get_op l with
+      | Some a => PArray.fold_left frec largs a
+      | None => l::largs
+    end.
+  Register flatten_op_body as PrimInline.
+
+
+  Definition flatten_op_lit (get_op:_lit -> option (array _lit)) max :=
+    foldi_cont (fun _ => flatten_op_body get_op) 0 max (fun largs l => l::largs).
+
+  Definition flatten_and t :=
+    PArray.fold_left (flatten_op_lit get_and (PArray.length t_form)) nil t.
+
+  Definition flatten_or t :=
+    PArray.fold_left (flatten_op_lit get_or (PArray.length t_form)) nil t.
+
+
+  Variable check_atom check_neg_atom : atom -> atom -> bool.
+
+  Definition check_flatten_body frec (l lf:_lit) :=
+    let l := remove_not l in
+      let lf := remove_not lf in
+        if l == lf then true
+          else if 1 land (l lxor lf) == 0 then
+            match get_form (Lit.blit l), get_form (Lit.blit lf) with
+              | Fatom a1, Fatom a2 => check_atom a1 a2
+              | Ftrue, Ftrue => true
+              | Ffalse, Ffalse => true
+              | Fand args1, Fand args2 =>
+                let args1 := flatten_and args1 in
+                  let args2 := flatten_and args2 in
+                    forallb2 frec args1 args2
+              | For args1, For args2 =>
+                let args1 := flatten_or args1 in
+                  let args2 := flatten_or args2 in
+                    forallb2 frec args1 args2
+              | Fxor l1 l2, Fxor lf1 lf2 =>
+                frec l1 lf1 && frec l2 lf2
+              | Fimp args1, Fimp args2 =>
+                if PArray.length args1 == PArray.length args2 then
+                  PArray.forallbi (fun i l => frec l (args2.[i])) args1
+                  else false
+              | Fiff l1 l2, Fiff lf1 lf2 =>
+                frec l1 lf1 && frec l2 lf2
+              | Fite l1 l2 l3, Fite lf1 lf2 lf3 =>
+                frec l1 lf1 && frec l2 lf2 && frec l3 lf3
+              | _, _ => false
+            end
+            else
+              match get_form (Lit.blit l), get_form (Lit.blit lf) with
+                | Fatom a1, Fatom a2 => check_neg_atom a1 a2
+                | _, _ => false (* We maybe need to extend the rule here ... *)
+              end.
+  Register check_flatten_body as PrimInline.
+
+  Definition check_flatten_aux l lf :=
+    foldi_cont (fun _ => check_flatten_body) 0 (PArray.length t_form) (fun _ _ => false) l lf.
+
+  Definition check_flatten s cid lf :=
+    match S.get s cid with
+      | l :: nil =>
+        if check_flatten_aux l lf then lf::nil else C._true
+      | _ => C._true
+    end.
+
+
+  (** Correctness proofs *)
+  Variable interp_atom : atom -> bool.
+  Hypothesis default_thf : default t_form = Ftrue.
+  Hypothesis wf_thf : wf t_form.
+  Hypothesis check_atom_correct :
+    forall a1 a2, check_atom a1 a2 -> interp_atom a1 = interp_atom a2.
+  Hypothesis check_neg_atom_correct :
+    forall a1 a2, check_neg_atom a1 a2 -> interp_atom a1 = negb (interp_atom a2).
+
+  Local Notation interp_var := (interp_state_var interp_atom t_form).
+  Local Notation interp_lit := (Lit.interp interp_var).
+
+  Lemma interp_Fnot2 : forall i l, interp interp_atom t_form (Fnot2 i l) = interp_lit l.
+  Proof.
+    intros i l;simpl;apply fold_ind;trivial.
+    intros a;rewrite negb_involutive;trivial.
+  Qed.
+
+  Lemma remove_not_correct :
+    forall l, interp_lit (remove_not l) = interp_lit l.
+  Proof.
+    unfold remove_not;intros l.
+    case_eq (get_form (Lit.blit l));intros;trivial.
+    unfold Lit.interp, Var.interp.
+    rewrite (wf_interp_form interp_atom t_form default_thf wf_thf (Lit.blit l)), H, interp_Fnot2.
+    destruct(Lit.is_pos l);trivial.
+    rewrite Lit.is_pos_neg, Lit.blit_neg;unfold Lit.interp;destruct (Lit.is_pos i0);trivial.
+    rewrite negb_involutive;trivial.
+  Qed.
+
+  Lemma get_and_correct : forall l args, get_and l = Some args ->
+    interp_lit l = interp interp_atom t_form (Fand args).
+  Proof.
+    unfold get_and;intros l args.
+    rewrite <- remove_not_correct;unfold Lit.interp;generalize (remove_not l).
+    intros l';unfold Var.interp.
+    destruct (Lit.is_pos l');[ | discriminate].
+    rewrite wf_interp_form;trivial.
+    destruct (get_form (Lit.blit l'));intros Heq;inversion Heq;trivial.
+  Qed.
+
+  Lemma get_or_correct : forall l args, get_or l = Some args ->
+    interp_lit l = interp interp_atom t_form (For args).
+  Proof.
+    unfold get_or;intros l args.
+    rewrite <- remove_not_correct;unfold Lit.interp;generalize (remove_not l).
+    intros l';unfold Var.interp.
+    destruct (Lit.is_pos l');[ | discriminate].
+    rewrite wf_interp_form;trivial.
+    destruct (get_form (Lit.blit l'));intros Heq;inversion Heq;trivial.
+  Qed.
+
+  Lemma flatten_and_correct : forall args,
+    List.fold_right (fun l res => andb res (interp_lit l)) true (flatten_and args) =
+    afold_left _ _ true andb interp_lit args.
+  Proof.
+    intros;rewrite afold_left_spec;auto;unfold flatten_and.
+    set (t:= true);unfold t at 2;
+      change true with
+        (List.fold_right (fun (l : int) (res : bool) => res && interp_lit l) true nil).
+    unfold t;clear t.
+    rewrite !fold_left_to_list.
+    generalize (@nil int);induction (to_list args);simpl;trivial.
+    intros l0;rewrite IHl.
+    clear IHl;f_equal; unfold flatten_op_lit.
+    clear l;revert a l0;apply foldi_cont_ind;simpl;trivial.
+    intros i cont _ Hle Hrec a l;unfold flatten_op_body.
+    case_eq (get_and a);intros;trivial.
+    rewrite get_and_correct with (1:= H);simpl.
+    rewrite afold_left_spec; auto; rewrite !fold_left_to_list.
+    rewrite <- !fold_left_rev_right.
+    clear H a;revert l;induction (List.rev (to_list a0));simpl.
+    intros l;rewrite andb_true_r;trivial.
+    intros;rewrite Hrec, IHl, andb_assoc;trivial.
+  Qed.
+
+  Lemma flatten_or_correct : forall args,
+    List.fold_right (fun l res => orb res (interp_lit l)) false (flatten_or args) =
+    afold_left _ _ false orb interp_lit args.
+  Proof.
+    intros;rewrite afold_left_spec;auto;unfold flatten_or.
+    set (t:= false);unfold t at 2;
+      change false with
+        (List.fold_right (fun (l : int) (res : bool) => res || interp_lit l) false nil).
+    unfold t;clear t.
+    rewrite !fold_left_to_list.
+    generalize (@nil int);induction (to_list args);simpl;trivial.
+    intros l0;rewrite IHl.
+    clear IHl;f_equal; unfold flatten_op_lit.
+    clear l;revert a l0;apply foldi_cont_ind;simpl;trivial.
+    intros i cont _ Hle Hrec a l;unfold flatten_op_body.
+    case_eq (get_or a);intros;trivial.
+    rewrite get_or_correct with (1:= H);simpl.
+    rewrite afold_left_spec; auto; rewrite !fold_left_to_list.
+    rewrite <- !fold_left_rev_right.
+    clear H a;revert l;induction (List.rev (to_list a0));simpl.
+    intros l;rewrite orb_false_r;trivial.
+    intros;rewrite Hrec, IHl, orb_assoc;trivial.
+  Qed.
+
+  Lemma check_flatten_aux_correct : forall l lf,
+    check_flatten_aux l lf = true ->
+    interp_lit l = interp_lit lf.
+  Proof.
+    unfold check_flatten_aux.
+    apply foldi_cont_ind.
+    discriminate.
+    intros i cont _ Hle Hrec l lf;unfold check_flatten_body.
+    rewrite <- (remove_not_correct l), <- (remove_not_correct lf).
+    generalize (remove_not l) (remove_not lf);clear l lf;intros l lf.
+    destruct (reflect_eqb l lf);[ intros;subst;trivial | ].
+    destruct (reflect_eqb (1 land (l lxor lf)) 0).
+    unfold Lit.interp.
+    assert (Lit.is_pos l = Lit.is_pos lf).
+    unfold Lit.is_pos.
+    rewrite <- eqb_spec, land_comm in e.
+    change (is_true (is_even (l lxor lf))) in e.
+    rewrite is_even_xor in e.
+    destruct (is_even l);destruct (is_even lf);trivial;discriminate.
+    rewrite H;match goal with
+                |- ?P -> _ =>
+                assert (W:P -> Var.interp interp_var (Lit.blit l) = Var.interp interp_var (Lit.blit lf));
+                  [ | intros;rewrite W;trivial]
+              end.
+    unfold Var.interp;rewrite !wf_interp_form;trivial.
+    clear e n H.
+    destruct (get_form (Lit.blit l));
+      destruct (get_form (Lit.blit lf));intros;try discriminate;simpl;trivial.
+     (* atom *)
+    apply check_atom_correct;trivial.
+     (* and *)
+    rewrite <- !flatten_and_correct.
+    revert H;generalize (flatten_and a) (flatten_and a0);clear a a0.
+    induction l0;intros l1;destruct l1;simpl;trivial;try discriminate.
+    rewrite andb_true_iff;intros (H1, H2).
+    rewrite (Hrec _ _ H1), (IHl0 _ H2);trivial.
+     (* or *)
+    rewrite <- !flatten_or_correct.
+    revert H;generalize (flatten_or a) (flatten_or a0);clear a a0.
+    induction l0;intros l1;destruct l1;simpl;trivial;try discriminate.
+    rewrite andb_true_iff;intros (H1, H2).
+    rewrite (Hrec _ _ H1), (IHl0 _ H2);trivial.
+     (* implb *)
+    revert H;destruct (reflect_eqb (length a) (length a0));[intros|discriminate].
+    apply afold_right_eq;trivial.
+    rewrite forallbi_spec in H;auto.
+     (* xorb *)
+    unfold is_true in H;rewrite andb_true_iff in H;destruct H as [H H0].
+    rewrite (Hrec _ _ H), (Hrec _ _ H0);trivial.
+    (* eqb (i.e iff) *)
+    unfold is_true in H;rewrite andb_true_iff in H;destruct H as [H H0].
+    rewrite (Hrec _ _ H), (Hrec _ _ H0);trivial.
+     (* ifb *)
+    unfold is_true in H;rewrite !andb_true_iff in H;destruct H as [[H H0] H1].
+    rewrite (Hrec _ _ H), (Hrec _ _ H0), (Hrec _ _ H1);trivial.
+     (** opposite sign *)
+    assert (Lit.is_pos l = negb (Lit.is_pos lf)).
+    unfold Lit.is_pos.
+    rewrite <- eqb_spec, land_comm in n0.
+    change (~is_true (is_even (l lxor lf))) in n0.
+    rewrite is_even_xor in n0.
+    destruct (is_even l);destruct (is_even lf);trivial;elim n0;reflexivity.
+    unfold Lit.interp;rewrite H. match goal with
+                                  |- ?P -> _ =>
+                                  assert (W:P -> Var.interp interp_var (Lit.blit l) = negb (Var.interp interp_var (Lit.blit lf)));
+                                    [ | intros;rewrite W;trivial]
+                                end.
+    unfold Var.interp;rewrite !wf_interp_form;trivial.
+    destruct (get_form (Lit.blit l));try discriminate.
+    destruct (get_form (Lit.blit lf));try discriminate.
+    apply check_neg_atom_correct.
+    rewrite negb_involutive;destruct (Lit.is_pos lf);trivial.
+  Qed.
+
+  Hypothesis Hwf: Valuation.wf interp_var.
+
+  Lemma valid_check_flatten : forall s, S.valid interp_var s ->
+    forall cid lf, C.valid interp_var (check_flatten s cid lf).
+  Proof.
+    unfold check_flatten; intros s Hs cid lf; case_eq (S.get s cid).
+    intros; apply C.interp_true; auto.
+    intros i [ |l q] Heq; try apply C.interp_true; auto; case_eq (check_flatten_aux i lf); intro Heq2; try apply C.interp_true; auto; unfold C.valid; simpl; rewrite <- (check_flatten_aux_correct _ _ Heq2); unfold S.valid in Hs; generalize (Hs cid); rewrite Heq; auto.
+  Qed.
+
+End FLATTEN.