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

(* $Date: 2012-04-05 13:02:28 -0400 (Thu, 05 Apr 2012) $ *)

Require Export 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 for some applications.  Consider the variant of Imp with
    lists that we introduced in ImpList.v.  We chose to define the
    meaning of programs like [0 + nil] by specifying that a list
    should be interpreted as [0] when it occurs in a context expecting
    a number, but this was a bit of a hack.  It would be better simply
    to say that the behavior of such a program is _undefined_ -- it
    doesn't evaluate to any result.  We could easily do this: we'd
    just have to use the formulations of [aeval] and [beval] as
    inductive propositions (rather than Fixpoints), so that we can
    make them partial functions instead of total ones.

    However, this way of defining Imp has 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 taking the successor of a boolean variable, 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
  | P : tm -> tm -> tm.

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "C" | Case_aux c "P" ].

Module SimpleArith0.

(** 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 eval (t : tm) : nat :=
  match t with
  | C n => n
  | P a1 a2 => eval a1 + eval a2
  end.

End SimpleArith0.

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

Tactic Notation "eval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Const" | Case_aux c "E_Plus" ].

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'
*)
(** Note that we're using variable naming conventions here to lighten
    the notation: by convention, [n1] and [n2] refer only to
    constants (constructed with [C]), while [t1] and [t2] refer
    to arbitrary terms.  In the formal rules, we use explicit
    constructors to make the same distinction. *)

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

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_PlusConstConst"
  | Case_aux c "ST_Plus1" | Case_aux c "ST_Plus2" ].

(** A couple of examples of reasoning with the [step]
    relation... *)

