(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 7: Model Checking
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Set Warnings "-notation-overridden". (* <-- needed while we play with defining one
                                      * of the book's notations ourselves locally *)
Require Import Frap TransitionSystems.

Set Implicit Arguments.

(* Coming up with invariants ourselves can be tedious!  Let's investigate how we
 * can automate the choice of invariants, for systems with only finitely many
 * reachable states.  This style is known as model checking.  First, let's think
 * more deliberately about how to grow a candidate invariant by adding new cases
 * that we missed.  Here's what it means for one invariant to retain all cases of
 * another. *)
Definition oneStepClosure_current {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st, invariant1 st
             -> invariant2 st.

(* And here's what it means to add all new states reachable from the original
 * set. *)
Definition oneStepClosure_new {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  forall st st', invariant1 st
                 -> sys.(Step) st st'
                 -> invariant2 st'.

(* Putting together the two conditions, we have a closure operator, for
 * enriching a candidate invariant with all new states reachable from it in a
 * single step. *)
Definition oneStepClosure {state} (sys : trsys state)
           (invariant1 invariant2 : state -> Prop) :=
  oneStepClosure_current sys invariant1 invariant2
  /\ oneStepClosure_new sys invariant1 invariant2.

(* Here's a simple restatement of [oneStepClosure] as a theorem with two
 * premises. *)
Theorem prove_oneStepClosure : forall state (sys : trsys state) (inv1 inv2 : state -> Prop),
  (forall st, inv1 st -> inv2 st)
  -> (forall st st', inv1 st -> sys.(Step) st st' -> inv2 st')
  -> oneStepClosure sys inv1 inv2.
Proof.
  unfold oneStepClosure.
  propositional.
Qed.

(* Now imagine the following general procedure to find an invariant.  Start with
 * the initial states as the candidate invariant.  Now take the one-step
 * closure, adding all states reachable in one step.  Then take it again, and
 * again, until the invariant is "big enough."  What is the formal meaning of
 * this termination condition?  We are done if one-step closure brings us back
 * to the original set.  (Of course, we must also retain all the initial
 * states.) *)
Theorem oneStepClosure_done : forall state (sys : trsys state) (invariant : state -> Prop),
  (forall st, sys.(Initial) st -> invariant st)
  -> oneStepClosure sys invariant invariant
  -> invariantFor sys invariant.
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new.
  propositional.
  apply invariant_induction.
  assumption.
  simplify.
  eapply H2.
  eassumption.
  assumption.
Qed.

(* Now we define an inductive relation, capturing repeated closure until
 * convergence. *)
Inductive multiStepClosure {state} (sys : trsys state)
  : (state -> Prop) -> (state -> Prop) -> Prop :=

(* We might be done, if one-step closure has no effect. *)
| MscDone : forall inv,
    oneStepClosure sys inv inv
    -> multiStepClosure sys inv inv

(* Or we might need to run another one-step closure and recurse. *)
| MscStep : forall inv inv' inv'',
    oneStepClosure sys inv inv'
    -> multiStepClosure sys inv' inv''
    -> multiStepClosure sys inv inv''.

(* Now, with the help of a lemma, we prove that multi-step closure is a sound
 * way to find an invariant for any transition system.  Note that we really do
 * not have that silver bullet here, because, for many systems, multi-step
 * closure does not terminate!  However, if it does, we get a correct
 * invariant. *)

Lemma multiStepClosure_ok' : forall state (sys : trsys state) (inv inv' : state -> Prop),
  multiStepClosure sys inv inv'
  -> (forall st, sys.(Initial) st -> inv st)
  -> invariantFor sys inv'.
Proof.
  induct 1; simplify.

  apply oneStepClosure_done.
  assumption.
  assumption.

  apply IHmultiStepClosure.
  simplify.
  unfold oneStepClosure, oneStepClosure_current in *.
  propositional.
  apply H3.
  apply H1.
  assumption.
Qed.

Theorem multiStepClosure_ok : forall state (sys : trsys state) (inv : state -> Prop),
  multiStepClosure sys sys.(Initial) inv
  -> invariantFor sys inv.
Proof.
  simplify.
  eapply multiStepClosure_ok'.
  eassumption.
  propositional.
Qed.

(* OK, great.  We know how to find invariants if we can evaluate one-step
 * closure efficiently.  Here's one case that is particularly easy to evaluate,
 * starting from the empty set as the invariant.  We use a function [constant]
 * from the FRAP library, for sets of finite size.  In general, we write
 * [constant [x1; ..., xN]] for the set [{x1, ..., xN}], and in fact the latter
 * notation is available, too. *)
Theorem oneStepClosure_empty : forall state (sys : trsys state),
  oneStepClosure sys (constant nil) (constant nil).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.
Qed.

(* In general, for finite sets, we'll compute one-step closure by closing
 * separately over each element of the set.  This theorem implements one step of
 * that process, where we learn that [inv1] accurately captures where we might
 * get from state [st] in one step.  States [sts] are those left over to
 * consider. *)
Theorem oneStepClosure_split : forall state (sys : trsys state) st sts (inv1 inv2 : state -> Prop),
  (forall st', sys.(Step) st st' -> inv1 st')
  -> oneStepClosure sys (constant sts) inv2
  -> oneStepClosure sys (constant (st :: sts)) ({st} \cup inv1 \cup inv2).
Proof.
  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; propositional.

  invert H0.

  left.
  (* [left] and [right]: prove a disjunction by proving the left or right case,
   *   respectively.  Note that here, we are using the fact that set union
   *   [\cup] is defined in terms of disjunction. *)
  left.
  simplify.
  propositional.

  right.
  apply H1.
  assumption.

  simplify.
  propositional.

  right.
  left.
  apply H.
  equality.

  right.
  right.
  eapply H2.
  eassumption.
  assumption.
Qed.

(* A trivial fact about union and singleton sets.
 * Note that we model sets as functions that are passed elements, deciding in
 * each case whether that element belongs to the set. *)
Theorem singleton_in : forall {A} (x : A) rest,
  ({x} \cup rest) x.
Proof.
  simplify.
  left.
  simplify.
  equality.
Qed.

(* OK, back to our example from last chapter, of factorial as a transition
 * system.  Here's a good overall correctness condition, which we didn't bother
 * to state before. *)
Definition fact_correct (original_input : nat) (st : fact_state) : Prop :=
  match st with
  | AnswerIs ans => fact original_input = ans
  | WithAccumulator _ _ => True
  end.

(* Let's also restate the initial-states set using a singleton set. *)
Theorem fact_init_is : forall original_input,
  fact_init original_input = {WithAccumulator original_input 1}.
Proof.
  simplify.
  apply sets_equal; simplify.
  (* Note the use of a theorem [sets_equal], saying that sets are equal if they
   * have the same elements. *)
  propositional.

  invert H.
  equality.

  rewrite <- H0.
  constructor.
Qed.

(* Now we will prove that factorial is correct, for the input 2, without needing
 * to write out an inductive invariant ourselves.  Note that it's important that
 * we choose a small, constant input, so that the reachable state space is
 * finite and tractable. *)
Theorem factorial_ok_2 :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  simplify.
  eapply invariant_weaken.
  (* We begin like in last chapter, by strengthening to an inductive
   * invariant. *)

  apply multiStepClosure_ok.
  (* The difference is that we will use multi-step closure to find the invariant
   * automatically.  Note that the invariant appears as an existential variable,
   * whose name begins with a question mark. *)
  simplify.
  rewrite fact_init_is.
  (* It's important to phrase the current candidate invariant explicitly as a
   * finite set, before continuing.  Otherwise, it won't be obvious how to take
   * the one-step closure. *)

  (* Compute which states are reachable after one step. *)
  eapply MscStep.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  (* Compute which states are reachable after two steps. *)
  eapply MscStep.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  (* Compute which states are reachable after three steps. *)
  eapply MscStep.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_split; simplify.
  invert H; simplify.
  apply singleton_in.
  apply oneStepClosure_empty.
  simplify.

  (* Now the candidate invariant is closed under single steps.  Let's prove
   * it. *)
  apply MscDone.
  apply prove_oneStepClosure; simplify.
  propositional.
  propositional; invert H0; try equality.
  invert H; equality.
  invert H1; equality.

  (* Finally, we prove that our new invariant implies the simpler, noninductive
   * one that we started with. *)
  simplify.
  propositional; subst; simplify; propositional.
  (* [subst]: remove all hypotheses like [x = e] for variables [x], simply
   *   replacing all uses of [x] by [e]. *)
Qed.

(* That process was so rote that we can automate it all, in a generic way that
 * will work for most transition systems that have finitely many reachable
 * states.  Here is a definition of some tactics to do the work.
 * BEGIN CODE THAT WILL NOT BE EXPLAINED IN DETAIL! *)

Local Hint Rewrite fact_init_is.

Ltac model_check_done :=
  apply MscDone; apply prove_oneStepClosure; simplify; propositional; subst;
  repeat match goal with
         | [ H : _ |- _ ] => invert H
         end; simplify; equality.

Theorem singleton_in_other : forall {A} (x : A) (s1 s2 : set A),
  s2 x
  -> (s1 \cup s2) x.
Proof.
  simplify.
  right.
  right.
  assumption.
Qed.

Ltac singletoner :=
  repeat match goal with
         | [ |- _ ?S ] => idtac S; apply singleton_in
         | [ |- (_ \cup _) _ ] => apply singleton_in_other
         end.

Ltac model_check_step0 :=
  eapply MscStep; [
    repeat ((apply oneStepClosure_empty; simplify)
            || (apply oneStepClosure_split; [ simplify;
                                              repeat match goal with
                                                     | [ H : _ |- _ ] => invert H; try congruence
                                                     end; solve [ singletoner ] | ]))
  | simplify ].

Ltac model_check_step :=
  match goal with
  | [ |- multiStepClosure _ ?inv1 _ ] =>
    model_check_step0;
    match goal with
    | [ |- multiStepClosure _ ?inv2 _ ] =>
      (assert (inv1 = inv2) by compare_sets; fail 3)
      || idtac
    end
  end.

Ltac model_check_steps1 := model_check_step || model_check_done.
Ltac model_check_steps := repeat model_check_steps1.

Ltac model_check_finish := simplify; propositional; subst; simplify; equality.

Ltac model_check_infer :=
  apply multiStepClosure_ok; simplify; model_check_steps.

Ltac model_check_find_invariant :=
  simplify; eapply invariant_weaken; [ model_check_infer | ]; cbv beta in *.

Ltac model_check := model_check_find_invariant; model_check_finish.

(* END CODE THAT WILL NOT BE EXPLAINED IN DETAIL! *)

(* Now watch this.  We can check various instances of factorial
 * automatically.  Notice that reachable states are printed as we encounter them
 * in exploration, using [idtac] invocations above.  This printing is for the
 * user's understanding and has no logical meaning. *)

Theorem factorial_ok_2_snazzy :
  invariantFor (factorial_sys 2) (fact_correct 2).
Proof.
  model_check.
Qed.

Theorem factorial_ok_3 :
  invariantFor (factorial_sys 3) (fact_correct 3).
Proof.
  model_check.
Qed.

Theorem factorial_ok_5 :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check.
Qed.

(* Let's see that last one broken into two steps, so that we get a look at the
 * inferred invariant. *)
Theorem factorial_ok_5_again :
  invariantFor (factorial_sys 5) (fact_correct 5).
Proof.
  model_check_find_invariant.
  model_check_finish.
Qed.

(** * Abstraction *)

(* It's lovely when we happen to be analyzing a system with a finite state
 * space, but usually we aren't that lucky.  For instance, imagine that we are
 * using a programming language with infinite-precision integers, and we want to
 * check this program:
 * <<
   int global = 0;

   thread() {
     int local;

     while (true) {
       local = global;
       global = local + 2;
     }
   }
   >>
 * The program loops indefinitely, adding 2 to a global variable.  We want to
 * prove that "global" always holds an even value.  Here's how we can formalize
 * evenness inductively. *)

Inductive isEven : nat -> Prop :=
| EvenO : isEven 0
| EvenSS : forall n, isEven n -> isEven (S (S n)).

(* And now we define a transition system for the program, in a process that
 * should be routine by now.  We use last chapter's concept of a multithreaded
 * transition system. *)

Inductive add2_thread :=
| Read
| Write (local : nat).

Inductive add2_init : threaded_state nat add2_thread -> Prop :=
| Add2Init : add2_init {| Shared := 0; Private := Read |}.

Inductive add2_step : threaded_state nat add2_thread -> threaded_state nat add2_thread -> Prop :=
| StepRead : forall global,
    add2_step {| Shared := global; Private := Read |}
              {| Shared := global; Private := Write global |}
| StepWrite : forall global local,
    add2_step {| Shared := global; Private := Write local |}
              {| Shared := S (S local); Private := Read |}.

Definition add2_sys1 := {|
  Initial := add2_init;
  Step := add2_step
|}.

Definition add2_sys := parallel add2_sys1 add2_sys1.

(* Here is the invariant we want to prove. *)
Definition add2_correct (st : threaded_state nat (add2_thread * add2_thread)) :=
  isEven st.(Shared).

(* We can't model-check [add2_sys] directly, because it can reach infinitely
 * many states.  Even if we worked with fixed-precision integers, say with 64
 * bits, the state space would be impractically large to explore directly.
 * Instead, we will *abstract* this system into another one that retains its
 * essential properties.  In particular, we want to find another transition
 * system that *simulates* this one, in the sense made precise by this
 * definition, where [sys1] will be [add2_sys] for this example. *)
Inductive simulates state1 state2 (R : state1 -> state2 -> Prop)
  (* [R] is a relation connecting the states of the two systems. *)
  (sys1 : trsys state1) (sys2 : trsys state2) : Prop :=
| Simulates :
  (* Every initial state of [sys1] has some matching initial state of [sys2]. *)
  (forall st1, sys1.(Initial) st1
               -> exists st2, R st1 st2
                              /\ sys2.(Initial) st2)

  (* Starting from a pair of related states, every step in [sys1] can be matched
   * in [sys2], to destinations that are also related. *)
  -> (forall st1 st2, R st1 st2
                      -> forall st1', sys1.(Step) st1 st1'
                                      -> exists st2', R st1' st2'
                                                      /\ sys2.(Step) st2 st2')

  -> simulates R sys1 sys2.

(* Given an invariant for [sys2], we now have a generic way of defining an
 * invariant for [sys1], by composing with [R]. *)
Inductive invariantViaSimulation state1 state2 (R : state1 -> state2 -> Prop)
  (inv2 : state2 -> Prop)
  : state1 -> Prop :=
| InvariantViaSimulation : forall st1 st2, R st1 st2
  -> inv2 st2
  -> invariantViaSimulation R inv2 st1.

(* By way of a lemma, let's prove that, given a simulation, any
 * invariant-via-simulation really is an invariant for the original system. *)
Lemma invariant_simulates' : forall state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2),
  (forall st1 st2, R st1 st2
                   -> forall st1', sys1.(Step) st1 st1'
                                   ->  exists st2', R st1' st2'
                                                    /\ sys2.(Step) st2 st2')
  -> forall st1 st1', sys1.(Step)^* st1 st1'
                      -> forall st2, R st1 st2
                                     -> exists st2', R st1' st2'
                                                     /\ sys2.(Step)^* st2 st2'.
Proof.
  induct 2.

  simplify.
  exists st2.
  (* [exists E]: prove [exists x, P(x)] by proving [P(E)]. *)
  propositional.
  constructor.

  simplify.
  eapply H in H2.
  first_order.
  (* [first_order]: simplify first-order logic structure.  Be forewarned: this
   *   one is especially likely to run forever! *)
  apply IHtrc in H2.
  first_order.
  exists x1.
  propositional.
  econstructor.
  eassumption.
  assumption.
  assumption.
Qed.

Theorem invariant_simulates : forall state1 state2 (R : state1 -> state2 -> Prop)
  (sys1 : trsys state1) (sys2 : trsys state2) (inv2 : state2 -> Prop),
  simulates R sys1 sys2
  -> invariantFor sys2 inv2
  -> invariantFor sys1 (invariantViaSimulation R inv2).
Proof.
  simplify.
  invert H.
  unfold invariantFor; simplify.
  apply H1 in H.
  first_order.
  apply invariant_simulates' with (sys2 := sys2) (R := R) (st2 := x) in H3; try assumption.
  first_order.
  unfold invariantFor in H0.
  apply H0 with (s' := x0) in H4; try assumption.
  econstructor.
  eassumption.
  assumption.
Qed.

(* OK, that's a general theory for abstracting a system with another one that
 * simulates it.  What abstraction will work for our example of the two threads
 * and the counter?  Here's another program that has replaced integers with
 * Booleans, where the Boolean is true iff the matching integer is even.
 * <<
    bool global = true;

    thread() {
      bool local;

      while (true) {
        local = global;
        global = local;
      }
    }
   >>
 * We can formalize this program as a transition system, too. *)

Inductive add2_bthread :=
| BRead
| BWrite (local : bool).

Inductive add2_binit : threaded_state bool add2_bthread -> Prop :=
| Add2BInit : add2_binit {| Shared := true; Private := BRead |}.

Inductive add2_bstep : threaded_state bool add2_bthread -> threaded_state bool add2_bthread -> Prop :=
| StepBRead : forall global,
    add2_bstep {| Shared := global; Private := BRead |}
               {| Shared := global; Private := BWrite global |}
| StepBWrite : forall global local,
    add2_bstep {| Shared := global; Private := BWrite local |}
               {| Shared := local; Private := BRead |}.

Definition add2_bsys1 := {|
  Initial := add2_binit;
  Step := add2_bstep
|}.

Definition add2_bsys := parallel add2_bsys1 add2_bsys1.

(* This invariant formalizes the connection between local states of threads, in
 * the original and abstracted systems. *)
Inductive R_private1 : add2_thread -> add2_bthread -> Prop :=
| RpRead : R_private1 Read BRead
| RpWrite : forall n b, (b = true <-> isEven n)
                        -> R_private1 (Write n) (BWrite b).

(* We lift [R_private1] to a relation over whole states. *)
Inductive add2_R : threaded_state nat (add2_thread * add2_thread)
                   -> threaded_state bool (add2_bthread * add2_bthread)
                   -> Prop :=
| Add2_R : forall n b th1 th2 th1' th2',
  (b = true <-> isEven n)
  -> R_private1 th1 th1'
  -> R_private1 th2 th2'
  -> add2_R {| Shared := n; Private := (th1, th2) |}
            {| Shared := b; Private := (th1', th2') |}.

(* Let's also recharacterize the initial states via a singleton set. *)
Theorem add2_init_is :
  parallel_init add2_binit add2_binit = { {| Shared := true; Private := (BRead, BRead) |} }.
Proof.
  simplify.
  apply sets_equal; simplify.
  propositional.

  invert H.
  invert H2.
  invert H4.
  equality.

  invert H0.
  constructor.
  constructor.
  constructor.
Qed.

(* We ask Coq to remember this lemma as a hint, which will be used by the
 * model-checking tactics that we refrain from explaining in detail. *)
Local Hint Rewrite add2_init_is.

(* Now, let's verify the original system. *)
Theorem add2_ok :
  invariantFor add2_sys add2_correct.
Proof.
  (* First step: strengthen the invariant.  We leave an underscore for the
   * unknown invariant, to be found by model checking. *)
  eapply invariant_weaken with (invariant1 := invariantViaSimulation add2_R _).

  (* One way to find an invariant-by-simulation is to find an invariant for the
   * abstracted system, as this step asks to do. *)
  apply invariant_simulates with (sys2 := add2_bsys).

  (* Now we must prove that the simulation via [add2_R] is valid, which is
   * routine. *)
  constructor; simplify.

  invert H.
  invert H0.
  invert H1.
  exists {| Shared := true; Private := (BRead, BRead) |}; simplify.
  propositional.
  constructor.
  propositional.
  constructor.
  constructor.
  constructor.

  invert H.
  invert H0; simplify.

  invert H7.

  invert H2.
  exists {| Shared := b; Private := (BWrite b, th2') |}.
  propositional.
  constructor.
  propositional.
  constructor.
  propositional.
  assumption.
  constructor.
  constructor.

  invert H2.
  exists {| Shared := b0; Private := (BRead, th2') |}.
  propositional.
  constructor.
  propositional.
  constructor.
  assumption.
  invert H0.
  propositional.
  constructor.
  assumption.
  constructor.
  constructor.

  invert H7.

  invert H3.
  exists {| Shared := b; Private := (th1', BWrite b) |}.
  propositional.
  constructor.
  propositional.
  assumption.
  constructor.
  propositional.
  constructor.
  constructor.

  invert H3.
  exists {| Shared := b0; Private := (th1', BRead) |}.
  propositional.
  constructor.
  propositional.
  constructor.
  assumption.
  invert H0.
  propositional.
  assumption.
  constructor.
  constructor.
  constructor.

  (* OK, we're glad to have that over with!  Such a process could also be
   * automated, but we won't bother doing so here.  However, we are now in a
   * good state, where our model checker can find the invariant
   * automatically. *)
  model_check_infer.
  (* It finds exactly four reachable states.  We finish by showing that they all
   * obey the original invariant. *)

  invert 1. (* Note that this [1] means "first premise below the double
             * line." *)
  invert H0.
  simplify.
  unfold add2_correct.
  simplify.
  propositional; subst.

  invert H.
  propositional.

  invert H1.
  propositional.

  invert H.
  propositional.

  invert H1.
  propositional.
Qed.

(** * Another abstraction example *)

(* Let's try a fancier example of abstraction.  Here's a simple integer
 * function.
 * <<
    f(int n) {
      int i, j;

      i = 0;
      j = 0;
      while (n > 0) {
        i = i + n;
        j = j + n;
        n = n - 1;
      }
    }
   >>
 * We might want to prove that "i" and "j" are always equal at the end.
 * First, we formalize the transition system. *)

Inductive pc :=
| i_gets_0
| j_gets_0
| Loop
| i_add_n
| j_add_n
| n_sub_1
| Done.

Record vars := {
  N : nat;
  I : nat;
  J : nat
}.

Record state := {
  Pc : pc;
  Vars : vars
}.

Inductive initial : state -> Prop :=
| Init : forall vs, initial {| Pc := i_gets_0; Vars := vs |}.

Inductive step : state -> state -> Prop :=
| Step_i_gets_0 : forall n i j,
  step {| Pc := i_gets_0; Vars := {| N := n;
                                     I := i;
                                     J := j |} |}
       {| Pc := j_gets_0; Vars := {| N := n;
                                     I := 0;
                                     J := j |} |}
| Step_j_gets_0 : forall n i j,
  step {| Pc := j_gets_0; Vars := {| N := n;
                                     I := i;
                                     J := j |} |}
       {| Pc := Loop; Vars := {| N := n;
                                 I := i;
                                 J := 0 |} |}
| Step_Loop_done : forall i j,
  step {| Pc := Loop; Vars := {| N := 0;
                                 I := i;
                                 J := j |} |}
       {| Pc := Done; Vars := {| N := 0;
                                 I := i;
                                 J := j |} |}
| Step_Loop_enter : forall n i j,
  step {| Pc := Loop; Vars := {| N := S n;
                                 I := i;
                                 J := j |} |}
       {| Pc := i_add_n; Vars := {| N := S n;
                                    I := i;
                                    J := j |} |}
| Step_i_add_n : forall n i j,
  step {| Pc := i_add_n; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := j_add_n; Vars := {| N := n;
                                    I := i + n;
                                    J := j |} |}
| Step_j_add_n : forall n i j,
  step {| Pc := j_add_n; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := n_sub_1; Vars := {| N := n;
                                    I := i;
                                    J := j + n |} |}
| Step_n_sub_1 : forall n i j,
  step {| Pc := n_sub_1; Vars := {| N := n;
                                    I := i;
                                    J := j |} |}
       {| Pc := Loop; Vars := {| N := n - 1;
                                 I := i;
                                 J := j |} |}.

Definition loopy_sys := {|
  Initial := initial;
  Step := step
|}.

Definition loopy_correct (st : state) :=
  st.(Pc) = Done -> st.(Vars).(I) = st.(Vars).(J).

(* Which abstraction will give us a finite-state system?  Unlike with factorial,
 * here we are more ambitious, seeking an abstraction that will be finite-state
 * even when considering all possible parameter values "n".  Let's try this
 * simple abstract version of variable state. *)
Inductive absvars :=
| Unknown
  (* We don't know anything about the values of the variables. *)
| i_is_0
  (* We know [i == 0]. *)
| i_eq_j
  (* We know [i == j]. *)
| i_eq_j_plus_n.
  (* We know [i == j + n]. *)

(* To get our abstract states, we keep the same program counters and just change
 * out the variable state. *)
Record absstate := {
  APc : pc;
  AVars : absvars
}.

(* Here's the rather boring new abstract step relation.  Note the clever state
 * transformations, in terms of our new abstraction. *)
Inductive absstep : absstate -> absstate -> Prop :=
| AStep_i_gets_0 : forall vs,
  absstep {| APc := i_gets_0; AVars := vs |}
          {| APc := j_gets_0; AVars := i_is_0 |}
| AStep_j_gets_0_i_is_0 :
  absstep {| APc := j_gets_0; AVars := i_is_0 |}
          {| APc := Loop; AVars := i_eq_j |}
| AStep_j_gets_0_Other : forall vs,
  vs <> i_is_0
  -> absstep {| APc := j_gets_0; AVars := vs |}
             {| APc := Loop; AVars := Unknown |}
| AStep_Loop_done : forall vs,
  absstep {| APc := Loop; AVars := vs |}
          {| APc := Done; AVars := vs |}
| AStep_Loop_enter : forall vs,
  absstep {| APc := Loop; AVars := vs |}
          {| APc := i_add_n; AVars := vs |}
| AStep_i_add_n_i_eq_j :
  absstep {| APc := i_add_n; AVars := i_eq_j |}
          {| APc := j_add_n; AVars := i_eq_j_plus_n |}
| AStep_i_add_n_Other : forall vs,
  vs <> i_eq_j
  -> absstep {| APc := i_add_n; AVars := vs |}
             {| APc := j_add_n; AVars := Unknown |}
| AStep_j_add_n_i_eq_j_plus_n :
  absstep {| APc := j_add_n; AVars := i_eq_j_plus_n |}
          {| APc := n_sub_1; AVars := i_eq_j |}
| AStep_j_add_n_i_Other : forall vs,
  vs <> i_eq_j_plus_n
  -> absstep {| APc := j_add_n; AVars := vs |}
             {| APc := n_sub_1; AVars := Unknown |}
| AStep_n_sub_1_bad :
  absstep {| APc := n_sub_1; AVars := i_eq_j_plus_n |}
          {| APc := Loop; AVars := Unknown |}
| AStep_n_sub_1_good : forall vs,
  vs <> i_eq_j_plus_n
  -> absstep {| APc := n_sub_1; AVars := vs |}
             {| APc := Loop; AVars := vs |}.

Definition absloopy_sys := {|
  Initial := { {| APc := i_gets_0; AVars := Unknown |} };
  Step := absstep
|}.

(* Now we need our simulation relation.  First, we define one just at the level
 * of local-variable state.  It formalizes our intuition about those values. *)
Inductive Rvars : vars -> absvars -> Prop :=
| Rv_Unknown : forall vs, Rvars vs Unknown
| Rv_i_is_0 : forall vs, vs.(I) = 0 -> Rvars vs i_is_0
| Rv_i_eq_j : forall vs, vs.(I) = vs.(J) -> Rvars vs i_eq_j
| Rv_i_eq_j_plus_n : forall vs, vs.(I) = vs.(J) + vs.(N) -> Rvars vs i_eq_j_plus_n.

(* We lift to full states in the obvious way. *)
Inductive R : state -> absstate -> Prop :=
| Rcon : forall pc vs avs, Rvars vs avs -> R {| Pc := pc; Vars := vs |}
                                             {| APc := pc; AVars := avs |}.

(* Now we are ready to prove the original system correct. *)
Theorem loopy_ok :
  invariantFor loopy_sys loopy_correct.
Proof.
  eapply invariant_weaken with (invariant1 := invariantViaSimulation R _).
  apply invariant_simulates with (sys2 := absloopy_sys).

  (* Here comes another boring simulation proof. *)
  constructor; simplify.

  invert H.
  exists {| APc := i_gets_0; AVars := Unknown |}.
  propositional.
  constructor.
  constructor.

  invert H0.

  invert H.
  exists {| APc := j_gets_0; AVars := i_is_0 |}.
  propositional; repeat constructor.

  invert H.
  invert H3.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_eq_j |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.

  exists {| APc := Done; AVars := st2.(AVars) |}.
  invert H; simplify; propositional; repeat constructor; equality.

  exists {| APc := i_add_n; AVars := st2.(AVars) |}.
  invert H; simplify; propositional; repeat constructor; equality.

  invert H.
  invert H3.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := j_add_n; AVars := i_eq_j_plus_n |}; repeat constructor; simplify; equality.
  exists {| APc := j_add_n; AVars := Unknown |}; repeat constructor; equality.

  invert H.
  invert H3.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := Unknown |}; repeat constructor; equality.
  exists {| APc := n_sub_1; AVars := i_eq_j |}; repeat constructor; simplify; equality.

  invert H.
  invert H3.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_is_0 |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := i_eq_j |}; propositional; repeat constructor; equality.
  exists {| APc := Loop; AVars := Unknown |}; propositional; repeat constructor; equality.

  (* Finally, we can call the model checker to find an invariant of the abstract
   * system. *)
  model_check_infer.
  (* We get 7 neat little states, one per program counter.  Next, we prove that
   * each of them implies the original invariant. *)

  invert 1.
  invert H0.
  unfold loopy_correct.
  simplify.
  propositional; subst.

  (* Most of the hypotheses we invert are contradictory, implying that distinct
   * program counters are equal. *)

  invert H2.

  invert H1.

  invert H2.

  invert H1.
  invert H.
  assumption.

  invert H2.

  invert H1.

  invert H2.
Qed.

(** * Modularity *)

(* Throughout the book, we'll come again and again to our two main weapons in
 * soundly modeling complex transition systems with simpler ones.  We just
 * learned about *abstraction*, to replace a full system with a simpler one.
 * The other key one is *modularity*, to replace a system with several others.
 * Let's study one example that helps with model checking, allowing us to check
 * programs with arbitrarily many threads running the same code, while still
 * finding an invariant automatically by brute-force enumeration. *)

(* The key to this particular technique is instrumenting a step relation to
 * consider *interference*, or the actions that other threads might take, in
 * between steps of the thread that we focus on.  This relation is parameterized
 * on an invariant [inv] that the other threads guarantee to preserve on the
 * shared state.  That is, the other threads may mess with the shared state
 * arbitrarily between our own steps, *but* they guarantee that every value they
 * set for it satisfies [inv]. *)
Inductive stepWithInterference shared private (inv : shared -> Prop)
          (step : threaded_state shared private -> threaded_state shared private -> Prop)
          : threaded_state shared private -> threaded_state shared private -> Prop :=

(* First kind of step: this thread runs in the normal way. *)
| StepSelf : forall st st',
  step st st'
  -> stepWithInterference inv step st st'

(* Second kind of step: other threads change shared state to some new value
 * satisfying [inv]. *)
| StepEnvironment : forall sh pr sh',
  inv sh'
  -> stepWithInterference inv step
                          {| Shared := sh; Private := pr |}
                          {| Shared := sh'; Private := pr |}.

(* Via this relation, we have an operator to build a new transition system from
 * an old one, given [inv]. *)
Definition withInterference shared private (inv : shared -> Prop)
           (sys : trsys (threaded_state shared private))
  : trsys (threaded_state shared private) := {|
  Initial := sys.(Initial);
  Step := stepWithInterference inv sys.(Step)
|}.

(* Tired of simulation proofs yet?  Then you'll love this theorem, which shows
 * a free simulation for any use of [withInterference]!  We even get to pick the
 * trivial simulation relation, state equality. *)
Theorem withInterference_abstracts : forall shared private (inv : shared -> Prop)
                                           (sys : trsys (threaded_state shared private)),
  simulates (fun st st' => st = st') sys (withInterference inv sys).
Proof.
  simplify.
  constructor; simplify.

  exists st1; propositional.

  exists st1'; propositional.
  constructor.
  equality.
Qed.

(* That proof was pretty straightforward, because we could construct the
 * simulation using only the first rule of [stepWithInterference], ignoring the
 * possibility for steps by other threads.  We go next for a theorem with an
 * intimidating statement and a much more interesting proof, whose details we
 * nonetheless won't comment on in text.  It may make sense to skip past the
 * next two lemma statements to the main theorem [withInterference_parallel]. *)
Lemma withInterference_parallel_init : forall shared private1 private2
                                          (invs : shared -> Prop)
                                          (sys1 : trsys (threaded_state shared private1))
                                          (sys2 : trsys (threaded_state shared private2))
                                          st st',
  (withInterference invs (parallel sys1 sys2)).(Step)^* st st'
  -> forall st1 st2,
      (forall st1', (withInterference invs sys1).(Step)^* st1 st1' -> invs st1'.(Shared))
      -> (forall st2', (withInterference invs sys2).(Step)^* st2 st2' -> invs st2'.(Shared))
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st.(Shared);
                                               Private := fst st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st.(Shared);
                                               Private := snd st.(Private) |}
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st'.(Shared);
                                               Private := fst st'.(Private) |}.
Proof.
  induct 1; simplify.

  assumption.

  invert H; simplify.
  invert H5; simplify.

  apply IHtrc with (st2 := {| Shared := sh'; Private := pr2 |}).
  simplify.
  apply H1.
  assumption.
  simplify.
  eapply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H1 with (st1' := {| Shared := sh'; Private := pr1' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  assumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.

  apply IHtrc with (st2 := {| Shared := sh'; Private := pr2' |}).
  assumption.
  simplify.
  apply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  eassumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H2 with (st2' := {| Shared := sh'; Private := pr2' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.
  constructor.

  apply IHtrc with (st2 := {| Shared := sh'; Private := snd pr |}).
  assumption.
  simplify.
  eapply H2.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  assumption.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  constructor.
  constructor.
Qed.

Lemma withInterference_parallel_step : forall shared private1 private2
                                              (invs : shared -> Prop)
                                              (sys1 : trsys (threaded_state shared private1))
                                              (sys2 : trsys (threaded_state shared private2))
                                              st st',
  (withInterference invs (parallel sys1 sys2)).(Step)^* st st'
  -> forall st1 st2,
      (forall st1', (withInterference invs sys1).(Step)^* st1 st1' -> invs st1'.(Shared))
      -> (forall st2', (withInterference invs sys2).(Step)^* st2 st2' -> invs st2'.(Shared))
      -> (withInterference invs sys1).(Step)^* st1
                                            {| Shared := st.(Shared);
                                               Private := fst st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st.(Shared);
                                               Private := snd st.(Private) |}
      -> (withInterference invs sys2).(Step)^* st2
                                            {| Shared := st'.(Shared);
                                               Private := snd st'.(Private) |}.
Proof.
  induct 1; simplify.

  assumption.

  invert H; simplify.
  invert H5; simplify.

  apply IHtrc with (st1 := {| Shared := sh'; Private := pr1' |}).
  simplify.
  apply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H1 with (st1' := {| Shared := sh'; Private := pr1' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  econstructor.
  eassumption.
  constructor.
  constructor.

  apply IHtrc with (st1 := {| Shared := sh'; Private := pr1 |}).
  simplify.
  apply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  apply H2 with (st2' := {| Shared := sh'; Private := pr2' |}).
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  constructor.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  constructor.
  eassumption.
  constructor.

  apply IHtrc with (st1 := {| Shared := sh'; Private := fst pr |}).
  simplify.
  eapply H1.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  assumption.
  assumption.
  constructor.
  eapply trc_trans.
  eassumption.
  eapply TrcFront.
  apply StepEnvironment with (sh' := sh').
  assumption.
  constructor.
Qed.

(* OK, we made it to the main theorem.  It helps us find an invariant for a
 * [parallel] system to which we have applied the [withInterference]
 * construction.  Crucially, we may check the invariant for each constituent
 * thread *separately*, avoiding the combinatorial state-space explosion that
 * would come from analyzing the combined system directly.  This is the essence
 * of modularity! *)
Theorem withInterference_parallel : forall shared private1 private2
                                           (invs : shared -> Prop)
                                           (sys1 : trsys (threaded_state shared private1))
                                           (sys2 : trsys (threaded_state shared private2)),
    invariantFor (withInterference invs sys1)
                 (fun st => invs st.(Shared))
    -> invariantFor (withInterference invs sys2)
                    (fun st => invs st.(Shared))
    -> invariantFor (withInterference invs (parallel sys1 sys2))
                    (fun st => invs st.(Shared)).
Proof.
  unfold invariantFor.
  simplify.
  invert H1.

  (* [assert P]: first prove proposition [P], then continue with it as a new
   *   hypothesis. *)
  assert ((withInterference invs sys1).(Step)^*
             {| Shared := sh; Private := pr1 |}
             {| Shared := s'.(Shared); Private := fst s'.(Private) |}).
  apply withInterference_parallel_init with (sys2 := sys2)
                                            (st := {| Shared := sh; Private := (pr1, pr2) |})
                                            (st2 := {| Shared := sh; Private := pr2 |});
    simplify; propositional.
  apply H in H1; propositional.
  apply H0 in H1; propositional.
  constructor.
  constructor.

  assert ((withInterference invs sys2).(Step)^*
             {| Shared := sh; Private := pr2 |}
             {| Shared := s'.(Shared); Private := snd s'.(Private) |}).
  apply withInterference_parallel_step with (sys1 := sys1)
                                            (st := {| Shared := sh; Private := (pr1, pr2) |})
                                            (st1 := {| Shared := sh; Private := pr1 |});
    simplify; propositional.
  apply H in H5; propositional.
  apply H0 in H5; propositional.
  constructor.
  constructor.

  apply H in H1; try assumption.
Qed.

(* Let's apply this principle on a concrete example.  Consider a program with
 * many threads running calls to this function.
 * <<
    int global = 0;

    f() {
      int local = 0;

      while (true) {
        local = global;
        local = 3 + local;
        local = 7 + local;
        global = local;
      }
    }
   >>
 * Here's the usual formalization as a transition system. *)

Inductive twoadd_pc := ReadIt | Add3 | Add7 | WriteIt.

Definition twoadd_initial := { {| Shared := 0; Private := (ReadIt, 0) |} }.

Inductive twoadd_step : threaded_state nat (twoadd_pc * nat)
                        -> threaded_state nat (twoadd_pc * nat) -> Prop :=
| Step_ReadIt : forall g l,
  twoadd_step {| Shared := g; Private := (ReadIt, l) |}
              {| Shared := g; Private := (Add3, g) |}
| Step_Add3 : forall g l,
  twoadd_step {| Shared := g; Private := (Add3, l) |}
              {| Shared := g; Private := (Add7, 3 + l) |}
| Step_Add7 : forall g l,
  twoadd_step {| Shared := g; Private := (Add7, l) |}
              {| Shared := g; Private := (WriteIt, 7 + l) |}
| Step_WriteIt : forall g l,
  twoadd_step {| Shared := g; Private := (WriteIt, l) |}
              {| Shared := l; Private := (ReadIt, l) |}.

Definition twoadd_sys := {|
  Initial := twoadd_initial;
  Step := twoadd_step
|}.

(* Invariant to prove: the global variable is always even, again. *)
Definition twoadd_correct private (st : threaded_state nat private) :=
  isEven st.(Shared).

(* Here's an abstract version of the system where, much like before, we model
 * integers as Booleans, recording whether they are even or not. *)

Definition twoadd_ainitial := { {| Shared := true; Private := (ReadIt, true) |} }.

Inductive twoadd_astep : threaded_state bool (twoadd_pc * bool)
                        -> threaded_state bool (twoadd_pc * bool) -> Prop :=
| AStep_ReadIt : forall g l,
  twoadd_astep {| Shared := g; Private := (ReadIt, l) |}
               {| Shared := g; Private := (Add3, g) |}
| AStep_Add3 : forall g l,
  twoadd_astep {| Shared := g; Private := (Add3, l) |}
               {| Shared := g; Private := (Add7, negb l) |}
| AStep_Add7 : forall g l,
  twoadd_astep {| Shared := g; Private := (Add7, l) |}
               {| Shared := g; Private := (WriteIt, negb l) |}
| AStep_WriteIt : forall g l,
  twoadd_astep {| Shared := g; Private := (WriteIt, l) |}
               {| Shared := l; Private := (ReadIt, l) |}
| AStep_Someone_Made_It_Even : forall g pr,
  twoadd_astep {| Shared := g; Private := pr |}
               {| Shared := true; Private := pr |}.

Definition twoadd_asys := {|
  Initial := twoadd_ainitial;
  Step := twoadd_astep
|}.

(* Here's a simulation relation at the level of integers and their Boolean
 * counterparts. *)
Definition even_R (n : nat) (b : bool) :=
  isEven n <-> b = true.

(* A few unsurprising properties hold of [even_R]. *)

Lemma even_R_0 : even_R 0 true.
Proof.
  unfold even_R; propositional.
  constructor.
Qed.

Lemma even_R_forward : forall n, isEven n -> even_R n true.
Proof.
  unfold even_R; propositional.
Qed.

Lemma even_R_backward : forall n, even_R n true -> isEven n.
Proof.
  unfold even_R; propositional.
Qed.

Lemma even_R_add2 : forall n b,
  even_R n b
  -> even_R (S (S n)) b.
Proof.
  unfold even_R; propositional.
  invert H; propositional.
  constructor; assumption.
Qed.

(* The cases for evenness of an integer and its successor *)
Lemma isEven_decide : forall n,
  (isEven n /\ ~isEven (S n)) \/ (~isEven n /\ isEven (S n)).
Proof.
  induct n; simplify; propositional.

  left; propositional.
  constructor.
  invert H.

  right; propositional.
  constructor; assumption.

  left; propositional.
  invert H.
  propositional.
Qed.

Lemma even_R_add1 : forall n b,
  even_R n b
  -> even_R (S n) (negb b).
Proof.
  unfold even_R; simplify.
  assert ((isEven n /\ ~isEven (S n)) \/ (~isEven n /\ isEven (S n))).
  apply isEven_decide.
  cases b; simplify; propositional.
  equality.
  equality.
Qed.

(* Here's the top-level simulation relation for our choice of abstraction. *)
Inductive twoadd_R : threaded_state nat (twoadd_pc * nat)
                     -> threaded_state bool (twoadd_pc * bool) -> Prop :=
| Twoadd_R : forall pc gn ln gb lb,
  even_R gn gb
  -> even_R ln lb
  -> twoadd_R {| Shared := gn; Private := (pc, ln) |}
              {| Shared := gb; Private := (pc, lb) |}.

(* Step 1 of main proof: model-check an individual thread. *)
Lemma twoadd_ok :
  invariantFor (withInterference isEven twoadd_sys)
               (fun st => isEven (Shared st)).
Proof.
  eapply invariant_weaken.
  apply invariant_simulates with (sys2 := twoadd_asys) (R := twoadd_R).

  (* Boring simulation proof begins here. *)
  constructor; simplify.

  invert H.
  exists {| Shared := true; Private := (ReadIt, true) |}; propositional.
  constructor; propositional.
  apply even_R_0.
  apply even_R_0.
  constructor.
  equality.
  simplify.
  propositional.

  invert H0.
  invert H1.

  invert H.
  exists {| Shared := gb; Private := (Add3, gb) |}; propositional.
  constructor; propositional.
  constructor.

  invert H.
  exists {| Shared := gb; Private := (Add7, negb lb) |}; propositional.
  constructor; propositional.
  apply even_R_add2.
  apply even_R_add1.
  assumption.
  constructor.

  invert H.
  exists {| Shared := gb; Private := (WriteIt, negb lb) |}; propositional.
  constructor; propositional.
  repeat apply even_R_add2.
  apply even_R_add1.
  assumption.
  constructor.

  invert H.
  exists {| Shared := lb; Private := (ReadIt, lb) |}; propositional.
  constructor; propositional.
  constructor.

  invert H.
  exists {| Shared := true; Private := (pc0, lb) |}; propositional.
  constructor; propositional.
  apply even_R_forward.
  assumption.
  constructor.

  (* Now find an invariant automatically. *)
  model_check_infer.

  (* Now prove that the invariant implies the correctness condition. *)
  invert 1.
  invert H0.
  simplify.
  propositional.

  invert H0.
  apply even_R_backward.
  assumption.

  invert H1.
  apply even_R_backward.
  assumption.

  invert H0.
  apply even_R_backward.
  assumption.

  invert H1.
  apply even_R_backward.
  assumption.
Qed.

(* Step 2: lift that result to the two-thread system, with no new model
 * checking. *)
Theorem twoadd2_ok :
  invariantFor (parallel twoadd_sys twoadd_sys) (twoadd_correct (private := _)).
Proof.
  eapply invariant_weaken.
  eapply invariant_simulates.
  apply withInterference_abstracts.
  apply withInterference_parallel.
  apply twoadd_ok.
  apply twoadd_ok.

  unfold twoadd_correct.
  invert 1.
  assumption.
Qed.

(* In fact, this modularity technique is so powerful that we now get correctness
 * for any number of threads, "for free"!  Here's a tactic definition, which we
 * won't explain, but which is able to derive correctness for any number of
 * threads, just by repeating use of [withInterference_parallel] and
 * [twoadd_ok]. *)
Ltac twoadd := eapply invariant_weaken; [ eapply invariant_simulates; [
                                          apply withInterference_abstracts
                                          | repeat (apply withInterference_parallel
                                                    || apply twoadd_ok) ]
                                        | unfold twoadd_correct; invert 1; assumption ].

(* For instance, let's verify the three-thread version. *)
Theorem twoadd3_ok :
  invariantFor (parallel twoadd_sys (parallel twoadd_sys twoadd_sys)) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.

(* To save us time defining versions with many threads, here's a recursive
 * function, creating exponentially many threads with respect to its
 * parameter. *)
Fixpoint manyadds_state (n : nat) : Type :=
  match n with
  | O => twoadd_pc * nat
  | S n' => manyadds_state n' * manyadds_state n'
  end%type.

Fixpoint manyadds (n : nat) : trsys (threaded_state nat (manyadds_state n)) :=
  match n with
  | O => twoadd_sys
  | S n' => parallel (manyadds n') (manyadds n')
  end.

(* Here are some examples of the systems we produce. *)
Eval simpl in manyadds 0.
Eval simpl in manyadds 1.
Eval simpl in manyadds 2.
Eval simpl in manyadds 3.

Theorem twoadd4_ok :
  invariantFor (manyadds 4) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.

Theorem twoadd6_ok :
  invariantFor (manyadds 6) (twoadd_correct (private := _)).
Proof.
  twoadd.
Qed.


Require Export D.

(** **** Exercise: 1 star (dist_not_exists)  *)
(** Prove that "[P] holds for all [x]" implies "there is no [x] for
    which [P] does not hold." *)

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 proof in H. inversion H. Qed.


Require Import Undecidability.Synthetic.Definitions.

Set Implicit Arguments.

(* ** Pre-order properties *)

Section Properties.

  Variables (X : Type) (P : X -> Prop)
            (Y : Type) (Q : Y -> Prop)
            (Z : Type) (R : Z -> Prop).

  Fact reduces_reflexive : P ⪯ P.
  Proof. exists (fun x => x); red; tauto. Qed.

  Fact reduces_transitive : P ⪯ Q -> Q ⪯ R -> P ⪯ R.
  Proof.
    unfold reduces, reduction.
    intros (f & Hf) (g & Hg).
    exists (fun x => g (f x)).
    firstorder easy.
  Qed.

  (* ** An equivalent dependent definition *)

  Fact reduces_dependent :
    P ⪯ Q <-> inhabited (forall x, { y | P x <-> Q y }).
  Proof.
    constructor.
    - intros [f Hf]. constructor. intros x. now exists (f x).
    - intros [f]. exists (fun x => proj1_sig (f x)).
      intros x. exact (proj2_sig (f x)).
  Qed.

  Fact reduces_complement : P ⪯ Q -> complement P ⪯ complement Q.
  Proof.
    intros [f Hf].
    exists f. intros x. specialize (Hf x). split.
    all: intros H Hc; apply H, Hf, Hc.
  Qed.

End Properties.

Lemma dec_red X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> decidable q -> decidable p.
Proof.
  unfold decidable, decider, reduces, reduction, reflects.
  intros [f] [d]. exists (fun x => d (f x)).
  firstorder easy.
Qed.

Lemma red_comp X (p : X -> Prop) Y (q : Y -> Prop) :
  p ⪯ q -> (fun x => ~ p x) ⪯ (fun y => ~ q y).
Proof.
  intros [f Hf]. exists f. firstorder easy.
Qed.

Module ReductionChainNotations.

(* YF: Broken on Coq 8.13.2

(* DLW: Thx to M. Wuttke for the tip, see coq-club ML *)

Ltac redchain2Prop_rec xs :=
  lazymatch xs with
  | pair ?x (pair ?y ?xs) =>
    let z := redchain2Prop_rec (pair y xs) in
    constr:(x ⪯ y /\ z)
  | pair ?x ?y => constr:(x ⪯ y)
  end.

Ltac redchain2Prop xs :=
  let z := redchain2Prop_rec xs
  in  exact z.

Declare Scope reduction_chain.
Delimit Scope reduction_chain with redchain_scope.
Notation "x '⪯ₘ' y" := (pair x y) (at level 80, right associativity, only parsing) : reduction_chain.
Notation "'⎩' xs '⎭'" := (ltac:(redchain2Prop (xs % redchain_scope))) (only parsing).

*)

(*
Definition Undec_Problem := { X : Type & X -> Prop }.

Definition undec_problem X (P : X -> Prop) : Undec_Problem := existT _ X P.

Notation "⎩ p ⎭" := (@undec_problem _ p) (format "⎩ p ⎭").

Infix "⪯ₚ" := (fun p q : Undec_Problem => projT2 p ⪯ projT2 q : Prop) (at level 70).

Reserved Notation "p '⪯ₗ' q 'by' l" (at level 70).

Section reduction_chain.

  Inductive reduction_chain : Undec_Problem -> Undec_Problem -> list Undec_Problem -> Prop :=
    | reduction_chain_nil  : forall p, p ⪯ₗ p by nil
    | reduction_chain_cons : forall p q r l, p ⪯ₚ q -> q ⪯ₗ r by l -> p ⪯ₗ r by q::l
  where "p '⪯ₗ' q 'by' l" := (reduction_chain p q l).

  Fact reduction_chain_reduces p q l : p ⪯ₗ q by l -> p ⪯ₚ q.
  Proof.
    induction 1 as [ p | p q r l H1 _ ? ].
    + apply reduces_reflexive.
    + apply reduces_transitive with (1 := H1); trivial.
  Qed.

  Fact reduction_chain_app p q r l m : p ⪯ₗ q by l -> q ⪯ₗ r by m -> p ⪯ₗ r by l++m.
  Proof.
    induction 1; intros; auto.
    constructor 2; auto.
  Qed.

End reduction_chain.

Notation "p '⪯ₗ' q 'by' l" := (reduction_chain p q l).

Tactic Notation "red" "chain" "stop" := constructor 1.
Tactic Notation "red" "chain" "step" constr(H) := constructor 2; [ apply H | ].
Tactic Notation "red" "chain" "app" constr(H) := apply reduction_chain_app with (1 := H).
*)

Tactic Notation "reduce" "with" "chain" constr(H) :=
  repeat (apply (reduces_reflexive _) || (eapply reduces_transitive; [ apply H | ])).

End ReductionChainNotations.


(** **** bool 基本定义 *)
Inductive bool : Type :=
| true
| false.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

(* 为何取反的符号不能定义,报错： *)
(* The reference x was not found in the current environment. *)
(* Notation "!x" := (negb x). *)
Notation "! x" := (negb x)(at level 70).

Example test_orb:  false || false || true = true.
Proof. simpl. reflexivity. Qed.

Example test_not:  !false = true.
Proof. simpl. reflexivity. Qed.


(** * Extract: Running Coq Programs in OCaml *)

(** Coq's [Extraction] feature enables you to write a functional
    program inside Coq, use Coq's logic to prove some correctness
    properties about it, and translate it into an OCaml program that
    you can compile with your optimizing OCaml compiler.  Haskell is
    also supported. *)

(** The [Extraction] chapter of _Logical Foundations_ has
    a simple example of Coq's program extraction features, but it's
    not required reading. This chapter starts from scratch and goes
    deeper. *)

From VFA Require Import Perm.
Require Extraction.

(* ################################################################# *)
(** * Extraction *)

(** As an example, let's extract insertion sort, which we implemented
    in [Sort]. *)

Fixpoint ins (i : nat) (l : list nat) :=
  match l with
  | [] => [i]
  | h :: t => if i <=? h then i :: h :: t else h :: ins i t
  end.

Fixpoint sort (l : list nat) : list nat :=
  match l with
  | [] => []
  | h :: t => ins h (sort t)
  end.

(** The [Extraction] command prints out a function as OCaml code. *)

Extraction sort.

(** You can see the translation of [sort] from Coq to OCaml in
    your IDE.  Examine it there, and notice the similarities and
    differences.  To get the whole program, we need [Recursive
    Extraction]: *)

Recursive Extraction sort.

(** The first thing you see there is a redefinition of the [bool] type.
    But OCaml already has a [bool] type whose inductive structure is
    isomorphic. We want our extracted functions to be compatible
    with, i.e. callable by, ordinary OCaml code. So we want to use
    OCaml's standard definition of [bool] in place of Coq's inductive
    definition, [bool]. You'll notice the same issue with lists. The
    following directive causes Coq to use OCaml's definitions of [bool]
    and [list] in the extracted code: *)

Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Recursive Extraction sort.

(** But the program still uses a unary representation of natural
    numbers: the number 7 is really [(S (S (S (S (S (S (S O)))))))],
    which in OCaml will be a data structure that's seven pointers
    deep. The [leb] function takes linear time, proportional to the
    difference in value between [n] and [m]. *)

(** We could instead use Coq's [Z], which is a binary representation
    of integers. But that is logarithmic-time, not constant. *)

Require Import ZArith.
Open Scope Z_scope.

Fixpoint insertZ (i : Z) (l : list Z) :=
  match l with
  | [] => [i]
  | h :: t => if i <=? h then i :: h :: t else h :: insertZ i t
  end.

Fixpoint sortZ (l : list Z) : list Z :=
  match l with
  | [] => []
  | h :: t => insertZ h (sortZ t)
  end.

Recursive Extraction sortZ.

(** Of course, for that extraction to be meaningful, we would need
    to prove that [sortZ] is a sorting algorithm. *)

(** Other alternatives include:

    - Extract [nat] directly to OCaml [int].  But [int] is finite (2^63
      in modern implementations), so there are theorems we could prove
      in Coq that wouldn't hold in OCaml.

    - Use Coq's [Int63], which faithfully models 63-bit cyclic
      arithmetic, and extract directly to OCaml [int]. But that's
      painful.

    - Define and axiomatize our own lightweight abstract type of
      naturals, but extract it to OCaml [int].  But, this is
      dangerous! If our axioms are inconsistent, we can prove anything
      at all. If they are not faithful to OCaml, our proofs will be
      meaningless. *)

(* ################################################################# *)
(** * Lightweight Extraction to [int] *)

(** We begin by positing a Coq type [int] that will be extracted to
    OCaml's [int]: *)

Parameter int : Type.
Extract Inlined Constant int => "int".

(** We'll abstract OCaml [int] to Coq [Z].  Every [int] does have a
    representation as a [Z], though the other direction cannot
    hold. *)

Parameter Abs : int -> Z.
Axiom Abs_inj: forall (n m : int), Abs n = Abs m -> n = m.

(** Nothing else is known so far about [int]. Let's add a less-than
    operators, which are extracted to OCaml's: *)

Parameter ltb: int -> int -> bool.
Extract Inlined Constant ltb => "(<)".
Axiom ltb_lt : forall (n m : int), ltb n m = true <-> Abs n < Abs m.

Parameter leb: int -> int -> bool.
Extract Inlined Constant leb => "(<=)".
Axiom leb_le : forall (n m : int), leb n m = true <-> Abs n <= Abs m.

(** Those axioms are sound: OCaml's [<] and [<=] are consistent with
    Coq's on any [int]. Note that we do not give extraction directives
    for [Abs], [ltb_lt], or [leb_le].  They will not appear in
    programs, only in proofs --which are not meant to be extracted. *)

(** You could imagine doing the same thing we just did with [(+)], but
    that would be wrong:

      Parameter ocaml_plus : int -> int -> int.
      Extract Inlined Constant ocaml_plus => "(+)".
      Axiom ocaml_plus_plus: forall a b c: int,
        ocaml_plus a b = c <-> Abs a + Abs b = Abs c.

    The first two lines are OK: there really is a [+] function in
    OCaml, and its type really is [int -> int -> int].

    But [ocaml_plus_plus] is unsound. From it, you could prove,

      Abs max_int + Abs max_int = Abs (ocaml_plus max_int max_int)

    which is not true in OCaml because of overflow.

*)

(** In [Perm] we proved several theorems showing that Boolean
    operators were reflected in propositions.  Below, we do that
    for [int] and [Z] comparisons. *)

Lemma int_ltb_reflect : forall x y, reflect (Abs x < Abs y) (ltb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply ltb_lt.
Qed.

Lemma int_leb_reflect : forall x y, reflect (Abs x <= Abs y) (leb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply leb_le.
Qed.

Lemma Z_eqb_reflect : forall x y, reflect (x = y) (Z.eqb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Z.eqb_eq.
Qed.

Lemma Z_ltb_reflect : forall x y, reflect (x < y) (Z.ltb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Z.ltb_lt.
Qed.

Lemma Z_leb_reflect : forall x y, reflect (x <= y) (Z.leb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. apply Z.leb_le.
Qed.

Lemma Z_gtb_reflect : forall x y, reflect (x > y) (Z.gtb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. rewrite Z.gtb_ltb. rewrite Z.gt_lt_iff. apply Z.ltb_lt.
Qed.

Lemma Z_geb_reflect : forall x y, reflect (x >= y) (Z.geb x y).
Proof.
  intros x y.
  apply iff_reflect. symmetry. rewrite Z.geb_leb. rewrite Z.ge_le_iff. apply Z.leb_le.
Qed.

(** Now we upgrade [bdall] to work with [Z] and [int].  *)

Hint Resolve
     int_ltb_reflect int_leb_reflect
     Z_eqb_reflect Z_ltb_reflect Z_leb_reflect Z_gtb_reflect Z_geb_reflect
  : bdestruct.

Ltac bdestruct_guard:=
  match goal with
  | |- context [ if Nat.eqb ?X ?Y then _ else _] => bdestruct (Nat.eqb X Y)
  | |- context [ if Nat.ltb ?X ?Y then _ else _] => bdestruct (Nat.ltb X Y)
  | |- context [ if Nat.leb ?X ?Y then _ else _] => bdestruct (Nat.leb X Y)
  | |- context [ if Z.eqb ?X ?Y then _ else _] => bdestruct (Z.eqb X Y)
  | |- context [ if Z.ltb ?X ?Y then _ else _] => bdestruct (Z.ltb X Y)
  | |- context [ if Z.leb ?X ?Y then _ else _] => bdestruct (Z.leb X Y)
  | |- context [ if Z.gtb ?X ?Y then _ else _] => bdestruct (Z.gtb X Y)
  | |- context [ if Z.geb ?X ?Y then _ else _] => bdestruct (Z.geb X Y)
  | |- context [ if ltb ?X ?Y then _ else _] => bdestruct (ltb X Y)
  | |- context [ if leb ?X ?Y then _ else _] => bdestruct (leb X Y)
  end.

Ltac bdall :=
  repeat (simpl; bdestruct_guard; try omega; auto).

(* ################################################################# *)
(** * Insertion Sort, Extracted *)

(** We're ready to state insertion sort with [int], and to extract it: *)

Fixpoint ins_int (i : int) (l : list int) :=
  match l with
  | [] => [i]
  | h :: t => if leb i h then i :: h :: t else h :: ins_int i t
  end.

Fixpoint sort_int (l : list int) : list int :=
  match l with
  | [] => []
  | h :: t => ins_int h (sort_int t)
  end.

Recursive Extraction sort_int.

(** Again, for that extraction to be meaningful, we need to prove that
    [sort_int] is a sorting algorithm.  We can do that with the same
    techniques we used in [Sort].  In particular, [omega] works
    with [Z], so we can enjoy automation without having to do any
    unnecessary work axiomatizing and proving lemmas about [int]. *)

Inductive sorted : list int -> Prop :=
| sorted_nil:
    sorted []
| sorted_1: forall x,
    sorted [x]
| sorted_cons: forall x y l,
    Abs x <= Abs y -> sorted (y :: l) -> sorted (x :: y :: l).

Hint Constructors sorted.

Lemma insert_sorted:
  forall a l, sorted l -> sorted (ins_int a l).
Proof.
  intros a l S. induction S; simpl.
  - constructor.
  - bdall; auto.
    constructor; auto. omega.
  - bdall; auto.
    bdall.
    + constructor; auto. omega.
    + constructor; auto.
      simpl in IHS. bdestruct (leb a y); auto.
      unfold not in H0. unfold not in H1. auto. omega.
Qed.

Theorem sort_sorted: forall l, sorted (sort_int l).
Proof.
  induction l; simpl; auto.
  apply insert_sorted. auto.
Qed.

Lemma insert_perm: forall x l,
    Permutation (x :: l) (ins_int x l).
Proof.
  induction l; simpl.
  - apply Permutation_refl.
  - destruct (leb x a).
    + apply Permutation_refl.
    + apply perm_trans with (a :: x :: l).
      * apply perm_swap.
      * apply perm_skip. assumption.
Qed.

(** **** Exercise: 3 stars, standard (sort_int_correct)  *)

(** Prove the correctness of [sort_int] by adapting your solution to
    [insertion_sort_correct] from [Sort]. *)

Theorem sort_int_correct : forall (al : list int),
    Permutation al (sort_int al) /\ sorted (sort_int al).
Proof.
  split.
  - induction al.
    apply Permutation_refl.
    simpl. apply Permutation_trans with (a :: (sort_int al)).
    apply perm_skip. assumption.
    + apply insert_perm.
  - apply sort_sorted.
Qed.

(** [] *)

(* ################################################################# *)
(** * Binary Search Trees, Extracted *)

(** We can reimplement BSTs with [int] keys. *)

Definition key := int.

Inductive tree (V : Type) : Type :=
  | E : tree V
  | T : tree V -> key -> V -> tree V -> tree V.

Arguments E {V}.
Arguments T {V}.

Definition empty_tree {V : Type} : tree V := E.

Fixpoint lookup {V : Type} (default : V) (x : key) (t : tree V) : V :=
  match t with
  | E => default
  | T l k v r => if ltb x k then lookup default x l
                else if ltb k x then lookup default x r
                     else v
  end.

Fixpoint insert {V : Type} (x : key) (v : V) (t : tree V) : tree V :=
  match t with
  | E => T E x v E
  | T l y v' r => if ltb x y then T (insert x v l) y v' r
                 else if ltb y x then T l y v' (insert x v r)
                      else T l x v r
  end.

Fixpoint elements_tr {V : Type}
         (t : tree V) (acc : list (key * V)) : list (key * V) :=
  match t with
  | E => acc
  | T l k v r => elements_tr l ((k, v) :: elements_tr r acc)
  end.

Definition elements {V : Type} (t : tree V) : list (key * V) :=
  elements_tr t [].

Theorem lookup_empty : forall (V : Type) (default : V) (k : key),
    lookup default k empty_tree = default.
Proof. auto. Qed.

(** **** Exercise: 2 stars, standard (lookup_insert_eq)  *)
Theorem lookup_insert_eq :
  forall (V : Type) (default : V) (t : tree V) (k : key) (v : V),
    lookup default k (insert k v t) = v.
Proof.
  intros. induction t.
  -  simpl. bdall.
  - simpl. bdall.
Qed.
(** [] *)

Lemma geimpeq : forall (k : int) (k' : int),
    (Abs k' >= Abs k) -> (Abs k >= Abs k') -> (Abs k' = Abs k).
Proof.
  intros. omega.
Qed.

(** **** Exercise: 3 stars, standard (lookup_insert_neq)  *)
Theorem lookup_insert_neq :
  forall (V : Type) (default : V) (t : tree V) (k k' : key) (v : V),
    k <> k' -> lookup default k' (insert k v t) = lookup default k' t.
Proof.
  intros. induction t.
  - simpl.  unfold not in H.
    bdall.  apply Znot_lt_ge in H0. apply Znot_lt_ge in H1.
    apply geimpeq in H0.  apply Abs_inj in H0. apply H in H0. inversion H0.
    apply H1.
  - simpl. bdall. apply Znot_lt_ge in H2. apply Znot_lt_ge in H3.
    apply geimpeq in H2.  apply Abs_inj in H2. apply H in H2. inversion H2.
    apply H3.
Qed.
(** [] *)

(** **** Exercise: 5 stars, standard, optional (int_elements)  *)

(** Port the definition of [BST] and re-prove the properties of
    [elements] for [int]-keyed trees. Send us your solution so
    we can include it! *)

(** [] *)

(** Now see the extraction in your IDE: *)

Extract Inductive prod => "(*)"  [ "(,)" ]. (* extract pairs natively *)
Recursive Extraction empty_tree insert lookup elements.

(* ################################################################# *)
(** * Performance Tests *)

(** Let's measure the performance of BSTs.  First, we extract to
    an OCaml file: *)

Extraction "searchtree.ml" empty_tree insert lookup elements.

(** Second, in the same directory as this file ([Extract.v])
    you will find the file [test_searchtree.ml]. You can
    run it using the OCaml toplevel with these commands:

# #use "searchtree.ml";;
# #use "test_searchtree.ml";;

On a recent machine with a 2.9 GHz Intel Core i9 that prints:

Insert and lookup 1000000 random integers in .889566 seconds.
Insert and lookup 20000 random integers in 0.009918 seconds.
Insert and lookup 20000 consecutive integers in 2.777335 seconds.

That execution uses the bytecode interpreter.  The native compiler
will have better performance:

$ ocamlopt -c searchtree.mli searchtree.ml
$ ocamlopt searchtree.cmx -open Searchtree test_searchtree.ml -o test_searchtree
$ ./test_searchtree

On the same machine that prints,

Insert and lookup 1000000 random integers in 0.488973 seconds.
Insert and lookup 20000 random integers in 0.003237 seconds.
Insert and lookup 20000 consecutive integers in 0.387535 seconds.
*)

(** Of course, the reason why the performance is so much worse with
    consecutive integers is that BSTs exhibit worst-case performance
    under that workload: linear time instead of logarithmic.  We need
    balanced search trees to achieve logarithmic.  [Redblack]
    will do that. *)

(* Mon May 11 23:21:35 EDT 2020 *)


Require Import Program.Equality Lia SimplDec.
Require Export ListExtra PreSuffix ListOrder.

Definition Tag := list nat.

Inductive Taglt : Tag -> Tag -> Prop :=
| TagltS (n m : nat) (i : Tag) : n < m -> Taglt (n :: i) (m :: i)
| TagltCons (n m : nat) (i j : Tag) : Taglt i j -> Taglt (n :: i) (m :: j).

Definition Tagle (i j : Tag) : Prop := Taglt i j \/ i = j.

Infix "⊴" := Tagle (at level 70).
Infix "◁" := Taglt (at level 70).

Lemma Tagle_refl (i : Tag)
  : i ⊴ i.
Proof.
  right;auto.
Qed.

Lemma Taglt_irrefl
  : Irreflexive Taglt.
Proof.
  unfold Irreflexive, Reflexive, complement.
  intros x Hx.
  dependent induction Hx.
  - lia.
  - auto.
Qed.

Lemma Taglt_trans
  : Transitive Taglt.
Proof.
  intros x y z Hxy Hyz.
  revert dependent z.
  dependent induction Hxy;intros.
  - dependent destruction Hyz.
    + econstructor. lia.
    + econstructor. auto.
  - dependent destruction Hyz.
    + econstructor. auto.
    + econstructor. eauto.
Qed.

Hint Resolve Taglt_irrefl Taglt_trans : tagle.

Global Instance Taglt_StrictOrder : StrictOrder Taglt.
Proof.
  split; eauto with tagle.
Qed.

Global Instance Tagle_PreOrder : PreOrder Tagle.
Proof.
  eapply StrictOrder_PreOrder;eauto.
Qed.

Global Instance Tagle_PartialOrder : PartialOrder eq Tagle.
Proof.
  eapply StrictOrder_PartialOrder;eauto.
Qed.

Lemma Taglt_non_nil1 (i : Tag)
  : [] ◁ i -> False.
Proof.
  intro H. inversion H.
Qed.

Lemma Taglt_non_nil2 (i : Tag)
  : i ◁ [] -> False.
Proof.
  intro H. inversion H.
Qed.

Hint Immediate Taglt_non_nil1 Taglt_non_nil2 : tagle.

Lemma Taglt_len (i j : Tag)
      (Htaglt : i ◁ j)
  : | i | = | j |.
Proof.
  induction Htaglt;cbn;auto.
Qed.

Lemma Taglt_rcons_le (i j : Tag) (n m : nat)
      (Htaglt : i ++ [n] ◁ j ++ [m])
  : n <= m.
Proof.
  dependent induction Htaglt.
  - rewrite cons_rcons' in x0.
    rewrite cons_rcons' in x.
    eapply app_inj_tail in x0.
    eapply app_inj_tail in x.
    do 2 destructH. subst n m.
    cbn in *.
    rinduction i0; cbn in *.
    + lia.
    + rewrite rev_rcons. cbn. reflexivity.
  - destruct i0. inversion Htaglt.
    destruct j0. inversion Htaglt.
    eapply (IHHtaglt (tl i) (tl j));eauto.
    + destruct i;cbn in *;eauto. congruence. inversion x0. eauto.
    + destruct j;cbn in *;eauto. congruence. inversion x. eauto.
Qed.

Lemma Taglt_eq_rcons_lt (i : Tag) (n m : nat)
      (Htaglt : i ++ [n] ◁ i ++ [m])
  : n < m.
Proof.
  induction i;cbn in *.
  - inversion Htaglt;subst;auto. inversion H0.
  - eapply IHi. inversion Htaglt;subst.
    + lia.
    + auto.
Qed.

Hint Immediate Taglt_irrefl : tagle.

Lemma Taglt_eq_cons_lt (i : Tag) (n m : nat)
      (Htaglt : n :: i ◁ m :: i)
  : n < m.
Proof.
  inversion Htaglt;subst;eauto.
  exfalso. eapply Taglt_irrefl; eauto.
Qed.

Lemma Taglt_eq_rcons_Taglt (i j : Tag) (n : nat)
      (Htaglt : i ++ [n] ◁ j ++ [n])
  : i ◁ j.
Proof.
  eapply Taglt_len in Htaglt as Hlen.
  do 2 rewrite length_rcons in Hlen. eapply Nat.succ_inj in Hlen.
  destruct i;[|revert dependent i; revert dependent n0];induction j;cbn in *;intros.
  - exfalso. inversion Htaglt;subst. lia. eauto with tagle.
  - lia.
  - lia.
  - dependent destruction Htaglt.
    + eapply app_inj_tail in x; destruct x;subst.
      econstructor;eauto.
    + econstructor.
      destruct i,j; cbn in *.
      1: exfalso;eapply Taglt_irrefl;eauto.
      1,2: lia.
      eapply IHj;eauto.
Qed.

Lemma Taglt_le_rcons (n m : nat) (i j : Tag)
      (Htaglt : i ◁ j)
      (Hle : n <= m)
  : i ++ [n] ◁ j ++ [m].
Proof.
  induction Htaglt;cbn.
  - eapply le_lt_or_eq in Hle. destruct Hle.
    + econstructor;eauto. induction i; cbn; econstructor; eauto.
    + subst. econstructor;eauto.
  - econstructor;eauto.
Qed.

Lemma Taglt_lt_rcons (n m : nat) (i j : Tag)
      (Hlen : |i| = |j|)
      (Hlt : n < m)
  : i ++ [n] ◁ j ++ [m].
Proof.
  destruct i; intros.
  - destruct j; cbn in *.
    + econstructor; eauto.
    + lia.
  - revert n0 i Hlen.
    induction j; cbn in *; intros.
    + lia.
    + destruct i; cbn in *.
      * destruct j; cbn in *; [|lia].
        econstructor;econstructor;eauto.
      * econstructor.
        eapply IHj.
        lia.
Qed.

Lemma Taglt_ind_r
      (P : Tag -> Tag -> Prop)
      (Hbase : forall (n m : nat) (i j : Tag), |i| = |j| -> n < m -> P (i++[n]) (j++[m]))
      (Hstep : forall (n : nat) (i j : Tag), Taglt i j -> P i j -> P (i++[n]) (j++[n]))
      (i j : Tag)
      (Htaglt : Taglt i j)
  : P i j.
Proof.
  revert dependent j.
  rinduction i. 1: exfalso; eauto with tagle.
  revert dependent l. revert dependent a.
  rinduction j. 1: exfalso; eauto with tagle.
  eapply Taglt_len in Htaglt as Hlen.
  do 2 rewrite length_rcons in Hlen. eapply Nat.succ_inj in Hlen.
  eapply Taglt_rcons_le in Htaglt as Hle.
  eapply le_lt_or_eq in Hle.
  destruct Hle.
  - eapply Hbase;eauto.
  - subst a0.
    eapply Taglt_eq_rcons_Taglt in Htaglt.
    eapply Hstep;eauto.
Qed.

Lemma taglt_tagle_trans (i j k : Tag)
  : i ◁ j -> j ⊴ k -> i ◁ k.
Proof.
  intros.
  destruct H0.
  - transitivity j;eauto.
  - subst. auto.
Qed.

Lemma tagle_taglt_trans (i j k : Tag)
  : i ⊴ j -> j ◁ k -> i ◁ k.
Proof.
  intros.
  destruct H.
  - transitivity j;eauto.
  - subst. auto.
Qed.

Lemma le_cons_tagle n1 n2 i
      (Hlt : n1 <= n2)
  : n1 :: i ⊴ n2 :: i.
Proof.
  eapply le_lt_or_eq in Hlt. destruct Hlt.
  - econstructor. econstructor. assumption.
  - subst. reflexivity.
Qed.

Lemma lt_cons_ntagle n1 n2 i
      (Hlt : n2 < n1)
  : ~ n1 :: i ⊴ n2 :: i.
Proof.
  simpl_dec.
  split.
  - intro N.
    inv N.
    + lia.
    + eapply Taglt_irrefl;eauto.
  - intro N. inv N. lia.
Qed.

Lemma taglt_trichotomy i j
      (Hlen : |i| = |j|)
  : i ◁ j \/ i = j \/ j ◁ i.
Proof.
  remember (|i|) as n.
  revert i j Heqn Hlen.
  induction n;intros.
  - destruct i,j;cbn in *;try congruence. right. left. reflexivity.
  - destruct i,j;cbn in *;try congruence.
    specialize (IHn i j).
    exploit IHn.
    destruct IHn as [IHn|[IHn|IHn]];[left| |right;right].
    + econstructor;eauto.
    + subst.
      specialize (Nat.lt_trichotomy n0 n1) as Hcase.
      destruct Hcase as [Hcase|Hcase];[left|right];[|destruct Hcase as [Hcase|Hcase];[left|right]].
      * econstructor;eauto.
      * subst. reflexivity.
      * econstructor;eauto.
    + econstructor;eauto.
Qed.

Lemma tagle_or i j
      (Hlen : |i| = |j|)
  : i ⊴ j \/ j ⊴ i.
Proof.
  eapply taglt_trichotomy in Hlen.
  destruct Hlen as [Hlen|[Hlen|Hlen]];[left;left|left;right|right;left];eauto.
Qed.

Lemma Tagle_len: forall [i j : Tag], i ⊴ j -> | i | = | j |.
Proof.
  intros. destruct H.
  - eapply Taglt_len;eauto.
  - subst. reflexivity.
Qed.


From Hammer Require Import Hammer.

Require Export NOrder.

Module NAddOrderProp (Import N : NAxiomsMiniSig').
Include NOrderProp N.

Theorem le_add_r : forall n m, n <= n + m.
Proof. hammer_hook "NAddOrder" "NAddOrder.NAddOrderProp.le_add_r".
intro n; induct m.
rewrite add_0_r; now apply eq_le_incl.
intros m IH. rewrite add_succ_r; now apply le_le_succ_r.
Qed.

Theorem lt_lt_add_r : forall n m p, n < m -> n < m + p.
Proof. hammer_hook "NAddOrder" "NAddOrder.NAddOrderProp.lt_lt_add_r".
intros n m p H; rewrite <- (add_0_r n).
apply add_lt_le_mono; [assumption | apply le_0_l].
Qed.

Theorem lt_lt_add_l : forall n m p, n < m -> n < p + m.
Proof. hammer_hook "NAddOrder" "NAddOrder.NAddOrderProp.lt_lt_add_l".
intros n m p; rewrite add_comm; apply lt_lt_add_r.
Qed.

Theorem add_pos_l : forall n m, 0 < n -> 0 < n + m.
Proof. hammer_hook "NAddOrder" "NAddOrder.NAddOrderProp.add_pos_l".
intros; apply add_pos_nonneg. assumption. apply le_0_l.
Qed.

Theorem add_pos_r : forall n m, 0 < m -> 0 < n + m.
Proof. hammer_hook "NAddOrder" "NAddOrder.NAddOrderProp.add_pos_r".
intros; apply add_nonneg_pos. apply le_0_l. assumption.
Qed.

End NAddOrderProp.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

Parameter bag : forall (a:Type), Type.

Parameter nb_occ: forall (a:Type), a -> (bag a) -> Z.
Implicit Arguments nb_occ.

Axiom occ_non_negative : forall (a:Type), forall (b:(bag a)) (x:a),
  (0%Z <= (nb_occ x b))%Z.

(* Why3 assumption *)
Definition mem (a:Type)(x:a) (b:(bag a)): Prop := (0%Z <  (nb_occ x b))%Z.
Implicit Arguments mem.

(* Why3 assumption *)
Definition eq_bag (a:Type)(a1:(bag a)) (b:(bag a)): Prop := forall (x:a),
  ((nb_occ x a1) = (nb_occ x b)).
Implicit Arguments eq_bag.

Axiom bag_extensionality : forall (a:Type), forall (a1:(bag a)) (b:(bag a)),
  (eq_bag a1 b) -> (a1 = b).

Parameter empty_bag: forall (a:Type), (bag a).
Set Contextual Implicit.
Implicit Arguments empty_bag.
Unset Contextual Implicit.

Axiom occ_empty : forall (a:Type), forall (x:a), ((nb_occ x (empty_bag :(bag
  a))) = 0%Z).

Axiom is_empty : forall (a:Type), forall (b:(bag a)), (forall (x:a),
  ((nb_occ x b) = 0%Z)) -> (b = (empty_bag :(bag a))).

Parameter singleton: forall (a:Type), a -> (bag a).
Implicit Arguments singleton.

Axiom occ_singleton : forall (a:Type), forall (x:a) (y:a), ((x = y) /\
  ((nb_occ y (singleton x)) = 1%Z)) \/ ((~ (x = y)) /\ ((nb_occ y
  (singleton x)) = 0%Z)).

Axiom occ_singleton_eq : forall (a:Type), forall (x:a) (y:a), (x = y) ->
  ((nb_occ y (singleton x)) = 1%Z).

Axiom occ_singleton_neq : forall (a:Type), forall (x:a) (y:a), (~ (x = y)) ->
  ((nb_occ y (singleton x)) = 0%Z).

Parameter union: forall (a:Type), (bag a) -> (bag a) -> (bag a).
Implicit Arguments union.

Axiom occ_union : forall (a:Type), forall (x:a) (a1:(bag a)) (b:(bag a)),
  ((nb_occ x (union a1 b)) = ((nb_occ x a1) + (nb_occ x b))%Z).

Axiom Union_comm : forall (a:Type), forall (a1:(bag a)) (b:(bag a)),
  ((union a1 b) = (union b a1)).

Axiom Union_identity : forall (a:Type), forall (a1:(bag a)), ((union a1
  (empty_bag :(bag a))) = a1).

(* Why3 goal *)
Theorem Union_assoc : forall (a:Type), forall (a1:(bag a)) (b:(bag a))
  (c:(bag a)), ((union a1 (union b c)) = (union (union a1 b) c)).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X a b c.
apply bag_extensionality; intro x.
do 4 rewrite occ_union; auto with zarith.
Qed.


(* @Owner MattIrv *)

Require Export QArith.
Require Export String.

Module BinStringToQ.

Inductive sign :=
  | sZero: sign
  | sPos: sign
  | sNeg: sign.

Local Open Scope char_scope.

Fixpoint bin_str_to_pos (str: string) (cp: positive) (start: bool) :=
  match start with
    | true =>
      match str with
        | EmptyString => None
        | String char s' =>
          match char with
            | "0" => bin_str_to_pos s' xH true
            | "1" => bin_str_to_pos s' xH false
            | _ => None
          end
      end
    | false =>
      match str with
        | EmptyString => Some cp
        | String char s' =>
          match char with
            | "0" => bin_str_to_pos s' (xO cp) false
            | "1" => bin_str_to_pos s' (xI cp) false
            | _ => None
          end
      end
  end.

Local Close Scope char_scope.

Definition numstr_to_z (numStr: string) (s: sign) :=
  match s with
    | sZero => Some Z0
    | sPos => let somepos := bin_str_to_pos numStr xH true in
      match somepos with
        | Some p => Some (Zpos p)
        | None => None
      end
    | sNeg => let somepos := bin_str_to_pos numStr xH true in
      match somepos with
        | Some p => Some (Zneg p)
        | None => None
      end
  end.

Definition bin_str_to_q (numStr denStr: string) (s: sign) :=
  let num := numstr_to_z numStr s in
  let denom := bin_str_to_pos denStr xH true in
    match num, denom with
      | None, _ => None
      | _, None => None
      | Some z, Some p => Some (Qmake z p)
    end.

Local Open Scope char_scope.

Fixpoint hex_str_to_bin_str (hexstr: string) :=
  match hexstr with
    | EmptyString => EmptyString
    | String char s' =>
      match char with
        | "0" => "0000" ++ hex_str_to_bin_str s'
        | "1" => "0001" ++ hex_str_to_bin_str s'
        | "2" => "0010" ++ hex_str_to_bin_str s'
        | "3" => "0011" ++ hex_str_to_bin_str s'
        | "4" => "0100" ++ hex_str_to_bin_str s'
        | "5" => "0101" ++ hex_str_to_bin_str s'
        | "6" => "0110" ++ hex_str_to_bin_str s'
        | "7" => "0111" ++ hex_str_to_bin_str s'
        | "8" => "1000" ++ hex_str_to_bin_str s'
        | "9" => "1001" ++ hex_str_to_bin_str s'
        | "A" => "1010" ++ hex_str_to_bin_str s'
        | "B" => "1011" ++ hex_str_to_bin_str s'
        | "C" => "1100" ++ hex_str_to_bin_str s'
        | "D" => "1101" ++ hex_str_to_bin_str s'
        | "E" => "1110" ++ hex_str_to_bin_str s'
        | "F" => "1111" ++ hex_str_to_bin_str s'
        | _ => "ERROR"%string
      end
  end
where "s1 ++ s2" := (append s1 s2).

Local Close Scope char_scope.

Definition hex_str_to_q (numStr denStr: string) (s: sign) :=
  let numBin := hex_str_to_bin_str numStr in
  let denBin := hex_str_to_bin_str denStr in
  bin_str_to_q numBin denBin s.

Example e1 := bin_str_to_q "0100101" "101010" sPos.
Example e2 := bin_str_to_q "0" "1" sPos.
Example e3 := bin_str_to_q "1" "10" sNeg.
Example h1 := hex_str_to_bin_str "2A".

End BinStringToQ.

Export BinStringToQ.


From Hammer Require Import Hammer.

Section Inverse_Image.

Variables A B : Type.
Variable R : B -> B -> Prop.
Variable f : A -> B.

Let Rof (x y:A) : Prop := R (f x) (f y).

Remark Acc_lemma : forall y:B, Acc R y -> forall x:A, y = f x -> Acc Rof x.
Proof. hammer_hook "Inverse_Image" "Inverse_Image.Acc_lemma".
induction 1 as [y _ IHAcc]; intros x H.
apply Acc_intro; intros y0 H1.
apply (IHAcc (f y0)); try trivial.
rewrite H; trivial.
Qed.

Lemma Acc_inverse_image : forall x:A, Acc R (f x) -> Acc Rof x.
Proof. hammer_hook "Inverse_Image" "Inverse_Image.Acc_inverse_image".
intros; apply (Acc_lemma (f x)); trivial.
Qed.

Theorem wf_inverse_image : well_founded R -> well_founded Rof.
Proof. hammer_hook "Inverse_Image" "Inverse_Image.wf_inverse_image".
red; intros; apply Acc_inverse_image; auto.
Qed.

Variable F : A -> B -> Prop.
Let RoF (x y:A) : Prop :=
exists2 b : B, F x b & (forall c:B, F y c -> R b c).

Lemma Acc_inverse_rel : forall b:B, Acc R b -> forall x:A, F x b -> Acc RoF x.
Proof. hammer_hook "Inverse_Image" "Inverse_Image.Acc_inverse_rel".
induction 1 as [x _ IHAcc]; intros x0 H2.
constructor; intros y H3.
destruct H3.
apply (IHAcc x1); auto.
Qed.

Theorem wf_inverse_rel : well_founded R -> well_founded RoF.
Proof. hammer_hook "Inverse_Image" "Inverse_Image.wf_inverse_rel".
red; constructor; intros.
case H0; intros.
apply (Acc_inverse_rel x); auto.
Qed.

End Inverse_Image.


From Hammer Require Import Hammer.

Require Import Decidable PeanoNat.
Require Eqdep_dec.
Local Open Scope nat_scope.

Implicit Types m n x y : nat.

Theorem O_or_S n : {m : nat | S m = n} + {0 = n}.
Proof. hammer_hook "Peano_dec" "Peano_dec.O_or_S".
induction n.
- now right.
- left; exists n; auto.
Defined.

Notation eq_nat_dec := Nat.eq_dec (compat "8.4").

Hint Resolve O_or_S eq_nat_dec: arith.

Theorem dec_eq_nat n m : decidable (n = m).
Proof. hammer_hook "Peano_dec" "Peano_dec.dec_eq_nat".
elim (Nat.eq_dec n m); [left|right]; trivial.
Defined.

Definition UIP_nat:= Eqdep_dec.UIP_dec Nat.eq_dec.

Import EqNotations.

Lemma le_unique: forall m n (le_mn1 le_mn2 : m <= n), le_mn1 = le_mn2.
Proof. hammer_hook "Peano_dec" "Peano_dec.le_unique".
intros m n.
generalize (eq_refl (S n)).
generalize n at -1.
induction (S n) as [|n0 IHn0]; try discriminate.
clear n; intros n [= <-] le_mn1 le_mn2.
pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2).
2: reflexivity.
generalize def_n2; revert le_mn1 le_mn2.
generalize n0 at 1 4 5 7; intros n1 le_mn1.
destruct le_mn1; intros le_mn2; destruct le_mn2.
+ now intros def_n0; rewrite (UIP_nat _ _ def_n0 eq_refl).
+ intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0.
now destruct (Nat.nle_succ_diag_l _ le_mn0).
+ intros def_n0; generalize le_mn1; rewrite def_n0; intros le_mn0.
now destruct (Nat.nle_succ_diag_l _ le_mn0).
+ intros def_n0. injection def_n0 as ->.
rewrite (UIP_nat _ _ def_n0 eq_refl); simpl.
assert (H : le_mn1 = le_mn2).
now apply IHn0.
now rewrite H.
Qed.

Require Import Le Lt.