Require Import Frap Pset11Sig.

(* The next span of code, up to the word "Example", sets up some automation
 * support. Feel free to skip ahead to the example to see the ingredients
 * in action in the verification of an example program.
 *)

Lemma HtReturn' : forall {t : Set} (P : hprop) (R G : hrel) (Q : _ -> hprop) (v : t),
    stableP P R
    -> (forall h, P h -> Q v h)
    -> hoare_triple P R (Return v) G Q.
Proof.
  simplify.
  eapply HtConsequence with (P' := P) (R' := R) (G' := G); eauto.
  simplify; propositional; subst; eauto.
Qed.

Lemma HtFail' : forall {t : Set} (P : hprop) (R G : hrel) (Q : t -> hprop),
    (forall h, P h -> False)
    -> hoare_triple P R Fail G Q.
Proof.
  simplify.
  eapply HtConsequence with (R' := R) (G' := G) (Q' := Q); eauto.
  simplify; propositional.
  simplify; propositional.
  unfold stableP; simplify.
  first_order.
Qed.

Lemma HtConsequenceBasic : forall {t : Set} P R c G Q (P' : hprop) (Q' : t -> hprop),
    hoare_triple P R c G Q
    -> (forall h, P' h -> P h)
    -> (forall v h, Q v h -> Q' v h)
    -> stableP P' R
    -> hoare_triple P' R c G Q'.
Proof.
  eauto.
Qed.

Lemma HtStrengthen : forall {t : Set} P R c G (Q : t -> _) (P' : hprop),
    hoare_triple P R c G Q
    -> (forall h, P' h -> P h)
    -> stableP P' R
    -> hoare_triple P' R c G Q.
Proof.
  eauto.
Qed.

Lemma HtWeaken : forall {t : Set} P R c G Q (Q' : t -> hprop),
    hoare_triple P R c G Q
    -> (forall v h, Q v h -> Q' v h)
    -> hoare_triple P R c G Q'.
Proof.
  eauto using always_stableP.
Qed.

(* The first several tactics are similar to those that we have
 * already seen for earlier iterations of our Hoare logics.
 *)
Ltac step0 := apply HtReturn' || eapply HtFail' || eapply HtBind.
Ltac step := step0; simp.
Ltac ht := simp; repeat step.
Ltac loop_inv0 Inv := (eapply HtStrengthen; [ apply HtLoop with (I := Inv) | .. ])
                      || (eapply HtConsequenceBasic; [ apply HtLoop with (I := Inv) | .. ]).
Ltac loop_inv Inv := loop_inv0 Inv; simp.
Ltac strengthen P_ := apply HtStrengthen with (P := P_); simp.

(** * Example *)

(* Here is a demonstrative use of rely-guarantee logic to verify a concurrent
 * program.  We prove that two threads cooperate to keep the value in one memory
 * address even.  They follow a manually implemented locking protocol --
 * we code and justify mutual-exclusion functionality explicitly as a part of
 * the implementation. *)

Fixpoint isEven (n : nat) : bool :=
  match n with
  | O => true
  | S (S n') => isEven n'
  | _ => false
  end.

Definition prog2_th turn_addr data_addr me other :=
  (* First, we loop forever adding to a counter. *)
  for _ := tt loop
    (* The next loop waits until it's our turn to run. *)
    _ <- (for _ := tt loop
      (* We read from a flag [turn_addr] that holds the ID of the thread allowed
       * to run next. *)
      turn <- Atomic (Read turn_addr);
      if turn ==n me then
        (* Is it my turn?  Good; exit the loop. *)
        Return (Done tt)
      else
        (* Not my turn?  Go around again. *)
        Return (Again tt)
      done);
    (* OK, we are allowed to run.  Let's read the counter from [data_addr]. *)
    tmp <- Atomic (Read data_addr);
    if isEven tmp then
      (* Just to make this interesting, let's first write an odd value, based on
       * incrementing by 1!  The other thread had better not be looking now. *)
      _ <- Atomic (Write data_addr (1 + tmp));
      (* Now let's read back what we wrote. *)
      tmp2 <- Atomic (Read data_addr);
      (* Then increment again to reach an even value. *)
      _ <- Atomic (Write data_addr (1 + tmp2));
      (* Finally, flip the whose-turn flag to the other thread's ID. *)
      _ <- Atomic (Write turn_addr other);
      Return (Again tt)
    else
      (* Impossible case: we read an odd counter. *)
      Fail
  done.

Example prog2 turn_addr data_addr :=
  prog2_th turn_addr data_addr 0 1 || prog2_th turn_addr data_addr 1 0.

(* Let's prove this program against a natural spec. *)
Lemma ht_prog2 : forall turn_addr data_addr,
    turn_addr <> data_addr
    -> hoare_triple
         (fun h => isEven (h $! data_addr) = true /\ (h $! turn_addr = 0 \/ h $! turn_addr = 1))
         (* Precondition: data starts out even, and it's someone's turn. *)

         (fun _ _ => False)
         (* Rely: no other threads are allowed to do anything at all, because
          * this program is meant to run by itself, with just these two
          * threads. *)

         (prog2 turn_addr data_addr)

         (fun _ _ => True)
         (* Guarantee: we are generous to ourselves and allow any steps. ;-)
          * (We will still use stricter guarantees internally within the
          * proof.) *)

         (fun _ _ => False)
         (* Postcondition: the program is nonterminating by design! *).
Proof.
  unfold prog2, prog2_th.
  simp.

  (* We use the [fork] tactic to make progress when we get to a parallel
   * composition. *)
  fork (fun h => (h $! turn_addr = 0 /\ isEven (h $! data_addr) = true)
                 \/ h $! turn_addr = 1)
       (* This is the precondition of the first thread.  Note how we make no
        * claim about the counter value if it is the *other* thread's turn.
        * Otherwise, the precondition would not be *stable*. *)

       (fun h h' => (h $! turn_addr = 0
                     /\ h' $! turn_addr = 0)
                    \/ (h $! turn_addr = 0
                        /\ h' $! turn_addr = 1
                        /\ isEven (h' $! data_addr) = true)
                    \/ (h $! turn_addr = 1
                        /\ h' $! turn_addr = 1
                        /\ h' $! data_addr = h $! data_addr))
       (* This is the first thread's guarantee: any step it takes should satisfy
        * this relation.  The details are easier to read in math than to explain
        * in prose! *)

       (fun (_ : unit) (_ : heap) => False)
       (* And here's the first thread's postcondition. *)

       (* We then repeat the mirror images to give the same specifications for
        * the second thread. *)
       (fun h => (h $! turn_addr = 1 /\ isEven (h $! data_addr) = true)
                 \/ h $! turn_addr = 0)
       (fun h h' => (h $! turn_addr = 1
                     /\ h' $! turn_addr = 1)
                    \/ (h $! turn_addr = 1
                        /\ h' $! turn_addr = 0
                        /\ isEven (h' $! data_addr) = true)
                    \/ (h $! turn_addr = 0
                        /\ h' $! turn_addr = 0
                        /\ h' $! data_addr = h $! data_addr))
       (fun (_ : unit) (_ : heap) => False).

  (* Now we're verifying thread #1. *)

  (* The outer loop invariant is a repeat of the precondition, also asserting
   * that the loop can never terminate (e.g., [Done] mapped to [False]). *)
  loop_inv (fun (o : loop_outcome unit) h => match o with
                                             | Done _ => False
                                             | Again _ => (h $! turn_addr = 0 /\ isEven (h $! data_addr) = true) \/ h $! turn_addr = 1
                                             end).
  step.
  (* Inner loop invariant: if the loop isn't done yet ([Again]), then we repeat
   * the precondition; otherwise, we have learned that it's our turn, so we use
   * the precondition with the case for "it's not my turn" pruned out. *)
  loop_inv (fun (o : loop_outcome unit) h => match o with
                                             | Done _ => h $! turn_addr = 0 /\ isEven (h $! data_addr) = true
                                             | Again _ => (h $! turn_addr = 0 /\ isEven (h $! data_addr) = true) \/ h $! turn_addr = 1
                                             end).
  step.
  (* Every time we reach an atomic command (read or write), we call [atomic],
   * providing the postcondition explicitly.  Some care is needed in choosing
   * this predicate, since it must be *stable*.  That is, other threads must not
   * be allowed to falsify it. *)
  atomic (fun r h =>
            ((h $! turn_addr = 0 /\ isEven (h $! data_addr) = true)
             \/ h $! turn_addr = 1)
            /\ (r = 0 -> h $! turn_addr = 0)).
  (* Further details in this particular proof aren't essential for completing
   * this pset, but feel free to step through and see what's happening. *)
  cases (r ==n 0).
  step.
  step.
  step.
  atomic (fun r h =>
            h $! turn_addr = 0 /\ isEven (h $! data_addr) = true /\ r = h $! data_addr).
  simp.
  cases (isEven r0).
  step.
  atomic (fun (_ : unit) h =>
            exists r, h $! turn_addr = 0 /\ isEven r = true /\ h $! data_addr = 1 + r).
  eauto.
  rewrite H4; eauto.
  simp.
  step.
  atomic (fun r' h =>
            exists r, h $! turn_addr = 0 /\ isEven r = true /\ h $! data_addr = 1 + r /\ r' = 1 + r).
  eauto.
  rewrite H4; eauto.
  rewrite H4; eauto.
  simp.
  step.
  atomic (fun (_ : unit) h =>
            h $! turn_addr = 0 /\ isEven (h $! data_addr) = true).
  rewrite H4; eauto.
  step.
  atomic (fun (_ : unit) h =>
            (h $! turn_addr = 0 /\ isEven (h $! data_addr) = true)
            \/ h $! turn_addr = 1).
  step.
  step.

  (* Here's the proof for the second thread, where we switch [0]s with [1]s. *)
  loop_inv (fun (o : loop_outcome unit) h => match o with
                                             | Done _ => False
                                             | Again _ => (h $! turn_addr = 1 /\ isEven (h $! data_addr) = true) \/ h $! turn_addr = 0
                                             end).
  step.
  loop_inv (fun (o : loop_outcome unit) h => match o with
                                             | Done _ => h $! turn_addr = 1 /\ isEven (h $! data_addr) = true
                                             | Again _ => (h $! turn_addr = 1 /\ isEven (h $! data_addr) = true) \/ h $! turn_addr = 0
                                             end).
  step.
  atomic (fun r h =>
            ((h $! turn_addr = 1 /\ isEven (h $! data_addr) = true)
             \/ h $! turn_addr = 0)
            /\ (r = 1 -> h $! turn_addr = 1)).
  cases (r ==n 1).
  step.
  step.
  step.
  atomic (fun r h =>
            h $! turn_addr = 1 /\ isEven (h $! data_addr) = true /\ r = h $! data_addr).
  simp.
  cases (isEven r0).
  step.
  atomic (fun (_ : unit) h =>
            exists r, h $! turn_addr = 1 /\ isEven r = true /\ h $! data_addr = 1 + r).
  eauto.
  rewrite H4; eauto.
  simp.
  step.
  atomic (fun r' h =>
            exists r, h $! turn_addr = 1 /\ isEven r = true /\ h $! data_addr = 1 + r /\ r' = 1 + r).
  eauto.
  rewrite H4; eauto.
  rewrite H4; eauto.
  simp.
  step.
  atomic (fun (_ : unit) h =>
            h $! turn_addr = 1 /\ isEven (h $! data_addr) = true).
  rewrite H4; eauto.
  step.
  atomic (fun (_ : unit) h =>
            (h $! turn_addr = 1 /\ isEven (h $! data_addr) = true)
            \/ h $! turn_addr = 0).
  step.
  step.

  simp.
  simp.
  simp.
  simp.
  simp.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(** * Compatibility functors between FSetInterface and MSetInterface. *)

Require Import FSetInterface FSetFacts MSetInterface MSetFacts.
Set Implicit Arguments.
Unset Strict Implicit.

(** * From new Weak Sets to old ones *)

Module Backport_WSets
 (E:DecidableType.DecidableType)
 (M:MSetInterface.WSets with Definition E.t := E.t
                        with Definition E.eq := E.eq)
 <: FSetInterface.WSfun E.

 Definition elt := E.t.
 Definition t := M.t.

 Implicit Type s : t.
 Implicit Type x y : elt.
 Implicit Type f : elt -> bool.

 Definition In : elt -> t -> Prop := M.In.
 Definition Equal s s' := forall a : elt, In a s <-> In a s'.
 Definition Subset s s' := forall a : elt, In a s -> In a s'.
 Definition Empty s := forall a : elt, ~ In a s.
 Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
 Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
 Definition empty : t := M.empty.
 Definition is_empty : t -> bool := M.is_empty.
 Definition mem : elt -> t -> bool := M.mem.
 Definition add : elt -> t -> t := M.add.
 Definition singleton : elt -> t := M.singleton.
 Definition remove : elt -> t -> t := M.remove.
 Definition union : t -> t -> t := M.union.
 Definition inter : t -> t -> t := M.inter.
 Definition diff : t -> t -> t := M.diff.
 Definition eq : t -> t -> Prop := M.eq.
 Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec.
 Definition equal : t -> t -> bool := M.equal.
 Definition subset : t -> t -> bool := M.subset.
 Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold.
 Definition for_all : (elt -> bool) -> t -> bool := M.for_all.
 Definition exists_ : (elt -> bool) -> t -> bool := M.exists_.
 Definition filter : (elt -> bool) -> t -> t := M.filter.
 Definition partition : (elt -> bool) -> t -> t * t:= M.partition.
 Definition cardinal : t -> nat := M.cardinal.
 Definition elements : t -> list elt := M.elements.
 Definition choose : t -> option elt := M.choose.

 Module MF := MSetFacts.WFacts M.

 Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s
  := MF.In_1.
 Definition eq_refl : forall s, eq s s
  := @Equivalence_Reflexive _ _ M.eq_equiv.
 Definition eq_sym : forall s s', eq s s' -> eq s' s
  := @Equivalence_Symmetric _ _ M.eq_equiv.
 Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s''
  := @Equivalence_Transitive _ _ M.eq_equiv.
 Definition mem_1 : forall s x, In x s -> mem x s = true
  := MF.mem_1.
 Definition mem_2 : forall s x, mem x s = true -> In x s
  := MF.mem_2.
 Definition equal_1 : forall s s', Equal s s' -> equal s s' = true
  := MF.equal_1.
 Definition equal_2 : forall s s', equal s s' = true -> Equal s s'
  := MF.equal_2.
 Definition subset_1 : forall s s', Subset s s' -> subset s s' = true
  := MF.subset_1.
 Definition subset_2 : forall s s', subset s s' = true -> Subset s s'
  := MF.subset_2.
 Definition empty_1 : Empty empty := MF.empty_1.
 Definition is_empty_1 : forall s, Empty s -> is_empty s = true
  := MF.is_empty_1.
 Definition is_empty_2 : forall s, is_empty s = true -> Empty s
  := MF.is_empty_2.
 Definition add_1 : forall s x y, E.eq x y -> In y (add x s)
  := MF.add_1.
 Definition add_2 : forall s x y, In y s -> In y (add x s)
  := MF.add_2.
 Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s
  := MF.add_3.
 Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s)
  := MF.remove_1.
 Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s)
  := MF.remove_2.
 Definition remove_3 : forall s x y, In y (remove x s) -> In y s
  := MF.remove_3.
 Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s'
  := MF.union_1.
 Definition union_2 : forall s s' x, In x s -> In x (union s s')
  := MF.union_2.
 Definition union_3 : forall s s' x, In x s' -> In x (union s s')
  := MF.union_3.
 Definition inter_1 : forall s s' x, In x (inter s s') -> In x s
  := MF.inter_1.
 Definition inter_2 : forall s s' x, In x (inter s s') -> In x s'
  := MF.inter_2.
 Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s')
  := MF.inter_3.
 Definition diff_1 : forall s s' x, In x (diff s s') -> In x s
  := MF.diff_1.
 Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s'
  := MF.diff_2.
 Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s')
  := MF.diff_3.
 Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y
  := MF.singleton_1.
 Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x)
  := MF.singleton_2.
 Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (fun a e => f e a) (elements s) i
  := MF.fold_1.
 Definition cardinal_1 : forall s, cardinal s = length (elements s)
  := MF.cardinal_1.
 Definition filter_1 : forall s x f, compat_bool E.eq f ->
  In x (filter f s) -> In x s
  := MF.filter_1.
 Definition filter_2 : forall s x f, compat_bool E.eq f ->
  In x (filter f s) -> f x = true
  := MF.filter_2.
 Definition filter_3 : forall s x f, compat_bool E.eq f ->
  In x s -> f x = true -> In x (filter f s)
  := MF.filter_3.
 Definition for_all_1 : forall s f, compat_bool E.eq f ->
  For_all (fun x => f x = true) s -> for_all f s = true
  := MF.for_all_1.
 Definition for_all_2 : forall s f, compat_bool E.eq f ->
  for_all f s = true -> For_all (fun x => f x = true) s
  := MF.for_all_2.
 Definition exists_1 : forall s f, compat_bool E.eq f ->
  Exists (fun x => f x = true) s -> exists_ f s = true
  := MF.exists_1.
 Definition exists_2 : forall s f, compat_bool E.eq f ->
  exists_ f s = true -> Exists (fun x => f x = true) s
  := MF.exists_2.
 Definition partition_1 : forall s f, compat_bool E.eq f ->
  Equal (fst (partition f s)) (filter f s)
  := MF.partition_1.
 Definition partition_2 : forall s f, compat_bool E.eq f ->
  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
  := MF.partition_2.
 Definition choose_1 : forall s x, choose s = Some x -> In x s
  := MF.choose_1.
 Definition choose_2 : forall s, choose s = None -> Empty s
  := MF.choose_2.
 Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s)
  := MF.elements_1.
 Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s
  := MF.elements_2.
 Definition elements_3w : forall s, NoDupA E.eq (elements s)
  := MF.elements_3w.

End Backport_WSets.

(** * From new Sets to new ones *)

Module Backport_Sets
 (E:OrderedType.OrderedType)
 (M:MSetInterface.Sets with Definition E.t := E.t
                       with Definition E.eq := E.eq
                       with Definition E.lt := E.lt)
 <: FSetInterface.S with Module E:=E.

  Include Backport_WSets E M.

  Implicit Type s : t.
  Implicit Type x y : elt.

  Definition lt : t -> t -> Prop := M.lt.
  Definition min_elt : t -> option elt := M.min_elt.
  Definition max_elt : t -> option elt := M.max_elt.
  Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s
   := M.min_elt_spec1.
  Definition min_elt_2 : forall s x y,
   min_elt s = Some x -> In y s -> ~ E.lt y x
   := M.min_elt_spec2.
  Definition min_elt_3 : forall s, min_elt s = None -> Empty s
   := M.min_elt_spec3.
  Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s
   := M.max_elt_spec1.
  Definition max_elt_2 : forall s x y,
   max_elt s = Some x -> In y s -> ~ E.lt x y
   := M.max_elt_spec2.
  Definition max_elt_3 : forall s, max_elt s = None -> Empty s
   := M.max_elt_spec3.
  Definition elements_3 : forall s, sort E.lt (elements s)
   := M.elements_spec2.
  Definition choose_3 : forall s s' x y,
   choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y
   := M.choose_spec3.
  Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s''
   := @StrictOrder_Transitive _ _ M.lt_strorder.
  Lemma lt_not_eq : forall s s',  lt s s' -> ~ eq s s'.
  Proof.
   unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt.
   apply (StrictOrder_Irreflexive s'); auto.
  Qed.
  Definition compare : forall s s', Compare lt eq s s'.
  Proof.
   intros s s'; destruct (CompSpec2Type (M.compare_spec s s'));
    [ apply EQ | apply LT | apply GT ]; auto.
  Defined.

  Module E := E.

End Backport_Sets.

(** * From old Weak Sets to new ones. *)

Module Update_WSets
 (E:Equalities.DecidableType)
 (M:FSetInterface.WS with Definition E.t := E.t
                     with Definition E.eq := E.eq)
 <: MSetInterface.WSetsOn E.

 Definition elt := E.t.
 Definition t := M.t.

 Implicit Type s : t.
 Implicit Type x y : elt.
 Implicit Type f : elt -> bool.

 Definition In : elt -> t -> Prop := M.In.
 Definition Equal s s' := forall a : elt, In a s <-> In a s'.
 Definition Subset s s' := forall a : elt, In a s -> In a s'.
 Definition Empty s := forall a : elt, ~ In a s.
 Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
 Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
 Definition empty : t := M.empty.
 Definition is_empty : t -> bool := M.is_empty.
 Definition mem : elt -> t -> bool := M.mem.
 Definition add : elt -> t -> t := M.add.
 Definition singleton : elt -> t := M.singleton.
 Definition remove : elt -> t -> t := M.remove.
 Definition union : t -> t -> t := M.union.
 Definition inter : t -> t -> t := M.inter.
 Definition diff : t -> t -> t := M.diff.
 Definition eq : t -> t -> Prop := M.eq.
 Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec.
 Definition equal : t -> t -> bool := M.equal.
 Definition subset : t -> t -> bool := M.subset.
 Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold.
 Definition for_all : (elt -> bool) -> t -> bool := M.for_all.
 Definition exists_ : (elt -> bool) -> t -> bool := M.exists_.
 Definition filter : (elt -> bool) -> t -> t := M.filter.
 Definition partition : (elt -> bool) -> t -> t * t:= M.partition.
 Definition cardinal : t -> nat := M.cardinal.
 Definition elements : t -> list elt := M.elements.
 Definition choose : t -> option elt := M.choose.

 Module MF := FSetFacts.WFacts M.

 Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
 Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed.

 Instance eq_equiv : Equivalence eq := _.

 Section Spec.
  Variable s s': t.
  Variable x y : elt.

  Lemma mem_spec : mem x s = true <-> In x s.
  Proof. intros; symmetry; apply MF.mem_iff. Qed.

  Lemma equal_spec : equal s s' = true <-> Equal s s'.
  Proof. intros; symmetry; apply MF.equal_iff. Qed.

  Lemma subset_spec : subset s s' = true <-> Subset s s'.
  Proof. intros; symmetry; apply MF.subset_iff. Qed.

  Definition empty_spec : Empty empty := M.empty_1.

  Lemma is_empty_spec : is_empty s = true <-> Empty s.
  Proof. intros; symmetry; apply MF.is_empty_iff. Qed.

  Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s.
  Proof. intros. rewrite MF.add_iff. intuition. Qed.

  Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
  Proof. intros. rewrite MF.remove_iff. intuition. Qed.

  Lemma singleton_spec : In y (singleton x) <-> E.eq y x.
  Proof. intros; rewrite MF.singleton_iff. intuition. Qed.

  Definition union_spec : In x (union s s') <-> In x s \/ In x s'
   := @MF.union_iff s s' x.
  Definition inter_spec : In x (inter s s') <-> In x s /\ In x s'
   := @MF.inter_iff s s' x.
  Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s'
   := @MF.diff_iff s s' x.
  Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
   fold f s i = fold_left (flip f) (elements s) i
   := @M.fold_1 s.
  Definition cardinal_spec : cardinal s = length (elements s)
   := @M.cardinal_1 s.

  Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s.
  Proof. intros; symmetry; apply MF.elements_iff. Qed.

  Definition elements_spec2w : NoDupA E.eq (elements s)
   := @M.elements_3w s.
  Definition choose_spec1 : choose s = Some x -> In x s
   := @M.choose_1 s x.
  Definition choose_spec2 : choose s = None -> Empty s
   := @M.choose_2 s.
  Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f ->
   (In x (filter f s) <-> In x s /\ f x = true)
   := @MF.filter_iff s x.
  Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f ->
   Equal (fst (partition f s)) (filter f s)
   := @M.partition_1 s.
  Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f ->
   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
   := @M.partition_2 s.

  Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f ->
    (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed.

  Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f ->
    (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof. intros; symmetry; apply MF.exists_iff; auto. Qed.

  End Spec.

End Update_WSets.

(** * From old Sets to new ones. *)

Module Update_Sets
 (E:Orders.OrderedType)
 (M:FSetInterface.S with Definition E.t := E.t
                    with Definition E.eq := E.eq
                    with Definition E.lt := E.lt)
 <: MSetInterface.Sets with Module E:=E.

  Include Update_WSets E M.

  Implicit Type s : t.
  Implicit Type x y : elt.

  Definition lt : t -> t -> Prop := M.lt.
  Definition min_elt : t -> option elt := M.min_elt.
  Definition max_elt : t -> option elt := M.max_elt.
  Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s
   := M.min_elt_1.
  Definition min_elt_spec2 : forall s x y,
   min_elt s = Some x -> In y s -> ~ E.lt y x
   := M.min_elt_2.
  Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s
   := M.min_elt_3.
  Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s
   := M.max_elt_1.
  Definition max_elt_spec2 : forall s x y,
   max_elt s = Some x -> In y s -> ~ E.lt x y
   := M.max_elt_2.
  Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s
   := M.max_elt_3.
  Definition elements_spec2 : forall s, sort E.lt (elements s)
   := M.elements_3.
  Definition choose_spec3 : forall s s' x y,
   choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y
   := M.choose_3.

  Instance lt_strorder : StrictOrder lt.
  Proof.
   split.
   intros x Hx. apply (M.lt_not_eq Hx); auto with *.
   exact M.lt_trans.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
  apply proper_sym_impl_iff_2; auto with *.
  intros s s' Hs u u' Hu H.
  assert (H0 : lt s' u).
   destruct (M.compare s' u) as [H'|H'|H']; auto.
   elim (M.lt_not_eq H). transitivity s'; auto with *.
   elim (M.lt_not_eq (M.lt_trans H H')); auto.
  destruct (M.compare s' u') as [H'|H'|H']; auto.
  elim (M.lt_not_eq H).
   transitivity u'; auto with *. transitivity s'; auto with *.
  elim (M.lt_not_eq (M.lt_trans H' H0)); auto with *.
  Qed.

  Definition compare s s' :=
   match M.compare s s' with
    | EQ _ => Eq
    | LT _ => Lt
    | GT _ => Gt
   end.

  Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s').
  Proof. intros; unfold compare; destruct M.compare; auto. Qed.

  Module E := E.

End Update_Sets.


From CAS Require Import Exp.

Variant request :=
  Request_CAS (cmp swp : N)
| Request_Q   (cmp     : N)
| Request_R.

Variant state :=
  State_Init
| State_Ready (data : exp N)
| State_Recv  (data : exp N) (req : request).

Variant transition :=
  Transition_Tau
| Transition_Send (res : exp bool)
| Transition_Recv (req : request).

Inductive rule :=
  Rule_Base (precondition : state -> exp bool)
            (trans        : state -> transition)
            (poststate    : state -> state)
| Rule_Exists {T} (k : T -> rule).

Definition reset : rule :=
  Rule_Exists
    (fun data : exp N =>
       Rule_Base (fun st =>
                    match st with
                    | State_Recv _ Request_R
                    | State_Init => exp_true
                    | _          => exp_false
                    end)
                 (fun st =>
                    match st with
                    | State_Recv _ _ => Transition_Send exp_true
                    | _ => Transition_Tau
                    end)
                 (const (State_Ready data))).

Definition recv : rule :=
  Rule_Exists
    (fun req : request =>
       Rule_Base (const exp_true)
                 (const (Transition_Recv req))
                 (fun st =>
                    match st with
                    | State_Ready data => State_Recv data req
                    | _ => State_Init (* don't care *)
                    end)).

Definition q : rule :=
  Rule_Base (fun st => match st with
                     | State_Recv _ (Request_Q _) => exp_true
                     | _ => exp_false
                     end)
            (fun st => match st with
                     | State_Recv data (Request_Q cmp) =>
                       Transition_Send (exp_eq cmp data)
                     | _ => Transition_Tau (* don't care *)
                     end)
            (fun st => match st with
                     | State_Recv data _ => State_Ready data
                     | _ => State_Init (* don't care *)
                     end).

Definition hit : rule :=
  Rule_Base (fun st =>
               match st with
               | State_Recv data (Request_CAS cmp _) =>
                 exp_eq cmp data
               | _ => exp_false
               end)
            (const (Transition_Send exp_true))
            (fun st =>
               match st with
               | State_Recv _ (Request_CAS _ swp) =>
                 State_Ready (exp_int swp)
               | _ => State_Init (* don't care *)
               end).

Definition miss : rule :=
  Rule_Base (fun st =>
               match st with
               | State_Recv data (Request_CAS cmp _) =>
                 exp_negb (exp_eq cmp data)
               | _ => exp_false
               end)
            (const (Transition_Send exp_false))
            (fun st =>
               match st with
               | State_Recv data _ => State_Ready data
               | _ => State_Init (* don't care *)
               end).


From Coq Require Import Arith NArith JMeq.
Require FSet Map.
Require Tower.

(* Two partial functions are Compat if they coincide on the intersection of their domains. *)
Definition Compat {Key Value: Type}
                   {KeyEqDec: forall x y: Key, {x = y} + {x <> y}}
                   {KeySet: Type}
                   {KeySetImpl: FSet.class KeyEqDec KeySet}
                   {s1 s2: KeySet}
                   (f1: forall key: Key, FSet.has s1 key = true -> Value)
                   (f2: forall key: Key, FSet.has s2 key = true -> Value)
:= forall key: Key,
     match FSet.has s1 key as z return _ = z -> _ with
     | false => fun _ => True
     | true => fun ok1 => match FSet.has s2 key as z return _ = z -> _ with
                          | false => fun _ => True
                          | true => fun ok2 => f1 key ok1 = f2 key ok2
                          end eq_refl
     end eq_refl.

Class class {Key: Type} {KeyEqDec: forall x y: Key, {x = y} + {x <> y}}
             {KeySet: Type} (KeySetImpl: FSet.class KeyEqDec KeySet) (Value: Type)
             (D: Tower.t -> Type)
             := {
  empty: D Tower.empty;

  lookup {t: Tower.t} (dict: D t)
         (key: Key) (ok: Tower.has t key = true)
  : Value;

  replace {t: Tower.t} (dict: D t)
          (key: Key) (ok: Tower.has t key = true)
          (new_value: Value)
  : D t;

  replace_ok {t: Tower.t} (dict: D t)
             (x: Key) (OkX: Tower.has t x = true)
             (new_value: Value)
             (y: Key)
             (OkY: Tower.has t y = true):
    lookup (replace dict x OkX new_value) y OkY =
      if KeyEqDec x y
        then new_value
        else lookup dict y OkY;

  enter_scope {t: Tower.t} (dict: D t)
  : D (Tower.dup t);

  enter_scope_ok {t: Tower.t} (dict: D t):
    Compat (lookup dict) (lookup (enter_scope dict));

  leave_scope {t: Tower.t} (dict: D t) (can_pop: Tower.height t <> 0%N)
  : D (Tower.drop' t can_pop);

  leave_scope_ok {t: Tower.t} (dict: D t) (can_pop: Tower.height t <> 0%N):
    Compat (lookup dict) (lookup (leave_scope dict can_pop));

  insert {t: Tower.t} (dict: D t)
         (key: Key) (ok: Tower.has t key = false)
         (value: Value)
  : D (Tower.add t key);

  insert_inserts {t: Tower.t} (dict: D t) (key: Key) (ok: Tower.has t key = false) (value: Value):
    lookup (insert dict key ok value) key (Tower.add_has key t) = value;

  insert_ok {t: Tower.t} (dict: D t) (key: Key) (ok: Tower.has t key = false) (value: Value):
    Compat (lookup dict) (lookup (insert dict key ok value));
}.

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

Section DictImpl.

Context {Key: Type} {KeyEqDec: forall x y: Key, {x = y} + {x <> y}}
         {KeySet: Type} (KeySetImpl: FSet.class KeyEqDec KeySet) {Value: Type} {M: Type}
         (MapImpl: Map.class KeyEqDec Value M).

Definition bound_map (t: Tower.t)
:= { m: M | forall x, Tower.has t x = true -> Map.lookup m x <> None }.

Lemma bound_map_empty_spec (x: Key):
  Tower.has Tower.empty x = true -> Map.lookup Map.empty x <> None.
Proof.
intro H. exfalso. unfold Tower.has in H. cbn in H.
rewrite FSet.empty_ok in H. discriminate.
Qed.

Definition bound_map_lookup (t: Tower.t)
                             (dict: bound_map t)
                             (key: Key)
                             (ok: Tower.has t key = true)
: Value
:= match Map.lookup (proj1_sig dict) key as z return _ = z -> _ with
   | Some x => fun _ => x
   | None => fun E => False_rect _ (proj2_sig dict key ok E)
   end eq_refl.

Lemma bound_map_some_lookup  (t: Tower.t)
                             (dict: bound_map t)
                             (key: Key)
                             (ok: Tower.has t key = true):
  Some (bound_map_lookup t dict key ok) = Map.lookup (proj1_sig dict) key.
Proof.
unfold bound_map_lookup.
remember (fun E => False_rect Value (proj2_sig dict key ok E)) as bad.
generalize bad. clear bad Heqbad.
remember (Map.lookup (proj1_sig dict) key) as l.
destruct l. { trivial. }
symmetry in Heql.
exfalso. exact (proj2_sig dict key ok Heql).
Qed.

Lemma bound_map_replace_spec (t: Tower.t) (dict: bound_map t)
               (key: Key) (ok: Tower.has t key = true)
               (new_value: Value)
               (x: Key)
               (T: Tower.has t x = true):
  Map.lookup (Map.insert (proj1_sig dict) key new_value) x <> None.
Proof.
rewrite Map.insert_ok.
destruct (KeyEqDec key x). { discriminate. }
exact (proj2_sig dict x T).
Qed.

Definition bound_map_replace (t: Tower.t) (dict: bound_map t)
               (key: Key) (ok: Tower.has t key = true)
               (new_value: Value)
: bound_map t
:= exist _ (Map.insert (proj1_sig dict) key new_value)
         (bound_map_replace_spec t dict key ok new_value).

Lemma bound_map_replace_ok (t: Tower.t) (dict: bound_map t)
                            (x: Key) (OkX: Tower.has t x = true)
                            (new_value: Value)
                            (y: Key)
                            (OkY: Tower.has t y = true):
   bound_map_lookup t (bound_map_replace t dict x OkX new_value) y OkY
    =
   if KeyEqDec x y
     then new_value
     else bound_map_lookup t dict y OkY.
Proof.
match goal with
|- ?lhs = ?rhs => enough (H: Some lhs = Some rhs)
end.
{ now inversion H. }
rewrite bound_map_some_lookup.
unfold bound_map_replace.
destruct KeyEqDec; cbn; rewrite Map.insert_ok; destruct KeyEqDec; try easy.
symmetry. apply bound_map_some_lookup.
Qed.

Definition bound_map_enter_scope {t: Tower.t} (dict: bound_map t)
: bound_map (Tower.dup t)
:= exist _ (proj1_sig dict) (proj2_sig dict).

Lemma bound_map_enter_scope_ok (t: Tower.t) (dict: bound_map t):
    Compat (bound_map_lookup t dict) (bound_map_lookup t (bound_map_enter_scope dict)).
Proof.
intro x.
remember (fun ok1 : FSet.has (Tower.top t) x = true =>
  (if FSet.has (Tower.top t) x as z return (FSet.has (Tower.top t) x = z -> Prop)
   then
    fun ok2 : FSet.has (Tower.top t) x = true =>
    bound_map_lookup t dict x ok1 = bound_map_lookup t (bound_map_enter_scope dict) x ok2
   else fun _ : FSet.has (Tower.top t) x = false => True) eq_refl) as Y.
assert (YY: forall ok1, Y ok1).
{
  intro ok1. subst Y.
  remember (fun ok2 : FSet.has (Tower.top t) x = true =>
  bound_map_lookup t dict x ok1 = bound_map_lookup t (bound_map_enter_scope dict) x ok2) as Z.
  assert (ZZ: forall (ok2: FSet.has (Tower.top t) x = true), Z ok2).
  {
    intro ok2. subst Z.
    match goal with
    |- ?lhs = ?rhs => enough (H: Some lhs = Some rhs)
    end. { now inversion H. }
    now repeat rewrite bound_map_some_lookup.
  }
  clear HeqZ.
  now destruct FSet.has.
}
clear HeqY.
now destruct FSet.has.
Qed.

Lemma bound_map_leave_scope_spec {t: Tower.t} (dict: bound_map t) (can_pop: Tower.height t <> 0%N)
                                 (x: Key):
  Tower.has (Tower.drop' t can_pop) x = true -> Map.lookup (proj1_sig dict) x <> None.
Proof.
intro H. apply (proj2_sig dict).
destruct t. cbn in *. unfold Tower.has in *. cbn in *.
destruct rest. { contradiction. }
cbn in *.
assert (Sub := FSet.is_subset_ok head top).
destruct Sub as (SubR, SubL).
assert (W := SubR Ok x).
rewrite H in W.
cbn in W. exact W.
Qed.

Definition bound_map_leave_scope {t: Tower.t} (dict: bound_map t) (can_pop: Tower.height t <> 0%N)
: bound_map (Tower.drop' t can_pop)
:= exist _ (proj1_sig dict) (bound_map_leave_scope_spec dict can_pop).

Lemma bound_map_leave_scope_ok (t: Tower.t) (dict: bound_map t) (can_pop: Tower.height t <> 0%N):
    Compat (bound_map_lookup _ dict) (bound_map_lookup _ (bound_map_leave_scope dict can_pop)).
Proof.
intro x.
remember (fun ok1 : FSet.has (Tower.top t) x = true =>
  (if FSet.has (Tower.top (Tower.drop' t can_pop)) x as z
    return (FSet.has (Tower.top (Tower.drop' t can_pop)) x = z -> Prop)
   then
    fun ok2 : FSet.has (Tower.top (Tower.drop' t can_pop)) x = true =>
    bound_map_lookup t dict x ok1 =
    bound_map_lookup (Tower.drop' t can_pop) (bound_map_leave_scope dict can_pop) x ok2
   else fun _ : FSet.has (Tower.top (Tower.drop' t can_pop)) x = false => True) eq_refl) as B.
assert (BB: forall ok1, B ok1).
{
  intro ok1. subst B.
  remember (fun ok2 : FSet.has (Tower.top (Tower.drop' t can_pop)) x = true =>
  bound_map_lookup t dict x ok1 =
  bound_map_lookup (Tower.drop' t can_pop) (bound_map_leave_scope dict can_pop) x ok2) as C.
  assert (CC: forall ok2, C ok2).
  {
    intro ok2. subst C.
    match goal with
    |- ?lhs = ?rhs => enough (H: Some lhs = Some rhs)
    end. { now inversion H. }
    now repeat rewrite bound_map_some_lookup.
  }
  clear HeqC.
  now destruct (FSet.has (Tower.top (Tower.drop' t can_pop))).
}
clear HeqB.
now destruct FSet.has.
Qed.

Lemma bound_map_insert_spec {t: Tower.t} (dict: bound_map t)
                             (key: Key) (ok: Tower.has t key = false)
                             (value: Value)
                             (x: Key)
                             (T: Tower.has (Tower.add t key) x = true):
  Map.lookup (Map.insert (proj1_sig dict) key value) x <> None.
Proof.
rewrite Map.insert_ok.
unfold Tower.has in T. cbn in T.
rewrite FSet.add_ok in T.
destruct KeyEqDec. { discriminate. }
apply (proj2_sig dict). exact T.
Qed.

Definition bound_map_insert {t: Tower.t} (dict: bound_map t)
                             (key: Key) (ok: Tower.has t key = false)
                             (value: Value)
: bound_map (Tower.add t key)
:= exist _ (Map.insert (proj1_sig dict) key value)
         (bound_map_insert_spec dict key ok value).

Lemma bound_map_insert_inserts (t: Tower.t) (dict: bound_map t)
                                (key: Key) (ok: Tower.has t key = false)
                                (value: Value):
  bound_map_lookup (Tower.add t key)
                   (bound_map_insert dict key ok value)
                   key
                   (Tower.add_has key t)
   =
  value.
Proof.
unfold bound_map_lookup. cbn.
remember (fun E =>
           False_rect Value (bound_map_insert_spec dict key ok value key (Tower.add_has key t) E)) as B.
generalize B. clear B HeqB.
rewrite Map.insert_ok.
now destruct KeyEqDec.
Qed.

Lemma bound_map_insert_ok (t: Tower.t) (dict: bound_map t)
                           (key: Key) (ok: Tower.has t key = false)
                           (value: Value):
  Compat (bound_map_lookup t dict)
         (bound_map_lookup (Tower.add t key)
            (bound_map_insert dict key ok value)).
Proof.
intro x.
remember (fun ok1 : FSet.has (Tower.top t) x = true =>
  (if FSet.has (Tower.top (Tower.add t key)) x as z
    return (FSet.has (Tower.top (Tower.add t key)) x = z -> Prop)
   then
    fun ok2 : FSet.has (Tower.top (Tower.add t key)) x = true =>
    bound_map_lookup t dict x ok1 =
    bound_map_lookup (Tower.add t key) (bound_map_insert dict key ok value) x ok2
   else fun _ : FSet.has (Tower.top (Tower.add t key)) x = false => True) eq_refl) as U.
assert (UU: forall H, U H).
{
  intro ok1. subst.
  remember (fun ok2 : FSet.has (Tower.top (Tower.add t key)) x = true =>
  bound_map_lookup t dict x ok1 =
  bound_map_lookup (Tower.add t key) (bound_map_insert dict key ok value) x ok2) as V.
  assert (VV: forall H, V H).
  {
    intro ok2. subst.
    match goal with
    |- ?lhs = ?rhs => enough (H: Some lhs = Some rhs)
    end. { now inversion H. }
    repeat rewrite bound_map_some_lookup.
    cbn.
    rewrite Map.insert_ok.
    destruct KeyEqDec; trivial.
    subst.
    unfold Tower.has in ok.
    rewrite ok in ok1.
    discriminate.
  }
  clear HeqV.
  now destruct (FSet.has (Tower.top (Tower.add t key))).
}
clear HeqU.
now destruct FSet.has.
Qed.

Definition bound_map_dict_impl
: class KeySetImpl Value bound_map
:= {|
      empty := exist _ Map.empty bound_map_empty_spec;
      lookup := bound_map_lookup;
      replace := bound_map_replace;
      replace_ok := bound_map_replace_ok;
      enter_scope _ map := bound_map_enter_scope map;
      enter_scope_ok := bound_map_enter_scope_ok;
      leave_scope _ map := bound_map_leave_scope map;
      leave_scope_ok := bound_map_leave_scope_ok;
      insert _ map := bound_map_insert map;
      insert_inserts := bound_map_insert_inserts;
      insert_ok := bound_map_insert_ok;
   |}.

End DictImpl.

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

Section Dict.

Context {Key: Type} {KeyEqDec: forall x y: Key, {x = y} + {x <> y}}
         {KeySet: Type} {KeySetImpl: FSet.class KeyEqDec KeySet} {Value: Type}
         {D: Tower.t -> Type}
         {Dict: class KeySetImpl Value D}.

(* A simple case of dict_replace_ok, similar to dict_insert_inserts. *)
Lemma replace_replaces (t: Tower.t)
                        (d: D t)
                        (key: Key) (ok: Tower.has t key = true)
                        (value: Value):
    lookup (replace d key ok value) key ok = value.
Proof.
rewrite replace_ok. now destruct KeyEqDec.
Qed.

Program Fixpoint leave_scopes {t: Tower.t} (dict: D t) (n: nat)
                                (ok: n <= N.to_nat (Tower.height t))
: D (Tower.dropn t n ok)
:= match n as n' return (n = n' -> _) with
   | O => fun e =>
      match _: t = Tower.dropn t n ok
      in (_ = z) return D z with
      | eq_refl => dict
      end
   | S k => fun e =>
      match _: Tower.dropn (Tower.drop' t (Tower.dropn_helper1 t n ok k e))
                            k
                            (Tower.dropn_helper2 t n ok k e)
                = Tower.dropn t n ok
      in (_ = z) return D z with
      | eq_refl => leave_scopes (leave_scope dict _) k _
      end
   end eq_refl.

(**
  Leaves several scopes to arrive at the scope with the given nesting level.
  Doesn't change the dictionary if the new level is higher than the old.
 *)
Definition set_scope_level {t: Tower.t} (dict: D t) (new_height: N)
: D (Tower.set_height t new_height)
:= leave_scopes dict (N.to_nat (Tower.height t - new_height)) (Tower.set_height_helper _ _).

End Dict.


(************************************************************************)
(*  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        *)
(************************************************************************)

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

(**** Tactics Tauto and Intuition ****)

(**** Tauto:
  Tactic for automating proof in Intuionnistic Propositional Calculus, based on
  the contraction-free LJT* of Dickhoff ****)

(**** Intuition:
  Simplifications of goals, based on LJT* calcul ****)

(**** Examples of intuitionistic tautologies ****)
Parameter A B C D E F : Prop.
Parameter even : nat -> Prop.
Parameter P : nat -> Prop.

Lemma Ex_Wallen : (A -> B /\ C) -> (A -> B) \/ (A -> C).
Proof.
   tauto.
Qed.

Lemma Ex_Klenne : ~ ~ (A \/ ~ A).
Proof.
   tauto.
Qed.

Lemma Ex_Klenne' : forall n : nat, ~ ~ (even n \/ ~ even n).
Proof.
   tauto.
Qed.

Lemma Ex_Klenne'' :
 ~ ~ ((forall n : nat, even n) \/ ~ (forall m : nat, even m)).
Proof.
   tauto.
Qed.

Lemma tauto : (forall x : nat, P x) -> forall y : nat, P y.
Proof.
   tauto.
Qed.

Lemma tauto1 : A -> A.
Proof.
   tauto.
Qed.

Lemma tauto2 : (A -> B -> C) -> (A -> B) -> A -> C.
Proof.
   tauto.
Qed.

Lemma a : forall (x0 : A \/ B) (x1 : B /\ C), A -> B.
Proof.
   tauto.
Qed.

Lemma a2 : (A -> B /\ C) -> (A -> B) \/ (A -> C).
Proof.
   tauto.
Qed.

Lemma a4 : ~ A -> ~ A.
Proof.
   tauto.
Qed.

Lemma e2 : ~ ~ (A \/ ~ A).
Proof.
   tauto.
Qed.

Lemma e4 : ~ ~ (A \/ B -> A \/ B).
Proof.
   tauto.
Qed.

Lemma y0 :
 forall (x0 : A) (x1 : ~ A) (x2 : A -> B) (x3 : A \/ B) (x4 : A /\ B),
 A -> False.
Proof.
   tauto.
Qed.

Lemma y1 : forall x0 : (A /\ B) /\ C, B.
Proof.
   tauto.
Qed.

Lemma y2 : forall (x0 : A) (x1 : B), C \/ B.
Proof.
   tauto.
Qed.

Lemma y3 : forall x0 : A /\ B, B /\ A.
Proof.
   tauto.
Qed.

Lemma y5 : forall x0 : A \/ B, B \/ A.
Proof.
   tauto.
Qed.

Lemma y6 : forall (x0 : A -> B) (x1 : A), B.
Proof.
   tauto.
Qed.

Lemma y7 : forall (x0 : A /\ B -> C) (x1 : B) (x2 : A), C.
Proof.
   tauto.
Qed.

Lemma y8 : forall (x0 : A \/ B -> C) (x1 : A), C.
Proof.
   tauto.
Qed.

Lemma y9 : forall (x0 : A \/ B -> C) (x1 : B), C.
Proof.
   tauto.
Qed.

Lemma y10 : forall (x0 : (A -> B) -> C) (x1 : B), C.
Proof.
   tauto.
Qed.

(* This example took much time with the old version of Tauto *)
Lemma critical_example0 : (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B.
Proof.
   tauto.
Qed.

(* Same remark as previously *)
Lemma critical_example1 : (~ ~ B -> B) -> (~ B -> ~ A) -> ~ ~ A -> B.
Proof.
   tauto.
Qed.

(* This example took very much time (about 3mn on a PIII 450MHz in bytecode)
   with the old Tauto. Now, it's immediate (less than 1s). *)
Lemma critical_example2 : (~ A <-> B) -> (~ B <-> A) -> (~ ~ A <-> A).
Proof.
   tauto.
Qed.

(* This example was a bug *)
Lemma old_bug0 :
 (~ A <-> B) -> (~ (C \/ E) <-> D /\ F) -> (~ (C \/ A \/ E) <-> D /\ B /\ F).
Proof.
   tauto.
Qed.

(* Another bug *)
Lemma old_bug1 : ((A -> B -> False) -> False) -> (B -> False) -> False.
Proof.
   tauto.
Qed.

(* A bug again *)
Lemma old_bug2 :
 ((((C -> False) -> A) -> ((B -> False) -> A) -> False) -> False) ->
 (((C -> B -> False) -> False) -> False) -> ~ A -> A.
Proof.
   tauto.
Qed.

(* A bug from CNF form *)
Lemma old_bug3 :
 ((~ A \/ B) /\ (~ B \/ B) /\ (~ A \/ ~ B) /\ (~ B \/ ~ B) -> False) ->
 ~ ((A -> B) -> B) -> False.
Proof.
   tauto.
Qed.

(* sometimes, the behaviour of Tauto depends on the order of the hyps *)
Lemma old_bug3bis :
 ~ ((A -> B) -> B) ->
 ((~ B \/ ~ B) /\ (~ B \/ ~ A) /\ (B \/ ~ B) /\ (B \/ ~ A) -> False) -> False.
Proof.
   tauto.
Qed.

(* A bug found by Freek Wiedijk <freek@cs.kun.nl> *)
Lemma new_bug :
 ((A <-> B) -> (B <-> C)) ->
 ((B <-> C) -> (C <-> A)) -> ((C <-> A) -> (A <-> B)) -> (A <-> B).
Proof.
   tauto.
Qed.

(*  A private club has the following rules :
 *
 *  . rule 1 : Every non-scottish member wears red socks
 *  . rule 2 : Every member wears a kilt or doesn't wear red socks
 *  . rule 3 : The married members don't go out on sunday
 *  . rule 4 : A member goes out on sunday if and only if he is scottish
 *  . rule 5 : Every member who wears a kilt is scottish and married
 *  . rule 6 : Every scottish member wears a kilt
 *
 *  Actually, no one can be accepted !
 *)

Section club.

Variable Scottish RedSocks WearKilt Married GoOutSunday : Prop.

Hypothesis rule1 : ~ Scottish -> RedSocks.
Hypothesis rule2 : WearKilt \/ ~ RedSocks.
Hypothesis rule3 : Married -> ~ GoOutSunday.
Hypothesis rule4 : GoOutSunday <-> Scottish.
Hypothesis rule5 : WearKilt -> Scottish /\ Married.
Hypothesis rule6 : Scottish -> WearKilt.

Lemma NoMember : False.
 tauto.
Qed.

End club.

(**** Use of Intuition ****)
Lemma intu0 :
 (forall x : nat, P x) /\ B -> (forall y : nat, P y) /\ P 0 \/ B /\ P 0.
Proof.
   intuition.
Qed.

Lemma intu1 :
 (forall A : Prop, A \/ ~ A) -> forall x y : nat, x = y \/ x <> y.
Proof.
   intuition.
Qed.


Require Export Frap.Frap.
From Coq Require Export NArith.
From Coq Require Export Program.Equality.

Arguments N.add : simpl nomatch.
Arguments N.sub : simpl nomatch.
Arguments N.mul : simpl nomatch.
Arguments N.div : simpl nomatch.
Arguments N.shiftl : simpl nomatch.
Arguments N.shiftr : simpl nomatch.

(*|
Totals below don't sum up to 100%!  This is because this pset is a
chose-your-own-adventure assignment, so you can pick what to do.  Here is the
complete rubric, which choice points indicated by `==`::

    1    Axiom opt_binop_fold_test1
    8    Axiom opt_binop_fold_sound
    7    Axiom eval_deterministic
         = Arith (23 points)
           == Precompute
   16         Axiom opt_binop_precompute_sound
    2         Axiom opt_arith_precompute_test1
    2         Axiom opt_arith_precompute_test2
           == Log
   16         Axiom opt_binop_log2_sound
    2         Axiom opt_arith_log2_test1
    2         Axiom opt_arith_log2_test2
           == Bitwise
   16         Axiom opt_binop_bitwise_sound
    2         Axiom opt_arith_bitwise_test1
    2         Axiom opt_arith_bitwise_test2
    4    Axiom opt_arith_fold_test1
   10    Axiom opt_arith_sound
    2    Axiom opt_unskip_test1
    2    Axiom opt_unskip_test2
   16    Axiom opt_unskip_sound
         = Eval (32 points)
           == ConstProp
    8         Axiom opt_arith_constprop_sound
    2         Axiom opt_constprop_test1
    2         Axiom opt_constprop_test2
   18         Axiom opt_constprop_sound
           == Unroll
    6         Parameter eval_read_only
    2         Axiom opt_unroll_test1
    2         Axiom opt_unroll_test2
   20         Axiom opt_unroll_sound
         -- Total 100
|*)

Module Type S.
  Inductive BinopName : Set :=
    LogAnd : BinopName
  | Eq : BinopName
  | ShiftLeft : BinopName
  | ShiftRight : BinopName
  | Times : BinopName
  | Divide : BinopName
  | Plus : BinopName
  | Minus : BinopName
  | Modulo : BinopName.

  Inductive expr : Set :=
    Const : nat -> expr
  | Var : var -> expr
  | Binop : BinopName -> expr -> expr -> expr.

  Inductive cmd : Set :=
    Skip : cmd
  | Assign : var -> expr -> cmd
  | AssignCall : var -> var -> expr -> expr -> cmd
  | Sequence : cmd -> cmd -> cmd
  | If : expr -> cmd -> cmd -> cmd
  | While : expr -> cmd -> cmd.

  Declare Scope expr.
  Delimit Scope expr with expr.

  Coercion Const : nat >-> expr.
  Coercion Var : var >-> expr.

  Infix "&" := (Binop LogAnd) (at level 80) : expr.
  Infix "==" := (Binop Eq) (at level 70) : expr.
  Infix ">>" := (Binop ShiftRight) (at level 60) : expr.
  Infix "<<" := (Binop ShiftLeft) (at level 60) : expr.
  Infix "+" := (Binop Plus) (at level 50, left associativity) : expr.
  Infix "-" := (Binop Minus) (at level 50, left associativity) : expr.
  Infix "*" := (Binop Times) (at level 40, left associativity) : expr.
  Infix "/" := (Binop Divide) (at level 40, left associativity) : expr.
  Infix "mod" := (Binop Modulo) (at level 40) : expr.

  Notation "x <- e" :=
    (Assign x e%expr)
      (at level 75).
  Notation "x <- 'call1' f e1" :=
    (AssignCall x f e1%expr (Const 0))
      (at level 75, f at level 0, e1 at level 0).
  Notation "x <- 'call2' f e1 e2" :=
    (AssignCall x f e1%expr e2%expr)
      (at level 75, f at level 0, e1 at level 0, e2 at level 0).
  Infix ";;" :=
    Sequence (at level 76).
  Notation "'when' e 'then' then_ 'else' else_ 'done'" :=
    (If e%expr then_ else_)
      (at level 75, e at level 0).
  Notation "'while' e 'loop' body 'done'" :=
    (While e%expr body)
      (at level 75).

  Example Times3Plus1Body :=
    ("n" <- "n" * 3 + 1).

  Example FactBody :=
    ("f" <- 1;;
     while "n" loop
       "f" <- "f" * "n";;
       "n" <- "n" - 1
     done).

  Example FactRecBody :=
    (when "n" == 1 then
       "f" <- 1
     else
       "f" <- call1 "fact_r" ("n" - 1);;
       "f" <- "f" * "n"
     done).

  Example FactTailRecBody :=
    (when "n" == 1 then
       "f" <- "acc"
     else
       "f" <- call2 "fact_tr" ("n" - 1) ("acc" * "n")
     done).

  Example CollatzBody :=
    (when ("start" == 1) then
       Skip
     else when ("start" mod 2 == 0) then
            "start" <- "start" / 2
          else
            (* `call1 f arg` is short for `call2 f arg 0` *)
            "start" <- call1 "times3plus1" ("start" + 0)
          done;;
          "flight" <- call2 "collatz" "start" ("flight" + 1)
     done).

  Notation TimesThreePlus1_signature := (("n", ""), "n", Times3Plus1Body).
  Notation Fact_signature := (("n", ""), "f", FactBody).
  Notation FactRec_signature := (("n", ""), "f", FactRecBody).
  Notation FactTailRec_signature := (("n", "acc"), "f", FactTailRecBody).
  Notation Collatz_signature := (("start", "flight"), "flight", CollatzBody).

  Notation Collatz_env :=
  ($0
    $+ ("collatz", Collatz_signature)
    $+ ("times3plus1", TimesThreePlus1_signature)).

  Notation Fact_env :=
    ($0
      $+ ("fact", Fact_signature)
      $+ ("fact_r", FactRec_signature)
      $+ ("fact_tr", FactTailRec_signature)).

  Parameter interp_binop : BinopName -> nat -> nat -> nat.

  Definition valuation := fmap var nat.
  Parameter interp_arith : expr -> valuation -> nat.

  Definition environment := fmap string ((var * var) * var * cmd).

  Inductive eval (phi: environment): valuation -> cmd -> valuation -> Prop :=
  | EvalSkip: forall v,
      eval phi v Skip v
  | EvalAssign: forall v x e a,
      interp_arith e v = a ->
      eval phi v (Assign x e) (v $+ (x, a))
  | EvalAssignCall: forall x f e1 e2 x1 x2 y body a1 a2 a v v',
      phi $? f = Some ((x1, x2), y, body) ->
      interp_arith e1 v = a1 ->
      interp_arith e2 v = a2 ->
      eval phi ($0 $+ (x1, a1) $+ (x2, a2)) body v' ->
      v' $? y = Some a ->
      eval phi v (AssignCall x f e1 e2) (v $+ (x, a))
  | EvalSequence: forall v c1 v1 c2 v2,
      eval phi v c1 v1 ->
      eval phi v1 c2 v2 ->
      eval phi v (Sequence c1 c2) v2
  | EvalIfTrue: forall v e thn els v' c,
      interp_arith e v = c ->
      c <> 0 ->
      eval phi v thn v' ->
      eval phi v (If e thn els) v'
  | EvalIfFalse: forall v e thn els v',
      interp_arith e v = 0 ->
      eval phi v els v' ->
      eval phi v (If e thn els) v'
  | EvalWhileTrue: forall v e body v' v'' c,
      interp_arith e v = c ->
      c <> 0 ->
      eval phi v body v' ->
      eval phi v' (While e body) v'' ->
      eval phi v (While e body) v''
  | EvalWhileFalse: forall v e body,
      interp_arith e v = 0 ->
      eval phi v (While e body) v.

  (*[6%]*)
  Axiom eval_deterministic : forall phi c v0 v1 v2,
      eval phi v0 c v1 ->
      eval phi v0 c v2 ->
      v1 = v2.

  Definition eval_returns phi v cmd outVar result :=
    exists v', eval phi v cmd v' /\ v' $? outVar = Some result.

  Axiom TwoPlusTwoIsFour :
    eval_returns $0 $0 ("out" <- 2 + 2) "out" 4.
  Axiom EvalVars :
    eval_returns $0 $0 ("x" <- 1 + 1;; "x" <- "x" + "x" + "y") "x" 4.
  Axiom EvalSimpleArith :
    eval_returns $0 $0 ("out" <- (((14 >> 1) + 8 / 4 / 2) * (7 - 2) << 1) + 2 == 82) "out" 1.
  Axiom EvalTimes3Plus1 : forall n : nat,
      eval_returns $0 ($0 $+ ("n", n)) Times3Plus1Body "n" (3 * n + 1).
  Axiom EvalFact6 : exists v : valuation,
      eval $0 ($0 $+ ("n", 3)) FactBody v /\ v $? "f" = Some 6.
  Axiom EvalFactRec6 : exists v : valuation,
      eval Fact_env ($0 $+ ("n", 3)) FactRecBody v /\ v $? "f" = Some 6.
  Axiom EvalFactTailRec6 : exists v : valuation,
      eval Fact_env ($0 $+ ("n", 3) $+ ("acc", 1)) FactTailRecBody v /\
      v $? "f" = Some 6.
  Axiom collatz_result : exists v : valuation,
      eval Collatz_env ($0 $+ ("flight", 0) $+ ("start", 10)) CollatzBody v /\
      v $? "flight" = Some 6.

  Parameter opt_binop_fold : BinopName -> expr -> expr -> expr.
  (*[1%]*) Axiom opt_binop_fold_test1 : opt_binop_fold Plus "x" 0 = "x".

  (*[8%]*) Axiom opt_binop_fold_sound :
    forall (b : BinopName) (e1 e2 : expr) (v : valuation),
      interp_arith (opt_binop_fold b e1 e2) v =
      interp_binop b (interp_arith e1 v) (interp_arith e2 v).

  Parameter opt_binop_precompute : BinopName -> expr -> expr -> expr.
  (*[Arith/Precompute:16%]*) Axiom opt_binop_precompute_sound :
    forall (b : BinopName) (e1 e2 : expr) (v : valuation),
      interp_arith (opt_binop_precompute b e1 e2) v =
      interp_binop b (interp_arith e1 v) (interp_arith e2 v).

  Parameter opt_binop_log2 : BinopName -> expr -> expr -> expr.
  (*[Arith/Log:16%]*) Axiom opt_binop_log2_sound :
    forall (b : BinopName) (e1 e2 : expr) (v : valuation),
      interp_arith (opt_binop_log2 b e1 e2) v =
      interp_binop b (interp_arith e1 v) (interp_arith e2 v).

  Parameter opt_binop_bitwise : BinopName -> expr -> expr -> expr.
  (*[Arith/Bitwise:16%]*) Axiom opt_binop_bitwise_sound :
    forall (b : BinopName) (e1 e2 : expr) (v : valuation),
      interp_arith (opt_binop_bitwise b e1 e2) v =
      interp_binop b (interp_arith e1 v) (interp_arith e2 v).

  Parameter opt_arith : expr -> expr.

  (*[4%]*) Axiom opt_arith_fold_test1 :
    opt_arith (1 + "z" * ("y" * ("x" * (0 + 0 / 1))))%expr =
    (1)%expr.
  (*[Arith/Precompute:2%]*) Axiom opt_arith_precompute_test1:
    opt_arith (("x" + (3 - 3)) / (0 + 1) + ("y" + "y" * 0))%expr =
    ("x" + "y")%expr.
  (*[Arith/Precompute:2%]*) Axiom opt_arith_precompute_test2 :
    opt_arith ((("y" / ("x" * 0 + 7 / 1)) mod (12 - 5)) / (2 * 3))%expr =
    (("y" / 7) mod 7 / 6)%expr.
  (*[Arith/Log:2%]*) Axiom opt_arith_log2_test1 :
    opt_arith (("y" * 8) mod 8 / 4)%expr =
    (("y" << 3 & 7) >> 2)%expr.
  (*[Arith/Log:2%]*) Axiom opt_arith_log2_test2 :
    opt_arith (("y" * 1 + (4 + 0)) mod 9 / 3)%expr =
    (("y" + 4) mod 9 / 3)%expr.
  (*[Arith/Bitwise:2%]*) Axiom opt_arith_bitwise_test1 :
    opt_arith ("y" * 13)%expr =
    ("y" + (("y" << 2) + ("y" << 3)))%expr.
  (*[Arith/Bitwise:2%]*) Axiom opt_arith_bitwise_test2 :
    opt_arith ("y" * (3 + 0))%expr =
    ("y" + ("y" << 1))%expr.

  (*[10%]*) Axiom opt_arith_sound :
    forall (e : expr) (v : valuation),
      interp_arith (opt_arith e) v = interp_arith e v.

  Parameter opt_unskip : cmd -> cmd.

  (*[2%]*) Axiom opt_unskip_test1 :
    opt_unskip (Skip;; (Skip;; Skip);; (Skip;; Skip;; Skip)) =
    Skip.
  (*[2%]*) Axiom opt_unskip_test2 :
    opt_unskip (when 0 then (Skip;; Skip) else Skip done;;
                while 0 loop Skip;; Skip done;; Skip) =
    (when 0 then Skip else Skip done;; while 0 loop Skip done).

  (*[16%]*) Axiom opt_unskip_sound :
    forall (phi : environment) (c : cmd) (v v' : valuation),
      eval phi v c v' -> eval phi v (opt_unskip c) v'.

  Parameter opt_arith_constprop : expr -> valuation -> expr.

  (*[Eval/ConstProp:8%]*) Axiom opt_arith_constprop_sound :
    forall (e : expr) (v consts : fmap var nat),
      consts $<= v ->
      interp_arith (opt_arith_constprop e consts) v = interp_arith e v.

  Parameter opt_constprop : cmd -> cmd.

  (*[Eval/ConstProp:2%]*) Axiom opt_constprop_test1 :
    opt_constprop FactBody = FactBody.
  (*[Eval/ConstProp:2%]*) Axiom opt_constprop_test2 :
    opt_constprop ("x" <- 7;; "y" <- "x";;
                   when "x" mod "w" then
                     "z" <- "x";; "t" <- "z";; while "t" loop "t" <- "t" - 1 done
                   else
                     "z" <- "u" + "x";; "t" <- "z"
                   done;;
                   "r" <- "z") =
   ("x" <- 7;; "y" <- 7;;
    when 7 mod "w" then
      "z" <- 7;; "t" <- 7;; while "t" loop "t" <- "t" - 1 done
    else
      "z" <- "u" + 7;; "t" <- "z"
    done;;
    "r" <- "z").

  (*[Eval/ConstProp:18%]*) Axiom opt_constprop_sound :
    forall (phi : environment) (c : cmd) (v v' : valuation),
      eval phi v c v' -> eval phi v (opt_constprop c) v'.

  Parameter read_only : forall (c: cmd) (x0: var), bool.

  (*[Eval/Unroll:6%]*)
  Parameter eval_read_only: forall {phi v v' x c},
      eval phi v c v' ->
      read_only c x = true ->
      v' $? x = v $? x.

  Parameter opt_unroll : cmd -> cmd.

  (*[Eval/Unroll:2%]*) Axiom opt_unroll_test1 :
    opt_unroll CollatzBody = CollatzBody.
  (*[Eval/Unroll:2%]*) Axiom opt_unroll_test2 :
    opt_unroll FactBody <> FactBody.

  (*[Eval/Unroll:20%]*) Axiom opt_unroll_sound :
    forall (phi : environment) (c : cmd) (v v' : valuation),
      eval phi v c v' -> eval phi v (opt_unroll c) v'.
End S.

Global Arguments Nat.modulo !_ !_ /.
Global Arguments Nat.div !_ !_.
Global Arguments Nat.log2 !_ /.

(*|
TIPS: A few things that might be helpful keep in mind as you work on Pset 6
===========================================================================
 *)

(*|

Throughout the pset, think carefully on what you want to be doing induction on: commands, or proofs of `eval`?  In many cases both are possible, but not always: theorems that require reasoning about equivalences between loops will typically not be provable by induction on a command.

---

Do not assume that all lemmas are directly provable as stated: you will often need intermediate lemmas.  For example, for `eval_deterministic`, you will likely want to prove a variant with premises reordered to get a stronger induction hypothesis.  For `opt_constprop_sound`, you'll want to make a generalized version with an arbitrary `consts` set instead of `$0`.

---

Automation can help with many of the proofs in this pset.  The tactics `eval_intro` and `eval_elim` may be convenient building blocks to use in your own tactics.

To detect an arbitrary match from Ltac, use `match ?x with _ => _ end`:
|*)

Ltac cases_any :=
  match goal with
  | [ |- context[match ?x with _ => _ end] ] => cases x
  end.

Goal (forall x y z: bool, x || y || z || true = true).
Proof.
  unfold orb.
  simplify; repeat cases_any; eauto.
Qed.

(*|
---

Coq's standard library contains many lemmas — you do not need to prove
everything from first principles!  Among other lemmas, our solution uses the
following, which get automatically picked up by `simplify`.
|*)

Local Hint Rewrite Nat.mul_0_r Nat.div_1_r Nat.add_0_r.
Local Hint Rewrite <- Nat.ones_equiv.
Local Hint Rewrite Nat.mul_1_r Nat.shiftl_mul_pow2 Nat.shiftr_div_pow2 Nat.land_ones.

(*|

As always, use `Search` to find relevant lemmas.

---

Beware of issues with operator precedence:
- `(n - 1) mod 2` is not the same as `n - 1 mod 2`.
 *)

(*|
HINTS: A few hints to help you if you get stuck on certain
       problems in Pset 6.
       Beware! Don't read further if you don't want spoilers!
=============================================================
|*)

Module Hints (I: S). Import I.

(*
HINT 1: Constant propagation
============================

You will have an easier time if you define a function to test for constants, like so:

Definition as_const (e: expr) : option nat :=
  match e with
  | Const n => Some n
  | _ => None
  end.

Otherwise, goals will get very large.
*)

(*|
HINT 2: Constant propagation
============================

In the proof of `opt_constprop_sound`, or more likely the strengthened version of it, you will probably find the following lemma useful:

Lemma includes_remove_add (consts v: valuation) x n:
  consts $<= v ->
  consts $- x $<= v $+ (x, n).
Proof.
  simplify; apply includes_intro; simplify.
  cases (x ==v k); subst; simplify; try equality.
  eauto using includes_lookup.
Qed.
|*)

(*|
HINT 3: Loop unrolling
======================

In the implementation of `read_only`, you can use `if x ==v x0 then true else false` to get a Boolean indicating whether two variables are equal.
|*)

(*|
HINT 4: Loop unrolling
======================

Programs in this section can get pretty big — consider adding intermediate definitions and proving lemmas about them.  For example, I used this:
 *)

Definition loop1 x body :=
  body;; x <- x - 1.

Lemma opt_unroll_decr : forall {phi v v' x body n},
    eval phi v (loop1 x body) v' ->
    read_only body x = true ->
    v $? x = Some n ->
    v' $? x = Some (n - 1).
Abort.

(*|
The key difficulty in this problem is connecting the unrolled loop body to the original loop body.  Because of the way `EvalWhileTrue` and `EvalWhileFalse` are defined, regular induction gives you two cases: one where the loop exits immediately and one where it runs `n + 1` times.

Instead, you want to think about three cases: the loops exits immediately, the loop runs a single time, and the loop runs `n + 2` times.  The key is to make a lemma that mentions both of these cases at once.  Let's look at a concrete example:
|*)

Fixpoint even (n: nat) :=
  match n with
  | 0 => True
  | 1 => False
  | S (S n) => even n
  end.

Lemma even_sum : forall x y, even x -> even y -> even (x + y).
Proof.
  induct x; simplify.
  - assumption.
  - cases x.
    + equality.
    + simpl.

(*|
This proof is stuck: intuitively, IH steps one step forward, and we want to take two steps at once.
|*)

Abort.

(*|
The trick is to generalize the lemma to assert two "levels":
|*)

Lemma even_sum : forall x y,
    (even x -> even y -> even (x + y)) /\
    (even (S x) -> even y -> even (S x + y)).
Proof.
  induct x.
  - simplify; cases y; first_order.
  - simplify; firstorder.
Qed.

(*|
What does that mean for this pset?  Chances are you'll probably come up with a lemma that looks like this at some point:
|*)

Lemma opt_unroll_template_sound : forall phi v v' x body n,
    n mod 2 = 0 ->
    v $? x = Some n ->
    read_only body x = true ->
    eval phi v (while x loop (loop1 x body) done) v' ->
    eval phi v (while x loop (loop1 x body);; (loop1 x body) done) v'.
Abort.

(*|
… but it won't work by induction.  No, what you need is this, which *will* work by induction:
|*)

Lemma opt_unroll_template_mx_sound : forall phi v v' x body n,
    v $? x = Some n ->
    read_only body x = true ->
    eval phi v (while x loop (loop1 x body) done) v' ->
    eval phi v (if n mod 2 ==n 0 then
                while x loop (loop1 x body);; (loop1 x body) done
              else
                (loop1 x body);;
                while x loop (loop1 x body);; (loop1 x body) done) v'.
Abort.

(*|
One last trick: this form with an `if` is essentially a partially evaluated version of the full loop-unrolling template, with the “fixup” phase at the beginning.  In other words, you can prove the following theorem:
|*)

Lemma opt_unroll_eqn {phi v v' body x}:
  let n := match v $? x with Some n => n | None => 0 end in
  eval phi v (if n mod 2 ==n 0 then
              while x loop (loop1 x body);; (loop1 x body) done
            else
              (loop1 x body);;
              while x loop (loop1 x body);; (loop1 x body) done) v' ->
  eval phi v (when (x mod 2) then loop1 x body else Skip done;;
            while x loop (loop1 x body);; (loop1 x body) done) v'.
Abort.

End Hints.