(** * Smallstep: Small-step Operational Semantics *)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import SfLib.
Require Import Maps.
Require Import Imp.

(** The evaluators we have seen so far (e.g., the ones for
    [aexp]s, [bexp]s, and commands) have been formulated in a
    "big-step" style -- they specify how a given expression can be
    evaluated to its final value (or a command plus a store to a final
    store) "all in one big step."

    This style is simple and natural for many purposes -- indeed,
    Gilles Kahn, who popularized its use, called it _natural
    semantics_.  But there are some things it does not do well.  In
    particular, it does not give us a natural way of talking about
    _concurrent_ programming languages, where the "semantics" of a
    program -- i.e., the essence of how it behaves -- is not just
    which input states get mapped to which output states, but also
    includes the intermediate states that it passes through along the
    way, since these states can also be observed by concurrently
    executing code.

    Another shortcoming of the big-step style is more technical, but
    critical in some situations.  To see the issue, suppose we wanted
    to define a variant of Imp where variables could hold _either_
    numbers _or_ lists of numbers (see the [HoareList] chapter for
    details).  In the syntax of this extended language, it will be
    possible to write strange expressions like [2 + nil], and our
    semantics for arithmetic expressions will then need to say
    something about how such expressions behave.  One
    possibility (explored in the [HoareList] chapter) is to maintain
    the convention that every arithmetic expressions evaluates to some
    number by choosing some way of viewing a list as a number -- e.g.,
    by specifying that a list should be interpreted as [0] when it
    occurs in a context expecting a number.  But this is really a bit
    of a hack.

    A much more natural approach is simply to say that the behavior of
    an expression like [2+nil] is _undefined_ -- it doesn't evaluate
    to any result at all.  And we can easily do this: we just have to
    formulate [aeval] and [beval] as [Inductive] propositions rather
    than Fixpoints, so that we can make them partial functions instead
    of total ones.

    However, now we encounter a serious deficiency.  In this language,
    a command might _fail_ to map a given starting state to any ending
    state for two quite different reasons: either because the
    execution gets into an infinite loop or because, at some point,
    the program tries to do an operation that makes no sense, such as
    adding a number to a list, and none of the evaluation rules can be
    applied.

    These two outcomes -- nontermination vs. getting stuck in an
    erroneous configuration -- are quite different.  In particular, we
    want to allow the first (permitting the possibility of infinite
    loops is the price we pay for the convenience of programming with
    general looping constructs like [while]) but prevent the
    second (which is just wrong), for example by adding some form of
    _typechecking_ to the language.  Indeed, this will be a major
    topic for the rest of the course.  As a first step, we need a
    different way of presenting the semantics that allows us to
    distinguish nontermination from erroneous "stuck states."

    So, for lots of reasons, we'd like to have a finer-grained way of
    defining and reasoning about program behaviors.  This is the topic
    of the present chapter.  We replace the "big-step" [eval] relation
    with a "small-step" relation that specifies, for a given program,
    how the "atomic steps" of computation are performed. *)

