Require Import List.
Import ListNotations.

Require Import Logic.Class.Eq.

Require Import Logic.List.In.
Require Import Logic.List.Remove.
Require Import Logic.List.Include.

Require Import Logic.Fol.Free.
Require Import Logic.Fol.Syntax.
Require Import Logic.Fol.Functor.
Require Import Logic.Fol.Variable.

Fixpoint bnd (v:Type) (p:P v) : list v :=
    match p with
    | Bot       => []
    | Elem x y  => []
    | Imp p1 p2 => bnd v p1 ++ bnd v p2
    | All x p1  => x :: bnd v p1
    end.

Arguments bnd {v} _.

Lemma bnd_var : forall (v:Type) (p:P v), bnd p <= var p.
Proof.
    intros v.
    induction p as [|x y|t1 IH1 t2 IH2|x t1 IH1]; simpl.
    - apply incl_refl.
    - intros z H. inversion H.
    - apply incl_app2; assumption.
    - apply incl_cons_compat. assumption.
Qed.

Lemma bnd_free : forall (v:Type) (e:Eq v) (p:P v) (z:v),
    z :: var p <-> (z :: Fr p) \/ (z :: bnd p).
Proof.
    intros v e p z. split.
    - induction p as [|x y|t1 IH1 t2 IH2|x t1 IH1]; intros H; simpl in H.
        + exfalso. assumption.
        + left. simpl. assumption.
        + apply in_app_or in H. destruct H as [H|H].
            { apply IH1 in H. destruct H as [H|H].
                { left.  simpl. apply in_or_app. left. assumption. }
                { right. simpl. apply in_or_app. left. assumption. }
            }
            { apply IH2 in H. destruct H as [H|H].
                { left.  simpl. apply in_or_app. right. assumption. }
                { right. simpl. apply in_or_app. right. assumption. }
            }
        + destruct H as [H|H].
            { right. simpl. left. assumption. }
            { apply IH1 in H. destruct H as [H|H].
                { destruct (eqDec x z) as [E|E].
                    { right. simpl. left. assumption. }
                    { left.  simpl. apply remove_charac. split; assumption. }
                }
                { right. right. assumption. }
            }
    - intros [H|H].
        + apply (free_var v e). assumption.
        + apply bnd_var. assumption.
Qed.

Lemma bnd_fmap : forall (v w:Type) (f:v -> w) (p:P v),
    bnd (fmap f p) = map f (bnd p).
Proof.
    intros v w f.
    induction p as [|x y|p1 IH1 p2 IH2|x p1 IH1]; simpl.
    - reflexivity.
    - reflexivity.
    - rewrite map_app, IH1, IH2. reflexivity.
    - rewrite IH1. reflexivity.
Qed.


