Defining Recursive Functions

We've seen how we can define some recursive functions in Coq, provided that it passes the termination checker. But what if we have a more complicated function? As an example, let's look at implementing merge sort for lists of natural numbers, using the standard ordering.

First, we need to define a function to merge two (already sorted lists). Normally, we'd write this as follows:

Definition nat_lte := Compare_dec.le_gt_dec.

Fixpoint merge (xs ys:list nat) {struct xs} : list nat :=
  match xs, ys with
  | [], ys => ys
  | xs, [] => xs
  | x::xs', y::ys' =>
      if nat_lte x y then
        x :: (merge xs' ys)
      else
        y :: (merge xs ys')
   end.
Recursive definition of merge is ill-formed.
In environment
merge : list nat -> list nat -> list nat
xs : list nat
ys : list nat
x : nat
xs' : list nat
y : nat
ys' : list nat
g : x > y
Recursive call to merge has principal argument equal
to "xs" instead of "xs'".
Recursive definition is:
"fun xs ys : list nat =>
 match xs with
 | [] => ys
 | x :: xs' =>
     match ys with
     | [] => xs
     | y :: ys' =>
         if nat_lte x y
         then x :: merge xs' ys
         else y :: merge xs ys'
     end
 end".

Unfortunately, Coq will reject this because it's the case that xs is always getting smaller, nor the case that ys is always getting smaller. Of course, one of them is always getting smaller, so eventually, this will terminate. But in this case, we can hack around the problem by simply re-organizing the function as follows.

Fixpoint merge (xs:list nat) : list nat -> list nat :=
  match xs with
  | nil => fun ys => ys
  | x::xs' =>
      (fix inner_merge (ys:list nat) : list nat :=
         match ys with
         | nil => x::xs'
         | y::ys' =>
             if nat_lte x y then
               x :: (merge xs' ys)
             else
               y :: (inner_merge ys')
         end)
  end.

We can write some examples to test that merge works as expected.

Compute merge [1;3;5] [2;4;6].
= [1; 2; 3; 4; 5; 6]
: list nat
Compute merge [3] [1;4].
= [1; 3; 4]
: list nat

Recursive functions with explicit measures

Require Import Coq.Program.Wf.
[Loading ML file extraction_plugin.cmxs (using legacy method) ... done]

Program Fixpoint merge' (xs ys:list nat)
  {measure (length xs + length ys)} : list nat :=
  match xs, ys with
  | [], ys => ys
  | xs, [] => xs
  | x::xs', y::ys' =>
      if nat_lte x y then
        x :: (merge' xs' ys)
      else
        y :: (merge' xs ys')  (* Generates a proof obligation *)
  end.
Next Obligation.
y: nat
ys': list nat
x: nat
xs': list nat
merge': forall xs ys : list nat,
Datatypes.length xs + Datatypes.length ys <
Datatypes.length (x :: xs') +
Datatypes.length (y :: ys') -> 
list nat
g: x > y
Datatypes.length (x :: xs') + Datatypes.length ys' <
Datatypes.length (x :: xs') +
Datatypes.length (y :: ys')
  (* To show: length xs + length ys' < length xs + length ys *)
  simpl.
y: nat
ys': list nat
x: nat
xs': list nat
merge': forall xs ys : list nat,
Datatypes.length xs + Datatypes.length ys <
Datatypes.length (x :: xs') +
Datatypes.length (y :: ys') -> 
list nat
g: x > y
S (Datatypes.length xs' + Datatypes.length ys') <
S (Datatypes.length xs' + S (Datatypes.length ys')) lia.
Defined.

Compute merge' [1;3;5] [2;4;6].
= [1; 2; 3; 4; 5; 6]
: list nat
Compute merge' [3] [1;4].
= [1; 3; 4]
: list nat

It is also interesting to examine the objects that are generated by this definition.

Print merge'.
merge' =
fun xs ys : list nat =>
merge'_func
  (existT (fun _ : list nat => list nat) xs ys)
     : list nat -> list nat -> list nat

Arguments merge' (xs ys)%list_scope
Print merge'_func.
merge'_func =
Fix_sub {_ : list nat & list nat}
  (MR lt
     (fun recarg : {_ : list nat & list nat} =>
      let xs := projT1 recarg in
      let ys := projT2 recarg in
      Datatypes.length xs + Datatypes.length ys))
  merge'_func_obligation_4
  (fun recarg : {_ : list nat & list nat} =>
   let xs := projT1 recarg in
   let ys := projT2 recarg in list nat)
  (fun (recarg : {_ : list nat & list nat})
     (merge'' : forall
                  recarg' : {recarg'
                            : {_ : list nat &
                              list nat}
                            | (let xs :=
                                 projT1 recarg' in
                               let ys :=
                                 projT2 recarg' in
                               Datatypes.length xs +
                               Datatypes.length ys) <
                              (let xs := projT1 recarg
                                 in
                               let ys := projT2 recarg
                                 in
                               Datatypes.length xs +
                               Datatypes.length ys)},
                let xs := projT1 (proj1_sig recarg')
                  in
                let ys := projT2 (proj1_sig recarg')
                  in
                list nat) =>
   let xs := projT1 recarg in
   let ys := projT2 recarg in
   let merge' :=
     fun (xs0 ys0 : list nat)
       (recproof : Datatypes.length xs0 +
                   Datatypes.length ys0 <
                   Datatypes.length xs +
                   Datatypes.length ys) =>
     merge''
       (exist
          (fun recarg' : {_ : list nat & list nat} =>
           (let xs1 := projT1 recarg' in
            let ys1 := projT2 recarg' in
            Datatypes.length xs1 +
            Datatypes.length ys1) <
           (let xs1 := projT1 recarg in
            let ys1 := projT2 recarg in
            Datatypes.length xs1 +
            Datatypes.length ys1))
          (existT (fun _ : list nat => list nat) xs0
             ys0) recproof) in
   let program_branch_0 :=
     fun (ys0 : list nat) (_ : [] = xs) (_ : ys0 = ys)
     => ys0 in
   let program_branch_1 :=
     fun (xs0 : list nat)
       (_ : forall ys0 : list nat,
            ~ ([] = xs0 /\ ys0 = [])) (_ : xs0 = xs)
       (_ : [] = ys) => xs0 in
   let program_branch_2 :=
     fun (x : nat) (xs' : list nat) (y : nat)
       (ys' : list nat) (Heq_xs : x :: xs' = xs)
       (Heq_ys : y :: ys' = ys) =>
     match nat_lte x y with
     | left x0 =>
         x
         :: merge' xs' ys
              ((fun (xs0 ys0 : list nat)
                  (merge'0 : forall xs1 ys1 : list nat,
                             Datatypes.length xs1 +
                             Datatypes.length ys1 <
                             Datatypes.length xs0 +
                             Datatypes.length ys0 ->
                             list nat) (x1 : nat)
                  (xs'0 : list nat) (y0 : nat)
                  (ys'0 : list nat)
                  (Heq_xs0 : x1 :: xs'0 = xs0)
                  (Heq_ys0 : y0 :: ys'0 = ys0)
                  (_ : x1 <= y0) =>
                merge'_func_obligation_1 xs0 ys0
                  merge'0 x1 xs'0 y0 ys'0 Heq_xs0
                  Heq_ys0) xs ys merge' x xs' y ys'
                 Heq_xs Heq_ys x0)
     | right x0 =>
         y
         :: merge' xs ys'
              ((fun (xs0 ys0 : list nat)
                  (merge'0 : forall xs1 ys1 : list nat,
                             Datatypes.length xs1 +
                             Datatypes.length ys1 <
                             Datatypes.length xs0 +
                             Datatypes.length ys0 ->
                             list nat) (x1 : nat)
                  (xs'0 : list nat) (y0 : nat)
                  (ys'0 : list nat)
                  (Heq_xs0 : x1 :: xs'0 = xs0)
                  (Heq_ys0 : y0 :: ys'0 = ys0)
                  (g : x1 > y0) =>
                merge'_func_obligation_2 xs0 ys0
                  merge'0 x1 xs'0 y0 ys'0 Heq_xs0
                  Heq_ys0 g) xs ys merge' x xs' y ys'
                 Heq_xs Heq_ys x0)
     end in
   match
     xs as ys'
     return (ys' = xs -> ys = ys -> list nat)
   with
   | [] => program_branch_0 ys
   | x :: xs' =>
       match
         ys as xs'0
         return
           (x :: xs' = xs -> xs'0 = ys -> list nat)
       with
       | [] =>
           program_branch_1 (x :: xs')
             ((fun (xs0 ys0 : list nat)
                 (_ : forall xs1 ys1 : list nat,
                      Datatypes.length xs1 +
                      Datatypes.length ys1 <
                      Datatypes.length xs0 +
                      Datatypes.length ys0 -> list nat)
                 (n : nat) (l ys1 : list nat) =>
               merge'_func_obligation_3 n l ys1) xs ys
                merge' x xs')
       | y :: ys' => program_branch_2 x xs' y ys'
       end
   end eq_refl eq_refl)
     : forall recarg : {_ : list nat & list nat},
       let xs := projT1 recarg in
       let ys := projT2 recarg in list nat

Arguments merge'_func recarg
Check Fix_sub.
Fix_sub
     : forall (A : Type) (R : A -> A -> Prop),
       well_founded R ->
       forall P : A -> Type,
       (forall x : A,
        (forall y : {y : A | R y x}, P (proj1_sig y)) ->
        P x) -> forall x : A, P x
Check merge'_func_obligation_4.
merge'_func_obligation_4
     : well_founded
         (MR lt
            (fun recarg : {_ : list nat & list nat} =>
             let xs := projT1 recarg in
             let ys := projT2 recarg in
             Datatypes.length xs + Datatypes.length ys))
Print merge'_func_obligation_4.
merge'_func_obligation_4 =
measure_wf lt_wf
  (fun recarg : {_ : list nat & list nat} =>
   Datatypes.length (projT1 recarg) +
   Datatypes.length (projT2 recarg))
     : well_founded
         (MR lt
            (fun recarg : {_ : list nat & list nat} =>
             let xs := projT1 recarg in
             let ys := projT2 recarg in
             Datatypes.length xs + Datatypes.length ys))

Arguments merge'_func_obligation_4 a
Check lt_wf.
lt_wf
     : well_founded lt
Print well_founded.
well_founded =
fun (A : Type) (R : A -> A -> Prop) =>
forall a : A, Acc R a
     : forall A : Type, (A -> A -> Prop) -> Prop

Arguments well_founded [A]%type_scope R%function_scope
Print Acc.
Inductive
Acc (A : Type) (R : A -> A -> Prop) (x : A) : Prop :=
    Acc_intro : (forall y : A, R y x -> Acc R y) ->
                Acc R x.

Arguments Acc [A]%type_scope R%function_scope x
Arguments Acc_intro [A]%type_scope [R]%function_scope
  x _%function_scope

Merge sort

Now let's write a pair of helper functions, one that takes a list of list of naturals and merges consecutive elements, and another that transforms a list into a list of singleton lists.

Fixpoint merge_pairs (xs:list (list nat)) : list (list nat) :=
  match xs with
  | h1::h2::t => (merge h1 h2) :: (merge_pairs t)
  | xs' => xs'
  end.

Definition make_lists (xs:list nat) : list (list nat) :=
  List.map (fun x => x::nil) xs.

Here are some examples to illustrate what these helper functions do.

Compute (make_lists [5; 1; 4; 2; 3]).
= [[5]; [1]; [4]; [2]; [3]]
: list (list nat)
Compute (merge_pairs [[1;3];[2;4;9];[0];[2;3]]).
= [[1; 2; 3; 4; 9]; [0; 2; 3]]
: list (list nat)
Compute (merge_pairs [[1;3];[2;4;9];[0]]).
= [[1; 2; 3; 4; 9]; [0]]
: list (list nat)
Compute (merge_pairs
           (merge_pairs
              (merge_pairs
                 (make_lists [5; 1; 4; 2; 3])))).
= [[1; 2; 3; 4; 5]]
: list (list nat)

Next we will prove an important lemma that relate the length of the list computed by merge_pairs to the length of its argument. Note that we prove a conjunction to get a strong enough induction hypothesis. (As a fun exercise, try to prove just the first conjunct by induction and see where you get stuck.)

Lemma merge_pairs_length' : forall xs,
  (forall h1 h2,
      length (merge_pairs (h1::h2::xs)) < length (h1::h2::xs)) /\
  (forall h,
      length (merge_pairs (h::xs)) <= length (h::xs)).
forall xs : list (list nat),
(forall h1 h2 : list nat,
 Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
 Datatypes.length (h1 :: h2 :: xs)) /\
(forall h : list nat,
 Datatypes.length (merge_pairs (h :: xs)) <=
 Datatypes.length (h :: xs))
Proof.
forall xs : list (list nat),
(forall h1 h2 : list nat,
 Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
 Datatypes.length (h1 :: h2 :: xs)) /\
(forall h : list nat,
 Datatypes.length (merge_pairs (h :: xs)) <=
 Datatypes.length (h :: xs))
  induction xs as [|x xs [H1 H2]].
(forall h1 h2 : list nat,
 Datatypes.length (merge_pairs [h1; h2]) <
 Datatypes.length [h1; h2]) /\
(forall h : list nat,
 Datatypes.length (merge_pairs [h]) <=
 Datatypes.length [h])
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
(forall h1 h2 : list nat,
 Datatypes.length (merge_pairs (h1 :: h2 :: x :: xs)) <
 Datatypes.length (h1 :: h2 :: x :: xs)) /\
(forall h : list nat,
 Datatypes.length (merge_pairs (h :: x :: xs)) <=
 Datatypes.length (h :: x :: xs))
  -
(forall h1 h2 : list nat,
 Datatypes.length (merge_pairs [h1; h2]) <
 Datatypes.length [h1; h2]) /\
(forall h : list nat,
 Datatypes.length (merge_pairs [h]) <=
 Datatypes.length [h]) simpl.
(list nat -> list nat -> 1 < 2) /\
(list nat -> 1 <= 1) split; lia.
  -
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
(forall h1 h2 : list nat,
 Datatypes.length (merge_pairs (h1 :: h2 :: x :: xs)) <
 Datatypes.length (h1 :: h2 :: x :: xs)) /\
(forall h : list nat,
 Datatypes.length (merge_pairs (h :: x :: xs)) <=
 Datatypes.length (h :: x :: xs)) split.
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: x :: xs)) <
Datatypes.length (h1 :: h2 :: x :: xs)
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
forall h : list nat,
Datatypes.length (merge_pairs (h :: x :: xs)) <=
Datatypes.length (h :: x :: xs)
    +
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: x :: xs)) <
Datatypes.length (h1 :: h2 :: x :: xs) specialize (H2 x).
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: Datatypes.length (merge_pairs (x :: xs)) <=
Datatypes.length (x :: xs)
forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: x :: xs)) <
Datatypes.length (h1 :: h2 :: x :: xs) simpl in *.
x: list nat
xs: list (list nat)
H1: list nat ->
list nat ->
S (Datatypes.length (merge_pairs xs)) <
S (S (Datatypes.length xs))
H2: Datatypes.length
  match xs with
  | [] => x :: xs
  | h2 :: t => merge x h2 :: merge_pairs t
  end <= S (Datatypes.length xs)
list nat ->
list nat ->
S
  (Datatypes.length
     match xs with
     | [] => x :: xs
     | h2 :: t => merge x h2 :: merge_pairs t
     end) < S (S (S (Datatypes.length xs))) lia.
    +
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
forall h : list nat,
Datatypes.length (merge_pairs (h :: x :: xs)) <=
Datatypes.length (h :: x :: xs) intros x'.
x: list nat
xs: list (list nat)
H1: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
x': list nat
Datatypes.length (merge_pairs (x' :: x :: xs)) <=
Datatypes.length (x' :: x :: xs) specialize (H1 x' x).
x: list nat
xs: list (list nat)
x': list nat
H1: Datatypes.length (merge_pairs (x' :: x :: xs)) <
Datatypes.length (x' :: x :: xs)
H2: forall h : list nat,
Datatypes.length (merge_pairs (h :: xs)) <=
Datatypes.length (h :: xs)
Datatypes.length (merge_pairs (x' :: x :: xs)) <=
Datatypes.length (x' :: x :: xs) lia.
Qed.

Next, we can prove a corollary that captures the case we will need to define merge sort.

Lemma merge_pairs_length : forall h1 h2 xs,
    length (merge_pairs (h1::h2::xs)) < length (h1::h2::xs).
forall (h1 h2 : list nat) (xs : list (list nat)),
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
Proof.
forall (h1 h2 : list nat) (xs : list (list nat)),
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
  intros.
h1, h2: list nat
xs: list (list nat)
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
  specialize (merge_pairs_length' xs).
h1, h2: list nat
xs: list (list nat)
(forall h1 h2 : list nat,
 Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
 Datatypes.length (h1 :: h2 :: xs)) /\
(forall h : list nat,
 Datatypes.length (merge_pairs (h :: xs)) <=
 Datatypes.length (h :: xs)) ->
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
  intros [H _].
h1, h2: list nat
xs: list (list nat)
H: forall h1 h2 : list nat,
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
Datatypes.length (merge_pairs (h1 :: h2 :: xs)) <
Datatypes.length (h1 :: h2 :: xs)
  apply H.
Qed.

Now we are ready to define our merge sort. We'll do it by iterating merge_pairs until we have a singleton list.

Program Fixpoint merge_iter (xs: list (list nat))
  { measure (length xs) } : list nat :=
  match xs with
  | nil => nil
  | x::nil => x
  | x1::x2::xs' => merge_iter (merge_pairs (x1::x2::xs'))
  end.
Obligation 1.
x1, x2: list nat
xs': list (list nat)
merge_iter: forall xs : list (list nat),
Datatypes.length xs <
Datatypes.length (x1 :: x2 :: xs') ->
list nat
S (Datatypes.length (merge_pairs xs')) <
Datatypes.length (x1 :: x2 :: xs') 
  intros.
x1, x2: list nat
xs': list (list nat)
merge_iter: forall xs : list (list nat),
Datatypes.length xs <
Datatypes.length (x1 :: x2 :: xs') ->
list nat
S (Datatypes.length (merge_pairs xs')) <
Datatypes.length (x1 :: x2 :: xs') apply merge_pairs_length.
Defined.

Note that we had to use merge_pairs_length before Coq was willing to accept our recursive definition.

With these pieces in hand, we can finally define our merge_sort function.

Definition merge_sort (xs:list nat) :=
  merge_iter (make_lists xs).

Let's test that is is working as expected:

Compute (merge_sort [7;8;3;5;1;2;6;4]).
= [1; 2; 3; 4; 5; 6; 7; 8]
: list nat
Compute (merge_sort [3;2;7;8]).
= [2; 3; 7; 8]
: list nat

Recap: arithmetic expressions

Axiom funext : forall {X Y: Type} (f g: X -> Y),
    (forall x, f x = g x) -> f = g.

Inductive expr : Type :=
  | Const : nat -> expr
  | Var : string -> expr
  | Plus : expr -> expr -> expr
  | Mult : expr -> expr -> expr
  | Minus : expr -> expr -> expr.

Fixpoint eval (env : string -> nat) (e : expr) : nat :=
  match e with
  | Const n => n
  | Var x => env x
  | Plus e1 e2 => eval env e1 + eval env e2
  | Mult e1 e2 => eval env e1 * eval env e2
  | Minus e1 e2 => eval env e1 - eval env e2
  end.

While loops

A simple imperative programming language with While loops

Inductive stmt :=
  | Assign : string -> expr -> stmt
  | Seq : stmt -> stmt -> stmt
  | If : expr -> stmt -> stmt -> stmt
  | While : expr -> stmt -> stmt.

Big-step semantics

Definition string_eq (x y : string) : {x = y} + {x <> y}.
x, y: string
{x = y} + {x <> y}
Proof.
x, y: string
{x = y} + {x <> y}
  destruct (String.eqb_spec x y); auto.
Defined.

Lemma string_eq_test x y :
  (if string_eq x y then 0 else 1) = 1 ->
  (if string_eq y x then 1 else 0) = 0.
x, y: string
(if string_eq x y then 0 else 1) = 1 ->
(if string_eq y x then 1 else 0) = 0
Proof.
x, y: string
(if string_eq x y then 0 else 1) = 1 ->
(if string_eq y x then 1 else 0) = 0
  intros H.
x, y: string
H: (if string_eq x y then 0 else 1) = 1
(if string_eq y x then 1 else 0) = 0 destruct string_eq.
x, y: string
e: x = y
H: 0 = 1
(if string_eq y x then 1 else 0) = 0
x, y: string
n: x <> y
H: 1 = 1
(if string_eq y x then 1 else 0) = 0
  -
x, y: string
e: x = y
H: 0 = 1
(if string_eq y x then 1 else 0) = 0 discriminate.
  -
x, y: string
n: x <> y
H: 1 = 1
(if string_eq y x then 1 else 0) = 0 destruct string_eq.
x, y: string
n: x <> y
H: 1 = 1
e: y = x
1 = 0
x, y: string
n: x <> y
H: 1 = 1
n0: y <> x
0 = 0
    +
x, y: string
n: x <> y
H: 1 = 1
e: y = x
1 = 0 congruence.
    +
x, y: string
n: x <> y
H: 1 = 1
n0: y <> x
0 = 0 reflexivity.
Qed.

Ltac simpeq := repeat match goal with
  | _ => congruence || (progress subst)
  | H : ?x = ?x |- _ => clear H
  | H : _ = _ |- _ => progress injection H as H
  end.

Shorter proof

Ltac string_cases := repeat (destruct string_eq; simpeq; simpl).

Lemma string_eq_test' x y :
  (if string_eq x y then 0 else 1) = 1 ->
  (if string_eq y x then 1 else 0) = 0.
x, y: string
(if string_eq x y then 0 else 1) = 1 ->
(if string_eq y x then 1 else 0) = 0
Proof.
x, y: string
(if string_eq x y then 0 else 1) = 1 ->
(if string_eq y x then 1 else 0) = 0
  string_cases.
Qed.

Big-step semantics

Definition env := string -> nat.

Inductive big_step : env -> stmt -> env -> Prop :=
  | big_Assign env x e :
    big_step env (Assign x e) 
      (fun var =>
         if string_eq x var then
           eval env e else
           env var)
  | big_Seq env env' env'' s1 s2 :
      big_step env s1 env' ->
      big_step env' s2 env'' ->
      big_step env (Seq s1 s2) env''
  | big_IfTrue env env' e s1 s2 :
      eval env e <> 0 ->
      big_step env s1 env' ->
      big_step env (If e s1 s2) env'
  | big_IfFalse env env' e s1 s2 :
      eval env e = 0 ->
      big_step env s2 env' ->
      big_step env (If e s1 s2) env'
  | big_WhileTrue env env' env'' e s :
      eval env e <> 0 ->
      big_step env s env' ->
      big_step env' (While e s) env'' ->
      big_step env (While e s) env''
  | big_WhileFalse env e s :
      eval env e = 0 ->
      big_step env (While e s) env.

Determinism

Lemma big_step_deterministic env s env1 env2 :
  big_step env s env1 ->
  big_step env s env2 ->
  env1 = env2.
env: lec07_big_step.env
s: stmt
env1, env2: lec07_big_step.env
big_step env s env1 ->
big_step env s env2 -> env1 = env2
Proof.
env: lec07_big_step.env
s: stmt
env1, env2: lec07_big_step.env
big_step env s env1 ->
big_step env s env2 -> env1 = env2
  intros H1.
env: lec07_big_step.env
s: stmt
env1, env2: lec07_big_step.env
H1: big_step env s env1
big_step env s env2 -> env1 = env2 revert env2.
env: lec07_big_step.env
s: stmt
env1: lec07_big_step.env
H1: big_step env s env1
forall env2 : lec07_big_step.env,
big_step env s env2 -> env1 = env2
  induction H1; intros env2 H2.
env0: env
x: string
e: expr
env2: env
H2: big_step env0 (Assign x e) env2
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) =
env2
env0, env', env'': env
s1, s2: stmt
H1_: big_step env0 s1 env'
H1_0: big_step env' s2 env''
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' s2 env2 -> env'' = env2
env2: env
H2: big_step env0 (Seq s1 s2) env2
env'' = env2
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e <> 0
H1: big_step env0 s1 env'
IHbig_step: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
env2: env
H2: big_step env0 (If e s1 s2) env2
env' = env2
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e = 0
H1: big_step env0 s2 env'
IHbig_step: forall env2 : env,
big_step env0 s2 env2 -> env' = env2
env2: env
H2: big_step env0 (If e s1 s2) env2
env' = env2
env0: string -> nat
env', env'': env
e: expr
s: stmt
H: eval env0 e <> 0
H1_: big_step env0 s env'
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env2 : env,
big_step env0 s env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
env2: env
H2: big_step env0 (While e s) env2
env'' = env2
env0: string -> nat
e: expr
s: stmt
H: eval env0 e = 0
env2: env
H2: big_step env0 (While e s) env2
env0 = env2
  -
env0: env
x: string
e: expr
env2: env
H2: big_step env0 (Assign x e) env2
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) =
env2 inversion H2.
env0: env
x: string
e: expr
env2: env
H2: big_step env0 (Assign x e) env2
env1: env
x0: string
e0: expr
H: env1 = env0
H1: x0 = x
H3: e0 = e
H0: (fun var : string =>
 if string_eq x var
 then eval env0 e
 else env0 var) = env2
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) =
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) clear H2.
env0: env
x: string
e: expr
env2, env1: env
x0: string
e0: expr
H: env1 = env0
H1: x0 = x
H3: e0 = e
H0: (fun var : string =>
 if string_eq x var
 then eval env0 e
 else env0 var) = env2
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) =
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) subst.
env0: env
x: string
e: expr
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) =
(fun var : string =>
 if string_eq x var then eval env0 e else env0 var) reflexivity.
  -
env0, env', env'': env
s1, s2: stmt
H1_: big_step env0 s1 env'
H1_0: big_step env' s2 env''
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' s2 env2 -> env'' = env2
env2: env
H2: big_step env0 (Seq s1 s2) env2
env'' = env2 inversion H2.
env0, env', env'': env
s1, s2: stmt
H1_: big_step env0 s1 env'
H1_0: big_step env' s2 env''
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' s2 env2 -> env'' = env2
env2: env
H2: big_step env0 (Seq s1 s2) env2
env1, env'0, env''0: env
s0, s3: stmt
H3: big_step env0 s1 env'0
H5: big_step env'0 s2 env2
H1: env1 = env0
H: s0 = s1
H0: s3 = s2
H4: env''0 = env2
env'' = env2 clear H2.
env0, env', env'': env
s1, s2: stmt
H1_: big_step env0 s1 env'
H1_0: big_step env' s2 env''
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' s2 env2 -> env'' = env2
env2, env1, env'0, env''0: env
s0, s3: stmt
H3: big_step env0 s1 env'0
H5: big_step env'0 s2 env2
H1: env1 = env0
H: s0 = s1
H0: s3 = s2
H4: env''0 = env2
env'' = env2 subst.
env0, env', env'': env
s1, s2: stmt
H1_: big_step env0 s1 env'
H1_0: big_step env' s2 env''
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' s2 env2 -> env'' = env2
env2, env'0: env
H3: big_step env0 s1 env'0
H5: big_step env'0 s2 env2
env'' = env2 
    apply IHbig_step2.
env0, env', env'': env
s1, s2: stmt
H1_: big_step env0 s1 env'
H1_0: big_step env' s2 env''
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' s2 env2 -> env'' = env2
env2, env'0: env
H3: big_step env0 s1 env'0
H5: big_step env'0 s2 env2
big_step env' s2 env2
    apply IHbig_step1 in H3.
env0, env', env'': env
s1, s2: stmt
H1_: big_step env0 s1 env'
H1_0: big_step env' s2 env''
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' s2 env2 -> env'' = env2
env2, env'0: env
H3: env' = env'0
H5: big_step env'0 s2 env2
big_step env' s2 env2 subst.
env0, env'': env
s1, s2: stmt
env'0: env
IHbig_step2: forall env2 : env,
big_step env'0 s2 env2 -> env'' = env2
IHbig_step1: forall env2 : env,
big_step env0 s1 env2 -> env'0 = env2
H1_0: big_step env'0 s2 env''
H1_: big_step env0 s1 env'0
env2: env
H5: big_step env'0 s2 env2
big_step env'0 s2 env2
    apply H5.
  -
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e <> 0
H1: big_step env0 s1 env'
IHbig_step: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
env2: env
H2: big_step env0 (If e s1 s2) env2
env' = env2 inversion H2; clear H2; subst.
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e <> 0
H1: big_step env0 s1 env'
IHbig_step: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
env2: env
H7: eval env0 e <> 0
H8: big_step env0 s1 env2
env' = env2
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e <> 0
H1: big_step env0 s1 env'
IHbig_step: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
env2: env
H7: eval env0 e = 0
H8: big_step env0 s2 env2
env' = env2
    +
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e <> 0
H1: big_step env0 s1 env'
IHbig_step: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
env2: env
H7: eval env0 e <> 0
H8: big_step env0 s1 env2
env' = env2 apply IHbig_step.
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e <> 0
H1: big_step env0 s1 env'
IHbig_step: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
env2: env
H7: eval env0 e <> 0
H8: big_step env0 s1 env2
big_step env0 s1 env2 apply H8.
    +
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e <> 0
H1: big_step env0 s1 env'
IHbig_step: forall env2 : env,
big_step env0 s1 env2 -> env' = env2
env2: env
H7: eval env0 e = 0
H8: big_step env0 s2 env2
env' = env2 congruence.
  -
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e = 0
H1: big_step env0 s2 env'
IHbig_step: forall env2 : env,
big_step env0 s2 env2 -> env' = env2
env2: env
H2: big_step env0 (If e s1 s2) env2
env' = env2 inversion H2; clear H2; subst.
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e = 0
H1: big_step env0 s2 env'
IHbig_step: forall env2 : env,
big_step env0 s2 env2 -> env' = env2
env2: env
H7: eval env0 e <> 0
H8: big_step env0 s1 env2
env' = env2
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e = 0
H1: big_step env0 s2 env'
IHbig_step: forall env2 : env,
big_step env0 s2 env2 -> env' = env2
env2: env
H7: eval env0 e = 0
H8: big_step env0 s2 env2
env' = env2
    +
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e = 0
H1: big_step env0 s2 env'
IHbig_step: forall env2 : env,
big_step env0 s2 env2 -> env' = env2
env2: env
H7: eval env0 e <> 0
H8: big_step env0 s1 env2
env' = env2 congruence.
    +
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e = 0
H1: big_step env0 s2 env'
IHbig_step: forall env2 : env,
big_step env0 s2 env2 -> env' = env2
env2: env
H7: eval env0 e = 0
H8: big_step env0 s2 env2
env' = env2 apply IHbig_step.
env0: string -> nat
env': env
e: expr
s1, s2: stmt
H: eval env0 e = 0
H1: big_step env0 s2 env'
IHbig_step: forall env2 : env,
big_step env0 s2 env2 -> env' = env2
env2: env
H7: eval env0 e = 0
H8: big_step env0 s2 env2
big_step env0 s2 env2 apply H8.
  -
env0: string -> nat
env', env'': env
e: expr
s: stmt
H: eval env0 e <> 0
H1_: big_step env0 s env'
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env2 : env,
big_step env0 s env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
env2: env
H2: big_step env0 (While e s) env2
env'' = env2 inversion H2; clear H2; subst.
env0: string -> nat
env', env'': env
e: expr
s: stmt
H: eval env0 e <> 0
H1_: big_step env0 s env'
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env2 : env,
big_step env0 s env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
env2, env'0: env
H3: eval env0 e <> 0
H5: big_step env0 s env'0
H7: big_step env'0 (While e s) env2
env'' = env2
env', env'': env
e: expr
s: stmt
env2: env
H1_: big_step env2 s env'
H: eval env2 e <> 0
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env3 : env,
big_step env2 s env3 -> env' = env3
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
H5: eval env2 e = 0
env'' = env2
    +
env0: string -> nat
env', env'': env
e: expr
s: stmt
H: eval env0 e <> 0
H1_: big_step env0 s env'
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env2 : env,
big_step env0 s env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
env2, env'0: env
H3: eval env0 e <> 0
H5: big_step env0 s env'0
H7: big_step env'0 (While e s) env2
env'' = env2 apply IHbig_step2.
env0: string -> nat
env', env'': env
e: expr
s: stmt
H: eval env0 e <> 0
H1_: big_step env0 s env'
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env2 : env,
big_step env0 s env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
env2, env'0: env
H3: eval env0 e <> 0
H5: big_step env0 s env'0
H7: big_step env'0 (While e s) env2
big_step env' (While e s) env2 apply IHbig_step1 in H5.
env0: string -> nat
env', env'': env
e: expr
s: stmt
H: eval env0 e <> 0
H1_: big_step env0 s env'
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env2 : env,
big_step env0 s env2 -> env' = env2
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
env2, env'0: env
H3: eval env0 e <> 0
H5: env' = env'0
H7: big_step env'0 (While e s) env2
big_step env' (While e s) env2
      subst.
env0: string -> nat
env'': env
e: expr
s: stmt
H: eval env0 e <> 0
env'0: env
IHbig_step2: forall env2 : env,
big_step env'0 (While e s) env2 ->
env'' = env2
IHbig_step1: forall env2 : env,
big_step env0 s env2 -> env'0 = env2
H1_0: big_step env'0 (While e s) env''
H1_: big_step env0 s env'0
env2: env
H3: eval env0 e <> 0
H7: big_step env'0 (While e s) env2
big_step env'0 (While e s) env2 apply H7.
    +
env', env'': env
e: expr
s: stmt
env2: env
H1_: big_step env2 s env'
H: eval env2 e <> 0
H1_0: big_step env' (While e s) env''
IHbig_step1: forall env3 : env,
big_step env2 s env3 -> env' = env3
IHbig_step2: forall env2 : env,
big_step env' (While e s) env2 ->
env'' = env2
H5: eval env2 e = 0
env'' = env2 congruence.
  -
env0: string -> nat
e: expr
s: stmt
H: eval env0 e = 0
env2: env
H2: big_step env0 (While e s) env2
env0 = env2 inversion H2; clear H2; subst.
env0: string -> nat
e: expr
s: stmt
H: eval env0 e = 0
env2, env': env
H3: eval env0 e <> 0
H5: big_step env0 s env'
H7: big_step env' (While e s) env2
env0 = env2
e: expr
s: stmt
env2: env
H, H5: eval env2 e = 0
env2 = env2
    +
env0: string -> nat
e: expr
s: stmt
H: eval env0 e = 0
env2, env': env
H3: eval env0 e <> 0
H5: big_step env0 s env'
H7: big_step env' (While e s) env2
env0 = env2 congruence.
    +
e: expr
s: stmt
env2: env
H, H5: eval env2 e = 0
env2 = env2 reflexivity.
Qed.

Shorter proof

Ltac inv H := inversion H; clear H; simpeq.

Lemma big_step_deterministic' env s env1 env2 :
  big_step env s env1 ->
  big_step env s env2 ->
  env1 = env2.
env: lec07_big_step.env
s: stmt
env1, env2: lec07_big_step.env
big_step env s env1 ->
big_step env s env2 -> env1 = env2
Proof.
env: lec07_big_step.env
s: stmt
env1, env2: lec07_big_step.env
big_step env s env1 ->
big_step env s env2 -> env1 = env2
  intros H1.
env: lec07_big_step.env
s: stmt
env1, env2: lec07_big_step.env
H1: big_step env s env1
big_step env s env2 -> env1 = env2 revert env2.
env: lec07_big_step.env
s: stmt
env1: lec07_big_step.env
H1: big_step env s env1
forall env2 : lec07_big_step.env,
big_step env s env2 -> env1 = env2
  induction H1; intros env2 H2; inv H2; auto;
  assert (env' = env'0) as ->; auto.
Qed.

Equivalence of programs

Definition equiv (s1 s2 : stmt) : Prop :=
  forall env env',
    big_step env s1 env' <-> big_step env s2 env'.

Lemma Seq_assoc s1 s2 s3 :
  equiv (Seq (Seq s1 s2) s3) (Seq s1 (Seq s2 s3)).
s1, s2, s3: stmt
equiv (Seq (Seq s1 s2) s3) (Seq s1 (Seq s2 s3))
Proof.
s1, s2, s3: stmt
equiv (Seq (Seq s1 s2) s3) (Seq s1 (Seq s2 s3))
  unfold equiv.
s1, s2, s3: stmt
forall env0 env' : env,
big_step env0 (Seq (Seq s1 s2) s3) env' <->
big_step env0 (Seq s1 (Seq s2 s3)) env' intros.
s1, s2, s3: stmt
env0, env': env
big_step env0 (Seq (Seq s1 s2) s3) env' <->
big_step env0 (Seq s1 (Seq s2 s3)) env' split; intros.
s1, s2, s3: stmt
env0, env': env
H: big_step env0 (Seq (Seq s1 s2) s3) env'
big_step env0 (Seq s1 (Seq s2 s3)) env'
s1, s2, s3: stmt
env0, env': env
H: big_step env0 (Seq s1 (Seq s2 s3)) env'
big_step env0 (Seq (Seq s1 s2) s3) env'
  -
s1, s2, s3: stmt
env0, env': env
H: big_step env0 (Seq (Seq s1 s2) s3) env'
big_step env0 (Seq s1 (Seq s2 s3)) env' inv H.
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 (Seq s1 s2) env'0
H5: big_step env'0 s3 env'
big_step env0 (Seq s1 (Seq s2 s3)) env' inv H3.
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env0 (Seq s1 (Seq s2 s3)) env'
    econstructor.
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env0 s1 ?env'
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step ?env' (Seq s2 s3) env'
    +
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env0 s1 ?env' apply H2.
    +
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env'1 (Seq s2 s3) env' econstructor.
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env'1 s2 ?env'
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step ?env' s3 env'
      *
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env'1 s2 ?env' apply H6.
      *
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env'0 s3 env' apply H5.  
  -
s1, s2, s3: stmt
env0, env': env
H: big_step env0 (Seq s1 (Seq s2 s3)) env'
big_step env0 (Seq (Seq s1 s2) s3) env' inv H.
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
H5: big_step env'0 (Seq s2 s3) env'
big_step env0 (Seq (Seq s1 s2) s3) env' inv H5.
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env0 (Seq (Seq s1 s2) s3) env'
    econstructor.
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env0 (Seq s1 s2) ?env'
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step ?env' s3 env'
    +
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env0 (Seq s1 s2) ?env' econstructor.
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env0 s1 ?env'0
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step ?env'0 s2 ?env'
      *
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env0 s1 ?env'0 apply H3.
      *
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env'0 s2 ?env' apply H2. 
    +
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env'1 s3 env' apply H6.
Qed.

Shorter proof

Lemma Seq_assoc' s1 s2 s3 :
  equiv (Seq (Seq s1 s2) s3) (Seq s1 (Seq s2 s3)).
s1, s2, s3: stmt
equiv (Seq (Seq s1 s2) s3) (Seq s1 (Seq s2 s3))
Proof.
s1, s2, s3: stmt
equiv (Seq (Seq s1 s2) s3) (Seq s1 (Seq s2 s3))
  unfold equiv.
s1, s2, s3: stmt
forall env0 env' : env,
big_step env0 (Seq (Seq s1 s2) s3) env' <->
big_step env0 (Seq s1 (Seq s2 s3)) env' intros.
s1, s2, s3: stmt
env0, env': env
big_step env0 (Seq (Seq s1 s2) s3) env' <->
big_step env0 (Seq s1 (Seq s2 s3)) env' split; intros; inv H.
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 (Seq s1 s2) env'0
H5: big_step env'0 s3 env'
big_step env0 (Seq s1 (Seq s2 s3)) env'
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
H5: big_step env'0 (Seq s2 s3) env'
big_step env0 (Seq (Seq s1 s2) s3) env'
  -
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 (Seq s1 s2) env'0
H5: big_step env'0 s3 env'
big_step env0 (Seq s1 (Seq s2 s3)) env' inv H3.
s1, s2, s3: stmt
env0, env', env'0: env
H5: big_step env'0 s3 env'
env'1: env
H2: big_step env0 s1 env'1
H6: big_step env'1 s2 env'0
big_step env0 (Seq s1 (Seq s2 s3)) env' eauto using big_step.
  -
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
H5: big_step env'0 (Seq s2 s3) env'
big_step env0 (Seq (Seq s1 s2) s3) env' inv H5.
s1, s2, s3: stmt
env0, env', env'0: env
H3: big_step env0 s1 env'0
env'1: env
H2: big_step env'0 s2 env'1
H6: big_step env'1 s3 env'
big_step env0 (Seq (Seq s1 s2) s3) env' eauto using big_step.
Qed.

Example: simple program

Definition ex1 :=
  Seq
    (Assign "x" (Plus (Var "x") (Var "x")))
    (Assign "x" (Plus (Var "x") (Var "x"))).

Lemma assign_behavior env env' :
  big_step env ex1 env' <->
    forall x,
      env' x = if string_eq x "x" then 4 * env "x" else env x.
env, env': lec07_big_step.env
big_step env ex1 env' <->
(forall x : string,
 env' x =
 (if string_eq x "x" then 4 * env "x" else env x))
Proof.
env, env': lec07_big_step.env
big_step env ex1 env' <->
(forall x : string,
 env' x =
 (if string_eq x "x" then 4 * env "x" else env x))
  split.
env, env': lec07_big_step.env
big_step env ex1 env' ->
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
env, env': lec07_big_step.env
(forall x : string,
 env' x =
 (if string_eq x "x" then 4 * env "x" else env x)) ->
big_step env ex1 env'
  -
env, env': lec07_big_step.env
big_step env ex1 env' ->
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x) intros H.
env, env': lec07_big_step.env
H: big_step env ex1 env'
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x) inv H.
env, env', env'0: lec07_big_step.env
H3: big_step env
  (Assign "x" (Plus (Var "x") (Var "x"))) env'0
H5: big_step env'0
  (Assign "x" (Plus (Var "x") (Var "x"))) env'
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x) inv H3.
env, env': lec07_big_step.env
H5: big_step
  (fun var : string =>
   if string_eq "x" var
   then eval env (Plus (Var "x") (Var "x"))
   else env var)
  (Assign "x" (Plus (Var "x") (Var "x"))) env'
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x) inv H5.
env: lec07_big_step.env
forall x : string,
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) =
(if string_eq x "x" then 4 * env "x" else env x)
    intros x.
env: lec07_big_step.env
x: string
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) =
(if string_eq x "x" then 4 * env "x" else env x) string_cases.
env: lec07_big_step.env
env "x" + env "x" + (env "x" + env "x") =
env "x" + (env "x" + (env "x" + (env "x" + 0))) lia. 
  -
env, env': lec07_big_step.env
(forall x : string,
 env' x =
 (if string_eq x "x" then 4 * env "x" else env x)) ->
big_step env ex1 env' intros H.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
big_step env ex1 env' 
    cut (exists env'', big_step env ex1 env'' /\ env'' = env').
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
(exists env'' : lec07_big_step.env,
   big_step env ex1 env'' /\ env'' = env') ->
big_step env ex1 env'
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
exists env'' : lec07_big_step.env,
  big_step env ex1 env'' /\ env'' = env'
    {
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
(exists env'' : lec07_big_step.env,
   big_step env ex1 env'' /\ env'' = env') ->
big_step env ex1 env' intros [env'' [H1 H2]].
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
env'': lec07_big_step.env
H1: big_step env ex1 env''
H2: env'' = env'
big_step env ex1 env' subst.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
H1: big_step env ex1 env'
big_step env ex1 env' auto. }
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
exists env'' : lec07_big_step.env,
  big_step env ex1 env'' /\ env'' = env'
    eexists.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
big_step env ex1 ?env'' /\ ?env'' = env' split.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
big_step env ex1 ?env''
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
?env'' = env'
    +
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
big_step env ex1 ?env'' eauto using big_step.
    +
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
(fun var : string =>
 if string_eq "x" var
 then
  eval
    (fun var0 : string =>
     if string_eq "x" var0
     then eval env (Plus (Var "x") (Var "x"))
     else env var0) (Plus (Var "x") (Var "x"))
 else
  (fun var0 : string =>
   if string_eq "x" var0
   then eval env (Plus (Var "x") (Var "x"))
   else env var0) var) = env' apply funext.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
forall x : string,
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) = env' x intros x.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
x: string
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) = env' x rewrite H.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
x: string
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) =
(if string_eq x "x" then 4 * env "x" else env x)
      string_cases.
env, env': lec07_big_step.env
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
env "x" + env "x" + (env "x" + env "x") =
env "x" + (env "x" + (env "x" + (env "x" + 0))) lia.
Qed.

Ltac run_big_step := 
  match goal with
  | [ |- big_step ?env ?s ?env' ] =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    cut (exists env'', big_step env s env'' /\ env'' = env');
    [ intros [env'' [H1 H2]]; subst; auto
    | eexists; split; eauto using big_step ]
  end.

Lemma assign_behavior_1 env env' :
  (forall x, env' x = if string_eq x "x" then 4 * env "x" else env x) ->
  big_step env ex1 env'.
env, env': string -> nat
(forall x : string,
 env' x =
 (if string_eq x "x" then 4 * env "x" else env x)) ->
big_step env ex1 env'
Proof.
env, env': string -> nat
(forall x : string,
 env' x =
 (if string_eq x "x" then 4 * env "x" else env x)) ->
big_step env ex1 env'
  intros H.
env, env': string -> nat
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
big_step env ex1 env' run_big_step.
env, env': string -> nat
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
(fun var : string =>
 if string_eq "x" var
 then
  eval
    (fun var0 : string =>
     if string_eq "x" var0
     then eval env (Plus (Var "x") (Var "x"))
     else env var0) (Plus (Var "x") (Var "x"))
 else
  (fun var0 : string =>
   if string_eq "x" var0
   then eval env (Plus (Var "x") (Var "x"))
   else env var0) var) = env'
  apply funext.
env, env': string -> nat
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
forall x : string,
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) = env' x intros x.
env, env': string -> nat
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
x: string
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) = env' x rewrite H.
env, env': string -> nat
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
x: string
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) =
(if string_eq x "x" then 4 * env "x" else env x) string_cases.
env, env': string -> nat
H: forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
env "x" + env "x" + (env "x" + env "x") =
env "x" + (env "x" + (env "x" + (env "x" + 0))) lia.
Qed.

(* Invert big step but only do it when it produces a single subgoal. *)
Ltac inv_big_step :=
  match goal with
  | [ H : big_step _ _ _ |- _ ] => inv H
  end.

Lemma assign_behavior_2 env env' :
  big_step env ex1 env' ->
  forall x, env' x = if string_eq x "x" then 4 * env "x" else env x.
env, env': lec07_big_step.env
big_step env ex1 env' ->
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
Proof.
env, env': lec07_big_step.env
big_step env ex1 env' ->
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x)
  intros H.
env, env': lec07_big_step.env
H: big_step env ex1 env'
forall x : string,
env' x =
(if string_eq x "x" then 4 * env "x" else env x) repeat inv_big_step.
env: lec07_big_step.env
forall x : string,
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) =
(if string_eq x "x" then 4 * env "x" else env x) intro x.
env: lec07_big_step.env
x: string
(if string_eq "x" x
 then
  eval
    (fun var : string =>
     if string_eq "x" var
     then eval env (Plus (Var "x") (Var "x"))
     else env var) (Plus (Var "x") (Var "x"))
 else
  if string_eq "x" x
  then eval env (Plus (Var "x") (Var "x"))
  else env x) =
(if string_eq x "x" then 4 * env "x" else env x) string_cases.
env: lec07_big_step.env
env "x" + env "x" + (env "x" + env "x") =
env "x" + (env "x" + (env "x" + (env "x" + 0))) lia.
Qed.