From Undecidability.L Require Import DecidableRecognisable InterpreterResults.
Open Scope list_scope.
Implicit Types s t : term.

(** * Enumerable classes *)

(** ** Definition of enumerable classes *)
Definition enumerable p := exists u, proc u /\ (forall n, u(enc n) ≡ none \/ exists s, u (enc n) ≡ oenc (Some s) /\ p s) /\ forall s, p s -> exists n, u (enc n) ≡ oenc (Some s).

(** ** Enumerable classes are recognisable *)

(** *** Equality of encoded terms *)

Definition Eq := rho (.\ "Eq", "s", "t"; "s" (.\"n";        "t" (.\"m"; !EqN "n" "m") !(lambda (lambda F)) !(lambda F))
                                           (.\"s1", "s2"; "t" !(lambda F) (.\"t1","t2"; ("Eq" "s1" "t1") ("Eq" "s2" "t2") !F) !(lambda F))
                                           (.\"s1";       "t" !(lambda F) !(lambda (lambda F)) (.\"t1"; "Eq" "s1" "t1")) ).
Hint Unfold Eq : cbv.

Definition term_eq_bool s t := if decision (s = t) then true else false.

Lemma Eq_correct' s t :
  Eq (tenc s) (tenc t) ≡ benc (term_eq_bool s t).
Proof with try solveeq.
  revert t; induction s; intros.
  + destruct t; [ | solveeq..].
    transitivity (EqN (enc n) (enc n0)). solveeq. rewrite EqN_correct.
    unfold term_eq_bool. destruct _. inv e.
    now rewrite <- beq_nat_refl. assert (n <> n0) by firstorder congruence.
    rewrite <- Nat.eqb_neq in H. now rewrite H.
  + destruct t; [ solveeq | | solveeq].
    transitivity ((Eq (tenc s1) (tenc t1)) (Eq (tenc s2) (tenc t2)) F). solveeq.
    rewrite IHs1, IHs2.
    unfold term_eq_bool. destruct *; try congruence; solveeq.
  + destruct t; [ solveeq.. | ].
    transitivity (Eq (tenc s) (tenc t)). solveeq.
    rewrite IHs.
    unfold term_eq_bool. destruct *; try congruence; solveeq.
Qed.

Lemma Eq_correct s t :
      (s  = t -> Eq (tenc s) (tenc t) ≡ T )
  /\ ( s <> t -> Eq (tenc s) (tenc t) ≡ F ).
Proof.
  intuition; rewrite Eq_correct';
  unfold term_eq_bool; destruct _; now try congruence.
Qed.

(** *** Search using Choose *)

Section Fix_f.

  Variable u : term.
  Hypothesis proc_u : proc u.
  Hypothesis total_u : forall n, u (enc n) ≡ none \/ exists s, u (enc n) ≡ oenc (Some s).

  Definition Re : term := Eval cbv in
        .\ "s"; !C (.\ "n"; !u "n" (.\ "t"; !Eq "s" "t") !F).

  Lemma Re_proc :
    proc Re.
  Proof.
    value.
  Qed.

  Lemma H_rec n s : ((lambda (((u 0) (lambda ((Eq (tenc s)) 0))) F)) (enc n) ≡ u (enc n) (lambda (Eq (tenc s) 0)) F).
  Proof.
    solveeq.
  Qed.

  Lemma H_proc s : proc (.\ "n"; !u "n" (.\ "t"; !Eq !(tenc s) "t") !F).
  Proof.
    value.
  Qed.

  Lemma H_test s : test (.\ "n"; !u "n" (.\ "t"; !Eq !(tenc s) "t") !F).
  Proof.
    intros n. cbn. rewrite H_rec.
    destruct (total_u n) as [ | [] ].
    + rewrite H. right. solveeq.
    + rewrite H, some_correct_r; value.
      assert (lambda (Eq (tenc s) 0) (tenc x) ≡ Eq (tenc s) (tenc x)) by solveeq.
      rewrite H0. decide (s = x).
      * eapply Eq_correct in e. rewrite e. left. econstructor.
      * eapply Eq_correct in n0. rewrite n0. right. econstructor.
  Qed.

  Lemma Re_sound s : eva (Re (tenc s)) -> exists n, u (enc n) ≡ oenc (Some s).
  Proof.
    intros.
    assert (Re (tenc s) ≡ C (lambda (u 0 (lambda (Eq (tenc s) 0)) F))) by solveeq.
    rewrite H0 in H. eapply C_sound in H as [n H]; value.
    - exists n. unfold satis in H. destruct (total_u n) as [ | []].
      + cbn. rewrite H_rec, H1, none_correct in H; value. inv H.
      + rewrite H_rec, H1, some_correct_r in H; value.
        assert (lambda (Eq (tenc s) 0) (tenc x) ≡ Eq (tenc s) (tenc x)) by (clear; solveeq).
        rewrite H2 in H.
        decide (s = x).
        * now subst.
        * eapply Eq_correct in n0. rewrite n0 in H. inv H.
    - intros n. rewrite H_rec. destruct (total_u n) as [ | [] ].
      + rewrite H1. right. solveeq.
      + rewrite H1, some_correct_r; value.
        assert (lambda (Eq (tenc s) 0) (tenc x) ≡ Eq (tenc s) (tenc x)) by solveeq.
        rewrite H2. decide (s = x).
        * eapply Eq_correct in e. rewrite e. left. econstructor.
        * eapply Eq_correct in n0. rewrite n0. right. econstructor.
  Qed.

  Lemma Re_complete n s : u (enc n) ≡ oenc (Some s) -> eva (Re (tenc s)).
  Proof.
    intros. assert (Re (tenc s) ≡ C (lambda (u 0 (lambda (Eq (tenc s) 0)) F))) by solveeq.
    rewrite H0. edestruct (C_complete (n := n) (H_proc s) (H_test s)).
    - unfold satis. cbn. rewrite H_rec, H. eapply evaluates_equiv; split; value.
      transitivity (Eq (tenc s) (tenc s)). solveeq.
      edestruct (Eq_correct). now rewrite H1.
    - destruct H1; eauto.
  Qed.

End Fix_f.

Lemma enumerable_recognisable p : enumerable p -> recognisable p.
Proof.
  intros [v [f_cls [f_total f_enum]]].
  pose (u := (lambda (Re v 0))).
  assert (Hu : forall s, u (tenc s) ≡ Re v (tenc s)) by (intros; solveeq).
  exists u.
  split. value. intuition.
  - rewrite Hu. eapply f_enum in H as []. eapply Re_complete.
    + value.
    + firstorder.
    + eauto.
  - rewrite Hu in H. eapply Re_sound in H as [n H].
    destruct (f_total n).
    + rewrite H in H0. replace none with (oenc None) in H0. eapply oenc_inj in H0. inv H0.
      reflexivity.
    + destruct H0 as [? [? ?]]. rewrite H0 in H. eapply oenc_inj in H. inv H. eassumption.
    + value.
    + firstorder.
Qed.

(** ** The class of all terms is enumerable *)

Lemma R_enumerates (R : nat -> option term) (u : term) :
  proc u -> (forall s, exists n, R n = Some s) -> (forall n, u (enc n) ▷ oenc (R n)) ->
  enumerable (fun s => True).
Proof.
  intros Hp HR Hu. exists u. repeat split; eauto; value.
  - intros . destruct (R n) eqn:E.
    + right. exists t. rewrite Hu, E. eauto.
    + left. rewrite Hu, E. reflexivity.
  - intros. destruct (HR s) as [n H0].
    exists n. rewrite (Hu n), H0. eauto.
Qed.

Fixpoint L n :=
  match n with
  | 0 => [ ]
  | S n => L n ++ var n :: map_pro L.app (L n) (L n) ++ map lambda (L n)
  end.

Lemma length_L n : |L n| >= n.
Proof.
  induction n; cbn.
  - omega.
  - rewrite app_length. cbn. omega.
Qed.

Lemma L_exists n : exists s, nth n (L (S n)) = Some s.
Proof.
  edestruct nth_length with (A := L (S n)) (n := n).
  + eapply length_L.
  + eauto.
Qed.

Lemma L_cum m n : m <= n -> exists A, L n = L m ++ A.
Proof.
  induction 1.
  - exists []. now simpl_list.
  - cbn. destruct IHle as [A ->].
    rewrite <- app_assoc. eauto.
Qed.

Lemma nth_app_l X (x : X) n A B :
  nth n A = Some x -> nth n (A ++ B) = Some x.
Proof.
  revert n.
  induction A as [|y A IH]; cbn; intros k H.
  - destruct k; discriminate H.
  - destruct k as [|k]; cbn in *. exact H.
    apply IH, H.
Qed.

Lemma L_inv m n k s t :
  nth k (L m) = Some s -> nth k (L n) = Some t -> s = t.
Proof.
  intros H1 H2.
  assert (m <= n \/ n <= m) as [H3|H3] by omega.
  - destruct (L_cum H3) as [A ?]. rewrite H in *.
    eapply nth_app_l in H1. rewrite H1 in H2. now inv H2.
  - destruct (L_cum H3) as [A ?]. rewrite H in *.
    eapply nth_app_l in H2. rewrite H2 in H1. now inv H1.
Qed.

Definition R n := nth n (L (S n)).

Fixpoint beta s :=
  match s with
  | var n => S n
  | app s t => S (beta s + beta t)
  | lambda s => S (beta s)
  end.

Lemma L_el s m n : s el L m -> m <= n -> s el L n.
Proof.
  intros. induction H0.
  - eauto.
  - cbn. eauto.
Qed.

Lemma L_beta s : s el L (beta s).
Proof.
  induction s; cbn.
  - eauto.
  - rewrite !in_app_iff. cbn. rewrite in_app_iff.
    do 2 right. left. eapply map_pro_in. repeat eexists; eauto.
    + eapply L_el; eauto. omega.
    + eapply L_el; eauto. omega.
  - rewrite !in_app_iff. cbn. rewrite in_app_iff.
    do 3 right. eapply in_map_iff. eauto.
Qed.

Lemma R_surjective s : exists n, R n = Some s.
Proof.
  destruct (el_pos _ (L_beta s)) as [n ? % pos_nth].
  unfold R. exists n. destruct (L_exists n) as [? ?].
  rewrite H0. f_equal. eapply L_inv; eauto.
Qed.

(** ** Procedural realisation of enumeration *)

(** ** Some list procedures *)

Section Fix_X.

  Variable X : Type.
  Variable enc : X -> term.
  Hypothesis enc_proc : (forall x, proc (enc x)).

  Fixpoint lenc (A : list X) :=
    match A with
    | nil => lambda (lambda 1)
    | a::A => lambda(lambda (0 (enc a) (lenc A)))
    end.

  Definition Nil : term := .\ "n", "c"; "n".
  Definition Cons: term := .\ "a", "A", "n", "c"; "c" "a" "A".

  Lemma lenc_proc A : proc (lenc A).
  Proof.
    induction A; value.
  Qed.

  Hint Resolve lenc_proc : cbv.

  Lemma Cons_correct a A : Cons (enc a) (lenc A) ≡ lenc(a::A).
  Proof.
    solveeq.
  Qed.

  Definition Append := rho (.\ "app", "A", "B";
                            "A" "B" (.\"a", "A"; !Cons "a" ("app" "A" "B"))).

  Hint Unfold Append : cbv.

  Lemma Append_correct A B : Append (lenc A) (lenc B) ≡ lenc(A ++ B).
  Proof.
    induction A; solveeq.
  Qed.

  Definition sim (F : term) f := proc F /\ forall x, F (enc x) ≡ (enc (f x)).

  Definition Map := rho (.\ "map", "F", "A";
                         "A" !Nil (.\"a", "A"; !Cons ("F" "a") ("map" "F" "A"))).

  Hint Unfold sim Map : cbv.

  Lemma Map_correct f A F : sim F f ->
                            Map F (lenc A) ≡ lenc(map f A).
  Proof.
    intros [[? ?] ?].
    induction A.
    - solveeq.
    - specialize (H1 a). solveeq.
  Qed.

  Definition sim2 (F : term) f := proc F /\ forall x y, F (enc x) (enc y) ≡ (enc (f x y)).

  Definition Map_pro := rho (.\ "map_pro", "f", "A", "B";
                               "A" !Nil (.\"a", "A"; !Append ("map_pro" "f" "A" "B") (!Map (.\"y" ; "f" "a" "y") "B"))).

  Goal proc Map_pro.
  Proof.
    value.
  Qed.

  Hint Unfold sim2 Map_pro : cbv.

  Lemma Map_pro_correct f A B F : sim2 F f ->
                            Map_pro F (lenc A) (lenc B) ≡ lenc(map_pro f A B).
  Proof.
    intros [[? ?] ?].
    induction A.
    - solveeq.
    - transitivity (Append (Map_pro F (lenc A) (lenc B)) (Map (lambda (F (enc a) 0)) (lenc B))). solvered.
      rewrite IHA, Map_correct with (f := f a), Append_correct. reflexivity.
      split; value. intros. specialize (H1 a x). solveeq.
  Qed.

  Definition Nth := rho (.\ "nth", "n", "A";
                         "n" ("A" !none (.\ "a", "A"; !some "a"))
                             (.\"n"; ("A" !none (.\"a", "A"; "nth" "n" "A"))) ).

  Definition onatenc x := match x with None => none | Some x => (lambda(lambda(1 (enc x)))) end.

  Lemma Nth_correct A n : Nth (Encodings.enc n) (lenc A) ≡ onatenc(nth n A).
  Proof.
    revert A; induction n; intros A.
    - destruct A; solveeq.
    - destruct A.
      + solveeq.
      + cbn. rewrite <- IHn. solveeq.
  Qed.

