From Hammer Require Import Hammer.

Require Import Coq.Strings.Ascii.
Require Import ExtLib.Data.Bool.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Core.RelDec.

Set Implicit Arguments.
Set Strict Implicit.

Definition ascii_dec (l r : Ascii.ascii) : bool :=
match l , r with
| Ascii.Ascii l1 l2 l3 l4 l5 l6 l7 l8 ,
Ascii.Ascii r1 r2 r3 r4 r5 r6 r7 r8 =>
if Bool.eqb l1 r1 then
if Bool.eqb l2 r2 then
if Bool.eqb l3 r3 then
if Bool.eqb l4 r4 then
if Bool.eqb l5 r5 then
if Bool.eqb l6 r6 then
if Bool.eqb l7 r7 then
if Bool.eqb l8 r8 then true
else false
else false
else false
else false
else false
else false
else false
else false
end.

Theorem ascii_dec_sound : forall l r,
ascii_dec l r = true <-> l = r.
Proof. hammer_hook "Char" "Char.ascii_dec_sound".
unfold ascii_dec. intros.
destruct l; destruct r.
repeat match goal with
| [ |- (if ?X then _ else _) = true <-> _ ] =>
consider X; intros; subst
end; split; congruence.
Qed.

Global Instance RelDec_ascii : RelDec (@eq Ascii.ascii) :=
{ rel_dec := ascii_dec }.

Global Instance RelDec_Correct_ascii : RelDec_Correct RelDec_ascii.
Proof. hammer_hook "Char" "Char.RelDec_Correct_ascii".
constructor; auto using ascii_dec_sound.
Qed.

Global Instance Reflect_ascii_dec a b : Reflect (ascii_dec a b) (a = b) (a <> b).
Proof. hammer_hook "Char" "Char.Reflect_ascii_dec".
apply iff_to_reflect; auto using ascii_dec_sound.
Qed.

Definition digit2ascii (n:nat) : Ascii.ascii :=
match n with
| 0 => "0"
| 1 => "1"
| 2 => "2"
| 3 => "3"
| 4 => "4"
| 5 => "5"
| 6 => "6"
| 7 => "7"
| 8 => "8"
| 9 => "9"
| n => ascii_of_nat (n - 10 + nat_of_ascii "A")
end%char.

Definition chr_newline : ascii :=
Eval compute in ascii_of_nat 10.

Export Ascii.


From iris.algebra Require Export big_op cmra.
From stdpp Require Import gmap gmultiset.
Set Default Proof Using "Type*".

(** Option *)
Lemma big_opL_None {M : cmraT} {A} (f : nat → A → option M) l :
  ([^op list] k↦x ∈ l, f k x) = None ↔ ∀ k x, l !! k = Some x → f k x = None.
Proof.
  revert f. induction l as [|x l IH]=> f //=. rewrite op_None IH. split.
  - intros [??] [|k] y ?; naive_solver.
  - intros Hl. split. by apply (Hl 0). intros k. apply (Hl (S k)).
Qed.
Lemma big_opM_None {M : cmraT} `{Countable K} {A} (f : K → A → option M) m :
  ([^op map] k↦x ∈ m, f k x) = None ↔ ∀ k x, m !! k = Some x → f k x = None.
Proof.
  induction m as [|i x m ? IH] using map_ind=> //=.
  rewrite -equiv_None big_opM_insert // equiv_None op_None IH. split.
  { intros [??] k y. rewrite lookup_insert_Some; naive_solver. }
  intros Hm; split.
  - apply (Hm i). by simplify_map_eq.
  - intros k y ?. apply (Hm k). by simplify_map_eq.
Qed.
Lemma big_opS_None {M : cmraT} `{Countable A} (f : A → option M) X :
  ([^op set] x ∈ X, f x) = None ↔ ∀ x, x ∈ X → f x = None.
Proof.
  induction X as [|x X ? IH] using collection_ind_L; [done|].
  rewrite -equiv_None big_opS_insert // equiv_None op_None IH. set_solver.
Qed.
Lemma big_opMS_None {M : cmraT} `{Countable A} (f : A → option M) X :
  ([^op mset] x ∈ X, f x) = None ↔ ∀ x, x ∈ X → f x = None.
Proof.
  induction X as [|x X IH] using gmultiset_ind.
  { rewrite big_opMS_empty. set_solver. }
  rewrite -equiv_None big_opMS_union big_opMS_singleton equiv_None op_None IH.
  set_solver.
Qed.


(** lib.v

   Copyright (C) 2017, Cong Sun

   This code is a part of CertIA.

   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
*)

Require Import Strings.Ascii.
Require Import Strings.String.
Require Import Numbers.Natural.Peano.NPeano.
Require Import Omega.

Open Scope char_scope.

Definition natToDigit (n : nat) : ascii :=
  match n with
    | 0 => "0"
    | 1 => "1"
    | 2 => "2"
    | 3 => "3"
    | 4 => "4"
    | 5 => "5"
    | 6 => "6"
    | 7 => "7"
     | 8 => "8"
    | _ => "9"
  end.

Open Scope string_scope.

Fixpoint writeNatAux (time n : nat) (acc : string) : string :=
  let acc' := String (natToDigit (n mod 10)) acc in
  match time with
    | 0 => acc'
    | S time' =>
      match n / 10 with
        | 0 => acc'
         | n' => writeNatAux time' n' acc'
       end
  end.

Definition nat2string (n : nat) : string :=
  writeNatAux n n "".

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


(** * Ensembles of traces

    Trace ensembles play one of central roles in SLOT, because from
    SLOT point of view any system is nothing but a collection of event
    traces that it can produce.

 *)
From Coq Require
     Program.Basics
     List
     Relations.

Import List ListNotations Basics Relations.

From Hammer Require Import
     Tactics.

From LibTx Require Import
     FoldIn
     Misc
     EventTrace
     Permutation
     SLOT.Hoare.

Open Scope hoare_scope.

Global Arguments Vec.nil {_}.
Global Arguments Vec.cons {_}.

Section defn.
  Context {S TE} `{StateSpace S TE}.

  Definition TraceEnsemble := list TE -> Prop.

  (** Hoare logic of trace ensembles consists of a single rule: *)
  Definition EHoareTriple (pre : S -> Prop) (g : TraceEnsemble) (post : S -> Prop) :=
    forall t, g t ->
         {{ pre }} t {{ post}}.

  (** Concatenation of trace ensembles represents systems that run
  sequentially: *)
  Inductive TraceEnsembleConcat (e1 e2 : TraceEnsemble) : TraceEnsemble :=
  | et_concat : forall t1 t2, e1 t1 -> e2 t2 -> TraceEnsembleConcat e1 e2 (t1 ++ t2).

  (** Set of all possible interleaving of two traces is a trace
  ensemble. As we later prove in [interleaving_to_permutation], this
  definition is dual to [Permutation]. *)
  Inductive Interleaving : list TE -> list TE -> TraceEnsemble :=
  | ilv_cons_l : forall te t1 t2 t,
      Interleaving t1 t2 t ->
      Interleaving (te :: t1) t2 (te :: t)
  | ilv_cons_r : forall te t1 t2 t,
      Interleaving t1 t2 t ->
      Interleaving t1 (te :: t2) (te :: t)
  | ilv_nil : Interleaving [] [] [].

  Section tests.
    (** Let's briefly check that our definition of [Interleaving] has
    desired properties: *)
    Variables (a b c d : TE).
    Goal Interleaving [a;b] [c;d] [a;b;c;d].
    Proof. repeat constructor. Qed.

    Goal Interleaving [a;b] [c;d] [a;c;b;d].
    Proof. repeat constructor. Qed.

    Goal Interleaving [a;b] [c;d] [a;c;d;b].
    Proof. repeat constructor. Qed.

    Goal Interleaving [a;b] [c;d] [c;a;b;d].
    Proof. repeat constructor. Qed.

    Goal Interleaving [a;b] [c;d] [c;a;d;b].
    Proof. repeat constructor. Qed.

    Goal Interleaving [a;b] [c;d] [c;d;a;b].
    Proof. repeat constructor. Qed.

    Goal a<>b -> b<>c -> not(Interleaving [a;b] [c;d] [b;a;c;d]).
    Proof.
      intros Hab Hac Hint.
      inversion_ Hint.
    Qed.
  End tests.

  Definition vec_modify {N} {A} (v : Vec.t A N) i (f : A -> A) :=
    Vec.replace v i (f (Vec.nth v i)).

  (* Left-biased version of [Interleaving] that doesn't make
  distinction between schedulings of commuting elements: *)
  Inductive UniqueInterleaving : list TE -> list TE -> TraceEnsemble :=
  | uilv_cons_l : forall l t1 t2 t,
      UniqueInterleaving t1 t2 t ->
      UniqueInterleaving (l :: t1) t2 (l :: t)
  | uilv_cons_r1 : forall l r t1 t2 t,
      ~trace_elems_commute l r ->
      UniqueInterleaving (l :: t1) t2 (l :: t) ->
      UniqueInterleaving (l :: t1) (r :: t2) (r :: l :: t)
  | uilv_cons_r2 : forall r1 r2 t1 t2 t,
      UniqueInterleaving t1 (r1 :: t2) (r1 :: t) ->
      UniqueInterleaving t1 (r2 :: r1 :: t2) (r2 :: r1 :: t)
  | uilv_nil : forall t, UniqueInterleaving [] t t.

  (** Two systems running in parallel are represented by interleaving
  of all possible traces that could be produced by these systems: *)
  Inductive Parallel (e1 e2 : TraceEnsemble) : TraceEnsemble :=
  | ilv_par : forall t1 t2 t,
      e1 t1 -> e2 t2 ->
      Interleaving t1 t2 t ->
      Parallel e1 e2 t.

  Definition EnsembleInvariant (prop : S -> Prop) (E : TraceEnsemble) : Prop :=
    forall (t : list TE), E t -> TraceInvariant prop t.