(** If [t1] can take a step to [t1'], then [P t1 t2] steps
    to [plus 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: 2 stars (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.
  apply ST_Plus2. apply ST_Plus2. apply ST_PlusConstConst.
Qed.
(** [] *)

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

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

End SimpleArith1.

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

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

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_PlusConstConst"
  | Case_aux c "ST_Plus1" | Case_aux c "ST_Plus2" ].

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

    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. *)
Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Theorem step_deterministic :
  deterministic step.
Proof.
  unfold deterministic. intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  step_cases (induction Hy1) Case; intros y2 Hy2.
  Case "ST_PlusConstConst".
      step_cases (inversion Hy2) SCase.
      SCase "ST_PlusConstConst". reflexivity.
      SCase "ST_Plus1". inversion H2.
      SCase "ST_Plus2". inversion H3.
  Case "ST_Plus1".
      step_cases (inversion Hy2) SCase.
      SCase "ST_PlusConstConst". rewrite <- H0 in Hy1. inversion Hy1.
      SCase "ST_Plus1". apply IHHy1 in H2. rewrite H2. reflexivity.
      SCase "ST_Plus2". inversion H1. rewrite <- H4 in Hy1. inversion Hy1.
  Case "ST_Plus2".
      step_cases (inversion Hy2) SCase.
      SCase "ST_PlusConstConst". rewrite <- H2 in Hy1. inversion Hy1.
      SCase "ST_Plus1". inversion H. rewrite <- H4 in H3. inversion H3.
      SCase "ST_Plus2". apply IHHy1 in H4. subst. reflexivity.
Qed.
(** [] *)

(* ########################################################### *)
(** ** 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_): For all [t:tm], 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.
  tm_cases (induction t) Case.
    Case "C". left. apply v_const.
    Case "P". right. inversion IHt1.
      SCase "l". inversion IHt2.
        SSCase "l". inversion H. inversion H0.
          exists (C (n + n0)).
          apply ST_PlusConstConst.
        SSCase "r". inversion H0 as [t' H1].
          exists (P t1 t').
          apply ST_Plus2. apply H. apply H1.
      SCase "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: they are exactly the terms that
    _cannot_ make progress in this sense.  To state this fact, 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 t,
  value t -> normal_form step t.
Proof.
  unfold normal_form. intros t 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').
    SCase "Proof of assertion". apply strong_progress.
  inversion G.
    SCase "l". apply H0.
    SCase "r". apply ex_falso_quodlibet. 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?  For two reasons:

    - Because [value] is a syntactic concept -- it is a 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, there are lots of languages in which the concepts of
      normal form and value do _not_ coincide. *)

(** Let's examine how this can happen... *)

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

(** 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, optional (value_not_same_as_normal_form) *)
Lemma value_not_same_as_normal_form :
  exists t, value t /\ ~ normal_form step t.
Proof.
  exists (P (C 1) (C 2)).
  split.
  Case "left".
      constructor.
  Case "right".
      intros contra.
      unfold normal_form in contra.
      apply contra.
      exists (C 3).
      constructor.
Qed.
(** [] *)

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, optional (value_not_same_as_normal_form) *)
Lemma value_not_same_as_normal_form :
  exists t, value t /\ ~ normal_form step t.
Proof.
  exists (C 1).
  split.
  Case "left".
      constructor.
  Case "right".
      intros contra.
      unfold normal_form in contra.
      apply contra.
      exists (P (C 1) (C 0)).
      constructor.
Qed.
(** [] *)

End Temp2.

(* ########################################################### *)
(** Finally, we might mistakenly 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_. *)

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 (value_not_same_as_normal_form') *)
Lemma value_not_same_as_normal_form :
  exists t, ~ value t /\ normal_form step t.
Proof.
  exists (P (C 1) (P (C 3) (C 2))).
  split.
  Case "left".
      intros contra.
      inversion contra.
  Case "right".
      unfold normal_form.
      intros contra.
      inversion contra.
      inversion H.
      inversion H3.
Qed.
(** [] *)

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 :=
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm.

Inductive value : tm -> Prop :=
  | v_true : value tm_true
  | v_false : value tm_false.

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

Inductive step : tm -> tm -> Prop :=
  | ST_IfTrue : forall t1 t2,
      tm_if tm_true t1 t2 ==> t1
  | ST_IfFalse : forall t1 t2,
      tm_if tm_false t1 t2 ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tm_if t1 t2 t3 ==> tm_if 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 :=
  tm_false ==> tm_false.

Theorem bsp1:
  ~bool_step_prop1.
Proof.
  intros contra.
  unfold bool_step_prop1 in contra.
  inversion contra.
Qed.

Definition bool_step_prop2 :=
     tm_if
       tm_true
       (tm_if tm_true tm_true tm_true)
       (tm_if tm_false tm_false tm_false)
  ==>
     tm_true.

Theorem bsp2:
  ~bool_step_prop2.
Proof.
  intros contra.
  unfold bool_step_prop2 in contra.
  inversion contra.
Qed.

Definition bool_step_prop3 :=
     tm_if
       (tm_if tm_true tm_true tm_true)
       (tm_if tm_true tm_true tm_true)
       tm_false
   ==>
     tm_if
       tm_true
       (tm_if tm_true tm_true tm_true)
       tm_false.

Theorem bsp3:
  bool_step_prop3.
Proof.
  unfold bool_step_prop3.
  apply ST_If.
  apply ST_IfTrue.
Qed.
(** [] *)

(** **** Exercise: 3 stars, recommended (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.
  intros t.
  induction t.
  Case "tm_true".
      left. constructor.
  Case "tm_false".
      left. constructor.
  Case "tm_if".
      right. inversion IHt1 as [HL| HR].
      destruct t1.
      SCase "tm_true".
          exists t2. apply ST_IfTrue.
      SCase "tm_false".
          exists t3. apply ST_IfFalse.
      SCase "tm_if".
          inversion HL.
      inversion HR.
      destruct x.
      SCase "tm_true".
          exists (tm_if tm_true t2 t3). apply ST_If. assumption.
      SCase "tm_false".
          exists (tm_if tm_false t2 t3). apply ST_If. assumption.
      SCase "tm_if".
          exists (tm_if (tm_if x1 x2 x3) t2 t3). apply ST_If.
          assumption.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (step_deterministic) *)
Theorem step_deterministic :
  deterministic step.
Proof.
  unfold deterministic. intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction x; intros y2 Hy2.
  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
    [tm_true] or [tm_false]) 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:
         tm_if
            (tm_if tm_true tm_true tm_true)
            tm_false
            tm_false
     ==>
         tm_false.
*)

(** 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,
      tm_if tm_true t1 t2 ==> t1
  | ST_IfFalse : forall t1 t2,
      tm_if tm_false t1 t2 ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tm_if t1 t2 t3 ==> tm_if t1' t2 t3
  | ST_IfShort : forall t1 v,
      value v ->
      tm_if t1 v v ==> v

  where " t '==>' t' " := (step t t').
(** [] *)

Definition bool_step_prop4 :=
         tm_if
            (tm_if tm_true tm_true tm_true)
            tm_false
            tm_false
     ==>
         tm_false.

Example bool_step_prop4_holds :
  bool_step_prop4.
Proof.
  unfold bool_step_prop4.
  apply ST_IfShort.
  constructor.
Qed.
(** [] *)

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

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

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

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

    First, a _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- that is, it is a
    proposition about a pair of elements of [X]. *)

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

(** Now, given a relation [R], we define a relation [multi 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.

(** The effect of this definition is that [multi R] relates two
    elements [x] and [y] of [X] if either [x = y] or else there is
    some (possibly empty) sequence [z1], [z2], ..., [zn] such that:
      R x z1
      R z1 z2
      ...
      R zn y
*)

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

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.

(** The crucial properties of the [multi R] relation are
       - [multi R] is reflexive
       - [multi R] is transitive
       - [multi R] relates everything related by [R] *)

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.
  multi_cases (induction G) Case.
    Case "multi_refl". assumption.
    Case "multi_step".
      apply multi_step with y. assumption.
      apply IHG. assumption.  Qed.

(** We now 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. *)

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

(* ########################################################### *)
(** ** 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.
  apply (multi_refl step).
Qed.
(** [] *)

(** **** Exercise: 1 star, optional (test_multistep_3) *)
Lemma test_multistep_3:
      P (C 0) (C 3)
   ==>*
      P (C 0) (C 3).
Proof.
  apply (multi_refl step).
Qed.
(** [] *)

(** **** 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.
  eapply multi_step.
  apply ST_Plus2.
  constructor.
  eapply ST_Plus2.
  constructor.
  apply ST_PlusConstConst.
  eapply multi_step.
  apply ST_Plus2.
  constructor.
  apply ST_PlusConstConst.
  apply multi_refl.
Qed.
(** [] *)

(* ########################################################### *)
(** ** 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 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 (test_multistep_5) *)
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. multi_cases (induction H) Case.
    Case "multi_refl". apply multi_refl.
    Case "multi_step". apply multi_step with (P y t2).
        apply ST_Plus1. apply H.
        apply IHmulti.  Qed.

(** **** Exercise: 2 stars *)
Lemma multistep_congr_2 : forall t1 t2 t2',
     value t1 ->
     t2 ==>* t2' ->
     P t1 t2 ==>* P t1 t2'.
Proof.
  intros t1 t2 t2' H1 H2.
  multi_cases (induction H2) Case.
  Case "multi_refl".
      apply multi_refl.
  Case "multi_step".
      apply multi_step with (P t1 y).
      apply ST_Plus2.
      assumption. assumption.
      apply IHmulti.
Qed.
(** [] *)

(** _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.
  tm_cases (induction t) Case.
    Case "C".
      exists (C n).
      split.
      SCase "l". apply multi_refl.
      SCase "r".
        (* We can use [rewrite] with "iff" statements, not
           just equalities: *)
        rewrite nf_same_as_value. apply v_const.
    Case "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.
        SCase "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.
        SCase "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 to you. *)

(** **** 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 t n H.
  induction H.
  Case "multi_refl".
      apply multi_refl.
  Case "multi_step".
      assert (P t1 t2 ==>* P (C n1) t2).
      SCase "Proof of assertion".
          apply multistep_congr_1 with (t1':=(C n1)) (t1:=t1) (t2:=t2).
          assumption.
      assert (P (C n1) t2 ==>* P (C n1) (C n2)).
      SCase "Proof of assertion".
          apply multistep_congr_2.
          constructor. assumption.
      assert (P (C n1) (C n2) ==>* C (n1 + n2)).
      SCase "Proof of assertion".
          eapply multi_step.
          apply ST_PlusConstConst.
          apply multi_refl.
      eapply multi_trans.
      eapply multi_trans.
      apply H1. apply H2. apply H3.
Qed.
(** [] *)

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

_Theorem_: if the term [t] evaluates to number [n], then by using
multistep reduction, [t] will be reduced to [C n].

_Proof_: By induction on [t || n], [t || n] either has the form of
         [C n || n], or [P t1 t2 || C (n1 + n2)].
         - Suppose [t] has the form [C n]. We need to prove
           [C n ==>* C n], which is immediate from the definition of
           [multistep_refl].
         - Suppose [t] has the form [P t1 t2 || C (n1 + n2)], where
           [t1 || C n1], [t2 || C n2], and [t1 ==>* C n1], [t2 ==>* C n2],
           we need to prove [P t1 t2 ==>* C (n1 + n2)].

           By using [multistep_congr_1], we can show that from
           [t1 ==>* C n1], [P t1 t2 ==>* P (C n1) t2] as [Assert1].

           By using [multistep_congr_2], we can show that from
           [t2 ==>* C n2], [P (C n1) t2 ==>* P (C n1) (C n2)]
           as [Assert2].

           In order to show [P (C n1) (C n2) ==>* C (n1 + n2)] as
           [Assert3],
           we first show [P (C n1) (C n2) ==> C (n1 + n2)] by using
           [ST_PlusConstConst], then with the help of [multi_refl],
           [ C (n1 + n2) ==>* C (n1 + n2)] is immediate. With the
           above two together and [multi_step], we can get
           [P (C n1) (C n2) ==>* C (n1 + n2)].

           By using [multi_trans] twice and together with [Assert1],
           [Assert2], and [Assert3], we can show
           [ P t1 t2 ==>* C (n1 + n2)].
[]
*)

(** For the other direction of the correspondence, we need one lemma,
    which establishes a relation between single-step reduction and
    big-step evaluation. *)

(** **** Exercise: 3 stars (step__eval) *)
Theorem step__eval : forall t t' n,
     t ==> t' ->
     t' || n ->
     t || n.
Proof.
  intros t t' n Hs. generalize dependent n.
  step_cases (induction Hs) Case.
  Case "ST_PlusConstConst".
      intros. inversion H.
      constructor. constructor. apply E_Const.
  Case "ST_Plus1".
      intros. inversion H. apply E_Plus.
      apply IHHs. assumption. assumption.
  Case "ST_Plus2".
      intros. inversion H0. apply E_Plus.
      assumption. apply IHHs. assumption.
Qed.
(** [] *)

(** The main theorem is now straightforward to prove, once it is
    stated correctly. The proof proceeds by induction on the
    multipstep reduction sequence that is buried in the hypothesis
    [normal_form_of t v]. *)
(** Make sure you understand the statement before you start to
    work on the proof.  *)

(** **** Exercise: 3 stars (multistep__eval) *)
Theorem multistep__eval : forall t v,
  normal_form_of t v -> exists n, v = C n /\ t || n.
Proof.
  intros t v Hn.
  inversion Hn as [HL HR].
  multi_cases (induction HL) Case.
  Case "multi_refl".
      tm_cases (destruct x) SCase.
      SCase "C".
          exists n. split. reflexivity. constructor.
      SCase "P".
          apply nf_is_value in HR. inversion HR.
  Case "multi_step".
      assert (normal_form_of y z).
      SCase "Proof of Assertion".
          unfold normal_form_of.
          split. assumption. assumption.
      apply IHHL in H0.
      inversion H0. inversion H1.
      exists x0.
      split.
          assumption.
          apply step__eval with y. assumption. assumption.
      assumption.
Qed.
(** [] *)

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

(** **** 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
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm.

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "C" | Case_aux c "P"
  | Case_aux c "tm_true" | Case_aux c "tm_false" | Case_aux c "tm_if" ].

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

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,
      tm_if tm_true t1 t2 ==> t1
  | ST_IfFalse : forall t1 t2,
      tm_if tm_false t1 t2 ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tm_if t1 t2 t3 ==> tm_if t1' t2 t3

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

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_PlusConstConst"
  | Case_aux c "ST_Plus1" | Case_aux c "ST_Plus2"
  | Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

(** 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 for the combined language. *)

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

Theorem step_deterministic :
  deterministic step.
Proof.
  unfold deterministic. intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  step_cases (induction Hy1) Case; intros y2 Hy2.
  Case "ST_PlusConstConst".
      inversion Hy2.
      SCase "ST_PlusConstConst". reflexivity.
      SCase "ST_Plus1". inversion H2.
      SCase "ST_Plus2". inversion H3.
  Case "ST_Plus1".
      inversion Hy2.
      SCase "ST_PlusConstConst". rewrite <- H0 in Hy1. inversion Hy1.
      SCase "ST_Plus1". rewrite <- (IHHy1 t1'0). reflexivity. assumption.
      SCase "ST_Plus2". inversion H1; rewrite <- H4 in Hy1; inversion Hy1.
  Case "ST_Plus2".
      inversion Hy2.
      SCase "ST_PlusConstConst". rewrite <- H2 in Hy1. inversion Hy1.
      SCase "ST_Plus1". inversion H; rewrite <- H4 in H3; inversion H3.
      SCase "ST_Plus2". apply IHHy1 in H4. subst. reflexivity.
  Case "ST_IfTrue".
      inversion Hy2. reflexivity. inversion H3.
  Case "ST_IfFalse".
      inversion Hy2. reflexivity. inversion H3.
  Case "ST_If".
      inversion Hy2.
      SCase "ST_IfTrue". rewrite <- H0 in Hy1. inversion Hy1.
      SCase "ST_IfFalse". rewrite <- H0 in Hy1. inversion Hy1.
      SCase "ST_If". apply IHHy1 in H3. subst. reflexivity.
Qed.

Theorem strong_progress : exists t,
  ~(value t \/ (exists t', t ==> t')).
Proof.
  exists (P (C 1) tm_true).
  intros contra.
  inversion contra. inversion H.
  inversion H. inversion H0. inversion H4. inversion H5.
Qed.
(** [] *)

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

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 (ble_nat 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').

(** Notice that we didn't actually bother to define boolean
    values -- they aren't needed in the definition of [==>b] (why?),
    though they might be if our language were a bit larger. *)

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

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

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

Notation "'SKIP'" :=
  CSkip.
Notation "l '::=' a" :=
  (CAss l a) (at level 60).
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
Notation "'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 / (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 / (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 update; reflexivity.

  rename x into st.
  inversion H as [H' [HX HY]]; clear H.
  exists (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 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 update_neq. assumption. reflexivity.
Qed.

End CImp.


(** * LogRel.TypeUniqueness: all types for a term are convertible. *)
From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction
  GenericTyping DeclarativeTyping DeclarativeInstance AlgorithmicTyping
  BundledAlgorithmicTyping AlgorithmicTypingProperties.

Import DeclarativeTypingProperties AlgorithmicTypingData BundledTypingData AlgorithmicTypingProperties.

Section AlgorithmicUnique.

  Lemma algo_typing_unique : AlgoTypingInductionConcl
    (fun Γ A => True)
    (fun Γ A t => forall A', [Γ |-[al] t ▹ A'] -> A' = A)
    (fun Γ A t => forall A', [Γ |-[al] t ▹h A'] -> ∑ A'', [A'' ⇒* A] × [A'' ⇒* A'])
    (fun Γ A t => True).
  Proof.
    apply AlgoTypingInduction.
    all: try easy.
    all: try solve [intros ** ; match goal with H : context [al] |- _ => now inversion H end].
    - intros * ? * Hty'.
      inversion Hty' ; subst.
      now eapply in_ctx_inj.
    - intros * _ _ _ IHt ? Hty'.
      inversion Hty' ; subst ; refold.
      now erewrite <- IHt.
    - intros * _ IHf _ _ ? Hty'.
      inversion Hty' ; subst ; refold.
      eapply IHf in H3 as [? [Hred Hred']].
      eapply whred_det in Hred ; tea.
      2-3: gen_typing.
      now inversion Hred.
    - intros * _ IHt ? ? Hty'.
      inversion Hty' ; subst ; refold.
      eapply IHt in H0 as ->.
      now eexists.
  Qed.

End AlgorithmicUnique.

Corollary typing_unique Γ T T' t :
  [Γ |-[de] t : T] ->
  [Γ |-[de] t : T'] ->
  [Γ |-[de] T ≅ T'].
Proof.
  intros [_ Ti Hty]%algo_typing_complete [_ Ti' Hty']%algo_typing_complete.
  eapply algo_typing_unique in Hty ; tea ; subst.
  etransitivity ; tea.
  now symmetry.
Qed.


Require Import Clight.
Require Import Ctypes.
Require Import veric.expr.
Require Import Integers.
Require Import Floats.
Require Import Zbool.
Require Import Coq.Numbers.BinNums.
Require Import Cop.
Require Import ExtLib.Tactics.
Require Import ExtLib.Data.List.

Definition beq_int (i1 i2 : Integers.int) : bool :=
Zbool.Zeq_bool (Int.intval i1) (Int.intval i2).

Lemma beq_int_true : forall a b, beq_int a b = true -> a = b.
Proof.
intros.
destruct a, b.
unfold beq_int in *.
simpl in H.
apply Zbool.Zeq_bool_eq in H. subst.
replace intrange with intrange0.
auto.
apply Axioms.proof_irr.
Qed.

Hint Resolve beq_int_true : expr_beq.

Lemma beq_int_refl : forall i, beq_int i i = true.
Proof.
intros.
unfold beq_int. apply Zeq_is_eq_bool. auto.
Qed.

Hint Resolve beq_int_refl : expr_beq.
Hint Rewrite beq_int_refl : expr_beq.

Definition beq_long (i1 i2 : int64) : bool :=
Zeq_bool (Int64.intval i1) (Int64.intval i2).

Lemma beq_long_true : forall a b, beq_long a b = true -> a = b.
Proof.
intros.
destruct a, b.
unfold beq_long in *.
simpl in H.
apply Zeq_bool_eq in H. subst.
replace intrange with intrange0.
auto.
apply Axioms.proof_irr.
Qed.

Lemma beq_long_refl : forall i, beq_long i i = true.
Proof.
intros.
unfold beq_long. apply Zeq_is_eq_bool. auto.
Qed.

Hint Resolve beq_long_refl : expr_beq.
Hint Rewrite beq_long_refl : expr_beq.
Hint Resolve beq_long_true : expr_beq.

Definition beq_float_dec a b:= if Float.eq_dec a b then true else false.

Lemma beq_float_dec_true a b : beq_float_dec a b = true -> a = b.
intros.  unfold beq_float_dec in *. destruct (Float.eq_dec a b); congruence.
Qed. (*If things are slow, this may be the culprit *)

Lemma beq_float_refl : forall a, beq_float_dec a a = true.
Proof.
intros. unfold beq_float_dec.
consider (Float.eq_dec a a); auto.
Qed.

Hint Resolve beq_float_refl : expr_beq.
Hint Rewrite beq_float_refl : expr_beq.
Hint Resolve beq_float_dec_true : expr_beq.

Definition beq_float32_dec a b:= if Float32.eq_dec a b then true else false.

Lemma beq_float32_dec_true a b : beq_float32_dec a b = true -> a = b.
intros.  unfold beq_float32_dec in *. destruct (Float32.eq_dec a b); congruence.
Qed. (*If things are slow, this may be the culprit *)

Lemma beq_float32_refl : forall a, beq_float32_dec a a = true.
Proof.
intros. unfold beq_float32_dec.
consider (Float32.eq_dec a a); auto.
Qed.

Hint Resolve beq_float32_refl : expr_beq.
Hint Rewrite beq_float32_refl : expr_beq.

Hint Resolve beq_float32_dec_true : expr_beq.

Definition unary_op_beq a b :=
match a, b with
  | Onotbool, Onotbool
  | Onotint, Onotint
  | Oneg, Oneg
  | Oabsfloat, Oabsfloat => true
  | _, _ => false
end.

Lemma unary_op_beq_sound : forall a b, unary_op_beq a b = true -> a = b .
destruct a, b; simpl in *; try congruence; auto.
Qed.

Lemma unary_op_beq_refl : forall a, unary_op_beq a a = true.
destruct a; auto.
Qed.

Hint Resolve unary_op_beq_refl : expr_beq.
Hint Rewrite unary_op_beq_refl : expr_beq.
Hint Resolve unary_op_beq_sound: expr_beq.

Definition binary_op_beq a b :=
match a, b with
    Oadd, Oadd
  | Osub, Osub
  | Omul, Omul
  | Odiv, Odiv
  | Omod, Omod
  | Oand, Oand
  | Oor, Oor
  | Oxor, Oxor
  | Oshl, Oshl
  | Oshr, Oshr
  | Oeq, Oeq
  | One, One
  | Olt, Olt
  | Ogt, Ogt
  | Ole, Ole
  | Oge, Oge => true
  | _, _ => false
end.

Lemma binary_op_beq_sound : forall a b, binary_op_beq a b = true -> a = b .
destruct a, b; simpl in *; try congruence; auto.
Qed.

Lemma binary_op_beq_refl : forall a, binary_op_beq a a = true.
destruct a; auto.
Qed.

Hint Resolve binary_op_beq_refl : expr_beq.
Hint Rewrite binary_op_beq_refl : expr_beq.
Hint Resolve binary_op_beq_sound : expr_beq.

Fixpoint expr_beq a b :=
match a, b with
| Econst_int i1 ty1, Econst_int i2 ty2 => andb (beq_int i1 i2) (eqb_type ty1 ty2)
| Econst_float f1 ty1, Econst_float f2 ty2 => andb (beq_float_dec f1 f2) (eqb_type ty1 ty2)
| Econst_single f1 ty1, Econst_single f2 ty2 => andb (beq_float32_dec f1 f2) (eqb_type ty1 ty2)
| Econst_long l1 ty1, Econst_long l2 ty2 => andb (beq_long l1 l2) (eqb_type ty1 ty2)
| Evar id1 ty1, Evar id2 ty2
| Etempvar id1 ty1, Etempvar id2 ty2 => andb (BinPos.Pos.eqb id1 id2) (eqb_type ty1 ty2)
| Ederef e1 ty1, Ederef e2 ty2
| Eaddrof e1 ty1, Eaddrof e2 ty2
| Ecast e1 ty1, Ecast e2 ty2 => (andb (expr_beq e1 e2) (eqb_type ty1 ty2))
| Eunop op1 e1 ty1, Eunop op2 e2 ty2 => (andb (andb (unary_op_beq op1 op2) (expr_beq e1 e2)) (eqb_type ty1 ty2))
| Ebinop op1 e11 e21 ty1, Ebinop op2 e12 e22 ty2 => (andb (andb (andb (binary_op_beq op1 op2) (expr_beq e11 e12)) (eqb_type ty1 ty2)) (expr_beq e21 e22))
| Efield e1 id1 ty1, Efield e2 id2 ty2 => andb (andb (expr_beq e1 e2) (BinPos.Pos.eqb id1 id2)) (eqb_type ty1 ty2)
| _, _ => false
end.

Hint Rewrite Bool.andb_true_iff : expr_beq.
Hint Resolve eqb_type_true : expr_beq.
Hint Resolve BinPos.Peqb_true_eq : expr_beq.
Hint Rewrite BinPos.Pos.eqb_refl : expr_beq.
Hint Resolve BinPos.Pos.eqb_refl : expr_beq.
Hint Resolve eqb_type_refl : expr_beq.
Hint Rewrite eqb_type_refl : expr_beq.

Ltac solve_expr_beq_sound :=
try solve [simpl in *; try congruence]; try reflexivity;
simpl in *; autorewrite with expr_beq in *;
repeat match goal with
| [ H : _ /\ _  |- _] => destruct H
end;
try match goal with
| [ H : List.list_eqb ?r ?a ?b = _ |- _] => consider ( List.list_eqb r a b); intros
end;
try f_equal;
auto with expr_beq.

Lemma expr_beq_refl : forall a, expr_beq a a = true.
Proof.
induction a; simpl; repeat (rewrite Bool.andb_true_iff; split); auto with expr_beq.
Qed.

Hint Resolve expr_beq_refl : expr_beq.

Lemma expr_beq_spec : forall a b, expr_beq a b = true <-> a = b.
split; revert b. induction a; intros; match goal with [ |-  _ = ?b] => destruct b end; solve_expr_beq_sound.
intros. induction a, b; inversion H; subst; auto with expr_beq.
Qed.

Lemma expr_beq_sound : forall a b, expr_beq a b = true -> a = b.
Proof.
apply expr_beq_spec.
Qed.


Require Import Setoid Morphisms RelationClasses Program.Basics.
From ChargeCore.Logics Require Import ILogic BILogic ILInsts Pure.
From ChargeCore.SepAlg Require Import SepAlg.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section BISepAlg.
  Context {A} `{sa : SepAlg A}.
  Context {B : Type} `{IL: ILogic B}.
  Context {HPre : PreOrder rel}.

  Open Scope sa_scope.

  Local Transparent ILPre_Ops.

  Global Program Instance SABIOps: BILogicOps (ILPreFrm rel B) := {
    empSP := mkILPreFrm (fun x => Exists a : (sa_unit x), ltrue) _;
    sepSP P Q :=  mkILPreFrm (fun x => Exists x1, Exists x2, Exists H : sa_mul x1 x2 x,
                                                (ILPreFrm_pred P) x1 //\\ (ILPreFrm_pred Q) x2) _;
    wandSP P Q := mkILPreFrm (fun x => Forall x1, Forall x2, Forall H : sa_mul x x1 x2,
                                                 (ILPreFrm_pred P) x1 -->> (ILPreFrm_pred Q) x2) _
  }.
  Next Obligation.
  	apply lexistsL; intro H1. eapply lexistsR. rewrite <- H. assumption. apply ltrueR.
  Qed.
  Next Obligation.
  	apply lexistsL; intro a; apply lexistsL; intro b; apply lexistsL; intro Hab.
  	apply lexistsR with a; apply lexistsR with b. eapply lexistsR. eapply sa_mul_monR; eassumption. reflexivity.
  Qed.
  Next Obligation.
	apply lforallR; intro a; apply lforallR; intro b; apply lforallR; intro Hab.
	apply lforallL with a; apply lforallL with b. apply lforallL. eapply sa_mul_mon; [symmetry|]; eassumption.
	reflexivity.
  Qed.

  Instance SABILogic : BILogic (ILPreFrm rel B).
    split.
    + apply _.
    + intros P Q x; simpl.
      apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro H'; apply sa_mulC in H'.
      apply lexistsR with x2; apply lexistsR with x1; apply lexistsR with H'; apply landC.
    + intros P Q R x; simpl.
      apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro Hx.
      repeat setoid_rewrite landexistsD1.
      apply lexistsL; intro x3. apply lexistsL; intro x4; apply lexistsL; intro Hx1.
      destruct (sa_mulA Hx1 Hx) as [x5 [Hx2 Hx5]].
      apply lexistsR with x3; apply lexistsR with x5; apply lexistsR with Hx5.
      rewrite landA. apply landR; [apply landL1; reflexivity| apply landL2].
      apply lexistsR with x4. apply lexistsR with x2; apply lexistsR with Hx2.
      reflexivity.
    + intros P Q R; split; intros H x; simpl.
      - apply lforallR; intro x1; apply lforallR; intro x2; apply lforallR; intro Hx1.
        apply limplAdj.
        specialize (H x2); simpl in H.
        rewrite <- H.
        apply lexistsR with x; apply lexistsR with x1; apply lexistsR with Hx1. reflexivity.
      - apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro Hx.
        specialize (H x1); simpl in H.
        rewrite H.
		apply landAdj.
        apply lforallL with x2; apply lforallL with x; apply lforallL with Hx.
        reflexivity.
    + intros P Q R H x; simpl.
      apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro Hx.
      repeat eapply lexistsR; [eassumption|].
      rewrite H. reflexivity.
    + intros P; split; intros x; simpl.
      - apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro Hx.
        rewrite landC, landexistsD1. apply lexistsL; intro Horg.
        apply landL2.
        apply sa_unit_eq in Hx. rewrite <- Hx. reflexivity. assumption.
      - destruct (sa_unit_ex x) as [u [H1 H2]].
        apply lexistsR with x; apply lexistsR with u; apply lexistsR with H2.
        apply landR; [reflexivity| apply lexistsR; [assumption | apply ltrueR]].
  Qed.

  Global Instance pureop_bi_sepalg : PureOp _ := {
    pure := fun (P : ILPreFrm rel B) => forall h h', (ILPreFrm_pred P) h |-- (ILPreFrm_pred P) h'
  }.

  Global Instance pure_bi_sepalg : Pure pureop_bi_sepalg.
  Proof.
    constructor.
    { unfold pure; simpl; constructor.
      { unfold sepSP; simpl; intros.
        destruct (sa_unit_ex t).
        apply lexistsR with x.
        apply lexistsR with t.
        destruct H0.
        apply sa_mulC in H1.
        eapply lexistsR; eauto.
        rewrite H. reflexivity. }
      constructor.
      { unfold sepSP; simpl; intros.
        repeat (eapply lexistsL; intros).
        rewrite H. rewrite H0. reflexivity. }
      constructor.
      { split; intros; unfold sepSP; simpl; intros.
        { repeat (eapply lexistsL; intros).
          apply landR. do 2 apply landL1. auto.
          eapply lexistsR.
          eapply lexistsR.
          eapply lexistsR. eassumption.
          eapply landR. apply landL1. apply landL2. reflexivity.
          apply landL2. reflexivity. }
        { rewrite landC.
          rewrite landexistsDL1.
          repeat (eapply lexistsL; intros).
          rewrite landexistsDL1.
          repeat (eapply lexistsL; intros).
          rewrite landexistsDL1.
          repeat (eapply lexistsL; intros).
          do 3 eapply lexistsR.
          eassumption.
          rewrite H.
          rewrite landC. rewrite landA. reflexivity. } }
      constructor.
      { unfold wandSP; simpl; intros.
        repeat (eapply lforallR; intros).
        destruct (sa_unit_ex x).
        destruct H0.
        eapply lforallL with x1.
        apply lforallL with x.
        eapply lforallL.
        rewrite x0. auto.
        apply limplAdj. apply limplL. apply H. apply landL1. reflexivity. }
      { unfold wandSP; simpl; intros.
        repeat (eapply lforallR; intros).
        eapply lforallL. eapply lforallL. reflexivity.
        apply limplAdj. apply limplL; auto. apply landL1. auto. } }
    { red. red. unfold pure; simpl.
      intros. setoid_rewrite H.
      reflexivity. }
  Qed.

End BISepAlg.

Section BISepAlg2.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{BIL: BILogic B}.
  Context {HPre : PreOrder rel}.
  Context {HIL : ILogic B}.

  Open Scope sa_scope.

  Local Transparent ILPre_Ops.

  Global Program Instance SABIOps2: BILogicOps (ILPreFrm rel B) :=
  { empSP := mkILPreFrm (fun x => Exists a : (sa_unit x), empSP) _
  ; sepSP P Q :=  mkILPreFrm (fun x => Exists x1, Exists x2, Exists H : sa_mul x1 x2 x,
                                                (ILPreFrm_pred P) x1 ** (ILPreFrm_pred Q) x2) _
  ; wandSP P Q := mkILPreFrm (fun x => Forall x1, Forall x2, Forall H : sa_mul x x1 x2,
                                                 (ILPreFrm_pred P) x1 -* (ILPreFrm_pred Q) x2) _
  }.
  Next Obligation.
  	apply lexistsL; intro H1. eapply lexistsR. rewrite <- H. assumption. reflexivity.
  Qed.
  Next Obligation.
  	apply lexistsL; intro a; apply lexistsL; intro b; apply lexistsL; intro Hab.
  	apply lexistsR with a; apply lexistsR with b. eapply lexistsR. eapply sa_mul_monR; eassumption. reflexivity.
  Qed.
  Next Obligation.
	apply lforallR; intro a; apply lforallR; intro b; apply lforallR; intro Hab.
	apply lforallL with a; apply lforallL with b. apply lforallL. eapply sa_mul_mon; [symmetry|]; eassumption.
	reflexivity.
  Qed.

  Global Instance SABILogic2 : BILogic (ILPreFrm rel B).
    split.
    + apply _.
    + intros P Q x; simpl.
      apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro H'; apply sa_mulC in H'.
      apply lexistsR with x2; apply lexistsR with x1; apply lexistsR with H'. apply sepSPC.
    + intros P Q R x; simpl.
      apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro Hx.
      rewrite sepSPC. do 3 setoid_rewrite <- bilexistssc.
      apply lexistsL; intro x3; apply lexistsL; intro x4; apply lexistsL; intro Hx1.
      destruct (sa_mulA Hx1 Hx) as [x5 [Hx2 Hx5]].
      apply lexistsR with x3; apply lexistsR with x5; apply lexistsR with Hx5; apply lexistsR with x4;
      apply lexistsR with x2; apply lexistsR with Hx2.
      rewrite sepSPC, sepSPA. reflexivity.
    + intros P Q R; split; intros H x; simpl.
      - apply lforallR; intro x1; apply lforallR; intro x2; apply lforallR; intro Hx1.
        apply wandSepSPAdj.
        specialize (H x2); simpl in H.
        rewrite <- H.
        apply lexistsR with x; apply lexistsR with x1; apply lexistsR with Hx1. reflexivity.
      - apply lexistsL; intro x1. apply lexistsL; intro x2; apply lexistsL; intro Hx.
        specialize (H x1); simpl in H.
        setoid_rewrite H.
        rewrite sepSPC. do 3 setoid_rewrite bilforallscR.
        apply lforallL with x2; apply lforallL with x; apply lforallL with Hx.
        rewrite sepSPC.
        apply wandSepSPAdj. reflexivity.
    + intros P Q R H x; simpl.
      apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro Hx.
      apply lexistsR with x1; apply lexistsR with x2; apply lexistsR with Hx.
      rewrite H. reflexivity.
    + intros P; split; intros x; simpl.
      - setoid_rewrite <- bilexistssc.
        apply lexistsL; intro x1; apply lexistsL; intro x2; apply lexistsL; intro Hx; apply lexistsL; intro H2.
        rewrite empSPR.
        apply sa_unit_eq in Hx. rewrite <- Hx. reflexivity. assumption.
      - destruct (sa_unit_ex x) as [u [H1 H2]].
        setoid_rewrite <- bilexistssc.
        apply lexistsR with x; apply lexistsR with u; apply lexistsR with H2; apply lexistsR with H1.
        rewrite empSPR. reflexivity.
  Qed.

  Context {POB : @PureOp B}.
  Context {PureB : Pure POB}.

  Global Instance pureop_bi_sepalg2 : PureOp (ILPreFrm rel B) := {
    pure := fun (P : ILPreFrm rel B) =>
        (forall h, pure ((ILPreFrm_pred P) h)) /\
    	(forall h h', (ILPreFrm_pred P) h |-- (ILPreFrm_pred P) h')
  }.

  Global Instance pure_bi_sepalg2 : Pure pureop_bi_sepalg2.
  Proof.
    constructor.
    { unfold pure; simpl; intros; constructor.
      { unfold sepSP; simpl; intros.
        destruct H as [H H1].
        pose proof (@pure_axiom B _ _ _ PureB _ (H t)) as H2.
        destruct H2 as [H2 _].
        destruct (sa_unit_ex t) as [x [Hx Htx]].
        apply lexistsR with x.
        apply lexistsR with t.
        apply sa_mulC in Htx.
        eapply lexistsR with Htx.
        rewrite H2, (H1 t x); reflexivity. }
      constructor.
      { unfold sepSP; simpl; intros.
        repeat (eapply lexistsL; intros).
        destruct H as [H1 H2]; destruct H0 as [H3 H4].
        rewrite (H2 x t), (H4 x0 t).
        specialize (H1 t). specialize (H3 t).
        pose proof (@pure_axiom B _ _ _ PureB _ H1).
        destruct H as [_ [H _]].
        rewrite H. reflexivity. assumption. }
      constructor.
      { split; intros; unfold sepSP; simpl; intros.
        { repeat (eapply lexistsL; intros).
          destruct H as [H H1].
          pose proof (@pure_axiom B _ _ _ PureB) _ (H x) as H2.
          destruct H2 as [_ [_ [H2 _]]].
          rewrite H2.
          apply landR; [apply landL1; auto | apply landL2].
          do 3 eapply lexistsR; [eassumption|reflexivity]. }
        { rewrite landC.
          rewrite landexistsDL1.
          repeat (eapply lexistsL; intros).
          rewrite landexistsDL1.
          repeat (eapply lexistsL; intros).
          rewrite landexistsDL1.
          repeat (eapply lexistsL; intros).
          do 3 eapply lexistsR.
          eassumption. destruct H as [H H1].
          rewrite (H1 t x).
          pose proof (@pure_axiom B _ _ _ PureB) _ (H x) as H2.
          destruct H2 as [_ [_ [H2 _]]].
          destruct (H2 (Q x) (R x0)) as [_ H3].
          rewrite landC. assumption.
	   } }
      constructor.
      { unfold wandSP; simpl; intros.
        repeat (eapply lforallR; intros).
        destruct (sa_unit_ex x).
        destruct H0.
        eapply lforallL with x1.
        apply lforallL with x.
        eapply lforallL.
        rewrite x0. auto.
        destruct H as [H H2].
        pose proof (@pure_axiom B _ _ _ PureB) _ (H x1) as H3.
        destruct H3 as [_ [_ [_ [H3 _]]]].
        rewrite H3.
        apply limplAdj. apply limplL. apply H2. apply landL1. reflexivity. }
      { unfold wandSP; simpl; intros.
        repeat (eapply lforallR; intros).
        eapply lforallL. eapply lforallL. reflexivity.
        destruct H as [H H2].
        pose proof (@pure_axiom B _ _ _ PureB) _ (H x) as H3.
        destruct H3 as [_ [_ [_ [_ H3]]]].
        destruct H0 as [H4 H5].
        rewrite <- H3; [|auto].
        apply limplAdj. apply limplL; auto. apply landL1; auto. } }
    { red. red. unfold pure; simpl; intros.
      destruct PureB. repeat setoid_rewrite H; reflexivity. }
  Qed.

End BISepAlg2.

Section BILPre.
  Context T (ord: relation T) {HPre: PreOrder ord}.
  Context {A : Type} `{HBI: BILogic A}.
  Context {HIL : ILogic A}.

  Program Instance BILPre_Ops : BILogicOps (ILPreFrm ord A) := {|
    empSP      := mkILPreFrm (fun t => empSP) _;
    sepSP  P Q := mkILPreFrm (fun t => (ILPreFrm_pred P) t ** (ILPreFrm_pred Q) t) _;
    wandSP P Q := mkILPreFrm (fun t => Forall t', Forall H : ord t t', (ILPreFrm_pred P) t' -* (ILPreFrm_pred Q) t') _
  |}.
  Next Obligation.
    intros; rewrite H; reflexivity.
  Qed.
  Next Obligation.
    intros.
    apply lforallR; intro x; apply lforallR; intro Hx. rewrite <- H in Hx.
    apply lforallL with x; apply lforallL with Hx; reflexivity.
  Qed.

  Local Existing Instance ILPre_Ops.
  Local Existing Instance ILPre_ILogic.

  Local Transparent ILPre_Ops.

  Instance BILPreLogic : BILogic (ILPreFrm ord A).
  Proof.
    split.
    + apply _.
    + intros P Q x; simpl; apply sepSPC.
    + intros P Q R x; simpl; apply sepSPA.
    + intros P Q R; split; intros H t; simpl.
      * apply lforallR; intro t'; apply lforallR; intro H1.
        transitivity ((ILPreFrm_pred P) t'); [apply ILPreFrm_closed; assumption|].
        apply wandSepSPAdj; apply H.
      *  apply wandSepSPAdj; specialize (H t); unfold wandSP in H; simpl in H.
         rewrite H. apply lforallL with t; apply lforallL; reflexivity.
    + intros P Q R H x; simpl; apply bilsep; apply H.
    + intros P; split; intros x; simpl; apply empSPR.
  Qed.

  Context {POA : @PureOp A} {PA : Pure POA}.

  Instance PureBILPreOp : @PureOp (ILPreFrm ord A) := {
    pure := fun a => forall t, pure ((ILPreFrm_pred a) t)
  }.

  Instance PureBILPre : Pure (PureBILPreOp).
  Proof.
    constructor.
    { repeat split; intros; intro t; simpl.
      * eapply pureandsc; eauto.
      * eapply purescand; eauto.
      * eapply pureandscD; eauto.
      * eapply pureandscD; eauto.
      * apply lforallR; intro t'; apply lforallR; intro Ht.
        apply lforallL with t'; apply lforallL with Ht.
        eapply puresiimpl; eauto.
      * apply lforallR; intro t'; apply lforallR; intro Ht.
        apply lforallL with t'; apply lforallL with Ht.
        eapply pureimplsi; eauto. }
    { do 2 red. unfold pure; simpl. intros.
      split.
      { intros. eapply pure_proper. 2: eapply H0. symmetry.
        instantiate (1 := t).
        red in H. red. unfold lentails in H. simpl in H.
        intuition. }
      { intros. eapply pure_proper. 2: eapply H0. symmetry.
        instantiate (1 := t).
        red in H. red. unfold lentails in H. simpl in H.
        intuition. } }
  Qed.

  Instance pureBILPre (a : ILPreFrm ord A) (H : forall t, pure ((ILPreFrm_pred a) t)) : pure a.
  Proof.
    simpl; apply H.
  Qed.

End BILPre.

Section BILogic_Fun.
  Context (T: Type).
  Context {A : Type} `{BIL: BILogic A}.
  Context {HIL : ILogic A}.

  Local Transparent ILFun_Ops.

  Program Definition BILFun_Ops : BILogicOps ((fun x y => x -> y) T A) := {|
    empSP         := fun t => empSP;
    sepSP     P Q := fun t => P t ** Q t;
    wandSP    P Q := fun t => P t -* Q t
  |}.

  Local Existing Instance ILFun_Ops.
  Local Existing Instance ILFun_ILogic.
  Local Existing Instance BILFun_Ops.

  Program Definition BILFunLogic : @BILogic ((fun x y => x -> y) T A) (@ILFun_Ops T A _) BILFun_Ops.
  Proof.
    split.
    + apply _.
    + intros P Q x; simpl; apply sepSPC1.
    + intros P Q R x; simpl; apply sepSPA.
    + intros P Q R; split; intros H x; simpl;
      apply wandSepSPAdj; apply H.
    + intros P Q R H x; simpl; apply bilsep; apply H.
    + intros P; split; intros x; simpl; apply empSPR.
  Qed.

  Context {POA : @PureOp A} {PA : Pure POA}.

  Instance PureBILFunOp : @PureOp ((fun x y => x -> y) T A) := {
    pure := fun a => forall t, pure (a t)
  }.

  Instance PureBILFun : Pure (PureBILFunOp).
  Proof.
    constructor.
    { intros. repeat split; intros; intro t; simpl.
      * eapply pureandsc; eauto.
      * eapply purescand; eauto.
      * eapply pureandscD; eauto.
      * eapply pureandscD; eauto.
      * eapply puresiimpl; eauto.
      * eapply pureimplsi; eauto. }
    { do 2 red; simpl; intros.
      red in H. simpl in H.
      split.
      { intros. eapply pure_proper.
        2: eapply H0. split. intuition. intuition. }
      { intros. eapply pure_proper.
        2: eapply H0. split. intuition. intuition. } }
  Qed.

  Instance pureBILFun (a : (fun x y => x -> y) T A) (H : forall t, pure (a t)) : @pure _ PureBILFunOp a.
  Proof.
    simpl; apply H.
  Qed.

End BILogic_Fun.

Global Opaque BILPre_Ops.
Global Opaque BILFun_Ops.
Global Opaque SABIOps.
Global Opaque SABIOps2.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria)      2016                             *)
(*                                                                      *)
(************************************************************************)

Require Import QMicromega.
Require Import QArith.
Require Import RingMicromega.
Require Import VarMap.
Require Coq.micromega.Tauto.
Declare ML Module "micromega_plugin".

Ltac rchange :=
  intros __wit __varmap __ff ;
  change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
  apply (QTautoChecker_sound __ff __wit).

Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity.
Ltac rchecker_abstract   := rchange ; vm_cast_no_check (eq_refl true).

Ltac rchecker := rchecker_no_abstract.

(** Here, lra stands for linear rational arithmetic *)
Ltac lra := lra_Q  rchecker.

(** Here, nra stands for non-linear rational arithmetic *)
Ltac nra := xnqa  rchecker.

Ltac xpsatz dom d :=
  let tac := lazymatch dom with
  | Q =>
    ((sos_Q rchecker) || (psatz_Q d rchecker))
  | _ => fail "Unsupported domain"
  end in tac.

Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1).

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


Require Import Lia Framework TotalMem.
Import ListNotations.

Set Implicit Arguments.

Section TransactionalDisk.

  Variable disk_size: nat.

  Inductive token' :=
  | CrashBefore : token'
  | CrashAfter : token'
  | Cont : token'
  | TxnFull : token'.

  Definition state' := (txn_state * ((@total_mem addr addr_dec value) * (@total_mem addr addr_dec value)))%type.

  Inductive transactional_disk_prog : Type -> Type :=
  (* | Start : transactional_disk_prog unit *)
  | Read : addr -> transactional_disk_prog value
  | Write : addr -> value -> transactional_disk_prog (option unit)
  | Commit : transactional_disk_prog unit
  | Abort : transactional_disk_prog unit
  | Recover : transactional_disk_prog unit
  | Init : list (addr * value) -> transactional_disk_prog unit.

  Inductive exec' :
    forall T, user -> token' ->  state' -> transactional_disk_prog T -> @Result state' T -> Prop :=
  | ExecReadInbound :
      forall s a u,
        let st := fst s in
        let c := fst (snd s) in
        let d := snd (snd s) in
        a < disk_size ->
        exec' u Cont s (Read a) (Finished s (c a))

  | ExecReadOutbound :
      forall s a u,
        a >= disk_size ->
        exec' u Cont s (Read a) (Finished s value0)

  | ExecWriteInbound :
      forall s a v u ,
        let st := fst s in
        let c := fst (snd s) in
        let d := snd (snd s) in
        a < disk_size ->
        exec' u Cont s (Write a v) (Finished (NotEmpty, ((upd c a v), d)) (Some tt))

  | ExecWriteInboundFull :
      forall s a v u,
        a < disk_size ->
        exec' u TxnFull s (Write a v) (Finished s None)

  | ExecWriteOutbound :
      forall s a v u,
        a >= disk_size ->
        exec' u Cont s (Write a v) (Finished s None)

  | ExecCommit :
      forall s u,
        exec' u Cont s Commit (Finished (Empty, (fst (snd s), fst (snd s))) tt)

  | ExecAbort :
      forall s u,
        exec' u Cont s Abort (Finished (Empty, (snd (snd s), snd (snd s))) tt)

  | ExecRecover :
      forall s u,
        exec' u Cont s Recover (Finished (Empty, (snd (snd s), snd (snd s))) tt)

  | ExecInit :
      forall s u l_av,
        let l_a := map fst l_av in
        let l_v := map snd l_av in
        exec' u Cont s (Init l_av) (Finished (Empty, (upd_batch (snd (snd s)) l_a l_v, upd_batch (snd (snd s)) l_a l_v)) tt)

  | ExecCrashBefore :
      forall d T (p: transactional_disk_prog T) u,
        exec' u CrashBefore d p (Crashed d)

  | ExecCommitCrashAfter :
      forall s u,
        let c := fst (snd s) in
        exec' u CrashAfter s Commit (Crashed (Empty, (c, c))).

  Hint Constructors exec' : core.

  Theorem exec_deterministic_wrt_token' :
    forall u o s T (p: transactional_disk_prog T) ret1 ret2,
      exec' u o s p ret1 ->
      exec' u o s p ret2 ->
      ret1 = ret2.
  Proof.
    intros; destruct p; simpl in *; cleanup;
    repeat
      match goal with
      | [H: exec' _ _ _ _ _ |- _] =>
        inversion H; clear H; cleanup
      end; eauto;
    repeat split_ors; cleanup; eauto; try lia; try congruence.
  Qed.

  Definition TDCore :=
    Build_Core
      transactional_disk_prog
      exec'
      exec_deterministic_wrt_token'.

  Definition TDLang := Build_Layer TDCore.

End TransactionalDisk.


(**
 Discrete morphisms in bicategories

 Contents:
 1. Conservative 1-cells
 2. Characterization of conservative 1-cells
 3. Pseudomonic 1-cells and fully faithful 1-cells are conservative
 4. Discrete 1-cells
 5. Pseudomonic and fully faithful 1-cells are discrete
 6. Conservative 1-cells in locally groupoidal bicategories
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.

Local Open Scope cat.

(**
 1. Conservative 1-cells
 *)
Definition conservative_1cell
           {B : bicat}
           {a b : B}
           (f : a --> b)
  : UU
  := ∏ (x : B)
       (g₁ g₂ : x --> a)
       (α : g₁ ==> g₂),
     is_invertible_2cell (α ▹ f)
     →
     is_invertible_2cell α.

Definition conservative_1cell_reflect_iso
           {B : bicat}
           {a b : B}
           {f : a --> b}
           (Hf : conservative_1cell f)
           {x : B}
           {g₁ g₂ : x --> a}
           (α : g₁ ==> g₂)
           (Hα : is_invertible_2cell (α ▹ f))
  : is_invertible_2cell α
  := Hf x g₁ g₂ α Hα.

Definition isaprop_conservative_1cell
           {B : bicat}
           {a b : B}
           (f : a --> b)
  : isaprop (conservative_1cell f).
Proof.
  do 5 (use impred ; intro).
  apply isaprop_is_invertible_2cell.
Qed.

(**
 2. Characterization of conservative 1-cells
 *)
Definition conservative_1cell_to_conservative
           {B : bicat}
           {a b : B}
           {f : a --> b}
           (Hf : conservative_1cell f)
           (x : B)
  : conservative (post_comp x f).
Proof.
  intros g₁ g₂ α Hα.
  apply is_inv2cell_to_is_z_iso.
  apply Hf.
  exact (z_iso_to_inv2cell (make_z_iso' _ Hα)).
Defined.

Definition conservative_to_conservative_1cell
           {B : bicat}
           {a b : B}
           {f : a --> b}
           (Hf : ∏ (x : B), conservative (post_comp x f))
  : conservative_1cell f.
Proof.
  intros x g₁ g₂ α Hα.
  apply is_z_iso_to_is_inv2cell.
  apply Hf.
  apply is_inv2cell_to_is_z_iso.
  exact Hα.
Defined.

Definition conservative_1cell_weq_conservative
           {B : bicat}
           {a b : B}
           (f : a --> b)
  : conservative_1cell f ≃ ∏ (x : B), conservative (post_comp x f).
Proof.
  use weqimplimpl.
  - exact conservative_1cell_to_conservative.
  - exact conservative_to_conservative_1cell.
  - exact (isaprop_conservative_1cell f).
  - use impred ; intro.
    apply isaprop_conservative.
Defined.

(**
 3. Pseudomonic and fully faithful 1-cells are conservative
 *)
Definition pseudomonic_is_conservative
           {B : bicat}
           {a b : B}
           {f : a --> b}
           (Hf : pseudomonic_1cell f)
  : conservative_1cell f.
Proof.
  intros x g₁ g₂ α Hα.
  pose (H := is_invertible_2cell_pseudomonic_1cell_inv_map Hf (α ▹ f) Hα).
  use make_is_invertible_2cell.
  - exact (H^-1).
  - abstract
      (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
       rewrite id2_left ;
       apply (pseudomonic_1cell_faithful Hf) ;
       exact (!(pseudomonic_1cell_inv_map_eq Hf (α ▹ f) Hα))).
  - abstract
      (use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
       rewrite id2_right ;
       apply (pseudomonic_1cell_faithful Hf) ;
       exact (!(pseudomonic_1cell_inv_map_eq Hf (α ▹ f) Hα))).
Defined.

Definition fully_faithful_to_conservative
           {B : bicat}
           {a b : B}
           {f : a --> b}
           (Hf : fully_faithful_1cell f)
  : conservative_1cell f.
Proof.
  apply pseudomonic_is_conservative.
  apply fully_faithful_is_pseudomonic.
  exact Hf.
Defined.

(**
 4. Discrete 1-cells
 *)
Definition discrete_1cell
           {B : bicat}
           {a b : B}
           (f : a --> b)
  : UU
  := faithful_1cell f × conservative_1cell f.

Definition isaprop_discrete_1cell
           {B : bicat}
           {a b : B}
           (f : a --> b)
  : isaprop (discrete_1cell f).
Proof.
  use isapropdirprod.
  - apply isaprop_faithful_1cell.
  - apply isaprop_conservative_1cell.
Qed.

(**
 5. Pseudomonic 1-cells and fully faithful 1-cells are discrete
 *)
Definition pseudomonic_is_discrete
           {B : bicat}
           {a b : B}
           {f : a --> b}
           (Hf : pseudomonic_1cell f)
  : discrete_1cell f.
Proof.
  split.
  - exact (pseudomonic_1cell_faithful Hf).
  - exact (pseudomonic_is_conservative Hf).
Defined.

Definition fully_faithful_is_discrete
           {B : bicat}
           {a b : B}
           {f : a --> b}
           (Hf : fully_faithful_1cell f)
  : discrete_1cell f.
Proof.
  split.
  - exact (fully_faithful_1cell_faithful Hf).
  - exact (fully_faithful_to_conservative Hf).
Defined.

(**
 6. Conservative 1-cells in locally groupoidal bicategories
 *)
Definition conservative_1cell_locally_groupoid
           {B : bicat}
           (HB : locally_groupoid B)
           {a b : B}
           (f : a --> b)
  : conservative_1cell f.
Proof.
  intros x g₁ g₂ α Hα.
  apply HB.
Defined.

Definition discrete_1cell_weq_faithful_locally_groupoid
           {B : bicat}
           (HB : locally_groupoid B)
           {a b : B}
           (f : a --> b)
  : discrete_1cell f ≃ faithful_1cell f.
Proof.
  use weqimplimpl.
  - exact (λ Hf, pr1 Hf).
  - intro Hf.
    split.
    + exact Hf.
    + exact (conservative_1cell_locally_groupoid HB f).
  - apply isaprop_discrete_1cell.
  - apply isaprop_faithful_1cell.
Defined.