Require Import Bool Arith Omega List Coq.Program.Equality.
Require Import Maps Imp.
Require Import Sequences Semantics.

(** This chapter defines a compiler from the Imp language to a virtual machine
  (a small subset of the Java Virtual Machine) and proves that this
  compiler preserves the semantics of the source programs. *)

(** * 1. The virtual machine. *)

(** The machine operates on a code [c] (a fixed list of instructions)
  and three variable components:
- a program counter, denoting a position in [c]
- a state assigning integer values to variables
- an evaluation stack, containing integers.
*)

(** The instruction set of the machine. *)

Inductive instruction: Type :=
  | Iconst(n: nat)                 (**r push integer [n] on stack *)
  | Ivar(x: id)                    (**r push the value of variable [x] *)
  | Isetvar(x: id)                 (**r pop an integer, assign it to variable [x] *)
  | Iadd                           (**r pop [n2], pop [n1], push back [n1+n2] *)
  | Isub                           (**r pop [n2], pop [n1], push back [n1-n2] *)
  | Imul                           (**r pop [n2], pop [n1], push back [n1*n2] *)
  | Ibranch_forward(ofs: nat)      (**r skip [ofs] instructions forward *)
  | Ibranch_backward(ofs: nat)     (**r skip [ofs] instructions backward *)
  | Ibeq(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1=n2] *)
  | Ibne(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1<>n2] *)
  | Ible(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1<=n2] *)
  | Ibgt(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1>n2] *)
  | Ihalt.                         (**r terminate execution successfully *)

Definition code := list instruction.

(** [code_at C pc = Some i] if [i] is the instruction at position [pc]
  in the list of instructions [C]. *)

Fixpoint code_at (C: code) (pc: nat) : option instruction :=
  match C, pc with
  | nil, _ => None
  | i :: C', O => Some i
  | i :: C', S pc' => code_at C' pc'
  end.

Definition stack := list nat.

(** The semantics of the virtual machine is given in small-step style,
  as a transition relation between machine configuration: triples
  (program counter, evaluation stack, variable state).
  The transition relation is parameterized by the code [c].
  There is one transition rule for each kind of instruction,
  except [Ihalt], which has no transition. *)

Definition configuration := (nat * stack * state)%type.

