Require Import Bool List Arith Nat Coq.Arith.Div2.
Import ListNotations.

Fixpoint bit_n (l : list bool) : nat :=
  match l with
    | [] => 0
    | a :: tl => 2 * bit_n tl + Nat.b2n a
  end.

Fixpoint n_bit (n : nat) (k : nat) : option (list bool) :=
    match n with
      | 0 => match k with
             | 0 => Some []
             | S _ => None
             end
      | S n' => match n_bit n' (Nat.div2 k) with
                  | None => None
                  | Some l => Some (Nat.odd k :: l)
                end
    end.

Compute pow 2 8.
Check leb 2 3.

Lemma n_bit_dont_fail : forall (n k : nat),
    k < pow 2 n -> exists (l : list bool), n_bit n k = Some l.
Proof.
  induction n.
  -destruct k.
   +simpl.
    exists [].
    reflexivity.
   +simpl.
    Search (_ < 0).
    Search (S _ < S _).
    exists [].
    apply lt_S_n in H.
    Search (_ < 0).
    apply Nat.nlt_0_r in H.
    inversion H.
  -intros.
   simpl.
   specialize (IHn (Nat.div2 k)).
   edestruct IHn.
   +Search Nat.div2.
    admit.
   +rewrite H0.
    eauto.
Admitted.

SearchAbout (_ mod _).

Lemma size_n_bit : forall (n k: nat) (l : list bool),
    n_bit n k = Some l -> length l = n.