End defn.

Hint Constructors Interleaving Parallel TraceEnsembleConcat : slot.

Delimit Scope hoare_scope with hoare.
Notation "'-{{' a '}}' e '{{' b '}}'" := (EHoareTriple a e b)(at level 40) : hoare_scope.
Notation "'-{{}}' e '{{' b '}}'" := (EHoareTriple (const True) e b)(at level 40) : hoare_scope.
Notation "'-{{}}' e '{{}}'" := (forall t, e t -> exists s s', ReachableByTrace s t s')(at level 38) : hoare_scope.
Infix "->>" := (TraceEnsembleConcat) (at level 100) : hoare_scope.
Infix "-||" := (Parallel) (at level 101) : hoare_scope.

Section props.
  Context {S TE} `{HsspS : StateSpace S TE}.
  Let T := list TE.

  (* Lemma ensemble_invariant_sublist : forall prop E a b c, *)
  (*     a ++ b = c -> *)
  (*     E c -> *)
  (*     EnsembleInvariant prop E -> *)
  (*     EnsembleInvariant prop E a. *)

  Lemma e_hoare_concat : forall pre mid post e1 e2,
      -{{pre}} e1 {{mid}} ->
      -{{mid}} e2 {{post}} ->
      -{{pre}} e1 ->> e2 {{post}}.
  Proof.
    intros *. intros H1 H2 t Ht.
    destruct Ht.
    apply hoare_concat with (mid0 := mid); auto.
  Qed.

  Section perm_props.
    Lemma interleaving_symm : forall {TE} (t1 t2 t : list TE),
      Interleaving t1 t2 t ->
      Interleaving t2 t1 t.
    Proof.
      intros.
      induction H; constructor; auto.
    Qed.

    Lemma interleaving_nil : forall {ctx} t1 t2,
        @Interleaving ctx [] t1 t2 ->
        t1 = t2.
    Proof.
      intros.
      remember [] as t.
      induction H; subst; try easy.
      rewrite IHInterleaving; auto.
    Qed.

    Lemma interleaving_par_head : forall (t1 t2 t : list TE),
        Interleaving t1 t2 t ->
        exists t' t1_hd t1_tl,
          t = t1_hd ++ t' /\ t1 = t1_hd ++ t1_tl /\ Interleaving t1_tl t2 t'.
    Proof with auto with slot; firstorder.
      intros *. intros Hint.
      induction Hint.
      - destruct IHHint as [t' [t1_hd [t1_tl IH]]].
        exists t'. exists (te :: t1_hd). exists (t1_tl).
        firstorder; subst; reflexivity.
      - exists (te :: t). exists []. exists t1...
      - exists []. exists []. exists []...
    Qed.

    Lemma e_hoare_par_ergo_seq : forall e1 e2 P Q,
      -{{P}} e1 -|| e2 {{Q}} ->
      -{{P}} e1 ->> e2 {{Q}}.
    Proof.
      intros. intros t Hseq.
      eapply H. clear H.
      destruct Hseq as [t1 t2].
      eapply ilv_par; eauto with slot.
      clear H H0.
      induction t1; induction t2; simpl; auto with slot.
    Qed.

    Lemma e_hoare_par_symm : forall e1 e2 P Q,
        -{{P}} e1 -|| e2 {{Q}} ->
        -{{P}} e2 -|| e1 {{Q}}.
    Proof.
      intros. intros t Hpar.
      eapply H. clear H.
      destruct Hpar as [t1 t2 t H1 H2 Hint].
      apply interleaving_symm in Hint.
      eapply ilv_par; eauto.
    Qed.

    Lemma interl_app_tl : forall (b c__hd c__tl t : list TE),
        Interleaving b c__tl t ->
        Interleaving b (c__hd ++ c__tl) (c__hd ++ t).
    Proof.
      intros.
      induction c__hd; simpl; auto with slot.
    Qed.

    Lemma interl_app_hd : forall (a c__hd c__tl t : list TE),
        Interleaving a c__hd t ->
        Interleaving a (c__hd ++ c__tl) (t ++ c__tl).
    Proof with simpl; auto with slot.
      intros.
      induction H...
      induction c__tl...
    Qed.

    Example no_swapping_heads_is_not_always_impossible : forall (a b c : TE),
        a <> b -> b <> c -> a <> c ->
        exists t,
          Interleaving [a; b] [c] t ->
          ~Interleaving [b] [a; c] t.
    Proof.
      intros a b c Hab Hbc Hac.
      exists [c; a; b]. intros H H'.
      repeat match goal with
             | [H : Interleaving _ _ _ |- _] => inversion H; clear H
             end; subst; contradiction.
    Qed.

    Lemma interleaving_nil_r : forall (a b : list TE),
        Interleaving a b [] ->
        a = [] /\ b = [].
    Proof.
      intros.
      remember [] as t.
      destruct H; try discriminate; firstorder.
    Qed.

    Theorem e_hoare_inv_par : forall e1 e2 prop,
        EnsembleInvariant prop e1 ->
        EnsembleInvariant prop e2 ->
        EnsembleInvariant prop (e1 -|| e2).
    Proof with constructor; auto.
      intros e1 e2 prop He1 He2.
      intros t [t1 t2 t12 Ht1 Ht2 Hint].
      specialize (He1 t1 Ht1). clear Ht1.
      specialize (He2 t2 Ht2). clear Ht2.
      induction Hint; try assumption.
      - inversion_ He1...
      - inversion_ He2...
    Qed.

    Lemma e_hoare_inv_seq : forall e1 e2 prop,
        EnsembleInvariant prop e1 ->
        EnsembleInvariant prop e2 ->
        EnsembleInvariant prop (e1 ->> e2).
    Proof.
      intros e1 e2 prop He1 He2.
      intros t [t1 t2 Ht1 Ht2].
      specialize (He1 t1 Ht1). clear Ht1.
      specialize (He2 t2 Ht2). clear Ht2.
      induction t1.
      - easy.
      - inversion He1.
        constructor; auto.
    Qed.

    Lemma interleaving_par_seq : forall (a b c t : list TE),
        Interleaving (a ++ b) c t ->
        exists c1 c2 t1 t2,
          t1 ++ t2 = t /\ c1 ++ c2 = c /\
          Interleaving a c1 t1 /\ Interleaving b c2 t2.
    Proof with auto with slot; firstorder.
      intros.
      remember (a ++ b) as ab.
      generalize dependent b.
      generalize dependent a.
      induction H as [te ab c t H IH| te ab c t H IH| ]; intros.
      - destruct a; [destruct b; inversion_ Heqab | idtac]; simpl in *.
        + exists []. exists c. exists []. exists (t0 :: t)...
        + inversion Heqab. subst.
          specialize (IH a b eq_refl).
          destruct IH as [c1 [c2 [t1 [t2 [Ht [Ht2 [Hint1 Hint2]]]]]]]; subst.
          exists c1. exists c2. exists (t0 :: t1). exists t2...
      - specialize (IH a b Heqab).
        destruct IH as [c1 [c2 [t1 [t2 [Ht [Ht2 [Hint1 Hint2]]]]]]]; subst.
        exists (te :: c1). exists c2. exists (te :: t1). exists t2...
      - symmetry in Heqab. apply app_eq_nil in Heqab.
        destruct Heqab. subst.
        exists []. exists []. exists []. exists []...
    Qed.

    Lemma e_hoare_par_seq1 : forall e1 e2 e P Q,
        (* -{{P}} e1 -|| e {{Q}} -> *)
        (* -{{Q}} e2 -|| e {{Q}} -> *)
        (* -{{P}} e1 ->> e2 {{Q}} -> *)
        -{{P}} e1 ->> e2 -|| e {{Q}}.
    Proof.
      intros *. (* intros Hpar1 Hpar2 Hseq. *)
      intros t Ht.
      destruct Ht as [t12 t_ t H12 Ht_ Hint].
      destruct H12 as [t1 t2 H1 H2].
      (*   t_, t, t1, t2 : list TE
           H1 : e1 t1
           H2 : e2 t2
           Ht_ : e t_
           Hint : Interleaving (t1 ++ t2) t_ t
       *)
    Abort.

    Lemma e_hoare_par_seq : forall e1 e2 e P Q R,
        -{{P}} e1 -|| e {{Q}} ->
        -{{Q}} e2 -|| e {{R}} ->
        -{{P}} e1 ->> e2 -|| e {{R}}.
    Proof.
      intros *. intros H1 H2 t Ht s s' Hss' Hpre.
      destruct Ht as [t1 t2 t Ht1 Ht2 Hint].
    Abort. (* This is wrong? *)
  End perm_props.

  Section ensemble_equiv.
    Context (e1 e2 : @TraceEnsemble TE).

    Definition sufficient_replacement :=
      forall t s s', e1 t ->
                ReachableByTrace s t s' ->
                exists t', e2 t' /\ ReachableByTrace s t' s'.

    Definition sufficient_replacement_p :=
      forall t, e1 t ->
           exists t', e2 t' /\ Permutation trace_elems_commute t t'.

    Theorem ht_sufficient_replacement P Q :
      sufficient_replacement ->
      -{{P}} e2 {{Q}} -> -{{P}} e1 {{Q}}.
    Proof.
      intros He2 H t Ht s s' Hls Hpre.
      destruct (He2 t s s' Ht Hls) as [t' [Ht' Hls']].
      eapply H; eauto.
    Qed.

    Lemma comm_perm_sufficient_replacement :
      sufficient_replacement_p ->
      sufficient_replacement.
    Proof.
      intros H t s s' Ht Hls.
      destruct (H t Ht) as [t' [Ht' Hperm]].
      eapply ht_comm_perm in Hperm; eauto.
    Qed.
  End ensemble_equiv.

  Lemma sufficient_replacement_p_trans :
    transitive (@TraceEnsemble TE) sufficient_replacement_p.
  Proof.
    intros e1 e2 e3 H12 H23. intros t Ht.
    apply H12 in Ht. destruct Ht as [t' [Ht' Hperm']].
    apply H23 in Ht'. destruct Ht' as [t'' [Ht'' Hperm'']].
    exists t''. split.
    - assumption.
    - eapply permut_trans; eauto.
  Qed.

  Section uniq_correct.
    Context (Hcomm_dec : forall a b, trace_elems_commute a b \/ not (trace_elems_commute a b)).

    Lemma uniq_ilv_ergo_ilv t1 t2 t :
      UniqueInterleaving t1 t2 t ->
      Interleaving t1 t2 t.
    Proof.
      intros.
      induction H; try constructor; auto.
      induction t; constructor.
      easy.
    Qed.

    Lemma uilv_nil_l : forall t, UniqueInterleaving t [] t.
    Proof.
      now induction t; constructor.
    Qed.

    Fixpoint uilv_append_r te (t1 t2 t : list TE)
             (Ht : UniqueInterleaving t1 t2 t)
             (s s' s'' : S) (Hls : ReachableByTrace s' t s'')
             (Hte : s ~[te]~> s')
             {struct Ht} :
      exists t', UniqueInterleaving t1 (te :: t2) t' /\ ReachableByTrace s t' s''.
    Proof with repeat (try assumption ; constructor); auto.
      destruct Ht.
      - long_step Hls.
        destruct (Hcomm_dec l te) as [Hcomm|Hcomm].
        + assert (Hx : ReachableByTrace s [te; l] s0).
          { forward s'...
            forward s0...
          }
          eapply Hcomm in Hx.
          repeat long_step Hx. subst.
          eapply uilv_append_r in Hcr1; eauto.
          destruct Hcr1 as [t' [Ht' Hls']].
          exists (l :: t').
          split...
          forward s1...
        + exists (te :: l :: t).
          split...
          forward s'...
          forward s0...
      - exists (te :: r :: l :: t).
        split...
        forward s'...
      - exists (te :: r2 :: r1 :: t).
        split...
        forward s'...
      - exists (te :: t).
        split...
        forward s'...
    Qed.

    Fixpoint canonicalize_ilv (t1 t2 t : list TE) (Ht : Interleaving t1 t2 t)
                              (s s' : S) (Hls : ReachableByTrace s t s')
                              {struct Ht} :
      exists t', UniqueInterleaving t1 t2 t' /\ ReachableByTrace s t' s'.
    Proof with repeat constructor; auto.
      destruct Ht; try long_step Hls.
      - destruct (canonicalize_ilv t1 t2 t Ht s0 s' Hls) as [t' [Ht' Hls']].
        exists (te :: t').
        split...
        forward s0...
      - destruct (canonicalize_ilv t1 t2 t Ht s0 s' Hls) as [t' [Ht' Hls']].
        apply (uilv_append_r te t1 t2 t' Ht' s s0 s' Hls' Hcr).
      - exists []...
    Defined.

    Lemma uniq_ilv_correct P Q t1 t2 :
      -{{P}} UniqueInterleaving t1 t2 {{Q}} ->
      -{{P}} Interleaving t1 t2 {{Q}}.
    Proof.
      intros Huilv t Ht. unfold_ht.
      destruct (canonicalize_ilv t1 t2 t Ht s_begin s_end Hls) as [t' [Ht' Hls']].
      eapply Huilv; eauto.
    Qed.
  End uniq_correct.
End props.

Ltac clear_equations :=
  repeat match goal with
           [H: ?a = ?a |- _] => clear H
         end.

Ltac destruct_interleaving H :=
  match type of H with
    Interleaving ?a ?b ?c =>
    let a0 := fresh in
    let b0 := fresh in
    let Ha := fresh in
    let Hb := fresh in
    remember a as a0 eqn:Ha; remember b as b0 eqn:Hb;
    destruct H; inversion Ha; inversion Hb; subst; try discriminate;
    clear_equations
  end.

Ltac destruct_uinterleaving H :=
  match type of H with
    UniqueInterleaving ?a ?b ?c =>
    let a0 := fresh in
    let b0 := fresh in
    let Ha := fresh in
    let Hb := fresh in
    remember a as a0 eqn:Ha; remember b as b0 eqn:Hb;
    destruct H; inversion Ha; inversion Hb; subst; try discriminate;
    clear_equations
  end.

Ltac interleaving_nil :=
  repeat match goal with
         | [H: Interleaving [] ?t1 ?t |- _] => apply interleaving_nil in H; try subst t
         | [H: Interleaving ?t1 [] ?t |- _] => apply interleaving_symm, interleaving_nil in H; try subst t
         end.

Hint Extern 4 => interleaving_nil : slot.

Ltac unfold_interleaving H tac :=
  simpl in H;
  lazymatch type of H with
  | Interleaving [] _ _ =>
    apply interleaving_nil in H;
    try (rewrite <-H in *; clear H);
    repeat tac
  | Interleaving _ [] _ =>
    apply interleaving_symm, interleaving_nil in H;
    try (rewrite <-H in *; clear H);
    repeat tac
  | Interleaving ?tl ?tr ?t =>
    let te := fresh "te" in
    let tl' := fresh "tl" in
    let tr' := fresh "tr" in
    let t := fresh "t" in
    (* stuff that we need in order to eliminate wrong hypotheses *)
    let tl0 := fresh "tl" in let Htl0 := fresh "Heql" in remember tl as tl0 eqn:Htl0;
    let tr0 := fresh "tr" in let Htr0 := fresh "Heqr" in remember tr as tr0 eqn:Htr0;
    destruct H as [te tl' tr' t H | te tl' tr' t H |];
    repeat (match goal with
            | [H : _ :: _ = _ |- _] =>
              inversion H; subst; clear H
            end);
    try discriminate;
    subst;
    tac;
    unfold_interleaving H tac
  | ?err =>
    fail "Not an unfoldable interleaving" err
  end.

Tactic Notation "unfold_interleaving" ident(H) "with" tactic(tac) :=
  unfold_interleaving H tac.

Tactic Notation "unfold_interleaving" ident(H) :=
  unfold_interleaving H with idtac.

Section permutation.
  Context {S PID Req : Type} {Ret : Req -> Type}.
  Let TE := @TraceElem PID Req Ret.
  Context `{HsspS : StateSpace S TE}.

  Definition can_swap (a b : TE) : Prop :=
    te_pid a <> te_pid b.

  Definition DoubleForall {X} (f : X -> X -> Prop) (l1 l2 : list X) : Prop :=
    Forall (fun a => (Forall (f a) l1)) l2.

  Lemma DoubleForall_drop {X} f (a : X) l1 l2 :
    Forall (fun a0 : X => Forall (f a0) (a :: l1)) l2 ->
    Forall (fun a0 : X => Forall (f a0) l1) l2.
  Proof.
    intros H.
    induction l2; sauto.
  Qed.

  Lemma DoubleForall_symm {X} f (l1 l2 : list X) :
    DoubleForall f l1 l2 -> DoubleForall f l2 l1.
  Admitted. (* TODO *)

  Lemma interleaving_to_permutation t1 t2 t :
    DoubleForall can_swap t2 t1 ->
    Interleaving t1 t2 t ->
    @Permutation _ can_swap (t1 ++ t2) t.
  Proof.
    intros Hdisjoint H.
    induction H.
    3:{ simpl. constructor. }
    { apply Forall_inv_tail in Hdisjoint.
      now apply permut_cons, IHInterleaving.
    }
    { specialize (DoubleForall_drop can_swap te t2 t1 Hdisjoint) as Htail.
      specialize (IHInterleaving Htail). clear Htail. clear H.
      apply DoubleForall_symm, Forall_inv in Hdisjoint.
      apply permut_cons with (a := te) in IHInterleaving.
      induction IHInterleaving; try now constructor.
      induction t1.
      - constructor.
      - specialize (perm_shuf can_swap ((a :: t1) ++ te :: t2) [] (t1 ++ t2) a te) as Hs.
        simpl in *.
        apply Hs.
        + apply permut_cons, IHt1.
          now apply Forall_inv_tail in Hdisjoint.
        + apply Forall_inv in Hdisjoint.
          symm_not. apply Hdisjoint.
    }
  Qed.