End Fix_X.

Definition L_term := rho (.\ "L", "n";
                            "n" !Nil (.\ "n"; !Append ("L" "n") (!Cons (!Var "n") (!Append (!Map_pro !App ("L" "n") ("L" "n")) (!Map !Lam ("L" "n")))))).

Lemma L_term_correct n : L_term (enc n) ≡ lenc tenc (L n).
Proof.
  induction n.
  - solvered.
  - transitivity (Append (L_term (enc n)) (Cons (Var (enc n)) (Append (Map_pro App (L_term (enc n)) (L_term (enc n))) (Map Lam (L_term (enc n)))))). solvered.
    rewrite IHn, Map_correct with (f := lambda), Map_pro_correct with (f := app), Append_correct, Var_correct, Cons_correct, Append_correct;
      intros; value.
    + reflexivity.
    + split. value. exact App_correct.
    + split. value. exact Lam_correct.
Qed.

Definition OfNat : term := .\ "n" ; !Nth "n" (!L_term (!Succ ("n"))).

Lemma OfNat_correct n : OfNat (enc n) ≡ oenc (R n).
Proof.
  transitivity (Nth (enc n) (L_term (Succ (enc n)))). solveeq.
  rewrite Succ_correct, L_term_correct, Nth_correct. reflexivity.
  intros; value.
Qed.

Lemma enumerable_all : enumerable (fun s => True).
Proof.
  eapply R_enumerates with (u := OfNat).
  - value.
  - eapply R_surjective.
  - intros. rewrite OfNat_correct. eapply evaluates_equiv; split; now value.
Qed.

(** ** Recognisable classes are enumerable *)