Proof.
  induction n.
  -intros k l.
   induction k.
   +intros.
    inversion H.
    reflexivity.
   +simpl.
    discriminate.
  -intros k l.
   simpl.
   case_eq (n_bit n (Nat.div2 k)).
   +intros.
    inversion H0.
    assert (help1: forall (l' : list bool) (b : bool), length l' = n -> length(b :: l') = S n).
    {
      induction l'.
      -intros b.
       simpl.
       intros.
       rewrite H1.
       reflexivity.
      -intros b.
       simpl.
       intros.
       rewrite H1.
       reflexivity.
    }
    apply help1.
    specialize (IHn (Nat.div2 k)).
    apply IHn.
    exact H.
   +intros.
    discriminate.
Qed.

(* first proof that we need on binary representation *)
Theorem n_bit_n : forall (l : list bool) (n k : nat),
                    n_bit n k = Some l -> bit_n l = k.
Proof.
  assert (I : forall (l : list bool) (n k : nat), n_bit n k = Some l -> bit_n l = k).
  {
    intros l; induction l; intros n k.
    simpl.
    assert (I_1 : n_bit n k = Some [] -> bit_n [] = k).
    {
      induction k.
      - reflexivity.
       (* the hypothesis is false so we will need to find how to demonstrate this *)
      - assert (I_1_1 : n_bit n (S k) = Some [] -> bit_n [] = S k).
       {
         induction n.
         - discriminate.
         - unfold n_bit; fold n_bit.
           destruct (n_bit n (Nat.div2 (S k))); discriminate.
       }
       exact I_1_1.
    }
    exact I_1.
    assert (I_2 : n_bit n k = Some (a :: l) -> bit_n (a :: l) = k).
    {
      intros H.
      simpl.
      About Nat.div2_odd.
      rewrite (Nat.div2_odd k).
      simpl.
      destruct n; simpl in H.
      - destruct k; discriminate.
      - destruct (n_bit n (Nat.div2 k)) eqn:Hl; try discriminate.
        inversion H; subst.
        erewrite IHl; eauto.
    }
    assumption.
  }
  assumption.
Qed.

(* second proof *)
Theorem bit_n_bit : forall (l : list bool) (n : nat),
                      n = length l -> (n_bit n (bit_n l)) = Some l.
Proof.
  assert (I : forall (l : list bool) (n : nat), n = length l -> n_bit n (bit_n l) = Some l).
  {
    induction l.
    assert (I_1 : forall n : nat, n = length ([] : list bool) -> n_bit n (bit_n []) = Some []).
    {
      simpl.
      intros n H.
      rewrite H.
      reflexivity.
    }
    exact I_1.
    assert (I_2 : forall n : nat, n = length (a :: l) -> n_bit n (bit_n (a :: l)) = Some (a :: l)).
    {
      intros n.
      simpl.
      destruct a.
      assert (I_2_1 : n = length (true :: l) -> n_bit n (bit_n (true :: l)) = Some (true :: l)).
      {
        simpl.
        Search (_ + 0).
        rewrite <- plus_n_O.
        intros H.
        rewrite H.
        simpl.
        assert (I_2_1_1 : forall l' : (list bool), bit_n l' + bit_n l' = 2 * bit_n l').
        {
          induction l'.
          -reflexivity.
          -simpl.
           rewrite <- plus_n_O.
           rewrite <- plus_n_O.
           reflexivity.
        }
        rewrite I_2_1_1.
        Search (_ + 1 = S _).
        Search (Nat.div2 _).
        rewrite Nat.add_1_r.
        Check even_div2.
        rewrite <- even_div2.
        -Search (Nat.div2 (2 * _)).
         rewrite div2_double.
         rewrite IHl.
         +assert (I_2_1_2 : forall (n' : nat), Nat.odd (S (2 * n')) = true).
          {
            intros n'.
            induction n'.
            -reflexivity.
            -simpl.
             rewrite <- plus_n_Sm.
             simpl in IHn'.
             rewrite <- IHn'.
             Search (Nat.odd (S (S _))).
             rewrite Nat.odd_succ_succ. reflexivity.
          }
          rewrite I_2_1_2.
          reflexivity.
         +reflexivity.
        -assert (I_2_1_3 : Even.even (2 * bit_n l)).
         {
           (* this is supposed to be trivial -_-_-_-_-_-_-_-_-_-_-_-_- *)
           Check Nat.even_add_mul_2.
           Search (0 + _).
           rewrite <- Nat.add_0_l.
           SearchAbout (even (_ + _)).
           specialize (Nat.even_add_mul_2 0 (bit_n l)).
           intros.
           Check Even.even_equiv.
           apply Even.even_equiv.
           (* even spec *)
           Check Nat.even_spec.
           simpl in H0.
           Search (_ + _ = 2 * _).
           Check I_2_1_1.
           rewrite <- I_2_1_1.
           assert (0 + (bit_n l + bit_n l) = bit_n l + (bit_n l + 0)).
           { simpl. Search (_ + 0). rewrite <- plus_n_O. reflexivity. }
           rewrite H1.
           rewrite Nat.even_spec in H0.
           exact H0.
         }
         exact I_2_1_3.
      }
      exact I_2_1.
      assert (I_2_2 : n = S (length l) -> n_bit n (bit_n l + (bit_n l + 0) + Nat.b2n false) = Some (false :: l)).
      {
        simpl.
        Search (_ + 0).
        rewrite <- plus_n_O.
        rewrite <- plus_n_O.
        intros H.
        rewrite H.
        simpl.
        Search (2 * _ = _).
        assert (I_2_2_0 : forall (n' : nat), 2 * n' = n' + n').
        {
          intros n'. simpl. rewrite <- plus_n_O. reflexivity.
        }
        rewrite <- I_2_2_0.
        rewrite div2_double.
        rewrite IHl.
        -assert (I_2_2_1 : forall (n' : nat), Nat.odd (2 * n') = false).
         {
           induction n'.
           -simpl. Search (Nat.odd 0).
            rewrite Nat.odd_0. reflexivity.
           -simpl.
            Search (_ + 0).
            rewrite <- plus_n_O.
            Search (_ + _ = _ + _).
            rewrite <- plus_Snm_nSm.
            Search (S _ + _).
            rewrite plus_Sn_m.
            Search (Nat.odd (S (S _))).
            rewrite Nat.odd_succ_succ.
            simpl in IHn'.
            rewrite <- plus_n_O in IHn'.
            rewrite IHn'.
            reflexivity.
         }
         rewrite I_2_2_1.
         reflexivity.
        -reflexivity.
      }
      exact I_2_2.
    }
    exact I_2.
  }
  exact I.
Qed.


Require Export D.

(********** Existential Quantification **********)

Print ex.

Inductive ex (X:Type) (P : X->Prop) : Prop :=
 ex_intro : forall (witness:X), P witness -> ex X P.

Notation "'exists' x , p" := (ex _ (fun x => p))
    (at level 200, x ident, right associativity) : type_scope.
Notation "'exists' x : X , p" := (ex _ (fun x:X => p))
    (at level 200, x ident, right associativity) : type_scope.

Example exists_example_1 : exists n, n + (n * n) = 6.
Proof. apply ex_intro with (witness:=2). constructor.  Qed.

Example exists_example_22 : exists n, n + (n * n) = 6.
Proof. exists 2. constructor.  Qed.

Theorem exists_example_2 : forall n,
  (exists m, n = 4 + m) -> (exists o, n = 2 + o).
Proof. intros. inversion H as [m Hm]. exists (2+m).
  assumption. Qed.

Lemma exists_example_3 : exists (n:nat), even n /\ beautiful n.
Proof. exists 8. split.
  Case "even". unfold even. reflexivity.
  Case "beautiful". apply b_sum with (n:=3) (m:=5). apply b_3. apply b_5. Qed.

Definition Eng_e : Prop := ex nat (fun n => beautiful (S n)).
Example eng : Eng_e.
Proof. exists 2. apply b_3. Qed.

Theorem dist_not_exists : forall (X:Type) (P: X -> Prop),
    (forall x, P x) -> ~(exists x, ~(P x)).
Proof. intros.  unfold not. intro Hcontra.
  inversion Hcontra. apply H0 in H. inversion H. Qed.

Print ex_falso_quodlibet.

Theorem not_exists_dist :
  excluded_middle ->
    forall (X:Type) (P:X -> Prop), ~(exists x, ~(P x)) ->
      (forall x, P x).
Proof.
 unfold excluded_middle. unfold not.
  intros H X P H2 x. destruct H with (P:=P x).
  Case "P". apply H0.
  Case "~P". apply ex_falso_quodlibet. apply H2. exists x. assumption.
Qed.

Theorem dist_exsits_or : forall (X:Type) (P Q:X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
 intros. split.
  Case "->". intros. destruct H as [x]. inversion H.
    SCase "P x". left. exists x. assumption.
    SCase "Q x". right. exists x. assumption.
  Case "<-". intros. destruct H.
    SCase "P x". destruct H as [x]. exists x. left. assumption.
    SCase "Q x". destruct H as [x]. exists x. right. assumption.
Qed.

(********** Evidence_Carrying Booleans **********)

Inductive sumbool (A B: Prop) : Set :=
| left : A -> sumbool A B
| right : B -> sumbool A B.

Notation "{ A } + { B }" := (sumbool A B) : type_scope.

Theorem eq_nat_dec : forall n m: nat,
  {n = m} + {~(n = m)}.
Proof. intros n.
  induction n as [|n'].
  Case "O".
    intro m. destruct m as [|m'].
    SCase "O". left. reflexivity.
    SCase "S m". right. intros contra. inversion contra.
  Case "S n".
    intro m. destruct m as [|m'].
    SCase "O". right. intros contra. inversion contra.
    SCase "S m". destruct IHn' with (m:=m').
      SSCase "left". left. rewrite e. reflexivity.
      SSCase "right". right. intros contra. inversion contra. apply n in H0. inversion H0.
Qed.

Definition override' {X:Type} (f:nat->X) (k:nat) (x:X) : nat->X :=
  fun (k':nat) => if eq_nat_dec k k' then x else f k'.

Theorem override_same' : forall (X:Type) x1 k1 k2 (f:nat ->X),
  f k1 = x1 -> (override' f k1 x1) k2 = f k2.
Proof. intros. unfold override'. destruct (eq_nat_dec k1 k2) eqn:Heq.
  Case "left".  rewrite<-e. symmetry. assumption.
  Case "right". reflexivity. Qed.

Theorem override_shadow' : forall (X:Type) x1 x2 k1 k2 (f:nat->X),
  (override' (override' f k1 x2) k1 x1) k2 = (override' f k1 x1) k2.
Proof. intros. unfold override'. destruct (eq_nat_dec k1 k2) eqn:Heq.
  Case "left". reflexivity.
  Case "right". reflexivity.
Qed.

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

Inductive all (X:Type) (P: X -> Prop) : list X -> Prop :=
|all_nil : all X P []
|all_cons :  forall hd tl, P hd -> all X P tl -> all X P (hd::tl)
.

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
match l with
| [] => true
| hd::tl => andb (test hd) (forallb test tl)
end.

Theorem all_forallb : forall (X : Type) (test : X -> bool) (l : list X),
  all X (fun x => test x = true) l <-> forallb test l = true.
Proof.
  intros.  (*remember (fun x : X => test x = true) as P.*) split.
  Case "->".
  {
     intro H. induction l as [|hd tl].
    SCase "[]". reflexivity.
    SCase "hd::tl". simpl. unfold andb. destruct (forallb test tl) eqn:Htl. destruct (test hd) eqn:Hhd. reflexivity.
      inversion H. rewrite H2 in Hhd. inversion Hhd.
      destruct (test hd) eqn:Hhd. inversion H. apply IHtl in H3. inversion H3.
      inversion H. rewrite H2 in Hhd. inversion Hhd.
  }
  Case "<-".
  {
    intro H. induction l as [|hd tl].
    SCase "[]". apply all_nil.
    SCase "hd::tl". apply all_cons. inversion H.
      destruct (test hd) eqn:Hhd. symmetry. assumption. reflexivity.
     apply IHtl. inversion H. destruct (forallb test tl) eqn:Htl.
      symmetry. assumption. destruct (test hd) eqn:Hhd. reflexivity. reflexivity.
  }
 Qed.

(*********************************************************)
Inductive inorder_merge {X : Type} : list X -> list X -> list X -> Prop :=
| inorder_nil : inorder_merge [] [] []
| inorder_l1 : forall hd tl l2 l3,
  inorder_merge tl l2 l3 -> inorder_merge (hd::tl) l2 (hd::l3)
| inorder_l2 : forall l1 hd tl l3,
  inorder_merge l1 tl l3 -> inorder_merge l1 (hd::tl) (hd::l3)
.

Lemma same_tail : forall (X:Type) (x:X) t1 t2, x::t1 = x::t2 -> t1 = t2.
Proof. intros. inversion H. reflexivity. Qed.

Theorem filter_challenge : forall (X:Type) (l1 l2 l:list X) (test:X->bool),
  (filter test l1 = l1) -> (filter test l2 = []) -> inorder_merge l1 l2 l -> (filter test l = l1).
Proof.
 intros. induction H1.
  Case "inorder_nil". assumption.
  Case "inorder_l1". simpl. destruct (test hd) eqn:Hhd.
    SCase "true".  assert (Htl : filter test tl = tl).
    Proof. inversion H. rewrite Hhd in H3. apply same_tail in H3. assumption.
  apply IHinorder_merge in Htl. rewrite Htl. reflexivity. assumption.
    SCase "false". simpl in H. rewrite Hhd in H. inversion H.  inversion H.
Abort.
(*************************************************************)

Inductive appears_in {X:Type} (a:X) : list X -> Prop :=
| ai_here : forall l, appears_in a (a::l)
| ai_later : forall b l, appears_in a l -> appears_in a (b::l).

Lemma appears_in_app: forall (X:Type) (xs ys : list X) (x:X),
  appears_in x (xs ++ ys) -> appears_in x xs \/ appears_in x ys.
Proof. intros X xs. induction xs as [|hd tl].
  Case "[]". intros. replace ([]++ys) with ys in H. right. assumption. reflexivity.
  Case "hd::tl". intros. inversion H.
    SCase "ai_here". left. apply ai_here.
    SCase "ai_later". apply IHtl in H1. destruct H1. left. apply ai_later. assumption. right. assumption. Qed.

Lemma app_appears_in: forall (X:Type) (xs ys:list X) (x:X),
  appears_in x xs \/ appears_in x ys -> appears_in x (xs ++ ys).
Proof. intros. destruct H.
  Case "left". induction xs as [|hd tl].
    SCase "[]". inversion H.
    SCase "hd::tl". replace ((hd::tl)++ys) with (hd::(tl++ys)).
      inversion H. apply ai_here. apply ai_later. apply IHtl. assumption. reflexivity.
  Case "right". induction xs as [|hd tl].
    SCase "[]". simpl. assumption.
    SCase "hd::tl". replace ((hd::tl)++ys) with (hd::(tl++ys)).
      apply ai_later. assumption. reflexivity. Qed.

Definition disjoint (X:Type) (l1 l2:list X) : Prop :=
  forall (x:X), appears_in x (l1 ++ l2) -> (appears_in x l1 -> ~(appears_in x l2)) /\ (appears_in x l2 -> ~(appears_in x l1)).

Example dis_ex : disjoint nat [1;2] [4;5].
Proof. unfold disjoint. intros. split.
  Case "left". intro H2. inversion H2.
    SCase "ai_here". unfold not. intro contra. inversion contra. inversion H4. inversion H7.
    SCase "ai_later". unfold not. intro contra. inversion H1. rewrite H5 in contra. inversion contra as [|n l' contra2]. inversion contra2. inversion H9.
      inversion H5.
  Case "right".  intro H2. inversion H2.
    SCase "ai_here". unfold not. intro contra. inversion contra. inversion H4. inversion H7.
    SCase "ai_later". unfold not. intro contra. inversion H1. rewrite H5 in contra. inversion contra as [|n l' contra2]. inversion contra2. inversion H9.
      inversion H5. Qed.

Inductive no_repeats (X:Type) : list X ->  Prop :=
| nr_nil : no_repeats X []
| nr_cons : forall hd tl, no_repeats X tl -> ~(appears_in hd tl) -> no_repeats X (hd::tl)
.

Inductive nostutter: list nat -> Prop :=
| ns_nil : nostutter []
| ns_single : forall n, nostutter [n]
| ns_cons : forall x1 x2 tl, (x1<>x2) -> nostutter tl -> nostutter (x1::x2::tl)
.
Example nostutter_example_1 : nostutter [1;4;1].
Proof. apply ns_cons. intros contra. inversion contra. apply ns_single. Qed.


Parameter G : Set.
Parameter mult : G -> G -> G.
Notation "x * y" := (mult x y).
Parameter one : G.
Notation "1" := one.
Parameter inv : G -> G.
Notation "/ x" := (inv x).

Axiom mult_assoc : forall x y z, x * (y * z) = (x * y) * z.
Axiom one_unit_l : forall x, 1 * x = x.
Axiom inv_l : forall x, /x * x = 1.

Lemma inv_r : forall x, x * / x = 1.
Proof.
  intros.
  rewrite <- (one_unit_l  x).
  rewrite <- (inv_l (/ x)).
  rewrite <- (mult_assoc (/ / x) (/ x) x).
  rewrite inv_l.
  rewrite <- (mult_assoc (/ / x) 1 (/ (/ / x * 1))).
  rewrite one_unit_l.
  rewrite inv_l.
  rewrite <- (inv_l x).
  rewrite (mult_assoc (/ / x) (/ x) x).
  rewrite inv_l.
  rewrite one_unit_l.
  rewrite inv_l.
  rewrite inv_l.
  reflexivity.
Qed.

Lemma one_unit_r : forall x, x * / x = 1.
Proof.
  intros.
  rewrite inv_r.
  reflexivity.
Qed.


Require Import List.
Import ListNotations.
Require Import Multiset.

Require Import Relations.
Require Import Arith.
Require Import Omega.

Set Implicit Arguments.

Section defs.

(* TODO:
   - finish soundness -- Done
   - think / read about completeness
   - make proofs independent of list order, either by reformulating proof rules,
     or by using multisets -- Done*)

Inductive Formula :=
  var : nat -> Formula (* p_n *)
| neg : Formula -> Formula
| con : Formula -> Formula -> Formula.

Definition Sequent := multiset Formula.

Lemma eqA_dec : forall x y: Formula, {x = y} + {~ (x = y)}.
intros; decide equality.
auto with arith.
Qed.

  Let emptyBag := EmptyBag Formula.
  Let singletonBag := SingletonBag _ eqA_dec.

Fixpoint list_contents (l:list Formula) : multiset Formula :=
    match l with
      | nil => emptyBag
      | a :: [] => (singletonBag a)
      | a :: l => munion (singletonBag a) (list_contents l)
    end.

Lemma sumpos (n m: nat) : n + m > 0 <-> ((n > 0) \/ (m > 0)).
Proof.
  omega.
Qed.

Definition InMSet (a : Formula) (m : multiset Formula): Prop  := multiplicity m a > 0.

Lemma multiSInversion: forall (x: Formula) (m n : multiset Formula), (InMSet x (munion m n) <-> ((InMSet x m) \/ (InMSet x n))).
Proof.
  intros x m n.
  split.
  intros H.
  unfold InMSet; unfold InMSet in H; simpl in H.
  destruct multiplicity; simpl in H.
  right; assumption.
  auto with arith.
  intros H.
  unfold InMSet; unfold InMSet in H; simpl.
  destruct multiplicity.
  destruct H.
  auto with arith.
  auto with arith.
  auto with arith.
Qed.

Lemma SingletonEquality:
  forall (x y: Formula) , InMSet x (singletonBag y) <-> (x = y).
Proof.
  split.
  -intros H. unfold InMSet in H. simpl in H .  destruct eqA_dec.
  rewrite e. reflexivity. assert (Zero: ~(0 > 0)).
  auto with arith. contradiction.

  -intros H. unfold InMSet. simpl. rewrite H. destruct eqA_dec.
  auto with arith. contradiction.
  Qed.

(* proofs of validity of a sequent *)
Inductive Proof : Sequent -> Type :=
  ax : forall (n: nat) (Gamma: Sequent),
    Proof (  munion  (list_contents [ var n ; neg (var n)] ) Gamma )
| ci : forall (A B : Formula) (Gamma: Sequent),
    Proof (munion (list_contents [A]) Gamma) -> Proof (munion (list_contents [B]) Gamma) -> Proof (munion (list_contents [con A B])  Gamma)
| di : forall (A B : Formula) (Gamma: Sequent),
    Proof (munion (list_contents [ neg A; neg B]) Gamma) -> Proof (munion (list_contents [neg (con A B) ]) Gamma).

(* todo: think about list order or use multisets, and define truth *)

(* negb: bool -> bool is boolean negation library function *)
(* andb: bool -> bool -> bool is conjunction library function *)
Check negb.
Check andb.

Definition Valuation := nat -> bool.

Fixpoint ev (A: Formula) (v: Valuation) : bool :=
  match A with
  | var n => (v n)
  | neg B => negb (ev B v)
  | con A B => andb (ev A v) (ev B v)
  end.

(* counterexample to validity *)
Definition counterexample (v: Valuation) (Gamma: Sequent) :=
  forall (A: Formula), InMSet A Gamma -> ev A v = false.

Check true.

Definition validF (A : Formula) := forall (v: Valuation),  ev A v = true.
Definition validS (Gamma : Sequent) := forall (v: Valuation), exists (A: Formula),
       InMSet A Gamma /\ ev A v = true.

(* Theorem conversion: forall (a b : bool), negb (a && b) = neg b *)

(* soundness *)
Theorem sound : forall (Gamma : Sequent) (p: Proof Gamma),  validS Gamma.
Proof.
  intros Gamma p.
  induction p.
  unfold validS.
  intro v.
  (* case distinction on v n = true or false *)

  (* probably use a library function or proof? *)
  assert (H: (v n = true) \/ (v n = false) ).
  destruct (v n).
  left.  reflexivity.
  right. reflexivity.

  destruct H as [HL | HR].
  (* case v n = true *)
  exists (var n).
  split.
  unfold InMSet.
  simpl.
  destruct eqA_dec.
  auto with arith.
  contradiction.
  assumption.

(*   case v n is false *)
  exists (neg (var n)).
  split.
  unfold InMSet.
  simpl.
  destruct eqA_dec.
  auto with arith.
  destruct eqA_dec.
  auto with arith.
  contradiction.
  simpl.
  rewrite HR.
  reflexivity.

(* case of conjunction *)
  unfold validS.
  intro v.
  destruct IHp1 with (v:= v); destruct IHp2 with (v:= v).
  firstorder.
  simpl in H0; simpl in H.

  rewrite multiSInversion in H0; rewrite multiSInversion in H.
  destruct H0.
  destruct H.
  exists (con x x0).
  split.
  simpl.
  rewrite multiSInversion.
  left.
  rewrite  SingletonEquality in H0; rewrite SingletonEquality in H.
 rewrite H0; rewrite H.
  rewrite SingletonEquality; reflexivity.
  simpl. rewrite H1; rewrite H2. reflexivity.

  exists x.
  split.
  simpl.
  rewrite multiSInversion.
  right; assumption.
  assumption.

  exists x0.
  split.
  simpl.
  rewrite multiSInversion.
  right; assumption.
  assumption.

  (* case of disjunction *)
  intro v.
  destruct IHp with (v := v).
  firstorder.
  simpl in H.
  rewrite multiSInversion in H.
  destruct H.
  rewrite multiSInversion in H.
  destruct H.

  - rewrite SingletonEquality in H.
  exists (neg(con A B)).
  split. simpl. rewrite multiSInversion. left. rewrite SingletonEquality.
  reflexivity.
  rewrite H in H0. simpl in H0.
  apply Bool.negb_false_iff in H0;
  rewrite <- Bool.negb_involutive_reverse in H0.
  simpl.
  destruct(ev B v).
  rewrite H0; reflexivity.
  rewrite H0; reflexivity.

  - rewrite SingletonEquality in H.
  exists (neg(con A B)).
  split. simpl. rewrite multiSInversion. left. rewrite SingletonEquality.
  reflexivity.
  rewrite H in H0. simpl in H0.
  apply Bool.negb_false_iff in H0;
  rewrite <- Bool.negb_involutive_reverse in H0.
  simpl.
  destruct(ev A v).
  rewrite H0; reflexivity.
  rewrite H0; reflexivity.

  -exists x.
  split.
  simpl. rewrite multiSInversion. right. assumption.
  assumption.
Qed.

(* completeness: every valid sequent is provable *)
    Theorem complete: forall (Gamma: Sequent),  validS Gamma -> exists (p: Proof Gamma), True.
Proof.

intros Gamma HG.
unfold Sequent in Gamma.
unfold validS in HG.
specialize (HG (fun _ => true)). destruct HG as [A [H1 H2]].
destruct A. exists. simpl in H2. pose ax. simpl in p. apply (Proof v).

Print validS.
intros G. induction G.
intros H1.  unfold validS in H1.

intuition.

      admit.

(* decidable with counterexample *)
      Theorem decidable : forall (Gamma: Sequent),  (exists p: Proof Gamma, True) \/ (exists v: Valuation, counterexample v Gamma).
        admit.


(* Bibliotecas importadas *)

Require Import Arith.

(* Definição indutiva dos termos de L0 *)

Inductive term :=
 | zero   : term
 | succ   : term -> term
 | true   : term
 | false  : term
 | iszero : term -> term
 | pred   : term -> term
 | ifte   : term -> term -> term -> term
.

(* Definição indutiva da propriedade de ser um número *)

Inductive nv : term -> Prop :=
 | zeroNum : nv zero
 | succNum : forall n, (nv n) -> (nv (succ n))
.

(* Definição indutiva de valor : números OU booleanos *)

Inductive value : term -> Prop :=
 | trueVal  : value true
 | falseVal : value false
 | numVal   : forall n, (nv n) -> (value n)
.

(* Testando termos *)
Check ifte false zero (succ zero).

(* Testando valores do tipo termo *)
Check value (iszero true).

(* Provando uma propriedade *)
Theorem teste1 : value (succ zero).
Proof.
constructor 3.
constructor 2.
constructor 1.
Qed.

(* Provando uma propriedade 2 *)
Theorem teste2 : value (succ zero).
Proof.
apply numVal.
apply succNum.
apply zeroNum.
Qed.

(* Provando uma propriedade negada *)
Lemma teste : ~ value (iszero true).
Proof.
unfold not.
intro H.
inversion H.
subst.
inversion H0.
Qed.

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

(* Definição da semântica operacional *)
Inductive step : term -> term -> Prop :=
 | e_iftrue     : forall t2 t3,        step (ifte true  t2 t3) t2
 | e_iffalse    : forall t2 t3,        step (ifte false t2 t3) t3
 | e_if         : forall t1 t2 t3 t1', (step t1 t1') -> step (ifte t1 t2 t3) (ifte t1' t2 t3)
 | e_succ       : forall t t',         step t t' -> step (succ t) (succ t')
 | e_predzero   :                      step (pred zero) zero
 | e_predsucc   : forall t,  (nv t) -> step (pred (succ t)) t
 | e_pred       : forall t t',         step t t' -> step (pred t) (pred t')
 | e_iszerozero :                      step (iszero zero) true
 | e_iszerosucc : forall t,  (nv t) -> step (iszero (succ t)) false
 | e_iszero     : forall t t',         step t t' -> step (iszero t) (iszero t')
.

(* Definição de forma normal *)

Definition NF (t:term) : Prop := forall t', not (step t t').

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

(* Exercício : TODO NV É FORMA NORMAL *)
Theorem nvNF : forall (t:term), nv t -> NF t.
Proof.
induction t.
intro. unfold NF. intro. unfold not. intro. inversion H0. (* zero *)
intro. inversion H. subst. apply IHt in H1. unfold NF in H1.  intro. unfold not. intro. inversion H0. subst. unfold not in H1. apply (H1 t'0) in H3. assumption. (* succ *)
intro. unfold NF. intro. intro. inversion H0. (* true *)
intro. unfold NF. intro. intro. inversion H0. (* false *)
intro. inversion H. (* iszero *)
intro. inversion H. (* pred *)
intro. inversion H. (* ifte *)
Qed.

(* Exercício : TODO VALOR É FORMA NORMAL *)

Theorem valueNF : forall (t:term), value t -> NF t.
Proof.
intro.
intro.
induction H.
  (* H=true *)
  unfold NF.
  intro.
  unfold not.
  intro.
  inversion H.
  (* H=false *)
  unfold NF.
  intro.
  unfold not.
  intro.
  inversion H.
  (* H=nv *)
  apply nvNF.
  assumption.
Qed.

(* DETERMINISMO *)

Theorem determinismo : forall t t' t'', (step t t') -> (step t t'') -> (t' = t'').
Proof.
induction t.
(* zero *)
intros. inversion H.
(* succ *)
intros.  inversion H. inversion H0. subst. assert (t'0 = t'1). apply (IHt t'0 t'1 H2 H5). apply f_equal. assumption.
(* true *)
intros. inversion H.
(* false *)
intros. inversion H.
(* iszero *)

intros. inversion H. subst. inversion H0. reflexivity. inversion H2.
inversion H0.  subst. discriminate H5. reflexivity. subst.
apply succNum in H2. apply nvNF in H2. unfold NF in H2. unfold not in H2. apply H2 in H5. exfalso. assumption.
inversion H0.  subst.  inversion H2. subst. apply succNum in H5. apply nvNF in H5. unfold NF in H5. unfold not in H5. exfalso. apply (H5 t'0 H2). subst. apply f_equal. apply (IHt t'0 t'1 H2 H5).

intros. inversion H. subst. inversion H0. reflexivity. inversion H2.
inversion H0.  subst. discriminate H5. subst. injection H4. intro. symmetry.  assumption.
subst.
apply succNum in H2. apply nvNF in H2. unfold NF in H2. unfold not in H2. apply H2 in H5. exfalso. assumption.
inversion H0.  subst.  inversion H2. subst. apply succNum in H5. apply nvNF in H5. unfold NF in H5. unfold not in H5. exfalso. apply (H5 t'0 H2). subst. apply f_equal. apply (IHt t'0 t'1 H2 H5).

intros.
inversion H. subst. inversion H0. subst. reflexivity. inversion H5.

inversion H0. subst. discriminate. subst. assumption. subst. inversion H9. subst. inversion H0. subst. inversion H5. subst. inversion H5. subst. assert (t1'=t1'0). apply IHt1. assumption. assumption. rewrite H1. reflexivity.

Qed.

Inductive type :=
 | tBool : type
 | tNat  : type
.

Inductive hasType : term -> type -> Prop :=
 | t_true   :                                         hasType true       tBool
 | t_false  :                                         hasType false      tBool
 | t_zero   :                                         hasType zero       tNat
 | t_succ   : forall t,           hasType t tNat   -> hasType (succ t)   tNat
 | t_pred   : forall t,           hasType t tNat   -> hasType (pred t)   tNat
 | t_iszero : forall t,           hasType t tNat   -> hasType (iszero t) tBool
 | t_ifte   : forall t1 t2 t3 ty, hasType t1 tBool ->
                                  hasType t2 ty    ->
                                  hasType t3 ty    -> hasType (ifte t1 t2 t3) ty
.

Theorem questao2a : hasType (ifte (iszero (succ (succ zero))) (succ zero) zero) tNat.
Proof.
apply t_ifte.
apply t_iszero.
apply t_succ.
apply t_succ.
apply t_zero.
apply t_succ.
apply t_zero.
apply t_zero.
Qed.

Theorem questao2b : step (ifte (iszero (succ (succ zero))) (succ zero) zero)
                       (ifte false (succ zero) zero).
Proof.
apply e_if.
apply e_iszerosucc.
apply succNum.
apply zeroNum.
Qed.

Theorem questao2c : ~ (step (ifte (iszero (succ (succ zero))) (succ zero) zero) zero).
Proof.
unfold not.
intro.
inversion H.
Qed.

Theorem questao2d : ~ forall t : term, value t.
Proof.
unfold not.
intros.
Admitted.

Theorem questao2e : forall t : term, (value t) \/ ~(value t).
Proof.
intros.
unfold not.
induction t.
  (* zero *)
  left. apply numVal. apply zeroNum.
  (* succ t *)
  inversion IHt.
  inversion H.
  (* value t*)
    (* succ true *)
    subst. right. intro. inversion H0. subst. inversion H1. subst. inversion H3.
    (* succ false *)
    subst. right. intro. inversion H0. subst. inversion H1. subst. inversion H3.
    (* succ nv *)
    subst. left. apply numVal. apply succNum. assumption.
  (* value t -> False *)
  right. intro. apply H. apply numVal. inversion H0. subst. inversion H1. subst. assumption.
  (* true *)
  left. apply trueVal.
  (* false *)
  left. apply falseVal.
  (* iszero t *)
  right. intro. inversion H. inversion H0.
  (* pred t *)
  right. intro. inversion H. inversion H0.
  (* ifte t1 t2 t3 *)
  right. intro. inversion H. inversion H0.
Qed.

Theorem unicidade_de_tipos : forall t, forall T1 T2 : type, (hasType t T1) -> (hasType t T2) -> T1 = T2.
Proof.
intros.
induction H.
  (* true *)
  inversion H0.
  reflexivity.
  (* false *)
  inversion H0.
  reflexivity.
  (* zero *)
  inversion H0.
  reflexivity.
  (* succ t *)
  inversion H0.
  reflexivity.
  (* pred t *)
  inversion H0.
  reflexivity.
  (* iszero t *)
  inversion H0.
  reflexivity.
  (* ifte t1 t2 t3 *)
  inversion H0.
  subst.
  apply IHhasType2.
  assumption.
Qed.


Parameter A : Type.
Parameter eq_bool : A -> A -> bool.
Axiom eq_bool_true : forall (x y:A), eq_bool x y = true  -> x = y.
Axiom eq_bool_false: forall (x y:A), eq_bool x y = false -> x <> y.

(* convoy pattern *)
Definition test (x y:A) : {x = y} + {x <> y} :=
    match eq_bool x y as b return eq_bool x y = b -> {x = y} + {x <> y} with
    | true  => fun p    => left  (eq_bool_true  x y p)
    | false => fun p    => right (eq_bool_false x y p)
    end (eq_refl (eq_bool x y)).

(* we do not need to use the convoy pattern *)

Definition test_bool (b:bool) : {b = true} + {b = false} :=
    match b with
    | true  => left  (eq_refl true)
    | false => right (eq_refl false)
    end.

(* now do not pattern match on boolean values, but on proofs instead *)

Definition test' (x y:A) : {x = y} + {x <> y} :=
    match test_bool (eq_bool x y) with
    | left  p   => left  (eq_bool_true  x y p)
    | right p   => right (eq_bool_false x y p)
    end.

(* functions such as test and test' are always 'correct' *)
Definition correct (f:forall (x y:A), {x = y} + {x <> y}) : Prop :=
    forall (x y:A),
        ( (exists p, f x y = left p ) <-> x = y ) /\
        ( (exists p, f x y = right p) <-> x <> y) .

Lemma always_correct : forall (f:forall (x y:A), {x = y} + {x <> y}), correct f.
Proof.
    intros f. unfold correct. intros x y. split.
    - split.
        + intros [H _]. exact H.
        + intros H. destruct (f x y) as [H'|H'].
            { exists H'. reflexivity. }
            { exfalso. apply H'. exact H. }
    - split.
        + intros [H _]. exact H.
        + intros H. destruct (f x y) as [H'|H'].
            { exfalso. apply H. exact H'. }
            { exists H'. reflexivity. }
Qed.


Require Import Setoid.

(** Results about lexicographic order *)

Notation lex x y :=
  (match x with
    | Eq => y
    | c => c
  end).

Section t.
  Variable A B: Type.
  Variable f : A -> A -> comparison.
  Variable g : B -> B -> comparison.
  Hypothesis Hf_sym: forall x y,  f x y = CompOpp (f y x).
  Hypothesis Hf_trans:forall c x y z,  f x y = c -> f y z = c -> f x z = c.
  Hypothesis Hg_sym: forall x y,  g x y = CompOpp (g y x).
  Hypothesis Hg_trans:forall c x y z,  g x y = c -> g y z = c -> g x z = c.

  Hint Resolve Hf_sym Hf_trans Hg_sym Hg_trans : lex.
  Lemma lex_sym x1 x2 y1 y2: lex (f x1 x2) (g y1 y2) = CompOpp (lex (f x2 x1) (g y2 y1)).
  Proof.
    repeat match goal with
               |- context [f ?x ?y] => case_eq (f x y); intros ?
             | |- context [f ?x ?y] => case_eq (g x y); intros ?
             | H : f ?x ?y = _, H' : f ?y ?x = _ |- _ =>
               rewrite Hf_sym, H' in H; simpl in H; clear H'; try discriminate
           end; simpl; try eauto with lex.
  Qed.

  Lemma CompOpp_move x y : CompOpp x = y <-> x = CompOpp y.
    destruct x; destruct y; simpl; intuition discriminate.
  Qed.

  Lemma Hf_sym' c x y : f x y = CompOpp c -> f y x = c.
  Proof.
    intros. rewrite Hf_sym. rewrite CompOpp_move. assumption.
  Qed.

  Hint Resolve Hf_sym' : lex.

  Lemma lex_trans c x1 x2 x3 y1 y2 y3:
    lex (f x1 x2) (g y1 y2) = c ->
    lex (f x2 x3) (g y2 y3) = c ->
    lex (f x1 x3) (g y1 y3) = c.
  Proof.
    Ltac finish :=
      repeat match goal with
               | H : ?x = ?y, H' : ?x = ?z |- _ => constr_eq y z; clear H'
               | H : ?x = ?y, H' : ?x = ?z |- _ =>
                 rewrite H in H'; discriminate
             end; simpl; try eauto with lex.

    repeat match goal with
               |- context [f ?x ?y] => case_eq (f x y); intros ?
             | |- context [f ?x ?y] => case_eq (g x y); intros ?
             | H : f ?x ?y = _, H' : f ?y ?x = _ |- _ =>
               rewrite Hf_sym, H' in H; simpl in H; clear H'; try discriminate
             | H : f ?x ?y = _, H' : f ?y ?z = _ |- _ =>
               pose proof (Hf_trans _ _ _ _ H H'); clear H H'
           end; finish.

    assert (f x2 x3 = Eq) by eauto with lex; finish.
    assert (f x1 x2 = Gt) by eauto with lex; finish.
    assert (f x2 x3 = Eq) by eauto with lex; finish.
    assert (f x1 x2 = Lt) by eauto with lex; finish.
    assert (f x1 x2 = Eq) by eauto with lex; finish.
    assert (f x2 x3 = Gt) by eauto with lex; finish.
    congruence.
    assert (f x1 x2 = Eq) by eauto with lex; finish.
    assert (f x2 x3 = Lt) by eauto with lex; finish.
    congruence.
  Qed.
End t.


Require Export VST.floyd.sublist.
Require Export Integers.
Require Export Coqlib.
Require Export List. Import ListNotations.
Require Export aes.sbox.

(* substitute b for its counterpart in the sbox *)
Definition look_sbox (b: int) : int :=
  (* All possible values of b are covered in the sbox so the default should never be returned *)
  Int.repr (Znth (Int.unsigned b) sbox 0).

(* substitute b for its counterpart in the inverse sbox *)
Definition look_inv_sbox (b: int) : int :=
  Int.repr (Znth (Int.unsigned b) inv_sbox 0).

(********************* GF(256) arithmetic *******************)

(* xtime operation from section 4.2.1. Corresponds to multiplying by 2 in GF(256) *)
Definition xtime (b: int) : int :=
  let b' := Int.modu (Int.shl b (Int.one)) (Int.repr 256) in (* shift left by one, mod 256 *)
  let c_1b := Int.repr 27 in (* 0x1b *)
  let c_80 := Int.repr 128 in (* 0x80 *)
  (* test if highest bit of b is one. If so, then XOR b' with 0x1b, otherwise return b' *)
  if Int.eq (Int.and b c_80) Int.zero then b'
  else Int.xor b' c_1b.

(* Finite field multiplication using xtime operation and xor for finite field addition
 * (Russian peasant multiplication), not described directly but suggested in section 4.2.1. *)

(* Repeatedly double b using xtime as per Russian peasant multiplication. Add b to accumulator
 * if there is a "remainder," i.e., the tested bit of a is 1 *)
Definition ff_checkbit (a b : int) (acc : int) : int :=
  (* if lowest bit of a is one, add (xor) b to acc. Otherwise do nothing *)
  if Int.eq (Int.and a Int.one) Int.zero then acc
  else Int.xor acc b.

Fixpoint xtime_test (a b : int) (acc : int) (shifts : nat) : int :=
  if Int.eq a Int.zero then acc (* if a or b are zero, nothing to do *)
  else if Int.eq b Int.zero then acc
  else
    (* check lowest bit of a, add b to acc if it is positive. Shift a
     * right for next iteration unless we're finished *)
    match shifts with
    | S n =>
      let acc' := ff_checkbit a b acc in
      (* shift a right and double b *)
      let a' := Int.shru a Int.one in
      let b' := xtime b in
      xtime_test a' b' acc' n
    | O => acc
    end.

Definition ff_mult (a b : int) : int := xtime_test a b Int.zero 8%nat.

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

(* Defining words and state as they are considered in the specification, using tuples
 * to enforce the length requirement -- a word is 4 bytes, while a state is 4 words,
 * illustrated as 4 rows of 4 bytes *)
Definition word := (int * int * int * int) % type.
Definition state := (word * word * word * word) % type.
Definition block := state%type. (* Used synonymously with state in the spec, aliased here for readability *)

(* SubBytes() transformation described in section 5.1.1 *)
Definition sub_word (w: word) : word :=
  match w with (b1, b2, b3, b4) => (look_sbox b1, look_sbox b2, look_sbox b3, look_sbox b4) end.
Definition SubBytes (s: state) : state :=
  match s with (w1, w2, w3, w4) => (sub_word w1, sub_word w2, sub_word w3, sub_word w4) end.

(* ShiftRows() transformation described in section 5.1.2 *)
Definition ShiftRows (s : state) : state :=
  match s with
  ((b11, b12, b13, b14),
   (b21, b22, b23, b24),
   (b31, b32, b33, b34),
   (b41, b42, b43, b44)) =>

  ((b11, b12, b13, b14),
   (b22, b23, b24, b21),
   (b33, b34, b31, b32),
   (b44, b41, b42, b43))
  end.

(* MixColumns() transformation described in section 5.1.3 *)

Definition transform_column (col: word) : word :=
  match col with (b1, b2, b3, b4) =>
    let two := Int.repr 2 in
    let three := Int.repr 3 in
    (* (2*b1)^(3*b2)^b3^b4 *)
    let c0 := Int.xor (Int.xor (ff_mult two b1) (ff_mult three b2)) (Int.xor b3 b4) in
    (* b1^(2*b2)^(3*b3)^b4 *)
    let c1 := Int.xor (Int.xor b1 (ff_mult two b2)) (Int.xor (ff_mult three b3) b4) in
    (* b1^b2^(2*b3)^(3*b4)*)
    let c2 := Int.xor (Int.xor b1 b2) (Int.xor (ff_mult two b3) (ff_mult three b4)) in
    (* (3*b1)^b2^b3^(2*b4)*)
    let c3 := Int.xor (Int.xor (ff_mult three b1) b2) (Int.xor b3 (ff_mult two b4)) in
    (c0, c1, c2, c3)
  end.

(* lets us treat state by columns rather than rows *)
Definition transpose (s: state) : state :=
  match s with
   ((b11, b12, b13, b14),
    (b21, b22, b23, b24),
    (b31, b32, b33, b34),
    (b41, b42, b43, b44)) =>

   ((b11, b21, b31, b41),
    (b12, b22, b32, b42),
    (b13, b23, b33, b43),
    (b14, b24, b34, b44))
end.

(* apply column transformation to each column in the state *)
Definition MixColumns (s: state) : state :=
  let cols := transpose s in
  match cols with (c1, c2, c3, c4) =>
    transpose (transform_column c1, transform_column c2, transform_column c3, transform_column c4)
  end.

(* Key expansion functions, section 5.2 *)

(* SubWord function from section 5.2: apply S-box to each byte in a word *)
Definition SubWord (w: word) : word :=
  match w with (b1, b2, b3, b4) => (look_sbox b1, look_sbox b2, look_sbox b3, look_sbox b4) end.

(* RotWord function from section 5.2: rotate bytes left, wrapping around *)
Definition RotWord (w: word) : word :=
  match w with (b1, b2, b3, b4) => (b2, b3, b4, b1) end.

(* round constant (RCon) array, described in section 5.2 and explicitly written
 * out in appendix A.3 (256-bit key expansion example) *)
Definition RCon : list word := [
  (* 0x01000000 *) (Int.repr 1, Int.zero, Int.zero, Int.zero);
  (* 0x02000000 *) (Int.repr 2, Int.zero, Int.zero, Int.zero);
  (* 0x04000000 *) (Int.repr 4, Int.zero, Int.zero, Int.zero);
  (* 0x08000000 *) (Int.repr 8, Int.zero, Int.zero, Int.zero);
  (* 0x10000000 *) (Int.repr 16, Int.zero, Int.zero, Int.zero);
  (* 0x20000000 *) (Int.repr 32, Int.zero, Int.zero, Int.zero);
  (* 0x40000000 *) (Int.repr 64, Int.zero, Int.zero, Int.zero)
].

(* For AES-256, figure 4 fixes the key length in words at 8 and the number
 * of rounds at 14 *)
Definition Nk := 8. (* number of words in key *)
Definition Nr := 14. (* number of cipher rounds *)
Definition Nb := 4. (* number of words in a block (state) *)

(* xor two words together, i.e., apply xor byte by byte *)
Definition xor_word (w1 w2 : word) : word :=
  match w1, w2 with (b1, b2, b3, b4), (b1', b2', b3', b4') =>
    (Int.xor b1 b1', Int.xor b2 b2', Int.xor b3 b3', Int.xor b4 b4')
  end.

(* Expanded key is Nb*(Nr+1) words, or Nr+1 blocks *)
Definition extended_key_blocks := Nr+1.

(* Based on Figure 11 and diagram in appendex A.3 *)

(* Note that "even" and "odd" are if you start counting blocks at 1, rather than 0 *)
(* b1 and b2 are the two blocks generated before this round. *)
Definition odd_round (b1 b2 : block) (rcon: word) : block :=
  match b1, b2 with (w1, w2, w3, w4), (_, _, _, w8) =>
    let w1' := xor_word w1 (xor_word (SubWord (RotWord w8)) rcon) in
    let w2' := xor_word w2 w1' in
    let w3' := xor_word w3 w2' in
    let w4' := xor_word w4 w3' in
    (w1', w2', w3', w4')
  end.
Definition even_round (b1 b2: block) : block :=
  match b1, b2 with (w1, w2, w3, w4), (_, _, _, w8) =>
    let w1' := xor_word w1 (SubWord w8) in
    let w2' := xor_word w2 w1' in
    let w3' := xor_word w3 w2' in
    let w4' := xor_word w4 w3' in
    (w1', w2', w3', w4')
  end.

Fixpoint grow_key (b1 b2: block) (rcs: list word) : list block :=
  match rcs with
  | rc :: [] =>
    (* for the last round constant, only apply an odd round *)
    (odd_round b1 b2 rc) :: []
  | rc :: tl =>
    (* generate a block with an odd round, use it in the next even round and keep going *)
    let b3 := odd_round b1 b2 rc in
	let b4 := even_round b2 b3 in
	b3 :: b4 :: (grow_key b3 b4 tl)
  | [] => [] (* should not happen *)
  end.

(* Note that RCon list (round constants) is described in section 5.2 and its values are given in A.3.
 * k should be a list of words of length Nk. Returns a list of blocks of length Nr+1 *)
Definition KeyExpansion (k : list word) : list block :=
  match k with
  | [w1; w2; w3; w4; w5; w6; w7; w8] =>
    let b1 := (w1, w2, w3, w4) in
	let b2 := (w5, w6, w7, w8) in
	b1 :: b2 :: (grow_key b1 b2 RCon)
  | l => [] (* should not happen *)
  end.

(* AddRoundKey() described in section 5.1.4: it uses a block from the expanded key, xoring
 * each word from the expanded key block with a column from the state *)
Definition AddRoundKey (s : state) (kb : block) : state :=
  let cols := transpose s in
  match cols, kb with (c1,c2,c3,c4), (k1,k2,k3,k4) =>
    transpose (xor_word c1 k1, xor_word c2 k2, xor_word c3 k3, xor_word c4 k4)
  end.

(* Based on figure 5, description of the cipher *)
Definition round (s : state) (kb: block) : state :=
  AddRoundKey (MixColumns (ShiftRows (SubBytes s))) kb.
(* omits mix columns step *)
Definition last_round (s : state) (kb : block) : state :=
  AddRoundKey (ShiftRows (SubBytes s)) kb.

(* Applies cipher rounds given an expanded key *)
Fixpoint apply_rounds (s : state) (ek: list block) : state :=
  match ek with
  | rk :: [] => last_round s rk (* last round *)
  | rk :: tl => apply_rounds (round s rk) tl
  | [] => s (* should not happen *)
  end.

(* exp_key should be length Nr+1 blocks, produced by applying KeyExpansion on a valid key. *)
Definition Cipher (exp_key : list block) (init : state) : state :=
  match exp_key with
  | k1 :: tl =>
    let r1 := AddRoundKey init k1 in
	apply_rounds r1 tl
  | [] => init (* should not happen *)
  end.

(* Inverse cipher and inverse operations -- section 5.3 *)

(* InvShiftRows in section 5.3.1 *)
Definition InvShiftRows (s: state) : state :=
  match s with
    ((b11, b12, b13, b14),
     (b21, b22, b23, b24),
	 (b31, b32, b33, b34),
	 (b41, b42, b43, b44)) =>

	((b11, b12, b13, b14),
	 (b24, b21, b22, b23),
	 (b33, b34, b31, b32),
	 (b42, b43, b44, b41))
  end.

(* InvSubBytes in section 5.3.2 *)
Definition inv_sub_word (w: word) : word :=
  match w with (b1, b2, b3, b4) =>
    (look_inv_sbox b1, look_inv_sbox b2, look_inv_sbox b3, look_inv_sbox b4)
  end.

Definition InvSubBytes (s : state) : state :=
  match s with (w1, w2, w3, w4) =>
    (inv_sub_word w1, inv_sub_word w2, inv_sub_word w3, inv_sub_word w4)
  end.

(* InvMixColumns in 5.3.3 *)
Definition inv_transform_column (w: word) : word :=
  let c_e := Int.repr 14 in (* 0x0e *)
  let c_b := Int.repr 11 in (* 0x0b *)
  let c_d := Int.repr 13 in (* 0x0d *)
  let c_9 := Int.repr 9 in (* 0x09 *)
  match w with (b1, b2, b3, b4) =>
    (* (0x0e * b1) ^ (0x0b * b2) ^ (0x0d * b3) ^ (0x09 * b4) *)
    let b1' := Int.xor (Int.xor (ff_mult c_e b1) (ff_mult c_b b2)) (Int.xor (ff_mult c_d b3) (ff_mult c_9 b4)) in
    (* (0x09 * b1) ^ (0x0e * b2) ^ (0x0b * b3) ^ (0x0d * b4) *)
    let b2' := Int.xor (Int.xor (ff_mult c_9 b1) (ff_mult c_e b2)) (Int.xor (ff_mult c_b b3) (ff_mult c_d b4)) in
    (* (0x0d * b1) ^ (0x09 * b2) ^ (0x0e * b3) ^ (0x0b * b4) *)
    let b3' := Int.xor (Int.xor (ff_mult c_d b1) (ff_mult c_9 b2)) (Int.xor (ff_mult c_e b3) (ff_mult c_b b4)) in
    (* (0x0b * b1) ^ (0x0d * b2) ^ (0x09 * b3) ^ (0x0e * b4) *)
    let b4' := Int.xor (Int.xor (ff_mult c_b b1) (ff_mult c_d b2)) (Int.xor (ff_mult c_9 b3) (ff_mult c_e b4)) in
    (b1', b2', b3', b4')
  end.

Definition InvMixColumns (s : state) : state :=
  let cols := transpose s in
  match cols with (c1, c2, c3, c4) =>
    transpose (inv_transform_column c1, inv_transform_column c2, inv_transform_column c3, inv_transform_column c4)
  end.

(* applies InvMixColumns to all members of expanded key but the last *)
Fixpoint grow_inv_key (ek : list block) : list block :=
  match ek with
  | rk :: [] => rk :: [] (* don't do anything to last one *)
  | rk :: tl => InvMixColumns rk :: grow_inv_key tl
  | [] => [] (* should not happen *)
  end.

(* Inverse key expansion briefly described at end of figure 15. k should be of length Nk. *)
Definition InverseKeyExpansion (k : list word) : list block :=
  let exp_key := KeyExpansion k in
  match exp_key with
  (* don't apply inv mix columns to first round key either *)
  | k1 :: tl => k1 :: grow_inv_key tl
  | ek => [] (* should not happen *)
  end.

(* Inverse cipher described in figure 15 *)
Definition inv_round (s : state) (kb : block) : state :=
  AddRoundKey (InvMixColumns (InvShiftRows (InvSubBytes s))) kb.
(* omits mix columns *)
Definition inv_last_round (s : state) (kb : block) : state :=
  AddRoundKey (InvShiftRows (InvSubBytes s)) kb.

Fixpoint apply_inv_rounds (s: state) (ek: list block) : state :=
  match ek with
  | kb :: [] => inv_last_round s kb
  | kb :: tl => apply_inv_rounds (inv_round s kb) tl
  | [] => s (* should not happen *)
  end.

(* exp_key should be length Nr+1 blocks, produced by applying InverseKeyExpansion on a valid
 * key and reversing the result, since the round keys are supposed to be applied starting with
 * the last. (We pass the key in this way for simplifying verification, since the implementation's
 * key expansion process also reverses the key, whereas the specification reverses it during the
 * decryption process) *)
Definition EqInvCipher (exp_key: list block) (init: state) : state :=
  match exp_key with
  | kb :: tl => apply_inv_rounds (AddRoundKey init kb) tl
  | l => init (* should not happen *)
  end.


Require Import Coq.Arith.PeanoNat.
Open Scope nat_scope.

Require Import Monad.
Import Notations.
Open Scope monad_scope.

Require Import List.
Import ListNotations.
Open Scope list_scope.

Require Export Coq.Sets.Ensembles.
Require Import Setoid.

(** * Decidable equality

Equality is decidable for a type [A] if there is a procedure such that, for any
two elements [a b : A], produces either (1) a proof that [a] equals [b], or (2)
a proof that [a] does not equal [b].

Equality is not decidable for every type [A]; for example, the type of real
numbers is not decidable, but all finite types and most simple inductive types
are decidable.

Types that are decidable can be given instances of the class [eq_dec A]. When
such a type is decidable, the expression [a =? b] is a boolean that can be used
e.g. in an [if] statement: [if a =? b then X else Y]. *)
Class eq_dec A := { Dec : forall (a b : A), {a = b} + {a <> b} }.
Definition eqb {A} `{eq_dec A} (a b : A) : bool :=
  if Dec a b then true else false.
Infix "=?" := eqb.

(** ** Some lemmas about decidable equality *)
Lemma eqb_eq : forall A `{eq_dec A} (a : A), a =? a = true.
Proof. intros. unfold eqb. destruct (Dec a a); auto. Qed.
Lemma eqb_eq' : forall A `{eq_dec A} (a b : A), a = b -> (a =? b) = true.
Proof. intros. unfold eqb. destruct (Dec a b); auto. Qed.
Lemma eqb_neq : forall A `{eq_dec A} (a b : A), a <> b -> a =? b = false.
Proof. intros. unfold eqb. destruct (Dec a b); auto. contradiction. Qed.

(** ** Instances of decidable equality *)
Instance eq_dec_bool : eq_dec bool.
Proof.
  split. intros [ | ] [ | ]; try (right; inversion 1; fail); try (left; auto; fail).
Defined.

Instance nat_eq_dec : eq_dec nat.
Proof.
  constructor.
  intros x;
  induction x as [ | x]; intros [ | y]; auto.
  destruct (IHx y) as [IHxy | IHxy]; subst; auto.
Defined.

Instance prod_eq_dec {A B} `{eq_dec A} `{eq_dec B} : eq_dec (A*B).
Proof.
  split. intros [a b] [a' b'].
  destruct (Dec a a'); destruct (Dec b b');
    subst; auto;
    right; inversion 1; contradiction.
Defined.

Instance option_eq_dec {A} `{eq_dec A} : eq_dec (option A).
Proof.
  constructor.
  intros [a | ] [b | ];
    try (left; reflexivity);
    try (right; discriminate).
  destruct (Dec a b); subst;
    try (left; reflexivity);
    try (right; inversion 1; contradiction).
Defined.

(** ** Decidable list inclusion

If a type [A] is decidable, then we can also decide whether an element [a] is an
element of a list [ls] of [A]s. This is written [a ∈? ls]. *)

Fixpoint in_list_dec {A} `{eq_dec A} (a : A) (ls : list A) : bool :=
  match ls with
  | [] => false
  | b :: ls' => if a =? b then true else in_list_dec a ls'
  end.
Notation "a ∈ ls" := (in_list_dec a ls = true) (no associativity, at level 90).
Notation "a ∈? ls" := (in_list_dec a ls) (no associativity, at level 90).

(** * Snoc/tail lists

A tail_list is just an ordinary list that is interpreted "backward". In this
development we use it for traces where a trace [t ▶ e] consists of the trace [t]
followed by the event [e].

*)

Inductive tail_list (A : Type) :=
| t_empty : tail_list A
| t_next : tail_list A -> A -> tail_list A.
Arguments t_empty {A}.
Arguments t_next {A}.
Infix "▶" := t_next (left associativity, at level 73).

(** * Ensemble notation

An [Ensemble A] in Coq represents a mathematical set with elements of the type
[A]. [Ensemble]s are defined in the Coq standard library but are not computable,
so we introduce the standard unicode notations below, including [X == Y] to mean
that the sets [X] and [Y] have the same elements.

 *)
Module EnsembleNotation.
  Notation "x ∈ X" := (In _ X x) : ensemble_scope.
  Notation "X ∪ Y" := (Union _ X Y) (at level 50) : ensemble_scope.
  Notation "X ∩ Y" := (Intersection _ X Y) (at level 50) : ensemble_scope.
  Notation "X ⊥ Y" := (Disjoint _ X Y) (at level 90) : ensemble_scope.
  Notation "X ∖ Y" := (Setminus _ X Y) (at level 40) : ensemble_scope.
  Notation "X ⊆ Y" := (Included _ X Y) (at level 80) : ensemble_scope.
  Notation "X == Y" := (Same_set _ X Y) (at level 90) : ensemble_scope.
  Notation "∅" := (Empty_set _) : ensemble_scope.
  Notation "⊤" := (fun _ => True) : ensemble_scope.
  Definition singleton {X} (x : X) : Ensemble X := Singleton X x.
  Notation "x ∉ X" := (~(In _ X x)) (at level 70) : ensemble_scope.

  (** ** Decidable set inclusion *)
  Open Scope ensemble_scope.
  Class in_dec {Z} (X : Ensemble Z) := {In_Dec : forall (x:Z), {x ∈ X} + {~(x ∈ X)}}.
  Arguments In_Dec {Z} X {in_dec} : rename.
  Notation "x ∈? X" := (In_Dec X x) : ensemble_scope.

  Instance in_dec_singleton {X} `{eq_dec X} {x : X} : in_dec (singleton x).
  Proof.
    constructor.
    intros y.
    destruct (Dec x y).
    - left. subst. constructor.
    - right. inversion 1; contradiction.
  Defined.
  Instance in_dec_union : forall A (X Y : Ensemble A), in_dec X -> in_dec Y -> in_dec (X ∪ Y).
  Proof.
    intros A X Y HX HY.
    constructor; intros z.
    destruct (@In_Dec _ X HX z); [ left; auto with sets | ].
    destruct (@In_Dec _ Y HY z); [ left; auto with sets | ].
    right. intros Hz.
    inversion Hz; contradiction.
  Qed.
  Instance in_dec_intersect : forall A (X Y : Ensemble A), in_dec X -> in_dec Y -> in_dec (X ∩ Y).
  Proof.
    intros A X Y HX HY.
    constructor; intros z.
    destruct (In_Dec X z); [ | right; inversion 1; contradiction].
    destruct (In_Dec Y z); [ | right; inversion 1; contradiction].
    left; auto with sets.
  Qed.
  Instance in_dec_setminus : forall A (X Y : Ensemble A), in_dec X -> in_dec Y -> in_dec (X ∖ Y).
  Proof.
    intros A X Y HX HY.
    constructor; intros z.
    destruct (In_Dec X z); [ | right; inversion 1; contradiction].
    destruct (In_Dec Y z); [ right; inversion 1; contradiction |].
    left; auto with sets.
  Qed.
  Instance in_dec_empty : forall A, in_dec (Empty_set A).
  Proof.
    intros A.
    constructor; intros x.
    right. inversion 1.
  Qed.
(*  Hint Resolve in_dec_singleton in_dec_union in_dec_intersect in_dec_setminus in_dec_singleton in_dec_empty : sets.*)

  (** ** Ensembles as a setoid *)

  Lemma Included_refl : forall A (X : Ensemble A), X ⊆ X.
  Proof.
    intros A X. intros x Hx; auto.
  Qed.
  Lemma Included_trans : forall A (X Y Z : Ensemble A), X ⊆ Y -> Y ⊆ Z -> X ⊆ Z.
  Proof.
    intros A X Y Z HXY HYZ x HX.
    apply HYZ. apply HXY. auto.
  Qed.

  Add Parametric Relation A : (Ensemble A) (Included A)
    reflexivity proved by (Included_refl A)
    transitivity proved by (Included_trans A)
    as subset_ensemble_rel.

  Lemma Same_set_refl : forall A (X : Ensemble A), X == X.
  Proof.
    intros A X. split; reflexivity.
  Qed.
  Lemma Same_set_symm : forall A (X Y : Ensemble A), X == Y -> Y == X.
  Proof.
    intros A X Y [HXY HYX]. split.
    * intros y Hy. apply HYX. auto.
    * intros x Hx. apply HXY. auto.
  Qed.
  Lemma Same_set_trans : forall A (X Y Z : Ensemble A), X == Y -> Y == Z -> X == Z.
  Proof.
    intros A X Y Z [HXY HYX] [HYZ HZY].
    split; transitivity Y; auto.
  Qed.

  Add Parametric Relation A : (Ensemble A) (Same_set A)
    reflexivity proved by (Same_set_refl A)
    symmetry proved by (Same_set_symm A)
    transitivity proved by (Same_set_trans A)
    as eq_ensemble_rel.

  Add Parametric Morphism A : (Included A)
    with signature (Same_set A) ==> (Same_set A) ==> iff as subset_mor.
  Proof.
    intros X Y [HXY HYX] X' Y' [HXY' HYX'].
    split; intros H.
    * intros y Hy. apply HXY'. apply H. apply HYX. assumption.
    * intros x HX. apply HYX'. apply H. apply HXY. assumption.
  Qed.

  Add Parametric Morphism A : (In A)
    with signature (Same_set A) ==> (@eq A) ==> iff as in_mor.
  Proof.
    intros X Y [HXY HYX] a.
    split; intros Ha.
    * apply HXY; auto.
    * apply HYX; auto.
  Qed.

  Add Parametric Morphism A : (Union A)
    with signature (Same_set A) ==> (Same_set A) ==> (Same_set A) as union_mor.
  Proof.
    intros X Y HXY X' Y' HXY'.
    split.
    * intros x Hx. inversion Hx; subst; clear Hx.
      + left. rewrite <- HXY. auto.
      + right. rewrite <- HXY'. auto.
    * intros x Hx. inversion Hx; subst; clear Hx.
      + left. rewrite HXY. auto.
      + right. rewrite HXY'. auto.
  Qed.

  Add Parametric Morphism A : (Intersection A)
    with signature (Same_set A) ==> (Same_set A) ==> (Same_set A) as intersection_mor.
  Proof.
    intros X Y HXY X' Y' HXY'.
    split.
    * intros x Hx. inversion Hx; subst; clear Hx.
      split.
      + rewrite <- HXY. auto.
      + rewrite <- HXY'. auto.
    * intros x Hx. inversion Hx; subst; clear Hx.
      split.
      + rewrite HXY. auto.
      + rewrite HXY'. auto.
  Qed.

  Add Parametric Morphism A : (Disjoint A)
    with signature (Same_set A) ==> (Same_set A) ==> iff as disjoint_mor.
  Proof.
    intros X Y HXY X' Y' HXY'.
    split; intros [Hdisjoint]; constructor; intros x.
    * rewrite <- HXY, <- HXY'. auto.
    * rewrite HXY, HXY'. auto.
  Qed.

  Add Parametric Morphism A : (Setminus A)
    with signature (Same_set A) ==> (Same_set A) ==> (Same_set A) as setminus_mor.
  Proof.
    intros X Y HXY X' Y' HXY'.
    split; intros x [Hx Hx'].
    * split; [rewrite <- HXY; auto | rewrite <- HXY'; auto].
    * split; [rewrite HXY; auto | rewrite HXY'; auto].
  Qed.

  (** ** Helper lemmas *)
  Lemma Setminus_in : forall {A} x (X Y : Ensemble A),
      x ∈ X ∖ Y ->
      x ∈ X.
  Proof.
    intros A x X Y H.
    inversion H; auto.
  Qed.
  Lemma Setminus_not_in : forall {A} x (X Y : Ensemble A),
      x ∈ X ∖ Y ->
      ~(x ∈ Y).
  Proof.
    intros A x X Y H.
    inversion H; auto.
  Qed.
  Hint Resolve Setminus_in Setminus_not_in : sets.

  Lemma not_union_1 : forall {A} (x : A) X Y,
      ~(x ∈ X ∪ Y) ->
      ~(x ∈ X).
  Proof.
    intros A x X Y Hunion HX.
    apply Hunion.
    left.
    assumption.
  Qed.
  Lemma not_union_2 : forall {A} (x : A) X Y,
      ~(x ∈ X ∪ Y) ->
      ~(x ∈ Y).
  Proof.
    intros A x X Y Hunion HX.
    apply Hunion.
    right.
    assumption.
  Qed.
  Hint Resolve not_union_1 not_union_2 : sets.

  Lemma not_in_singleton_neq : forall {A} (x y : A),
      ~(x ∈ singleton y) <->
      x <> y.
  Proof.
    intros x y. split.
    * intros H_x_y x_y.
      apply H_x_y.
      subst.
      auto with sets.
    * intros x_neq_y.
      inversion 1.
      subst.
      contradiction.
  Qed.
  Hint Resolve not_in_singleton_neq : sets.

  Lemma not_in_setminus : forall {A} (x : A) (X Y : Ensemble A) `{in_dec _ Y},
      x ∉ (X ∖ Y) ->
      (x ∈ Y) \/ x ∉ X.
  Proof.
    intros A x X Y decY Hin.
    destruct (x ∈? Y).
    - left. assumption.
    - right. intro x_in_X.
      apply Hin.
      constructor; auto.
  Qed.

  Lemma in_Y_not_in_setminus_X_Y : forall {A} (x : A) (X Y : Ensemble A),
      (x ∈ Y) ->
      x ∉ (X ∖ Y).
  Proof.
    intros A x X Y HY Hsetminus.
    inversion Hsetminus; contradiction.
  Qed.

  Lemma not_in_X_not_in_setminus_X_Y : forall {A} (x : A) (X Y : Ensemble A),
      x ∉ X ->
      x ∉ (X ∖ Y).
  Proof.
    intros A x X Y HX Hsetminus.
    inversion Hsetminus; contradiction.
  Qed.

  Lemma not_in_union : forall {A} (x : A) X Y,
      x ∉ X ∪ Y <->
      x ∉ X /\ x ∉ Y.
  Proof.
    intros A x X Y.
    split.
    - intros Hunion. split.
      * intros HX. apply Hunion. left. assumption.
      * intros HY. apply Hunion. right. assumption.
    - intros [HX HY] Hunion.
      inversion Hunion; subst; contradiction.
  Qed.

  (** ** Convert from lists to ensembles *)
  Fixpoint from_list {A} (l : list A) : Ensemble A :=
    match l with
    | nil => ∅
    | x :: l' => singleton x ∪ from_list l'
    end.
  Instance from_list_in_dec {A} `{eq_dec A} (l : list A) : in_dec (from_list l).
  Proof.
    constructor. intros a.
    induction l.
    * right. inversion 1.
    * destruct (Dec a a0) as [Heq | Hneq].
      + subst. left. constructor. constructor.
      + destruct IHl as [IHl | IHl].
        ++ left. right. auto.
        ++ right. simpl.
           apply not_in_union.
           split; auto.
           inversion 1; subst; contradiction.
  Defined.

  Lemma from_list_app : forall {X} (l1 l2 : list X),
    from_list (l1 ++ l2) == from_list l1 ∪ from_list l2.
  Proof.
    induction l1; intros; simpl.
    * split; intros x Hx.
      { right; assumption. }
      { inversion Hx; subst.
        + inversion H.
        + assumption.
      }
    * rewrite IHl1.
      split; intros x Hx.
      { inversion Hx as [? Hx' | ? Hx' ]; subst; clear Hx.
        { inversion Hx'; subst. left. left. assumption. }
        { inversion Hx' as [? Hx'' | ? Hx'']; subst; clear Hx'.
          { left. right. assumption. }
          { right. assumption. }
        }
      }
      { inversion Hx as [? Hx' | ? Hx' ]; subst; clear Hx.
        { inversion Hx'; subst.
          { left. assumption. }
          { right. left. assumption. }
        }
        { right. right. assumption. }
      }
  Qed.

  Lemma setminus_union_equiv : forall {X} (A B : Ensemble X) `{in_dec X B},
    (A ∖ B) ∪ B == A ∪ B.
  Proof.
    intros X A B Bdec. split; intros x Hx.
    + inversion Hx as [? HA | HB]; subst.
      { inversion HA as [HA' _].
        left. auto.
      }
      { right. auto. }

    + destruct (In_Dec B x) as [HB | HB].
      { right. auto. }
      inversion Hx as [? HA | ? HB']; subst.
      { left. constructor; auto. }
      { right. auto. }
  Qed.

  (** The [all_disjoint ls] predicate asserts that every element of the list
  [ls] is disjoint from every other elemenet of the list [ls]. *)
  Inductive all_disjoint {A} : list A -> Prop :=
  | nil_disjoint : all_disjoint []
  | cons_disjoint x ls :
      x ∉ from_list ls ->
      all_disjoint ls ->
      all_disjoint (x::ls).

  Class enumerable {A} (X : Ensemble A) :=
    { enumerate : list A
    ; rewrite_enumerate : X == from_list enumerate
    }.
  Arguments enumerate {A} X {enumX} : rename.
  Instance singleton_enumerable {X} : forall (x : X), enumerable (singleton x).
  Proof. intros x. exists [x]. simpl.
    split; intros y Hy.
    * constructor; auto.
    * inversion Hy; subst; auto.
      inversion H.
  Defined.
  Instance from_list_enumerable {X} : forall (l : list X), enumerable (from_list l).
  Proof.
    intros l. exists l. reflexivity.
  Defined.

  Instance union_enumerable {A} (X Y : Ensemble A) :
    enumerable X ->
    enumerable Y ->
    enumerable (X ∪ Y).
  Proof.
    intros [Xl HX] [Yl HY].
    exists (Xl ++ Yl).
    rewrite HX, HY.
    rewrite from_list_app.
    reflexivity.
  Defined.

  Instance enum_in_dec : forall {A} `{eq_dec A} (X : Ensemble A) `{enumerable _ X}, in_dec X.
  Proof.
    intros ? ? X [Xl Hl].
    constructor; intros x.
    destruct (x ∈? from_list Xl).
    + left. rewrite Hl; auto.
    + right. rewrite Hl; auto.
  Defined.

End EnsembleNotation.

(** * Tactics *)

(** ** Inversion *)
Ltac inversion_In :=
  repeat match goal with
  | [ H : In _ [ _ ] |- _ ] => inversion H; subst; clear H
  | [ H : In _ [] |- _ ] => inversion H
  | [ H : In _ (flat_map _ _) |- _ ] => apply in_flat_map in H; destruct H as [? ?]
  | [ H : _ * _ |- _ ] => destruct H as [? ?]
  | [ H : _ /\ _ |- _ ] => destruct H as [? ?]
  | [ H : (_ , _) = (_, _) |- _] => inversion H; subst; clear H
  end.

Ltac case_In :=
  match goal with
  | [ H : In _ [ _ ] |- _ ] => inversion H as [ | H0]
  | [ H : In _ [] |- _ ] => inversion H
  | [ H : In _ (_ :: _) |- _ ] => destruct H as [? | ?]

  | [ H : In _ (_ ++ _) |- _ ] => apply in_app_or in H; destruct H as [H | H]
  end; inversion_In.

Import EnsembleNotation.

(** ** Contradictions *)

(* First, we find contradictions of the form [all_disjoint ls] where [ls] has
more than one occurrence of the same variable. *)

Fixpoint count {A} `{eq_dec A} (a : A) (ls : list A) : nat :=
  match ls with
  | nil => 0
  | cons b ls' => if a =? b then 1+count a ls'
                       else count a ls'
  end.

Lemma count_1_disjoint_contradiction : forall {A} `{eq_dec A} (a:A) ls,
    count a ls > 0 ->
    ~ all_disjoint (a::ls).
Proof.
  induction ls as [ | b ls']; intros Hcount Hdisjoint; simpl in *.
  * inversion Hcount.
  * destruct (Dec a b); subst.
    + inversion Hdisjoint as [ | ? ? Hcontra ]; subst.
      apply Hcontra. left. auto with sets.
    + inversion Hdisjoint as [ | ? ? Ha Hdisjoint']; subst.
      inversion Hdisjoint'; subst.
      apply IHls'; [rewrite eqb_neq in Hcount; auto | ].
      constructor; auto.
      intros Ha_ls'.
      apply Ha.
      right; auto.
Qed.

Lemma count_disjoint_contradiction : forall {A} `{eq_dec A} (a : A) ls,
    count a ls > 1 ->
    ~ all_disjoint ls.
Proof.
  induction ls as [ | b ls']; intros Hcount.
  * inversion Hcount.
  * simpl in Hcount.
    destruct (Dec a b); [subst; rewrite eqb_eq in Hcount | rewrite eqb_neq in Hcount]; auto.
    + apply count_1_disjoint_contradiction.
      apply Gt.gt_S_n; auto.
    + inversion 1; subst.
      apply IHls'; auto.
Qed.

Ltac find_occurrence x ls :=
  match ls with
  | x :: _ => idtac
  | _ :: ?ls' => find_occurrence x ls'
  end.

Ltac find_repetition ls :=
  match ls with
  | context[ ?x :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)
  | context[ ?x :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: _  :: ?x :: _ ] => constr:(x)

  end.
Lemma reduce_count_cons_eq : forall {A} `{eq_dec A} (x:A) ls n,
    count x ls > n ->
    count x (x :: ls) > S n.
Proof.
    intros A Adec x ls.
    induction ls as [ | a ls]; intros n Hn.
    * simpl in Hn. inversion Hn.
    * simpl in *.
      unfold eqb in *.
      destruct (Dec x x) as [Hx | Hx].
      2:{ contradict Hx; auto. }
      destruct (Dec x a) as [Ha | Ha].
      { apply Gt.gt_n_S; auto. }
      { apply IHls; auto. }
Qed.
Lemma reduce_count_cons_0 : forall  {A} `{eq_dec A} (x:A) ls,
    count x (x :: ls) > 0.
Proof.
  intros. simpl.
  unfold eqb.
  destruct (Dec x x) as [Hx | Hx].
  { apply Gt.gt_Sn_O. }
  { contradict Hx. auto. }
Qed.
Lemma reduce_count_cons_neq : forall  {A} `{eq_dec A} (x y : A) ls n,
    count x ls > n ->
    count x (y :: ls) > n.
Proof.
  intros A Adec x y ls n Hn.
  simpl. unfold eqb.
  destruct (Dec x y) as [Hx | Hx]; [ | auto].
  apply Gt.gt_trans with (m := (count x ls)); auto.
Qed.
Ltac reduce_count :=
  repeat match goal with
  | [ |- count ?x (?x :: _) > S ?n ] => apply reduce_count_cons_eq
  | [ |- count ?x (?x :: _) > 0    ] => apply reduce_count_cons_0
  | [ |- count ?x (?y :: _) > ?n   ] => apply reduce_count_cons_neq
  end.
Ltac all_disjoint_contradiction :=
  repeat match goal with
  (* contradiction *)
  | [ H : all_disjoint ?ls |- _ ] => let x := find_repetition ls in
                                     contradict H;
                                     apply (count_disjoint_contradiction x);
                                     reduce_count
  | [ H : all_disjoint ?ls, Heq : ?x = ?y |- _ ] =>
    rewrite Heq in *;
    clear Heq
  end;
  fail.

(** ** [find_contradiction]

Use when a hypothesis or collection of hypotheses leads to a simple
contradiction about equality, numbers, or set inclusion that can't be solved by
[contradiction].

*)
Ltac find_contradiction :=
  try contradiction;
  try discriminate;
  try match goal with
  | [ H : ?a = _, H' : ?a = _ |- _ ] => rewrite H in H'; discriminate
  | [ H : ?a = _, H' : _ = ?a |- _ ] => rewrite H in H'; discriminate
  | [ H : _ = ?a, H' : ?a = _ |- _ ] => rewrite <- H in H'; discriminate
  | [ H : _ = ?a, H' : _ = ?a |- _ ] => rewrite H in H'; discriminate
  | [ H : ?a = ?b, H' : ?a <> ?b |- _] => rewrite H in H'; contradiction
  | [ H : ?a = ?b, H' : ?b <> ?a |- _] => rewrite H in H'; contradiction
  | [ H : ?x < ?x |- _ ] => apply Nat.lt_irrefl in H; contradiction
  | [ H : ?x > ?x |- _ ] => apply Nat.lt_irrefl in H; contradiction
  | [ H : ~( ?x ∈ singleton ?x ) |- _ ] => contradict H; auto with sets
  | [ H1 : ?x ∈ ?X1, H2 : ?x ∈ ?X2, H : ?X1 ⊥ ?X2 |- _] =>
      absurd (x ∈ X1 ∩ X2); inversion H; auto with sets; fail
  | [ H : all_disjoint ?ls |- _ ] => all_disjoint_contradiction
  end.

(** ** [decompose_set_structure] and [solve_set]

Use [decompose_set_structure] to deconstruct hypotheses about set inclusion into
simpler hypotheses that can be used to automatically solve a goal.

Use [solve_set] to solve goals of the form [?x ∈ ?X]. May need to combine these;
[decompose_set_structure; solve_set].

*)

Ltac my_subst :=
  match goal with
  | [ H : ?x = ?y |- _ ] => replace y with x in * by auto; clear H
  end.

Ltac decompose_set_structure_1 :=
  match goal with
  | [ H : ?x ∉ ∅ |- _ ] => clear H
  | [ H : ?x ∈ ∅ |- _ ] => inversion H
  | [ H : ?x ∈ ?X ∖ ?Y |- _ ] => destruct H
  | [ H : ?x ∈ ?X ∪ ?Y |- _ ] => inversion H; subst; clear H
  | [ H : ?x ∈ ?X ∩ ?Y |- _ ] => inversion H; subst; clear H
  | [ H : ~(?x ∈ ?X ∪ ?Y) |- _] => assert (~(x ∈ X)) by auto with sets;
                                   assert (~(x ∈ Y)) by auto with sets;
                                   clear H
  | [ H : ?x ∉ ?X ∪ ?Y |- _ ] => apply not_in_union in H; destruct H
  | [ H : ?x ∉ singleton ?y |- _ ] => apply not_in_singleton_neq in H
  | [ H : ?x ∈ Couple _ ?y ?z |- _] => inversion H; try subst; clear H
  | [ H : ?x ∈ singleton ?y |- _ ] => inversion H; my_subst; clear H
  | [ H : _ /\ _ |- _ ] => destruct H
  | [ H : exists _, _ |- _ ] => destruct H

(*
  | [ H : all_disjoint [] |- _ ] => clear H
  | [ H : all_disjoint (_ :: _) |- _] => let H' := fresh "H" in
                                         inversion H as [ | ? ? H']; subst;
                                         simpl in H'; clear H
*)
  | [ H : ?x ∈ from_list _ |- _ ] => simpl in H
  | [ H : ?x ∉ ?X ∖ ?Y |- _ ] =>
    apply not_in_setminus in H;
    [destruct H | typeclasses eauto]
  end.
Ltac decompose_set_structure :=
  repeat (decompose_set_structure_1; try find_contradiction; auto with sets).
Ltac deep_decompose_set_structure :=
  repeat (decompose_set_structure;
          try match goal with
          | [ H : _ ∈ _ |- _ ] => inversion H; subst; clear H
          end).

Ltac try_solve_set :=
  repeat (auto with sets;
  match goal with
  | [ |- ?x <> ?y ] => auto; fail
  | [ |- ?x <> ?y ] => intro; my_subst; all_disjoint_contradiction
  | [ |- ?x ∉ singleton ?y ] => apply not_in_singleton_neq; try congruence
  | [ |- ?x ∈ ?X ∖ ?Y ] => constructor
  | [ |- ?x ∈ ?X ∪ ?Y ] => left; try_solve_set; fail
  | [ |- ?x ∈ ?X ∪ ?Y ] => right; try_solve_set; fail
  | [ |- ?x ∈ ?X ∩ ?Y ] => constructor
  | [ |- ?x ∉ ?X ∖ ?Y ] => apply in_Y_not_in_setminus_X_Y; try_solve_set; fail
  | [ |- ?x ∉ ?X ∖ ?Y ] => apply not_in_X_not_in_setminus_X_Y; try_solve_set; fail
  | [ |- ?x ∉ ?X ∪ ?Y ] => apply not_in_union; constructor
  | [ |- ?x ∉ ?X ]      => intro; decompose_set_structure; fail
  | [ |- ?X ⊥ ?Y ]      => constructor; intro
  end).

Ltac solve_set :=
  simpl; try_solve_set; fail.

  Lemma intersection_emptyset : forall {X} (A : Ensemble X),
    ∅ ∩ A == ∅.
  Proof.
    intros. split; intros x Hx; decompose_set_structure.
  Qed.
  Lemma union_emptyset : forall {X} (A : Ensemble X),
    ∅ ∪ A == A.
  Proof.
    intros. split; intros x Hx; decompose_set_structure; solve_set.
  Qed.
  Lemma setminus_emptyset : forall {X} (A : Ensemble X),
    ∅ ∖ A == ∅.
  Proof.
    intros. split; intros x Hx; decompose_set_structure; solve_set.
  Qed.

  Lemma union_symm : forall {X} (A B : Ensemble X),
    A ∪ B == B ∪ A.
  Proof.
    intros. split; intros x Hx; decompose_set_structure; solve_set.
  Qed.
  Lemma intersection_symm : forall {X} (A B : Ensemble X),
    A ∩ B == B ∩ A.
  Proof.
    intros. split; intros x Hx; decompose_set_structure; solve_set.
  Qed.

  Lemma union_emptyset_r : forall {X} (A : Ensemble X),
    A ∪ ∅ == A.
  Proof.
    intros.
    rewrite union_symm. apply union_emptyset.
  Qed.
  Lemma intersection_emptyset_r : forall {X} (A : Ensemble X),
    A ∩ ∅ == ∅.
  Proof.
    intros. rewrite intersection_symm. apply intersection_emptyset.
  Qed.
  Lemma setminus_emptyset_r : forall {X} (A : Ensemble X),
    A ∖ ∅ == A.
  Proof.
    intros. split; intros x Hx; decompose_set_structure; solve_set.
  Qed.

  Lemma union_intersect_distr : forall {X} (A B C : Ensemble X),
    (A ∪ B) ∩ C == (A ∩ C) ∪ (B ∩ C).
  Proof.
    intros. split; intros x Hx; decompose_set_structure; solve_set.
  Qed.

  Lemma union_setminus_distr : forall {X} (A B C : Ensemble X),
    (A ∪ B) ∖ C == (A ∖ C) ∪ (B ∖ C).
  Proof.
    intros; split; intros x Hx; decompose_set_structure; solve_set.
  Qed.

  Lemma singleton_intersection_in : forall {X} (A : Ensemble X) a,
    a ∈ A ->
    singleton a ∩ A == singleton a.
  Proof.
    intros X A a Ha; split; intros x Hx;
    decompose_set_structure.
  Qed.
  Lemma singleton_intersection_not_in : forall {X} (A : Ensemble X) a,
    a ∉ A ->
    singleton a ∩ A == ∅.
  Proof.
    intros X A a Ha; split; intros x Hx;
    decompose_set_structure.
  Qed.
  Lemma singleton_setminus_in : forall {X} (A : Ensemble X) a,
      a ∈ A ->
      singleton a ∖ A == ∅.
    intros X A a Ha; split; intros x Hx;
    decompose_set_structure.
  Qed.
  Lemma singleton_setminus_not_in : forall {X} (A : Ensemble X) a,
      a ∉ A ->
      singleton a ∖ A == singleton a.
    intros X A a Ha; split; intros x Hx;
    decompose_set_structure.
  Qed.

  Lemma not_in_intersection : forall {X} (x : X) A B, x ∉ A \/ x ∉ B -> x ∉ (A ∩ B).
  Proof.
    intros X x A B [H | H]; intros Hx;
    inversion Hx; subst;
       contradiction.
  Qed.

  Lemma subset_union_r : forall {X} (A B : Ensemble X),
    B ⊆ A ->
    A ∪ B == A.
  Proof.
    intros X A B Hsubset.
    split; intros x Hx.
    2:{ left. auto. }
    decompose_set_structure; auto.
  Qed.

Ltac reduce_set_simpl := match goal with
    | [ |- context[ ∅ ∩ ?A ] ] => rewrite (intersection_emptyset A)
    | [ |- context[ ?A ∩ ∅ ] ] => rewrite (intersection_emptyset_r A)
    | [ |- context[ ∅ ∖ ?A ] ] => rewrite (setminus_emptyset A)
    | [ |- context[ ?A ∖ ∅ ] ] => rewrite (setminus_emptyset_r A)
    | [ |- context[ ∅ ∪ ?A ] ] => rewrite (union_emptyset A)
    | [ |- context[ ?A ∪ ∅ ] ] => rewrite (union_emptyset_r A)
    end.

(** ** Tactics for decidable equality

Use [reduce_eqb] to reduce expressions of the form [x =? y] in both the hypotheses and the goal when you know either [x = y] or [x <> y].

Use [compare e1 e2] to apply decidable equality to decide whether [e1] and [e2] are equal.

Use [compare_next] to search for occurrences of [x =? y] in the context and apply [compare e1 e2].

*)
Ltac reduce_eqb :=
  repeat match goal with
  | [ H : context[ ?x =? ?x ] |- _ ] => rewrite eqb_eq in H
  | [ H : context[ ?x1 =? ?x2 ], H' : ?x1 <> ?x2 |- _] => rewrite (eqb_neq _ x1 x2) in H; [ | auto]
  | [ H : context[ ?x1 =? ?x2 ], H' : ?x2 <> ?x1 |- _] => rewrite (eqb_neq _ x1 x2) in H; [ | auto]
  | [ |- context[ ?x =? ?x ] ] => rewrite eqb_eq
  | [ H' : ?x1 <> ?x2 |- context[ ?x1 =? ?x2 ] ] => rewrite (eqb_neq _ x1 x2); [ | auto]
  | [ H' : ?x1 <> ?x2 |- context[ ?x2 =? ?x1 ] ] => rewrite (eqb_neq _ x2 x1); [ | auto]
  | [ H' : ?x1 = ?x2 |- context[ ?x1 =? ?x2 ] ] => rewrite H'
  | [ H' : ?x1 = ?x2 |- context[ ?x2 =? ?x1 ] ] => rewrite H'

  | [ H1 : context[ ?x =? ?y ]
    , H2 : ?x = ?y
    |- _ ] => rewrite (eqb_eq' _ x y) in H1; auto
  | [ H1 : context[ ?x =? ?y ]
    , H2 : ?y = ?x
    |- _ ] => rewrite (eqb_eq' _ x y) in H1; auto
  | [ H2 : ?x = ?y
    |- context[ ?x =? ?y] ] => rewrite (eqb_eq' _ x y); auto
  | [ H2 : ?y = ?x
    |- context[ ?x =? ?y] ] => rewrite (eqb_eq' _ x y); auto
  end; find_contradiction.

Ltac compare e1 e2 :=
  let Heq := fresh "Heq" in
  let Hneq := fresh "Hneq" in
  destruct (Dec e1 e2) as [Heq | Hneq]; [try subst; try (rewrite Heq) | ]; reduce_eqb.

Ltac compare_next :=
    match goal with
    | [ |- context[ eqb ?e1 ?e2 ] ] => let tp := type of e1 in
                                       compare (e1 : tp) (e2 : tp)
    | [ H : context[ eqb ?e1 ?e2 ] |- _ ] => let tp := type of e1 in compare (e1 : tp) (e2 : tp)
    end.

(** ** Convert between x ∈ X and in_list_dec x (enumerate X) *)

Lemma in_list_dec_t {A} `{A_dec : eq_dec A} : forall (x : A) (X : list A),
    in_list_dec x X = true <-> x ∈ from_list X.
Proof.
    induction X; split; simpl; intros H; try (inversion H; fail).
    * compare_next; try solve_set.
      right. apply IHX. auto.
    * compare_next; auto.
      apply IHX.
      decompose_set_structure.
Qed.
Lemma in_list_dec_f {A} `{a_dec : eq_dec A} : forall (x : A) X,
    in_list_dec x X = false <-> x ∉ from_list X.
Proof.
    induction X; split; simpl; intros H; auto; try solve_set.
    * compare_next.
      apply IHX in H.
      solve_set.
    * decompose_set_structure.
      compare_next.
      apply IHX; auto.
Qed.

Ltac from_in_list_dec :=
  repeat match goal with
  | [ H : in_list_dec ?x ?X = true |- _] => apply in_list_dec_t in H
  | [ |- in_list_dec ?x ?X = true ] => apply in_list_dec_t
  | [ H : in_list_dec ?x ?X = false |- _] => apply in_list_dec_f in H
  | [ |- in_list_dec ?x ?X = false ] => apply in_list_dec_f
  end.
Ltac to_in_list_dec :=
  repeat match goal with
  | [ H : ?x ∈ ?X |- _] => apply in_list_dec_t in H
  | [ |- ?x ∈ ?X ] => apply in_list_dec_t
  | [ H : ?x ∉ ?X |- _] => apply in_list_dec_f in H
  | [ |- ?x ∉ ?X ] => apply in_list_dec_f
  end.

  Ltac rewrite_in_list_dec :=
    match goal with
    | [ H : ?x ∈ from_list ?l |- context[ in_list_dec ?x ?l ] ] =>
      replace (in_list_dec x l) with true in *
      by (to_in_list_dec; rewrite H; auto)
    | [ H : ?x ∈ from_list ?l, H' : context[ in_list_dec ?x ?l ] |- _ ] =>
      replace (in_list_dec x l) with true in *
      by (to_in_list_dec; rewrite H; auto)
    | [ H : ?x ∈ ?X |- context[ in_list_dec ?x (enumerate ?X) ] ] =>
      replace (in_list_dec x (enumerate X)) with true in *
      by (rewrite (@rewrite_enumerate _ X) in H;
          to_in_list_dec;
          rewrite H;
          auto)
    | [ H : ?x ∈ ?X, H' : context[ in_list_dec ?x (enumerate ?X) ] |- _ ] =>
      replace (in_list_dec x (enumerate X)) with true in *
      by (rewrite (@rewrite_enumerate _ X) in H;
          to_in_list_dec;
          rewrite H;
          auto)

    | [ H : ?x ∉ from_list ?l |- context[ in_list_dec ?x ?l ] ] =>
      replace (in_list_dec x l) with false in *
      by (to_in_list_dec; rewrite H; auto)
    | [ H : ?x ∉ from_list ?l, H' : context[ in_list_dec ?x ?l ] |- _ ] =>
      replace (in_list_dec x l) with false in *
      by (to_in_list_dec; rewrite H; auto)
    | [ H : ?x ∉ ?X |- context[ in_list_dec ?x (enumerate ?X) ] ] =>
      replace (in_list_dec x (enumerate X)) with false in *
      by (rewrite (@rewrite_enumerate _ X) in H;
          to_in_list_dec;
          rewrite H;
          auto)
    | [ H : ?x ∉ ?X, H' : context[ in_list_dec ?x (enumerate ?X) ] |- _ ] =>
      replace (in_list_dec x (enumerate X)) with false in *
      by (rewrite (@rewrite_enumerate _ X) in H;
          to_in_list_dec;
          rewrite H;
          auto)
    end.

Ltac compare_next_in :=
  match goal with
  | [ |- context[ ?x ∈? ?X ] ] => destruct (x ∈? X)
  | [ H : context[ ?x ∈? ?X ] |- _ ] => destruct (x ∈? X)
  end.
Ltac compare_in_list :=
  match goal with
  | [ |- context[ in_list_dec ?x ?X ] ] =>
    let Hx := fresh "Hx" in
    destruct (in_list_dec x X) eqn:Hx
  end.

  Section IntersectionEnumerable.

    Context {A : Type} `{A_dec : eq_dec A}.
    Definition list_intersection (A B : list A) := filter (fun x => in_list_dec x B) A.

    Lemma list_intersection_equiv : forall (l1 l2 : list A),
      from_list (list_intersection l1 l2) == from_list l1 ∩ from_list l2.
    Proof.
      intros l1 l2.
      unfold list_intersection.
      simpl.
      induction l1.
      * simpl. rewrite intersection_emptyset.
        reflexivity.
      * simpl.
        destruct (in_list_dec a l2) eqn:Ha.
        + (* a ∈ l2 *) simpl; from_in_list_dec.
          rewrite union_intersect_distr.
          rewrite singleton_intersection_in; auto.
          rewrite IHl1.
          reflexivity.
        + (* a ∉ l2 *)
          from_in_list_dec.
          rewrite union_intersect_distr.
          rewrite singleton_intersection_not_in; auto.
          rewrite union_emptyset.
          rewrite IHl1; reflexivity.
    Qed.

    Variable X Y : Ensemble A.
    Context `{enumX : enumerable _ X} `{enumY : enumerable _ Y}.

    Lemma from_list_intersection :
      X ∩ Y == from_list (list_intersection (enumerate X) (enumerate Y)).
    Proof.
      destruct enumX as [Xl HX]; destruct enumY as [Yl HY].
      rewrite list_intersection_equiv.
      repeat rewrite <- rewrite_enumerate.
      reflexivity.
    Qed.

    Instance intersection_enumerable :
      enumerable (X ∩ Y).
    Proof.
      exists (list_intersection (enumerate X) (enumerate Y)).
      apply from_list_intersection.
    Defined.
  End IntersectionEnumerable.
  Existing Instance intersection_enumerable.

  Section SetminusEnumerable.
    Context {name : Type} `{name_dec : eq_dec name}.

    Fixpoint better_filter {A : Type} (f : A -> bool) (l : list A) :=
      match l with
      | nil => nil
      | x :: l0 => (if f x then x::nil else nil) ++ better_filter f l0
      end.
    Lemma filter_false : forall {X} (l : list X),
      better_filter (fun _ => false) l = nil.
    Proof.
      induction l; auto.
    Qed.

    Definition list_setminus (lX lY : list name) :=
      better_filter (fun x => negb (in_list_dec x lY)) lX.

    Lemma list_setminus_equiv : forall l1 l2 : list name,
      from_list (list_setminus l1 l2) == from_list l1 ∖ from_list l2.
    Proof.
      intros l1.
      unfold list_setminus.
      induction l1 as [ | a l1]; intros l2.
      * simpl.
        rewrite setminus_emptyset.
        reflexivity.
      * simpl.
        rewrite union_setminus_distr.
        rewrite <- IHl1.
        destruct (in_list_dec a l2) eqn:Ha;
          from_in_list_dec;
          simpl.
        + (* a ∈ Y *)
          rewrite singleton_setminus_in; auto.
          rewrite union_emptyset.
          reflexivity.
        + (* a ∉ Y *)
          rewrite singleton_setminus_not_in; auto.
          reflexivity.
  Qed.

    Variable X Y : Ensemble name.
    Context `{enumX : enumerable _ X} `{enumY : enumerable _ Y}.

    Lemma from_list_setminus :
      X ∖ Y == from_list (list_setminus (enumerate X) (enumerate Y)).
    Proof.
      rewrite list_setminus_equiv.
      destruct enumX as [Xl HX]; destruct enumY as [Yl HY].
      repeat rewrite <- rewrite_enumerate.
      reflexivity.
  Qed.
  Instance setminus_enumerable : enumerable (X ∖ Y).
    exists (list_setminus (enumerate X) (enumerate Y)).
    apply from_list_setminus.
  Defined.
  End SetminusEnumerable.

  Instance empty_enumerable : forall {A}, @enumerable A ∅.
  Proof.
    intros A.
    exists nil. simpl. reflexivity.
  Defined.
  Existing Instance union_enumerable.
  Existing Instance setminus_enumerable.

(** ** Utilities for making robust Ltac tactics *)

Ltac maybe_do flag tac :=
  match flag with
  | false => idtac
  | true  => tac
  end.

Ltac replace_with_in x y loc_flag :=
  match loc_flag with
  | false => (* only in conclusion *) replace x with y
  | true  => (* everywhere *) replace x with y in *
  | _ => replace x with y in loc_flag
  end.