(**************************************************************)
(*   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 Bool Lia Eqdep_dec.

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 fol_ops fo_sig fo_terms fo_logic fo_sat Sig2_SigSSn1.

Import fol_notations.

Set Implicit Arguments.

(* * Expanding from Σ=({f^n};{P^1}) to any signature *)

Tactic Notation "iff" "equal" := apply fol_equiv_ext.

Local Notation ø := vec_nil.

Section Sig_n1_Sig.

  Variable (n : nat) (Σ' : fo_signature) (f : syms Σ') (p : rels Σ').

  Notation Σ := (Σn1 n).

  Hypothesis (Hf : ar_syms _ f = n).
  Hypothesis (Hp : ar_rels _ p = 1).

  Let Fixpoint convert_t (t : fo_term (ar_syms Σ)) : fo_term (ar_syms Σ').
  Proof.
    refine (match t with
      | in_var i   => in_var i
      | in_fot s v => @in_fot _ (ar_syms Σ') f (vec_map convert_t (cast v _))
    end); now simpl.
  Defined.

  Fixpoint Σn1_Σ (A : fol_form Σ) : fol_form Σ'.
  Proof using Hf Hp.
    refine (match A with
      | ⊥              => ⊥
      | fol_atom   _ v => fol_atom p (vec_map convert_t (cast v _))
      | fol_bin b A B  => fol_bin b (Σn1_Σ A) (Σn1_Σ B)
      | fol_quant q A  => fol_quant q (Σn1_Σ A)
     end); now simpl.
  Defined.

  Notation convert := Σn1_Σ.

  Section soundness.

    Variables (X : Type) (M : fo_model Σ X) (phi : nat -> X).

    Let M' : fo_model Σ' X.
    Proof.
      split.
      + intros s.
        destruct (eq_nat_dec (ar_syms _ s) n) as [ E | D ].
        * intros v; apply (fom_syms M tt); revert v; rewrite E; trivial.
        * intros; apply (phi 0).
      + intros r.
        destruct (eq_nat_dec (ar_rels _ r) 1) as [ E | D ].
        * intros v; apply (fom_rels M tt); revert v; rewrite E; trivial.
        * intros; exact True.
    Defined.

    Let convert_t_sound t φ : fo_term_sem M φ t = fo_term_sem M' φ (convert_t t).
    Proof.
      induction t as [ i | [] v IH ]; simpl; auto.
      destruct (eq_nat_dec (ar_syms Σ' f) n) as [ H | [] ]; auto.
      rewrite vec_map_map; generalize H Hf; intros -> H'.
      unfold eq_rect_r; simpl; f_equal.
      apply vec_pos_ext; intros j; rewrite !vec_pos_map.
      rewrite IH; repeat f_equal.
      rewrite (eq_nat_pirr H' eq_refl); auto.
    Qed.

    Let convert_sound A φ : fol_sem M φ A <-> fol_sem M' φ (convert A).
    Proof.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros φ.
      + simpl; tauto.
      + simpl.
        destruct (eq_nat_dec (ar_rels Σ' p) 1) as [ H | [] ]; auto.
        generalize H Hp; intros -> H'.
        unfold eq_rect_r; simpl; f_equal.
        rewrite (eq_nat_pirr H' eq_refl); simpl.
        rewrite !vec_map_map.
        apply fol_equiv_ext; f_equal.
        apply vec_pos_ext; intros j; rewrite !vec_pos_map; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

    Hypothesis (Xfin : finite_t X)
               (Mdec : fo_model_dec M)
               (A : fol_form Σ)
               (HA : fol_sem M phi A).

    Local Fact convert_soundness : fo_form_fin_dec_SAT (convert A).
    Proof using Xfin Mdec HA.
      exists X, M', Xfin.
      exists.
      { intros r v; simpl in *.
        destruct (eq_nat_dec (ar_rels Σ' r) 1); try tauto; apply Mdec. }
      exists phi; apply convert_sound; auto.
    Qed.

  End soundness.

  Section completeness.

    Variables (X : Type) (M' : fo_model Σ' X).

    Let M : fo_model Σ X.
    Proof.
      split.
      + intros []; simpl; intros v.
        apply (fom_syms M' f); rewrite Hf; trivial.
      + intros []; simpl; intros v.
        apply (fom_rels M' p); rewrite Hp; trivial.
    Defined.

    Let convert_t_complete t φ : fo_term_sem M φ t = fo_term_sem M' φ (convert_t t).
    Proof.
      induction t as [ i | [] v IH ]; simpl; auto.
      f_equal; generalize Hf; intros ->.
      unfold eq_rect_r; simpl; f_equal.
      apply vec_pos_ext; intros j; rewrite !vec_pos_map.
      rewrite IH; repeat f_equal.
    Qed.

    Let convert_complete A φ : fol_sem M φ A <-> fol_sem M' φ (convert A).
    Proof.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros φ.
      + simpl; tauto.
      + simpl.
        apply fol_equiv_ext; f_equal; generalize Hp; intros ->.
        unfold eq_rect_r; simpl; f_equal.
        apply vec_pos_ext; intros j; rewrite !vec_pos_map; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

    Hypothesis (Xfin : finite_t X)
               (M'dec : fo_model_dec M')
               (phi : nat -> X)
               (A : fol_form Σ)
               (HA : fol_sem M' phi (convert A)).

    Local Fact convert_completeness : fo_form_fin_dec_SAT A.
    Proof using Xfin M'dec HA.
      exists X, M, Xfin.
      exists.
      { intros [] v; apply M'dec. }
      exists phi; apply convert_complete; auto.
    Qed.

  End completeness.

  Theorem Σn1_Σ_correct A :
              fo_form_fin_dec_SAT A
          <-> fo_form_fin_dec_SAT (Σn1_Σ A).
  Proof.
    split.
    + intros (X & M & H1 & H2 & phi & H3).
      apply convert_soundness with X M phi; auto.
    + intros (X & M & H1 & H2 & phi & H3).
      apply convert_completeness with X M phi; auto.
  Qed.

End Sig_n1_Sig.


Require Import FP.Data.WeakSetoid.
Require Import FP.Classes.WeakEqv.
Require Import FP.Classes.Functor.
Require Import FP.Classes.Reflexive.
Require Import FP.Classes.Symmetric.
Require Import FP.Classes.Transitive.
Require Import FP.Data.Relation.
Require Import FP.Data.Function.
Require Import FP.Data.Function_Q.
Require Import FP.Data.RewriteState.
Require Import FP.Data.Tactic.

Import WeakSetoid.Notation.
Import WeakEqv.Notation.
Import Eqv.Notation.
Import RewriteState.Notation.

Class Applicative (t:WeakSetoid -> WeakSetoid) :=
  { fret :
      forall {A:WeakSetoid}, DD (A ⇨ t A)
  ; fapply :
      forall {A B:WeakSetoid}, DD (t (A ⇨ B) ⇨ (t A ⇨ t B))
  ; applicative_identity :
      forall (A:WeakSetoid),
      fapply ⊛ (fret ⊛ (id_Q (A:=A))) ≃ id_Q
  ; applicative_interchange :
      forall {A B:WeakSetoid} (fT:DD (t (A ⇨ B))) (x:DD A),
      fapply ⊛ fT ⊛ (fret ⊛ x) ≃ fapply ⊛ (fret ⊛ (apply_to_Q ⊛ x)) ⊛ fT
  ; applicative_homomorphism :
      forall {A B:WeakSetoid} (f:DD (A ⇨ B)) (x:DD A),
      fapply ⊛ (fret ⊛ f) ⊛ (fret ⊛ x) ≃ fret ⊛ (f ⊛ x)
  ; applicative_composition :
      forall {A B C:WeakSetoid} (g:DD (t (B ⇨ C))) (f:DD (t (A ⇨ B))),
      compose_Q ⊛ (fapply ⊛ g) ⊛ (fapply ⊛ f)
      ≃ fapply ⊛ (fapply ⊛ (fapply ⊛ (fret ⊛ compose_Q) ⊛ g) ⊛ f)
  }.
Ltac R_Applicative_identity :=
  match goal with
  | [ |- RewriteState (fapply ⊛ (fret ⊛ (@id_Q ?A))) _ _ ] => ReplaceBy (applicative_identity A)
  end.
Ltac R_Applicative_interchange :=
  match goal with
  | [ |- RewriteState (fapply ⊛ ?fT ⊛ (fret ⊛ ?x)) _ _ ] => ReplaceBy (applicative_interchange fT x)
  end.
Ltac R_Applicative_homomorphism :=
  match goal with
  | [ |- RewriteState (fapply ⊛ (fret ⊛ ?f) ⊛ (fret ⊛ ?x)) _ _ ] => ReplaceBy (applicative_homomorphism f x)
  end.
Ltac R_Applicative_composition :=
  match goal with
  | [ |- RewriteState (compose_Q ⊛ (fapply ⊛ ?g) ⊛ (fapply ⊛ ?f)) _ _ ] => ReplaceBy (applicative_composition g f)
  end.
Ltac R_Applicative := R_Applicative_identity || R_Applicative_homomorphism || R_Applicative_composition.

Section Applicative.
  Context {t:WeakSetoid -> WeakSetoid} `{! Applicative t }.

  Definition applicative_fmap {A B:WeakSetoid} : DD ((A ⇨ B) ⇨ t A ⇨ t B) :=
    compose_Q ⊛ fapply ⊛ fret.

  Local Instance Applicative_To_Functor : Functor t := { fmap := @applicative_fmap }.
  Proof.
    Local Ltac Hammer :=
      intros ; unfold applicative_fmap ;
      repeat Everywhere ltac:(R_fun_beta || R_Applicative).
    - Hammer.
    - Hammer.
  Defined.
End Applicative.


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

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

Print Assumptions carry.


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

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

Print Assumptions sub.


(*** *********************** ***)
(*** TOWERS OF HANOI EXAMPLE ***)
(*** *********************** ***)

(* James Power * James.Power@May.ie * http://www.cs.may.ie/~jpower/ *)
(* Dept. of Computer Science, NUI Maynooth, Co. Kildare, Ireland.   *)

(* This file is part of the Towers of Hanoi in ILL example
 * In it, we define the discs and the "smaller" relation
 * as well as some lemmas relating to quantification over disc-lists
 *
 * See also: discs.v, auxHanoi.v
 *)
Require Import discs auxHanoi.

(*************)
(*** POLES ***)
(*************)

Parameter Pole : Set.
Parameter onPole : Pole -> list Disc -> ILinProp.

Definition empty : Pole -> ILinProp :=
  fun p:Pole => onPole p (@nil Disc).

(*********************)
(*** THE ALGORITHM ***)
(*********************)

(* Assume we can move one disc *)
Axiom Txfr :
  forall (p1 p2:Pole)
  (f:Disc)(fs ts:list Disc), canTxfrTo f ts ->
  ([(onPole p1 (cons f fs))***(onPole p2 ts)]
|-
  ((onPole p1 fs) *** (onPole p2 (cons f ts)))).

(* Now prove that this scales up to n discs ... *)

(* The strategy is to use a Cut to introduce the intermediate states
 * then get to them using Move, Txfr and Move, in that order.
 * Each of these three applications has three sub-steps:
 *  a) Re-arrange the conjunction into the correct form
 *  b) Apply Txfr or Move, as appropriate
 *  c) Prove that the state-invariant predicates still hold true
 *)

Lemma Move
  (dTop dBot:list Disc)
  (p1 p2 p3:Pole) (d2 d3:list Disc):
  ordered dTop ->
  canMoveTo dTop dBot -> canMoveTo dTop d2 -> canMoveTo dTop d3 ->
  ([(onPole p1 (dTop++dBot))***(onPole p2 d2)***(onPole p3 d3)]
|-
  (onPole p1 dBot) *** (onPole p2 d2) *** (onPole p3 (dTop++d3))).
Proof.
  revert dBot p1 p2 p3 d2 d3.
  apply rev_ind with (l:=dTop). (* Reverse Induction on dTop *)

  (* Base Case: dTop is nil *)
  intros; simpl; apply Identity.

  (* Inductive Case: dTop is (cons d ds) *)
  intros d ds MOVE dBot p1 p2 p3 d2 d3 ORD.
  unfold canMoveTo; intros CM1 CM2 CM3.

  (* Mark out the "states" we're going to go through *)
  lincut (onPole p1 dBot)***(onPole p2 (ds++d2))***(onPole p3 ([d]++d3)).
  lincut (onPole p1 ([d]++dBot))***(onPole p2 (ds++d2))***(onPole p3 d3).

  (* Step 1: (Move ds from p1 to p2) *)
  rewrite <- (app_assoc ds). apply Swap23.
  apply MOVE;
    try (unfold canMoveTo; apply Forall_app with (l1:=ds) (l2:=[d]); assumption).
  apply OrdCat with (d1:=ds) (d2:=[d]); assumption.
  apply CanMoveApp.
  apply OrdMove; assumption.
  unfold canMoveTo; apply Forall_app with (l1:=ds) (l2:=[d]); assumption.

  (* Step 2: (Txfr d  from p1 to p3) *)
  apply Lose2. simpl.
  apply (Txfr p1 p3).
  apply Forall_elt with (a:=d) (l1:=ds) (l2:=nil); assumption.

  (* Step 3: (Move ds from p2 to p3) *)
  apply Swap21. rewrite <- app_assoc.
  apply MOVE;
    try (unfold canMoveTo; apply Forall_app with (l1:=ds) (l2:=[d]); assumption).
  apply OrdCat with (d1:=ds) (d2:=[d]); assumption.
  apply CanMoveApp.
  apply OrdMove; assumption.
  unfold canMoveTo; apply Forall_app with (l1:=ds) (l2:=[d]); assumption.
Qed.

Theorem Hanoi
  (p1 p2 p3:Pole) (ds:list Disc):
  ordered ds ->
  ([(onPole p1 ds) *** (empty p2) *** (empty p3)]
|-
  (empty p1) *** (empty p2) *** (onPole p3 ds)).
Proof.
intros. rewrite <- (app_nil_r ds). unfold empty.
apply Move; try apply CanMoveEmpty.
assumption.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(*i $Id: ZAddOrder.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export ZLt.

Module ZAddOrderPropFunct (Import Z : ZAxiomsSig').
Include ZOrderPropFunct Z.

(** Theorems that are either not valid on N or have different proofs
    on N and Z *)

Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_mono.
Qed.

Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
Qed.

Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
Qed.

Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0.
Proof.
intros n m H1 H2. rewrite <- (add_0_l 0). now apply add_le_mono.
Qed.

(** Sub and order *)

Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m.
Proof.
intros n m. stepl (0 + n < m - n + n) by symmetry; apply add_lt_mono_r.
rewrite add_0_l; now rewrite sub_simpl_r.
Qed.

Notation sub_pos := lt_0_sub (only parsing).

Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m.
Proof.
intros n m; stepl (0 + n <= m - n + n) by symmetry; apply add_le_mono_r.
rewrite add_0_l; now rewrite sub_simpl_r.
Qed.

Notation sub_nonneg := le_0_sub (only parsing).

Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m.
Proof.
intros n m. stepl (n - m + m < 0 + m) by symmetry; apply add_lt_mono_r.
rewrite add_0_l; now rewrite sub_simpl_r.
Qed.

Notation sub_neg := lt_sub_0 (only parsing).

Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m.
Proof.
intros n m. stepl (n - m + m <= 0 + m) by symmetry; apply add_le_mono_r.
rewrite add_0_l; now rewrite sub_simpl_r.
Qed.

Notation sub_nonpos := le_sub_0 (only parsing).

Theorem opp_lt_mono : forall n m, n < m <-> - m < - n.
Proof.
intros n m. stepr (m + - m < m + - n) by symmetry; apply add_lt_mono_l.
do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply lt_0_sub.
Qed.

Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n.
Proof.
intros n m. stepr (m + - m <= m + - n) by symmetry; apply add_le_mono_l.
do 2 rewrite add_opp_r. rewrite sub_diag. symmetry; apply le_0_sub.
Qed.

Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0.
Proof.
intro n; rewrite (opp_lt_mono n 0); now rewrite opp_0.
Qed.

Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n.
Proof.
intro n. rewrite (opp_lt_mono 0 n). now rewrite opp_0.
Qed.

Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0.
Proof.
intro n; rewrite (opp_le_mono n 0); now rewrite opp_0.
Qed.

Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n.
Proof.
intro n. rewrite (opp_le_mono 0 n). now rewrite opp_0.
Qed.

Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n.
Proof.
intros n m p. do 2 rewrite <- add_opp_r. rewrite <- add_lt_mono_l.
apply opp_lt_mono.
Qed.

Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p.
Proof.
intros n m p; do 2 rewrite <- add_opp_r; apply add_lt_mono_r.
Qed.

Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply lt_trans with (m - p);
[now apply -> sub_lt_mono_r | now apply -> sub_lt_mono_l].
Qed.

Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n.
Proof.
intros n m p; do 2 rewrite <- add_opp_r; rewrite <- add_le_mono_l;
apply opp_le_mono.
Qed.

Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p.
Proof.
intros n m p; do 2 rewrite <- add_opp_r; apply add_le_mono_r.
Qed.

Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q.
Proof.
intros n m p q H1 H2.
apply le_trans with (m - p);
[now apply -> sub_le_mono_r | now apply -> sub_le_mono_l].
Qed.

Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply lt_le_trans with (m - p);
[now apply -> sub_lt_mono_r | now apply -> sub_le_mono_l].
Qed.

Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply le_lt_trans with (m - p);
[now apply -> sub_le_mono_r | now apply -> sub_lt_mono_l].
Qed.

Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q.
Proof.
intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n));
[now apply -> opp_le_mono | now do 2 rewrite add_opp_r].
Qed.

Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q.
Proof.
intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n));
[now apply -> opp_lt_mono | now do 2 rewrite add_opp_r].
Qed.

Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q.
Proof.
intros n m p q H1 H2. apply (le_le_add_le (- m) (- n));
[now apply -> opp_le_mono | now do 2 rewrite add_opp_r].
Qed.

Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p.
Proof.
intros n m p. stepl (n + p - p < m - p) by symmetry; apply sub_lt_mono_r.
now rewrite add_simpl_r.
Qed.

Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p.
Proof.
intros n m p. stepl (n + p - p <= m - p) by symmetry; apply sub_le_mono_r.
now rewrite add_simpl_r.
Qed.

Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n.
Proof.
intros n m p. rewrite add_comm; apply lt_add_lt_sub_r.
Qed.

Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n.
Proof.
intros n m p. rewrite add_comm; apply le_add_le_sub_r.
Qed.

Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p.
Proof.
intros n m p. stepl (n - p + p < m + p) by symmetry; apply add_lt_mono_r.
now rewrite sub_simpl_r.
Qed.

Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p.
Proof.
intros n m p. stepl (n - p + p <= m + p) by symmetry; apply add_le_mono_r.
now rewrite sub_simpl_r.
Qed.

Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p.
Proof.
intros n m p. rewrite add_comm; apply lt_sub_lt_add_r.
Qed.

Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p.
Proof.
intros n m p. rewrite add_comm; apply le_sub_le_add_r.
Qed.

Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p.
Proof.
intros n m p q. rewrite lt_sub_lt_add_l. rewrite add_sub_assoc.
now rewrite <- lt_add_lt_sub_r.
Qed.

Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p.
Proof.
intros n m p q. rewrite le_sub_le_add_l. rewrite add_sub_assoc.
now rewrite <- le_add_le_sub_r.
Qed.

Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n.
Proof.
intros n m. stepr (n - m < n - 0) by now rewrite sub_0_r. apply sub_lt_mono_l.
Qed.

Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n.
Proof.
intros n m. stepr (n - m <= n - 0) by now rewrite sub_0_r. apply sub_le_mono_l.
Qed.

Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p.
Proof.
intros n m p q H. rewrite lt_sub_lt_add in H. now apply add_lt_cases.
Qed.

Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p.
Proof.
intros n m p q H. rewrite le_sub_le_add in H. now apply add_le_cases.
Qed.

Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m.
Proof.
intros n m H; rewrite <- add_opp_r in H.
setoid_replace (0 < m) with (- m < 0) using relation iff by (symmetry; apply opp_neg_pos).
now apply add_neg_cases.
Qed.

Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0.
Proof.
intros n m H; rewrite <- add_opp_r in H.
setoid_replace (m < 0) with (0 < - m) using relation iff by (symmetry; apply opp_pos_neg).
now apply add_pos_cases.
Qed.

Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m.
Proof.
intros n m H; rewrite <- add_opp_r in H.
setoid_replace (0 <= m) with (- m <= 0) using relation iff by (symmetry; apply opp_nonpos_nonneg).
now apply add_nonpos_cases.
Qed.

Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0.
Proof.
intros n m H; rewrite <- add_opp_r in H.
setoid_replace (m <= 0) with (0 <= - m) using relation iff by (symmetry; apply opp_nonneg_nonpos).
now apply add_nonneg_cases.
Qed.

Section PosNeg.

Variable P : Z.t -> Prop.
Hypothesis P_wd : Proper (Z.eq ==> iff) P.

Theorem zero_pos_neg :
  P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n.
Proof.
intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]].
apply <- opp_pos_neg in H3. apply H2 in H3. destruct H3 as [_ H3].
now rewrite opp_involutive in H3.
now rewrite H3.
apply H2 in H3; now destruct H3.
Qed.

End PosNeg.

Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg).

End ZAddOrderPropFunct.


(* DEC 1.0 language specification.
   Paolo Torrini and David Nowak,
   Universite' Lille-1 - CRIStAL-CNRS
*)

Require Import List.

Import ListNotations.

(** * DEC 1.0 auxiliary library *)

(** Auxiliary definitions and type classes *)

(* *)

(** Decidable equality class *)

Class DEq (K: Type) : Type := {
   dEq : forall x y: K, {x = y} + {x <> y}
}.

(** Admissible value type class *)

Class ValTyp (T: Type) : Prop.

(** Pip state class *)

Class PState (W: Type) : Type := {

   loc_pi : forall (T: Type) (p1 p2: ValTyp T), p1 = p2;

   b_init : W ;
}.

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

(** Environment type *)

Definition Envr (K V: Type) : Type := list (K * V).

Definition emptyE {K V: Type}: Envr K V := nil.

Definition overrideE {K V: Type}
    (f1 f2: Envr K V) : Envr K V := app f1 f2.

Definition updateE {K V: Type} (g: Envr K V) (z: K) (t: V) :
    Envr K V := cons (z, t) g.

Definition singleE {K V: Type} (z: K) (t: V) :
   Envr K V := cons (z, t) emptyE.

Fixpoint findE {K V: Type} {h: DEq K} (m: Envr K V) (k: K) : option V :=
  match m with
     | nil => None
     | cons (k', x) ls => match (dEq k k') with
                            | left _ => Some x
                            | right _ => findE ls k
                            end
    end.

Inductive disjoint {K V: Type} {h: DEq K} (m1 m2: Envr K V) : Prop :=
   disjoint1 : (forall x: K, or (findE m1 x = None) (findE m2 x = None)) ->
                   disjoint m1 m2.

Inductive includeEnv {K V: Type} {h: DEq K} (m1 m2: Envr K V) : Prop :=
  includeEnv1 : (forall x: K, or (findE m1 x = None)
                                 (findE m1 x = findE m2 x)) ->
                   includeEnv m1 m2.

Inductive findEP {K V: Type} {h: DEq K} (m: Envr K V) (k: K) : V -> Prop :=
  FindEP : forall x: V, findE m k = Some x -> findEP m k x.

Inductive findEP2 {K V: Type} {h: DEq K} (m: Envr K V) (k: K) : V -> Prop :=
  FindEP2 : forall (v: V) (m0 m1: Envr K V),
            m = overrideE m0 (updateE m1 k v) ->
            findE m0 k = None ->
            findEP2 m k v.

Inductive findET {K V: Type} {h: DEq K} (m: Envr K V) (k: K) : V -> Type :=
  FindET : forall x: V, findE m k = Some x -> findET m k x.

Fixpoint interleave {V1 V2: Type} (ls1 : list V1) (ls2: list V2) :
                                                    list (V1 * V2) :=
  match ls1 with
    | nil => nil
    | cons x ts1 => match ls2 with
               | nil => nil
               | cons y ts2 => cons (x,y) (interleave ts1 ts2)
               end
  end.

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

(** Relations on environments and lists *)

Inductive MatchEnvsT {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Type) :
          Envr K V1 -> Envr K V2 -> Type :=
| MatchEnvs_NilT : MatchEnvsT rel nil nil
| MatchEnvs_ConsT : forall ls1 ls2 k v1 v2,
                     rel v1 v2 ->
                     MatchEnvsT rel ls1 ls2 ->
                     MatchEnvsT rel ((k,v1)::ls1) ((k,v2)::ls2).

Inductive MatchEnvs2BT {K V1 V2: Type} {h: DEq K} (rel: V1 -> V2 -> Type)
          (k: K) (v1: V1) (v2: V2) : Envr K V1 -> Envr K V2 -> Type :=
| MatchEnvs2B_splitT : forall ls5 ls6 ls1 ls2 ls3 ls4,
                     rel v1 v2 ->
                     MatchEnvsT rel ls1 ls2 ->
                     MatchEnvsT rel ls3 ls4 ->
                     findE ls2 k = None ->
                     ls5 = ls1 ++ ((k,v1)::ls3) ->
                     ls6 = ls2 ++ ((k,v2)::ls4) ->
            MatchEnvs2BT rel k v1 v2 ls5 ls6.

Inductive ForallT {A: Type} (P: A -> Type): list A -> Type :=
      | Forall_nilT : ForallT P nil
      | Forall_consT : forall x l, P x -> ForallT P l -> ForallT P (x::l).

Inductive Forall2T {A B : Type} (R: A -> B -> Type):
    list A -> list B -> Type :=
  | Forall2_nilT : Forall2T R nil nil
  | Forall2_consT : forall x y l l',
      R x y -> Forall2T R l l' -> Forall2T R (x::l) (y::l').


(** * Decidability and Enumerability *)

From FOL Require Export Prelim.

(* ** Definitions *)

Definition compl X p := fun x : X => ~ p x.
Definition decidable {X} (p : X -> Prop) := exists f, forall x, p x <-> f x = true.
Definition enumerable {X} (p : X -> Prop) := exists f, forall x, p x <-> exists n : nat, f n = Some x.

Definition discrete X := decidable (fun '(x,y) => x = y :> X).
Definition enumerable__T X := exists f : nat -> option X, forall x, exists n, f n = Some x.

(* *** more practical type-theoretic characterisations *)

Lemma dec_decidable' X p :
  (forall x : X, dec (p x)) -> { f : _ | forall x, p x <-> f x = true}.
Proof.
  intros d. exists (fun x => if d x then true else false). intros x. destruct (d x); firstorder congruence.
Qed.

Lemma decidable_iff X p :
  decidable p <-> inhabited (forall x : X, dec (p x)).
Proof.
  split.
  - intros [f]. econstructor. intros x. specialize (H x). destruct (f x); firstorder congruence.
  - intros [d]. eapply dec_decidable' in d as [f]. now exists f.
Qed.

Lemma discrete_iff X :
  discrete X <-> inhabited (eq_dec X).
Proof.
  split.
  - intros [] % decidable_iff. econstructor. intros x y; destruct (X0 (x,y)); firstorder.
  - intros [d]. eapply decidable_iff. econstructor. intros (x,y). eapply d.
Qed.

(* ** Facts *)

Lemma dec_compl X p :
  decidable p -> decidable (fun x : X => ~ p x).
Proof.
  intros [f]. exists (fun x => negb (f x)).
  intros. rewrite H. destruct (f x); split; cbn; congruence.
Qed.

Lemma dec_conj X p q :
  decidable p -> decidable q -> decidable (fun x : X => p x /\ q x).
Proof.
  intros [f] [g]. exists (fun x => f x && g x).
  intros. rewrite H, H0. destruct (f x), (g x); cbn; firstorder congruence.
Qed.

Lemma dec_disj X p q :
  decidable p -> decidable q -> decidable (fun x : X => p x \/ q x).
Proof.
  intros [f] [g]. exists (fun x => f x || g x).
  intros. rewrite H, H0. destruct (f x), (g x); cbn; firstorder congruence.
Qed.

Theorem dec_count_enum X (p : X -> Prop) :
  decidable p -> enumerable__T X -> enumerable p.
Proof.
  intros [d Hd] [c Hc].
  exists (fun n => match c n with Some x => if d x then Some x else None | None => None end).
  setoid_rewrite Hd. intros x. split; intros.
  - destruct (Hc x) as [n Hn]. exists n. now rewrite Hn, H.
  - destruct H as [n H]. destruct (c n) eqn:E.
    + destruct (d x0) eqn:E2; now inv H.
    + inv H.
Qed.

Theorem dec_count_enum' X (p : X -> Prop) :
  decidable p -> enumerable__T X -> enumerable (fun x => ~ p x).
Proof.
  intros ? % dec_compl ?. eapply dec_count_enum; eauto.
Qed.

(** ** Closure of enumerable types *)

Lemma enumerable_enumerable_T X :
  enumerable (fun _ : X => True) <-> enumerable__T X.
Proof.
  split.
  - intros [e He]. exists e. intros x. now eapply He.
  - intros [c Hc]. exists c. intros x. split; eauto.
Qed.

Definition cumulative {X} (L: nat -> list X) :=
  forall n, exists A, L (S n) = L n ++ A.
Hint Extern 0 (cumulative _) => intros ?; cbn; eauto : core.

Lemma cum_ge {X} (L: nat -> list X) n m :
  cumulative L -> m >= n -> exists A, L m = L n ++ A.
Proof.
  induction 2 as [|m _ IH].
  - exists nil. now rewrite app_nil_r.
  - destruct (H m) as (A&->), IH as [B ->].
    exists (B ++ A). now rewrite app_assoc.
Qed.

Lemma cum_ge' {X} (L: nat -> list X) x n m :
  cumulative L -> x el L n -> m >= n -> x el L m.
Proof.
  intros ? H [A ->] % (cum_ge (L := L)). apply in_app_iff. eauto. eauto.
Qed.

Definition enum {X} p (L: nat -> list X) :=
  cumulative L /\ forall x, p x <-> exists m, x el L m.

Section enumerable_enum.

  Variable X : Type.
  Variable p : X -> Prop.
  Variables (e : nat -> option X).

  Definition T_ (n : nat) : list X :=  match e n with Some x => [x] | None => [] end.

  Lemma count_enum' : exists L : nat -> list X, forall x, (exists n, e n = Some x) <-> (exists n, x el L n).
  Proof.
    exists T_. split; intros [n H].
    - exists n. unfold T_. rewrite H. eauto.
    - unfold T_ in *. destruct (e n) eqn:E. inv H. eauto. inv H0. inv H.
  Qed.

End enumerable_enum.

Lemma enum_to_cumulative X (p : X -> Prop) L :
  (forall x, p x <-> exists m : nat, x el L m) -> exists L, enum p L.
Proof.
  intros H. exists (fix L' n := match n with 0 => [] | S n => L' n ++ L n end).
  split.
  - eauto.
  - intros x. rewrite H. split; intros [m Hm].
    + exists (S m). eauto.
    + induction m; try now inv Hm.
      eapply in_app_iff in Hm as []; eauto.
Qed.

(** ** Enumerability of pairs of natural numbers *)

Class enumT X :=
  {
    L_T : nat -> list X;
    cum_T : cumulative L_T ;
    el_T : forall x, exists m, x el L_T m
  }.

Arguments L_T {_ _} _, _ {_} _.
Hint Immediate cum_T : core.

Lemma discrete_bool : discrete bool.
Proof.
  eapply discrete_iff. econstructor. exact _.
Qed.

Lemma discrete_nat : discrete nat.
Proof.
  eapply discrete_iff. econstructor. exact _.
Qed.

Lemma discrete_nat_nat : discrete (nat * nat).
Proof.
  eapply discrete_iff. econstructor. exact _.
Qed.

Instance enum_bool : enumT bool.
Proof.
  exists (fun n => [true; false]).
  - eauto.
  - intros b; exists 1; destruct b; cbn; eauto.
Qed.

Lemma count_bool :
  enumerable__T bool.
Proof.
  exists (fun n => match n with 0 => Some true | _ => Some false end).
  intros []. now exists 0. now exists 1.
Qed.

Instance enumT_nat : enumT nat.
Proof.
  exists (fix f n := match n with 0 => [0] | S n => f n ++ [S n] end).
  - intros ?; cbn; eauto.
  - intros n. exists n. destruct n; eauto.
Defined.

Lemma count_nat :
  enumerable__T nat.
Proof.
  exists Some. intros n. now exists n.
Qed.

Lemma T_nat_in n m : m <= n -> m el L_T nat n.
Proof.
  induction 1.
  - destruct m; cbn. tauto. apply in_app_iff. cbn. tauto.
  - cbn. apply in_app_iff. now left.
Qed.

Lemma T_nat_length n : length (L_T nat n) = S n.
Proof.
  induction n; cbn; try rewrite app_length. omega. cbn in *. omega.
Qed.

Section enumerable_prod.

  Variable X Y : Type.

  Section fixLs.

    Variables (L_X : enumT X).
    Variables (L_Y : enumT Y).

    Fixpoint T_prod (n : nat) : list (X * Y) :=
      match n
      with
      | 0 => [ (x,y) | (x,y) ∈ (L_T X 0 × L_T Y 0) ]
      | S n => T_prod n ++ [ (x,y) | (x,y) ∈ (L_T X n  × L_T Y n) ]
      end.

    Lemma T_prod_cum : cumulative T_prod.
    Proof.
      intros ?; cbn; eauto.
    Qed.

  End fixLs.

  Lemma T_prod_el LX LY (a : X * Y)  :
    exists n, a el T_prod LX LY n.
  Proof.
    destruct a. destruct (el_T x) as [m1], (el_T y) as [m2].
    exists (1 + m1 + m2). cbn. in_app 2.
    in_collect (x,y); eapply cum_ge'; eauto; omega.
  Qed.

  Global Instance prod_enumerable (LX : enumT X) (LY : enumT Y) : enumT (X * Y).
  Proof.
    exists (T_prod LX LY).
    - apply T_prod_cum.
    - apply T_prod_el.
  Defined.

End enumerable_prod.

Lemma C_exhaustive n m : (n,m) el L_T (1 + n + m).
Proof.
  cbn. in_app 2. in_collect (n, m); apply T_nat_in; omega.
Qed.

Lemma C_longenough n : length (L_T (nat * nat) n) > n.
Proof.
  induction n; cbn.
  - omega.
  - rewrite app_length, map_length, prod_length, T_nat_length. cbn in *. remember (n + n * S n) as k. omega.
Qed.

Definition R_nat_nat n : option (nat * nat) := nthe n (L_T n).

Lemma pairs_retract :  forall p, exists n, R_nat_nat n = Some p.
Proof.
  intros [n m].
  unfold R_nat_nat. destruct(pos (fun x y => Dec (x = y)) (n,m) (L_T (1 + n + m))) as [ k | ] eqn:A.
  exists k. destruct (nthe k (L_T k)) eqn:B.
  - eapply pos_nthe in A.
    destruct (le_lt_dec k (1 + n + m)) as [D | ?].
    + destruct (cum_ge (@cum_T (nat * nat) _) D) as [B' HB]. rewrite HB in A.
      rewrite (nthe_app_l _ B) in A. now injection A.
    + assert (1 + n + m <= k) as D by omega.
      destruct (cum_ge (@cum_T (nat * nat) _) D) as [B' HB]. rewrite HB in B.
      rewrite (nthe_app_l  _ A) in B. now injection B.
  - exfalso. edestruct nthe_length. 2:{ rewrite e in B. inv B. } eapply C_longenough.
  - exfalso. destruct (el_pos (fun x y => Dec (x = y)) (C_exhaustive n m)) as [k H]. congruence.
Qed.

Lemma enumerable_nat_nat : enumerable__T (nat * nat).
Proof.
  exists R_nat_nat. eapply pairs_retract.
Qed.

Section enum_enumerable.

  Context X L p { enum_X : @enum X p L }.

  Definition ofNat n := match R_nat_nat n with Some (n, m) => nthe n ((L m)) | None => None end.

  Lemma enum_count : enumerable p.
  Proof.
    exists ofNat. unfold R_nat_nat. destruct enum_X as [CX HX].
    intros. rewrite HX.
    - split; intros [n].
      + eapply In_nth_error in H as [m].
        destruct (pairs_retract (m, n)) as [k]. exists k. unfold ofNat. now rewrite H0.
      + unfold ofNat in *. destruct R_nat_nat as [ [] | ].
        eapply nth_error_In in H. eauto. inv H.
  Defined.

End enum_enumerable.

(** ** Discrete types are closed under ... *)

Lemma discrete_prod X Y : discrete X -> discrete Y -> discrete (X * Y).
Proof.
  intros [d1] % discrete_iff [d2] % discrete_iff.
  eapply discrete_iff. eauto.
Qed.

Lemma discrete_sum X Y : discrete X -> discrete Y -> discrete (X + Y).
Proof.
  intros [d1] % discrete_iff [d2] % discrete_iff.
  eapply discrete_iff. eauto.
Qed.

Lemma discrete_option X : discrete X -> discrete (option X).
Proof.
  intros [d1] % discrete_iff. eapply discrete_iff. eauto.
Qed.

Lemma discrete_list X : discrete X -> discrete (list X).
Proof.
  intros [d1] % discrete_iff. eapply discrete_iff. eauto.
Qed.

(** ** Enumerable types are closed under ... *)

Lemma enumerable_enum X p :
  (exists L, enum p L) <-> @enumerable X p.
Proof.
  split.
  - intros [L]. eapply enum_count; eauto.
  - intros [f]. destruct count_enum' with (e := f) as (L & ?).
    eapply enum_to_cumulative. intros. now rewrite <- H0, H.
Qed.

Lemma enum_enumT X :
  enumerable__T X <-> inhabited (enumT X).
Proof.
  rewrite <- enumerable_enumerable_T, <-  enumerable_enum. split.
  - intros [L [] ]. econstructor. unshelve econstructor. exact L. all: firstorder.
  - intros [ [] ]. exists L_T0. firstorder.
Qed.

Lemma enumerable__T_prod X Y : enumerable__T X -> enumerable__T Y -> enumerable__T (X * Y).
Proof.
  intros [LX] % enum_enumT [LY] % enum_enumT.
  eapply enum_enumT. econstructor.
  exact _.
Qed.

Lemma enumerable__T_sum X Y : enumerable__T X -> enumerable__T Y -> enumerable__T (X + Y).
Proof.
  intros [LX] % enum_enumT [LY] % enum_enumT.
  eapply enum_enumT. econstructor.
  exists (fix f n := match n with 0 => [] | S n => f n ++ [ inl x | x ∈ L_T X n ] ++ [inr y | y ∈ L_T Y n] end).
  - eauto.
  - intros [].
    + destruct (el_T x) as [m]. exists (1 + m).
      cbn. in_app 2. in_collect x. eauto.
    + destruct (el_T y) as [m]. exists (1 + m).
      cbn. in_app 3. in_collect y. eauto.
Qed.

Lemma enumerable__T_option X : enumerable__T X -> enumerable__T (option X).
Proof.
  intros [f]. exists (fun n => match n with 0 => Some None | S n => Some (f n) end).
  intros [].
  - destruct (H x) as [n]. exists (S n). congruence.
  - now exists 0.
Qed.

Section enumerable_list.

  Variable X : Type.

  Section fixL.

    Variables (LX : enumT X).

    Fixpoint T_list (n : nat) : list (list X) :=
      match n
      with
      | 0 => [ [] ]
      | S n => T_list n ++ [ x :: L | (x,L) ∈ (L_T X n × T_list n) ]
      end.

    Lemma T_list_cum : cumulative T_list.
    Proof.
      intros ?; cbn; eauto.
    Qed.

  End fixL.

  Lemma T_list_el LX l :
    exists n, l el T_list LX n.
  Proof.
    induction l.
    - exists 0. cbn. eauto.
    - destruct IHl as [n IH].
      destruct (el_T a) as [m ?].
      exists (1 + n + m). cbn. intros. in_app 2.
      in_collect (a,l).
      all: eapply cum_ge'; eauto using T_list_cum; omega.
  Qed.

  Global Instance enumerable_list (LX : enumT X) : enumT (list X).
  Proof.
    exists (T_list LX). apply T_list_cum. apply T_list_el.
  Defined.

End enumerable_list.

Lemma enumerable__T_list X : enumerable__T X -> enumerable__T (list X).
Proof.
  intros [LX] % enum_enumT. eapply enum_enumT. econstructor.
  exact _.
Qed.

(** ** Enumerable predicates are closed under ... *)

Lemma enumerable_disj X (p q : X -> Prop) :
  enumerable p -> enumerable q -> enumerable (fun x => p x \/ q x).
Proof.
  intros [Lp] % enumerable_enum [Lq] % enumerable_enum.
  eapply enumerable_enum.
  exists (fix f n := match n with 0 => [] | S n => f n ++ [ x | x ∈ Lp n] ++ [ y | y ∈ Lq n] end).
  econstructor.
  - eauto.
  - intros. split.
    + intros [].
      * eapply H in H1 as [m]. exists (1 + m). cbn. in_app 2. in_collect x. eauto.
      * eapply H0 in H1 as [m]. exists (1 + m). cbn. in_app 3. in_collect x. eauto.
    + intros [m]. induction m.
      * inv H1.
      * inv_collect; firstorder.
Qed.

Lemma enumerable_conj X (p q : X -> Prop) :
  discrete X -> enumerable p -> enumerable q -> enumerable (fun x => p x /\ q x).
Proof.
  intros [] % discrete_iff [Lp] % enumerable_enum [Lq] % enumerable_enum.
  eapply enumerable_enum.
  exists (fix f n := match n with 0 => [] | S n => f n ++ [ x | x ∈ Lp n, x el Lq n] end).
  econstructor.
  - eauto.
  - intros. split.
    + intros []. eapply H in H1 as [m1]. eapply H0 in H2 as [m2].
      exists (1 + m1 + m2). cbn. in_app 2. in_collect x.
      eapply cum_ge'; eauto. firstorder. omega.
      eapply cum_ge'; eauto. firstorder. omega.
    + intros [m]. induction m.
      * inv H1.
      * inv_collect; firstorder.
Qed.

Lemma projection X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun x => exists y, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some x | None => None end).
  intros; split.
  - intros [y ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inv H0.
    exists y. eapply H. eauto.
Qed.

Lemma projection' X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun y => exists x, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some y | None => None end).
  intros y; split.
  - intros [x ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inv H0.
    exists x. eapply H. eauto.
Qed.


Add LoadPath "D:\sfsol".
Require Export 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.

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

(* {a}{b}{c,h}{d}{e}{f,i}{g} *)

Theorem aequiv_example:
  aequiv (AMinus (AId X) (AId X)) (ANum 0).
Proof.
  unfold aequiv.
  intros.
  unfold aeval.
  induction (st X); simpl; try reflexivity; try assumption.
  Qed.

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

Theorem skip_left: forall c,
  cequiv
     (SKIP;; c)
     c.
Proof.
  (* WORKED IN CLASS *)
  intros c st st'.
  split; intros H.
  Case "->".
    inversion H. subst.
    inversion H2. subst.
    assumption.
  Case "<-".
    apply E_Seq with st.
    apply E_Skip.
    assumption.
Qed.

Theorem skip_right: forall c,
  cequiv
    (c;; SKIP)
    c.
Proof.
  intros c st st'.
  split; intros.
    inversion H. inversion H5.
    rewrite H8 in H2. auto.
    apply E_Seq with st'. auto.
    apply E_Skip.
    Qed.

Theorem IFB_true_simple: forall c1 c2,
  cequiv
    (IFB BTrue THEN c1 ELSE c2 FI)
    c1.
Proof.
  intros c1 c2 st st'.
  split; intros H.
  inversion H; try inversion H5; try auto.
  apply E_IfTrue; auto.
  Qed.

Theorem IFB_true: forall b c1 c2,
     bequiv b BTrue ->
     cequiv
       (IFB b THEN c1 ELSE c2 FI)
       c1.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  Case "->".
    inversion H; subst.
    SCase "b evaluates to true".
      assumption.
    SCase "b evaluates to false (contradiction)".
      rewrite Hb in H5.
      inversion H5.
  Case "<-".
    apply E_IfTrue; try assumption.
    rewrite Hb. reflexivity. Qed.

Theorem IFB_false: forall b c1 c2,
  bequiv b BFalse ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.
Proof.
  intros b c1 c2 Hb.
  split; intros H.
  inversion H; subst.
    rewrite Hb in H5. inversion H5.
    auto.
    apply E_IfFalse; try rewrite Hb; auto.
  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.
  intros b e1 e2; split; intros H; inversion H; subst.
    apply E_IfFalse; simpl; try rewrite H5; try auto.
    apply E_IfTrue; simpl; try rewrite H5; try auto.
    apply E_IfFalse; inversion H5; destruct (beval st b); inversion H1; auto.
    apply E_IfTrue; inversion H5; destruct (beval st b); inversion H1; auto.
  Qed.

Theorem WHILE_false : forall b c,
     bequiv b BFalse ->
     cequiv
       (WHILE b DO c END)
       SKIP.
Proof.
  intros b c Hb st st'.
  split; intros H.
  inversion H; subst; try apply E_Skip; rewrite Hb in H2; inversion H2.
  inversion H; apply E_WhileEnd; rewrite Hb; auto.
  Qed.

Lemma WHILE_true_nonterm : forall b c st st',
     bequiv b BTrue ->
     ~( (WHILE b DO c END) / st || st' ).
Proof.
  (* WORKED IN CLASS *)
  intros b c st st' Hb.
  intros H.
  remember (WHILE b DO c END) as cw eqn:Heqcw.
  ceval_cases (induction H) Case;
    (* Most rules don't apply, and we can rule them out
       by inversion *)
    inversion Heqcw; subst; clear Heqcw.
  (* The two interesting cases are the ones for WHILE loops: *)
  Case "E_WhileEnd". (* contradictory -- b is always true! *)
    unfold bequiv in Hb.
    (* rewrite is able to instantiate the quantifier in st *)
    rewrite Hb in H. inversion H.
  Case "E_WhileLoop". (* immediate from the IH *)
    apply IHceval2. reflexivity. Qed.

Theorem WHILE_true: forall b c,
     bequiv b BTrue ->
     cequiv
       (WHILE b DO c END)
       (WHILE BTrue DO SKIP END).
Proof.
  intros b c Hb st st'.
  split; intros. assert (~(WHILE b DO c END) / st || st').
    apply WHILE_true_nonterm. auto.
    apply H0 in H. inversion H.
  assert (~(WHILE BTrue DO SKIP END) / st || st').
    apply loop_stop. auto.
    apply H0 in H. inversion H.
  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.
  intros b c st st'.
  split; intros H.
  inversion H; subst.
    apply E_IfFalse; auto; try apply E_Skip.
    apply E_IfTrue; auto; try apply E_Seq with st'0; auto.
  inversion H; subst; inversion H6; subst.
    apply E_WhileLoop with st'0; auto.
    apply E_WhileEnd. auto.
  Qed.

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

Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y},
    (forall (x: X), f x = g x) -> f = g.

Theorem identity_assignment : forall (X:id),
  cequiv
    (X ::= AId X)
    SKIP.
Proof.
   intros. split; intro H.
     Case "->".
       inversion H; subst. simpl.
       replace (update st X (st X)) with st.
       constructor.
       apply functional_extensionality. intro.
       rewrite update_same; reflexivity.
     Case "<-".
       inversion H; subst.
       assert (st' = (update st' X (st' X))).
          apply functional_extensionality. intro.
          rewrite update_same; reflexivity.
       rewrite H0 at 2.
       constructor. reflexivity.
Qed.

Theorem assign_aequiv : forall X e,
  aequiv (AId X) e ->
  cequiv SKIP (X ::= e).
Proof.
  intros X e He st st';
  split; intros H.
    inversion H. replace ((X ::= e) / st' || st') with ((X ::= e) / st' || update st' X (aeval st' e)).
    constructor; auto.
    replace (update st' X (aeval st' e)) with st'.
    auto. apply functional_extensionality. intro.
    rewrite update_same; auto; apply He.
  inversion H; subst.
  replace (update st X (aeval st e)) with st.
    constructor.
    apply functional_extensionality. intro.
    rewrite update_same; auto.
    apply He.
  Qed.

Lemma refl_aequiv : forall (a : aexp), aequiv a a.
Proof.
  intros a st. auto. Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
  aequiv a1 a2 -> aequiv a2 a1.
Proof.
  intros a1 a2 H st. symmetry. apply H. Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
  aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
  intros a1 a2 a3 H1 H2 st. rewrite H1. auto. Qed.

Lemma refl_bequiv : forall (b : bexp), bequiv b b.
Proof.
  intros b st. auto. Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
  bequiv b1 b2 -> bequiv b2 b1.
Proof.
  intros b1 b2 H st. auto. Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
  bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
  intros b1 b2 b3 H1 H2 st. rewrite H1. auto. Qed.

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof.
  intros c st; split; intros H; auto. Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  intros c1 c2 H st; split; apply H. Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
  (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
  intros P1 P2 P3 H1 H2; split.
    rewrite H1. apply H2.
    rewrite <- H2. apply H1.
    Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  intros c1 c2 c3 H1 H2 st; split; intros H.
  apply H2. apply H1. apply H.
  apply H1. apply H2. apply H.
  Qed.

Theorem CAss_congruence : forall i a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss i a1) (CAss i a1').
Proof.
  intros; split; intro;
  inversion H0; subst; apply E_Ass; rewrite H; auto.
  Qed.

Theorem CWhile_congruence : forall b1 b1' c1 c1',
  bequiv b1 b1' -> cequiv c1 c1' ->
  cequiv (WHILE b1 DO c1 END) (WHILE b1' DO c1' END).
Proof.
  (* WORKED IN CLASS *)
  unfold bequiv,cequiv.
  intros b1 b1' c1 c1' Hb1e Hc1e st st'.
  split; intros Hce.
  Case "->".
    remember (WHILE b1 DO c1 END) as cwhile eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    SCase "E_WhileEnd".
      apply E_WhileEnd. rewrite <- Hb1e. apply H.
    SCase "E_WhileLoop".
      apply E_WhileLoop with (st' := st').
      SSCase "show loop runs". rewrite <- Hb1e. apply H.
      SSCase "body execution".
        apply (Hc1e st st'). apply Hce1.
      SSCase "subsequent loop execution".
        apply IHHce2. reflexivity.
  Case "<-".
    remember (WHILE b1' DO c1' END) as c'while eqn:Heqc'while.
    induction Hce; inversion Heqc'while; subst.
    SCase "E_WhileEnd".
      apply E_WhileEnd. rewrite -> Hb1e. apply H.
    SCase "E_WhileLoop".
      apply E_WhileLoop with (st' := st').
      SSCase "show loop runs". rewrite -> Hb1e. apply H.
      SSCase "body execution".
        apply (Hc1e st st'). apply Hce1.
      SSCase "subsequent loop execution".
        apply IHHce2. reflexivity. Qed.

Theorem CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').
Proof.
  intros c1 c1' c2 c2' H1 H2 st st';
  split; intros H; inversion H; subst;
  apply E_Seq with st'0; try apply H1; try apply H2; auto.
  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.
  intros; split; intros Htmp; inversion Htmp; subst.
  rewrite H in H7; apply E_IfTrue; auto; apply H0; auto.
  rewrite H in H7; apply E_IfFalse; auto; apply H1; auto.
  rewrite <- H in H7; apply E_IfTrue; auto; apply H0; auto.
  rewrite <- H in H7; apply E_IfFalse; auto; apply H1; auto.
  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 ble_nat 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 =>
      CAss 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.
  intros a st.
  induction a; try auto; simpl;
  remember (fold_constants_aexp a1) as af1;
  destruct af1;
  remember (fold_constants_aexp a2) as af2;
  destruct af2; rewrite IHa1; rewrite IHa2; auto.
  Qed.

Theorem fold_constants_bexp_sound:
  btrans_sound fold_constants_bexp.
Proof.
  unfold btrans_sound. intros b. unfold bequiv. intros st.
  bexp_cases (induction b) Case;
    (* BTrue and BFalse are immediate *)
    try reflexivity.
  Case "BEq".
    (* Doing induction when there are a lot of constructors makes
       specifying variable names a chore, but Coq doesn't always
       choose nice variable names.  We can rename entries in the
       context with the rename tactic: rename a into a1 will
       change a to a1 in the current goal and context. *)
    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') by
       (subst a1'; rewrite <- fold_constants_aexp_sound; reflexivity).
    replace (aeval st a2) with (aeval st a2') by
       (subst a2'; rewrite <- fold_constants_aexp_sound; reflexivity).
    destruct a1'; destruct a2'; try reflexivity.
      (* The only interesting case is when both a1 and a2
         become constants after folding *)
      simpl. destruct (beq_nat n n0); reflexivity.
  Case "BLe".
    simpl.
    rewrite -> fold_constants_aexp_sound.
    replace (aeval st a0) with (aeval st (fold_constants_aexp a0)).
    remember (fold_constants_aexp a) as af;
    remember (fold_constants_aexp a0) as af0;
    destruct af; simpl; try auto.
    destruct af0; simpl; try auto.
    destruct (ble_nat n n0); auto.
    rewrite <- fold_constants_aexp_sound. auto.
  Case "BNot".
    simpl. remember (fold_constants_bexp b) as b' eqn:Heqb'.
    rewrite IHb.
    destruct b'; reflexivity.
  Case "BAnd".
    simpl.
    remember (fold_constants_bexp b1) as b1' eqn:Heqb1'.
    remember (fold_constants_bexp b2) as b2' eqn:Heqb2'.
    rewrite IHb1. rewrite IHb2.
    destruct b1'; destruct b2'; reflexivity. Qed.

Theorem fold_constants_com_sound :
  ctrans_sound fold_constants_com.
Proof.
  unfold ctrans_sound. intros c.
  com_cases (induction c) Case; simpl.
  Case "SKIP". apply refl_cequiv.
  Case "::=". apply CAss_congruence. apply fold_constants_aexp_sound.
  Case ";;". apply CSeq_congruence; assumption.
  Case "IFB".
    assert (bequiv b (fold_constants_bexp b)).
      SCase "Pf of assertion". apply fold_constants_bexp_sound.
    destruct (fold_constants_bexp b) eqn:Heqb;
      (* If the optimization doesn't eliminate the if, then the result
         is easy to prove from the IH and fold_constants_bexp_sound *)
      try (apply CIf_congruence; assumption).
    SCase "b always true".
      apply trans_cequiv with c1; try assumption.
      apply IFB_true; assumption.
    SCase "b always false".
      apply trans_cequiv with c2; try assumption.
      apply IFB_false; assumption.
  Case "WHILE".
    assert (bequiv b (fold_constants_bexp b)).
      apply fold_constants_bexp_sound.
    destruct (fold_constants_bexp b) eqn:Heqb.
      apply WHILE_true; auto.
      apply WHILE_false; auto.
      try apply CWhile_congruence; auto.
      try apply CWhile_congruence; auto.
      try apply CWhile_congruence; auto.
      try apply CWhile_congruence; auto.
  Qed.

Fixpoint optimize_0plus_aexp (e:aexp) : aexp :=
      match e with
      | ANum n =>
          ANum n
      | AId i => AId i
      | 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.

Fixpoint optimize_0plus_bexp (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BLe a1 a2 => BLe (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BNot b1 => BNot (optimize_0plus_bexp b1)
  | BAnd b1 b2 => BAnd (optimize_0plus_bexp b1) (optimize_0plus_bexp b2)
  end.

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

Theorem optimize_0plus_aexp_sound :
  atrans_sound optimize_0plus_aexp.
Proof.
  intros a st.
  induction a; simpl; try auto.
  destruct a1 eqn:Heqa1; try simpl; auto.
  destruct n; simpl; auto.
  Qed.

Theorem optimize_0plus_bexp_sound:
  btrans_sound optimize_0plus_bexp.
Proof.
  intros b st.
  induction b; try auto;
  simpl; try rewrite <- optimize_0plus_aexp_sound;
  try rewrite <- optimize_0plus_aexp_sound; auto.
  rewrite IHb; auto.
  rewrite IHb1; rewrite IHb2; auto.
  Qed.

Theorem optimize_0plus_com_sound :
  ctrans_sound optimize_0plus_com.
Proof.
  unfold ctrans_sound. intros c.
  induction c; simpl.
    split; auto.
    apply CAss_congruence. apply optimize_0plus_aexp_sound.
    apply CSeq_congruence; auto.
    apply CIf_congruence; auto; try apply optimize_0plus_bexp_sound.
    apply CWhile_congruence; auto; try apply optimize_0plus_bexp_sound.
  Qed.

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

Example optexam1 :
  optimizer_0plus_const_com
    (* Original program: *)
    (X ::= APlus (ANum 4) (ANum 5);;
     X ::= APlus (ANum 0) (AId X);;
     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;;
     X ::= AId X;;
     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 optimizer_0plus_const_com_sound :
  ctrans_sound optimizer_0plus_const_com.
Proof.
  unfold ctrans_sound.
  intro.
  unfold optimizer_0plus_const_com.
  split.
  intro.
  apply fold_constants_com_sound in H.
  apply optimize_0plus_com_sound in H.
  auto.
  intros.
  apply fold_constants_com_sound.
  apply optimize_0plus_com_sound.
  auto.
  Qed.

Fixpoint subst_aexp (i : id) (u : aexp) (a : aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | AId i' => if eq_id_dec 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 subst_equiv_property.
  intros Contra.

  (* Here is the counterexample: assuming that subst_equiv_property
     holds allows us to prove that these two programs are
     equivalent... *)
  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 Contra).

  (* ... allows us to show that the command c2 can terminate
     in two different final states:
        st1 = {X |-> 1, Y |-> 1}
        st2 = {X |-> 1, Y |-> 2}. *)
  remember (update (update empty_state X 1) Y 1) as st1.
  remember (update (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' := (update empty_state X 1));
       apply E_Ass; reflexivity).
  apply H in H1.

  (* Finally, we use the fact that evaluation is deterministic
     to obtain a contradiction. *)
  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 (update st i ni) a = aeval st a.
Proof.
  intros.
  induction a; inversion H; simpl; try auto; try rewrite IHa1; try rewrite IHa2; auto.
  apply neq_id. auto.
  Qed.

Definition 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).

Theorem subst_equiv :
  subst_equiv_property'.
Proof.
  intros i1 i2 a1 a2 H.
  split; intro; inversion H0; subst.
  apply E_Seq with st'0; auto. clear H0.
  generalize dependent st'.
  induction a2. intros. simpl. auto.
  intros; inversion H6; subst; simpl; try apply E_Ass; auto; simpl; try rewrite IHa2_1.
  destruct (eq_id_dec i1 i) eqn:eqid; auto.
  inversion H3; subst.
  simpl. rewrite aeval_weakening; auto. unfold update. rewrite eq_id. auto.
  intros. inversion H6; subst.
  assert((i2 ::= subst_aexp i1 a1 a2_1) / st'0
|| update st'0 i2 (aeval st'0 a2_1)). apply IHa2_1. constructor. auto.
  assert((i2 ::= subst_aexp i1 a1 a2_2) / st'0
|| update st'0 i2 (aeval st'0 a2_2)). apply IHa2_2. constructor. auto.
  simpl. apply E_Ass. simpl.
  assert(aeval st'0 (subst_aexp i1 a1 a2_1) = aeval st'0 a2_1).
  inversion H0. rewrite H7.
  assert (update st'0 i2 n i2 = update st'0 i2 (aeval st'0 a2_1) i2).
    rewrite H8; auto.
  rewrite update_eq in H9. rewrite update_eq in H9. auto.
  assert(aeval st'0 (subst_aexp i1 a1 a2_2) = aeval st'0 a2_2).
  inversion H1. rewrite H8.
  assert (update st'0 i2 n i2 = update st'0 i2 (aeval st'0 a2_2) i2).
    rewrite H9; auto.
  rewrite update_eq in H10. rewrite update_eq in H10. auto.
  rewrite H2. rewrite H4. auto.
  intros.
  assert((i2 ::= subst_aexp i1 a1 a2_1) / st'0
|| update st'0 i2 (aeval st'0 a2_1)). apply IHa2_1. constructor. auto.
  assert((i2 ::= subst_aexp i1 a1 a2_2) / st'0
|| update st'0 i2 (aeval st'0 a2_2)). apply IHa2_2. constructor. auto.
  inversion H6; subst. simpl. apply E_Ass. simpl.
  assert(aeval st'0 (subst_aexp i1 a1 a2_1) = aeval st'0 a2_1).
  inversion H0. rewrite H7.
  assert (update st'0 i2 n i2 = update st'0 i2 (aeval st'0 a2_1) i2).
    rewrite H8; auto.
  rewrite update_eq in H9. rewrite update_eq in H9. auto.
  assert(aeval st'0 (subst_aexp i1 a1 a2_2) = aeval st'0 a2_2).
  inversion H1. rewrite H8.
  assert (update st'0 i2 n i2 = update st'0 i2 (aeval st'0 a2_2) i2).
    rewrite H9; auto.
  rewrite update_eq in H10. rewrite update_eq in H10. auto.
  rewrite H2. rewrite H4. auto. intros.
  assert((i2 ::= subst_aexp i1 a1 a2_1) / st'0
|| update st'0 i2 (aeval st'0 a2_1)). apply IHa2_1. constructor. auto.
  assert((i2 ::= subst_aexp i1 a1 a2_2) / st'0
|| update st'0 i2 (aeval st'0 a2_2)). apply IHa2_2. constructor. auto.
  inversion H6; subst. simpl. apply E_Ass. simpl.
  assert(aeval st'0 (subst_aexp i1 a1 a2_1) = aeval st'0 a2_1).
  inversion H0. rewrite H7.
  assert (update st'0 i2 n i2 = update st'0 i2 (aeval st'0 a2_1) i2).
    rewrite H8; auto.
  rewrite update_eq in H9. rewrite update_eq in H9. auto.
  assert(aeval st'0 (subst_aexp i1 a1 a2_2) = aeval st'0 a2_2).
  inversion H1. rewrite H8.
  assert (update st'0 i2 n i2 = update st'0 i2 (aeval st'0 a2_2) i2).
    rewrite H9; auto.
  rewrite update_eq in H10. rewrite update_eq in H10. auto.
  rewrite H2. rewrite H4. auto. intros.
  apply E_Seq with st'0. auto.
  generalize dependent st'.
  induction a2; intros; inversion H6; subst; auto. destruct (eq_id_dec i1 i).
  apply E_Ass. rewrite <- e. inversion H3; subst.
  assert(aeval (update st i (aeval st a1)) a1 = aeval st a1).
  rewrite aeval_weakening; auto.
  rewrite H1. simpl. apply update_eq.
  apply E_Ass. auto.
  assert((i2 ::= a2_1) / st'0 || update st'0 i2
     (aeval st'0 (subst_aexp i1 a1 a2_1))).
  apply IHa2_1. apply E_Seq with st'0. auto. apply E_Ass. auto. apply E_Ass. auto.
  assert((i2 ::= a2_2) / st'0 || update st'0 i2
     (aeval st'0 (subst_aexp i1 a1 a2_2))).
  apply IHa2_2. apply E_Seq with st'0. auto. apply E_Ass. auto. apply E_Ass. auto.
  inversion H1; subst. inversion H2; subst. apply E_Ass. simpl.
  assert(aeval st'0 a2_1 = aeval st'0 (subst_aexp i1 a1 a2_1)).
    symmetry. rewrite <- update_eq with (X:=i2) (st:=st'0). symmetry.
    rewrite <- update_eq with (X:=i2) (st:=st'0). rewrite H9. auto.
  assert(aeval st'0 a2_2 = aeval st'0 (subst_aexp i1 a1 a2_2)).
    symmetry. rewrite <- update_eq with (X:=i2) (st:=st'0). symmetry.
    rewrite <- update_eq with (X:=i2) (st:=st'0). rewrite H10. auto.
  rewrite <- H4. rewrite <- H5. auto.
  assert((i2 ::= a2_1) / st'0 || update st'0 i2
     (aeval st'0 (subst_aexp i1 a1 a2_1))).
  apply IHa2_1. apply E_Seq with st'0. auto. apply E_Ass. auto. apply E_Ass. auto.
  assert((i2 ::= a2_2) / st'0 || update st'0 i2
     (aeval st'0 (subst_aexp i1 a1 a2_2))).
  apply IHa2_2. apply E_Seq with st'0. auto. apply E_Ass. auto. apply E_Ass. auto.
  inversion H1; subst. inversion H2; subst. apply E_Ass. simpl.
  assert(aeval st'0 a2_1 = aeval st'0 (subst_aexp i1 a1 a2_1)).
    symmetry. rewrite <- update_eq with (X:=i2) (st:=st'0). symmetry.
    rewrite <- update_eq with (X:=i2) (st:=st'0). rewrite H9. auto.
  assert(aeval st'0 a2_2 = aeval st'0 (subst_aexp i1 a1 a2_2)).
    symmetry. rewrite <- update_eq with (X:=i2) (st:=st'0). symmetry.
    rewrite <- update_eq with (X:=i2) (st:=st'0). rewrite H10. auto.
  rewrite <- H4. rewrite <- H5. auto.
  assert((i2 ::= a2_1) / st'0 || update st'0 i2
     (aeval st'0 (subst_aexp i1 a1 a2_1))).
  apply IHa2_1. apply E_Seq with st'0. auto. apply E_Ass. auto. apply E_Ass. auto.
  assert((i2 ::= a2_2) / st'0 || update st'0 i2
     (aeval st'0 (subst_aexp i1 a1 a2_2))).
  apply IHa2_2. apply E_Seq with st'0. auto. apply E_Ass. auto. apply E_Ass. auto.
  inversion H1; subst. inversion H2; subst. apply E_Ass. simpl.
  assert(aeval st'0 a2_1 = aeval st'0 (subst_aexp i1 a1 a2_1)).
    symmetry. rewrite <- update_eq with (X:=i2) (st:=st'0). symmetry.
    rewrite <- update_eq with (X:=i2) (st:=st'0). rewrite H9. auto.
  assert(aeval st'0 a2_2 = aeval st'0 (subst_aexp i1 a1 a2_2)).
    symmetry. rewrite <- update_eq with (X:=i2) (st:=st'0). symmetry.
    rewrite <- update_eq with (X:=i2) (st:=st'0). rewrite H10. auto.
  rewrite <- H4. rewrite <- H5. auto.
  Qed.

Theorem inequiv_exercise:
  ~ cequiv (WHILE BTrue DO SKIP END) SKIP.
Proof.
  intros contra.
  unfold cequiv in contra.
  assert(forall st: state, SKIP / st || st).
    intros. apply E_Skip.
  assert(forall st: state, (WHILE BTrue DO SKIP END) / st || st).
    intros; apply contra; apply H.
  assert(forall st: state, ~((WHILE BTrue DO SKIP END) / st || st)).
    intros. apply loop_never_stops.
  assert((WHILE BTrue DO SKIP END) / empty_state || empty_state -> False).
  apply H1. apply H2. apply H0.
  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.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";;"
  | Case_aux c "IFB" | Case_aux c "WHILE" | Case_aux c "HAVOC" ].

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).

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

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 || 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 (st : state) (n : nat) (X : id),
            (HAVOC X) / st || update st X n
  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_Havoc" ].

Example havoc_example1 : (HAVOC X) / empty_state || update empty_state X 0.
Proof.
  apply E_Havoc. Qed.

Example havoc_example2 :
  (SKIP;; HAVOC Z) / empty_state || update empty_state Z 42.
Proof.
  apply E_Seq with 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 update_swap: forall st X Y n n0,
  X<>Y->update (update st X n) Y n0 = update (update st Y n0) X n.
Proof.
  intros. apply functional_extensionality.
  intros. simpl.
  unfold update.
  destruct (eq_id_dec Y x); try auto.
  destruct (eq_id_dec X x); try auto; try subst.
  unfold not in H. assert (x=x).
  auto. apply H in H0. inversion H0.
  Qed.

Theorem pXY_cequiv_pYX :
  cequiv pXY pYX \/ ~cequiv pXY pYX.
Proof.
  apply or_introl.
  intros st st'; split; intros H;
  inversion H; subst; inversion H2; subst;
  inversion H5; subst;
  destruct (eq_id_dec X Y) eqn:eqid;
  inversion eqid; rewrite update_swap; auto.
  apply E_Seq with (update st Y n0);
    apply E_Havoc.
  apply E_Seq with (update st X n0);
    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.
  apply or_intror.
  unfold not.
  intro. unfold cequiv in H.
  assert(ptwice / empty_state || update (update empty_state X 0) Y (S 0)
    <-> pcopy / empty_state || update (update empty_state X 0) Y (S 0)).
  apply H. clear H.
  destruct (eq_id_dec X Y) eqn:eqid.
    inversion eqid.
  inversion H0 as [H1 H2].
  clear H0.
  assert(pcopy / empty_state || update (update empty_state X 0) Y 1).
  apply H1. apply E_Seq with (update empty_state X 0);
    apply E_Havoc.
  clear H1. clear H2.
  assert((HAVOC X) / empty_state || update empty_state X 0).
    apply E_Havoc.
  inversion H; subst. inversion H3; subst.
  inversion H6; subst. simpl in H7.
  destruct n0.
    assert(update (update empty_state X 0) Y (update empty_state X 0 X) Y = update (update empty_state X 0) Y 1 Y).
    rewrite H7. auto. rewrite update_eq in H1. rewrite update_eq in H1.
    rewrite update_eq in H1. inversion H1.
    assert(update (update empty_state X (S n0)) Y (update empty_state X (S n0) X) X = update (update empty_state X 0) Y 1 X).
    rewrite H7. auto. rewrite update_neq in H1; auto. rewrite update_eq in H1.
    rewrite update_neq in H1; auto. rewrite update_eq in H1.
    inversion H1.
  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.

Theorem p1_p2_equiv : cequiv p1 p2.
Proof.
  intros st st'; split; intros; unfold p2.
  unfold p1 in H.
  destruct (eq_id_dec X Y) eqn:eq; inversion eq; subst.
  inversion H; subst.
  apply E_WhileEnd. auto.
  remember (WHILE BNot (BEq (AId X) (ANum 0))
      DO HAVOC Y;; X ::= APlus (AId X) (ANum 1) END) as loopdef eqn:loop.
  assert (False).
  clear H3 H6 st'0.
  induction H; try inversion loop; subst.
  rewrite H in H2. inversion H2.
  apply IHceval2; try auto.
  clear loop IHceval1 IHceval2.
  inversion H0; subst. inversion H5; subst.
  inversion H8; subst. simpl.
  rewrite update_eq. rewrite update_neq; auto.
  simpl in H2.
  destruct (st X).
    inversion H2.
    simpl. auto.
  inversion H0.
  unfold p1; unfold p2 in H.
  remember (st X) as stx.
    destruct stx.
    inversion H; subst.
    apply E_WhileEnd. auto.
    simpl in H2. rewrite <- Heqstx in H2.
    simpl in H2. inversion H2.
    assert(False).
      remember (WHILE BNot (BEq (AId X) (ANum 0)) DO SKIP END)
        as loopdef eqn:loop.
      induction H; subst; try inversion loop.
      rewrite H1 in H. simpl in H. rewrite <- Heqstx in H.
      simpl in H. inversion H.
      apply IHceval2; try auto.
      rewrite H4 in H0.
      inversion H0. subst. auto.
      inversion H0.
  Qed.

Definition p3 : com :=
  Z ::= ANum 1;;
  WHILE (BNot (BEq (AId X) (ANum 0))) DO
    HAVOC X;;
    HAVOC Z
  END.

Definition p4 : com :=
  X ::= (ANum 0);;
  Z ::= (ANum 1).

Theorem p3_p4_inequiv : ~ cequiv p3 p4.
Proof.
  intro. unfold cequiv in H.
  assert(p3/update empty_state X 1||update (update (update (update empty_state X 1) Z 1) X 0) Z 0 <->
    p4/update empty_state X 1||update (update (update (update empty_state X 1) Z 1) X 0) Z 0).
  apply H. inversion H0 as [H1 H2].
  clear H H0 H2.
  assert(p3 / update empty_state X 1 || update (update (update (update empty_state X 1) Z 1) X 0) Z 0).
  apply E_Seq with (update (update empty_state X 1) Z 1).
    apply E_Ass. auto.
    apply E_WhileLoop with (update (update (update (update empty_state X 1) Z 1) X 0) Z 0).
    simpl. auto.
    apply E_Seq with (update (update (update empty_state X 1) Z 1) X 0);
      apply E_Havoc.
    apply E_WhileEnd. simpl. auto.
  apply H1 in H.
  inversion H; subst. inversion H3; subst; simpl in H3.
  simpl in H6. inversion H6; subst; simpl in H7.
  assert (update (update (update empty_state X 1) X 0) Z 1 Z=
     update (update (update (update empty_state X 1) Z 1) X 0) Z 0 Z).
  rewrite H7. auto.
  rewrite update_eq in H0. rewrite update_eq in H0.
  inversion H0.
  Qed.

Definition p5 : com :=
  WHILE (BNot (BEq (AId X) (ANum 1))) DO
    HAVOC X
  END.

Definition p6 : com :=
  X ::= ANum 1.

Theorem p5_p6_equiv : cequiv p5 p6.
Proof.
  intros st st'. unfold p5. unfold p6.
  split. intros.
  remember (WHILE BNot (BEq (AId X) (ANum 1))
      DO HAVOC X END) as loopdef eqn:loop.
  induction H; inversion loop; subst.
  inversion H.
  unfold negb in H1. destruct (beq_nat (st X) 1) eqn:stx.
  assert(st = update st X 1).
    apply functional_extensionality. intros.
    replace 1 with (st X). symmetry.
    apply update_same. auto.
    destruct (st X). inversion stx. destruct n.
    auto. inversion stx.
  assert((X ::= ANum 1) / st || update st X 1 -> (X ::= ANum 1) / st || st).
  rewrite <- H0. auto. apply H2. apply E_Ass. auto.
  inversion H1.
  assert((X ::= ANum 1) / st' || st'').
  apply IHceval2. auto. clear IHceval1 IHceval2.
  inversion H0; subst. inversion H2; subst. simpl.
  assert(update (update st X n) X 1 = update st X 1).
    apply functional_extensionality. intros.
    destruct (eq_id_dec X x) eqn:eqid; subst.
      apply update_eq.
      rewrite update_neq; auto.
      rewrite update_neq; auto.
      rewrite update_neq; auto.
    rewrite H3.
    apply E_Ass.
    auto.
  intro. inversion H; subst. simpl in H.
  remember (st X) as stx.
  destruct stx. apply E_WhileLoop with (update st X 1).
    simpl. rewrite <- Heqstx. auto.
    apply E_Havoc.
    apply E_WhileEnd. simpl. auto.
  destruct stx. simpl. replace (update st X 1) with st.
  apply E_WhileEnd. simpl. rewrite <- Heqstx. auto.
  apply functional_extensionality. intros.
  destruct (eq_id_dec X x) eqn:eqid; subst.
    rewrite update_eq. auto.
    rewrite update_neq; auto.
  apply E_WhileLoop with (update st X 1).
    simpl; rewrite <- Heqstx; auto.
    apply E_Havoc.
    apply E_WhileEnd. simpl. auto.
  Qed.

End Himp.

Definition stequiv (st1 st2 : state) : Prop :=
  forall (X:id), st1 X = st2 X.

Notation "st1 '~' st2" := (stequiv st1 st2) (at level 30).

Lemma stequiv_refl : forall (st : state),
  st ~ st.
Proof.
  intros. intro X. auto. Qed.

Lemma stequiv_sym : forall (st1 st2 : state),
  st1 ~ st2 ->
  st2 ~ st1.
Proof.
  intros. intro X. symmetry. apply H. Qed.

Lemma stequiv_trans : forall (st1 st2 st3 : state),
  st1 ~ st2 ->
  st2 ~ st3 ->
  st1 ~ st3.
Proof.
  intros. intro X. rewrite H. apply H0. Qed.

Lemma stequiv_update : forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (X:id) (n:nat),
  update st1 X n ~ update st2 X n.
Proof.
  intros. intros x.
  destruct (eq_id_dec X x) eqn:eq.
    subst. rewrite update_eq. rewrite update_eq. auto.
    rewrite update_neq; auto. rewrite update_neq; auto.
  Qed.

Lemma stequiv_aeval : forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (a:aexp), aeval st1 a = aeval st2 a.
Proof.
  intros.
  induction a; simpl; auto.
  Qed.

Lemma stequiv_beval : forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (b:bexp), beval st1 b = beval st2 b.
Proof.
  intros.
  induction b; simpl; auto; try rewrite stequiv_aeval with (st2:=st2); auto;
  try rewrite stequiv_aeval with (st1:=st1) (st2:=st2); auto.
  rewrite IHb; auto.
  rewrite IHb1. rewrite IHb2. auto.
  Qed.

Lemma stequiv_ceval: forall (st1 st2 : state),
  st1 ~ st2 ->
  forall (c: com) (st1': state),
    (c / st1 || st1') ->
    exists st2' : state,
    ((c / st2 || st2') /\ st1' ~ st2').
Proof.
  intros st1 st2 STEQV c st1' CEV1. generalize dependent st2.
  induction CEV1; intros st2 STEQV.
  Case "SKIP".
    exists st2. split.
      constructor.
      assumption.
  Case ":=".
    exists (update st2 x n). split.
       constructor. rewrite <- H. symmetry. apply stequiv_aeval.
       assumption. apply stequiv_update. assumption.
  Case ";".
    destruct (IHCEV1_1 st2 STEQV) as [st2' [P1 EQV1]].
    destruct (IHCEV1_2 st2' EQV1) as [st2'' [P2 EQV2]].
    exists st2''. split.
      apply E_Seq with st2'; assumption.
      assumption.
  Case "IfTrue".
    destruct (IHCEV1 st2 STEQV) as [st2' [P EQV]].
    exists st2'. split.
      apply E_IfTrue. rewrite <- H. symmetry. apply stequiv_beval.
      assumption. assumption. assumption.
  Case "IfFalse".
    destruct (IHCEV1 st2 STEQV) as [st2' [P EQV]].
    exists st2'. split.
     apply E_IfFalse. rewrite <- H. symmetry. apply stequiv_beval.
     assumption. assumption. assumption.
  Case "WhileEnd".
    exists st2. split.
      apply E_WhileEnd. rewrite <- H. symmetry. apply stequiv_beval.
      assumption. assumption.
  Case "WhileLoop".
    destruct (IHCEV1_1 st2 STEQV) as [st2' [P1 EQV1]].
    destruct (IHCEV1_2 st2' EQV1) as [st2'' [P2 EQV2]].
    exists st2''. split.
      apply E_WhileLoop with st2'. rewrite <- H. symmetry.
      apply stequiv_beval. assumption. assumption. assumption.
      assumption.
Qed.

Reserved Notation "c1 '/' st '||'' st'" (at level 40, st at level 39).

Inductive ceval' : com -> state -> state -> Prop :=
  | E_equiv : forall c st st' st'',
    c / st || st' ->
    st' ~ st'' ->
    c / st ||' st''
  where "c1 '/' st '||'' st'" := (ceval' c1 st st').

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

Lemma cequiv__cequiv' : forall (c1 c2: com),
  cequiv c1 c2 -> cequiv' c1 c2.
Proof.
  unfold cequiv, cequiv'; split; intros.
    inversion H0 ; subst. apply E_equiv with st'0.
    apply (H st st'0); assumption. assumption.
    inversion H0 ; subst. apply E_equiv with st'0.
    apply (H st st'0). assumption. assumption.
Qed.

Example identity_assignment' :
  cequiv' SKIP (X ::= AId X).
Proof.
    unfold cequiv'. intros. split; intros.
    Case "->".
      inversion H; subst; clear H. inversion H0; subst.
      apply E_equiv with (update st'0 X (st'0 X)).
      constructor. reflexivity. apply stequiv_trans with st'0.
      unfold stequiv. intros. apply update_same.
      reflexivity. assumption.
    Case "<-".
      inversion H; subst; clear H.
      apply E_equiv with st'0; auto.
      generalize H0.
      apply identity_assignment.
    Qed.

Theorem for_while_skip_equiv : forall b c2 c3 st st',
  ((FOR(FSKIP,b,c2) DO c3 END) /f st || st') <->
  ((WHILEF b DO c3 F; c2 END) /f st || st').
Proof.
  split; intros.
  remember (FOR  (FSKIP, b, c2)DO c3 END) as floop.
  induction H; try inversion Heqfloop; subst.
  inversion H; subst.
  apply F_WhileEnd; auto.
  inversion H; subst.
  apply F_WhileLoop with st''; auto.
  remember (WHILEF b DO c3 F; c2 END) as loopdef eqn:loop.
  induction H; try inversion loop; subst.
  apply F_ForEnd; try constructor; auto.
  apply F_ForLoop with st st'; try apply F_Skip; subst; auto.
  Qed.

Theorem for_while_equiv : forall b c1 c2 c3 st st',
  ((FOR(c1,b,c2) DO c3 END) /f st || st') <->
  ((c1 F; WHILEF b DO c3 F; c2 END) /f st || st').
Proof.
  split.
  generalize dependent st'.
  remember (FOR  (c1, b, c2)DO c3 END) as floop.
  intros.
  induction H; try inversion Heqfloop.
  apply F_Seq with st'; subst; auto.
    apply F_WhileEnd; auto.
  apply F_Seq with st'; subst; auto.
    apply F_WhileLoop with st''; auto.
    apply for_while_skip_equiv. auto.
  intros. inversion H; subst.
  remember (WHILEF b DO c3 F; c2 END) as floopdef eqn:loop.
  induction H5; try inversion loop; subst.
    apply F_ForEnd; auto.
    apply F_ForLoop with st0 st'; try auto.
    apply for_while_skip_equiv. auto.
  Qed.

Theorem swap_noninterfering_assignments: forall l1 l2 a1 a2,
  l1 <> l2 ->
  var_not_used_in_aexp l1 a2 ->
  var_not_used_in_aexp l2 a1 ->
  cequiv
    (l1 ::= a1;; l2 ::= a2)
    (l2 ::= a2;; l1 ::= a1).
Proof.
  intros.
  assert(Hevaleq : forall st, update (update st l1 (aeval st a1)) l2
     (aeval (update st l1 (aeval st a1)) a2) =
       update (update st l2 (aeval st a2)) l1
     (aeval (update st l2 (aeval st a2)) a1)).
  intros. apply functional_extensionality.
  intro.
    destruct (eq_id_dec l1 x) eqn:id1.
    rewrite update_neq; subst; auto.
    rewrite update_eq. rewrite update_eq.
    rewrite aeval_weakening; auto.
    destruct (eq_id_dec l2 x) eqn:id2; subst.
    rewrite update_eq. rewrite aeval_weakening; auto.
    rewrite update_neq; auto. rewrite update_eq. auto.
    repeat rewrite update_neq; auto.
  split; intro;
  inversion H2; subst; inversion H5; subst; inversion H8; subst.
  rewrite Hevaleq. apply E_Seq with (update st l2 (aeval st a2));
  apply E_Ass; auto.
  rewrite <- Hevaleq. apply E_Seq with (update st l1 (aeval st a1));
  apply E_Ass; auto.
  Qed.


(** * MoreStlc: A Typechecker for STLC *)

(* $Date: 2013-07-18 05:19:11 +0900 (木, 18  7月 2013) $ *)

Require Export Stlc.

(** The [has_type] relation of the STLC defines what it means for a
    term to belong to a type (in some context).  But it doesn't, by
    itself, tell us how to _check_ whether or not a term is well
    typed.

    Fortunately, the rules defining [has_type] are _syntax directed_
    -- they exactly follow the shape of the term.  This makes it
    straightforward to translate the typing rules into clauses of a
    typechecking _function_ that takes a term and a context and either
    returns the term's type or else signals that the term is not
    typable. *)

Module STLCChecker.
Import STLC.

(* ###################################################################### *)
(** ** Comparing Types *)

(** First, we need a function to compare two types for equality... *)

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | TBool, TBool =>
      true
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

(** ... and we need to establish the usual two-way connection between
    the boolean result returned by [beq_ty] and the logical
    proposition that its inputs are equal. *)

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity.  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  Case "T1=TBool".
    reflexivity.
  Case "T1=TArrow T1_1 T1_2".
    apply andb_true in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst...  Qed.

(* ###################################################################### *)
(** ** The Typechecker *)

(** Now here's the typechecker.  It works by walking over the
    structure of the given term, returning either [Some T] or [None].
    Each time we make a recursive call to find out the types of the
    subterms, we need to pattern-match on the results to make sure
    that they are not [None].  Also, in the [tapp] case, we use
    pattern matching to extract the left- and right-hand sides of the
    function's arrow type (and fail if the type of the function is not
    [TArrow T11 T12] for some [T1] and [T2]). *)

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x => Gamma x
  | tabs x T11 t12 => match type_check (extend Gamma x T11) t12 with
                          | Some T12 => Some (TArrow T11 T12)
                          | _ => None
                        end
  | tapp t1 t2 => match type_check Gamma t1, type_check Gamma t2 with
                      | Some (TArrow T11 T12),Some T2 =>
                        if beq_ty T11 T2 then Some T12 else None
                      | _,_ => None
                    end
  | ttrue => Some TBool
  | tfalse => Some TBool
  | tif x t f => match type_check Gamma x with
                     | Some TBool =>
                       match type_check Gamma t, type_check Gamma f with
                         | Some T1, Some T2 =>
                           if beq_ty T1 T2 then Some T1 else None
                         | _,_ => None
                       end
                     | _ => None
                   end
  end.

(* ###################################################################### *)
(** ** Properties *)

(** To verify that this typechecking algorithm is the correct one, we
    show that it is _sound_ and _complete_ for the original [has_type]
    relation -- that is, [type_check] and [has_type] define the same
    partial function. *)

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  t_cases (induction t) Case; intros Gamma T Htc; inversion Htc.
  Case "tvar"...
  Case "tapp".
    remember (type_check Gamma t1) as TO1.
    remember (type_check Gamma t2) as TO2.
    destruct TO1 as [T1|]; try solve by inversion;
    destruct T1 as [|T11 T12]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T11 T2) eqn: Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0; subst...
  Case "tabs".
    rename i into y. rename t into T1.
    remember (extend Gamma y T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve by inversion.
    inversion H0; subst...
  Case "ttrue"...
  Case "tfalse"...
  Case "tif".
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve by inversion.
    destruct Tc; try solve by inversion.
    destruct TO1 as [T1|]; try solve by inversion.
    destruct TO2 as [T2|]; try solve by inversion.
    destruct (beq_ty T1 T2) eqn:Heqb;
    try solve by inversion.
    apply beq_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  has_type_cases (induction Hty) Case; simpl.
  Case "T_Var"...
  Case "T_Abs". rewrite IHHty...
  Case "T_App".
    rewrite IHHty1. rewrite IHHty2.
    rewrite (beq_ty_refl T11)...
  Case "T_True"...
  Case "T_False"...
  Case "T_If". rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (beq_ty_refl T)...
Qed.

End STLCChecker.