(* ########################################################### *)
(** * A Toy Language *)

(** To save space in the discussion, let's go back to an
    incredibly simple language containing just constants and
    addition.  (We use single letters -- [C] and [P] -- for the
    constructor names, for brevity.)  At the end of the chapter, we'll
    see how to apply the same techniques to the full Imp language.  *)

Inductive tm : Type :=
  | C : nat -> tm         (* Constant *)
  | P : tm -> tm -> tm.   (* Plus *)

(** Here is a standard evaluator for this language, written in the
    same (big-step) style as we've been using up to this point. *)

Fixpoint evalF (t : tm) : nat :=
  match t with
  | C n => n
  | P a1 a2 => evalF a1 + evalF a2
  end.

(** Now, here is the same evaluator, written in exactly the same
    style, but formulated as an inductively defined relation.  Again,
    we use the notation [t \\ n] for "[t] evaluates to [n]." *)
(**
                               --------                                (E_Const)
                               C n \\ n

                               t1 \\ n1
                               t2 \\ n2
                           ------------------                          (E_Plus)
                           P t1 t2 \\ n1 + n2
*)

Reserved Notation " t '\\' n " (at level 50, left associativity).

Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n,
      C n \\ n
  | E_Plus : forall t1 t2 n1 n2,
      t1 \\ n1 ->
      t2 \\ n2 ->
      P t1 t2 \\ (n1 + n2)

  where " t '\\' n " := (eval t n).

Module SimpleArith1.

(** Now, here is a small-step version. *)
(**
                     -------------------------------        (ST_PlusConstConst)
                     P (C n1) (C n2) ==> C (n1 + n2)

                              t1 ==> t1'
                         --------------------                        (ST_Plus1)
                         P t1 t2 ==> P t1' t2

                              t2 ==> t2'
                      ---------------------------                    (ST_Plus2)
                      P (C n1) t2 ==> P (C n1) t2'
*)

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall n1 t2 t2',
      t2 ==> t2' ->
      P (C n1) t2 ==> P (C n1) t2'

  where " t '==>' t' " := (step t t').

(** Things to notice:

    - We are defining just a single reduction step, in which
      one [P] node is replaced by its value.

    - Each step finds the _leftmost_ [P] node that is ready to
      go (both of its operands are constants) and rewrites it in
      place.  The first rule tells how to rewrite this [P] node
      itself; the other two rules tell how to find it.

    - A term that is just a constant cannot take a step. *)

(** Let's pause and check a couple of examples of reasoning with
    the [step] relation... *)

(** If [t1] can take a step to [t1'], then [P t1 t2] steps
    to [P t1' t2]: *)

Example test_step_1 :
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
      ==>
      P
        (C (0 + 3))
        (P (C 2) (C 4)).
Proof.
  apply ST_Plus1. apply ST_PlusConstConst.  Qed.

(** **** Exercise: 1 star (test_step_2)  *)
(** Right-hand sides of sums can take a step only when the
    left-hand side is finished: if [t2] can take a step to [t2'],
    then [P (C n) t2] steps to [P (C n)
    t2']: *)

Example test_step_2 :
      P
        (C 0)
        (P
          (C 2)
          (P (C 0) (C 3)))
      ==>
      P
        (C 0)
        (P
          (C 2)
          (C (0 + 3))).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* HIDEFROMTERSE *)
End SimpleArith1.
(* /HIDEFROMTERSE *)

(* ########################################################### *)
(** * Relations *)

(** We will be using several different step relations, so it is
    helpful to generalize a bit and state a few definitions and
    theorems about relations in general.  (The optional chapter
    [Rel.v] develops some of these ideas in a bit more detail; it may
    be useful if the treatment here is too dense.) *)

(** A (binary) _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

Definition relation (X: Type) := X->X->Prop.

(** Our main examples of such relations in this chapter will be
    the single-step and multi-step reduction relations on terms, [==>]
    and [==>*], but there are many other examples -- some that come to
    mind are the "equals," "less than," "less than or equal to," and
    "is the square of" relations on numbers, and the "prefix of"
    relation on lists and strings. *)

(** One simple property of the [==>] relation is that, like the
    evaluation relation for our language of Imp programs, it is
    _deterministic_.

    _Theorem_: For each [t], there is at most one [t'] such that [t]
    steps to [t'] ([t ==> t'] is provable).  Formally, this is the
    same as saying that [==>] is deterministic. *)

(** _Proof sketch_: We show that if [x] steps to both [y1] and [y2]
    then [y1] and [y2] are equal, by induction on a derivation of
    [step x y1].  There are several cases to consider, depending on
    the last rule used in this derivation and in the given derivation
    of [step x y2].

      - If both are [ST_PlusConstConst], the result is immediate.

      - The cases when both derivations end with [ST_Plus1] or
        [ST_Plus2] follow by the induction hypothesis.

      - It cannot happen that one is [ST_PlusConstConst] and the other
        is [ST_Plus1] or [ST_Plus2], since this would imply that [x] has
        the form [P t1 t2] where both [t1] and [t2] are
        constants (by [ST_PlusConstConst]) _and_ one of [t1] or [t2] has
        the form [P ...].

      - Similarly, it cannot happen that one is [ST_Plus1] and the other
        is [ST_Plus2], since this would imply that [x] has the form
        [P t1 t2] where [t1] has both the form [P t1 t2] and
        the form [C n]. [] *)

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Module SimpleArith2.
Import SimpleArith1.

Theorem step_deterministic:
  deterministic step.
Proof.
  unfold deterministic. intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2.
    - (* ST_PlusConstConst *) inversion Hy2.
      + (* ST_PlusConstConst *) reflexivity.
      + (* ST_Plus1 *) inversion H2.
      + (* ST_Plus2 *) inversion H2.
    - (* ST_Plus1 *) inversion Hy2.
      + (* ST_PlusConstConst *) rewrite <- H0 in Hy1. inversion Hy1.
      + (* ST_Plus1 *)
        rewrite <- (IHHy1 t1'0).
        reflexivity. assumption.
      + (* ST_Plus2 *) rewrite <- H in Hy1. inversion Hy1.
    - (* ST_Plus2 *) inversion Hy2.
      + (* ST_PlusConstConst *) rewrite <- H1 in Hy1. inversion Hy1.
      + (* ST_Plus1 *) inversion H2.
      + (* ST_Plus2 *)
        rewrite <- (IHHy1 t2'0).
        reflexivity. assumption.
Qed.

(** There is some annoying repetition in this proof.  Each use of
    [inversion Hy2] results in three subcases, only one of which is
    relevant (the one which matches the current case in the induction
    on [Hy1]). The other two subcases need to be dismissed by finding
    the contradiction among the hypotheses and doing inversion on it.

    There is a tactic called [solve by inversion] defined in a small
    accompanying file [SfLib.v] that can be of use in such cases. It
    will solve the goal if it can be solved by inverting some
    hypothesis; otherwise, it fails.  (There are variants [solve by
    inversion 2] and [solve by inversion 3] that work if two or three
    consecutive inversions will solve the goal.)

    The example below shows how a proof of the previous theorem can be
    simplified using this tactic.
*)

Theorem step_deterministic_alt: deterministic step.
Proof.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2;
    inversion Hy2; subst; try (solve by inversion).
  - (* ST_PlusConstConst *) reflexivity.
  - (* ST_Plus1 *)
    apply IHHy1 in H2. rewrite H2. reflexivity.
  - (* ST_Plus2 *)
    apply IHHy1 in H2. rewrite H2. reflexivity.
Qed.

End SimpleArith2.

(* ########################################################### *)
(** ** Values *)

(** Let's take a moment to slightly generalize the way we state the
    definition of single-step reduction.  *)

(** It is useful to think of the [==>] relation as defining an
    _abstract machine_:

      - At any moment, the _state_ of the machine is a term.

      - A _step_ of the machine is an atomic unit of computation --
        here, a single "add" operation.

      - The _halting states_ of the machine are ones where there is no
        more computation to be done.
*)
(**
    We can then execute a term [t] as follows:

      - Take [t] as the starting state of the machine.

      - Repeatedly use the [==>] relation to find a sequence of
        machine states, starting with [t], where each state steps to
        the next.

      - When no more reduction is possible, "read out" the final state
        of the machine as the result of execution. *)

(** Intuitively, it is clear that the final states of the
    machine are always terms of the form [C n] for some [n].
    We call such terms _values_. *)

Inductive value : tm -> Prop :=
  v_const : forall n, value (C n).

(** Having introduced the idea of values, we can use it in the
    definition of the [==>] relation to write [ST_Plus2] rule in a
    slightly more elegant way: *)

(**
                     -------------------------------        (ST_PlusConstConst)
                     P (C n1) (C n2) ==> C (n1 + n2)

                              t1 ==> t1'
                         --------------------                        (ST_Plus1)
                         P t1 t2 ==> P t1' t2

                               value v1
                              t2 ==> t2'
                         --------------------                        (ST_Plus2)
                         P v1 t2 ==> P v1 t2'
*)
(** Again, the variable names here carry important information:
    by convention, [v1] ranges only over values, while [t1] and [t2]
    range over arbitrary terms.  (Given this convention, the explicit
    [value] hypothesis is arguably redundant.  We'll keep it for now,
    to maintain a close correspondence between the informal and Coq
    versions of the rules, but later on we'll drop it in informal
    rules, for the sake of brevity.) *)

(**  Here are the formal rules: *)

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
          P (C n1) (C n2)
      ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
        t1 ==> t1' ->
        P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
        value v1 ->                     (* <----- n.b. *)
        t2 ==> t2' ->
        P v1 t2 ==> P v1 t2'

  where " t '==>' t' " := (step t t').

(** **** Exercise: 3 stars, recommended (redo_determinism)  *)
(** As a sanity check on this change, let's re-verify determinism

    Proof sketch: We must show that if [x] steps to both [y1] and [y2]
    then [y1] and [y2] are equal.  Consider the final rules used in
    the derivations of [step x y1] and [step x y2].

    - If both are [ST_PlusConstConst], the result is immediate.

    - It cannot happen that one is [ST_PlusConstConst] and the other
      is [ST_Plus1] or [ST_Plus2], since this would imply that [x] has
      the form [P t1 t2] where both [t1] and [t2] are
      constants (by [ST_PlusConstConst]) AND one of [t1] or [t2] has
      the form [P ...].

    - Similarly, it cannot happen that one is [ST_Plus1] and the other
      is [ST_Plus2], since this would imply that [x] has the form
      [P t1 t2] where [t1] both has the form [P t1 t2] and
      is a value (hence has the form [C n]).

    - The cases when both derivations end with [ST_Plus1] or
      [ST_Plus2] follow by the induction hypothesis. [] *)

(** Most of this proof is the same as the one above.  But to get
    maximum benefit from the exercise you should try to write it from
    scratch and just use the earlier one if you get stuck. *)

Theorem step_deterministic :
  deterministic step.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ########################################################### *)
(** ** Strong Progress and Normal Forms *)

(** The definition of single-step reduction for our toy language is
    fairly simple, but for a larger language it would be pretty easy
    to forget one of the rules and create a situation where some term
    cannot take a step even though it has not been completely reduced
    to a value.  The following theorem shows that we did not, in fact,
    make such a mistake here. *)

(** _Theorem_ (_Strong Progress_): If [t] is a term, then either [t]
    is a value, or there exists a term [t'] such that [t ==> t']. *)

(** _Proof_: By induction on [t].

    - Suppose [t = C n]. Then [t] is a [value].

    - Suppose [t = P t1 t2], where (by the IH) [t1] is either a
      value or can step to some [t1'], and where [t2] is either a
      value or can step to some [t2']. We must show [P t1 t2] is
      either a value or steps to some [t'].

      - If [t1] and [t2] are both values, then [t] can take a step, by
        [ST_PlusConstConst].

      - If [t1] is a value and [t2] can take a step, then so can [t],
        by [ST_Plus2].

      - If [t1] can take a step, then so can [t], by [ST_Plus1].  [] *)

Theorem strong_progress : forall t,
  value t \/ (exists t', t ==> t').
Proof.
  induction t.
    - (* C *) left. apply v_const.
    - (* P *) right. inversion IHt1.
      + (* l *) inversion IHt2.
        * (* l *) inversion H. inversion H0.
          exists (C (n + n0)).
          apply ST_PlusConstConst.
        * (* r *) inversion H0 as [t' H1].
          exists (P t1 t').
          apply ST_Plus2. apply H. apply H1.
      + (* r *) inversion H as [t' H0].
          exists (P t' t2).
          apply ST_Plus1. apply H0.  Qed.

(** This important property is called _strong progress_, because
    every term either is a value or can "make progress" by stepping to
    some other term.  (The qualifier "strong" distinguishes it from a
    more refined version that we'll see in later chapters, called
    simply "progress.") *)

(** The idea of "making progress" can be extended to tell us something
    interesting about [value]s: in this language [value]s are exactly
    the terms that _cannot_ make progress in this sense.

    To state this observation formally, let's begin by giving a name
    to terms that cannot make progress.  We'll call them _normal
    forms_. *)

Definition normal_form {X:Type} (R:relation X) (t:X) : Prop :=
  ~ exists t', R t t'.

(** This definition actually specifies what it is to be a normal form
    for an _arbitrary_ relation [R] over an arbitrary set [X], not
    just for the particular single-step reduction relation over terms
    that we are interested in at the moment.  We'll re-use the same
    terminology for talking about other relations later in the
    course. *)

(** We can use this terminology to generalize the observation we made
    in the strong progress theorem: in this language, normal forms and
    values are actually the same thing. *)

Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
  unfold normal_form. intros v H. inversion H.
  intros contra. inversion contra. inversion H1.
Qed.

Lemma nf_is_value : forall t,
  normal_form step t -> value t.
Proof. (* a corollary of [strong_progress]... *)
  unfold normal_form. intros t H.
  assert (G : value t \/ exists t', t ==> t').
  { (* Proof of assertion *) apply strong_progress. }
  inversion G.
    + (* l *) apply H0.
    + (* r *) exfalso. apply H. assumption.  Qed.

Corollary nf_same_as_value : forall t,
  normal_form step t <-> value t.
Proof.
  split. apply nf_is_value. apply value_is_nf. Qed.

(** Why is this interesting?

    Because [value] is a syntactic concept -- it is defined by looking
    at the form of a term -- while [normal_form] is a semantic one --
    it is defined by looking at how the term steps.  It is not obvious
    that these concepts should coincide!

    Indeed, we could easily have written the definitions so that they
    would not coincide... *)

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

(** We might, for example, mistakenly define [value] so that it
    includes some terms that are not finished reducing. *)

Module Temp1.
(* Open an inner module so we can redefine value and step. *)

Inductive value : tm -> Prop :=
| v_const : forall n, value (C n)
| v_funny : forall t1 n2,                       (* <---- *)
              value (P t1 (C n2)).

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      P v1 t2 ==> P v1 t2'

  where " t '==>' t' " := (step t t').

(** **** Exercise: 3 stars, advanced (value_not_same_as_normal_form)  *)
Lemma value_not_same_as_normal_form :
  exists v, value v /\ ~ normal_form step v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)
End Temp1.

(* ##################################################### *)
(** Alternatively, we might mistakenly define [step] so that it
    permits something designated as a value to reduce further. *)

Module Temp2.

Inductive value : tm -> Prop :=
| v_const : forall n, value (C n).

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_Funny : forall n,                         (* <---- *)
      C n ==> P (C n) (C 0)
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      P v1 t2 ==> P v1 t2'

  where " t '==>' t' " := (step t t').

(** **** Exercise: 2 stars, advanced (value_not_same_as_normal_form)  *)
Lemma value_not_same_as_normal_form :
  exists v, value v /\ ~ normal_form step v.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)
End Temp2.

(* ########################################################### *)
(** Finally, we might define [value] and [step] so that there is some
    term that is not a value but that cannot take a step in the [step]
    relation.  Such terms are said to be _stuck_. In this case this is
    caused by a mistake in the semantics, but we will also see
    situations where, even in a correct language definition, it makes
    sense to allow some terms to be stuck. *)

Module Temp3.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n).

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2

  where " t '==>' t' " := (step t t').

(** (Note that [ST_Plus2] is missing.) *)

(** **** Exercise: 3 stars, advanced (value_not_same_as_normal_form')  *)
Lemma value_not_same_as_normal_form :
  exists t, ~ value t /\ normal_form step t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Temp3.

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

Module Temp4.

(** Here is another very simple language whose terms, instead of being
    just plus and numbers, are just the booleans true and false and a
    conditional expression... *)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Inductive value : tm -> Prop :=
  | v_true : value ttrue
  | v_false : value tfalse.

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      tif ttrue t1 t2 ==> t1
  | ST_IfFalse : forall t1 t2,
      tif tfalse t1 t2 ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tif t1 t2 t3 ==> tif t1' t2 t3

  where " t '==>' t' " := (step t t').

(** **** Exercise: 1 star (smallstep_bools)  *)
(** Which of the following propositions are provable?  (This is just a
    thought exercise, but for an extra challenge feel free to prove
    your answers in Coq.) *)

Definition bool_step_prop1 :=
  tfalse ==> tfalse.

(* FILL IN HERE *)

Definition bool_step_prop2 :=
     tif
       ttrue
       (tif ttrue ttrue ttrue)
       (tif tfalse tfalse tfalse)
  ==>
     ttrue.

(* FILL IN HERE *)

Definition bool_step_prop3 :=
     tif
       (tif ttrue ttrue ttrue)
       (tif ttrue ttrue ttrue)
       tfalse
   ==>
     tif
       ttrue
       (tif ttrue ttrue ttrue)
       tfalse.

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars, optional (progress_bool)  *)
(** Just as we proved a progress theorem for plus expressions, we can
    do so for boolean expressions, as well. *)

Theorem strong_progress : forall t,
  value t \/ (exists t', t ==> t').
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (step_deterministic)  *)
Theorem step_deterministic :
  deterministic step.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

Module Temp5.

(** **** Exercise: 2 stars (smallstep_bool_shortcut)  *)
(** Suppose we want to add a "short circuit" to the step relation for
    boolean expressions, so that it can recognize when the [then] and
    [else] branches of a conditional are the same value (either
    [ttrue] or [tfalse]) and reduce the whole conditional to this
    value in a single step, even if the guard has not yet been reduced
    to a value. For example, we would like this proposition to be
    provable:
         tif
            (tif ttrue ttrue ttrue)
            tfalse
            tfalse
     ==>
         tfalse.
*)

(** Write an extra clause for the step relation that achieves this
    effect and prove [bool_step_prop4]. *)

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      tif ttrue t1 t2 ==> t1
  | ST_IfFalse : forall t1 t2,
      tif tfalse t1 t2 ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tif t1 t2 t3 ==> tif t1' t2 t3
(* FILL IN HERE *)

  where " t '==>' t' " := (step t t').

Definition bool_step_prop4 :=
         tif
            (tif ttrue ttrue ttrue)
            tfalse
            tfalse
     ==>
         tfalse.

Example bool_step_prop4_holds :
  bool_step_prop4.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (properties_of_altered_step)  *)
(** It can be shown that the determinism and strong progress theorems
    for the step relation in the lecture notes also hold for the
    definition of step given above.  After we add the clause
    [ST_ShortCircuit]...

    - Is the [step] relation still deterministic?  Write yes or no and
      briefly (1 sentence) explain your answer.

      Optional: prove your answer correct in Coq.
*)

(* FILL IN HERE *)
(**
   - Does a strong progress theorem hold? Write yes or no and
     briefly (1 sentence) explain your answer.

     Optional: prove your answer correct in Coq.
*)

(* FILL IN HERE *)
(**
   - In general, is there any way we could cause strong progress to
     fail if we took away one or more constructors from the original
     step relation? Write yes or no and briefly (1 sentence) explain
     your answer.

(* FILL IN HERE *)
*)
(** [] *)

End Temp5.
End Temp4.

(* ########################################################### *)
(** * Multi-Step Reduction *)

(** Until now, we've been working with the _single-step reduction_
    relation [==>], which formalizes the individual steps of an
    _abstract machine_ for executing programs.

    We can also use this machine to reduce programs to completion --
    to find out what final result they yield.  This can be formalized
    as follows:

    - First, we define a _multi-step reduction relation_ [==>*], which
      relates terms [t] and [t'] if [t] can reach [t'] by any number
      of single reduction steps (including zero steps!).

    - Then we define a "result" of a term [t] as a normal form that
      [t] can reach by multi-step reduction. *)

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

(** Since we'll want to reuse the idea of multi-step reduction many
    times in this and future chapters, let's take a little extra
    trouble here and define it generically.

    Given a relation [R], we define a relation [multi R], called the
    _multi-step closure of [R]_ as follows. *)

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl  : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

(** (In the [Rel] chapter and the Coq standard library, this relation
    is called [clos_refl_trans_1n].  We give it a shorter name here
    for the sake of readability.)

    The effect of this definition is that [multi R] relates two
    elements [x] and [y] if either

       - [x = y], or else
       - there is some sequence [z1], [z2], ..., [zn] such that
           R x z1 R z1 z2 ...  R zn y.

    Thus, if [R] describes a single-step of computation, [z1],
    ... [zn] is the sequence of intermediate steps of computation
    between [x] and [y].
*)

(** We write [==>*] for the [multi step] relation -- i.e., the
    relation that relates two terms [t] and [t'] if we can get from
    [t] to [t'] using the [step] relation zero or more times. *)

Notation " t '==>*' t' " := (multi step t t') (at level 40).

(** The relation [multi R] has several crucial properties.

    First, it is obviously _reflexive_ (that is, [forall x, multi R x
    x]).  In the case of the [==>*] (i.e. [multi step]) relation, the
    intuition is that a term can execute to itself by taking zero
    steps of execution.

    Second, it contains [R] -- that is, single-step executions are a
    particular case of multi-step executions.  (It is this fact that
    justifies the word "closure" in the term "multi-step closure of
    [R].") *)

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> (multi R) x y.
Proof.
  intros X R x y H.
  apply multi_step with y. apply H. apply multi_refl.   Qed.

(** Third, [multi R] is _transitive_. *)

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  intros X R x y z G H.
  induction G.
    - (* multi_refl *) assumption.
    - (* multi_step *)
      apply multi_step with y. assumption.
      apply IHG. assumption.  Qed.

(** That is, if [t1==>*t2] and [t2==>*t3], then [t1==>*t3]. *)

(* ########################################################### *)
(** ** Examples *)

Lemma test_multistep_1:
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
   ==>*
      C ((0 + 3) + (2 + 4)).
Proof.
  apply multi_step with
            (P
                (C (0 + 3))
                (P (C 2) (C 4))).
  apply ST_Plus1. apply ST_PlusConstConst.
  apply multi_step with
            (P
                (C (0 + 3))
                (C (2 + 4))).
  apply ST_Plus2. apply v_const.
  apply ST_PlusConstConst.
  apply multi_R.
  apply ST_PlusConstConst. Qed.

(** Here's an alternate proof that uses [eapply] to avoid explicitly
    constructing all the intermediate terms. *)

Lemma test_multistep_1':
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
  ==>*
      C ((0 + 3) + (2 + 4)).
Proof.
  eapply multi_step. apply ST_Plus1. apply ST_PlusConstConst.
  eapply multi_step. apply ST_Plus2. apply v_const.
  apply ST_PlusConstConst.
  eapply multi_step. apply ST_PlusConstConst.
  apply multi_refl.  Qed.

(** **** Exercise: 1 star, optional (test_multistep_2)  *)
Lemma test_multistep_2:
  C 3 ==>* C 3.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, optional (test_multistep_3)  *)
Lemma test_multistep_3:
      P (C 0) (C 3)
   ==>*
      P (C 0) (C 3).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (test_multistep_4)  *)
Lemma test_multistep_4:
      P
        (C 0)
        (P
          (C 2)
          (P (C 0) (C 3)))
  ==>*
      P
        (C 0)
        (C (2 + (0 + 3))).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ########################################################### *)
(** ** Normal Forms Again *)

(** If [t] reduces to [t'] in zero or more steps and [t'] is a
    normal form, we say that "[t'] is a normal form of [t]." *)

Definition step_normal_form := normal_form step.

Definition normal_form_of (t t' : tm) :=
  (t ==>* t' /\ step_normal_form t').

(** We have already seen that, for our language, single-step reduction is
    deterministic -- i.e., a given term can take a single step in
    at most one way.  It follows from this that, if [t] can reach
    a normal form, then this normal form is unique.  In other words, we
    can actually pronounce [normal_form t t'] as "[t'] is _the_
    normal form of [t]." *)

(** **** Exercise: 3 stars, optional (normal_forms_unique)  *)
Theorem normal_forms_unique:
  deterministic normal_form_of.
Proof.
  unfold deterministic. unfold normal_form_of.  intros x y1 y2 P1 P2.
  inversion P1 as [P11 P12]; clear P1. inversion P2 as [P21 P22]; clear P2.
  generalize dependent y2.
  (* We recommend using this initial setup as-is! *)
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Indeed, something stronger is true for this language (though not
    for all languages): the reduction of _any_ term [t] will
    eventually reach a normal form -- i.e., [normal_form_of] is a
    _total_ function.  Formally, we say the [step] relation is
    _normalizing_. *)

Definition normalizing {X:Type} (R:relation X) :=
  forall t, exists t',
    (multi R) t t' /\ normal_form R t'.

(** To prove that [step] is normalizing, we need a couple of lemmas.

    First, we observe that, if [t] reduces to [t'] in many steps, then
    the same sequence of reduction steps within [t] is also possible
    when [t] appears as the left-hand child of a [P] node, and
    similarly when [t] appears as the right-hand child of a [P]
    node whose left-hand child is a value. *)

Lemma multistep_congr_1 : forall t1 t1' t2,
     t1 ==>* t1' ->
     P t1 t2 ==>* P t1' t2.
Proof.
  intros t1 t1' t2 H. induction H.
    - (* multi_refl *) apply multi_refl.
    - (* multi_step *) apply multi_step with (P y t2).
        apply ST_Plus1. apply H.
        apply IHmulti.  Qed.

(** **** Exercise: 2 stars (multistep_congr_2)  *)
Lemma multistep_congr_2 : forall t1 t2 t2',
     value t1 ->
     t2 ==>* t2' ->
     P t1 t2 ==>* P t1 t2'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** _Theorem_: The [step] function is normalizing -- i.e., for every
    [t] there exists some [t'] such that [t] steps to [t'] and [t'] is
    a normal form.

    _Proof sketch_: By induction on terms.  There are two cases to
    consider:

    - [t = C n] for some [n].  Here [t] doesn't take a step,
      and we have [t' = t].  We can derive the left-hand side by
      reflexivity and the right-hand side by observing (a) that values
      are normal forms (by [nf_same_as_value]) and (b) that [t] is a
      value (by [v_const]).

    - [t = P t1 t2] for some [t1] and [t2].  By the IH, [t1] and
      [t2] have normal forms [t1'] and [t2'].  Recall that normal
      forms are values (by [nf_same_as_value]); we know that [t1' =
      C n1] and [t2' = C n2], for some [n1] and [n2].
      We can combine the [==>*] derivations for [t1] and [t2] to prove
      that [P t1 t2] reduces in many steps to [C (n1 + n2)].

      It is clear that our choice of [t' = C (n1 + n2)] is a
      value, which is in turn a normal form. [] *)

Theorem step_normalizing :
  normalizing step.
Proof.
  unfold normalizing.
  induction t.
    - (* C *)
      exists (C n).
      split.
      + (* l *) apply multi_refl.
      + (* r *)
        (* We can use [rewrite] with "iff" statements, not
           just equalities: *)
        rewrite nf_same_as_value. apply v_const.
    - (* P *)
      inversion IHt1 as [t1' H1]; clear IHt1. inversion IHt2 as [t2' H2]; clear IHt2.
      inversion H1 as [H11 H12]; clear H1. inversion H2 as [H21 H22]; clear H2.
      rewrite nf_same_as_value in H12. rewrite nf_same_as_value in H22.
      inversion H12 as [n1]. inversion H22 as [n2].
      rewrite <- H in H11.
      rewrite <- H0 in H21.
      exists (C (n1 + n2)).
      split.
        + (* l *)
          apply multi_trans with (P (C n1) t2).
          apply multistep_congr_1. apply H11.
          apply multi_trans with
             (P (C n1) (C n2)).
          apply multistep_congr_2. apply v_const. apply H21.
          apply multi_R. apply ST_PlusConstConst.
        + (* r *)
          rewrite nf_same_as_value. apply v_const.  Qed.

(* ########################################################### *)
(** ** Equivalence of Big-Step and Small-Step Reduction *)

(** Having defined the operational semantics of our tiny programming
    language in two different styles, it makes sense to ask whether
    these definitions actually define the same thing!  They do, though
    it takes a little work to show it.  (The details are left as an
    exercise). *)

(** **** Exercise: 3 stars (eval__multistep)  *)
Theorem eval__multistep : forall t n,
  t \\ n -> t ==>* C n.

(** The key idea behind the proof comes from the following picture:
       P t1 t2 ==>            (by ST_Plus1)
       P t1' t2 ==>           (by ST_Plus1)
       P t1'' t2 ==>          (by ST_Plus1)
       ...
       P (C n1) t2 ==>        (by ST_Plus2)
       P (C n1) t2' ==>       (by ST_Plus2)
       P (C n1) t2'' ==>      (by ST_Plus2)
       ...
       P (C n1) (C n2) ==>    (by ST_PlusConstConst)
       C (n1 + n2)
    That is, the multistep reduction of a term of the form [P t1 t2]
    proceeds in three phases:
       - First, we use [ST_Plus1] some number of times to reduce [t1]
         to a normal form, which must (by [nf_same_as_value]) be a
         term of the form [C n1] for some [n1].
       - Next, we use [ST_Plus2] some number of times to reduce [t2]
         to a normal form, which must again be a term of the form [C
         n2] for some [n2].
       - Finally, we use [ST_PlusConstConst] one time to reduce [P (C
         n1) (C n2)] to [C (n1 + n2)]. *)

(** To formalize this intuition, you'll need to use the congruence
    lemmas from above (you might want to review them now, so that
    you'll be able to recognize when they are useful), plus some basic
    properties of [==>*]: that it is reflexive, transitive, and
    includes [==>]. *)
(* !!! *)
Proof.
  intros.
  induction H.
  - apply multi_refl.
  - apply multi_trans with (y := P (C n1) t2 ).
    apply multistep_congr_1. assumption.
    apply multi_trans with (y:= P (C n1) (C n2)).
    apply multistep_congr_2.
    + apply v_const.
    + assumption.
    + apply multi_R. apply ST_PlusConstConst.
Qed.

(** **** Exercise: 3 stars, advanced (eval__multistep_inf)  *)
(** Write a detailed informal version of the proof of [eval__multistep].

(* FILL IN HERE *)
[]
*)
(** For the other direction, we need one lemma, which establishes a
    relation between single-step reduction and big-step evaluation. *)

(** **** Exercise: 3 stars (step__eval)  *)
Lemma step__eval : forall t t' n,
     t ==> t' ->
     t' \\ n ->
     t \\ n.
Proof.
  intros t t' n Hs. generalize dependent n.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The fact that small-step reduction implies big-step is now
    straightforward to prove, once it is stated correctly.

    The proof proceeds by induction on the multi-step reduction
    sequence that is buried in the hypothesis [normal_form_of t t']. *)
(** Make sure you understand the statement before you start to
    work on the proof.  *)

(** **** Exercise: 3 stars (multistep__eval)  *)
Theorem multistep__eval : forall t t',
  normal_form_of t t' -> exists n, t' = C n /\ t \\ n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** **** Exercise: 3 stars, optional (interp_tm)  *)
(** Remember that we also defined big-step evaluation of [tm]s as a
    function [evalF].  Prove that it is equivalent to the existing
    semantics.

    Hint: we just proved that [eval] and [multistep] are
    equivalent, so logically it doesn't matter which you choose.
    One will be easier than the other, though!  *)

Theorem evalF_eval : forall t n,
  evalF t = n <-> t \\ n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars (combined_properties)  *)
(** We've considered the arithmetic and conditional expressions
    separately.  This exercise explores how the two interact. *)

Module Combined.

Inductive tm : Type :=
  | C : nat -> tm
  | P : tm -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n)
  | v_true : value ttrue
  | v_false : value tfalse.

Reserved Notation " t '==>' t' " (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      P v1 t2 ==> P v1 t2'
  | ST_IfTrue : forall t1 t2,
      tif ttrue t1 t2 ==> t1
  | ST_IfFalse : forall t1 t2,
      tif tfalse t1 t2 ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tif t1 t2 t3 ==> tif t1' t2 t3

  where " t '==>' t' " := (step t t').

(** Earlier, we separately proved for both plus- and if-expressions...

    - that the step relation was deterministic, and

    - a strong progress lemma, stating that every term is either a
      value or can take a step.

    Prove or disprove these two properties for the combined language. *)

(* FILL IN HERE *)
(** [] *)

End Combined.

(* ########################################################### *)
(** * Small-Step Imp *)

(** For a more serious example, here is the small-step version of the
    Imp operational semantics.  *)

(** The small-step evaluation relations for arithmetic and boolean
    expressions are straightforward extensions of the tiny language
    we've been working up to now.  To make them easier to read, we
    introduce the symbolic notations [==>a] and [==>b], respectively,
    for the arithmetic and boolean step relations. *)

Inductive aval : aexp -> Prop :=
  av_num : forall n, aval (ANum n).

(** We are not actually going to bother to define boolean
    values, since they aren't needed in the definition of [==>b]
    below (why?), though they might be if our language were a bit
    larger (why?). *)

Reserved Notation " t '/' st '==>a' t' " (at level 40, st at level 39).

Inductive astep : state -> aexp -> aexp -> Prop :=
  | AS_Id : forall st i,
      AId i / st ==>a ANum (st i)
  | AS_Plus : forall st n1 n2,
      APlus (ANum n1) (ANum n2) / st ==>a ANum (n1 + n2)
  | AS_Plus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (APlus a1 a2) / st ==>a (APlus a1' a2)
  | AS_Plus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (APlus v1 a2) / st ==>a (APlus v1 a2')
  | AS_Minus : forall st n1 n2,
      (AMinus (ANum n1) (ANum n2)) / st ==>a (ANum (minus n1 n2))
  | AS_Minus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMinus a1 a2) / st ==>a (AMinus a1' a2)
  | AS_Minus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMinus v1 a2) / st ==>a (AMinus v1 a2')
  | AS_Mult : forall st n1 n2,
      (AMult (ANum n1) (ANum n2)) / st ==>a (ANum (mult n1 n2))
  | AS_Mult1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMult (a1) (a2)) / st ==>a (AMult (a1') (a2))
  | AS_Mult2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMult v1 a2) / st ==>a (AMult v1 a2')

    where " t '/' st '==>a' t' " := (astep st t t').

  Reserved Notation " t '/' st '==>b' t' " (at level 40, st at level 39).

  Inductive bstep : state -> bexp -> bexp -> Prop :=
  | BS_Eq : forall st n1 n2,
      (BEq (ANum n1) (ANum n2)) / st ==>b
      (if (beq_nat n1 n2) then BTrue else BFalse)
  | BS_Eq1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (BEq a1 a2) / st ==>b (BEq a1' a2)
  | BS_Eq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (BEq v1 a2) / st ==>b (BEq v1 a2')
  | BS_LtEq : forall st n1 n2,
      (BLe (ANum n1) (ANum n2)) / st ==>b
               (if (leb n1 n2) then BTrue else BFalse)
  | BS_LtEq1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (BLe a1 a2) / st ==>b (BLe a1' a2)
  | BS_LtEq2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (BLe v1 a2) / st ==>b (BLe v1 (a2'))
  | BS_NotTrue : forall st,
      (BNot BTrue) / st ==>b BFalse
  | BS_NotFalse : forall st,
      (BNot BFalse) / st ==>b BTrue
  | BS_NotStep : forall st b1 b1',
      b1 / st ==>b b1' ->
      (BNot b1) / st ==>b (BNot b1')
  | BS_AndTrueTrue : forall st,
      (BAnd BTrue BTrue) / st ==>b BTrue
  | BS_AndTrueFalse : forall st,
      (BAnd BTrue BFalse) / st ==>b BFalse
  | BS_AndFalse : forall st b2,
      (BAnd BFalse b2) / st ==>b BFalse
  | BS_AndTrueStep : forall st b2 b2',
      b2 / st ==>b b2' ->
      (BAnd BTrue b2) / st ==>b (BAnd BTrue b2')
  | BS_AndStep : forall st b1 b1' b2,
      b1 / st ==>b b1' ->
      (BAnd b1 b2) / st ==>b (BAnd b1' b2)

  where " t '/' st '==>b' t' " := (bstep st t t').

(** The semantics of commands is the interesting part.  We need two
    small tricks to make it work:

       - We use [SKIP] as a "command value" -- i.e., a command that
         has reached a normal form.

            - An assignment command reduces to [SKIP] (and an updated
              state).

            - The sequencing command waits until its left-hand
              subcommand has reduced to [SKIP], then throws it away so
              that reduction can continue with the right-hand
              subcommand.

       - We reduce a [WHILE] command by transforming it into a
         conditional followed by the same [WHILE].  *)

(** (There are other ways of achieving the effect of the latter
   trick, but they all share the feature that the original [WHILE]
   command needs to be saved somewhere while a single copy of the loop
   body is being evaluated.) *)

Reserved Notation " t '/' st '==>' t' '/' st' "
                  (at level 40, st at level 39, t' at level 39).

Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st i a a',
      a / st ==>a a' ->
      (i ::= a) / st ==> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st ==> SKIP / (t_update st i n)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st c1 c2,
      IFB BTrue THEN c1 ELSE c2 FI / st ==> c1 / st
  | CS_IfFalse : forall st c1 c2,
      IFB BFalse THEN c1 ELSE c2 FI / st ==> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b / st ==>b b' ->
      IFB b THEN c1 ELSE c2 FI / st ==> (IFB b' THEN c1 ELSE c2 FI) / st
  | CS_While : forall st b c1,
          (WHILE b DO c1 END) / st
      ==> (IFB b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI) / st

  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')).

(* ########################################################### *)
(** * Concurrent Imp *)

(** Finally, to show the power of this definitional style, let's
    enrich Imp with a new form of command that runs two subcommands in
    parallel and terminates when both have terminated.  To reflect the
    unpredictability of scheduling, the actions of the subcommands may
    be interleaved in any order, but they share the same memory and
    can communicate by reading and writing the same variables. *)

Module CImp.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  (* New: *)
  | CPar : com -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' b 'THEN' c1 'ELSE' c2 'FI'" :=
  (CIf b c1 c2) (at level 80, right associativity).
Notation "'PAR' c1 'WITH' c2 'END'" :=
  (CPar c1 c2) (at level 80, right associativity).

Inductive cstep : (com * state)  -> (com * state) -> Prop :=
    (* Old part *)
  | CS_AssStep : forall st i a a',
      a / st ==>a a' ->
      (i ::= a) / st ==> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st ==> SKIP / (t_update st i n)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st c1 c2,
      (IFB BTrue THEN c1 ELSE c2 FI) / st ==> c1 / st
  | CS_IfFalse : forall st c1 c2,
      (IFB BFalse THEN c1 ELSE c2 FI) / st ==> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b /st ==>b b' ->
      (IFB b THEN c1 ELSE c2 FI) / st ==> (IFB b' THEN c1 ELSE c2 FI) / st
  | CS_While : forall st b c1,
      (WHILE b DO c1 END) / st ==>
               (IFB b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI) / st
    (* New part: *)
  | CS_Par1 : forall st c1 c1' c2 st',
      c1 / st ==> c1' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1' WITH c2 END) / st'
  | CS_Par2 : forall st c1 c2 c2' st',
      c2 / st ==> c2' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1 WITH c2' END) / st'
  | CS_ParDone : forall st,
      (PAR SKIP WITH SKIP END) / st ==> SKIP / st
  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')).

Definition cmultistep := multi cstep.

Notation " t '/' st '==>*' t' '/' st' " :=
   (multi cstep  (t,st) (t',st'))
   (at level 40, st at level 39, t' at level 39).

(** Among the many interesting properties of this language is the fact
    that the following program can terminate with the variable [X] set
    to any value... *)

Definition par_loop : com :=
  PAR
    Y ::= ANum 1
  WITH
    WHILE BEq (AId Y) (ANum 0) DO
      X ::= APlus (AId X) (ANum 1)
    END
  END.

(** In particular, it can terminate with [X] set to [0]: *)

Example par_loop_example_0:
  exists st',
       par_loop / empty_state  ==>* SKIP / st'
    /\ st' X = 0.
Proof.
  eapply ex_intro. split.
  unfold par_loop.
  eapply multi_step. apply CS_Par1.
    apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity. Qed.

(** It can also terminate with [X] set to [2]: *)

Example par_loop_example_2:
  exists st',
       par_loop / empty_state ==>* SKIP / st'
    /\ st' X = 2.
Proof.
  eapply ex_intro. split.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.

  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Ass.

  eapply multi_step. apply CS_Par1. apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity. Qed.

(** More generally... *)

(** **** Exercise: 3 stars, optional  *)
Lemma par_body_n__Sn : forall n st,
  st X = n /\ st Y = 0 ->
  par_loop / st ==>* par_loop / (t_update st X (S n)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional  *)
Lemma par_body_n : forall n st,
  st X = 0 /\ st Y = 0 ->
  exists st',
    par_loop / st ==>*  par_loop / st' /\ st' X = n /\ st' Y = 0.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** ... the above loop can exit with [X] having any value
    whatsoever. *)

Theorem par_loop_any_X:
  forall n, exists st',
    par_loop / empty_state ==>*  SKIP / st'
    /\ st' X = n.
Proof.
  intros n.
  destruct (par_body_n n empty_state).
    split; unfold t_update; reflexivity.

  rename x into st.
  inversion H as [H' [HX HY]]; clear H.
  exists (t_update st Y 1). split.
  eapply multi_trans with (par_loop,st). apply H'.
  eapply multi_step. apply CS_Par1. apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id. rewrite t_update_eq.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  apply multi_refl.

  rewrite t_update_neq. assumption. intro X; inversion X.
Qed.

End CImp.

(* ########################################################### *)
(** * A Small-Step Stack Machine *)

(** Last example: a small-step semantics for the stack machine example
    from Imp.v. *)

Definition stack := list nat.
Definition prog  := list sinstr.

Inductive stack_step : state -> prog * stack -> prog * stack -> Prop :=
  | SS_Push : forall st stk n p',
    stack_step st (SPush n :: p', stk)      (p', n :: stk)
  | SS_Load : forall st stk i p',
    stack_step st (SLoad i :: p', stk)      (p', st i :: stk)
  | SS_Plus : forall st stk n m p',
    stack_step st (SPlus :: p', n::m::stk)  (p', (m+n)::stk)
  | SS_Minus : forall st stk n m p',
    stack_step st (SMinus :: p', n::m::stk) (p', (m-n)::stk)
  | SS_Mult : forall st stk n m p',
    stack_step st (SMult :: p', n::m::stk)  (p', (m*n)::stk).

Theorem stack_step_deterministic : forall st,
  deterministic (stack_step st).
Proof.
  unfold deterministic. intros st x y1 y2 H1 H2.
  induction H1; inversion H2; reflexivity.
Qed.

Definition stack_multistep st := multi (stack_step st).

(** **** Exercise: 3 stars, advanced (compiler_is_correct)  *)
(** Remember the definition of [compile] for [aexp] given in the
    [Imp] chapter. We want now to prove [compile] correct with respect
    to the stack machine.

    State what it means for the compiler to be correct according to
    the stack machine small step semantics and then prove it. *)

Definition compiler_is_correct_statement : Prop :=
(* FILL IN HERE *) admit.

Theorem compiler_is_correct : compiler_is_correct_statement.
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** $Date: 2016-02-04 21:50:25 +0000 (Thu, 04 Feb 2016) $ *)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA        LRI-CNRS        ENS-CNRS                *)
(*              Rocquencourt         Orsay          Lyon                    *)
(*                                                                          *)
(*                                 Coq V6.2                                 *)
(*                               May 1st 1998                               *)
(*                                                                          *)
(****************************************************************************)
(*                                Streams.v                                 *)
(****************************************************************************)

(* -------------------------------------------------------------------------*)
(*          Modified because of name clashes on map and ForAll              *)
(*                      with their list counterpart                         *)
(* -------------------------------------------------------------------------*)

Require Import List.

Set Implicit Arguments.
Unset Strict Implicit.

Section Streams. (* The set of streams : definition *)

Variable A : Set.

CoInductive Stream : Set :=
    Cons : A -> Stream -> Stream.

Definition hd (x : Stream) := match x with
                              | Cons a _ => a
                              end.

Definition tl (x : Stream) := match x with
                              | Cons _ s => s
                              end.

Fixpoint Str_nth_tl (n : nat) : Stream -> Stream :=
  fun s : Stream => match n with
                    | O => s
                    | S m => Str_nth_tl m (tl s)
                    end.

Definition Str_nth (n : nat) (s : Stream) : A := hd (Str_nth_tl n s).

Lemma unfold_Stream :
 forall x : Stream, x = match x with
                        | Cons a s => Cons a s
                        end.
Proof.
  intro x.
  case x.
  trivial.
Qed.

Lemma tl_nth_tl :
 forall (n : nat) (s : Stream), tl (Str_nth_tl n s) = Str_nth_tl n (tl s).
Proof.
  simple induction n; simpl in |- *; auto.
Qed.
Hint Resolve tl_nth_tl: datatypes.

Lemma Str_nth_tl_plus :
 forall (n m : nat) (s : Stream),
 Str_nth_tl n (Str_nth_tl m s) = Str_nth_tl (n + m) s.
simple induction n; simpl in |- *; intros; auto with datatypes.
rewrite <- H.
rewrite tl_nth_tl; trivial with datatypes.
Qed.

Lemma Str_nth_plus :
 forall (n m : nat) (s : Stream),
 Str_nth n (Str_nth_tl m s) = Str_nth (n + m) s.
intros; unfold Str_nth in |- *; rewrite Str_nth_tl_plus;
 trivial with datatypes.
Qed.

(* Extensional Equality between two streams  *)

CoInductive EqSt : Stream -> Stream -> Prop :=
    eqst :
      forall s1 s2 : Stream,
      hd s1 = hd s2 -> EqSt (tl s1) (tl s2) -> EqSt s1 s2.

(* A coinduction principle *)

Ltac coinduction proof :=
  cofix proof;
   (intros; (constructor; [ clear proof | try (apply proof; clear proof) ])).

(* Extensional equality is an equivalence relation *)

Theorem EqSt_reflex : forall s : Stream, EqSt s s.
coinduction ipattern:(EqSt_reflex).
reflexivity.
Qed.

Theorem sym_EqSt : forall s1 s2 : Stream, EqSt s1 s2 -> EqSt s2 s1.
coinduction ipattern:(Eq_sym).
case H; intros; symmetry  in |- *; assumption.
case H; intros; assumption.
Qed.

Theorem trans_EqSt :
 forall s1 s2 s3 : Stream, EqSt s1 s2 -> EqSt s2 s3 -> EqSt s1 s3.
coinduction ipattern:(Eq_trans).
transitivity (hd s2).
case H; intros; assumption.
case H0; intros; assumption.
apply (Eq_trans (tl s1) (tl s2) (tl s3)).
case H; trivial with datatypes.
case H0; trivial with datatypes.
Qed.

(*
The definition given is equivalent to require the elements at each position to be equal
*)

Theorem eqst_ntheq :
 forall (n : nat) (s1 s2 : Stream), EqSt s1 s2 -> Str_nth n s1 = Str_nth n s2.
unfold Str_nth in |- *; simple induction n.
intros s1 s2 H; case H; trivial with datatypes.
intros m hypind.
simpl in |- *.
intros s1 s2 H.
apply hypind.
case H; trivial with datatypes.
Qed.

Theorem ntheq_eqst :
 forall s1 s2 : Stream,
 (forall n : nat, Str_nth n s1 = Str_nth n s2) -> EqSt s1 s2.
coinduction ipattern:(Equiv2).
apply (H 0).
intros n; apply (H (S n)).
Qed.

Section Stream_Properties.

Variable P : Stream -> Prop.

Inductive Exists : Stream -> Prop :=
  | Here : forall x : Stream, P x -> Exists x
  | Further : forall x : Stream, ~ P x -> Exists (tl x) -> Exists x.

CoInductive ForAllS : Stream -> Prop :=
    forallS : forall x : Stream, P x -> ForAllS (tl x) -> ForAllS x.

End Stream_Properties.

End Streams.

Section Map.

Variable A B C : Set.
Variable f : A -> B.

CoFixpoint mapStr  : Stream A -> Stream B :=
  fun s : Stream A => Cons (f (hd s)) (mapStr (tl s)).

Variable g : A -> B -> C.

CoFixpoint mapStr2  : Stream A -> Stream B -> Stream C :=
  fun sa sb => Cons (g (hd sa) (hd sb)) (mapStr2 (tl sa) (tl sb)).

End Map.

Section Others.

Variable A B C : Set.
Variable a : A.

CoInductive ForAllStr (P : A -> Prop) : Stream A -> Prop :=
    DefForAllStr :
      forall sa : Stream A,
      P (hd sa) -> ForAllStr P (tl sa) -> ForAllStr P sa.

CoInductive ForAllStr2 (P : A -> B -> Prop) : Stream A -> Stream B -> Prop :=
    DefForAllStr2 :
      forall (sa : Stream A) (sb : Stream B),
      P (hd sa) (hd sb) -> ForAllStr2 P (tl sa) (tl sb) -> ForAllStr2 P sa sb.

CoFixpoint l_ListOfStr2StrOfLists  : list (Stream A) -> Stream (list A) :=
  fun ls =>
  let lh := map (fun s : Stream A => hd s) ls in
  let ltl := map (fun s : Stream A => tl s) ls in
  Cons lh (l_ListOfStr2StrOfLists ltl).

(* A REVOIR *)
Parameter
  l_streamOfLists2ListOfStreams :
    A -> nat -> Stream (list A) -> list (Stream A).

Fixpoint mapCons (lh : list A) : list (Stream A) -> list (Stream A) :=
  fun ltls =>
  match lh, ltls with
  | nil, _ => nil (A:=Stream A)
  | h :: tlh, nil => nil (A:=Stream A)
  | h :: tlh, htls :: tltls =>
      let hs := Cons h htls in let tls := mapCons tlh tltls in hs :: tls
  end.
End Others.

Section Extend_Some_Function_Pointwise.
Variable A B C D : Set.
Variable f : A -> B.
Variable g : A -> B -> C.
Variable h : A -> B -> C -> D.
Variable k : list A -> A.

CoFixpoint extend  : Stream A -> Stream B :=
  fun s => Cons (f (hd s)) (extend (tl s)).

CoFixpoint extend2  : Stream A -> Stream B -> Stream C :=
  fun s1 s2 => Cons (g (hd s1) (hd s2)) (extend2 (tl s1) (tl s2)).

CoFixpoint extend3  : Stream A -> Stream B -> Stream C -> Stream D :=
  fun s1 s2 s3 =>
  Cons (h (hd s1) (hd s2) (hd s3)) (extend3 (tl s1) (tl s2) (tl s3)).

CoFixpoint extendNTo1  : list (Stream A) -> Stream A :=
  fun lsv =>
  let heads := map (fun x => hd x) lsv in
  let tails := map (fun x => tl x) lsv in Cons (k heads) (extendNTo1 tails).

End Extend_Some_Function_Pointwise.

Section Extend_Some_Relationship_Pointwise.
Variable A B C : Set.
Variable R1 : A -> Prop.
Variable R2 : A -> B -> Prop.
Variable R3 : A -> B -> C -> Prop.

CoInductive Extend1 : Stream A -> Prop :=
    ExtendCons1 :
      forall s1 : Stream A, R1 (hd s1) -> Extend1 (tl s1) -> Extend1 s1.

CoInductive Extend2 : Stream A -> Stream B -> Prop :=
    ExtendCons2 :
      forall (s1 : Stream A) (s2 : Stream B),
      R2 (hd s1) (hd s2) -> Extend2 (tl s1) (tl s2) -> Extend2 s1 s2.

CoInductive Extend3 : Stream A -> Stream B -> Stream C -> Prop :=
    ExtendCons3 :
      forall (s1 : Stream A) (s2 : Stream B) (s3 : Stream C),
      R3 (hd s1) (hd s2) (hd s3) ->
      Extend3 (tl s1) (tl s2) (tl s3) -> Extend3 s1 s2 s3.

End Extend_Some_Relationship_Pointwise.

Section Extend_Some_Dependent_Relationship_Pointwise.
Variable A B C : Set.
Variable R : A -> A -> Prop.

CoInductive ExtendFrom : A -> Stream A -> Prop :=
    ExtendFromCons :
      forall (a : A) (s1 : Stream A),
      R a (hd s1) -> ExtendFrom (hd s1) (tl s1) -> ExtendFrom a s1.
End Extend_Some_Dependent_Relationship_Pointwise.

Set Strict Implicit.
Unset Implicit Arguments.

(* $Id$ *)


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

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive term :=
  | S : term
  | K : term
  | App : term -> term -> term.
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint is_value (t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.

(* Why3 assumption *)
Inductive context :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context.
Axiom context_WhyType : WhyType context.
Existing Instance context_WhyType.

(* Why3 assumption *)
Fixpoint is_context (c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.

(* Why3 assumption *)
Fixpoint subst (c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.

(* Why3 assumption *)
Inductive infix_mnmngt: term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR: term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Axiom reducible_or_value : forall (t:term), (exists t':term, (infix_mnmngt t
  t')) \/ (is_value t).

(* Why3 assumption *)
Definition irreducible (t:term): Prop := forall (t':term), ~ (infix_mnmngt t
  t').

Axiom irreducible_is_value : forall (t:term), (irreducible t) <-> (is_value
  t).

(* Why3 assumption *)
Inductive only_K: term -> Prop :=
  | only_K_K : (only_K K)
  | only_K_App : forall (t1:term) (t2:term), (only_K t1) -> ((only_K t2) ->
      (only_K (App t1 t2))).

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 5; admit.
Hint Constructors infix_mnmngt.
Hint Constructors relTR.
Hint Constructors only_K.

(* Why3 goal *)
Theorem only_K_reduces : forall (t:term), (only_K t) -> exists v:term, (relTR
  t v) /\ ((is_value v) /\ (only_K v)).
(* Why3 intros t h1. *)

induction t; auto.
(* S *)
inversion 1.
(* K *)
intros _; exists K; intuition.
simpl; auto.
(* App *)
inversion_clear 1.
destruct (IHt1 H0) as (v1, (hv11,(hv12,hv13))). clear IHt1.
destruct (IHt2 H1) as (v2, (hv21,(hv22,hv23))). clear IHt2.

destruct v1.
inversion hv13.
destruct v2.
inversion hv23.
exists (App K K); intuition; auto.
apply relTR_transitive with (App K t2); auto.
apply red_star_left; auto.
apply red_star_right; auto.

exists (App K (App v2_1 v2_2)); intuition.
apply relTR_transitive with (App K t2); auto.
apply red_star_left; auto.
apply red_star_right; auto.

assert (v1_1=K).
destruct v1_1; simpl.
inversion hv13.
inversion H3.
auto.
destruct v1_1_1.
inversion hv13.
inversion H3.
inversion H7.
inversion hv12.
inversion hv12.

subst v1_1.
exists v1_2; intuition.
apply StepTransRefl with (App (App K v1_2) v2); auto.
apply relTR_transitive with (App (App K v1_2) t2); auto.
ae.
ae.
apply (red_K Hole); auto.
ae.
inversion hv13; auto.
Admitted.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L.Datatypes Require Export List_enc LBool.

Set Default Proof Using "Type".

Section forallb.
  Variable (X : Type).
  Context (H : registered X).

  Definition c__forallb := 15.
  Definition forallb_time (fT : X -> nat) (l : list X) := sumn (map (fun elm => fT elm + c__forallb) l) + c__forallb.

  Global Instance term_forallb : computableTime' (@forallb X) (fun f fT => (1, fun l _ => (forallb_time (callTime fT) l, tt))).
  Proof.
    extract.
    solverec.
    all: unfold forallb_time, c__forallb; solverec.
  Defined.

  Lemma forallb_time_eq f (l:list X):
    forallb_time f l = sumn (map f l) + length l * c__forallb + c__forallb.
  Proof.
    induction l as [ | x l IH];cbn -[c__forallb]. lia. unfold forallb_time in IH. nia.
  Qed.

  Lemma forallb_time_const c (l:list X):
    forallb_time (fun _ =>  c) l = length l * (c+c__forallb) + c__forallb.
  Proof.
    induction l as [ | x l IH];cbn -[c__forallb]. lia. unfold forallb_time in IH; nia.
  Qed.
End forallb.

  Section foldl_time.
  Context {X Y : Type}.
  Context {H : registered X}.
  Context {F : registered Y}.

  Definition c__fold_left := 15.
  Definition c__fold_left2 := 5.
  Fixpoint fold_left_time (f : X -> Y -> X) (t__f : X -> Y -> nat) (l : list Y) (acc : X) :=
  (match l with
      | [] =>c__fold_left
      | (l :: ls) => t__f acc l + c__fold_left + fold_left_time f t__f ls (f acc l)
      end ).

  Global Instance term_fold_left :
    computableTime' (@fold_left X Y) (fun f fT => (c__fold_left2, fun l _ => (c__fold_left2, fun acc _ => (fold_left_time f (callTime2 fT) l acc, tt)))).
  Proof.
    extract.
    solverec. all: unfold c__fold_left, c__fold_left2; solverec.
  Qed.
End foldl_time.

  Section foldr_time.
  Context {X Y: Type}.
  Context {H:registered X}.
  Context {H0: registered Y}.

  Definition c__fold_right := 15.
  Fixpoint fold_right_time (f : Y -> X -> X) (tf : Y -> X -> nat) (l : list Y) (acc : X) :=
      match l with [] => c__fold_right
              | l::ls => tf l (fold_right f acc ls) + c__fold_right + fold_right_time f tf ls acc
      end.
  Global Instance term_fold_right : computableTime' (@fold_right X Y) (fun f fT => (1, fun acc _ => (1, fun l _ => (fold_right_time f (callTime2 fT) l acc + c__fold_right, tt)))).
  Proof.
    extract. solverec. all: unfold fold_right, c__fold_right; solverec.
  Qed.
End foldr_time.


(** * ITrees as sets of traces *)

(* begin hide *)
From Coq Require Import ProofIrrelevance.

From Paco Require Import
     paco.

From ITree Require Import
     Core.ITreeDefinition
     Eq.Eq
     Eq.UpToTaus
     Eq.SimUpToTaus
     Eq.Shallow
     Eq.Paco2.

Local Open Scope itree.
(* end hide *)

Inductive trace {E : Type -> Type} {R : Type} : Type :=
| TEnd : trace
| TRet : R -> trace
| TEventEnd : forall {X}, E X -> trace
| TEventResponse : forall {X}, E X -> X -> trace -> trace
.

(* Append two traces, ignoring the end of the first trace. *)
Fixpoint app_trace {E R S} (tr1 : @trace E R) (tr2 : @trace E S) : @trace E S :=
  match tr1 with
  | TEventResponse e x tr => TEventResponse e x (app_trace tr tr2)
  | _ => tr2
  end.

(* Get the value in the TRet at the end of the trace, if it exists. *)
Fixpoint trace_ret {E R} (tr : @trace E R) : option R :=
  match tr with
  | TRet r => (Some r)
  | TEventResponse _ _ tr => trace_ret tr
  | _ => None
  end.

Inductive is_traceF {E : Type -> Type} {R : Type} :
  itreeF E R (itree E R) -> @trace E R -> Prop :=
| TraceEmpty : forall t, is_traceF t TEnd
| TraceRet : forall r, is_traceF (RetF r) (TRet r)
| TraceTau : forall t tr,
    is_traceF (observe t) tr ->
    is_traceF (TauF t) tr
| TraceVisEnd : forall X (e : E X) k,
    is_traceF (VisF e k) (TEventEnd e)
| TraceVisContinue : forall X (e : E X) (x : X) k tr,
    is_traceF (observe (k x)) tr ->
    is_traceF (VisF e k) (TEventResponse e x tr)
.

Definition is_trace {E : Type -> Type} {R : Type} (t : itree E R) :=
  is_traceF (observe t).

(* t1 ⊑ t2 *)
Definition trace_incl {E : Type -> Type} {R : Type} :
  itree E R -> itree E R -> Prop :=
  fun t1 t2 =>
    forall tr, is_trace t1 tr -> is_trace t2 tr.

(* t1 ≡ t2 *)
Definition trace_eq {E : Type -> Type} {R : Type} :
  itree E R -> itree E R -> Prop :=
  fun t1 t2 =>
    trace_incl t1 t2 /\ trace_incl t2 t1.

Lemma is_traceF_tau : forall {E R} (t : itree E R) tr,
    is_traceF (observe t) tr <->
    is_traceF (TauF t) tr.
Proof.
  intros. split; intros.
  - constructor. remember (observe t).
    generalize dependent t.
    induction H; intros; subst; constructor; eapply IHis_traceF; auto.
  - inversion H; subst; try constructor; auto.
Qed.

Lemma sutt_trace_incl : forall {E R} (t1 t2 : itree E R),
    sutt eq t1 t2 -> trace_incl t1 t2.
Proof.
  red. intros. red in H0. remember (observe t1).
  generalize dependent t1. generalize dependent t2.
  induction H0; intros; try solve [constructor].
  - punfold H. rewrite <- Heqi in H.
    remember (RetF _). remember (observe t2).
    generalize dependent t2.
    induction H; intros; try inv Heqi0; red; rewrite <- Heqi1; constructor.
    eapply IHsuttF; eauto.
  - apply IHis_traceF with (t1:=t); auto.
    apply sutt_inv_tau_left. red. red in H. rewrite <- Heqi in H. auto.
  - punfold H. rewrite <- Heqi in H.
    remember (VisF _ _). remember (observe t2).
    generalize dependent t2.
    induction H; intros; try discriminate.
    + inv_Vis. subst. red. rewrite <- Heqi1. constructor.
    + red. rewrite <- Heqi1. constructor. eapply IHsuttF; eauto.
  - punfold H. rewrite <- Heqi in H.
    remember (VisF _ _). remember (observe t2).
    generalize dependent t2.
    induction H; intros; try discriminate.
    + inv_Vis. pclearbot. subst. red. rewrite <- Heqi1. constructor.
      eapply IHis_traceF; auto.
    + red. rewrite <- Heqi1. constructor. apply IHsuttF; auto.
Qed.

Lemma eutt_trace_eq : forall {E R} (t1 t2 : itree E R),
    t1 ≈ t2 -> trace_eq t1 t2.
Proof.
  split.
  - apply sutt_trace_incl; apply eutt_sutt; auto.
  - symmetry in H. apply sutt_trace_incl; apply eutt_sutt; auto.
Qed.

Lemma eq_trace_inv {E R} (t1 t2 : @trace E R) (H : t1 = t2)
  : match t1, t2 with
    | TEnd, TEnd => True
    | TRet r1, TRet r2 => r1 = r2
    | TEventEnd e1, TEventEnd e2 => exists p, eqeq E p e1 e2
    | TEventResponse e1 x1 t1, TEventResponse e2 x2 t2 =>
      exists p, eqeq E p e1 e2 /\ eqeq (fun X => X) p x1 x2 /\ t1 = t2
    | _, _ => False
    end.
Proof.
  destruct H, t1; auto.
  - exists eq_refl; cbn; auto.
  - exists eq_refl; cbn; auto.
Qed.

Lemma trace_incl_sutt : forall {E R} (t1 t2 : itree E R),
    trace_incl t1 t2 -> sutt eq t1 t2.
Proof.
  intros E R. pcofix CIH. pstep. intros t1 t2 Hincl.
  unfold trace_incl in *. unfold is_trace in *.
  destruct (observe t1).
  - assert (H : is_traceF (RetF r0 : itreeF E R (itree E R)) (TRet r0)) by constructor.
    apply Hincl in H. clear Hincl. destruct (observe t2); inv H.
    + constructor. auto.
    + constructor.
      remember (observe t). remember (TRet _).
      generalize dependent t.
      induction H1; intros; try inv Heqt0; auto.
      constructor. eapply IHis_traceF; eauto.
  - constructor. right. apply CIH. intros. apply Hincl. constructor. auto.
  - assert (H: is_traceF (VisF e k) (TEventEnd e)) by constructor.
    apply Hincl in H. destruct (observe t2); inv H.
    + constructor.
      assert (forall tr, is_traceF (VisF e k) tr -> is_traceF (observe t) tr).
      {
        intros. rewrite is_traceF_tau. apply Hincl; auto.
      }
      clear Hincl. rename H into Hincl.
      remember (observe t). remember (TEventEnd _).
      generalize dependent t.
      induction H1; intros; try discriminate.
      * constructor. eapply IHis_traceF; eauto.
        intros. rewrite is_traceF_tau. apply Hincl; auto.
      * apply eq_trace_inv in Heqt0; destruct Heqt0 as [<- <-].
        subst. constructor. intro. right. apply CIH. intros.
        assert (is_traceF (VisF e k) (TEventResponse e x tr)) by (constructor; auto).
        apply Hincl in H1. inv H1.
        apply inj_pair2 in H5; apply inj_pair2 in H7; subst; auto.
    + apply inj_pair2 in H2; apply inj_pair2 in H5. subst. constructor. intro. right. apply CIH. intros.
      assert (is_traceF (VisF e k) (TEventResponse e x tr)) by (constructor; auto).
      apply Hincl in H0. inv H0. apply inj_pair2 in H5; apply inj_pair2 in H7. subst. auto.
Qed.

Theorem trace_incl_iff_sutt : forall {E R} (t1 t2 : itree E R),
    sutt eq t1 t2 <-> trace_incl t1 t2.
Proof.
  split.
  - apply sutt_trace_incl.
  - apply trace_incl_sutt.
Qed.

Lemma trace_eq_eutt : forall {E R} (t1 t2 : itree E R),
    trace_eq t1 t2 -> t1 ≈ t2.
Proof.
  intros E R t1 t2 [? ?]. apply sutt_eutt.
  - apply trace_incl_sutt; auto.
  - apply trace_incl_sutt in H0. clear H.
    generalize dependent t1. generalize dependent t2. pcofix CIH; pstep; intros.
    punfold H0. induction H0; constructor; try red; pclearbot; eauto with paco.
    right. rewrite itree_eta'. eauto with paco.
Qed.

Theorem trace_eq_iff_eutt : forall {E R} (t1 t2 : itree E R),
    t1 ≈ t2 <-> trace_eq t1 t2.
Proof.
  split.
  - apply eutt_trace_eq.
  - apply trace_eq_eutt.
Qed.

Inductive event (E : Type -> Type) : Type :=
| Event : forall {X}, E X -> X -> event E
.

(* [step_ ev t' t] if [t] steps to [t'] (read right to left!)
   with visible event [ev]. *)
Inductive step_ {E : Type -> Type} {R : Type}
          (ev : event E) (t' : itree E R) :
  itree E R -> Prop :=
| StepTau : forall t, step_ ev t' t -> step_ ev t' (Tau t)
| StepVis : forall X (e : E X) (x : X) k,
    ev = Event _ e x ->
    t' = k x ->
    step_ ev t' (Vis e k)
.

Definition step {E : Type -> Type} {R : Type}
           (ev : event E) (t t' : itree E R) : Prop :=
  step_ ev t' t.

CoInductive simulates {E : Type -> Type} {R : Type} :
  itree E R -> itree E R -> Prop :=
| SimStep : forall t1 t2,
    (forall ev t1',
        step ev t1 t1' ->
        exists t2', step ev t2 t2' /\ simulates t1' t2') ->
    simulates t1 t2.

Theorem simulates_trace_incl {E : Type -> Type} {R : Type} :
  forall t1 t2 : itree E R,
    simulates t1 t2 -> trace_incl t1 t2.
Proof.
Abort.

(* Set-of-traces monad *)
Definition traces (E : Type -> Type) (R : Type) : Type :=
  @trace E R -> Prop.

Definition bind_traces {E : Type -> Type} {R S : Type}
           (ts : traces E R) (kts : R -> traces E S) : traces E S :=
  fun tr =>
    (tr = TEnd /\ ts TEnd) \/
    (exists X (e : E X), tr = TEventEnd e /\ ts (TEventEnd e)) \/
    (exists r tr1 tr2,
        tr = app_trace tr1 tr2 /\
        trace_ret tr1 = Some r /\
        ts tr1 /\
        kts r tr).

Definition ret_traces {E : Type -> Type} {R : Type} :
  R -> traces E R :=
  fun r tr =>
    tr = TEnd \/ tr = TRet r.


(************************************************************
* Lambda-calculus with exceptions and sums,                 *
* Small-step semantics                                      *
*************************************************************)

Set Implicit Arguments.
Require Export LambdaExnSum_Syntax LibRelation.

Implicit Types v : val.
Implicit Types t : trm.

(* TODO move *)

CoInductive infclosure A (R:binary A) : A -> Prop :=
  | infclosure_step : forall y x,
      R x y -> infclosure R y -> infclosure R x.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Reduction contexts *)

(** Grammar of contexts *)

Inductive ctx :=
  | ctx_hole : ctx
  | ctx_app_1 : ctx -> trm -> ctx
  | ctx_app_2 : val -> ctx -> ctx
  | ctx_case : ctx -> trm -> trm -> ctx
  | ctx_inj : bool -> ctx -> ctx
  | ctx_try : ctx -> trm -> ctx
  | ctx_raise : ctx -> ctx.

Implicit Types c : ctx.

(** Application of contexts *)

Fixpoint ctx_apply c t :=
  let r c' := ctx_apply c' t in
  match c with
  | ctx_hole => t
  | ctx_app_1 c' t2 => trm_app (r c') t2
  | ctx_app_2 v1 c' => trm_app v1 (r c')
  | ctx_inj b c' => trm_inj b (r c')
  | ctx_case c' t1 t2 => trm_case (r c') t1 t2
  | ctx_try c' t2 => trm_try (r c') t2
  | ctx_raise c' => trm_raise (r c')
  end.

Coercion ctx_apply : ctx >-> Funclass.

(** Contexts that do not contain [try] construct *)

Fixpoint ctx_notry c :=
  let r := ctx_notry in
  match c with
  | ctx_hole => True
  | ctx_app_1 c' t2 => r c'
  | ctx_app_2 v1 c' => r c'
  | ctx_inj b c' => r c'
  | ctx_case c' t1 t2 => r c'
  | ctx_try c' t2 => False
  | ctx_raise c' => r c'
  end.

(************************************************************)
(* ** Semantics *)

(** Reduction *)

Inductive step : binary trm :=
  | step_ctx : forall c t1 t2,
      step t1 t2 ->
      step (c t1) (c t2)
  | step_exn : forall c v,
      ctx_notry c ->
      step (c (trm_raise v)) (trm_raise v)
  | step_abs : forall x t,
      step (trm_abs x t) (val_abs x t)
  | step_beta : forall x t3 v2,
      step (trm_app (val_abs x t3) v2) (subst x v2 t3)
  | step_try_val : forall v1 t2,
      step (trm_try v1 t2) v1
  | step_try_exn : forall v t2,
      step (trm_try (trm_raise v) t2) (trm_app t2 v)
  | step_inj : forall b v1,
      step (trm_inj b v1) (val_inj b v1)
  | sred_case_true : forall t1 t2 t3 v1,
      step (trm_case (val_inj true v1) t2 t3) (trm_app t2 v1)
  | sred_case_false : forall t1 t2 t3 v1,
      step (trm_case (val_inj false v1) t2 t3) (trm_app t3 v1).

(** Complete evaluation *)

Definition sredstar t t' := (rtclosure step) t t'.

Definition sredplus t t' := (tclosure step) t t'.

Definition sredval t v := sredstar t v.

Definition sdiverge t := (infclosure step) t.

(*==========================================================*)
(* * Proofs *)

Notation "'stepstar'" := (rtclosure step).
Notation "'stepplus'" := (tclosure step).

Hint Constructors step.
Hint Unfold sredval sredstar sredplus.
Hint Resolve rtclosure_once.

Hint Constructors rtclosure infclosure.

(************************************************************)
(* ** Derived reduction rules *)

(** Addition reduction contexts *)

Definition isctx (f:trm->trm) :=
  forall t1 t2, step t1 t2 -> step (f t1) (f t2).

Lemma isctx_ctx : forall c, isctx c.
Proof. intros_all. applys* step_ctx. Qed.

Hint Resolve isctx_ctx.

(** Transitive reduction in contexts *)

Lemma stepstar_ctx : forall f t1 t2,
  isctx f ->
  stepstar t1 t2 ->
  stepstar (f t1) (f t2).
Proof. introv C R. induction* R. Qed.

(************************************************************)
(* ** Equivalence with pretty-big-step semantics *)

Require Export LambdaExnSum_Pretty.

(* todo: move *)

Definition ext_not_diverge e :=
  let n o := o <> out_div in
  match e with
  | ext_trm _ => True
  | ext_app_1 o1 t2 => n o1
  | ext_app_2 v1 o2 => n o2
  | ext_inj_1 b o1 => n o1
  | ext_case_1 o1 t2 t3 => n o1
  | ext_try_1 o1 t2 => n o1
  | ext_raise_1 o1 => n o1
  end.

Hint Unfold ext_not_diverge.

Lemma red_not_div : forall e o,
  red e o -> ext_not_diverge e -> o <> out_div.
Admitted.

Hint Resolve red_not_div.

Instance trm_inhab : Inhab trm.
Proof. applys Inhab_of_val (trm_val (val_int 0)). Qed.

Definition trm_of_out o : trm :=
  match o with
  | out_ret v => v
  | out_exn v => trm_raise v
  | out_div => arbitrary
  end.

Definition trm_of_ext e : trm :=
  let r := trm_of_out in
  match e with
  | ext_trm t => t
  | ext_app_1 o1 t2 => trm_app (r o1) t2
  | ext_app_2 v1 o2 => trm_app v1 (r o2)
  | ext_inj_1 b o1 => trm_inj b (r o1)
  | ext_case_1 o1 t2 t3 => trm_case (r o1) t2 t3
  | ext_try_1 o1 t2 => trm_try (r o1) t2
  | ext_raise_1 o1 => trm_raise (r o1)
  end.

Hint Unfold ctx_notry.

Section Equiv.

Tactic Notation "applys_simpl" constr(E) :=
  let M := fresh "TEMP" in
  lets M: E; simpl in M; applys M; clear M.

Tactic Notation "applys_simpl" "~" constr(E) :=
  applys_simpl E; auto_tilde.
Tactic Notation "applys_simpl" "*" constr(E) :=
  applys_simpl E; auto_star.

(** [sredval] to [red] *)

Lemma sredval_red : forall t v,
  sredval t v -> red t v.
Proof. skip. Qed.

(** [red] to [sredval] *)

Lemma red_sredstar : forall e o,
  red e o -> ext_not_diverge e -> sredstar (trm_of_ext e) (trm_of_out o).
Proof.
  introv R. induction R; introv N; simpls.
  auto.
  auto.
  applys rtclosure_trans; [ | applys* IHR2].
   applys* stepstar_ctx (ctx_app_1 ctx_hole t2).
  inverts H; tryfalse. simpl. applys rtclosure_once.
   applys~ step_exn (ctx_app_1 ctx_hole t2).
  applys rtclosure_trans; [ | applys* IHR2].
   applys* stepstar_ctx (ctx_app_2 v1 ctx_hole).
  inverts H; tryfalse. simpl. applys rtclosure_once.
   applys~ step_exn (ctx_app_2 v1 ctx_hole).
  applys rtclosure_trans; [ | applys* IHR].
   applys* rtclosure_once.
  applys rtclosure_trans; [ | applys* IHR2].
   applys* stepstar_ctx (ctx_inj b ctx_hole).
  inverts H; tryfalse. simpl. applys rtclosure_once.
   applys~ step_exn (ctx_inj b ctx_hole).
  auto.
  applys rtclosure_trans; [ | applys* IHR2].
   applys* stepstar_ctx (ctx_case ctx_hole t2 t3).
  inverts H; tryfalse. simpl. applys rtclosure_once.
   applys~ step_exn (ctx_case ctx_hole t2 t3).
  applys rtclosure_trans; [ | applys* IHR].
   applys rtclosure_once. simple*.
  applys rtclosure_trans; [ | applys* IHR].
   applys rtclosure_once. simple*.
  applys rtclosure_trans; [ | applys* IHR2].
   applys* stepstar_ctx (ctx_try ctx_hole t2).
  applys* rtclosure_once.
  applys rtclosure_trans; [ | applys* IHR].
   applys* rtclosure_once.
  false.
  applys rtclosure_trans; [ | applys* IHR2].
   applys* stepstar_ctx (ctx_raise ctx_hole).
  inverts H; tryfalse. simpl. applys rtclosure_once.
   applys~ step_exn (ctx_raise ctx_hole).
  auto.
Qed.

Lemma red_sredval : forall t v,
  red t v -> sredval t v.
Proof. introv R. applys~ red_sredstar R. Qed.

(* TODO

(** [sdiverge] to [diverge] *)

Lemma sdiverge_diverge : forall t,
  sdiverge t -> diverge t.
Proof.
  hint sredval_cored. unfold diverge. cofix IH.
  introv H. inverts H; try solve [constructors*].
Qed.

(** [diverge] to [sdiverge] *)

Lemma diverge_sdiverge : forall t,
  diverge t -> sdiverge t.
Proof.
  hint red_sredval. cofix IH. introv R. inverts R as.
  introv R1 R2. destruct~ (cored_to_diverge_or_red R1).
    apply* sdiverge_app_1.
    inverts R2 as.
      intros. apply~ sdiverge_app_1.
      introv R2 R3. destruct~ (cored_to_diverge_or_red R2).
        apply* sdiverge_app_2.
        inverts R3 as.
          intros. apply* sdiverge_app_2.
          introv R3. apply* sdiverge_app_3.
Qed.
*)

End Equiv.


Require Import List.

Require Import StructTact.StructTactics.
Require Import StructTact.Util.

Require Import Chord.Chord.
Require Import Chord.SystemReachable.

Require Import Chord.SystemLemmas.
Require Import Chord.HandlerLemmas.

Set Bullet Behavior "Strict Subproofs".

Definition nodes_have_state_invariant (gst : global_state) :=
  forall h, In h (nodes gst) ->
       exists st,
         sigma gst h = Some st.
Hint Unfold nodes_have_state_invariant.

Theorem nodes_have_state_preserved :
  forall gst,
    reachable_st gst ->
    nodes_have_state_invariant gst.
Proof using.
  eapply chord_net_invariant; do 2 autounfold; intros;
    repeat find_rewrite;
    repeat (update_destruct; rewrite_update);
      eauto with datatypes.
  simpl in *; break_or_hyp;
    congruence || eauto.
Qed.

Lemma nodes_have_state :
  forall gst h,
    In h (nodes gst) ->
    reachable_st gst ->
    exists st,
      sigma gst h = Some st.
Proof.
  intros.
  now eapply nodes_have_state_preserved.
Qed.
Hint Resolve nodes_have_state.

Lemma only_nodes_have_state :
  forall gst h st,
    sigma gst h = Some st ->
    reachable_st gst ->
    In h (nodes gst).
Proof.
  intros.
  generalize dependent st.
  generalize dependent h.
  pattern gst.
  eapply chord_net_invariant; do 2 autounfold; intros;
    repeat find_rewrite;
    repeat handler_simpl;
    eauto with datatypes.
  inv_prop initial_st.
  break_and.
  destruct (In_dec addr_eq_dec h (nodes gst0)); eauto.
  assert (sigma gst0 h = None) by auto.
  congruence.
Qed.
Hint Resolve only_nodes_have_state.

Lemma in_failed_in_nodes :
  forall gst h,
    reachable_st gst ->
    In h (failed_nodes gst) ->
    In h (nodes gst).
Proof.
  induction 1; intros.
  - unfold initial_st in *.
    intuition; repeat find_rewrite; solve_by_inversion.
  - invcs H0; intuition.
    subst. auto.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_onStakeReject (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Lemma DePoolContract_Ф_onStakeReject_exec : forall ( Л_queryId : XInteger64 )
                                                   ( Л_comment : XInteger32 )
                                                   ( Л_elector : XAddress )
                                                   (l: Ledger) ,
let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound Л_queryId ) ) l in
let req1 : bool := isSome optRound  in
let round := maybeGet optRound in
let req2 : bool := eval_state msg_sender l =?  round ->> RoundsBase_ι_Round_ι_proxy in
let req3 : bool :=  Л_elector =?  round ->> RoundsBase_ι_Round_ι_elector  in
let req4 : bool :=  round ->> RoundsBase_ι_Round_ι_id  =? Л_queryId  in
let req5 : bool :=  eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted in
let round' := {$ round with ( RoundsBase_ι_Round_ι_step , RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest ) ;
                            ( RoundsBase_ι_Round_ι_completionReason , RoundsBase_ι_CompletionReasonP_ι_StakeIsRejectedByElector )
              $} in
let la := exec_state (↓ tvm_accept) l in
let l_setRound := exec_state ( ↓  RoundsBase_Ф_setRound Л_queryId round'  ) la in
let oldEvents := VMState_ι_events ( Ledger_ι_VMState l ) in
let newEvent  := roundStakeIsRejected (( round ->> RoundsBase_ι_Round_ι_validatorRequest ) ->> DePoolLib_ι_Request_ι_queryId) Л_comment in

exec_state (↓ DePoolContract_Ф_onStakeReject Л_queryId Л_comment Л_elector ) l =

if req1 then if req2 then if req3 then if req4 then if req5 then
        {$ l_setRound With ( VMState_ι_events , newEvent :: oldEvents ) $}
else l else l else l else l else l .

Proof.
  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve.

Qed.

Lemma DePoolContract_Ф_onStakeReject_eval : forall ( Л_queryId : XInteger64 )
                                                    ( Л_comment : XInteger32 )
                                                    ( Л_elector : XAddress )
                                                    (l: Ledger) ,
let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound Л_queryId ) ) l in
let req1 : bool := isSome optRound  in
let round := maybeGet optRound in
let req2 : bool := eval_state msg_sender l =?  round ->> RoundsBase_ι_Round_ι_proxy in
let req3 : bool :=  Л_elector =?  round ->> RoundsBase_ι_Round_ι_elector  in
let req4 : bool :=  round ->> RoundsBase_ι_Round_ι_id  =? Л_queryId  in
let req5 : bool :=  eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted in

eval_state (↓ DePoolContract_Ф_onStakeReject Л_queryId Л_comment Л_elector ) l =
if req1 then if req2 then if req3 then if req4 then if req5 then Value I
else Error Errors_ι_INVALID_ROUND_STEP
else Error Errors_ι_INVALID_QUERY_ID
else Error Errors_ι_IS_NOT_ELECTOR
else Error Errors_ι_IS_NOT_PROXY
else Error InternalErrors_ι_ERROR513 .

Proof.

  intros.
  destructLedger l.
  compute.

  Time repeat destructIf_solve.

Qed.

End DePoolContract_Ф_onStakeReject.


Require Import Blech.Defaults.

Require Import Coq.Program.Tactics.

Record prod S := prod_intro {
  prod_s: Type ;
  prod_π: prod_s → S ;
}.

Arguments prod_intro {S prod_s}.
Arguments prod_s {S}.
Arguments prod_π {S}.

Record sum S := sum_intro {
  sum_s: Type ;
  sum_π: sum_s → S ;
}.

Arguments sum_intro {S sum_s}.
Arguments sum_s {S}.
Arguments sum_π {S}.

Coercion sum_s: sum >-> Sortclass.
Coercion sum_π: sum >-> Funclass.

Coercion prod_s: prod >-> Sortclass.
Coercion prod_π: prod >-> Funclass.

Module Import PowerNotations.
  Notation "'Π' x , P" := (prod_intro (λ x, P)) (at level 200, x ident).
  Notation "'Π' x : A , P" := (prod_intro (λ x: A, P)) (at level 200, x ident).
  Notation "'Π' ( x : A ) , P" := (prod_intro (λ x: A, P)) (at level 200, x ident).

  Notation "'Σ' x , P" := (sum_intro (λ x, P)) (at level 200, x ident).
  Notation "'Σ' x : A , P" := (sum_intro (λ x: A, P)) (at level 200, x ident).
  Notation "'Σ' ( x : A ) , P" := (sum_intro (λ (x: A), P)) (at level 200, x ident).
End PowerNotations.

(* I think ? *)
#[program]
Definition sum_map {A B} (f: B → A) (p: sum A): sum B :=
  Σ (x: {y: B | ∃ x, f y = p x }), x.

#[program]
Definition prod_map {A B} (f: B → A) (p: prod A): prod B :=
  Π (x: {y: B | ∃ x, f y = p x }), x.

Definition poly S := sum (prod S).

(* Vaguely makes sense I think ? *)
Definition pure {A} (x: A): poly A := Σ (i: {y: prod A | y = Π (j: {y| y = x}), proj1_sig j}), proj1_sig i.

Definition map {A B} (f: A → B): poly A → poly B := sum_map (prod_map f).

(* Not at all sure here *)
Definition counit {A} (x: A): prod (sum A) :=
Π (i: {y: sum A | y = Σ (j: {y| y = x}), proj1_sig j}), proj1_sig i.

(* Probably wrong *)
Definition join {A} (p: poly (poly A)): poly A := sum_map counit p.