End permutation.

Ltac resolve_forall :=
  match goal with
  | [H : Forall (trace_elems_commute ?a) (?x :: ?t) |- Forall (trace_elems_commute ?a) ?t] =>
    apply Forall_inv_tail in H; assumption
  | [H : Forall (trace_elems_commute ?a) (?x :: ?t) |- trace_elems_commute ?a ?x] =>
    apply Forall_inv in H; assumption
  end.

Hint Extern 1 (Forall (trace_elems_commute _) _) => resolve_forall : slot.
Hint Extern 3 (trace_elems_commute _ _) => resolve_forall : slot.

Section properties.
  Context `{HSSp : StateSpace}.

  Fixpoint num_interleavings (a b : nat) : nat :=
    match a, b with
    | 0, _   => 1
    | _, 0   => 1
    | _, S b => fold_left (fun acc i => acc + (num_interleavings i b)) (seq 0 (S a)) 0
    end.

  Goal forall (a b c d e f g h i j k : TE) s s' t,
      trace_elems_commute a d ->
      trace_elems_commute a c ->
      ReachableByTrace s t s' ->
      Interleaving [a; b; e; f; g] [c; d; i] t ->
      False.
  Proof.
    intros.
    Compute num_interleavings 5 3. (* 56 *)
    repeat (match goal with
            | [H : Interleaving (?a :: ?t1) ?t2 ?t |- _ ] =>
              destruct_interleaving H
            | [H : Interleaving ?t2 (?a :: ?t1) ?t |- _ ] =>
              inversion_ H; clear H
            | [H : Interleaving [] [] ?t |- _ ] =>
              inversion H; clear H
            end; try contradiction);
    let n := numgoals in guard n = 56.
  Abort.

  Let comm_diff a b := num_interleavings a b - (num_interleavings (a - 1) (b - 1)).

  Lemma comm_ilv_ls s s' a t t' :
    Forall (trace_elems_commute a) t ->
    Interleaving [a] t t' ->
    ReachableByTrace s t' s' ->
    ReachableByTrace s (a :: t) s'.
  Proof with auto with slot.
    intros Hcomm Ht Ht'.
    generalize dependent s'.
    generalize dependent s.
    remember [a] as t1.
    induction Ht; intros; inversion_ Heqt1...
    apply trace_elems_commute_head...
    inversion_ Ht'.
    forward s'0...
  Qed.

  Lemma ilv_singleton_comm_all a t2 P Q :
    Forall (trace_elems_commute a) t2 ->
    {{P}} [a] {{P}} ->
    {{P}} t2 {{Q}} ->
    -{{P}} Interleaving [a] t2 {{Q}}.
  Proof with auto with slot.
    intros Hcomm Ha Ht2 t Ht.
    remember [a] as t1.
    destruct Ht; inversion_ Heqt1.
    - interleaving_nil.
      apply hoare_cons with (mid := P)...
    - unfold_ht.
      inversion_ Hls.
      assert (Ha' : {{P}} a :: te :: t2 {{Q}}).
      { apply hoare_cons with (mid := P)... }
      apply trace_elems_commute_head_ht in Ha'...
      specialize (comm_ilv_ls s' s_end a t2 t) as Ht'.
      refine (Ha' s_begin s_end _ _)...
      forward s'...
  Qed.

  Lemma ilv_singleton_vs_app x a b (P Q : S0 -> Prop) :
    -{{P}} Interleaving a [x] ->> eq b {{Q}} ->
    -{{P}} eq a ->> Interleaving b [x] {{Q}} ->
    -{{P}} Interleaving (a ++ b) [x] {{Q}}.
  Proof with auto with slot.
    intros H1 H2 t Ht.
    remember [x] as t1.
    apply interleaving_par_seq in Ht.
    destruct Ht as [c1 [c2 [t2 [t3 [Ht [Hc [Hint1 Hint2]]]]]]].
    subst.
    destruct c1; destruct c2; try discriminate;
      autorewrite with list in *; simpl in *;
      inversion_ Hc.
    exfalso.
    destruct c1; inversion H3.
  Qed.
End properties.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

(** Properties of real sequences. *)
Require Import Max.
Require Export Rseries_facts.
Require Export Rsequence_facts.
Require Import Lra.
Require Import Complex.
Require Import Csequence_facts.
Require Import Cseries.
Open Scope C_scope.
Open Scope Cseq_scope.

Lemma Cser_cv_re_compat : forall Un l, Cser_cv Un l ->
  Rser_cv (fun n : nat => Cre (Un n)) (Cre l).
Proof.
intros Un l HC.
apply Rseq_cv_eq_compat with (fun n => Cre (sum_f_C0 Un n)).
 intro; rewrite sum_f_C0_Cre_compat; trivial.
 apply Cseq_cv_re_compat.
 apply HC.
Qed.

Lemma Cser_cv_im_compat : forall Un l, Cser_cv Un l ->
  Rser_cv (fun n : nat => Cim (Un n)) (Cim l).
Proof.
intros Un l HC.
apply Rseq_cv_eq_compat with (fun n => Cim (sum_f_C0 Un n)).
 intro; rewrite sum_f_C0_Cim_compat; trivial.
 apply Cseq_cv_im_compat.
 apply HC.
Qed.

Lemma Cser_cv_re_im_compat : forall Un l,
  Rser_cv (fun n => Cre (Un n)) (Cre l) ->
  Rser_cv (fun n => Cim (Un n)) (Cim l) ->
  Cser_cv Un l.
Proof.
intros Un l HCre HCim.
apply Cseq_cv_re_im_compat.
 apply Rseq_cv_eq_compat with (sum_f_R0 (fun n => Cre (Un n))).
  intro; rewrite <- sum_f_C0_Cre_compat; trivial.
  apply HCre.
 apply Rseq_cv_eq_compat with (sum_f_R0 (fun n => Cim (Un n))).
  intro; rewrite <- sum_f_C0_Cim_compat; trivial.
  apply HCim.
Qed.

Lemma Ccauchy_product : forall An Bn la lb lna,
 Cser_cv An la ->
 Cser_cv Bn lb ->
 Cser_abs_cv An lna ->
 Cser_cv ((fun k:nat => sum_f_C0 (fun p:nat => An p * Bn (k - p)%nat) k)%C)
   (la * lb)%C.
Proof.
intros An Bn la lb lna HA HB HNA.
assert (HNAre : {lnare | Rser_abs_cv (fun n => Cre (An n)) lnare}).
 apply Rser_pos_maj_cv with (fun n => Cnorm (An n)).
  intro; apply Rabs_pos.
  intro; apply Cnorm_pos.
  intro; unfold Rseq_abs; apply Cre_le_Cnorm.
  exists lna; apply HNA.
destruct HNAre as [lnare HNAre].

assert (HNAim : {lnaim | Rser_abs_cv (fun n => Cim (An n)) lnaim}).
 apply Rser_pos_maj_cv with (fun n => Cnorm (An n)).
  intro; apply Rabs_pos.
  intro; apply Cnorm_pos.
  intro; unfold Rseq_abs; apply Cim_le_Cnorm.
  exists lna; apply HNA.
destruct HNAim as [lnaim HNAim].

apply Cser_cv_re_im_compat.
 rewrite Cre_mul.
 apply Rser_cv_ext with (fun k =>
   sum_f_R0 (fun p => ((Cre (An p) * Cre (Bn (k - p)%nat)))%R) k -
   sum_f_R0 (fun p => ((Cim (An p) * Cim (Bn (k - p)%nat)))%R) k )%R.
  repeat (intro; rewrite <- sum_f_C0_Cre_compat; rewrite <- minus_sum; apply Rseq_sum_ext).
  intro; rewrite <- Cre_mul; trivial.

  apply Rser_cv_minus_compat.
   eapply (Rser_cv_prod_compat (fun n => Cre (An n)) (fun n => Cre (Bn n)));
     try (apply Cser_cv_re_compat; auto).
   apply HNAre.

   eapply (Rser_cv_prod_compat (fun n => Cim (An n)) (fun n => Cim (Bn n)));
     try (apply Cser_cv_im_compat; auto).
   apply HNAim.

 rewrite Cim_mul.
 apply Rser_cv_ext with (fun k =>
   sum_f_R0 (fun p => ((Cre (An p) * Cim (Bn (k - p)%nat)))%R) k +
   sum_f_R0 (fun p => ((Cim (An p) * Cre (Bn (k - p)%nat)))%R) k )%R.
  intro; rewrite <- sum_f_C0_Cim_compat ; rewrite <- plus_sum ; apply Rseq_sum_ext.
  intro; rewrite Cim_mul; ring.

  apply Rser_cv_plus_compat.
   eapply (Rser_cv_prod_compat (fun n => Cre (An n)) (fun n => Cim (Bn n))).
    apply Cser_cv_re_compat; auto.
    apply Cser_cv_im_compat; auto.
    apply HNAre.

   rewrite Rmult_comm.
   eapply (Rser_cv_prod_compat (fun n => Cim (An n)) (fun n => Cre (Bn n))).
    apply Cser_cv_im_compat; auto.
    apply Cser_cv_re_compat; auto.
    apply HNAim.
Qed.

Lemma Cser_cv_unique : forall Un l1 l2, Cser_cv Un l1 -> Cser_cv Un l2 -> l1 = l2.
Proof.
intros Un l1 l2 H H'.
apply Cseq_cv_unique with (sum_f_C0 Un); auto.
Qed.

Lemma Csum_eq_compat_weak : forall Un Vn n,
  (forall j, Un j = Vn j) -> sum_f_C0 Un n = sum_f_C0 Vn n.
Proof.
intros Un Vn n H.
induction n.
 apply H.
 simpl; rewrite H; rewrite IHn; trivial.
Qed.

Lemma Csum_eq_compat : forall Un Vn n,
  (forall j, (j <= n)%nat -> Un j = Vn j) -> sum_f_C0 Un n = sum_f_C0 Vn n.
Proof.
intros Un Vn n H.
induction n.
 apply H; omega.
 simpl; rewrite H; try omega.
 rewrite IHn; trivial.
 intros j Hj.
 apply H; omega.
Qed.

Lemma Cser_cv_eq_compat : forall Un Vn l,
  (forall j, Un j = Vn j) -> Cser_cv Un l -> Cser_cv Vn l.
Proof.
intros Un Vn l H HC.
apply Cseq_cv_eq_compat with (sum_f_C0 Un).
 intro; apply Csum_eq_compat_weak; apply H.
 apply HC.
Qed.


From isla Require Import opsem.

Definition a4 : isla_trace :=
  Smt (DeclareConst 50%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 50%Z)) Mk_annot :t:
  Smt (DefineConst 56%Z (Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot; Val (Val_Symbolic 50%Z) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R28" [] (RegVal_Base (Val_Symbolic 56%Z)) Mk_annot :t:
  Smt (DeclareConst 57%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 57%Z)) Mk_annot :t:
  Smt (DefineConst 58%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 57%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 58%Z)) Mk_annot :t:
  tnil
.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
From Fairness Require Import pind_internal.
Set Implicit Arguments.

Section PIND4.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.

(** ** Predicates of Arity 4
*)

Definition pind4(gf : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)(r: rel4 T0 T1 T2 T3) : rel4 T0 T1 T2 T3 :=
  @curry4 T0 T1 T2 T3 (pind (fun R0 => @uncurry4 T0 T1 T2 T3 (gf (@curry4 T0 T1 T2 T3 R0))) (@uncurry4 T0 T1 T2 T3 r)).

Definition upind4(gf : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)(r: rel4 T0 T1 T2 T3) := pind4 gf r /4\ r.
Arguments pind4 : clear implicits.
Arguments upind4 : clear implicits.
#[local] Hint Unfold upind4 : core.

Lemma monotone4_inter (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)
      (MON1: monotone4 gf)
      (MON2: monotone4 gf'):
  monotone4 (gf /5\ gf').
Proof.
  red; intros. destruct IN. split; eauto.
Qed.

Lemma _pind4_mon_gen (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r r'
    (LEgf: gf <5= gf')
    (LEr: r <4= r'):
  pind4 gf r <4== pind4 gf' r'.
Proof.
  apply curry_map4. red; intros. eapply pind_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma pind4_mon_gen (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r r' x0 x1 x2 x3
    (REL: pind4 gf r x0 x1 x2 x3)
    (LEgf: gf <5= gf')
    (LEr: r <4= r'):
  pind4 gf' r' x0 x1 x2 x3.
Proof.
  eapply _pind4_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma pind4_mon_bot (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r' x0 x1 x2 x3
    (REL: pind4 gf bot4 x0 x1 x2 x3)
    (LEgf: gf <5= gf'):
  pind4 gf' r' x0 x1 x2 x3.
Proof.
  eapply pind4_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Definition top4 { T0 T1 T2 T3} (x0: T0) (x1: T1 x0) (x2: T2 x0 x1) (x3: T3 x0 x1 x2) := True.

Lemma pind4_mon_top (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r x0 x1 x2 x3
    (REL: pind4 gf r x0 x1 x2 x3)
    (LEgf: gf <5= gf'):
  pind4 gf' top4 x0 x1 x2 x3.
Proof.
  eapply pind4_mon_gen; eauto. red. auto.
Qed.

Lemma upind4_mon_gen (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r r' x0 x1 x2 x3
    (REL: upind4 gf r x0 x1 x2 x3)
    (LEgf: gf <5= gf')
    (LEr: r <4= r'):
  upind4 gf' r' x0 x1 x2 x3.
Proof.
  destruct REL. split; eauto.
  eapply pind4_mon_gen; [apply H | apply LEgf | apply LEr].
Qed.

Lemma upind4_mon_bot (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r' x0 x1 x2 x3
    (REL: upind4 gf bot4 x0 x1 x2 x3)
    (LEgf: gf <5= gf'):
  upind4 gf' r' x0 x1 x2 x3.
Proof.
  eapply upind4_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upind4mon_top (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r x0 x1 x2 x3
    (REL: upind4 gf r x0 x1 x2 x3)
    (LEgf: gf <5= gf'):
  upind4 gf' top4 x0 x1 x2 x3.
Proof.
  eapply upind4_mon_gen; eauto. red. auto.
Qed.

Section Arg4.

Variable gf : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3.
Arguments gf : clear implicits.

Theorem _pind4_mon: _monotone4 (pind4 gf).
Proof.
  red; intros. eapply curry_map4, _pind_mon; apply uncurry_map4; assumption.
Qed.

Theorem _pind4_acc: forall
  l r (OBG: forall rr (DEC: rr <4== r) (IH: rr <4== l), pind4 gf rr <4== l),
  pind4 gf r <4== l.
Proof.
  intros. apply curry_adjoint2_4.
  eapply _pind_acc. intros.
  apply curry_adjoint2_4 in DEC. apply curry_adjoint2_4 in IH.
  apply curry_adjoint1_4.
  eapply le4_trans. 2: eapply (OBG _ DEC IH).
  apply curry_map4.
  apply _pind_mon; try apply le1_refl; apply curry_bij2_4.
Qed.

Theorem _pind4_mult_strong: forall r,
  pind4 gf r <4== pind4 gf (upind4 gf r).
Proof.
  intros. apply curry_map4.
  eapply le1_trans; [eapply _pind_mult_strong |].
  apply _pind_mon; intros [] H. apply H.
Qed.

Theorem _pind4_fold: forall r,
  gf (upind4 gf r) <4== pind4 gf r.
Proof.
  intros. apply uncurry_adjoint1_4.
  eapply le1_trans; [| apply _pind_fold]. apply le1_refl.
Qed.

Theorem _pind4_unfold: forall (MON: _monotone4 gf) r,
  pind4 gf r <4== gf (upind4 gf r).
Proof.
  intros. apply curry_adjoint2_4.
  eapply _pind_unfold; apply monotone4_map; assumption.
Qed.

Theorem pind4_acc: forall
  l r (OBG: forall rr (DEC: rr <4= r) (IH: rr <4= l), pind4 gf rr <4= l),
  pind4 gf r <4= l.
Proof.
  apply _pind4_acc.
Qed.

Theorem pind4_mon: monotone4 (pind4 gf).
Proof.
  apply monotone4_eq.
  apply _pind4_mon.
Qed.

Theorem upind4_mon: monotone4 (upind4 gf).
Proof.
  red; intros.
  destruct IN. split; eauto.
  eapply pind4_mon. apply H. apply LE.
Qed.

Theorem pind4_mult_strong: forall r,
  pind4 gf r <4= pind4 gf (upind4 gf r).
Proof.
  apply _pind4_mult_strong.
Qed.

Corollary pind4_mult: forall r,
  pind4 gf r <4= pind4 gf (pind4 gf r).
Proof. intros; eapply pind4_mult_strong in PR. eapply pind4_mon; eauto. intros. destruct PR0. eauto. Qed.

Theorem pind4_fold: forall r,
  gf (upind4 gf r) <4= pind4 gf r.
Proof.
  apply _pind4_fold.
Qed.

Theorem pind4_unfold: forall (MON: monotone4 gf) r,
  pind4 gf r <4= gf (upind4 gf r).
Proof.
  intro. eapply _pind4_unfold; apply monotone4_eq; assumption.
Qed.

End Arg4.

Arguments pind4_acc : clear implicits.
Arguments pind4_mon : clear implicits.
Arguments upind4_mon : clear implicits.
Arguments pind4_mult_strong : clear implicits.
Arguments pind4_mult : clear implicits.
Arguments pind4_fold : clear implicits.
Arguments pind4_unfold : clear implicits.

End PIND4.

Global Opaque pind4.

#[export] Hint Unfold upind4 : core.
#[export] Hint Resolve pind4_fold : core.
#[export] Hint Unfold monotone4 : core.


(** Not working for now. *)
Set Implicit Arguments.

Record Monad (M : Type -> Type) : Type := {
  ret : forall A, A -> M A;
  bind : forall A B, M A -> (A -> M B) -> M B}.

Record Morphism (M1 M2 : Type -> Type) : Type := {
  lift : forall A, M1 A -> M2 A}.

Definition app (M1 M2 M3 M4 : Type -> Type) (T1 T2 : Type)
  (monad1 : Monad M1) (monad2 : Monad M2) (monad3 : Monad M3) (monad4 : Monad M4)
  (f14 : Morphism M1 M4) (f24 : Morphism M2 M4) (f34 : Morphism M3 M4)
  (e1 : M1 (T2 -> M3 T1)) (e2 : M2 T2)
  : M4 T1 :=
  bind monad4 _ (lift f14 _ e1) (fun f =>
  bind monad4 _ (lift f24 _ e2) (fun x =>
    lift f34 _ (f x))).

Definition Id : Monad (fun A => A) := {|
  ret A x := x;
  bind A B x f := f x |}.

Definition Option : Monad option := {|
  ret A x := Some x;
  bind A B x f :=
    match x with
    | Some x' => f x'
    | None => None
    end |}.

Definition identity_morphism (M : Type -> Type) : Morphism M M := {|
  lift A x := x |}.

Definition IdOfId := identity_morphism (fun A => A).

Definition OptionOfOption := identity_morphism option.

Definition OptionOfId : Morphism (fun A => A) option := {|
  lift A x := Some x |}.

Canonical Structure Id.
Canonical Structure Option.

Canonical Structure IdOfId.
Canonical Structure OptionOfOption.
Canonical Structure OptionOfId.

(** Inference does not seem to work for us with canonical structures *)
Definition gre :=
  app (M1 := fun A => A) (M2 := option) (M3 := option) (M4 := option)
    nat nat
    Id Option Option Option
    OptionOfId OptionOfOption OptionOfOption
    (ret Id (fun n => ret Option n)) (ret Option 23).


Set Primitive Projections.
Set Implicit Arguments.
Record sigT {A} (P : A -> Type) := existT { projT1 : A ; projT2 : P projT1 }.
Definition eta_sigma {A} {P : A -> Type} (u : sigT P)
  : existT _ (projT1 u) (projT2 u) = u
  := match u with existT _ x y => eq_refl end. (* Toplevel input, characters 0-139:
Error: Pattern-matching expression on an object of inductive type sigT
has invalid information. *)
Definition sum_of_sigT A B (x : sigT (fun b : bool => if b then A else B))
: A + B
  := match x with
       | existT _ true a => inl a
       | existT _ false b => inr b
     end. (* Toplevel input, characters 0-182:
Error: Pattern-matching expression on an object of inductive type sigT
has invalid information. *)


Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.StringBound
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple.

(* A relation schema is a heading for the tuples of the
   relation and constraints on the members
   (usually functional dependencies). *)

Record RawSchema :=
  { rawSchemaHeading : RawHeading;
    attrConstraints: option (@RawTuple rawSchemaHeading
                             -> Prop);
    tupleConstraints: option (@RawTuple rawSchemaHeading
                             -> @RawTuple rawSchemaHeading
                             -> Prop)
  }.

Record Schema :=
  { schemaRaw :> RawSchema;
    schemaHeadingNames : Vector.t string (NumAttr (rawSchemaHeading schemaRaw)) }.

Definition schemaHeading (sch : Schema) : Heading :=
  {| HeadingRaw := rawSchemaHeading (schemaRaw sch);
     HeadingNames := schemaHeadingNames sch |}.

Class HeadingHint :=
  { headingHint : Heading }.

(* A notation for functional dependencies. *)
Definition tupleAgree
           {h : RawHeading}
           (tup1 tup2 : @RawTuple h) attrlist :=
  forall attr,
    List.In attr attrlist ->
    GetAttributeRaw tup1 attr = GetAttributeRaw tup2 attr.

Definition AttributeList {hHint : HeadingHint}
  := list (Attributes headingHint).

Definition UniqueAttribute' {heading : RawHeading}
           attr
           (tup1 tup2 : @RawTuple heading) :=
  GetAttributeRaw tup1 attr <> GetAttributeRaw tup2 attr.

Definition UniqueAttribute {heading}
           (attr : BoundedString (HeadingNames heading)) :=
  UniqueAttribute' (ibound (indexb attr)).

Notation "[ attr1 ; .. ; attr2 ] " :=
  (cons (ibound (indexb (@Build_BoundedIndex _ _ (HeadingNames headingHint) attr1%string _)))
        .. (cons
                 (ibound (indexb ((@Build_BoundedIndex _ _  (HeadingNames headingHint) attr2%string _)))) nil) ..)
  : SchemaConstraints_scope.

Notation "[ attr1 ; attr2 ; .. ; attr3 ] " :=
  (cons (ibound (indexb (@Build_BoundedIndex _ _ (HeadingNames headingHint) attr1%string _)))
        (cons (ibound (indexb (@Build_BoundedIndex _ _ (HeadingNames headingHint) attr2%string _)))
              .. (cons
                    (ibound (indexb ((@Build_BoundedIndex _ _  (HeadingNames headingHint) attr3%string _)))) nil) ..))
  : SchemaConstraints_scope.

Definition FunctionalDependency_P
           (hHint : RawHeading)
  :  list (Attributes hHint)
     -> list (Attributes hHint)
     -> @RawTuple hHint
     -> @RawTuple hHint
     -> Prop :=
  fun attrlist1 attrlist2 tup1 tup2 =>
    tupleAgree tup1 tup2 attrlist2 ->
    tupleAgree tup1 tup2 attrlist1.

Notation "'attributes' attrlist1 'depend' 'on' attrlist2 " :=
  (let hint := @headingHint _ in
    (@FunctionalDependency_P hint : list (Attributes hint)
                                          -> list (Attributes hint)
                                          -> @RawTuple hint
                                          -> @RawTuple hint
                                          -> Prop)
     (attrlist1%SchemaConstraints : list (Attributes hint))
     (attrlist2%SchemaConstraints : list (Attributes hint)))
  : SchemaConstraints_scope.

(* Notations for Schemas. *)

Notation "'schema' headings' 'where' aconstraints 'and' tupconstraints" :=
  (let headings := headings'%Heading in
   {| schemaRaw :=
       {| rawSchemaHeading := headings;
          attrConstraints := @Some (@RawTuple headings
                                    -> Prop) (let hHint := {|headingHint := headings |} in
                                              aconstraints%SchemaConstraints);
          tupleConstraints :=
            @Some (@RawTuple headings
                   -> @RawTuple headings
                   -> Prop) (let hHint := {|headingHint := headings |} in
                             tupconstraints%SchemaConstraints) |};
     schemaHeadingNames := HeadingNames headings |})
       : Schema_scope.

Notation "'schema' headings' 'where' constraints" :=
    (let headings := headings'%Heading in
   {| schemaRaw :=
       {| rawSchemaHeading := headings;
          attrConstraints := None;
          tupleConstraints :=
            @Some (@RawTuple headings
                   -> @RawTuple headings
                   -> Prop) (let hHint := {|headingHint := headings |} in
                             constraints%SchemaConstraints) |};
      schemaHeadingNames := HeadingNames headings |})

       : Schema_scope.

Notation "'schema' headings'" :=
      (let headings := headings'%Heading in
       {| schemaRaw :=
            {| rawSchemaHeading := headings;
               attrConstraints := None;
               tupleConstraints := None |};
          schemaHeadingNames := HeadingNames headings |})
       : Schema_scope.


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

(* $Date: 2011-05-07 16:41:12 -0400 (Sat, 07 May 2011) $ *)

Require Export Imp.
Require Import Relations.

(** 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.
    At the end of the chapter, we'll see how to apply the same
    techniques to the full Imp language. *)

Inductive tm : Type :=
  | tm_const : nat -> tm
  | tm_plus : tm -> tm -> tm.

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

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
  | tm_const n => n
  | tm_plus a1 a2 => eval a1 + eval a2
  end.

End SimpleArith0.

Module SimpleArith1.

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

                               t1 || n1
                               t2 || n2
                        ---------------------                          (E_Plus)
                        t1 + t2 || plus n1 n2
]]]
    We write [plus n1 n2] in the second rule, rather than [n1 + n2],
    to emphasize the fact that the [+] on the left of the [||] is an
    abstract-syntax-tree node while the addition on the right of the
    [||] is the mathematical sum of the numbers [n1] and [n2].  The
    formal Coq version of the definition is more pedantic about this
    distinction: *)

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

Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n,
      tm_const n || n
  | E_Plus : forall t1 t2 n1 n2,
      t1 || n1 ->
      t2 || n2 ->
      tm_plus t1 t2 || plus n1 n2

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

End SimpleArith1.

(** Here is a slight variation, still in big-step style, where
    the final result of evaluating a term is also a term, rather than
    a bare number. *)

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

Inductive eval : tm -> tm -> Prop :=
  | E_Const : forall n1,
        tm_const n1 || tm_const n1
  | E_Plus : forall t1 n1 t2 n2,
        t1 || tm_const n1 ->
        t2 || tm_const n2 ->
        tm_plus t1 t2 || tm_const (plus n1 n2)

  where " t '||' t' " := (eval t t').

(** (Note that this doesn't change anything in the informal rules,
    where we are eliding the distinction between the constant _term_
    [n] and the bare _number_ [n].) *)

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

Module SimpleArith2.

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

                              t1 || t1'
                         -------------------                         (ST_Plus1)
                         t1 + t2 || t1' + t2

                              t2 || t2'
                         -------------------                         (ST_Plus2)
                         n1 + t2 || n1 + t2'
]]]
*)
(** Note that we're using variable names here to lighten the notation:
    by convention, [n1] and [n2] refer only to constants (constructed
    with [tm_const]), 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,
      tm_plus (tm_const n1) (tm_const n2) ==> tm_const (plus n1 n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      tm_plus t1 t2 ==> tm_plus t1' t2
  | ST_Plus2 : forall n1 t2 t2',
      t2 ==> t2' ->
      tm_plus (tm_const n1) t2 ==> tm_plus (tm_const n1) t2'

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

(** Things to notice:

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

    - Each step finds the _leftmost_ [tm_plus] 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 [tm_plus] 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 [tm_plus t1 t2] steps
    to [plus t1' t2]: *)

Example test_step_1 :
      tm_plus
        (tm_plus (tm_const 0) (tm_const 3))
        (tm_plus (tm_const 2) (tm_const 4))
      ==>
      tm_plus
        (tm_const (plus 0 3))
        (tm_plus (tm_const 2) (tm_const 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 [tm_plus (tm_const n) t2] steps to [tm_plus (tm_const n)
    t2']: *)

Example test_step_2 :
      tm_plus
        (tm_const 0)
        (tm_plus
          (tm_const 2)
          (tm_plus (tm_const 0) (tm_const 3)))
      ==>
      tm_plus
        (tm_const 0)
        (tm_plus
          (tm_const 2)
          (tm_const (plus 0 3))).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** One interesting 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 a partial function.

    _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 [tm_plus t1 t2] where both [t1] and [t2] are
        constants (by [ST_PlusConstConst]) _and_ one of [t1] or [t2] has
        the form [tm_plus ...].

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

Theorem step_deterministic:
  partial_function step.
Proof.
  unfold partial_function. 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 SimpleArith2.

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

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

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

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

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

      - The _halting states_ of the machine are ones where there is no
        more computation to be done.

    We can then execute a term [t] as follows:

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

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

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

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

Inductive value : tm -> Prop :=
  v_const : forall n, value (tm_const 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 intuitive way: *)
(**
[[[
                        ----------------------              (ST_PlusConstConst)
                        n1 + n2 ==> plus n1 n2

                              t1 || t1'
                         -------------------                         (ST_Plus1)
                         t1 + t2 || t1' + t2

                              t2 || t2'
                         -------------------                         (ST_Plus2)
                         v1 + t2 || 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.  In the Coq version of the rules, we
    use an explicit [value] hypothesis for the same purpose. *)

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

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
          tm_plus (tm_const n1) (tm_const n2)
      ==> tm_const (plus n1 n2)
  | ST_Plus1 : forall t1 t1' t2,
        t1 ==> t1' ->
        tm_plus t1 t2 ==> tm_plus t1' t2
  | ST_Plus2 : forall v1 t2 t2',
        value v1 ->                     (* <----- n.b. *)
        t2 ==> t2' ->
        tm_plus v1 t2 ==> tm_plus 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 [tm_plus t1 t2] where both [t1] and [t2] are
      constants (by [ST_PlusConstConst]) AND one of [t1] or [t2] has
      the form [tm_plus ...].

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

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

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

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

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

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

(** _Theorem_ (_Strong Progress_): 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 = tm_const n]. Then [t] is a [value].

    - Suppose [t = tm_plus 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 [tm_plus 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].  [] *)

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

Theorem strong_progress : forall t,
  value t \/ (exists t', t ==> t').
Proof.
  tm_cases (induction t) Case.
    Case "tm_const". left. apply v_const.
    Case "tm_plus". right. inversion IHt1.
      SCase "l". inversion IHt2.
        SSCase "l". inversion H. inversion H0.
          exists (tm_const (plus n n0)).
          apply ST_PlusConstConst.
        SSCase "r". inversion H0 as [t' H1].
          exists (tm_plus t1 t').
          apply ST_Plus2. apply H. apply H1.
      SCase "r". inversion H as [t' H0].
          exists (tm_plus t' t2).
          apply ST_Plus1. apply H0.  Qed.

(** 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 (tm_const n)
| v_funny : forall t1 n2,                       (* <---- *)
              value (tm_plus t1 (tm_const n2)).

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

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      tm_plus (tm_const n1) (tm_const n2) ==> tm_const (plus n1 n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      tm_plus t1 t2 ==> tm_plus t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      tm_plus v1 t2 ==> tm_plus v1 t2'

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

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

End 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 (tm_const n).

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

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

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

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

End 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 (tm_const n).

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

Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      tm_plus (tm_const n1) (tm_const n2) ==> tm_const (plus n1 n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      tm_plus t1 t2 ==> tm_plus 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.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Temp3.

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

(* FILL IN HERE *)

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.

(* FILL IN HERE *)

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.

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

(** **** 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.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

Module Temp5.

(** **** Exercise: 2 stars (smallstep_bool_shortcut) *)
(** Suppose we want to add a "short circuit" to the step relation for
    boolean expressions, so that it can recognize when the [then] and
    [else] branches of a conditional are the same value (either
    [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
(* FILL IN HERE *)

  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.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (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.

    It is also interesting to 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. *)

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

(** The _multi-step reduction_ relation [==>*] is the reflexive,
    transitive closure of the single-step relation [==>]. *)

Definition stepmany := refl_step_closure step.

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

(** For example... *)

Lemma test_stepmany_1:
      tm_plus
        (tm_plus (tm_const 0) (tm_const 3))
        (tm_plus (tm_const 2) (tm_const 4))
   ==>*
      tm_const (plus (plus 0 3) (plus 2 4)).
Proof.
  apply rsc_step with
            (tm_plus
                (tm_const (plus 0 3))
                (tm_plus (tm_const 2) (tm_const 4))).
  apply ST_Plus1. apply ST_PlusConstConst.
  apply rsc_step with
            (tm_plus
                (tm_const (plus 0 3))
                (tm_const (plus 2 4))).
  apply ST_Plus2. apply v_const.
  apply ST_PlusConstConst.
  apply rsc_R.
  apply ST_PlusConstConst.  Qed.

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

Lemma test_stepmany_1':
      tm_plus
        (tm_plus (tm_const 0) (tm_const 3))
        (tm_plus (tm_const 2) (tm_const 4))
  ==>*
      tm_const (plus (plus 0 3) (plus 2 4)).
Proof.
  eapply rsc_step. apply ST_Plus1. apply ST_PlusConstConst.
  eapply rsc_step. apply ST_Plus2. apply v_const.
  apply ST_PlusConstConst.
  eapply rsc_step. apply ST_PlusConstConst.
  apply rsc_refl.  Qed.

(** **** Exercise: 1 star (test_stepmany_2) *)
Lemma test_stepmany_2:
  tm_const 3 ==>* tm_const 3.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star (test_stepmany_3) *)
Lemma test_stepmany_3:
      tm_plus (tm_const 0) (tm_const 3)
   ==>*
      tm_plus (tm_const 0) (tm_const 3).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (test_stepmany_4) *)
Lemma test_stepmany_4:
      tm_plus
        (tm_const 0)
        (tm_plus
          (tm_const 2)
          (tm_plus (tm_const 0) (tm_const 3)))
  ==>*
      tm_plus
        (tm_const 0)
        (tm_const (plus 2 (plus 0 3))).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

Definition step_normal_form := normal_form step.

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

(** We have already seen that 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 -- i.e.,
    [normal_form_of] is a partial function.  In other words, we
    can actually pronounce [normal_form t t'] as "[t'] is _the_
    normal form of [t]." *)

(** **** Exercise: 3 stars, optional (test_stepmany_3) *)
Theorem normal_forms_unique:
  partial_function normal_form_of.
Proof.
  unfold partial_function. unfold normal_form_of.  intros x y1 y2 P1 P2.
  destruct P1 as [P11 P12]. destruct P2 as [P21 P22].
  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',
    (refl_step_closure 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 [tm_plus] node, and
    similarly when [t] appears as the right-hand child of a [tm_plus]
    node (whose left-hand child is a value). *)

Lemma stepmany_congr_1 : forall t1 t1' t2,
     t1 ==>* t1' ->
     tm_plus t1 t2 ==>* tm_plus t1' t2.
Proof.
  intros t1 t1' t2 H. rsc_cases (induction H) Case.
    Case "rsc_refl". apply rsc_refl.
    Case "rsc_step". apply rsc_step with (tm_plus y t2).
        apply ST_Plus1. apply H.
        apply IHrefl_step_closure.  Qed.

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

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

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

    - [t = tm_const 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 = tm_plus 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' =
      tm_const n1] and [t2' = tm_const n2], for some [n1] and [n2].
      We can combine the [==>*] derivations for [t1] and [t2] to prove
      that [tm_plus t1 t2] reduces in many steps to [tm_const (plus n1
      n2)].

      It is clear that our choice of [t' = tm_const (plus 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 "tm_const".
      exists (tm_const n).
      split.
      SCase "l". apply rsc_refl.
      SCase "r".
        (* We can use [rewrite] with "iff" statements, not
           just equalities: *)
        rewrite nf_same_as_value. apply v_const.
    Case "tm_plus".
      destruct IHt1 as [t1' H1]. destruct IHt2 as [t2' H2].
      destruct H1 as [H11 H12]. destruct H2 as [H21 H22].
      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 (tm_const (plus n1 n2)).
      split.
        SCase "l".
          apply rsc_trans with (tm_plus (tm_const n1) t2).
          apply stepmany_congr_1. apply H11.
          apply rsc_trans with
             (tm_plus (tm_const n1) (tm_const n2)).
          apply stepmany_congr_2. apply v_const. apply H21.
          apply rsc_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, but it
    is not completely straightforward to show this -- or even to see
    how to state it exactly, since one of the relations only goes a
    small step at a time while the other proceeds in large chunks. *)

Lemma eval__value : forall t1 t2,
     eval t1 t2 ->
     value t2.
Proof.
  intros t1 t2 HE.
  eval_cases (inversion HE) Case; apply v_const.  Qed.

(** **** Exercise: 3 stars (eval__stepmany) *)
(** You'll want to use the congruences and some properties of
    [rsc] for this. *)

Theorem eval__stepmany : forall t v,
  eval t v -> t ==>* v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (eval__stepmany_inf) *)
(** Write an informal version of the proof of eval__stepmany.

(* FILL IN HERE *)
[]
*)

(** **** Exercise: 3 stars (step__eval) *)
Theorem step__eval : forall t t' v,
     t ==> t' ->
     t' || v ->
     t || v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem stepmany__eval : forall t v,
  normal_form_of t v -> t || v.
Proof.
  intros t v Hnorm.
  unfold normal_form_of in Hnorm.
  inversion Hnorm as [Hs Hnf]; clear Hnorm.
  (* v is a normal form -> v = tm_const n for some n *)
  rewrite nf_same_as_value in Hnf. inversion Hnf. clear Hnf.
  rsc_cases (induction Hs) Case; subst.
  Case "rsc_refl".
    apply E_Const.
  Case "rsc_step".
    eapply step__eval. eassumption. apply IHHs. reflexivity.  Qed.

(** Bringing it all together, we can crisply say that the [v] is the
    normal form of [t] iff [t] evaluates to [v]. *)

Corollary stepmany_iff_eval : forall t v,
  normal_form_of t v <-> t || v.
Proof.
  split.
  Case "->". apply stepmany__eval.
  Case "<-". unfold normal_form_of. intros E. split. apply eval__stepmany.
    assumption. rewrite nf_same_as_value. eapply eval__value. eassumption.  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 :=
  | tm_const : nat -> tm
  | tm_plus : 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 "tm_const" | Case_aux c "tm_plus"
  | Case_aux c "tm_true" | Case_aux c "tm_false" | Case_aux c "tm_if" ].

Inductive value : tm -> Prop :=
  | v_const : forall n, value (tm_const 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,
      tm_plus (tm_const n1) (tm_const n2) ==> tm_const (plus n1 n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      tm_plus t1 t2 ==> tm_plus t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      tm_plus v1 t2 ==> tm_plus 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 a partial function (i.e., it 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. *)

(* FILL IN HERE *)
(** [] *)
End Combined.

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

(** For a more serious example, here is the small-step version of the
    Imp operational semantics.  Although the definitions are bigger,
    the basic ideas are exactly the same as what we've seen above. *)

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 (plus 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 desired effect, 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 *)

(** 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 :=
  | 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: *)
  | 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 cstepmany := refl_step_closure cstep.

Notation " t '/' st '==>*' t' '/' st' " :=
   (refl_step_closure 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 rsc_step. apply CS_Par1.
    apply CS_Ass.
  eapply rsc_step. apply CS_Par2. apply CS_While.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply rsc_step. apply CS_Par2. apply CS_IfFalse.
  eapply rsc_step. apply CS_ParDone.
  eapply rsc_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 rsc_step. apply CS_Par2. apply CS_While.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply rsc_step. apply CS_Par2. apply CS_IfTrue.
  eapply rsc_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply rsc_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus.
  eapply rsc_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Ass.
  eapply rsc_step. apply CS_Par2. apply CS_SeqFinish.

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

  eapply rsc_step. apply CS_Par1. apply CS_Ass.
  eapply rsc_step. apply CS_Par2. apply CS_SeqFinish.
  eapply rsc_step. apply CS_Par2. apply CS_While.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply rsc_step. apply CS_Par2. apply CS_IfFalse.
  eapply rsc_step. apply CS_ParDone.
  eapply rsc_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.
  destruct H as [H' [HX HY]].
  exists (update st Y 1). split.
  eapply rsc_trans with (par_loop,st). apply H'.
  eapply rsc_step. apply CS_Par1. apply CS_Ass.
  eapply rsc_step. apply CS_Par2. apply CS_While.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id. rewrite update_eq.
  eapply rsc_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply rsc_step. apply CS_Par2. apply CS_IfFalse.
  eapply rsc_step. apply CS_ParDone.
  apply rsc_refl.

  rewrite update_neq. assumption. reflexivity.
Qed.

End CImp.