Inductive transition (C: code): configuration -> configuration -> Prop :=
  | trans_const: forall pc stk s n,
      code_at C pc = Some(Iconst n) ->
      transition C (pc, stk, s) (pc + 1, n :: stk, s)
  | trans_var: forall pc stk s x,
      code_at C pc = Some(Ivar x) ->
      transition C (pc, stk, s) (pc + 1, s x :: stk, s)
  | trans_setvar: forall pc stk s x n,
      code_at C pc = Some(Isetvar x) ->
      transition C (pc, n :: stk, s) (pc + 1, stk, t_update s x n)
  | trans_add: forall pc stk s n1 n2,
      code_at C pc = Some(Iadd) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc + 1, (n1 + n2) :: stk, s)
  | trans_sub: forall pc stk s n1 n2,
      code_at C pc = Some(Isub) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc + 1, (n1 - n2) :: stk, s)
  | trans_mul: forall pc stk s n1 n2,
      code_at C pc = Some(Imul) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc + 1, (n1 * n2) :: stk, s)
  | trans_branch_forward: forall pc stk s ofs pc',
      code_at C pc = Some(Ibranch_forward ofs) ->
      pc' = pc + 1 + ofs ->
      transition C (pc, stk, s) (pc', stk, s)
  | trans_branch_backward: forall pc stk s ofs pc',
      code_at C pc = Some(Ibranch_backward ofs) ->
      pc' = pc + 1 - ofs ->
      transition C (pc, stk, s) (pc', stk, s)
  | trans_beq: forall pc stk s ofs n1 n2 pc',
      code_at C pc = Some(Ibeq ofs) ->
      pc' = (if beq_nat n1 n2 then pc + 1 + ofs else pc + 1) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s)
  | trans_bne: forall pc stk s ofs n1 n2 pc',
      code_at C pc = Some(Ibne ofs) ->
      pc' = (if beq_nat n1 n2 then pc + 1 else pc + 1 + ofs) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s)
  | trans_ble: forall pc stk s ofs n1 n2 pc',
      code_at C pc = Some(Ible ofs) ->
      pc' = (if leb n1 n2 then pc + 1 + ofs else pc + 1) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s)
  | trans_bgt: forall pc stk s ofs n1 n2 pc',
      code_at C pc = Some(Ibgt ofs) ->
      pc' = (if leb n1 n2 then pc + 1 else pc + 1 + ofs) ->
      transition C (pc, n2 :: n1 :: stk, s) (pc', stk, s).

(** As usual with small-step semantics, we form sequences of machine transitions
  to define the behavior of a code.  We always start with [pc = 0]
  and an empty evaluation stack.  We stop successfully if [pc] points
  to an [Ihalt] instruction and the evaluation stack is empty.

  If [R] is a binary relation, [star R] is its reflexive transitive closure.
  (See file [Sequences] for the definition.)  [star (transition C)]
  therefore represents a sequence of  zero, one or several machine transitions.
*)

Definition mach_terminates (C: code) (s_init s_fin: state) :=
  exists pc,
  code_at C pc = Some Ihalt /\
  star (transition C) (0, nil, s_init) (pc, nil, s_fin).

(** Likewise, [infseq R] represents an infinite sequence of [R] transitions.
  (Also defined in file [Sequences].) *)

Definition mach_diverges (C: code) (s_init: state) :=
  infseq (transition C) (0, nil, s_init).

(** A third case can occur: after a finite number of transitions,
  the machine hits a configuration where it cannot make any transition,
  and this state is not a final configuration ([Ihalt] instruction and empty stack).
  In this case, we say that the machine "goes wrong", which is
  a politically-correct way of saying that our program just crashed. *)

Definition mach_goes_wrong (C: code) (s_init: state) :=
  exists pc, exists stk, exists s_fin,
  star (transition C) (0, nil, s_init) (pc, stk, s_fin)
  /\ irred (transition C) (pc, stk, s_fin)
  /\ (code_at C pc <> Some Ihalt \/ stk <> nil).

(** An important property of the virtual machine is that it is deterministic:
  from a given configuration, it can transition to at most one other configuration. *)

Lemma machine_deterministic:
  forall C config config1 config2,
  transition C config config1 -> transition C config config2 -> config1 = config2.
Proof.
  intros. inversion H; subst; inversion H0; try congruence.
  destruct (beq_nat n1 n2); congruence.
  destruct (beq_nat n1 n2); congruence.
  destruct (leb n1 n2); congruence.
  destruct (leb n1 n2); congruence.
Qed.

(** As a consequence of this determinism, it follows that
  the final state of a terminating program is unique,
  and that a program cannot both terminate and diverge,
  or terminate and go wrong, or diverge and go wrong.
  These results follow from the generic determinism properties
  found at the end of module [Sequence]. *)

Remark stop_irred:
  forall C pc stk st,
  code_at C pc = Some Ihalt -> irred (transition C) (pc, stk, st).
Proof.
  unfold irred; intros. unfold not; intros. inversion H0; congruence.
Qed.

Lemma terminates_unique:
  forall C st st1 st2, mach_terminates C st st1 -> mach_terminates C st st2 -> st1 = st2.
Proof.
  unfold mach_terminates; intros. destruct H as (pc1 & A1 & B1), H0 as (pc2 & A2 & B2).
  assert (((pc1, nil, st1) : configuration) = ((pc2, nil, st2) : configuration)).
  { eapply finseq_unique; eauto using machine_deterministic, stop_irred. }
  congruence.
Qed.

Lemma terminates_goeswrong_exclusive:
  forall C st st', mach_terminates C st st' -> mach_goes_wrong C st -> False.
Proof.
  unfold mach_terminates, mach_goes_wrong; intros.
  destruct H as (pc1 & A1 & B1), H0 as (pc2 & stk2 & st2 & A2 & B2 & C2).
  assert (((pc1, nil, st') : configuration) = ((pc2, stk2, st2) : configuration)).
  { eapply finseq_unique; eauto using machine_deterministic, stop_irred. }
  inversion H. subst pc2 stk2 st2. destruct C2; congruence.
Qed.

Lemma terminates_diverges_exclusive:
  forall C st st', mach_terminates C st st' -> mach_diverges C st -> False.
Proof.
  unfold mach_terminates, mach_diverges; intros.
  destruct H as (pc1 & A1 & B1).
  eapply infseq_finseq_excl with (R := transition C); eauto using machine_deterministic, stop_irred.
Qed.

Lemma goeswrong_diverges_exclusive:
  forall C st, mach_goes_wrong C st -> mach_diverges C st -> False.
Proof.
  unfold mach_terminates, mach_diverges; intros.
  destruct H as (pc2 & stk2 & st2 & A2 & B2 & C2).
  eapply infseq_finseq_excl with (R := transition C); eauto using machine_deterministic, stop_irred.
Qed.

(** *** Exercise (2 stars, recommended). *)
(** To quickly see how a machine program executes, it is convenient
  to redefine the semantics of the machine as an executable function
  instead of inductively-defined relations.  This is similar to the
  [ceval_step] function from the [Imp] chapter of Software Foundations,
  which provides an executable interpreter for the Imp language.

  To ensure termination of the machine interpreter, we need to bound
  the number of instructions it can execute.  The result of the
  machine interpreter, therefore, is of the following type:
*)

Inductive machine_result : Type :=
  | Timeout : machine_result              (**r the interpreter ran out of fuel *)
  | GoesWrong : machine_result            (**r the machine goes wrong on an impossible case *)
  | Terminates : state -> machine_result. (**r the machine successfully stops with the given state *)

(** Please fill in the blanks in the following definition for a machine interpreter: *)

Fixpoint mach_interp (C: code) (fuel: nat)
                     (pc: nat) (stk: stack) (st: state) : machine_result :=
  match fuel with
  | O => Timeout
  | S fuel' =>
      match code_at C pc, stk with
      | Some Ihalt, nil => Terminates st
      | Some (Iconst n), stk => mach_interp C fuel' (pc + 1) (n :: stk) st
      (* FILL IN HERE *)
      | _, _ => GoesWrong
      end
  end.

(** * 2. The compilation scheme *)

(** The code for an arithmetic expression [a]
- executes in sequence (no branches)
- deposits the value of [a] at the top of the stack
- preserves the variable state.

This is the familiar translation to "reverse Polish notation".
*)

Fixpoint compile_aexp (a: aexp) : code :=
  match a with
  | ANum n => Iconst n :: nil
  | AId v => Ivar v :: nil
  | APlus a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Iadd :: nil
  | AMinus a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Isub :: nil
  | AMult a1 a2 => compile_aexp a1 ++ compile_aexp a2 ++ Imul :: nil
  end.

(** Some examples. *)

Notation vx := (Id "X").
Notation vy := (Id "Y").

Compute (compile_aexp (APlus (AId vx) (ANum 1))).

(** Result is: [ [Ivar vx, Iconst 1, Iadd] ] *)

Compute (compile_aexp (AMult (AId vy) (APlus (AId vx) (ANum 1)))).

(** Result is: [ [Ivar vy, Ivar vx, Iconst 1, Iadd, Imul] ] *)

(** The code [compile_bexp b cond ofs] for a boolean expression [b]
- skips forward the [ofs] following instructions if [b] evaluates to [cond] (a boolean)
- executes in sequence if [b] evaluates to the negation of [cond]
- leaves the stack and the variable state unchanged.

See slides for explanation of the mysterious branch offsets!
*)

Fixpoint compile_bexp (b: bexp) (cond: bool) (ofs: nat) : code :=
  match b with
  | BTrue =>
      if cond then Ibranch_forward ofs :: nil else nil
  | BFalse =>
      if cond then nil else Ibranch_forward ofs :: nil
  | BEq a1 a2 =>
      compile_aexp a1 ++ compile_aexp a2 ++
      (if cond then Ibeq ofs :: nil else Ibne ofs :: nil)
  | BLe a1 a2 =>
      compile_aexp a1 ++ compile_aexp a2 ++
      (if cond then Ible ofs :: nil else Ibgt ofs :: nil)
  | BNot b1 =>
      compile_bexp b1 (negb cond) ofs
  | BAnd b1 b2 =>
      let c2 := compile_bexp b2 cond ofs in
      let c1 := compile_bexp b1 false (if cond then length c2 else ofs + length c2) in
      c1 ++ c2
  end.

(** Examples. *)

Compute (compile_bexp (BEq (AId vx) (ANum 1)) true 42).

(** Result is: [ [Ivar vx, Iconst 1, Ibeq 42] ] *)

Compute (compile_bexp (BAnd (BLe (ANum 1) (AId vx)) (BLe (AId vx) (ANum 10))) false 42).

(** Result is: [ [Iconst 1, Ivar vx, Ibgt 45, Ivar vx, Iconst 10, Ibgt 42] ] *)

Compute (compile_bexp (BNot (BAnd BTrue BFalse)) true 42).

(** Result is: [ [Ibranch_forward 42] ] *)

(** The code for a command [c]
- updates the variable state as prescribed by [c]
- preserves the stack
- finishes on the next instruction immediately following the generated code.

Again, see slides for explanations of the generated branch offsets.
*)

Fixpoint compile_com (c: com) : code :=
  match c with
  | SKIP =>
      nil
  | (id ::= a) =>
      compile_aexp a ++ Isetvar id :: nil
  | (c1 ;; c2) =>
      compile_com c1 ++ compile_com c2
  | IFB b THEN ifso ELSE ifnot FI =>
      let code_ifso := compile_com ifso in
      let code_ifnot := compile_com ifnot in
      compile_bexp b false (length code_ifso + 1)
      ++ code_ifso
      ++ Ibranch_forward (length code_ifnot)
      :: code_ifnot
  | WHILE b DO body END =>
      let code_body := compile_com body in
      let code_test := compile_bexp b false (length code_body + 1) in
      code_test
      ++ code_body
      ++ Ibranch_backward (length code_test + length code_body + 1)
      :: nil
  end.

(** The code for a program [p] (a command) is similar, but terminates
  cleanly on an [Ihalt] instruction. *)

Definition compile_program (p: com) : code :=
  compile_com p ++ Ihalt :: nil.

(** Examples of compilation: *)

Compute (compile_program (vx ::= APlus (AId vx) (ANum 1))).

(** Result is: [ [Ivar vx, Iconst 1, Iadd, Isetvar vx, Ihalt] ] *)

Compute (compile_program (WHILE BTrue DO SKIP END)).

(** Result is: [ [Ibranch_backward 1, Ihalt] ].  That's a tight loop indeed! *)

Compute (compile_program (IFB BEq (AId vx) (ANum 1) THEN vx ::= ANum 0 ELSE SKIP FI)).

(** Result is: [ [Ivar vx, Iconst 1, Ibne 3, Iconst 0, Isetvar vx, Ibranch_forward 0, Ihalt] ] *)

(** *** Exercise (1 star, recommended) *)
(** The last example shows a slight inefficiency in the code generated for
  [IFB ... THEN ... ELSE SKIP FI].  How would you change [compile_com]
  to generate better code?  Hint: ponder the following function. *)

Definition smart_Ibranch_forward (ofs: nat) : code :=
  if beq_nat ofs 0 then nil else Ibranch_forward(ofs) :: nil.

(** * 3. Semantic preservation *)

(** ** Auxiliary results about code sequences. *)

(** To reason about the execution of compiled code, we need to consider
  code sequences [C2] that are at position [pc] in a bigger code
  sequence [C = C1 ++ C2 ++ C3].  The following predicate
  [codeseq_at C pc C2] does just this. *)

Inductive codeseq_at: code -> nat -> code -> Prop :=
  | codeseq_at_intro: forall C1 C2 C3 pc,
      pc = length C1 ->
      codeseq_at (C1 ++ C2 ++ C3) pc C2.

(** We show a number of no-brainer lemmas about [code_at] and [codeseq_at],
  then populate a "hint database" so that Coq can use them automatically. *)

Lemma code_at_app:
  forall i c2 c1 pc,
  pc = length c1 ->
  code_at (c1 ++ i :: c2) pc = Some i.
Proof.
  induction c1; simpl; intros; subst pc; auto.
Qed.

Lemma codeseq_at_head:
  forall C pc i C',
  codeseq_at C pc (i :: C') ->
  code_at C pc = Some i.
Proof.
  intros. inversion H. simpl. apply code_at_app. auto.
Qed.

Lemma codeseq_at_tail:
  forall C pc i C',
  codeseq_at C pc (i :: C') ->
  codeseq_at C (pc + 1) C'.
Proof.
  intros. inversion H.
  change (C1 ++ (i :: C') ++ C3)
    with (C1 ++ (i :: nil) ++ C' ++ C3).
  rewrite <- app_ass. constructor. rewrite app_length. auto.
Qed.

Lemma codeseq_at_app_left:
  forall C pc C1 C2,
  codeseq_at C pc (C1 ++ C2) ->
  codeseq_at C pc C1.
Proof.
  intros. inversion H. rewrite app_ass. constructor. auto.
Qed.

Lemma codeseq_at_app_right:
  forall C pc C1 C2,
  codeseq_at C pc (C1 ++ C2) ->
  codeseq_at C (pc + length C1) C2.
Proof.
  intros. inversion H. rewrite app_ass. rewrite <- app_ass. constructor. rewrite app_length. auto.
Qed.

Lemma codeseq_at_app_right2:
  forall C pc C1 C2 C3,
  codeseq_at C pc (C1 ++ C2 ++ C3) ->
  codeseq_at C (pc + length C1) C2.
Proof.
  intros. inversion H. repeat rewrite app_ass. rewrite <- app_ass. constructor. rewrite app_length. auto.
Qed.

Hint Resolve codeseq_at_head codeseq_at_tail codeseq_at_app_left codeseq_at_app_right codeseq_at_app_right2: codeseq.

Ltac normalize :=
  repeat rewrite app_length in *;
  repeat rewrite plus_assoc in *;
  repeat rewrite plus_0_r in *;
  simpl in *.

(** ** Correctness of generated code for expressions. *)

(** Remember the informal specification we gave for the code generated
  for an arithmetic expression [a].  It should
- execute in sequence (no branches)
- deposit the value of [a] at the top of the stack
- preserve the variable state.

We now prove that the code [compile_aexp a] fulfills this contract.
The proof is a nice induction on the structure of [a]. *)

Lemma compile_aexp_correct:
  forall C st a pc stk,
  codeseq_at C pc (compile_aexp a) ->
  star (transition C)
       (pc, stk, st)
       (pc + length (compile_aexp a), aeval st a :: stk, st).
Proof.
  induction a; simpl; intros.

- (* ANum *)
  apply star_one. apply trans_const. eauto with codeseq.

- (* AId *)
  apply star_one. apply trans_var. eauto with codeseq.

- (* APlus *)
  eapply star_trans.
  apply IHa1. eauto with codeseq.
  eapply star_trans.
  apply IHa2. eauto with codeseq.
  apply star_one. normalize. apply trans_add. eauto with codeseq.

- (* AMinus *)
  eapply star_trans.
  apply IHa1. eauto with codeseq.
  eapply star_trans.
  apply IHa2. eauto with codeseq.
  apply star_one. normalize. apply trans_sub. eauto with codeseq.

- (* AMult *)
  eapply star_trans.
  apply IHa1. eauto with codeseq.
  eapply star_trans.
  apply IHa2. eauto with codeseq.
  apply star_one. normalize. apply trans_mul. eauto with codeseq.
Qed.

(** Here is a similar proof for the compilation of boolean expressions. *)

Lemma compile_bexp_correct:
  forall C st b cond ofs pc stk,
  codeseq_at C pc (compile_bexp b cond ofs) ->
  star (transition C)
       (pc, stk, st)
       (pc + length (compile_bexp b cond ofs) + if eqb (beval st b) cond then ofs else 0, stk, st).
Proof.
  induction b; simpl; intros.

- (* BTrue *)
  destruct cond; simpl.
  + (* BTrue, true *)
    apply star_one. apply trans_branch_forward with ofs. eauto with codeseq. auto.
  + (* BTrue, false *)
    repeat rewrite plus_0_r. apply star_refl.

- (* BFalse *)
  destruct cond; simpl.
  + (* BFalse, true *)
    repeat rewrite plus_0_r. apply star_refl.
  + (* BFalse, false *)
    apply star_one. apply trans_branch_forward with ofs. eauto with codeseq. auto.

- (* BEq *)
  eapply star_trans.
  apply compile_aexp_correct with (a := a). eauto with codeseq.
  eapply star_trans.
  apply compile_aexp_correct with (a := a0). eauto with codeseq.
  apply star_one. normalize.
  destruct cond.
  + (* BEq, true *)
    apply trans_beq with ofs. eauto with codeseq.
    destruct (beq_nat (aeval st a) (aeval st a0)); simpl; omega.
  + (* BEq, false *)
    apply trans_bne with ofs. eauto with codeseq.
    destruct (beq_nat (aeval st a) (aeval st a0)); simpl; omega.

- (* BLe *)
  eapply star_trans.
  apply compile_aexp_correct with (a := a). eauto with codeseq.
  eapply star_trans.
  apply compile_aexp_correct with (a := a0). eauto with codeseq.
  apply star_one. normalize.
  destruct cond.
  + (* BLe, true *)
    apply trans_ble with ofs. eauto with codeseq.
    destruct (leb (aeval st a) (aeval st a0)); simpl; omega.
  + (* BLe, false *)
    apply trans_bgt with ofs. eauto with codeseq.
    destruct (leb (aeval st a) (aeval st a0)); simpl; omega.

- (* BNot *)
  replace (eqb (negb (beval st b)) cond)
     with (eqb (beval st b) (negb cond)).
  apply IHb; auto.
  destruct (beval st b); destruct cond; auto.

- (* BAnd *)
  set (code_b2 := compile_bexp b2 cond ofs) in *.
  set (ofs' := if cond then length code_b2 else ofs + length code_b2) in *.
  set (code_b1 := compile_bexp b1 false ofs') in *.
  apply star_trans with (pc + length code_b1 + (if eqb (beval st b1) false then ofs' else 0), stk, st).
  apply IHb1. eauto with codeseq.
  destruct cond.
  + (* BAnd, true *)
    destruct (beval st b1); simpl.
    * (* b1 evaluates to true *)
      normalize. apply IHb2. eauto with codeseq.
    * (* b1 evaluates to false *)
      normalize. apply star_refl.
  + (* BAnd, false *)
    destruct (beval st b1); simpl.
    * (* b1 evaluates to true *)
      normalize. apply IHb2. eauto with codeseq.
    * (* b1 evaluates to false *)
      replace ofs' with (length code_b2 + ofs). normalize. apply star_refl.
      unfold ofs'; omega.
Qed.

(** ** Correctness of generated code for commands: terminating case. *)

Lemma compile_com_correct_terminating:
  forall C st c st',
  c / st \\ st' ->
  forall stk pc,
  codeseq_at C pc (compile_com c) ->
  star (transition C)
       (pc, stk, st)
       (pc + length (compile_com c), stk, st').
Proof.
  induction 1; intros stk pc AT.

- (* SKIP *)
  simpl in *. rewrite plus_0_r. apply star_refl.

- (* := *)
  simpl in *. subst n.
  eapply star_trans. apply compile_aexp_correct. eauto with codeseq.
  apply star_one. normalize. apply trans_setvar. eauto with codeseq.

- (* sequence *)
  simpl in *.
  eapply star_trans. apply IHceval1. eauto with codeseq.
  normalize. apply IHceval2. eauto with codeseq.

- (* if true *)
  simpl in *.
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  eapply star_trans.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length code1 + 1).
  eauto with codeseq.
  rewrite H. simpl. rewrite plus_0_r. fold codeb. normalize.
  eapply star_trans. apply IHceval. eauto with codeseq.
  apply star_one. eapply trans_branch_forward. eauto with codeseq. omega.

- (* if false *)
  simpl in *.
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  eapply star_trans.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length code1 + 1).
  eauto with codeseq.
  rewrite H. simpl. fold codeb. normalize.
  replace (pc + length codeb + length code1 + S(length code2))
     with (pc + length codeb + length code1 + 1 + length code2).
  apply IHceval. eauto with codeseq. omega.

- (* while false *)
  simpl in *.
  eapply star_trans.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length (compile_com c) + 1).
  eauto with codeseq.
  rewrite H. simpl. normalize. apply star_refl.

- (* while true *)
  apply star_trans with (pc, stk, st').
  simpl in *.
  eapply star_trans.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length (compile_com c) + 1).
  eauto with codeseq.
  rewrite H; simpl. rewrite plus_0_r.
  eapply star_trans. apply IHceval1. eauto with codeseq.
  apply star_one.
  eapply trans_branch_backward. eauto with codeseq. omega.
  apply IHceval2. auto.
Qed.

Theorem compile_program_correct_terminating:
  forall c st st',
  c / st \\ st' ->
  mach_terminates (compile_program c) st st'.
Proof.
  intros. unfold compile_program. red.
  exists (length (compile_com c)); split.
  apply code_at_app. auto.
  apply compile_com_correct_terminating with (pc := 0). auto.
  apply codeseq_at_intro with (C1 := nil). auto.
Qed.

(** *** Exercise (2 stars, recommended) *)
(** The previous exercise in this chapter suggested to use
  [smart_Ibranch_forward] to avoid generating useless "branch forward"
  instructions when compiling [IFB ... THEN ... ELSE SKIP FI] commands.
  Once you have modified [compile_com] to use [smart_Ibranch_forward],
  adapt the proof of [compile_com_correct_terminating] accordingly.
  The following lemma will come handy: *)

Lemma trans_smart_branch_forward:
  forall C ofs pc stk st,
  codeseq_at C pc (smart_Ibranch_forward ofs) ->
  star (transition C) (pc, stk, st) (pc + length (smart_Ibranch_forward ofs) + ofs, stk, st).
Proof.
  unfold smart_Ibranch_forward; intros.
  (* FILL IN HERE *)
Admitted.

(** *** Exercise (3 stars, optional) *)
(** The manufacturer of our virtual machine offers a cheaper variant
  that lacks the [Ibge] and [Ibgt] conditional branches.  The only
  conditional branches available are [Ibeq] (branch if equal) and
  [Ibne] (branch if different).  Modify the definition of [compile_bexp] and
  its correctness proof to target this cheaper virtual machine.
  Hint: study Coq's definition of subtraction between natural numbers
  (do [Print Nat.sub]). *)

(** ** Correctness of generated code for commands: general case. *)

(** We would like to strengthen the correctness result above so that it
  is not restricted to terminating source programs, but also applies to
  source program that diverge.  To this end, we abandon the big-step
  semantics for commands and switch to the small-step semantics with continuations.
  We then show a simulation theorem, establishing that every transition
  of the small-step semantics in the source program is simulated (in a sense
  to be made precise below) by zero, one or several transitions of the
  machine executing the compiled code for the source program. *)

(** Our first task is to relate configurations [(c, k, st)] of the small-step
  semantics with configurations [(C, pc, stk, st)] of the machine.
  We already know how to relate a command [c] with the machine code,
  using the [codeseq_at] predicate.  What needs to be defined is a relation
  between the continuation [k] and the machine code.

  Intuitively, when the machine finishes executing the generated code for
  command [c], that is, when it reaches the program point
  [pc + length(compile_com c)], the machine should continue by executing
  instructions that perform the pending computations described by
  continuation [k], then reach an [Ihalt] instruction to stop cleanly.

  We formalize this intution by the following inductive predicate
  [compile_cont C k pc], which states that, starting at program point [pc],
  there are instructions that perform the computations described in [k]
  and reach an [Ihalt] instruction. *)

Inductive compile_cont (C: code): cont -> nat -> Prop :=
  | ccont_stop: forall pc,
      code_at C pc = Some Ihalt ->
      compile_cont C Kstop pc
  | ccont_seq: forall c k pc pc',
      codeseq_at C pc (compile_com c) ->
      pc' = pc + length (compile_com c) ->
      compile_cont C k pc' ->
      compile_cont C (Kseq c k) pc
  | ccont_while: forall b c k pc ofs pc' pc'',
      code_at C pc = Some(Ibranch_backward ofs) ->
      pc' = pc + 1 - ofs ->
      codeseq_at C pc' (compile_com (WHILE b DO c END)) ->
      pc'' = pc' + length (compile_com (WHILE b DO c END)) ->
      compile_cont C k pc'' ->
      compile_cont C (Kwhile b c k) pc
  | ccont_branch: forall ofs k pc pc',
      code_at C pc = Some(Ibranch_forward ofs) ->
      pc' = pc + 1 + ofs ->
      compile_cont C k pc' ->
      compile_cont C k pc.

(** Then, a configuration [(c,k,st)] of the small-step semantics matches
  a configuration [(C, pc, stk, st')] of the machine if the following conditions hold:
- The memory states are identical: [st' = st].
- The machine stack is empty: [stk = nil].
- The machine code at point [pc] is the compiled code for [c]:
  [codeseq_at C pc (compile_com c)].
- The machine code at point [pc + length (compile_com c)] matches continuation
  [k], in the sense of [compile_cont] above.
*)

Inductive match_config (C: code): com * cont * state -> configuration -> Prop :=
  | match_config_intro: forall c k st pc,
      codeseq_at C pc (compile_com c) ->
      compile_cont C k (pc + length (compile_com c)) ->
      match_config C (c, k, st) (pc, nil, st).

(** We are now ready to prove the expected simulation property.  Our first
  attempt is to show a diagram of the following form:
<<
                      match_config
     c / k / st  ----------------------- machstate
       |                                   |
       |                                   | *
       |                                   |
       v                                   v
    c' / k' / st' ----------------------- machstate'
                      match_config
>>
Hypotheses:
- Left: one transition in the small-step continuation semantics for Imp.
- Top: the [match_config] invariant.

Conclusions:
- Bottom: the [match_config] invariant, which must be preserved.
- Right: zero, one or several transitions of the virtual machine.

Why "zero, one, or several"?  Some transitions of the Imp semantics involve
the evaluation of a complex expression, which requires several machine instructions
to be executed.  However, other transitions of the Imp semantics, such as
the [KS_Seq] and [KS_SkipSeq] rules, just change the focus on a sub-command,
but the machine need not execute any instruction to reflect this change of focus.
*)

Lemma simulation_step_first_attempt:
  forall C impstate1 impstate2 machstate1,
  kstep impstate1 impstate2 ->
  match_config C impstate1 machstate1 ->
  exists machstate2,
      star (transition C) machstate1 machstate2
   /\ match_config C impstate2 machstate2.
Proof.
Abort.

(** This simulation lemma is true and can be proved, but it is too weak to
  imply the preservation of diverging behaviors: we have an issue with
  "infinite stuttering".  Imagine a situation where the source program
  takes infinitely many transitions, but every such transition is matched
  by zero transitions of the virtual machine.  In this case, the source
  program diverges, but the machine code can do anything: it can diverge,
  as expected, but it can also terminate cleanly or go wrong.
  The simulation lemma above is too weak to rule out the last two cases!

  We therefore need a stronger simulation result that rules out stuttering.
  To this end, we are going to require that if a source transition is
  matched by zero machine transition, some nonnegative measure of the source
  configuration must strictly decrease.  This ensures that only a finite
  number of stuttering steps can be taken before the machine actually does
  a transition.  Here is the revised simulation diagram:

<<
                      match_config
     c / k / st  ----------------------- machconfig
       |                                   |
       |                                   | + or ( * and |c',k'| < |c,k} )
       |                                   |
       v                                   v
    c' / k' / st' ----------------------- machconfig'
                      match_config
>>
Note the stronger conclusion on the right:
- either the virtual machine does one or several transitions
- or it does zero, one or several transitions, but the size of the [c,k]
  pair decreases strictly.

It would be equivalent to state:
- either the virtual machine does one or several transitions
- or it does zero transitions, but the size of the [c,k] pair decreases strictly.

However, the formulation above, with the "star" case, is often more convenient.
*)

(** Finding an appropriate "anti-stuttering" measure is a bit of a black art.
After trial and error, we find that the following measure works.  It is
the sum of the sizes of the command [c] under focus and all the commands
appearing in the continuation [k]. *)

Fixpoint com_size (c: com) : nat :=
  match c with
  | SKIP => 1
  | x ::= a => 1
  | (c1 ;; c2) => com_size c1 + com_size c2 + 1
  | IFB b THEN ifso ELSE ifnot FI => com_size ifso + com_size ifnot + 1
  | WHILE b DO c1 END => com_size c1 + 1
  end.

Remark com_size_nonzero: forall c, com_size c > 0.
Proof.
  induction c; simpl; omega.
Qed.

Fixpoint cont_size (k: cont) : nat :=
  match k with
  | Kstop => 0
  | Kseq c k' => com_size c + cont_size k'
  | Kwhile b c k' => cont_size k'
  end.

Definition measure (impconf: com * cont * state) : nat :=
  match impconf with (c, k, m) => com_size c + cont_size k end.

(** A few technical lemmas to help with the simulation proof. *)

Lemma compile_cont_Kstop_inv:
  forall C pc m,
  compile_cont C Kstop pc ->
  exists pc',
  star (transition C) (pc, nil, m) (pc', nil, m)
  /\ code_at C pc' = Some Ihalt.
Proof.
  intros. dependent induction H.
- exists pc; split. apply star_refl. auto.
- destruct IHcompile_cont as [pc'' [A B]]; auto.
  exists pc''; split; auto. eapply star_step; eauto. eapply trans_branch_forward; eauto.
Qed.

Lemma compile_cont_Kseq_inv:
  forall C c k pc m,
  compile_cont C (Kseq c k) pc ->
  exists pc',
  star (transition C) (pc, nil, m) (pc', nil, m)
  /\ codeseq_at C pc' (compile_com c)
  /\ compile_cont C k (pc' + length(compile_com c)).
Proof.
  intros. dependent induction H.
  exists pc; split. apply star_refl. split; congruence.
  destruct (IHcompile_cont _ _ eq_refl) as [pc'' [A [B D]]].
  exists pc''; split; auto. eapply star_step; eauto. eapply trans_branch_forward; eauto.
Qed.

Lemma compile_cont_Kwhile_inv:
  forall C b c k pc m,
  compile_cont C (Kwhile b c k) pc ->
  exists pc',
  plus (transition C) (pc, nil, m) (pc', nil, m)
  /\ codeseq_at C pc' (compile_com (WHILE b DO c END))
  /\ compile_cont C k (pc' + length(compile_com (WHILE b DO c END))).
Proof.
  intros. dependent induction H.
- exists (pc + 1 - ofs); split.
  apply plus_one. eapply trans_branch_backward; eauto.
  split; congruence.
- destruct (IHcompile_cont _ _ _ (refl_equal _)) as [pc'' [A [B D]]].
  exists pc''; split; auto. eapply plus_left. eapply trans_branch_forward; eauto. apply plus_star; auto.
Qed.

Remark code_at_inv:
  forall C pc i, code_at C pc = Some i -> exists C1, exists C2, C = C1 ++ C2 /\ length C1 = pc.
Proof.
  induction C; simpl; intros.
  inversion H.
  destruct pc. inversion H. exists (@nil instruction); exists (i :: C); auto.
  destruct (IHC _ _ H) as [C1 [C2 [A B]]].
  exists (a :: C1); exists C2; split. simpl; congruence. simpl; congruence.
Qed.

Remark code_at_codeseq:
  forall C pc i, code_at C pc = Some i -> codeseq_at C pc nil.
Proof.
  intros. destruct (code_at_inv _ _ _ H) as [C1 [C2 [A B]]].
  subst. change C2 with (nil ++ C2). constructor. auto.
Qed.

Lemma match_config_skip:
  forall C k m pc,
  compile_cont C k pc ->
  match_config C (SKIP, k, m) (pc, nil, m).
Proof.
  intros C.
  assert (forall k pc, compile_cont C k pc -> codeseq_at C pc nil).
    induction 1.
    eapply code_at_codeseq; eauto.
    change (compile_com c) with (nil ++ compile_com c) in H. eauto with codeseq.
    eapply code_at_codeseq; eauto.
    eapply code_at_codeseq; eauto.
  intros. constructor. simpl. eauto. simpl. rewrite plus_0_r; auto.
Qed.

(** At long last, we can state and prove the right simulation diagram. *)

Lemma simulation_step:
  forall C impstate1 impstate2 machstate1,
  kstep impstate1 impstate2 ->
  match_config C impstate1 machstate1 ->
  exists machstate2,
      (plus (transition C) machstate1 machstate2
       \/ (star (transition C) machstate1 machstate2 /\ measure impstate2 < measure impstate1))
   /\ match_config C impstate2 machstate2.
Proof.
  intros until machstate1; intros KSTEP MATCH.
  inversion KSTEP; clear KSTEP; subst; inversion MATCH; clear MATCH; subst; simpl in *.

- (* assign *)
  econstructor; split.
  left. eapply plus_right. eapply compile_aexp_correct; eauto with codeseq.
  eapply trans_setvar; eauto with codeseq.
  normalize. apply match_config_skip. auto.

- (* seq *)
  econstructor; split.
  right; split. apply star_refl. omega.
  normalize. constructor. eauto with codeseq. eapply ccont_seq; eauto with codeseq.

- (* if true *)
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  econstructor; split.
  right; split.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length code1 + 1).
  eauto with codeseq.
  omega.
  rewrite H; simpl. fold codeb. normalize. constructor; eauto with codeseq.
  eapply ccont_branch; eauto with codeseq.
  change (S (length code2)) with (1 + length code2) in H5. normalize. auto.

- (* if false *)
  set (code1 := compile_com c1) in *.
  set (codeb := compile_bexp b false (length code1 + 1)) in *.
  set (code2 := compile_com c2) in *.
  econstructor; split.
  right; split.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length code1 + 1).
  eauto with codeseq.
  omega.
  rewrite H; simpl. fold codeb. normalize. constructor; eauto with codeseq.
  change (S (length code2)) with (1 + length code2) in H5. normalize. auto.

- (* while true *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b false (length codec + 1)) in *.
  econstructor; split.
  right; split.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length codec + 1).
  eauto with codeseq.
  omega.
  rewrite H; simpl. fold codeb. normalize. constructor; eauto with codeseq.
  fold codec.
  assert (PC: pc + length codeb + length codec + 1 - (length codeb + length codec + 1) = pc)
      by omega.
  eapply ccont_while; eauto with codeseq. rewrite PC; auto. rewrite PC.
  simpl. normalize. auto.

- (* while false *)
  set (codec := compile_com c) in *.
  set (codeb := compile_bexp b false (length codec + 1)) in *.
  econstructor; split.
  right; split.
  apply compile_bexp_correct with (b := b) (cond := false) (ofs := length codec + 1).
  eauto with codeseq.
  generalize (com_size_nonzero c). omega.
  rewrite H; simpl. fold codeb. normalize. apply match_config_skip. auto.

- (* skip seq *)
  normalize.
  destruct (compile_cont_Kseq_inv _ _ _ _ st H4) as [pc' [X [Y Z]]].
  econstructor; split.
  right; split. eexact X. omega.
  constructor; auto.

- (* skip while *)
  normalize.
  destruct (compile_cont_Kwhile_inv _ _ _ _ _ st H4) as [pc' [X [Y Z]]].
  econstructor; split.
  left. eexact X.
  constructor; auto.
Qed.

(** Simulation diagrams such as [simulation_step] above imply semantic preservation
  for terminating programs and for diverging programs.  We now develop a generic
  proof of this fact that we can reuse later for other program transformations. *)

Section SIMULATION_DIAGRAM.

(** The generic proof is parameterized over the small-step semantics for the
  source and target languages, and over an invariant between their states. *)

Variable state1: Type.	     (**r the type of configurations for the source language *)
Variable step1: state1 -> state1 -> Prop.   (**r the small-step semantics for the source language *)

Variable state2: Type.	     (**r the type of configurations for the target language *)
Variable step2: state2 -> state2 -> Prop.   (**r the small-step semantics for the target language *)

Variable match_states: state1 -> state2 -> Prop.  (**r the invariant *)

Variable measure: state1 -> nat.                  (**r the anti-stuttering measure *)

Hypothesis simulation:
  forall S1 S1' S2,
  step1 S1 S1' -> match_states S1 S2 ->
  exists S2',
    (plus step2 S2 S2' \/ (star step2 S2 S2' /\ measure S1' < measure S1))
  /\ match_states S1' S2'.

(** We first extend the simulation to finite sequences of source transitions.
  This will show semantic preservation for terminating programs. *)

Lemma simulation_star:
  forall S1 S1', star step1 S1 S1' ->
  forall S2, match_states S1 S2 ->
  exists S2', star step2 S2 S2' /\ match_states S1' S2'.
Proof.
  induction 1; intros.
- (* zero transition *)
  exists S2; split. apply star_refl. auto.
- (* one or more transitions *)
  destruct (simulation _ _ _ H H1) as [S2' [P Q]].
  destruct (IHstar _ Q) as [S2'' [U V]].
  exists S2''; split.
  eapply star_trans; eauto. destruct P. apply plus_star; auto. destruct H2; auto.
  auto.
Qed.

(** Turning to infinite sequences, we first show that the target program
  can always make progress, while preserving the [match_states] relation,
  if the source diverges.  The proof is an induction on the maximal number
  [N] of stutterings the target can make before performing at least one transition. *)

Lemma simulation_infseq_productive:
  forall N S1 S2,
  measure S1 < N ->
  infseq step1 S1 ->
  match_states S1 S2 ->
  exists S1', exists S2',
      plus step2 S2 S2'
   /\ infseq step1 S1'
   /\ match_states S1' S2'.
Proof.
  induction N; intros.
- (* N = 0 *)
  exfalso. omega.
- (* N > 0 *)
  inversion H0; clear H0; subst.
  destruct (simulation _ _ _ H2 H1) as [S2' [P Q]].
  destruct P.
  + (* one or several transitions *)
    exists b; exists S2'; auto.
  + (* zero, one or several transitions *)
    destruct H0. inversion H0; clear H0; subst.
    * (* zero transitions *)
      eapply IHN; eauto. omega.
    * (* one or several transitions *)
      exists b; exists S2'; split. eapply plus_left; eauto. auto.
Qed.

(** It follows that the target performs infinitely many transitions if
  started in a configuration that matches a diverging source configuration. *)

Lemma simulation_infseq:
  forall S1 S2,
  infseq step1 S1 ->
  match_states S1 S2 ->
  infseq step2 S2.
Proof.
  intros.
  apply infseq_coinduction_principle_2 with
    (X := fun S2 => exists S1, infseq step1 S1 /\ match_states S1 S2).
  intros. destruct H1 as [S [A B]].
  destruct (simulation_infseq_productive (measure S + 1) S a)
  as [S1' [S2' [P [Q R]]]].
  omega. auto. auto.
  exists S2'; split. auto. exists S1'; auto.
  exists S1; auto.
Qed.

End SIMULATION_DIAGRAM.

(** We now apply these results to the Imp compiler.  We first obtain
  an alternate proof of semantic preservation for terminating Imp programs. *)

Lemma match_config_initial:
  forall c st,
  match_config (compile_program c) (c, Kstop, st) (0, nil, st).
Proof.
  intros. constructor.
  change (compile_program c) with (nil ++ compile_com c ++ Ihalt :: nil). constructor. auto.
  simpl. unfold compile_program. constructor. apply code_at_app. auto.
Qed.

Theorem compile_program_correct_terminating_2:
  forall c st st',
  kterminates c st st' ->
  mach_terminates (compile_program c) st st'.
Proof.
  intros.
  assert (exists machconf2,
           star (transition (compile_program c)) (0, nil, st) machconf2
           /\ match_config (compile_program c) (SKIP, Kstop, st') machconf2).
  eapply simulation_star; eauto. eapply simulation_step. apply match_config_initial.
  destruct H0 as [machconf2 [STAR MS]].
  inversion MS; subst. simpl in *. normalize.
  destruct (compile_cont_Kstop_inv _ _ st' H5) as [pc' [A B]].
  red. exists pc'; split. auto. eapply star_trans; eauto.
Qed.

(** More interestingly, we also prove semantic preservation for diverging
  Imp programs. *)

Theorem compile_program_correct_diverging:
  forall c st,
  kdiverges c st ->
  mach_diverges (compile_program c) st.
Proof.
  intros; red; intros.
  eapply simulation_infseq with (match_states := match_config (compile_program c)); eauto.
  eapply simulation_step. apply match_config_initial.
Qed.

(** *** Mini-project (4 stars) *)

(** Our compiler for arithmetic expressions implements a left-to-right
  evaluation order: in [a1 + a2], [a1] is evaluated first, and its value
  left on the stack; then [a2] is evaluated; then an [Iadd] instruction
  is performed.  For commutative operators like [+] and [*], we
  could just as well evaluate [a2] first, then [a1], then combine
  their results.

  This can help producing more efficient code in terms of how much
  stack space is required by the evaluation.  Consider the expression
  [1 + (2 + (3 + ... (N-1 + N)))].  With left-to-right evaluation,
  it uses [N+1] stack entries.  With right-to-left evaluation,
  it uses only 2 stack entries.

  In this exercise, we explore the effect of different evaluation orders
  on stack usage.  Let us first parameterize [compile_aexp] with
  a heuristic function [ord] that, given the two arguments of a [+]
  or [*] operator, decides whether to evaluate them left-to-right
  or right-to-left: *)

Inductive eval_order : Type := LtoR | RtoL.

Fixpoint compile_aexp_gen (ord: aexp -> aexp -> eval_order) (a: aexp) : code :=
  match a with
  | ANum n => Iconst n :: nil
  | AId v => Ivar v :: nil
  | APlus a1 a2 =>
      match ord a1 a2 with
      | LtoR => compile_aexp_gen ord a1 ++ compile_aexp_gen ord a2 ++ Iadd :: nil
      | RtoL => compile_aexp_gen ord a2 ++ compile_aexp_gen ord a1 ++ Iadd :: nil
      end
  | AMinus a1 a2 =>
      compile_aexp_gen ord a1 ++ compile_aexp_gen ord a2 ++ Isub :: nil
  | AMult a1 a2 =>
      match ord a1 a2 with
      | LtoR => compile_aexp_gen ord a1 ++ compile_aexp_gen ord a2 ++ Imul :: nil
      | RtoL => compile_aexp_gen ord a2 ++ compile_aexp_gen ord a1 ++ Imul :: nil
      end
  end.

(** First show that, whatever the [ord] heuristic is, the code generated
by [compile_aexp_gen ord] is correct.  This is a simple extension of
the proof of [compile_aexp_correct]. *)

Lemma compile_aexp_gen_correct:
  forall ord C st a pc stk,
  codeseq_at C pc (compile_aexp_gen ord a) ->
  star (transition C)
       (pc, stk, st)
       (pc + length (compile_aexp_gen ord a), aeval st a :: stk, st).
Proof.
  induction a; simpl; intros.
  (* FILL IN HERE *)
Admitted.

(** Now, let us try to compute the minimum number of stack entries
  needed to evaluate an expression, regardless of the strategy used. *)

Require Import Min Max.     (**r Libraries of lemmas about min and max *)

Fixpoint stack_needs (a: aexp) : nat :=
  match a with
  | ANum n => 1
  | AId v => 1
  | APlus a1 a2 =>
      let n1 := stack_needs a1 in
      let n2 := stack_needs a2 in
      min (max n1 (n2 + 1)) (max n2 (n1 + 1))
  | AMinus a1 a2 =>
      let n1 := stack_needs a1 in
      let n2 := stack_needs a2 in
      max n1 (n2 + 1)
  | AMult a1 a2 =>
      let n1 := stack_needs a1 in
      let n2 := stack_needs a2 in
      min (max n1 (n2 + 1)) (max n2 (n1 + 1))
  end.

(** This definition is a variation on the Strahler numbering of a tree.
  Here are some intuitions.  Consider [APlus a1 a2].  If we
  evaluate [a1] then [a2], we will need at least [stack_needs a1]
  space for evaluating [a1], then [stack_needs a2 + 1] for [a2]:
  plus one, because during the evaluation of [a2], the value of [a1]
  sits in the stack.  So, our space usage is the max of these two
  quantities.  But we can also choose the other evaluation order,
  so our space usage is the min of the two max corresponding to the
  two possible evaluation orders. *)

(** To show that [stack_needs] is the minimal stack size required,
  we can define the stack usage (number of stack entries needed) of
  a given strategy [ord], the show that it is at least [stack_needs]. *)

Fixpoint stack_usage (ord: aexp -> aexp -> eval_order) (a: aexp) : nat :=
  match a with
  | ANum n => 1
  | AId v => 1
  | APlus a1 a2 =>
      match ord a1 a2 with
      | LtoR => max (stack_usage ord a1) (stack_usage ord a2 + 1)
      | RtoL => max (stack_usage ord a2) (stack_usage ord a1 + 1)
      end
  | AMinus a1 a2 =>
      max (stack_usage ord a1) (stack_usage ord a2 + 1)
  | AMult a1 a2 =>
      match ord a1 a2 with
      | LtoR => max (stack_usage ord a1) (stack_usage ord a2 + 1)
      | RtoL => max (stack_usage ord a2) (stack_usage ord a1 + 1)
      end
  end.

Lemma stack_needs_is_optimal:
  forall ord a, stack_needs a <= stack_usage ord a.
Proof.
  (* FILL IN HERE *)
Admitted.

(** Useful tip: the tactic [zify; omega] works very well to prove
    arithmetic properties involving min and max operators. *)

(** An optimal strategy (with respect to stack usage) is to always
  compute the biggest subexpression first: *)

Definition optimal_ord (a1 a2: aexp) :=
  if leb (stack_needs a2) (stack_needs a1) then LtoR else RtoL.

Definition compile_aexp_optimal (a: aexp) : code :=
  compile_aexp_gen optimal_ord a.

(** The intuition is simple: if one of the arguments, say [a1], has
  stack needs strictly less than the other, say [a2], evaluating [a1]
  after [a2], with [a2]'s value as additional entry on the stack,
  will use no more stack space than evaluating [a2].  So, evaluating
  [a1 + a2] can be done with no extra space than evaluating just [a2].
  This would not be the case if we started with [a1], then evaluated [a2]:
  in this case, one more stack slot would be needed.

  If both arguments have the same stack needs, the two evaluation
  orders use exactly the same amount of space, so it does not matter
  which one we choose. *)

(** We can show the optimality of the strategy by observing that
  its stack usage is the minimum predicted by [stack_needs]. *)

Lemma stack_usage_optimal_ord:
  forall a, stack_usage optimal_ord a = stack_needs a.
Proof.
  (* FILL IN HERE *)
Admitted.

(** So far, we've reasoned informally on the stack usage of a particular
  evaluation strategy.  Now, let us formally connect this reasoning with the
  execution of the compiled code.  First, we need to instrument the
  virtual machine so that it monitors its stack usage and goes wrong
  if the stack size goes over a given maximum [maxstack]. *)

Inductive checked_transition (C: code) (maxstack: nat) : configuration -> configuration -> Prop :=
  | ctrans: forall pc stk s pc' stk' s',
      transition C (pc, stk, s) (pc', stk', s') ->
      length stk' <= maxstack ->
      checked_transition C maxstack (pc, stk, s) (pc', stk', s').

(** Now, we can state and prove the fact that the compiled code for
  expression [a] with respect to a strategy [ord] execute safely
  if at least [stack_usage ord a] stack entries are available. *)

Lemma compile_aexp_gen_safe:
  forall ord C maxstack st a pc stk,
  codeseq_at C pc (compile_aexp_gen ord a) ->
  length stk + stack_usage ord a <= maxstack ->
  star (checked_transition C maxstack)
       (pc, stk, st)
       (pc + length (compile_aexp_gen ord a), aeval st a :: stk, st).
Proof.
  induction a; simpl; intros.
Admitted.

(** Moreover, the size [stack_usage ord a] is tight, in that there exists
  a point in the execution of the compiled code for [a] where the stack
  is at least that big. *)

Lemma stack_usage_reached:
  forall ord C st a pc stk,
  codeseq_at C pc (compile_aexp_gen ord a) ->
  exists pc', exists stk',
  star (transition C) (pc, stk, st) (pc', stk', st)
  /\ length stk' >= length stk + stack_usage ord a.
Proof.
  induction a; simpl; intros.
  (* FILL IN HERE *)
Admitted.

(** **** Full project (5 stars) *)

Module StorelessMachine.

(** The purpose of this project is to retarget the IMP compiler to a
  different, simpler virtual machine that has no store, just a stack
  that also supports direct accesses, i.e. reading or modifying the
  N-th entry of the stack.  Here is the instruction set of the machine:
*)

Inductive instruction: Type :=
  | Iconst(n: nat)                 (**r push integer [n] on stack *)
  | Iget(n: nat)                   (**r push the value of the [n]-th stack slot *)
  | Iset(n: nat)                   (**r pop an integer, assign it to the [n]-th stack slot *)
  | Iadd                           (**r pop [n2], pop [n1], push back [n1+n2] *)
  | Isub                           (**r pop [n2], pop [n1], push back [n1-n2] *)
  | Imul                           (**r pop [n2], pop [n1], push back [n1*n2] *)
  | Ibranch_forward(ofs: nat)      (**r skip [ofs] instructions forward *)
  | Ibranch_backward(ofs: nat)     (**r skip [ofs] instructions backward *)
  | Ibeq(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1=n2] *)
  | Ibne(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1<>n2] *)
  | Ible(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1<=n2] *)
  | Ibgt(ofs: nat)                 (**r pop [n2], pop [n1], skip [ofs] forward if [n1>n2] *)
  | Ihalt.                         (**r terminate execution successfully *)

(** The only difference with the original virtual machine is that the
  [Ivar] and [Isetvar] instructions (to access the store by
  identifier) are gone and replaced by [Iget] and [Iset] instructions
  (to access the stack by position). *)

Definition code := list instruction.
Definition stack := list nat.
Definition configuration := (nat * stack)%type.

Fixpoint code_at (C: code) (pc: nat) : option instruction :=
  match C, pc with
  | nil, _ => None
  | i :: C', O => Some i
  | i :: C', S pc' => code_at C' pc'
  end.

(** To give semantics to the [Iget] and [Iset] instructions, start by
  defining two stack-manipulating functions, such that
<<
     get_nth_slot (v0 :: ... :: vN :: ...) N = Some vN
     set_nth_slot (v0 :: ... :: vN :: ...) N v' = Some (v0 :: ... :: v' :: ...)
>>
*)

Definition get_nth_slot (s: stack) (n: nat) : option nat :=
  None. (* FILL HERE *)

Fixpoint set_nth_slot (s: stack) (n: nat) (v: nat) : option stack :=
  None. (* FILL HERE *)

(** Then, the semantics of the machine is given by the following transition
  relation.  Note that machine states are just pairs of a program counter
  and a stack.  Note also that many transitions are exactly those of
  the original machine after erasing the store component of the state. *)

Inductive transition (C: code): configuration -> configuration -> Prop :=
  | trans_const: forall pc stk n,
      code_at C pc = Some(Iconst n) ->
      transition C (pc, stk) (pc + 1, n :: stk)
  | trans_get: forall pc stk n v,
      code_at C pc = Some(Iget n) ->
      get_nth_slot stk n = Some v ->
      transition C (pc, stk) (pc + 1, v :: stk)
  | trans_set: forall pc stk n v stk',
      code_at C pc = Some(Iset n) ->
      set_nth_slot stk n v = Some stk' ->
      transition C (pc, v :: stk) (pc + 1, stk')
  | trans_add: forall pc stk n1 n2,
      code_at C pc = Some(Iadd) ->
      transition C (pc, n2 :: n1 :: stk) (pc + 1, (n1 + n2) :: stk)
  | trans_sub: forall pc stk n1 n2,
      code_at C pc = Some(Isub) ->
      transition C (pc, n2 :: n1 :: stk) (pc + 1, (n1 - n2) :: stk)
  | trans_mul: forall pc stk n1 n2,
      code_at C pc = Some(Imul) ->
      transition C (pc, n2 :: n1 :: stk) (pc + 1, (n1 * n2) :: stk)
  | trans_branch_forward: forall pc stk ofs pc',
      code_at C pc = Some(Ibranch_forward ofs) ->
      pc' = pc + 1 + ofs ->
      transition C (pc, stk) (pc', stk)
  | trans_branch_backward: forall pc stk ofs pc',
      code_at C pc = Some(Ibranch_backward ofs) ->
      pc' = pc + 1 - ofs ->
      transition C (pc, stk) (pc', stk)
  | trans_beq: forall pc stk ofs n1 n2 pc',
      code_at C pc = Some(Ibeq ofs) ->
      pc' = (if beq_nat n1 n2 then pc + 1 + ofs else pc + 1) ->
      transition C (pc, n2 :: n1 :: stk) (pc', stk)
  | trans_bne: forall pc stk ofs n1 n2 pc',
      code_at C pc = Some(Ibne ofs) ->
      pc' = (if beq_nat n1 n2 then pc + 1 else pc + 1 + ofs) ->
      transition C (pc, n2 :: n1 :: stk) (pc', stk)
  | trans_ble: forall pc stk ofs n1 n2 pc',
      code_at C pc = Some(Ible ofs) ->
      pc' = (if leb n1 n2 then pc + 1 + ofs else pc + 1) ->
      transition C (pc, n2 :: n1 :: stk) (pc', stk)
  | trans_bgt: forall pc stk ofs n1 n2 pc',
      code_at C pc = Some(Ibgt ofs) ->
      pc' = (if leb n1 n2 then pc + 1 else pc + 1 + ofs) ->
      transition C (pc, n2 :: n1 :: stk) (pc', stk).

Definition mach_terminates (C: code) (stk_init stk_fin: stack) :=
  exists pc,
  code_at C pc = Some Ihalt /\
  star (transition C) (0, stk_init) (pc, stk_fin).

(** Now it's your turn: define a compilation scheme from IMP programs
    to machine code and prove its correctness w.r.t. terminating executions,
    as stated below. *)

Definition compile_program (c: com) : code := nil. (* FILL HERE *)

Theorem compile_program_correct_terminating:
  forall c st,
  c / empty_state \\ st ->
  exists stk,
     mach_terminates (compile_program c) nil stk
  /\ True.
Proof.
  (* Have fun! *)
Admitted.

(** The [True] above is to be replaced by some informative relation between
  the final stack [stk] and the final store [st]. *)

(** Some hints to get you started.  Clearly, we need to use a portion of
  the stack to hold the current values for the program variables.  It may
  seem impossible to represent a store (a function from identifiers to values,
  giving gives values to infinitely many variables) as a stack (a finite
  list of values).  However, only the variables that are ever assigned to
  within the program need to be associated with a stack slot: all
  other variables keep their initial value of 0 throughout the program
  execution. *)

(**  Hence, the first order of business is to construct a list of
  variables that are ever assigned in the program, and, from this
  list, to assign a position in the stack for every such variable.
  For example, if the list of assigned variables is [["x";"y";"z"]]
  we could say that the value of ["x"] is at the top of the stack,
  the value of ["y"] one slot below, and that of ["z"] two slots below.
  Those offsets need adjusting during the evaluation of expressions,
  because intermediate results are pushed on the stack on top of the
  values of variables. *)

(**  Using this information, the compilation of an expression [AId id] is
  either [Iconst 0] if the variable is not assigned in the program,
  or, [Iget N] otherwise, for a stack distance [N] that reflects the
  stack position of variable [id]. *)

(** To state and prove semantic preservation for the compilation functions,
  you will need a predicate [agree st stk] that relates an IMP store [st]
  with a machine stack [stk].  Typically, it will say that
- [st x = 0] for all non-assigned variables [x]
- [get_nth_slot stk N = Some (st x)] if [N] is the stack offset for variable [x]

  The predicate [agree st stk] acts both as a pre- and a post-condition, e.g.

<<
Lemma compile_com_correct_terminating:
  forall C st c st',
  c / st \\ st' ->
  forall stk pc,
  codeseq_at C pc (compile_com c) ->
  agree st stk ->
  exists stk',
     star (transition C) (pc, stk) (pc + length (compile_com c), stk')
  /\ agree st' stk'.
>>
*)

End StorelessMachine.


Require Import Coq.Classes.EquivDec.
Require Import RamifyCoq.lib.List_ext.

Section FIND_NOT_IN.
Context {V: Type}.
Context {EDV: EqDec V eq}.

Fixpoint findNotIn (l1 l2 l3: list V) : (option V * (list V * list V)) :=
  match l1 with
    | nil => (None, (nil, nil))
    | x :: l => if (in_dec equiv_dec x l2) then findNotIn l l2 (x :: l3) else (Some x, (rev l3, l))
  end.

Lemma find_not_in_none: forall l1 l2 l3, fst (findNotIn l1 l2 l3) = None -> Forall (fun m => In m l2) l1.
Proof.
  induction l1; intros. apply Forall_nil. simpl in H. destruct (in_dec equiv_dec a l2).
  apply Forall_cons. auto. apply IHl1 with (a :: l3); auto. inversion H.
Qed.

Lemma find_not_in_some_explicit:
  forall l1 l2 l3 x li1 li2,
    findNotIn l1 l2 l3 = (Some x, (li1, li2)) -> (Forall (fun m => In m l2) l3) ->
    (~ In x li1) /\ (~ In x l2) /\ exists l4, li1 = rev l3 ++ l4 /\ Forall (fun m => In m l2) l4 /\ l1 = l4 ++ x :: li2.
Proof.
  induction l1; intros; simpl in H. inversion H. destruct (in_dec equiv_dec a l2).
  assert (Forall (fun m : V => In m l2) (a :: l3)) by (apply Forall_cons; auto).
  specialize (IHl1 l2 (a :: l3) x li1 li2 H H1). destruct IHl1 as [? [? [l4 [? [? ?]]]]]. split; auto. split; auto.
  exists (a :: l4). repeat split; auto. simpl in H4. rewrite <- app_assoc in H4. rewrite <- app_comm_cons in H4.
  rewrite app_nil_l in H4. auto. rewrite H6; apply app_comm_cons. inversion H. split. intro; apply n.
  rewrite Forall_forall in H0. apply (H0 a). rewrite H2. rewrite in_rev. auto. split. rewrite <- H2. auto.
  exists nil. repeat split; auto. rewrite app_nil_r. auto.
Qed.

Lemma find_not_in_some:
  forall l1 l2 x li1 li2,
    findNotIn l1 l2 nil = (Some x, (li1, li2)) ->
    Forall (fun m => In m l2) li1 /\ l1 = li1 ++ x :: li2 /\ ~ In x li1 /\ ~ In x l2.
Proof.
  intros. assert (Forall (fun m : V => In m l2) nil) by apply Forall_nil.
  destruct (find_not_in_some_explicit l1 l2 nil x li1 li2 H H0). destruct H2 as [? [l4 [? [? ?]]]].
  simpl in H3. rewrite H3 in *. repeat split; auto.
Qed.

End FIND_NOT_IN.


Require Import Undecidability.Shared.Libs.PSL.Base.
Require Import Lia.
From Undecidability.L Require Import L_facts.
Require Import Undecidability.Shared.ListAutomation.
From Complexity.Libs.CookPrelim Require Export Tactics.

(** * Various preliminaries for the TM -> SAT part of the Cook-Levin Theorem *)

(** Results regarding lists *)
Section tabulate.
  Variable (A : Type).
  Fixpoint tabulate (f : nat -> A) (n : nat): list A := match n with 0 => []
                                                                      | S n => tabulate f n ++ [f n]
                                                                end.

  Lemma tabulate_length (f : nat -> A)  (n : nat) : |tabulate f n| = n.
  Proof.
    induction n; cbn.
    - reflexivity.
    - rewrite app_length, IHn. cbn;lia.
  Qed.

  Lemma tabulate_nth (f : nat -> A) (n : nat) : forall k, k < n -> nth_error (tabulate f n) k = Some (f k).
  Proof.
    intros. induction n.
    - lia.
    - destruct (Nat.eqb k n) eqn:H1; dec_bool.
      + rewrite H1 in *; clear H1. cbn. rewrite nth_error_app2, tabulate_length. 2: specialize (tabulate_length f n); lia.
        rewrite Nat.sub_diag; cbn; reflexivity.
      + assert (k < n) by lia. clear H1 H. cbn. rewrite nth_error_app1. 2: now rewrite tabulate_length.
        now apply IHn.
  Qed.

  Lemma tabulate_In (f : nat -> A) (n : nat) : forall a, a el tabulate f n <-> exists k, k < n /\ f k = a.
  Proof.
    specialize (@tabulate_nth f n) as H1.
    intros a. split.
    - intros (n0 & H2)%In_nth_error.
      assert (n0 < n). { rewrite <- tabulate_length with (f := f). now apply nth_error_Some_lt with (x:=a). }
      exists n0. split; [assumption|].
      specialize (H1 n0 H). congruence.
    - intros (k & H2 & H3). specialize (H1 k H2).
      rewrite <- H3; eapply nth_error_In, H1.
  Qed.
End tabulate.

Section subsequence.
  Variable (X : Type).
  Definition subsequence (A B : list X) := exists C D, B = C ++ A ++ D.
  Notation "A 'subs' B" := (subsequence A B)(at level 70).

  Lemma subsequence_incl (A B : list X) : A subs B -> incl A B.
  Proof.
    induction B.
    - unfold subsequence. destruct A; cbn; try firstorder.
      intros (C & D & H). destruct C; cbn in H; congruence.
    - intros (C & D & H). intros x xel. destruct C.
      + cbn in H. rewrite H. firstorder.
      + cbn in H. assert (x0 = a) as -> by congruence.
        right. apply IHB; [|assumption]. exists C,D. congruence.
  Qed.
End subsequence.

(* Lemma dupfree_nthe (X : Type) (l : list X) : dupfree l <-> forall i j a b, nth_error l i = Some a -> nth_error l j = Some b -> i <> j -> a <> b. *)
(* use NoDup_nth_error *)

Section remove.
  Variable (X : Type).
  Context (eqdec : (forall x y: X, dec (x = y))).
  Lemma in_remove_iff (l : list X) (a b : X) : a el remove eqdec b l <-> a el l /\ a <> b.
  Proof.
    revert a. induction l; intros; cbn.
    - tauto.
    - destruct (eqdec b a).
      + split; [firstorder | ]. intros [[-> | H1] H2]; [congruence|]. now apply IHl.
      + split; [ firstorder; congruence | firstorder ].
  Qed.

  Lemma remove_length (l : list X) (a : X) : |remove eqdec a l| <= |l|.
  Proof.
    induction l; cbn.
    - lia.
    - destruct eqdec; cbn; lia.
  Qed.

  Lemma remove_length_el (l : list X) (a : X) : a el l -> |remove eqdec a l| < |l|.
  Proof.
    induction l.
    - intros [].
    - intros [-> | H1].
      + cbn. destruct (eqdec a a); [specialize (remove_length l a); lia | congruence].
      + cbn. destruct (eqdec a a0); [specialize (remove_length l a); lia | cbn; firstorder nia ].
  Qed.
End remove.

Proposition map_dupfree (X Y : Type) (f : X -> Y) (A : list X) : dupfree (map f A) -> dupfree A.
Proof.
  remember (map f A) as B. intros H1. revert A HeqB. induction H1; intros B HeqB.
  - destruct B; cbn in HeqB; [constructor | congruence].
  - destruct B; cbn in HeqB; [congruence | ].
    inv HeqB. constructor.
    + rewrite in_map_iff in H. contradict H. eauto.
    + now apply IHNoDup.
Qed.

Require Import Lia.
(*Require Template.utils.*)
From Undecidability.Shared.Libs.PSL Require Export FiniteTypes.FinTypes FiniteTypes.BasicFinTypes FiniteTypes.CompoundFinTypes Retracts Inhabited Base Vectors.Vectors FiniteTypes.
Require Export smpl.Smpl.
From Undecidability.Shared Require Import Prelim.

From Undecidability.L Require Import Util.L_facts.
From Undecidability.L.Tactics Require Import Lrewrite.

(*option monad in order to ease notation *)
Definition optReturn := @Some.
Definition optBind {X Y : Type} (x : option X) (f : X -> option Y) :=
  match x with
  | None => None
  | Some x => f x
  end.

(*notations from https://pdp7.org/blog/2011/01/the-maybe-monad-in-coq/ *)
Notation "A >>= F" := (optBind A F) (at level 40, left associativity).
Notation "'do' X <- A ; B" := (optBind A (fun X => B)) (at level 200, X name, A at level 100, B at level 200).

(* involutions *)
Definition involution (X : Type) (f : X -> X) := forall (x : X), f (f x) = x.

Lemma map_involution (X : Type)(f : X -> X) : involution f -> involution (map f).
Proof.
  intros. intros l. rewrite map_map. setoid_rewrite H. now rewrite map_id.
Qed.

Lemma involution_invert_eqn (X : Type) (f : X -> X) : involution f -> forall a b, f a = f b -> a = b.
Proof.
  intros. enough (f (f a) = f(f b)). { now rewrite  !H in H1. } now rewrite H0.
Qed.

Lemma involution_invert_eqn2 (X : Type) (f : X -> X) : involution f -> forall a b, f a = b -> a = f b.
Proof.
  intros. rewrite <- (H a). now apply involution_invert_eqn with (f := f).
Qed.

Smpl Create involution.
Ltac involution_simpl := smpl involution; repeat (involution_simpl).

Smpl Add (apply map_involution) : involution.

Lemma rev_involution (X : Type): involution (@rev X).
Proof.
  unfold involution. apply rev_involutive.
Qed.

Smpl Add (apply rev_involution) : involution.

Definition prefix (X : Type) (a b : list X) := exists b', b = a ++ b'.
Definition substring (X : Type) (a b : list X) := exists b1 b2, b = b1 ++ a ++ b2.

Lemma map_skipn (A B : Type) (f : A -> B) (l : list A) (n : nat) : map f (skipn n l) = skipn n (map f l).
Proof.
  induction n as [ | n] in l |-*; cbn; [reflexivity | destruct l as [ | x l]]; cbn; firstorder.
Qed.

Lemma skipn_add (X : Type) (xs vs: list X) (i j : nat) : length vs = j -> skipn (j + i) (vs ++ xs) = skipn i xs.
Proof.
  revert vs; induction j; intros.
  - inv_list. now cbn.
  - inv_list. cbn. apply IHj. cbn in H; congruence.
Qed.

Lemma skipn_app2 (X : Type) i (a b c : list X): c <> [] -> skipn i a = c -> skipn i (a ++ b) = c ++ b.
Proof.
  intros H; revert i; induction a; intros.
  - destruct i; cbn in H0; congruence.
  - destruct i; cbn in H0.
    + cbn. now rewrite <- H0.
    + cbn. now apply IHa.
Qed.

Lemma skipn_app3 (X : Type) i (a b : list X) : i <= |a| -> exists a', skipn i (a ++ b) = a' ++ b /\ a = firstn i a ++ a'.
Proof.
  intros. exists (skipn i a). split.
  + destruct (nat_eq_dec i (|a|)).
    - rewrite skipn_app. 2: apply e. rewrite skipn_all2. 2: lia. now cbn.
    - apply skipn_app2.
      * enough (|skipn i a| <> 0) by (destruct skipn; cbn in *; congruence). rewrite skipn_length. lia.
      * reflexivity.
  + now rewrite firstn_skipn.
Qed.

Lemma firstn_skipn_rev (X : Type) i (h : list X) : firstn i h = rev (skipn (|h| - i) (rev h)).
Proof.
  rewrite <- (firstn_skipn i h) at 3.
  rewrite rev_app_distr.
  rewrite skipn_app.
  - now rewrite rev_involution.
  - rewrite rev_length. now rewrite skipn_length.
Qed.

Lemma skipn_firstn_rev (X : Type) i (h : list X) : skipn i h = rev (firstn (|h| - i) (rev h)).
Proof.
  intros.
  destruct (le_lt_dec i (|h|)).
  - rewrite firstn_skipn_rev.
    rewrite !rev_involution.
    rewrite rev_length.
    replace ((|h|) - (|h| - i)) with i by  lia. easy.
  - specialize (skipn_length i h) as H1. assert (|skipn i h| = 0) by lia.
    specialize (firstn_le_length (|h| - i) (rev h)) as H2. assert (|firstn (|h| - i) (rev h)| = 0)  as H3 by lia.
    destruct skipn, firstn; cbn in *; try congruence.
Qed.

Lemma map_firstn (X Y : Type) i (h : list X) (f : X -> Y) : map f (firstn i h) = firstn i (map f h).
Proof.
  revert i; induction h; intros; cbn.
  - now rewrite !firstn_nil.
  - destruct i; cbn; [reflexivity | now rewrite IHh].
Qed.

Lemma length_app_decompose (X : Type) (a : list X) i j : length a = i + j -> exists a1 a2, a = a1 ++ a2 /\ length a1 = i /\ length a2 = j.
Proof.
  revert a.
  induction i.
  - cbn. intros. now exists [], a.
  - cbn. intros.
inv_list. assert (|a| = i + j) by lia. destruct (IHi a H0) as (a1 & a2 & H2 & H3).
    exists (x :: a1), a2. rewrite H2; cbn. firstorder.
Qed.

Inductive relpowerRev (X : Type) (R : X -> X -> Prop) : nat -> X -> X -> Prop :=
| relpowerRevB x : relpowerRev R 0 x x
| relpowerRevS x y y' n: relpowerRev R n x y -> R y y' -> relpowerRev R (S n) x y'.
#[export]
Hint Constructors relpowerRev : core.

Inductive relpower (A : Type) (R : A -> A -> Prop) : nat -> A -> A -> Prop :=
| relpowerB (a : A) : relpower R 0 a a
| relpowerS (a b c : A) n : R a b -> relpower R n b c -> relpower R (S n) a c.
#[export]
Hint Constructors relpower : core.

Lemma relpower_trans A R n m (x y z : A) : relpower R n x y -> relpower R m y z -> relpower R (n + m) x z.
Proof.
  induction 1.
  - now cbn.
  - intros. apply relpowerS with (b := b). assumption. now apply IHrelpower.
Qed.

Lemma relpower_monotonous (X : Type) (R1 R2 : X -> X -> Prop) : (forall a b, R1 a b -> R2 a b) -> forall n a b, relpower R1 n a b -> relpower R2 n a b.
Proof.
  intros H1 n a b. induction 1.
  - eauto.
  - apply H1 in H. eauto.
Qed.

Lemma relpower_congruent (X : Type) (R R': X -> X -> Prop) :
  (forall x y, R x y <-> R' x y) -> forall n x y, relpower R n x y <-> relpower R' n x y.
Proof.
  intros H. induction n.
  - split; intros H0; inv H0; eauto.
  - split; intros H0; inv H0.
    + apply H in H2. apply IHn in H3. eauto.
    + apply H in H2. apply IHn in H3. eauto.
Qed.

Lemma relpowerRev_trans (X : Type) (R : X -> X -> Prop) n m x y z : relpowerRev R n x y -> relpowerRev R m y z -> relpowerRev R (n + m) x z.
Proof.
  rewrite Nat.add_comm. induction 2; cbn; eauto.
Qed.

Lemma relpower_relpowerRev (X : Type) (R : X -> X -> Prop) n x y : relpower R n x y <-> relpowerRev R n x y.
Proof.
  split; induction 1; eauto.
  - replace (S n) with (1 + n) by lia. eauto using relpowerRev_trans.
  - replace (S n) with (n + 1) by lia. eauto using relpower_trans.
Qed.

Lemma relpower_add_split (X : Type) (R : X -> X -> Prop) n m x y: relpower R (n + m) x y -> exists z, relpower R n x z /\ relpower R m z y.
Proof.
  revert x y. induction n; intros.
  - cbn in H. eauto.
  - inv H. apply IHn in H2 as (z & H3 & H4). exists z. eauto.
Qed.

Notation injective := FinFun.Injective.

Lemma getPosition_map (X Y : eqType) (f : X -> Y) (l : list X) (x : X) : injective f -> getPosition (map f l) (f x) = getPosition l x.
Proof.
  intros.
  induction l; cbn.
  - reflexivity.
  - destruct Dec; destruct Dec; try congruence.
    now apply H in e.
Qed.

Lemma getPosition_app1 (X : eqType) (A B : list X) x k : k < |A| -> getPosition A x = k -> getPosition (A ++ B) x = k.
Proof.
  revert k. induction A; intros; cbn in *.
  - lia.
  - destruct Dec; [assumption | destruct k; [ lia | erewrite IHA]].
    + reflexivity.
    + lia.
    + easy.
Qed.

Lemma getPosition_app2 (X : eqType) (A B : list X) x k : k < |B| -> not (x el A) -> getPosition B x = k -> getPosition (A ++ B) x = |A| + k.
Proof.
  revert k. induction A; intros; cbn in *.
  - apply H1.
  - destruct Dec; [ exfalso ; auto | ].
    erewrite IHA; eauto.
Qed.

Lemma getPosition_prodLists (X Y : eqType) (A : list X) (B : list Y) x1 x2 k1 k2 : getPosition A x1 = k1 -> k1 < |A| -> getPosition B x2 = k2 -> k2 < |B| -> getPosition (list_prod A B) (x1, x2) = (k1 * |B|) + k2.
Proof.
  revert k1. induction A; intros; cbn in *.
  - lia.
  - destruct k1.
    + destruct Dec; [ | congruence].
      rewrite getPosition_app1 with (k := k2); [reflexivity | now rewrite map_length| ].
      rewrite e; now rewrite getPosition_map.
    + destruct Dec; [ congruence | ].
      rewrite getPosition_app2 with (k := (k1 * |B|) + k2).
      * rewrite map_length. lia.
      * setoid_rewrite prod_length. nia.
      * intros (? & ? &?)%in_map_iff. congruence.
      * apply IHA; eauto. now apply Nat.succ_lt_mono.
Qed.

Fixpoint filterSome (X : Type) (l : list (option X)) := match l with
                                                        | [] => []
                                                        | (Some x :: l) => x :: filterSome l
                                                        | None :: l => filterSome l
                                                        end.

Lemma in_filterSome_iff (X : Type) (l : list (option X)) a:
  a el filterSome l <-> Some a el l.
Proof.
  induction l as [ | []]; cbn.
  - tauto.
  - split.
    + intros [-> | H]; [eauto | right; now apply IHl].
    + intros [H1 | H]; [eauto | ]. inv H1.
      * eauto.
      * right; now apply IHl.
  - rewrite IHl. split; intros H; [ eauto | now destruct H].
Qed.

(*an actually usable version of the lemma without useless bool2Prop stuff *)
Lemma in_filter_iff (X : Type) (x : X) (p : X -> bool) (A : list X): x el filter p A <-> x el A /\ p x = true.
Proof.
  induction A; cbn.
  - tauto.
  - destruct (p a) eqn:H1.
    + cbn. rewrite IHA. split; [intros [-> | [H2 H3]]; tauto | tauto ].
    + rewrite IHA. split; [tauto | intros [[-> | H2] H3]; [congruence | tauto] ].
Qed.

Lemma nth_error_nth (X : Type) x (l : list X) n : nth_error l n = Some x -> nth n l x = x.
Proof.
  revert n; induction l; intros; cbn.
  - now destruct n.
  - destruct n; cbn in H.
    * congruence.
    * now apply IHl.
Qed.

Lemma nth_error_nth' (X : Type) x y (l : list X) n : nth_error l n = Some x -> nth n l y = x.
Proof.
  revert n; induction l; intros; cbn.
  - now destruct n.
  - destruct n; cbn in H.
    * congruence.
    * now apply IHl.
Qed.

Lemma nth_error_map (A B : Type) (f : A -> B) (n : nat) (l : list A) : nth_error (map f l) n = option_map f (nth_error l n).
Proof.
  induction n as [ | n] in l |-* ; destruct l as [ | x l]; cbn; congruence.
Qed.

Lemma nth_error_Some_length (A : Type) (l : list A) (n : nat) (v : A) : nth_error l n = Some v -> n < |l|.
Proof.
  induction l as [ | x l IH] in n |-*; destruct n as [ | n]; cbn; try congruence. lia. intros H%IH; lia.
Qed.

Lemma In_explicit (X : Type) (x : X) (l : list X) :
  x el l <-> exists s1 s2, l = s1 ++ [x] ++ s2.
Proof.
  induction l; cbn.
  - split; [tauto | intros (s1 & s2 & H)].
    destruct s1; cbn in H; congruence.
  - split.
    + intros [-> | (s1 & s2 & ->)%IHl].
      * exists [], l. eauto.
      * exists (a :: s1), s2; eauto.
    + intros ([] & s2 & H).
      * inv H. eauto.
      * inv H. right; apply IHl.
        exists l0, s2. eauto.
Qed.

Lemma list_length_split1 (X : Type) (s : list X) n : n <= |s| -> exists s1 s2, |s1| = n /\ |s2| = |s| - n /\ s = s1 ++ s2.
Proof.
  revert s. induction n; intros.
  - exists [], s. cbn; rewrite Nat.sub_0_r. eauto.
  - destruct s; cbn in H; [lia | ]. assert (n <= |s|) as H' by lia.
    apply IHn in H' as (s1 & s2 & H1 & H2 & ->).
    exists (x::s1), s2. cbn. eauto.
Qed.

Lemma list_length_split2 (X : Type) (s : list X) n : n <= |s| -> exists s1 s2, |s1| = |s| - n /\ |s2| = n /\ s = s1 ++ s2.
Proof.
  intros. assert (|s| - n <= |s|) as H' by lia.
  specialize (list_length_split1 H') as (s1 & s2 & H1 & H2 & ->).
  exists s1, s2.
  rewrite app_length in *.
  repeat split; [lia | lia].
Qed.

Lemma app_eq_length (X : Type) (s1 s2 w1 w2 : list X) : |s1| = |w1| -> s1 ++ s2 = w1 ++ w2 -> s1 = w1 /\ s2 = w2.
Proof.
  intros. revert w1 H H0. induction s1; cbn in *; intros.
  - destruct w1; cbn in *; eauto.
  - destruct w1; cbn in *; [congruence | ]. inv H0. inv H.
    specialize (IHs1 w1 H1 H3) as (-> & ->). eauto.
Qed.

Lemma nth_error_step (X : Type) x s (l : list X) a y : x >= S s -> nth_error l (x - S s) = Some a <-> nth_error (y :: l) (x - s) = Some a.
Proof.
  intros. replace (y :: l) with ([y] ++ l) by now cbn.
  rewrite nth_error_app2; cbn; [ | lia].
  replace (x - s - 1) with (x - S s) by lia. tauto.
Qed.

Lemma list_eq_nth_error (X : Type) (l1 l2 : list X) :
  l1 = l2 <-> (|l1| = |l2| /\ forall k, k < |l1| -> nth_error l1 k = nth_error l2 k).
Proof.
  split; [intros -> | intros (H1 & H2)].
  - split; [easy | intros; easy ].
  - revert l2 H1 H2; induction l1; intros; destruct l2.
    + easy.
    + cbn in H1; congruence.
    + cbn in H1; congruence.
    + cbn in H1. apply Nat.succ_inj in H1. enough (a = x /\ l1 = l2) by easy; split.
      * specialize (H2 0 (Nat.lt_0_succ (|l1|))). now cbn in H2.
      * apply IHl1; [ apply H1 | ].
        intros. apply Nat.succ_lt_mono in H. specialize (H2 (S k) H). now cbn in H2.
Qed.

Lemma nth_error_firstn (X : Type) k m (l : list X): k < m -> nth_error (firstn m l) k = nth_error l k.
Proof.
  revert k l. induction m; intros.
  - lia.
  - destruct k; cbn; destruct l; cbn; firstorder. now apply IHm.
Qed.

Lemma nth_error_skipn (X : Type) k m (l : list X) : nth_error (skipn m l) k = nth_error l (m + k).
Proof.
  revert k l. induction m; intros.
  - easy.
  - destruct l; cbn; [ now destruct k | apply IHm].
Qed.

Lemma firstn_all_inv (X : Type) (m l : list X) : |l| = |m| -> firstn (|l|) m = l -> m = l.
Proof.
  revert l; induction m; intros.
  - destruct l; cbn; easy.
  - destruct l; cbn in *; [easy | ]. inv H0. apply Nat.succ_inj in H.
    rewrite H3. f_equal. now apply IHm.
Qed.

Lemma skipn_firstn_shift (X : Type) (m : list X) len l : skipn l (firstn len m) = firstn (len - l) (skipn l m).
Proof.
  revert l len. induction m; cbn; intros.
  - rewrite !firstn_nil, !skipn_nil, firstn_nil. easy.
  - destruct len.
    + cbn. now destruct l.
    + cbn. destruct l; cbn; [ easy | ]. now rewrite IHm.
Qed.

Lemma skipn_skipn (X : Type) (m : list X) l1 l2 : skipn l1 (skipn l2 m) = skipn (l1 + l2) m.
Proof.
  revert l1 l2.
  induction m; intros; destruct l2; cbn; try now rewrite !skipn_nil.
  - now rewrite Nat.add_0_r.
  - rewrite IHm. rewrite Nat.add_succ_r. easy.
Qed.

Lemma skipn_firstn_skipn (X : Type) (m : list X) l1 l2 len2 :
  skipn l1 (firstn len2 (skipn l2 m)) = firstn (len2 - l1) (skipn (l1 + l2) m).
Proof.
  intros.
  rewrite skipn_firstn_shift. now rewrite skipn_skipn.
Qed.

Lemma firstn_add (X : Type) (m : list X) l1 l2 : firstn (l1 + l2) m = firstn l1 m ++ firstn l2 (skipn l1 m).
Proof.
  revert l1 l2. induction m; intros.
  - now rewrite !skipn_nil, !firstn_nil.
  - destruct l1; cbn; [ easy | ]. now rewrite IHm.
Qed.

Lemma dupfree_map_getPosition (X : eqType) (l : list X) : NoDup l -> seq 0 (|l|) = map (getPosition l) l.
Proof.
  intros H. enough (forall n, seq n (|l|) = map (fun x => n + getPosition l x) l).
  { specialize (H0 0). apply H0. }
  induction H; intros; [ easy | ].
  cbn. destruct Dec; [ | congruence].
  rewrite Nat.add_0_r. f_equal. rewrite (IHNoDup (S n)).
  clear IHNoDup e.
  apply map_ext_in.
  intros a H1. destruct (Dec (a = x)); [ congruence | lia ].
Qed.

Lemma repEl_app_inv (X : Type) (a : X) s1 s2 n : repeat a n = s1 ++ s2 -> exists n1 n2, s1 = repeat a n1 /\ s2 = repeat a n2 /\ n1 + n2 = n.
Proof.
  revert s1 s2.  induction n.
  - cbn. destruct s1, s2; cbn; try congruence. intros _. exists 0, 0; now cbn.
  - cbn. destruct s1.
    + cbn. destruct s2; cbn; [ congruence | ].
      intros H. inv H. exists 0, (S n); now cbn.
    + intros. cbn in H. inv H. apply IHn in H2 as (n1 & n2 & -> & -> & <-).
      exists (S n1), n2; now cbn.
Qed.

Lemma app_length_split (X : Type) (v u b c : list X) : v ++ b = u ++ c -> |v| <= |u| -> exists u', u = v ++ u'.
Proof.
  intros. apply list_length_split1 in H0 as (s1 & s2 & H0 & _ & ->).
  rewrite <- app_assoc in H. apply app_eq_length in H as (-> & ->); [ | easy].
  now exists s2.
Qed.

Lemma nth_nth_error (X : Type) (l : list X) n def a  : nth n l def = a -> n < |l| -> nth_error l n = Some a.
Proof.
  intros. apply nth_error_Some in H0. destruct nth_error eqn:H1; [ | congruence].
  clear H0. apply nth_error_nth' with (y := def) in H1. easy.
Qed.

Lemma in_concat_map_iff (X Y : Type) (f : X -> list Y) (l : list X) y : y el concat (map f l) <-> exists x, x el l /\ y el f x.
Proof.
  split; intros.
  - apply in_concat_iff in H as (? & H1 & (? & <- & H3)%in_map_iff). eauto.
  - apply in_concat_iff. destruct H as (x & H1 & H2). exists (f x). split.
    + exact H2.
    + apply in_map. exact H1.
Qed.


Require Import ZArith.
Require Import Coqlib.
Require Import Floats.

(* This file defines the data types for defining syntax. *)

Local Open Scope nat_scope.

Module Size.

Definition t := nat.
Definition dec : forall x y : t, {x=y} + {x<>y} := eq_nat_dec.
Definition Zero : t := 0.
Definition One : t := 1.
Definition Two : t := 2.
Definition Four : t := 4.
Definition Eight : t := 8.
Definition Sixteen : t := 16.
Definition ThirtyTwo : t := 32.
Definition SixtyFour : t := 64.
Definition from_nat (i:nat) : t := i.
Definition to_nat (i:t) : nat := i.
Definition to_Z (i:t) : Z := Z_of_nat i.
Definition from_Z (i:Z) : t := nat_of_Z i.
Definition add (a b:t) : t := (a + b).
Definition sub (a b:t) : t := (a - b).
Definition mul (a b:t) : t := (a * b).
Definition div (a b:t) : t := nat_of_Z ((Z_of_nat a) / (Z_of_nat b)).
Definition gt (a b:t) : Prop := (a > b).
Definition lt (a b:t) : Prop := (a < b).

End Size.

Module Align.

Definition t := nat.
Definition dec : forall x y : t, {x=y} + {x<>y} := eq_nat_dec.
Definition Zero : t := 0.
Definition One : t := 1.
Definition Two : t := 2.
Definition Four : t := 4.
Definition Eight : t := 8.
Definition Sixteen : t := 16.
Definition ThirtyTwo : t := 32.
Definition SixtyFour : t := 64.
Definition from_nat (i:nat) : t := i.
Definition to_nat (i:t) : nat := i.
Definition to_Z (i:t) : Z := Z_of_nat i.
Definition from_Z (i:Z) : t := nat_of_Z i.
Definition add (a b:t) : t := (a + b).
Definition sub (a b:t) : t := (a - b).
Definition mul (a b:t) : t := (a * b).
Definition div (a b:t) : t := nat_of_Z ((Z_of_nat a) / (Z_of_nat b)).
Definition gt (a b:t) : Prop := (a > b).
Definition lt (a b:t) : Prop := (a < b).

End Align.

Module INTEGER.

Definition t := Z.
Definition dec : forall x y : t, {x=y} + {x<>y} := zeq.
Definition to_nat (i:t) : nat := nat_of_Z i.
Definition to_Z (i:t) : Z := i.
Definition of_Z (bitwidth:Z) (v:Z) (is_signed:bool) : t := v.

End INTEGER.

Module FLOAT.

Definition t := float.
Definition dec : forall x y : t, {x=y} + {x<>y} := Float.eq_dec.
(* Definition Zero : t := Float.zero. *)

End FLOAT.


Definition tsat (f:nat -> bool) : Prop := exists (n:nat), f n = true.

Lemma tsatOr : forall (f g:nat -> bool),
    (tsat f \/ tsat g) -> tsat (fun n => orb (f n) (g n)).
Proof.
    intros f g [H1|H1]; destruct H1 as [n H1]; exists n; rewrite H1.
    - destruct (g n); reflexivity.
    - destruct (f n); reflexivity.
Qed.


Theorem Ex046 (A B : Prop): (A /\ (A -> ~A)) -> (A /\ (B -> ~A)).
Proof.
  intro.
  destruct H.
  split.
  + exact H.
  + intro. intro.
    apply H0.
    - exact H.
    - exact H.
Qed.


(* ********************************************** *)
(* Types and Semantics for Programming Languages  *)
(* ********************************************** *)

(* Place an X in front of the appropriate statement *)
(* [ ]  I have done Problems 1 and 2 *)
(* [ ]  I have done Problems 1 and 3 *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Export Maps.
Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive last {X:Type} : list X -> X -> Prop:=
  | last_end : forall x,
      last (x :: nil) x
  | last_step : forall x y xs,
      last xs y ->
      last (x::xs) y.

Theorem last_app : forall (X:Type) (x:X) (xs:list X),
  last xs x -> exists xs', xs = xs' ++ [x].
Proof.
  intros.
  induction H.
  - exists nil.  simpl. reflexivity.
  - destruct IHlast.
    exists (x::x0). rewrite H0. simpl. reflexivity.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* Arithmetic and boolean expressions *)

Definition state := total_map nat.

Definition ble_nat := leb.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CLoop : com -> bexp -> com -> com.

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

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''
  |

  where "c1 '/' st '||' st'" := (ceval c1 st st').

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  + (* "b is true" *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  + (* "b is false" *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  + (* Case "E_WhileEnd" *)
    split. assumption. apply bexp_eval_false. assumption.
  + (* Case "E_WhileLoop" *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

(* Values *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(* Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20, right associativity).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Evaluation relation *)

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Definition relation a := a -> a -> Prop.

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

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

(* Contexts *)

Definition context := partial_map ty.

(* Typing relation *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  + (* Case "T_Var" *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  + (* Case "T_App" *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    - (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    - (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  + (* Case "T_If" *)
    right. destruct IHHt1...

    - (* t1 is a value *)
      destruct (cannonical_forms_bool t1); subst; eauto.

    - (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.