Theorem recognisable_enumerable p : recognisable p -> enumerable p.
Proof.
  destruct enumerable_all as (Enum & pE & TE & HE).
  intros [u [proc_u Hu]].

  pose (v := (.\ "n"; !Enum "n" (.\ "u"; "u" !(lambda none) (.\ "t", "s"; "t" (.\ "n"; !E "n" (!App !(tenc u) (!Q "s")) (.\ "_"; !some "s") !none) !(lambda (lambda none)) !(lambda none)) !(lambda none)) !none) : term).
  cbn -[none App Q some] in v.
  assert (Hv : forall n, v (enc n) ≡ Enum (enc n) (.\ "u"; "u" !(lambda none) (.\ "t", "s"; "t" (.\ "n"; !E "n" (!App !(tenc u) (!Q "s")) (.\ "_"; !some "s") !none) !(lambda (lambda none)) !(lambda none)) !(lambda none)) !none) by (intros; solvered).
  exists v.
  repeat split; value.
  - intros n. destruct (TE n) as [ | H]; try  destruct H as ([ | t1 s | ] & H & _).
    + left. rewrite Hv, H. solveeq.
    + left. rewrite Hv, H. solveeq.
    + destruct t1 as [ m | |].
      * destruct (eval m (u (tenc s))) eqn:He.
        -- right. exists s. rewrite Hv, H, some_correct_r. split.
           transitivity (E (enc m) (App (tenc u) (Q (tenc s))) (lambda (some (tenc s))) none). solveeq.
           rewrite Q_correct, App_correct, E_correct, He. transitivity (some (tenc s)). solveeq.
           now rewrite some_correct.
           eapply Hu. eapply eval_evaluates in He. firstorder. value. now value.
        -- left. rewrite Hv, H, some_correct_r.
           transitivity (E (enc m) (App (tenc u) (Q (tenc s))) (lambda (some (tenc s))) none). solveeq.
           rewrite Q_correct, App_correct, E_correct, He. solveeq. value. now value.
      * left. rewrite Hv, H. solveeq.
      * left. rewrite Hv, H. solveeq.
    + left. rewrite Hv, H. solveeq.
  - intros s [s' [n H] % evaluates_eval] % Hu.
    destruct (HE (n s)). eauto. exists x.
    rewrite Hv, H0.
    transitivity (E (enc n) (App (tenc u) (Q (tenc s))) (lambda (some (tenc s))) none). solveeq.
    rewrite Q_correct, App_correct, E_correct, H. solveeq.
Qed.

Lemma recognisable_range_total f u : proc u -> (forall n, u (enc n) ▷ tenc (f n)) -> recognisable (fun t => exists n, f n = t).
Proof.
  intros. eapply enumerable_recognisable.
  exists (lambda (some (u 0))). repeat split; value.
  - intros n. right. exists (f n); split; eauto.
    specialize (H0 n). solveeq.
  - intros s [n]. exists n. specialize (H0 n). subst. solveeq.
Qed.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import ListNotations.
Require Import Maps.
Require Import Imp.

Definition aequiv (a1 a2: aexp) : Prop :=
  forall (st: state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2: bexp) : Prop :=
  forall (st: state),
    beval st b1 = beval st b2.

Theorem aequiv_example:
  aequiv (AMinus (AId X) (AId X)) (ANum 0).
Proof.
  unfold aequiv. intros. simpl. omega.
Qed.

Theorem bequiv_example:
  bequiv (BEq (AMinus (AId X) (AId X)) (ANum 0)) BTrue.
Proof.
  unfold bequiv. intros.
  unfold beval. rewrite aequiv_example.
  reflexivity.
Qed.

Definition cequiv (c1 c2: com) : Prop :=
  forall (st st': state),
    (c1 / st \\ st') <-> (c2 / st \\ st').

Theorem skip_left: forall c,
  cequiv
     (SKIP ;; c)
     c.
Proof.
  unfold cequiv. intros.
  split; intros.
  - inversion H. subst.
    inversion H2. subst.
    assumption.
  - apply E_Seq with st.
    + apply E_Skip.
    + assumption.
Qed.

Theorem skip_right: forall c,
  cequiv
    (c ;; SKIP)
    c.
Proof.
  unfold cequiv. intros.
  split; intros.
  - inversion H. subst.
    inversion H5. subst.
    assumption.
  - apply E_Seq with st'.
    + assumption.
    + apply E_Skip.
Qed.

Theorem IFB_true_simple: forall c1 c2,
  cequiv
    (IFB BTrue THEN c1 ELSE c2 FI)
    c1.
Proof.
  unfold cequiv. intros.
  split; intros.
  - inversion H; subst.
    + assumption.
    + inversion H5.
  - apply E_IfTrue.
    + reflexivity.
    + assumption.
Qed.

Theorem IFB_true: forall b c1 c2,
    bequiv b BTrue ->
    cequiv
      (IFB b THEN c1 ELSE c2 FI)
      c1.
Proof.
  unfold bequiv, cequiv.
  split; intros.
  - inversion H0; subst.
    + assumption.
    + rewrite H in H6.
      inversion H6.
  - apply E_IfTrue.
    + apply H.
    + assumption.
Qed.

Theorem IFB_false: forall b c1 c2,
  bequiv b BFalse ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.
Proof.
  unfold bequiv, cequiv.
  split; intros.
  - inversion H0; subst.
    + rewrite H in H6.
      inversion H6.
    + assumption.
  - apply E_IfFalse.
    + apply H.
    + assumption.
Qed.

Theorem swap_if_branches: forall b e1 e2,
  cequiv
    (IFB b THEN e1 ELSE e2 FI)
    (IFB BNot b THEN e2 ELSE e1 FI).
Proof.
  unfold cequiv. intros.
  split; intros.
  - inversion H; subst.
    + apply E_IfFalse.
      * simpl. rewrite H5. reflexivity.
      * assumption.
    + apply E_IfTrue.
      * simpl. rewrite H5. reflexivity.
      * assumption.
  - inversion H; subst.
    + apply E_IfFalse.
      * simpl in H5. rewrite negb_true_iff in H5. apply H5.
      * assumption.
    + apply E_IfTrue.
      * simpl in H5. rewrite negb_false_iff in H5. apply H5.
      * assumption.
Qed.

Theorem WHILE_false : forall b c,
  bequiv b BFalse ->
  cequiv
    (WHILE b DO c END)
    SKIP.
Proof.
  unfold bequiv, cequiv. intros.
  split; intros.
  - inversion H0; subst.
    + apply E_Skip.
    + rewrite H in H3. inversion H3.
  - inversion H0; subst.
    apply E_WhileEnd.
    apply H.
Qed.

Theorem WHILE_true_nonterm : forall b c st st',
    bequiv b BTrue ->
    ~( (WHILE b DO c END) / st \\ st').
Proof.
  unfold not, bequiv. intros.
  remember (WHILE b DO c END) as cw.
  induction H0;
    inversion Heqcw; subst.
  - rewrite H in H0. inversion H0.
  - apply IHceval2. apply Heqcw.
Qed.

Lemma bequiv_self : forall b,
    bequiv b b.
Proof.
  unfold bequiv; intros; reflexivity.
Qed.

Theorem WHILE_true: forall b c,
  bequiv b BTrue ->
  cequiv
    (WHILE b DO c END)
    (WHILE BTrue DO SKIP END).
Proof.
  unfold cequiv; intros.
  split; intros.
  - exfalso.
    apply (WHILE_true_nonterm b c st st' H).
    apply H0.
  - inversion H0; subst.
    + apply E_WhileEnd.
      inversion H5.
    + exfalso.
      apply (WHILE_true_nonterm BTrue SKIP st st').
      * apply bequiv_self.
      * apply H0.
Qed.

Theorem loop_unrolling: forall b c,
  cequiv
    (WHILE b DO c END)
    (IFB b THEN (c ;; WHILE b DO c END) ELSE SKIP FI).
Proof.
  unfold cequiv; intros.
  split; intros.
  - inversion H; subst.
    + apply E_IfFalse.
      * assumption.
      * apply E_Skip.
    + apply E_IfTrue.
      * assumption.
      * apply E_Seq with (st' := st'0).
        assumption.
        assumption.
  - inversion H; subst.
    + inversion H6; subst.
      apply E_WhileLoop with (st' := st'0).
      * assumption.
      * assumption.
      * assumption.
    + inversion H6; subst.
      apply E_WhileEnd.
      assumption.
Qed.

Theorem seq_assoc : forall c1 c2 c3,
  cequiv ((c1;;c2);;c3) (c1;;(c2;;c3)).
Proof.
  unfold cequiv; intros.
  split; intros.
  - inversion H; subst.
    inversion H2; subst.
    apply E_Seq with (st' := st'1).
      assumption.
    apply E_Seq with (st' := st'0).
      assumption.
      assumption.
  - inversion H; subst.
    inversion H5; subst.
    apply E_Seq with (st' := st'1).
      apply E_Seq with (st' := st'0).
        assumption.
        assumption.
      assumption.
Qed.

Theorem identity_assignment : forall (X:id),
  cequiv
    (X ::= AId X)
    SKIP.
Proof.
  unfold cequiv; intros.
  split; intros.
  - inversion H; subst.
    simpl in *.
    replace (t_update st X (st X)) with st.
    + apply E_Skip.
    + apply functional_extensionality. intros.
      rewrite t_update_same. reflexivity.
  - replace st' with (t_update st' X (aeval st' (AId X))).
    + inversion H; subst.
      apply E_Ass.
      reflexivity.
    + simpl. rewrite t_update_same. reflexivity.
Qed.

Theorem assign_aequiv : forall X e,
  aequiv (AId X) e ->
  cequiv SKIP (X ::= e).
Proof.
  unfold aequiv; intros.
  split; intros.
  - inversion H0; subst.
    assert (st' = t_update st' X (st' X)).
    + apply functional_extensionality. intros.
      rewrite t_update_same.
      reflexivity.
    + rewrite H1 at 2.
      apply E_Ass.
      rewrite <- H.
      reflexivity.
  - inversion H0; subst.
    assert (st = t_update st X (aeval st e)).
    + apply functional_extensionality. intros.
      rewrite <- H.
      simpl.
      rewrite t_update_same.
      reflexivity.
    + rewrite <- H1.
      apply E_Skip.
Qed.

Lemma refl_aequiv : forall (a : aexp), aequiv a a.
Proof.
  unfold aequiv. reflexivity.
Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
  aequiv a1 a2 -> aequiv a2 a1.
Proof.
  unfold aequiv; intros.
  rewrite H. reflexivity.
Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
    aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
  unfold aequiv; intros.
  rewrite H, H0.
  reflexivity.
Qed.

Definition refl_bequiv := bequiv_self.

Lemma sym_bequiv : forall (b1 b2 : bexp),
  bequiv b1 b2 -> bequiv b2 b1.
Proof.
  unfold bequiv; intros.
  rewrite H.
  reflexivity.
Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
  bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
  unfold bequiv; intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma refl_cequiv : forall (c: com), cequiv c c.
Proof.
  unfold cequiv; intros.
  reflexivity.
Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv; intros.
  rewrite H.
  reflexivity.
Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
  (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  unfold cequiv; intros.
  apply (iff_trans (c1 / st \\ st') (c2 / st \\ st') (c3 / st \\ st') (H st st') (H0 st st')).
Qed.

Theorem CAss_congruence : forall i a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss i a1) (CAss i a1').
Proof.
  unfold aequiv, cequiv; intros.
  split; intros; inversion H0; subst;
    first [rewrite H | rewrite <- H];
    apply E_Ass;
    reflexivity.
Qed.

Theorem CWhile_congruence : forall b1 b2 c1 c2,
  bequiv b1 b2 ->
  cequiv c1 c2 ->
  cequiv
    (WHILE b1 DO c1 END)
    (WHILE b2 DO c2 END).
Proof.
  unfold bequiv, cequiv; intros.
  split; intros.
  - remember (WHILE b1 DO c1 END) as cwhile.
    induction H1; inversion Heqcwhile; subst.
    + apply E_WhileEnd. rewrite <- H. assumption.
    + apply E_WhileLoop with (st' := st').
      * rewrite <- H. assumption.
      * rewrite <- H0. assumption.
      * apply IHceval2. reflexivity.
  - remember (WHILE b2 DO c2 END) as cwhile.
    induction H1; inversion Heqcwhile; subst.
    + apply E_WhileEnd. rewrite H. assumption.
    + apply E_WhileLoop with (st' := st').
      * rewrite H. assumption.
      * rewrite H0. assumption.
      * apply IHceval2. reflexivity.
Qed.

Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
  unfold cequiv; intros.
  split; intros.
  - remember (c1;;c2) as cseq.
    destruct H1; inversion Heqcseq; subst.
    + apply E_Seq with (st' := st').
      * apply H. assumption.
      * apply H0. assumption.
  - remember (c1';;c2') as cseq.
    destruct H1; inversion Heqcseq; subst.
    + apply E_Seq with (st' := st').
      * apply H. assumption.
      * apply H0. assumption.
Qed.

Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (IFB b THEN c1 ELSE c2 FI)
         (IFB b' THEN c1' ELSE c2' FI).
Proof.
  unfold bequiv, cequiv; intros.
  split; intros.
  - remember (IFB b THEN c1 ELSE c2 FI) as cif.
    destruct H2; inversion Heqcif; subst.
    + apply E_IfTrue.
      * rewrite <- H. assumption.
      * apply H0. assumption.
    + apply E_IfFalse.
      * rewrite <- H. assumption.
      * apply H1. assumption.
  - remember (IFB b' THEN c1' ELSE c2' FI) as cif.
    destruct H2; inversion Heqcif; subst.
    + apply E_IfTrue.
      * rewrite  H. assumption.
      * apply H0. assumption.
    + apply E_IfFalse.
      * rewrite H. assumption.
      * apply H1. assumption.
Qed.

Example congruence_example:
  cequiv
    (* Program 1: *)
    (X ::= ANum 0;;
     IFB (BEq (AId X) (ANum 0))
     THEN
       Y ::= ANum 0
     ELSE
       Y ::= ANum 42
     FI)
    (* Program 2: *)
    (X ::= ANum 0;;
     IFB (BEq (AId X) (ANum 0))
     THEN
       Y ::= AMinus (AId X) (AId X) (* <--- changed here *)
     ELSE
       Y ::= ANum 42
     FI).
Proof.
  apply CSeq_congruence.
  - apply refl_cequiv.
  - apply CIf_congruence.
    + apply refl_bequiv.
    + apply CAss_congruence.
      unfold aequiv. simpl.
      symmetry.
      apply minus_diag.
    + apply refl_cequiv.
Qed.

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId i        => AId i
  | APlus a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 + n2)
    | (a1', a2') => APlus a1' a2'
    end
  | AMinus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 - n2)
    | (a1', a2') => AMinus a1' a2'
    end
  | AMult a1 a2  =>
    match (fold_constants_aexp a1, fold_constants_aexp a2)
    with
    | (ANum n1, ANum n2) => ANum (n1 * n2)
    | (a1', a2') => AMult a1' a2'
    end
  end.

Example fold_aexp_ex1 :
    fold_constants_aexp
      (AMult (APlus (ANum 1) (ANum 2)) (AId X))
  = AMult (ANum 3) (AId X).
Proof.
  reflexivity.
Qed.

Example fold_aexp_ex2 :
    fold_constants_aexp
      (AMinus (AId X) (APlus (AMult (ANum 0) (ANum 6))
                             (AId Y)))
  = AMinus (AId X) (APlus (ANum 0) (AId Y)).
Proof. reflexivity. Qed.

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue        => BTrue
  | BFalse       => BFalse
  | BEq a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if beq_nat n1 n2 then BTrue else BFalse
      | (a1', a2') =>
          BEq a1' a2'
      end
  | BLe a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) =>
          if leb n1 n2 then BTrue else BFalse
      | (a1', a2') =>
          BLe a1' a2'
      end
  | BNot b1  =>
      match (fold_constants_bexp b1) with
      | BTrue => BFalse
      | BFalse => BTrue
      | b1' => BNot b1'
      end
  | BAnd b1 b2  =>
      match (fold_constants_bexp b1, fold_constants_bexp b2) with
      | (BTrue, BTrue) => BTrue
      | (BTrue, BFalse) => BFalse
      | (BFalse, BTrue) => BFalse
      | (BFalse, BFalse) => BFalse
      | (b1', b2') => BAnd b1' b2'
      end
  end.

Example fold_bexp_ex1 :
    fold_constants_bexp (BAnd BTrue (BNot (BAnd BFalse BTrue)))
  = BTrue.
Proof. reflexivity. Qed.

Example fold_bexp_ex2 :
    fold_constants_bexp
      (BAnd (BEq (AId X) (AId Y))
            (BEq (ANum 0)
                 (AMinus (ANum 2) (APlus (ANum 1)
                                         (ANum 1)))))
  = BAnd (BEq (AId X) (AId Y)) BTrue.
Proof. reflexivity. Qed.

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP      =>
      SKIP
  | i ::= a  =>
      i ::= (fold_constants_aexp a)
  | c1 ;; c2  =>
      (fold_constants_com c1) ;; (fold_constants_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => IFB b' THEN fold_constants_com c1
                     ELSE fold_constants_com c2 FI
      end
  | WHILE b DO c END =>
      match fold_constants_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

Example fold_com_ex1 :
  fold_constants_com
    (* Original program: *)
    (X ::= APlus (ANum 4) (ANum 5);;
     Y ::= AMinus (AId X) (ANum 3);;
     IFB BEq (AMinus (AId X) (AId Y))
             (APlus (ANum 2) (ANum 4)) THEN
       SKIP
     ELSE
       Y ::= ANum 0
     FI;;
     IFB BLe (ANum 0)
             (AMinus (ANum 4) (APlus (ANum 2) (ANum 1)))
     THEN
       Y ::= ANum 0
     ELSE
       SKIP
     FI;;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END)
  = (* After constant folding: *)
    (X ::= ANum 9;;
     Y ::= AMinus (AId X) (ANum 3);;
     IFB BEq (AMinus (AId X) (AId Y)) (ANum 6) THEN
       SKIP
     ELSE
       (Y ::= ANum 0)
     FI;;
     Y ::= ANum 0;;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END).
Proof. reflexivity. Qed.

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound;
  unfold aequiv. intros.
  induction a; simpl; try reflexivity;
    destruct (fold_constants_aexp a1);
    destruct (fold_constants_aexp a2);
    rewrite IHa1; rewrite IHa2;
    reflexivity.
Qed.

Theorem fold_constants_bexp_sound:
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound;
  unfold bequiv. intros.
  induction b; try reflexivity.
  - rename a into a1. rename a0 into a2.
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1').
    replace (aeval st a2) with (aeval st a2').
    destruct a1'; destruct a2'; try reflexivity.
    simpl.
    destruct (beq_nat n n0); reflexivity.
    + rewrite Heqa2'.
      rewrite <- fold_constants_aexp_sound.
      reflexivity.
    + rewrite Heqa1'.
      rewrite <- fold_constants_aexp_sound.
      reflexivity.
  - rename a into a1. rename a0 into a2.
    simpl.
    remember (fold_constants_aexp a1) as a1' eqn:Heqa1'.
    remember (fold_constants_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1').
    replace (aeval st a2) with (aeval st a2').
    destruct a1'; destruct a2'; try reflexivity.
    simpl.
    destruct (leb n n0); reflexivity.
    + rewrite Heqa2'.
      rewrite <- fold_constants_aexp_sound.
      reflexivity.
    + rewrite Heqa1'.
      rewrite <- fold_constants_aexp_sound.
      reflexivity.
  - simpl.
    remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  - simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1, IHb2.
    destruct b1'; destruct b2'; reflexivity.
Qed.

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound; intros.
  induction c; simpl.
  - apply refl_cequiv.
  - apply CAss_congruence.
    apply fold_constants_aexp_sound.
  - apply CSeq_congruence.
    + assumption.
    + assumption.
  - assert (bequiv b (fold_constants_bexp b)).
    { apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb;
      try (apply CIf_congruence; assumption).
    + apply trans_cequiv with c1; try assumption.
      apply IFB_true. assumption.
    + apply trans_cequiv with c2; try assumption.
      apply IFB_false. assumption.
  - assert (bequiv b (fold_constants_bexp b)).
    { apply fold_constants_bexp_sound. }
    destruct (fold_constants_bexp b) eqn:Heqb;
      try (apply CWhile_congruence; assumption).
    + apply (WHILE_true b c H).
    + apply (WHILE_false b c H).
Qed.

Fixpoint optimize_0plus_aexp (e:aexp) : aexp :=
      match e with
      | AId x => AId x
      | ANum n =>
          ANum n
      | APlus (ANum 0) e2 =>
          optimize_0plus_aexp e2
      | APlus e1 e2 =>
          APlus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
      | AMinus e1 e2 =>
          AMinus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
      | AMult e1 e2 =>
          AMult (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
      end.

Theorem optimize_0plus_aexp_sound :
    atrans_sound optimize_0plus_aexp.
Proof.
  unfold atrans_sound, aequiv; intros.
  induction a; try reflexivity.
  - destruct a1.
    + destruct n.
      * simpl. apply IHa2.
      * simpl. rewrite IHa2. reflexivity.
    + simpl. rewrite IHa2. reflexivity.
    + simpl. simpl in IHa1.
      rewrite IHa1. rewrite IHa2.
      reflexivity.
    + simpl. simpl in IHa1.
      rewrite IHa1. rewrite IHa2.
      reflexivity.
    + simpl. simpl in IHa1.
      rewrite IHa1. rewrite IHa2.
      reflexivity.
  - simpl.
    rewrite IHa1. rewrite IHa2.
    reflexivity.
  - simpl.
    rewrite IHa1. rewrite IHa2.
    reflexivity.
Qed.

Fixpoint optimize_0plus_bexp (b : bexp) : bexp :=
  match b with
  | BEq l r => BEq (optimize_0plus_aexp l) (optimize_0plus_aexp r)
  | BLe l r => BLe (optimize_0plus_aexp l) (optimize_0plus_aexp r)
  | BNot b' => BNot (optimize_0plus_bexp b')
  | BAnd l r => BAnd (optimize_0plus_bexp l) (optimize_0plus_bexp r)
  | _ => b
  end.

Theorem optimize_0plus_bexp_sound :
    btrans_sound optimize_0plus_bexp.
Proof.
  unfold btrans_sound;
  unfold bequiv. intros.
  induction b; try reflexivity.
  - rename a into a1. rename a0 into a2.
    simpl.
    remember (optimize_0plus_aexp a1) as a1' eqn:Heqa1'.
    remember (optimize_0plus_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1').
    replace (aeval st a2) with (aeval st a2').
    reflexivity.
    + rewrite Heqa2'.
      rewrite <- optimize_0plus_aexp_sound.
      reflexivity.
    + rewrite Heqa1'.
      rewrite <- optimize_0plus_aexp_sound.
      reflexivity.
  - rename a into a1. rename a0 into a2.
    simpl.
    remember (optimize_0plus_aexp a1) as a1' eqn:Heqa1'.
    remember (optimize_0plus_aexp a2) as a2' eqn:Heqa2'.
    replace (aeval st a1) with (aeval st a1').
    replace (aeval st a2) with (aeval st a2').
    reflexivity.
    + rewrite Heqa2'.
      rewrite <- optimize_0plus_aexp_sound.
      reflexivity.
    + rewrite Heqa1'.
      rewrite <- optimize_0plus_aexp_sound.
      reflexivity.
  - simpl.
    remember (optimize_0plus_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  - simpl.
    remember (optimize_0plus_bexp b1) as b1' eqn:Heqb1'.
    remember (optimize_0plus_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1, IHb2.
    destruct b1'; destruct b2'; reflexivity.
Qed.

Fixpoint optimize_0plus_com (c : com) : com :=
  match c with
  | SKIP      =>
      SKIP
  | i ::= a  =>
      i ::= (optimize_0plus_aexp a)
  | c1 ;; c2  =>
      (optimize_0plus_com c1) ;; (optimize_0plus_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match optimize_0plus_bexp b with
      | BTrue => optimize_0plus_com c1
      | BFalse => optimize_0plus_com c2
      | b' => IFB b' THEN optimize_0plus_com c1
                     ELSE optimize_0plus_com c2 FI
      end
  | WHILE b DO c END =>
      match optimize_0plus_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (optimize_0plus_com c) END
      end
  end.

Theorem optimize_0plus_com_sound :
    ctrans_sound optimize_0plus_com.
Proof.
  unfold ctrans_sound; intros.
  induction c; simpl.
  - apply refl_cequiv.
  - apply CAss_congruence.
    apply optimize_0plus_aexp_sound.
  - apply CSeq_congruence.
    + assumption.
    + assumption.
  - assert (bequiv b (optimize_0plus_bexp b)).
    { apply optimize_0plus_bexp_sound. }
    destruct (optimize_0plus_bexp b) eqn:Heqb;
      try (apply CIf_congruence; assumption).
    + apply trans_cequiv with c1; try assumption.
      apply IFB_true. assumption.
    + apply trans_cequiv with c2; try assumption.
      apply IFB_false. assumption.
  - assert (bequiv b (optimize_0plus_bexp b)).
    { apply optimize_0plus_bexp_sound. }
    destruct (optimize_0plus_bexp b) eqn:Heqb;
      try (apply CWhile_congruence; assumption).
    + apply (WHILE_true b c H).
    + apply (WHILE_false b c H).
Qed.

Definition optimizer (c: com) : com :=
  optimize_0plus_com (fold_constants_com c).

Example optimizer_ex :
  optimizer
    (* Original program: *)
    (X ::= APlus (APlus (ANum 0) (ANum 2)) (ANum 5))
  = (* After constant folding: *)
    (X ::= ANum 7).
Proof. reflexivity. Qed.

Theorem optimizer_sound:
    ctrans_sound optimizer.
Proof.
  unfold ctrans_sound, optimizer; intros.
  apply trans_cequiv with (fold_constants_com c).
  - apply fold_constants_com_sound.
  - apply (optimize_0plus_com_sound (fold_constants_com c)).
Qed.

Fixpoint subst_aexp (i : id) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n       =>
      ANum n
  | AId i'       =>
      if beq_id i i' then u else AId i'
  | APlus a1 a2  =>
      APlus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMinus a1 a2 =>
      AMinus (subst_aexp i u a1) (subst_aexp i u a2)
  | AMult a1 a2  =>
      AMult (subst_aexp i u a1) (subst_aexp i u a2)
  end.

Example subst_aexp_ex :
  subst_aexp X (APlus (ANum 42) (ANum 53))
             (APlus (AId Y) (AId X))
= (APlus (AId Y) (APlus (ANum 42) (ANum 53))).
Proof. reflexivity. Qed.

Definition subst_equiv_property := forall i1 i2 a1 a2,
  cequiv (i1 ::= a1;; i2 ::= a2)
         (i1 ::= a1;; i2 ::= subst_aexp i1 a1 a2).

Theorem subst_inequiv :
  ~ subst_equiv_property.
Proof.
  unfold not, subst_equiv_property.
  intros.
  remember (X ::= APlus (AId X) (ANum 1);;
            Y ::= AId X)
      as c1.
  remember (X ::= APlus (AId X) (ANum 1);;
            Y ::= APlus (AId X) (ANum 1))
      as c2.
  assert (cequiv c1 c2)
    by (subst; apply H).
  remember (t_update (t_update empty_state X 1) Y 1) as st1.
  remember (t_update (t_update empty_state X 1) Y 2) as st2.
  assert (H1: c1 / empty_state \\ st1);
  assert (H2: c2 / empty_state \\ st2);
  try (subst;
       apply E_Seq with (st' := (t_update empty_state X 1));
       apply E_Ass; reflexivity).
  apply H0 in H1.
  assert (Hcontra: st1 = st2)
    by (apply (ceval_deterministic c2 empty_state); assumption).
  assert (Hcontra': st1 Y = st2 Y)
    by (rewrite Hcontra; reflexivity).
  subst.
  inversion Hcontra'.
Qed.

Inductive var_not_used_in_aexp (X:id) : aexp -> Prop :=
  | VNUNum: forall n, var_not_used_in_aexp X (ANum n)
  | VNUId: forall Y, X <> Y -> var_not_used_in_aexp X (AId Y)
  | VNUPlus: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (APlus a1 a2)
  | VNUMinus: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMinus a1 a2)
  | VNUMult: forall a1 a2,
      var_not_used_in_aexp X a1 ->
      var_not_used_in_aexp X a2 ->
      var_not_used_in_aexp X (AMult a1 a2).

Lemma aeval_weakening : forall i st a ni,
  var_not_used_in_aexp i a ->
  aeval (t_update st i ni) a = aeval st a.
Proof.
  intros.
  induction a; simpl; inversion H; subst;
    try reflexivity;
    try (
        apply IHa1 in H2; apply IHa2 in H3;
        rewrite H2, H3;
        reflexivity
      ).
  - apply (t_update_neq _ ni i i0 st H1).
Qed.

(* Theorem not_used_then_subst_equiv_property : forall i1 i2 a1 a2,
         var_not_used_in_aexp i1 a1 ->
         cequiv (i1 ::= a1;; i2 ::= a2)
         (i1 ::= a1;; i2 ::= subst_aexp i1 a1 a2).
         Proof.
         intros.
         apply CSeq_congruence.
         - apply refl_cequiv.
         - apply CAss_congruence.
         unfold aequiv.
         remember (subst_aexp i1 a1 a2) as sa.
         induction a1; intros; simpl.
         + simpl in Heqsa. *)

Theorem inequiv_exercise:
  ~ cequiv (WHILE BTrue DO SKIP END) SKIP.
Proof.
  unfold not; intros.
  eapply loop_never_stops with empty_state empty_state.
  unfold loop.
  apply H.
  apply E_Skip.
Qed.

Module Himp.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CHavoc : id -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'HAVOC' l" := (CHavoc l) (at level 60).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st : state, SKIP / st \\ st
  | E_Ass : forall (st : state) (a1 : aexp) (n : nat) (X : id),
      aeval st a1 = n ->
      (X ::= a1) / st \\ t_update st X n
  | E_Seq : forall (c1 c2 : com) (st st' st'' : state),
      c1 / st \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
      beval st b1 = true ->
      c1 / st \\ st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall (st st' : state) (b1 : bexp) (c1 c2 : com),
      beval st b1 = false ->
      c2 / st \\ st' ->
      (IFB b1 THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall (b1 : bexp) (st : state) (c1 : com),
      beval st b1 = false ->
      (WHILE b1 DO c1 END) / st \\ st
  | E_WhileLoop : forall (st st' st'' : state) (b1 : bexp) (c1 : com),
      beval st b1 = true ->
      c1 / st \\ st' ->
      (WHILE b1 DO c1 END) / st' \\ st'' ->
      (WHILE b1 DO c1 END) / st \\ st''
  | E_Havoc : forall (X: id) (st: state) (n: nat),
      (HAVOC X) / st \\ t_update st X n

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

Example havoc_example1 : (HAVOC X) / empty_state \\ t_update empty_state X 0.
Proof.
  apply E_Havoc.
Qed.

Example havoc_example2 :
  (SKIP;; HAVOC Z) / empty_state \\ t_update empty_state Z 42.
Proof.
  apply E_Seq with (st' := empty_state).
  - apply E_Skip.
  - apply E_Havoc.
Qed.

Definition cequiv (c1 c2 : com) : Prop := forall st st' : state,
  c1 / st \\ st' <-> c2 / st \\ st'.

Definition pXY :=
  HAVOC X;; HAVOC Y.

Definition pYX :=
  HAVOC Y;; HAVOC X.

Theorem pXY_cequiv_pYX :
  cequiv pXY pYX \/ ~ cequiv pXY pYX.
Proof.
  left.
  unfold not, cequiv, pXY, pYX; intros.
  split; intros; inversion H; subst.
  - inversion H2; inversion H5; subst.
    apply E_Seq with (st' := (t_update st Y n0)).
    + apply E_Havoc.
    + assert (J :  t_update (t_update st X n) Y n0 =  t_update (t_update st Y n0) X n).
      { apply t_update_permute.
        unfold not; intros; inversion H0. }
      rewrite J.
      apply E_Havoc.
  - inversion H2; inversion H5; subst.
    apply E_Seq with (st' := (t_update st X n0)).
    + apply E_Havoc.
    + assert (J :  t_update (t_update st X n0) Y n =  t_update (t_update st Y n) X n0).
      { apply t_update_permute.
        unfold not; intros; inversion H0. }
      rewrite <- J.
      apply E_Havoc.
Qed.

Definition ptwice :=
  HAVOC X;; HAVOC Y.

Definition pcopy :=
  HAVOC X;; Y ::= AId X.

Theorem ptwice_cequiv_pcopy :
  cequiv ptwice pcopy \/ ~ cequiv ptwice pcopy.
Proof.
  right.
  unfold not, cequiv; intros.
  remember (t_update (t_update empty_state X 1) Y 5) as st'.
  assert (ptwice / empty_state \\ st' ->
          pcopy / empty_state \\ st')
         by apply H.
  assert (~ (pcopy / empty_state \\ st')).
  {
   unfold not; intros.
   inversion H1; subst.
   inversion H7; subst.
   simpl in H8.
   assert (t_update (t_update empty_state X 1) Y 5 X = 1).
   { reflexivity. }
   assert (t_update (t_update empty_state X 1) Y 5 Y = 5).
   { reflexivity. }
   rewrite <- H8 in H2, H3.
   assert (st'0 X = 1).
   { apply H2. }
   assert (st'0 X = 5).
   { apply H3. }
   rewrite H5 in H6.
   inversion H6.
  }
  apply H1.
  apply H0.
  unfold ptwice.
  rewrite Heqst'.
  apply E_Seq with (st' := (t_update empty_state X 1)).
  - apply E_Havoc.
  - apply E_Havoc.
Qed.

Definition p1 : com :=
  WHILE (BNot (BEq (AId X) (ANum 0))) DO
    HAVOC Y;;
    X ::= APlus (AId X) (ANum 1)
  END.

Definition p2 : com :=
  WHILE (BNot (BEq (AId X) (ANum 0))) DO
    SKIP
  END.

Lemma p1_may_diverge : forall st st', st X <> 0 ->
  ~ p1 / st \\ st'.
Proof.
  unfold not, p1; intros.
  remember (WHILE BNot (BEq (AId X) (ANum 0))
        DO HAVOC Y;; X ::= APlus (AId X) (ANum 1) END) as p1.
  induction H0; inversion Heqp1.
  - subst.
    apply H.
    simpl in H0.
    apply negb_false_iff in H0.
    apply beq_nat_true in H0.
    assumption.
  - apply IHceval2.
    + rewrite H3 in H0_.
      inversion H0_; subst.
      inversion H8; subst.
      rewrite t_update_eq.
      simpl.
      rewrite <- plus_n_Sm.
      intros.
      inversion H1.
    + assumption.
Qed.

Lemma p2_may_diverge : forall st st', st X <> 0 ->
  ~ p2 / st \\ st'.
Proof.
  unfold not, p2; intros.
  remember (WHILE (BNot (BEq (AId X) (ANum 0))) DO
    SKIP
  END) as p2.
  induction H0; inversion Heqp2.
  - apply H.
    rewrite H2 in H0.
    simpl in H0.
    apply negb_false_iff in H0.
    apply beq_nat_true in H0.
    assumption.
  - apply IHceval2.
    + rewrite H3 in H0_.
      inversion H0_; subst.
      assumption.
    + rewrite H2, H3. reflexivity.
Qed.

Theorem p1_p2_equiv : cequiv p1 p2.
Proof.
  split; intros; inversion H; subst;
    try (apply E_WhileEnd; assumption);
    try ((apply p1_may_diverge with (st := st) (st' := st') in H);
         inversion H;
         simpl in H2;
         apply negb_true_iff in H2;
         apply beq_nat_false in H2;
         assumption).
    - (apply p1_may_diverge with (st := st) (st' := st') in H).
      inversion H.
              apply negb_true_iff in H2;
        apply beq_nat_false in H2.
        assumption.
   - (apply p2_may_diverge with (st := st) (st' := st') in H).
      inversion H.
              apply negb_true_iff in H2;
        apply beq_nat_false in H2.
        assumption.
Qed.


Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import
  Coq.QArith.Qabs
  CoRN.model.metric2.Qmetric
  CoRN.metric2.ProductMetric
  CoRN.model.totalorder.QposMinMax
  CoRN.model.totalorder.QMinMax
  CoRN.reals.faster.ARabs
  CoRN.reals.faster.ARroot
  CoRN.reals.faster.ARArith.

(** Basic definitions for the complex numbers. *)

Section ACcomplex.
Context `{AppRationals AQ}.

(* The instance of Setoid AR*AR is already in scope,
   with u = v iff (fst u = fst v /\ snd u = snd v). *)

Definition ACball (u v : AR*AR) (e : Q) : Prop
  := 0 <= e
     /\ ARle ((fst u - fst v)*(fst u - fst v) + (snd u - snd v)*(snd u - snd v))
            (inject_Q_AR (e*e)).

(* TODO the distance of ACball would be better. *)
Definition AC : MetricSpace := ProductMS AR AR.

Instance: Plus AC
  := fun xy uv => pair (fst xy + fst uv) (snd xy + snd uv).

Instance: Mult AC
  := fun xy uv => pair (fst xy*fst uv - snd xy*snd uv)
                    (fst xy*snd uv + snd xy*fst uv).

(* The square root of -1, imaginary number i. *)
Definition ACi : AC := pair 0 1.

Definition ACmodulus : AC -> AR
  := fun z => ARsqrt (fst z*fst z + snd z*snd z).

Lemma ACplus_comm : forall u v : AC, u + v = v + u.
Proof.
  intros u v. split; apply ARplus_comm.
Qed.

Lemma ACplus_assoc : forall u v w : AC,
    (u + v) + w = u + (v + w).
Proof.
  intros u v w. split; apply ARplus_assoc.
Qed.

Definition ACsqrt (z : AC) (yDec : {ARle 0 (snd z)} + {ARle (snd z) 0}) : AC
  := pair (ARsqrt ((ACmodulus z + fst z) * inject_Q_AR (1#2)))
          ((if yDec then 1 else -1)
           * (ARsqrt ((ACmodulus z - fst z) * inject_Q_AR (1#2)))).

Add Ring AR : (rings.stdlib_ring_theory AR).

Lemma ARdouble : forall x : AR, x + x = 2*x.
Proof.
  intro x. ring.
Qed.

Lemma ARmult_neg_one : forall x : AR, -1 * x = -x.
Proof.
  intros. ring.
Qed.

Lemma ACsqrt_correct : forall (z : AC) (yDec : {ARle 0 (snd z)} + {ARle (snd z) 0}),
    ACsqrt z yDec * ACsqrt z yDec = z.
Proof.
  intros [x y] yDec.
  assert (2 * inject_Q_AR (1 # 2) = 1) as twoHalf.
  { unfold one.
    pose proof inject_Q_AR_1.
    unfold one in H5.
    rewrite <- H5.
    rewrite <- inject_Q_AR_plus, <- inject_Q_AR_mult.
    apply inject_Q_AR_wd. reflexivity. }
  assert (ARle 0 (ACmodulus (x, y) - x)) as modMinus.
  { unfold ACmodulus, fst, snd.
    rewrite <- (ARplus_opp_r x).
    apply ARplus_le_compat_r.
    apply (ARle_trans _ (ARsqrt (x*x))).
    rewrite (ARsqrt_srq_abs x).
    apply ARle_abs.
    apply ARsqrt_inc.
    apply ARsquare_pos.
    rewrite <- (ARplus_0_r (x*x)) at 1.
    apply ARplus_le_compat_l.
    apply ARsquare_pos. }
  assert (ARle 0 (ACmodulus (x, y) + x)) as modPlus.
  { unfold ACmodulus, fst, snd.
    rewrite <- (ARplus_opp_r x).
    rewrite ARplus_comm.
    apply ARplus_le_compat_r.
    apply (ARle_trans _ (ARsqrt (x*x))).
    rewrite (ARsqrt_srq_abs x).
    rewrite <- ARabs_opp.
    apply ARle_abs.
    apply ARsqrt_inc.
    apply ARsquare_pos.
    rewrite <- (ARplus_0_r (x*x)) at 1.
    apply ARplus_le_compat_l.
    apply ARsquare_pos. }
  assert (ARle 0 (inject_Q_AR (1 # 2))) as halfPos.
  { rewrite <- inject_Q_AR_0.
    apply inject_Q_AR_le.
    discriminate. }
  split.
  - unfold mult, Mult_instance_0, ACsqrt, fst, snd.
    rewrite (ARsqrt_correct ((ACmodulus (x, y) + x) * inject_Q_AR (1 # 2))).
    rewrite (ARmult_comm (if yDec then 1 else -1)
                         (ARsqrt ((ACmodulus (x, y) - x) * inject_Q_AR (1 # 2)))).
    rewrite ARmult_assoc.
    rewrite <- (ARmult_comm (if yDec then 1 else -1)).
    rewrite <- (ARmult_assoc (if yDec then 1 else -1)).
    setoid_replace (ARmult (if yDec then 1 else -1) (if yDec then 1 else -1))
      with AR1.
    rewrite ARmult_1_l.
    rewrite (ARsqrt_correct ((ACmodulus (x, y) - x) * inject_Q_AR (1 # 2))).
    + setoid_replace ((ACmodulus (x, y) + x) * inject_Q_AR (1 # 2) -
                      (ACmodulus (x, y) - x) * inject_Q_AR (1 # 2))
        with (x*(2*inject_Q_AR (1#2))) by ring.
      rewrite twoHalf.
      apply ARmult_1_r.
    + apply AR_mult_0_le_compat. exact modMinus.
      exact halfPos.
    + destruct yDec. exact (ARmult_1_l AR1).
      pose proof (ARmult_neg_one (-1)).
      simpl in H5. rewrite H5. clear H5.
      apply ARopp_involutive.
    + apply AR_mult_0_le_compat. exact modPlus.
      exact halfPos.
  - unfold mult, Mult_instance_0, ACsqrt, fst, snd.
    rewrite ARmult_comm, ARmult_assoc, ARdouble.
    rewrite ARsqrt_mult, ARsqrt_mult.
    assert (forall a b c : AR, a * c * (b * c) = c * c * (a * b)).
    { intros. ring. }
    rewrite H5. clear H5.
    pose proof (ARsqrt_correct (inject_Q_AR (1 # 2))).
    simpl in H5. rewrite H5. clear H5.
    rewrite <- (ARsqrt_mult (ACmodulus (x, y) - x)).
    setoid_replace ((ACmodulus (x, y) - x) * (ACmodulus (x, y) + x))
      with (ACmodulus (x, y) * ACmodulus (x, y) - x*x)
      by ring.
    unfold ACmodulus, fst, snd.
    rewrite (ARsqrt_correct (x*x+y*y)).
    setoid_replace (x * x + y * y - x * x)
      with (y*y) by ring.
    rewrite ARsqrt_srq_abs.
    setoid_replace (2 * ((if yDec then 1 else -1) * (inject_Q_AR (1 # 2) * ARabs y)))
      with (2 * inject_Q_AR (1 # 2) * ((if yDec then 1 else -1) * ARabs y))
      by ring.
    rewrite twoHalf, ARmult_1_l.
    simpl in yDec. destruct yDec.
    rewrite ARmult_1_l.
    rewrite ARabs_pos. reflexivity. exact a.
    rewrite ARabs_neg.
    rewrite ARmult_neg_one.
    apply ARopp_involutive.
    exact a.
    apply (ARle_trans _ (x*x + 0)).
    rewrite ARplus_0_r.
    apply ARsquare_pos.
    apply ARplus_le_compat_l, ARsquare_pos.
    exact modMinus.
    exact modPlus.
    exact halfPos.
    exact modPlus.
    exact halfPos.
    exact modMinus.
    exact halfPos.
Qed.

End ACcomplex.


(******************************************************************************)
(** Imports **)

(* Disable notation conflict warnings *)
Set Warnings "-notation-overridden".

(* SSReflect *)
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq eqtype.
Set Bullet Behavior "Strict Subproofs".

(* Sortedness *)
Require Import Coq.Sorting.Sorted.

(* Basic Haskell libraries *)
Require Import GHC.Base      Proofs.GHC.Base.
Require Import Data.Foldable Proofs.Data.Foldable.
Require Import Data.Bits     Proofs.Data.Bits.Popcount.

(* IntSet library *)
Require Import Data.IntSet.Internal.
Require Import Utils.Containers.Internal.BitUtil.

(* IntSet proofs *)
Require Import DyadicIntervals.
Require Import IntSetProofs.

(* Bit manipulation *)
Require Import BitUtils.

(* Working with Haskell *)
Require Import HSUtil SortedUtil.

(******************************************************************************)
(** Name dismabiguation -- copied from HSUtil **)

Notation list    := Coq.Init.Datatypes.list.
Notation seq     := Coq.Lists.List.seq.
Notation reflect := ssrbool.reflect.

(******************************************************************************)
(** Bit manipulation **)

Theorem bitcount_0_1_power (n : Word) :
  bitcount #0 n = #1 <-> exists i, n = (2^i)%N.
Proof.
  rewrite /bitcount /popCount /=.
  split=> [/N_popcount_1_pow2 [i def_n] | [i ->{n}]].
  - by exists i.
  - apply N_popcount_pow2.
Qed.

Theorem WF_Bin_mask_power_N {p : Prefix} {m : Mask} {l r : IntSet} :
  WF (Bin p m l r) ->
  ex (fun i => m = 2^i)%N.
Proof.
  move=> /valid_maskPowerOfTwo /= /and3P [/Eq_eq BITS _ _].
  by apply bitcount_0_1_power.
Qed.

(******************************************************************************)
(** Well-formedness (WF) theorems **)

Theorem WF_Bin_children (p : Prefix) (m : Mask) (l r : IntSet) :
  WF (Bin p m l r) -> WF l /\ WF r.
Proof.
  case=> fn;
    inversion 1    as [|s bounds fn' desc];
    subst s fn';
    inversion desc as [|l' bounds_l fn_l r' bounds_r fn_r
                        p' m' bounds' fn'
                        desc_l desc_r is_pos sub_l sub_r def_p def_m spec_fn];
    subst p' m' l' r' bounds' fn'.
  split; [exists fn_l | exists fn_r]; eauto using DescSem.
Qed.

Corollary WF_Bin_left (p : Prefix) (m : Mask) (l r : IntSet) :
  WF (Bin p m l r) -> WF l.
Proof. by move=> /WF_Bin_children []. Qed.

Corollary WF_Bin_right (p : Prefix) (m : Mask) (l r : IntSet) :
  WF (Bin p m l r) -> WF r.
Proof. by move=> /WF_Bin_children []. Qed.

(******************************************************************************)
(** Sortedness theorems in terms of Ord **)

Theorem toList_sorted (s : IntSet) :
  WF s ->
  StronglySorted _<_ (toList s).
Proof.
  move=> WF_s; apply StronglySorted_R_ext with N.lt; last by apply to_List_sorted.
  move=> a b; unfold "<", Ord_Integer___ => /=.
  symmetry; apply rwP.
  apply/N.ltb_spec0.
Qed.

Theorem toAscList_sorted (s : IntSet) :
  WF s ->
  StronglySorted _<_ (toAscList s).
Proof.
  apply toList_sorted.
Qed.

Theorem toDescList_sorted (s : IntSet) :
  WF s ->
  StronglySorted _>_ (toDescList s).
Proof.
  move=> WF_s; rewrite toDescList_spec //.
  rewrite -StronglySorted_rev.
  by apply toList_sorted.
Qed.

(******************************************************************************)
(** Functions in terms of other functions **)

Theorem partition_filter (s : IntSet) (p : Word -> bool) :
  WF s ->
  partition p s = (filter p s, filter (fun k => ~~ p k) s).
Proof. by move=> WF_s; rewrite -partition_fst -partition_snd //; case: (partition p s). Qed.

Theorem split_splitMember (x : Word) (s : IntSet) :
  WF s ->
  let: (l,m,r) := splitMember x s in
  split x s = (l, r) /\ member x s = m.
Proof.
  move=> [fs Sem_s].
  apply splitMember_Sem with fs => //= l fl r fr m' Sem_l Sem_r <-{m'} def_fl def_fr.
  split.
  - apply split_Sem with fs => //= l' fl' r' fr' Sem_l' Sem_r' def_fl' def_fr'.
    f_equal; eauto using Sem_unique.
  - by apply member_Sem.
Qed.

Theorem split_splitMember' (x : Word) (s : IntSet) :
  WF s ->
  split x s = ((splitMember x s).1.1, (splitMember x s).2) /\ member x s = (splitMember x s).1.2.
Proof. by move=> /(split_splitMember x); case: (splitMember x s) => [[? ?] ?]. Qed.

Theorem splitMember_split (x : Word) (s : IntSet) :
  WF s ->
  let: (l,r) := split x s in
  splitMember x s = (l, member x s, r).
Proof. by move=> /(split_splitMember x); case: (splitMember x s) => [[? ?] ?] [-> ->]. Qed.

Theorem splitMember_split' (x : Word) (s : IntSet) :
  WF s ->
  splitMember x s = ((split x s).1, member x s, (split x s).2).
Proof. by move=> /(splitMember_split x); case: (split x s) => [? ?]. Qed.

Theorem split_filter (x : Word) (s : IntSet) :
  WF s ->
  split x s = (filter (fun y => y < x) s, filter (fun y => y > x) s).
Proof.
  move=> [fs Sem_s].
  apply split_Sem with fs => //= l fl r fr Sem_l Sem_r def_fl def_fr.
  f_equal; eauto using Sem_unique, filter_Sem.
Qed.

Theorem splitMember_filter (x : Word) (s : IntSet) :
  WF s ->
  splitMember x s = (filter (fun y => y < x) s, member x s, filter (fun y => y > x) s).
Proof.
  by move=> WFs; move: (WFs) (WFs) => /(splitMember_split' x) -> /(split_filter x) ->.
Qed.

(******************************************************************************)
(** Basic properties of Sem **)

Theorem Sem_Desc0 : forall s f, Sem s f -> exists r, Desc0 s r f.
Proof.
  apply Sem_ind => [f false_f | s r f Desc_srf].
  - by exists (0%N,0%N); apply Desc0Nil.
  - by exists r; apply (Desc0NotNil s r f r f); rewrite // isSubrange_refl.
Qed.

Theorem Sem_member (s : IntSet) :
  WF s ->
  Sem s (member ^~ s).
Proof.
  move=> [f def_f].
  apply Sem_change_f with f => //.
  by move: (def_f) => /member_Sem.
Qed.

(******************************************************************************)
(** Low-level IntSet membership theorems **)

Theorem Nil_member :
  forall k, member k Nil = false.
Proof. done. Qed.

Theorem Nil_member' :
  forall k, ~~ member k Nil.
Proof. done. Qed.

Theorem Tip_member (p : Prefix) (bm : BitMap) :
  WF (Tip p bm) ->
  forall k, member k (Tip p bm) = bitmapInRange (N.shiftr p (N.log2  WIDTH), N.log2 WIDTH) bm k.
Proof.
  move=> [fs SEMs] k;
    inversion SEMs  as [| s' rng fs' DESCs]; subst s' fs';
    inversion DESCs as [p' bm' rng' fs' def_p def_bits_r def_fs isbm_bm |]; subst p' bm' rng' fs' p.
  erewrite member_Desc, def_fs; last eassumption.
  f_equal.
  replace rng with (fst rng, rBits rng) by rewrite -surjective_pairing //.
  f_equal => //; rewrite /rPrefix.
  rewrite N.shiftr_shiftl_l; last Nomega.
  by rewrite def_bits_r N.shiftl_0_r /=.
Qed.

Theorem Bin_member (p : Prefix) (msk : Mask) (l r : IntSet) :
  WF (Bin p msk l r) ->
  forall k, member k (Bin p msk l r) = member k l || member k r.
Proof.
  move=> [fs SEMs] k;
    inversion SEMs  as [| s' rng fs' DESCs];
    subst s' fs';
    inversion DESCs as [| l' rng_l fl r' rng_r fr p' msk' rng' fs'
                          DESCl DESCr POS_bits SUBRl SUBRr def_p def_msk def_fs];
    subst l' r' p' msk' rng' fs' p msk.
  erewrite !member_Desc, def_fs; eauto.
Qed.

Theorem Bin_left_lt_right {p msk : N} {l r : IntSet} :
  WF (Bin p msk l r) ->
  forall kl, member kl l -> forall kr, member kr r -> kl < kr.
Proof.
  move=> WFs; move: (WFs) => [fs SEMs];
    inversion SEMs as [|s' rng_s fs' DESCs];
    subst s' fs';
    inversion DESCs as [|l' rng_l fl r' rng_r fr p' msk' rng_s' fs'
                         DESCl DESCr POSrng subrange_l subrange_r def_p def_m def_fs];
    subst p' msk' l' r' rng_s' fs' p msk.

  move=> kl MEM_kl kr MEM_kr.
  move: MEM_kl MEM_kr; erewrite !member_Desc; try eassumption.
  move=> /(Desc_inside DESCl)/(inRange_isSubrange_true _ _ _ subrange_l)/inRange_bounded IN_kl
         /(Desc_inside DESCr)/(inRange_isSubrange_true _ _ _ subrange_r)/inRange_bounded IN_kr.
  move: IN_kl IN_kr; rewrite rPrefix_halfRange_otherhalf // => IN_kl IN_kr.
  apply/N.ltb_spec0; Nomega.
Qed.

(******************************************************************************)
(** Working with IntSets by membership **)

Theorem eqIntSetMemberP {s1 s2 : IntSet} :
  WF s1 -> WF s2 ->
  reflect (forall x, member x s1 = member x s2) (s1 == s2).
Proof.
  move=> WF1 WF2.
  set s1' := exist _ _ WF1; set s2' := exist _ _ WF2.
  move: (IntSetFSet.equal_1 s1' s2') (IntSetFSet.equal_2 s1' s2').
  rewrite /= /IntSetFSet.Equal /= /IntSetFSet.In_set => Equal_eq eq_Equal.
  apply iff_reflect; split.
  - move=> KEYS; apply Equal_eq=> /= n; apply eq_iff_eq_true.
    move: KEYS; cbv -[member Z.of_N "<="%N eqb is_true].
    apply.
  - move=> /eq_Equal KEYS n.
    move: (KEYS n); cbv -[member eqb iff].
    by case: (member _ s1); case: (member _ s2); intuition.
Qed.

(* Prove the spec for `forall k, member k (F ... s ...) = ...` in terms of
   `F_Sem`, where `F` is a function that produces an `IntSet` from another
   `IntSet`. *)
Ltac member_by_Sem SEM :=
  repeat (move=> /Sem_member ? || move=> ?);
  erewrite member_Sem;
    last (eapply SEM; try eassumption; reflexivity);
    reflexivity.

Theorem insert_member (x : Nat) (s : IntSet) :
  WF s ->
  forall k, member k (insert x s) = (k == x) || member k s.
Proof. member_by_Sem insert_Sem. Qed.

Theorem delete_member (x : Nat) (s : IntSet) :
  WF s ->
  forall k, member k (delete x s) = (k /= x) && member k s.
Proof. member_by_Sem delete_Sem. Qed.

Theorem union_member (s1 s2 : IntSet) :
  WF s1 -> WF s2 ->
  forall k, member k (union s1 s2) = member k s1 || member k s2.
Proof. member_by_Sem union_Sem. Qed.

Theorem intersection_member (s1 s2 : IntSet) :
  WF s1 -> WF s2 ->
  forall k, member k (intersection s1 s2) = member k s1 && member k s2.
Proof. member_by_Sem intersection_Sem. Qed.

Theorem difference_member (s1 s2 : IntSet) :
  WF s1 -> WF s2 ->
  forall k, member k (difference s1 s2) = member k s1 && ~~ member k s2.
Proof. member_by_Sem difference_Sem. Qed.

Theorem unions_member (ss : list IntSet) :
  Forall WF ss ->
  forall k, member k (unions ss) = any (member k) ss.
Proof.
  move=> WF_ss k.
  rewrite /unions hs_coq_foldl'_list Foldable_any_ssreflect.
  rewrite -(orFb (has _ _)); change false with (member k empty); have: (WF empty) by [].
  elim: ss empty WF_ss => [|s ss IH] z WF_sss WF_z //=;
    [by rewrite orbF | inversion WF_sss as [|s' ss' WF_s WF_ss]; subst s' ss'].
  rewrite IH //; last by apply union_WF.
  by rewrite union_member // orbA.
Qed.

Theorem empty_member :
  forall k, member k empty = false.
Proof. done. Qed.

Theorem empty_member' :
  forall k, ~~ member k empty.
Proof. done. Qed.

Theorem singleton_member (x : Nat) :
  forall k, member k (singleton x) = (k == x).
Proof. member_by_Sem singleton_Sem. Qed.

Theorem null_member (s : IntSet) :
  WF s ->
  null s <-> forall k, member k s = false.
Proof.
  move=> [f Sem_s]; move: (Sem_s) => /null_Sem null_Sem_iff.
  split.
  - move=> null_s k; erewrite member_Sem; last eassumption.
    by apply null_Sem_iff.
  - move=> no_members; apply null_Sem_iff=> k.
    erewrite <-member_Sem; last eassumption.
    by apply no_members.
Qed.

Theorem disjoint_member (s1 s2 : IntSet) :
  WF s1 -> WF s2 ->
  disjoint s1 s2 <-> (forall k, ~~ (member k s1 && member k s2)).
Proof.
  move=> [f1 Sem1] [f2 Sem2]; move: (disjoint_Sem _ _ _ _ Sem1 Sem2) => disjoint_iff.
  split.
  - move=> /disjoint_iff is_disjoint k.
    erewrite !member_Sem; try eassumption.
    case: (is_disjoint k) => -> /=; intuition.
  - move=> is_disjoint; apply disjoint_iff => k.
    erewrite <-!member_Sem; try eassumption.
    move: (is_disjoint k) => [] /negbTE ->; tauto.
Qed.

Theorem isSubsetOf_member (s1 s2 : IntSet) :
  WF s1 -> WF s2 ->
  isSubsetOf s1 s2 <-> (forall k, member k s1 -> member k s2).
Proof.
  move=> [f1 Sem1] [f2 Sem2]; move: (isSubsetOf_Sem _ _ _ _ Sem1 Sem2) => subset_iff.
  split.
  - move=> /subset_iff is_subset k.
    erewrite !member_Sem; try eassumption.
    apply is_subset.
  - move=> is_subset; apply subset_iff=> k.
    erewrite <-!member_Sem; try eassumption.
    apply (is_subset k).
Qed.

Theorem isProperSubsetOf_member (s1 s2 : IntSet) :
  WF s1 -> WF s2 ->
  isProperSubsetOf s1 s2 <-> (forall k, member k s1 -> member k s2) /\ (s1 /= s2).
Proof.
  move=> [f1 Sem1] [f2 Sem2]; move: (isProperSubsetOf_Sem _ _ _ _ Sem1 Sem2) => proper_subset_iff.
  split.
  - move=> /proper_subset_iff [is_subset is_proper]; split.
    + move=> k; erewrite !member_Sem; try eassumption.
      apply is_subset.
    + rewrite Neq_inv; apply/Eq_eq=> ?; subst s2.
      case: is_proper => [] i; apply.
      erewrite Sem_extensional; eauto.
  - move=> [is_subset is_proper]; apply proper_subset_iff; split.
    + move=> k; erewrite <-!member_Sem; try eassumption.
      apply (is_subset k).
    + have distinct: s1 <> s2 by move=> ?; subst; move: is_proper; rewrite Neq_inv Eq_refl.
      eapply Sem_differ_witness; eassumption.
Qed.

Theorem fromList_member (xs : list Nat) :
  forall k, member k (fromList xs) = elem k xs.
Proof.
  move=> k.
  move: (fromList_Sem xs) => [f [SEM DEF]].
  erewrite member_Sem; last by eapply SEM.
  move: (DEF k); case: (f k) => DEF_k.
  all: by symmetry; apply/elemP/DEF_k.
Qed.

Theorem toList_member (s : IntSet) :
  WF s ->
  forall k, elem k (toList s) = member k s.
Proof.
  move=> /Sem_member/toList_In SEM k.
  by case CONT: (member k s) (SEM k) => SEM_k; apply/elemP/SEM_k.
Qed.

Theorem toAscList_member (s : IntSet) :
  WF s ->
  forall k, elem k (toAscList s) = member k s.
Proof. apply toList_member. Qed.

Theorem toDescList_member (s : IntSet) :
  WF s ->
  forall k, elem k (toDescList s) = member k s.
Proof.
  move=> WF_s; rewrite toDescList_spec // => k.
  by rewrite rev_elem toList_member.
Qed.

Theorem map_member (s : IntSet) (f : Nat -> Nat) :
  WF s ->
  forall k, member k (map f s) <-> ex2 (fun k' => member k' s) (fun k' => k = f k').
Proof.
  move=> WF_s k.
  rewrite /map /=; change @GHC.Base.map with @seq.map; rewrite fromList_member.
  rewrite elem_in; eapply iff_trans.
  + split; first by move=> /mapP/=; apply.
    move=> [k' k'_in ->].
    by apply map_f.
  + split; move=> [k' IN ?]; subst; exists k'=> //.
    * by rewrite -toList_member // elem_in.
    * rewrite in_elem toList_member //.
Qed.

Theorem filter_member (s : IntSet) (p : Nat -> bool) :
  WF s ->
  forall k, member k (filter p s) = member k s && p k.
Proof. member_by_Sem filter_Sem. Qed.

Theorem partition_member_1 (s : IntSet) (p : Nat -> bool) :
  WF s ->
  forall k, member k (partition p s).1 = member k s && p k.
Proof. by move=> *; rewrite partition_fst filter_member. Qed.

Theorem partition_member_2 (s : IntSet) (p : Nat -> bool) :
  WF s ->
  forall k, member k (partition p s).2 = member k s && ~~ p k.
Proof. by move=> *; rewrite partition_snd // filter_member. Qed.

Theorem split_member_1 (x : Nat) (s : IntSet) :
  WF s ->
  forall k, member k (split x s).1 = member k s && (k < x).
Proof. by move=> WFs k; rewrite split_filter //= filter_member. Qed.

Theorem split_member_2 (x : Nat) (s : IntSet) :
  WF s ->
  forall k, member k (split x s).2 = member k s && (k > x).
Proof. by move=> WFs k; rewrite split_filter //= filter_member. Qed.

Theorem splitMember_member_1 (x : Nat) (s : IntSet) :
  WF s ->
  forall k, member k (splitMember x s).1.1 = member k s && (k < x).
Proof. by move=> WFs k; rewrite splitMember_filter //= filter_member. Qed.

Theorem splitMember_member_bool (x : Nat) (s : IntSet) :
  WF s ->
  (splitMember x s).1.2 = member x s.
Proof. by move=> WFs; rewrite splitMember_filter. Qed.

Theorem splitMember_member_2 (x : Nat) (s : IntSet) :
  WF s ->
  forall k, member k (splitMember x s).2 = member k s && (k > x).
Proof. by move=> WFs k; rewrite splitMember_filter //= filter_member. Qed.


(** Coq coding by choukh, Jan 2021 **)

Require Import ZFC.Axiom.ZFC2.

(* Epsilon-induction *)
(* https://en.wikipedia.org/wiki/Epsilon-induction *)

(**=== Epsilon归纳原理 ===**)
(* 对于集合的任意性质P，如果可以通过证明"集合A的所有成员都具有性质P"来证明A具有性质P，
  那么所有集合都具有性质P。 *)
Axiom ε_ind : ∀ P : set → Prop,
  (∀ A, (∀a ∈ A, P a) → P A) → ∀ A, P A.

Lemma not_all_not_iff_ex : ∀ P : set → Prop, ¬ (∀ A, ¬ P A) ↔ (∃ A, P A).
Proof. split. exact (not_all_not_ex _ P). firstorder. Qed.

Lemma not_all_iff_ex_not : ∀ P : set → Prop, ¬ (∀ A, P A) ↔ (∃ A, ¬ P A).
Proof. split. exact (not_all_ex_not _ P). firstorder. Qed.

(** ∈归纳原理蕴含正则公理模式 **)
Theorem reg_schema : ∀ P,
  (∃ A, P A) → ∃ A, P A ∧ ¬∃x ∈ A, P x.
Proof.
  intros P.
  pose proof (ε_ind (λ x, ¬ P x)). simpl in H.
  remember (∀ A, (∀x ∈ A, ¬ P x) → ¬ P A) as R.
  remember (∀ A, ¬ P A) as S.
  assert (∀ P Q: Prop, (P → Q) → (¬ Q → ¬ P)) by auto.
  pose proof (H0 R S H). subst. clear H H0.
  rewrite not_all_not_iff_ex in H1.
  rewrite not_all_iff_ex_not in H1.
  intros. apply H1 in H. destruct H as [A H].
  exists A. clear H1.
  assert (∀ A B : Prop, ¬ (A → ¬ B) ↔ ¬¬B ∧ ¬¬A) by firstorder.
  rewrite H0 in H. clear H0. destruct H.
  apply NNPP in H. apply NNPP in H0. firstorder.
Qed.

(* 由正则公理模式导出原始正则公理：
  所有非空集合X中至少有一个成员x，它与X的交集为空集。*)
Theorem regularity : ∀ A, A ≠ ∅ → ∃a ∈ A, a ∩ A = ∅.
Proof.
  intros A Hne. apply EmptyNE in Hne.
  pose proof (reg_schema (λ x, x ∈ A)).
  simpl in H. apply H in Hne.
  destruct Hne as [x [H1 H2]].
  exists x. split. apply H1.
  apply EmptyI. intros y H3.
  apply H2. apply BInterE in H3.
  exists y. apply H3.
Qed.

(* 不存在以自身为元素的集合 *)
Theorem not_self_contained : ¬ ∃ x, x ∈ x.
Proof.
  intros H.
  pose proof (reg_schema (λ x, x ∈ x)).
  simpl in H0. apply H0 in H.
  destruct H as [x [H1 H2]].
  apply H2. exists x. split; auto.
Qed.

(* 没有循环单链 *)
Lemma well_founded_1 : ∀ X, X ∉ X.
Proof.
  intros X. pose proof (ε_ind (λ X, X ∉ X)). simpl in H.
  apply H. intros. intros Ht. apply H0 in Ht as Hf. auto.
Qed.

(* 没有循环双链 *)
Lemma well_founded_2 : ∀ X Y, X ∈ Y → Y ∉ X.
Proof.
  intros X Y H. pose proof (ε_ind (λ X, ∀ Y, X ∈ Y → Y ∉ X)).
  apply H0; [|apply H]. clear X Y H H0.
  intros X H Y H1 H2.
  pose proof (H Y H2 X H2). auto.
Qed.

(* 没有循环三链 *)
Lemma well_founded_3 : ∀ X Y Z, X ∈ Y → Y ∈ Z → Z ∉ X.
Proof.
  intros X Y Z H. pose proof (ε_ind (λ X, ∀ Y Z, X ∈ Y → Y ∈ Z → Z ∉ X)).
  apply H0; [|apply H]. clear X Y Z H H0.
  intros X H Y Z H1 H2 H3.
  pose proof (H Z H3 X Y H3 H1). auto.
Qed.


From Undecidability.FOL.Incompleteness Require Import utils.

From Undecidability.Synthetic Require Import Definitions EnumerabilityFacts.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(** ** Church's thesis *)

Definition is_universal {Y : Type} (theta : nat -> nat -\ Y) :=
  forall f : nat -\ Y, exists c, forall x y, f x ▷ y <-> theta c x ▷ y.

Definition EPF_B := exists (theta : nat -> nat -\ bool), is_universal theta.
Definition EPF_N := exists (theta : nat -> nat -\ nat), is_universal theta.

Section epf.
  Variable (theta : nat -> nat -\ bool).
  Hypothesis theta_universal : is_universal theta.

  Definition self_halting : nat -> Prop := fun x => exists y, theta x x ▷ y.

  Theorem self_halting_diverge (f : nat -\ bool) :
    (forall c, f c ▷ true <-> self_halting c) ->
    exists c, forall y, ~f c ▷ y.
  Proof.
    intros H.
    unshelve evar (g: nat -\ bool).
    { intros n. exists (fun k => match (f n).(core) k with
                                 | Some true => None
                                 | Some false => Some true
                                 | None => None
                                 end).
      intros y1 y2 k1 k2 Hk1 Hk2.
      destruct (core (f n) k1) as [[]|] eqn:Hf1, (core (f n) k2) as [[]|] eqn:Hf2.
      all: congruence. }
    destruct (theta_universal g) as [c Hc]. exists c.
    intros [] Hf.
    - pose proof (Hf' := Hf).
      apply H in Hf.
      destruct Hf as [b [k Hk]%Hc].
      cbn in Hk. destruct (core (f c) k) as [[]|] eqn:Hf; try discriminate.
      enough (true = false) by discriminate.
      apply (@part_functional _ (f c)); firstorder.
    - enough (f c ▷ true) as H1.
      { now pose proof (part_functional Hf H1). }
      apply H. exists true. apply Hc.
      destruct Hf as [k Hk]. exists k.
      cbn. now rewrite Hk.
  Qed.

  Lemma self_halting_undec : ~decidable self_halting.
  Proof.
    intros [f Hf].
    unshelve evar (g: nat -\ bool).
    { intros n. exists (fun _ => Some (f n)). congruence. }
    destruct (@self_halting_diverge g).
    { intros c. split.
      - now intros [k [=Hk%Hf]].
      - intros H%Hf. exists 0. cbn. congruence. }
    apply (H (f x)). now exists 0.
  Qed.

  (* A partial function recursively separates two predicates *)
  Definition recursively_separates (P1 P2 : nat -> Prop)  (f : nat -\ bool) :=
    (forall x, P1 x -> f x ▷ true) /\
    (forall x, P2 x -> f x ▷ false).

  Definition theta_self_return (b : bool) : nat -> Prop :=
    fun x => theta x x ▷ b.

  Lemma theta_self_return_semi_decidable b : semi_decidable (theta_self_return b).
  Proof.
    exists (fun c k => match core (theta c c) k, b with
                       | Some true, true => true
                       | Some false, false => true
                       | _, _ => false
                       end).
   intros c. split; intros [k Hk]; exists k.
   - rewrite Hk. destruct b; congruence.
   - destruct (core _ _) as [[]|], b; congruence.
  Qed.
  Lemma theta_self_return_enumerable b : enumerable (theta_self_return b).
  Proof.
    apply semi_decidable_enumerable.
    { exists (fun n => Some n). intros n. now exists n. }
    apply theta_self_return_semi_decidable.
  Qed.

  Theorem recursively_separating_diverge (f : nat -\ bool):
    (forall b c, theta_self_return b c -> f c ▷ b) ->
    exists c, forall y, ~f c ▷ y.
  Proof.
    intros H.
    unshelve evar (g : nat -\ bool).
    { intros x. exact (comp_part_total negb (f x)). }
    destruct (theta_universal g) as [c Hc]. exists c.
    intros y [k Hk].
    assert (g c ▷ (negb y)) as Hg.
    { exists k. cbn. rewrite Hk. reflexivity. }
    apply Hc in Hg. specialize (H _ _ Hg).
    enough (y = negb y) by now destruct y.
    apply (@part_functional _ (f c)).
    - now exists k.
    - assumption.
  Qed.

  Lemma no_recursively_separating (f : nat -> bool) :
    (* Looks closer to required condition by destructing b *)
    ~(forall b c, theta_self_return b c -> f c = b).
  Proof.
    intros H.
    unshelve evar (g : nat -\ bool).
    { intros x. exists (fun _ => Some (f x)). congruence. }
    destruct (@recursively_separating_diverge g) as [c Hc].
    { intros b c Hc%H. exists 0. cbn. congruence. }
    apply (Hc (f c)). now exists 0.
  Qed.

End epf.

Section epf_nat_bool.
  Local Definition bool_to_nat (b : bool) := if b then 1 else 0.
  Local Program Definition nat_to_bool : nat -\ bool.
  Proof.
    intros [|[|n]].
    - exists (fun _ => Some false). congruence.
    - exists (fun _ => Some true). congruence.
    - exists (fun _ => None). congruence.
  Defined.
  (* EPF_N implies EPF_B *)
  Lemma epf_nat_bool : EPF_N -> EPF_B.
  Proof.
    intros [theta theta_universal].
    unshelve eexists.
    { intros c x. exact (comp_part_partial nat_to_bool (theta c x)). }
    intros f.
    unshelve edestruct theta_universal as [c Hc].
    { intros x. exact (comp_part_total bool_to_nat (f x)). }
    exists c. intros x y. split; intros [k Hk].
    - assert (theta c x ▷ bool_to_nat y) as [k' Hk'].
      { rewrite <-Hc. exists k. cbn. now rewrite Hk. }
      exists k'. cbn. rewrite Hk'. now destruct y.
    - assert (theta c x ▷ bool_to_nat y) as [k' Hk']%Hc.
      { exists k. cbn in Hk. destruct core; try congruence.
        destruct y, n as [|[|n]]; cbn in *; try congruence. }
      exists k'. cbn in Hk'. destruct (core (f x) k') as [[]|], y as []; cbn in *; congruence.
  Qed.

End epf_nat_bool.


Require Coq.Setoids.Setoid.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Arith.EqNat.

Require Import Shared.
Require Import Meta.

(*
=============
Partial maps
=============
*)

Ltac case_id_eq_dec :=
  match goal with
    | _ : _ |- context[id_eq_dec _ _] =>
      repeat(elim id_eq_dec); intros; subst; try(congruence)
  end.

Ltac case_extend :=
  match goal with
    | _ : _ |- context[extend _ _ _ _] =>
      unfold extend; case_id_eq_dec
  end.

Ltac case_drop :=
  match goal with
    | _ : _ |- context[drop _ _ _] =>
      unfold drop; cases_if
  end.

Lemma extend_eq :
  forall A B (eqd : ID A) Gamma x y (v : B),
    x = y ->
    extend Gamma x v y = Some v.
Proof with case_extend.
  introv...
Qed.

Hint Resolve extend_eq.

Lemma extend_neq :
  forall A B (eqd : ID A) Gamma x y (v : B),
    x <> y ->
    extend Gamma x v y = Gamma y.
Proof with case_extend.
  introv...
Qed.

Hint Resolve extend_neq.

Lemma extend_order :
  forall A B (eqd : ID A) Gamma x y z (v1 v2 : B),
    x <> y ->
    extend (extend Gamma x v1) y v2 z =
    extend (extend Gamma y v2) x v1 z.
Proof with case_extend.
  introv...
Qed.

Hint Resolve extend_order.

Lemma extend_shadow :
  forall A B (eqd : ID A) Gamma x y (v1 v2 : B),
    extend (extend Gamma x v1) x v2 y=
    extend Gamma x v2 y.
Proof with case_extend.
  introv...
Qed.

Hint Resolve extend_shadow.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia Max.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils decidable
                 fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Implicit Arguments.

(* * Removal of function symbols from propositional signatures *)

Section Σ_Σ0.

  Variable (Σ  : fo_signature)
           (HΣ : forall r, ar_rels Σ r = 0).

  Definition Σ0 : fo_signature.
  Proof using Σ.
    exists Empty_set (rels Σ); exact (fun _ => 0).
  Defined.

  Fixpoint Σ_Σ0 (A : fol_form Σ) :=
    match A with
      |  ⊥            => ⊥
      | fol_atom r _  => @fol_atom Σ0 r vec_nil
      | fol_bin b A B => fol_bin b (Σ_Σ0 A) (Σ_Σ0 B)
      | fol_quant q A => fol_quant q (Σ_Σ0 A)
     end.

  Section soundness.

    Variable (X : Type) (M : fo_model Σ X).

    Let M' : fo_model Σ0 unit.
    Proof.
      split.
      + intros [].
      + intros r _; apply (fom_rels M r).
        rewrite HΣ; exact vec_nil.
    Defined.

    Local Fact Σ_Σ0_sound A φ ψ : fol_sem M φ A <-> fol_sem M' ψ (Σ_Σ0 A).
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl; fol equiv.
        revert v; rewrite (HΣ r); unfold eq_rect_r; simpl.
        intros v; vec nil v; auto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists tt; revert H; apply HA.
        * intros (? & H); exists (φ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (φ 0)); apply HA.
        * intros H x; generalize (H tt); apply HA.
    Qed.

    Hypothesis (Mdec : fo_model_dec M)
               (phi : nat -> X)
               (A : fol_form Σ)
               (HA : fol_sem M phi A).

    Local Lemma Σ_Σ0_soundness : fo_form_fin_dec_SAT (Σ_Σ0 A).
    Proof using HΣ Mdec HA.
      exists unit, M', finite_t_unit.
      exists. { intros r v; simpl; apply Mdec. }
      exists (fun _ => tt).
      revert HA; apply Σ_Σ0_sound.
    Qed.

  End soundness.

  Section completeness.

    Variable (X : Type) (M' : fo_model Σ0 X).

    Let M : fo_model Σ unit.
    Proof.
      split.
      + intros; exact tt.
      + intros r _; apply (fom_rels M' r vec_nil).
    Defined.

    Local Fact Σ_Σ0_complete A φ ψ : fol_sem M φ A <-> fol_sem M' ψ (Σ_Σ0 A).
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl; tauto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists (ψ 0); revert H; apply HA.
        * intros (? & H); exists (φ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (φ 0)); apply HA.
        * intros H x; generalize (H (ψ 0)); apply HA.
    Qed.

    Hypothesis (M'dec : fo_model_dec M')
               (psi : nat -> X)
               (A : fol_form Σ)
               (HA : fol_sem M' psi (Σ_Σ0 A)).

    Local Lemma Σ_Σ0_completeness : fo_form_fin_dec_SAT A.
    Proof using M'dec HA.
      exists unit, M, finite_t_unit.
      exists. { intros r v; simpl; apply M'dec. }
      exists (fun _ => tt).
      revert HA; apply Σ_Σ0_complete.
    Qed.

  End completeness.

  Theorem Σ_Σ0_correct A : fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT (Σ_Σ0 A).
  Proof using HΣ.
    split.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ_Σ0_soundness with X M phi; auto.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ_Σ0_completeness with X M phi; auto.
  Qed.

End Σ_Σ0.

Section Σ0_Σ.

  Variable (Σ  : fo_signature)
           (HΣ : forall r, ar_rels Σ r = 0).

  Fixpoint Σ0_Σ (A : fol_form (Σ0 Σ)) :=
    match A with
      |  ⊥            => ⊥
      | fol_atom r _  => @fol_atom Σ r (cast vec_nil (eq_sym (HΣ r)))
      | fol_bin b A B => fol_bin b (Σ0_Σ A) (Σ0_Σ B)
      | fol_quant q A => fol_quant q (Σ0_Σ A)
     end.

  Section soundness.

    Variable (X : Type) (M : fo_model (Σ0 Σ) X).

    Let M' : fo_model Σ unit.
    Proof.
      split.
      + intros; exact tt.
      + intros r _; apply (fom_rels M r vec_nil).
    Defined.

    Local Fact Σ0_Σ_sound A φ ψ : fol_sem M' ψ (Σ0_Σ A) <-> fol_sem M φ A.
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl in *; vec nil v; simpl; tauto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists (φ 0); revert H; apply HA.
        * intros (? & H); exists (ψ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (ψ 0)); apply HA.
        * intros H x; generalize (H (φ 0)); apply HA.
    Qed.

    Hypothesis (Mdec : fo_model_dec M)
               (φ : nat -> X)
               (A : fol_form (Σ0 Σ))
               (HA : fol_sem M φ A).

    Local Lemma Σ0_Σ_soundness : fo_form_fin_dec_SAT (Σ0_Σ A).
    Proof using Mdec HA.
      exists unit, M', finite_t_unit.
      exists. { intros r v; simpl; apply Mdec. }
      exists (fun _ => tt).
      revert HA; apply Σ0_Σ_sound.
    Qed.

  End soundness.

  Section completeness.

    Variable (X : Type) (M : fo_model Σ X).

    Let M' : fo_model (Σ0 Σ) unit.
    Proof.
      split.
      + intros [].
      + intros r _; apply (fom_rels M r).
        rewrite HΣ; exact vec_nil.
    Defined.

    Local Fact Σ0_Σ_complete A φ ψ : fol_sem M ψ (Σ0_Σ A) <-> fol_sem M' φ A.
    Proof.
      revert φ ψ; induction A as [ | r v | b A HA B HB | [] A HA ]; intros φ ψ.
      + simpl; tauto.
      + simpl; fol equiv.
        revert v; rewrite (HΣ r); unfold eq_rect_r; simpl; auto.
      + apply fol_bin_sem_ext; auto.
      + simpl; split.
        * intros (? & H); exists tt; revert H; apply HA.
        * intros (? & H); exists (ψ 0); revert H; apply HA.
      + simpl; split.
        * intros H x; generalize (H (ψ 0)); apply HA.
        * intros H x; generalize (H tt); apply HA.
    Qed.

    Hypothesis (Mdec : fo_model_dec M)
               (phi : nat -> X)
               (A : fol_form (Σ0 Σ))
               (HA : fol_sem M phi (Σ0_Σ A)).

    Local Lemma Σ0_Σ_completeness : fo_form_fin_dec_SAT A.
    Proof using Mdec HA.
      exists unit, M', finite_t_unit.
      exists. { intros r v; simpl; apply Mdec. }
      exists (fun _ => tt).
      revert HA; apply Σ0_Σ_complete.
    Qed.

  End completeness.

  Theorem Σ0_Σ_correct A : fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT (Σ0_Σ A).
  Proof.
    split.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ0_Σ_soundness with X M phi; auto.
    + intros (X & M & _ & G2 & phi & G3).
      apply Σ0_Σ_completeness with X M phi; auto.
  Qed.

End Σ0_Σ.