Require Import Bool Arith Equality.
Require Import List.
Import ListNotations.

From FormalSystems Require Import Base.

(** * Types and terms *)

Inductive Ty : Type :=
    | TNat : Ty
    | TArr : Ty -> Ty -> Ty.

Notation "a → b" := (TArr a b) (at level 60, right associativity).

Inductive Tm : Ty -> Type :=
    | K : forall {a b : Ty}, Tm (a → b → a)
    | S : forall {a b c : Ty}, Tm ((a → b → c) → (a → b) → a → c)
    | App : forall {a b : Ty}, Tm (a → b) -> Tm a -> Tm b
    | zero : Tm TNat
    | succ : Tm (TNat → TNat)
    | rec  : forall {a : Ty}, Tm (a → (TNat → a → a) → TNat → a).

Notation "M @ N" := (App M N) (at level 50, left associativity).

Inductive red : forall {A : Ty}, Tm A -> Tm A -> Prop :=
    | red_K :
        forall {A B : Ty} (f : Tm (A → B → A)) (a : Tm A) (b : Tm B),
          red (K @ a @ b) a
    | red_S :
        forall {A B C : Ty} (f : Tm (A → B → C)) (g : Tm (A → B)) (a : Tm A),
          red (S @ f @ g @ a) (f @ a @ (g @ a))
    | red_rec_zero :
        forall {A : Ty} (z : Tm A) (s : Tm (TNat → A → A)),
          red (rec @ z @ s @ zero) z
    | red_rec_succ :
        forall {A : Ty} (z : Tm A) (s : Tm (TNat → A → A)) (n : Tm TNat),
          red (rec @ z @ s @ (succ @ n)) (s @ n @ (rec @ z @ s @ n))
    | red_AppL :
        forall {A B : Ty} (f f' : Tm (A → B)) (a : Tm A),
          red f f' -> red (f @ a) (f @ a)
    | red_AppR :
        forall {A B : Ty} (f : Tm (A → B)) (a a' : Tm A),
          red a a' -> red (f @ a) (f @ a').

Notation "A ~> B" := (red A B) (at level 60).

#[global] Hint Constructors Ty Tm red rtc : core.

Definition reds {A : Ty} (t1 t2 : Tm A) : Prop := rtc (@red A) t1 t2.

Notation "A ~> B" := (red A B) (at level 60).

Definition isNormal {A : Ty} (a : Tm A) : Prop :=
  forall a' : Tm A, ~ a ~> a'.

Inductive Nf : forall {A : Ty}, Tm A -> Prop :=
    | Nf_K0    : forall {A B : Ty}, Nf (@K A B)
    | Nf_K1    : forall {A B : Ty} (a : Tm A), Nf a -> Nf (@K A B @ a)
    | Nf_S0    : forall {A B C : Ty}, Nf (@S A B C)
    | Nf_S1    : forall {A B C : Ty} (f : Tm (A → B → C)), Nf f -> Nf (S @ f)
    | Nf_S2    : forall {A B C : Ty} (f : Tm (A → B → C)) (g : Tm (A → B)), Nf f -> Nf g -> Nf (S @ f @ g)
    | Nf_zero  : Nf zero
    | Nf_succ0 : Nf succ
    | Nf_succ1 : forall n : Tm TNat, Nf n -> Nf (succ @ n)
    | Nf_rec0  : forall {A : Ty}, Nf (@rec A)
    | Nf_rec1  : forall {A : Ty} (z : Tm A), Nf z -> Nf (rec @ z)
    | Nf_rec2  : forall {A : Ty} (z : Tm A) (s : Tm (TNat → A → A)), Nf z -> Nf s -> Nf (rec @ z @ s).

#[global] Hint Constructors Nf : core.

Ltac wut :=
repeat match goal with
    | |- forall _, _ => intro
    | |- ~ _ => intro
    | |- _ /\ _ => split
    | H : _ /\ _ |- _ => destruct H
    | H : red (_ @ _) _ |- _ => inv H
    | H : red K       _ |- _ => inv H
    | H : red S       _ |- _ => inv H
    | H : red zero    _ |- _ => inv H
    | H : red succ    _ |- _ => inv H
    | H : red rec     _ |- _ => inv H
    | H : isNormal ?t, H' : red ?t _ |- _ => destruct (H _ H')
    | |- isNormal _ => do 2 intro
    | H : exists _, _   |- _ => decompose [ex and] H; clear H
(*     | H : Ne ?x          |- _ => is_var x + inv H *)
(*     | H : Ne' ?x          |- _ => is_var x + inv H *)
    | _ => auto
end.

Lemma Nf_isNormal :
  forall {A : Ty} {a : Tm A},
    Nf a -> isNormal a.
Proof.
  unfold isNormal.
  induction 1.
    wut.
    do 2 intro. inv H0.
Abort.

(*
Fixpoint Nf'_isNormal {t : Tm} (nf : Nf' t) {struct nf} : isNormal t

with     Ne'_isNormal {t : Tm} (ne : Ne' t) {struct ne} : isNormal t.
Proof.
  destruct nf; wut.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal. 2: eauto. eauto.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal; eauto.
    eapply Nf'_isNormal. 2: eauto. eauto.
    eapply Nf'_isNormal; eauto.
    eapply Ne'_isNormal; eauto.
  destruct ne; wut.
    eapply Ne'_isNormal; eauto.
    eapply Nf'_isNormal; eauto.
Qed.

Lemma isNormal_Nf' :
  forall {t : Tm}, isNormal t -> Nf' t.
Proof.

      Ltac hehe :=
      repeat match goal with
          | H : forall _, ~ _ |- False => eapply H; eauto
          | H : _ -> Nf' _ |- Nf' _ => apply H; do 2 intro
          | |- Nf' (_ @ _) => constructor; auto
          | |- Ne' (_ @ _) => constructor; auto
          | H : Nf' (_ @ _) |- _ => inv H
          | H : Ne' (_ @ _) |- _ => inv H
      end.

  unfold isNormal.
  induction t; intros; auto.
  destruct t1.
    1-2, 4-6: hehe.
    destruct t1_1. all: cycle 3.
      do 2 constructor.
        assert (Nf' (zero @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0.
        apply IHt2. do 2 intro. eapply H. eauto.
      do 2 constructor.
        assert (Nf' (succ @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0.
        apply IHt2. do 2 intro. eapply H. eauto.
      constructor.
        assert (Nf' (rec @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0. inv H1.
        apply IHt2. do 2 intro. eapply H. eauto.
      specialize (H t1_2). contradict H. eauto.
      constructor.
        assert (Nf' (S @ t1_2)).
          apply IHt1. wut. eapply H. eauto.
          inv H0. inv H1.
        apply IHt2. do 2 intro. eapply H. eauto.
      assert (Nf' (t1_1_1 @ t1_1_2 @ t1_2)).
        apply IHt1. do 2 intro. eapply H. eauto.
        inv H0.
          specialize (H (t1_1_2 @ t2 @ (t1_2 @ t2))). contradict H. eauto.
          exfalso. eapply H.
Abort.

Goal
  forall t : Tm,
    Nf' t -> hasType t TNat -> t = zero \/ exists t' : Tm, t = succ @ t' /\ hasType t' TNat.
Proof.
  induction 1; intros HT; inv HT.
    inv H2.
    inv H2.
    inv H3. inv H4.
    inv H2.
    inv H3. inv H4.
    revert x a H0 H1 H. induction f; intros.
      inv H0.
      inv H0.
      inv H0. inv H4.
        inv H. inv H3. inv H2.
        inv H. inv H5. inv H4.
  inv H0; inv H3.
    inv H1.
    inv H1.
    inv H. inv H4. inv H3; inv H0. inv H. inv H8. inv H8.

Lemma isNormal_Nf' :
  forall {t : Tm} {a : Ty}, hasType t a -> isNormal t -> Nf' t.
Proof.
  unfold isNormal.
  induction 1; intros; auto.
  inv H; cycle 3.
    do 2 constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    inv H2. all: cycle 3.
      constructor.
        assert (Nf' (rec @ x0)).
          apply IHhasType1. wut. eapply H1. eauto.
          inv H. inv H2.
        apply IHhasType2. wut. eapply H1. eauto.
      specialize (H1 x0). contradict H1. eauto.
      constructor; auto.
        assert (Nf' (S @ x0)).
          apply IHhasType1. wut. eapply H1. eauto.
          inv H. inv H2.
        apply IHhasType2. wut. eapply H1. eauto.
      assert (Nf' (f @ x1 @ x0)).
        apply IHhasType1. do 2 intro. eapply H1. eauto.
        inv H2.
          specialize (H1 (x1 @ x @ (x0 @ x))). contradict H1. eauto.
          assert (Nf' x).
            apply IHhasType2. do 2 intro. eapply H1. eauto.
            inv H. inv H0; try inv H6; try inv H8; try inv H6.
              inv H.
                inv H2.
                  inv H0.
                  inv H0.
                  inv H. inv H10. inv H8.
                    inv H0. inv H0. inv

 inv H2. inv H8; inv H.
                exfalso. eapply H1. eauto.

    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    inv H2.
      admit.
      constructor.
        constructor.
      assert (Nf' (S @ x0)).
        admit.
        inv H.
          repeat constructor. inv H6. econstructor. auto.
      constructor. auto.
        assert (Nf'
        constructor; auto. apply IHhasType2. wut. eapply H1. eauto.
    constructor; auto. apply IHhasType2. wut. eapply H1. eauto. constructor.
  destruct f. all: cycle 3.
    constructor; auto. apply IHt2. wut. eapply H. eauto.
    constructor; auto. apply IHt2. wut. eapply H. eauto.
    constructor; auto. apply IHt2. wut. eapply H. eauto.
    constructor; auto. apply IHt2. wut. eapply H. eauto.
    constructor; auto. apply IHt2. wut. eapply H. eauto.
    destruct t1_1. all: cycle 3.
      repeat constructor. constructor. auto.
Abort.

Definition hasNormal (t : Tm) : Prop :=
  exists t' : Tm, reds t t' /\ isNormal t'.

Definition WN (t : Tm) (a : Ty) : Prop :=
  exists t' : Tm, hasType t' a /\ rtc red t t' /\ isNormal t'.

Fixpoint Reducible (t : Tm) (ty : Ty) : Prop :=
match ty with
    | TNat     => WN t TNat
    | TArr a b => WN t (TArr a b) /\
                  forall t' : Tm,
                    hasType t' a -> Reducible t' a -> Reducible (t @ t') b
end.

Fixpoint R' (t : Tm) (ty : Ty) : Prop :=
match ty with
    | TNat     => True
    | TArr a b => forall t' : Tm,
                    hasType t' a -> R' t' a -> R' (t @ t') b
end.

Goal
  forall t ty,
    Reducible t ty <-> WN t ty /\ R' t ty.
Proof.
  split.
    revert t. induction ty; cbn; intros.
      auto.
      firstorder. destruct ty2; cbn.
        trivial.
        intros. cbn in *. edestruct IHty2.
Abort.

Lemma reds_AppL :
  forall t1 t1' t2 : Tm,
    reds t1 t1' -> reds (t1 @ t2) (t1' @ t2).
Proof.
  unfold reds.
  induction 1; eauto.
Qed.

Lemma reds_AppR :
  forall t1 t2 t2' : Tm,
    reds t2 t2' -> reds (t1 @ t2) (t1 @ t2').
Proof.
  unfold reds.
  induction 1; eauto.
Qed.

Lemma reds_App :
  forall t1 t1' t2 t2' : Tm,
    reds t1 t1' -> reds t2 t2' -> reds (t1 @ t2) (t1' @ t2').
Proof.
  intros.
  eapply rtc_trans.
    apply reds_AppL. eassumption.
    apply reds_AppR. eassumption.
Qed.

Lemma hasType_Reducible :
  forall {a : Ty} {t : Tm},
    hasType t a -> Reducible t a.
Proof.
  induction 1.
    cbn. split.
      red. exists K. repeat split; auto. wut.
      split; intros.
        red. destruct a; cbn in *; unfold WN in *.
          decompose [ex and] H0; clear H0. exists (K @ x). split; eauto. split.
            apply reds_AppR. assumption.
            wut.
          decompose [ex and] H0; clear H0. exists (K @ x). split; eauto. split.
            apply reds_AppR. assumption.
            wut.
        clear -a H0. induction a; cbn in *; unfold WN in *; intros.
          wut. exists x. wut. constructor 3 with (K @ x @ t'0).
            apply reds_AppL, reds_AppR. assumption.
            auto.
          wut.
            exists x. wut. constructor 3 with (K @ x @ t'0).
              apply reds_AppL, reds_AppR. assumption.
              auto.
            admit.
    admit.
    cbn in *. wut.
    cbn. wut. red. exists zero. wut.
    cbn. wut.
      red. exists succ. wut.
      unfold WN in *. wut. exists (succ @ x). wut.
        eauto.
        apply reds_AppR. assumption.
    cbn. unfold WN. wut.
      exists rec. wut.
      destruct a; cbn in *; unfold WN in *; wut.
        exists (rec @ x). wut.
          eauto.
          apply reds_AppR. assumption.
        exists (rec @ x). wut.
          eauto.
          apply reds_AppR. assumption.
      destruct a; cbn in *; unfold WN in *; wut.
        exists (rec @ x0 @ x). wut.
          eauto.
          repeat apply reds_App; unfold reds; auto.
        exists (rec @ x0 @ x). wut.
          eauto.
          repeat apply reds_App; unfold reds; auto.
      edestruct (H5 _ H7).
        exists x. wut.
        wut. destruct a; cbn.
Abort.
*)


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Bounded and unbounded iterators *)

Require Import Axioms.
Require Import Coqlib.
Require Import Wfsimpl.

(** This modules defines several Coq encodings of a general "while" loop.
  The loop is presented in functional style as the iteration
  of a [step] function of type [A -> B + A]:
<<
        let rec iterate step a =
          match step a with
          | inl b -> b
          | inr a' -> iterate step a'
>>
  This iteration cannot be defined directly in Coq using [Fixpoint],
  because Coq is a logic of total functions, and therefore we must
  guarantee termination of the loop.
*)

(** * Terminating iteration *)

(** We first implement the case where termination is guaranteed because
  the current state [a] decreases at each iteration. *)

Module WfIter.

Section ITERATION.

Variables A B: Type.
Variable step: A -> B + A.
Variable ord: A -> A -> Prop.
Hypothesis ord_wf: well_founded ord.
Hypothesis step_decr: forall a a', step a = inr _ a' -> ord a' a.

Definition step_info (a: A) : {b | step a = inl _ b} + {a' | step a = inr _ a' & ord a' a}.
Proof.
  caseEq (step a); intros. left; exists b; auto. right; exists a0; auto.
Defined.

Definition iterate_F (a: A) (rec: forall a', ord a' a -> B) : B :=
  match step_info a with
  | inl (exist b P) => b
  | inr (exist2 a' P Q) => rec a' Q
  end.

Definition iterate (a: A) : B := Fix ord_wf iterate_F a.

(** We now prove an invariance property [iterate_prop], similar to the Hoare
  logic rule for "while" loops. *)

Variable P: A -> Prop.
Variable Q: B -> Prop.

Hypothesis step_prop:
  forall a : A, P a ->
  match step a with inl b => Q b | inr a' => P a' end.

Lemma iterate_prop:
  forall a, P a -> Q (iterate a).
Proof.
  intros a0. pattern a0. apply well_founded_ind with (R := ord). auto.
  intros. unfold iterate; rewrite unroll_Fix. unfold iterate_F.
  destruct (step_info x) as [[b U] | [a' U V]].
  exploit step_prop; eauto. rewrite U; auto.
  apply H. auto. exploit step_prop; eauto. rewrite U; auto.
Qed.

End ITERATION.

End WfIter.

(** * Bounded iteration *)

(** The presentation of iteration shown above is predicated on the existence
  of a well-founded ordering that decreases at each step of the iteration.
  In several parts of the CompCert development, it is very painful to define
  such a well-founded ordering and to prove decrease, even though we know our
  iterations always terminate.

  In the presentation below, we choose instead to bound the number of iterations
  by an arbitrary constant.  [iterate] then becomes a function that can fail,
  of type [A -> option B].  The [None] result denotes failure to reach
  a result in the number of iterations prescribed, or, in other terms,
  failure to find a solution to the dataflow problem.  The compiler
  passes that exploit dataflow analysis (the [Constprop], [CSE] and
  [Allocation] passes) will, in this case, either fail ([Allocation])
  or turn off the optimization pass ([Constprop] and [CSE]).

  Since we know (informally) that our computations terminate, we can
  take a very large constant as the maximal number of iterations.
  Failure will therefore never happen in practice, but of
  course our proofs also cover the failure case and show that
  nothing bad happens in this hypothetical case either.  *)

Module PrimIter.

Section ITERATION.

Variables A B: Type.
Variable step: A -> B + A.

Definition num_iterations := 1000000000000%positive.

(** The simple definition of bounded iteration is:
<<
Fixpoint iterate (niter: nat) (a: A) {struct niter} : option B :=
  match niter with
  | O => None
  | S niter' =>
      match step a with
      | inl b => b
      | inr a' => iterate niter' a'
      end
  end.
>>
  This function is structural recursive over the parameter [niter]
  (number of iterations), represented here as a Peano integer (type [nat]).
  However, we want to use very large values of [niter].  As Peano integers,
  these values would be much too large to fit in memory.  Therefore,
  we must express iteration counts as a binary integer (type [positive]).
  However, Peano induction over type [positive] is not structural recursion,
  so we cannot define [iterate] as a Coq fixpoint and must use
  Noetherian recursion instead. *)

Definition iter_step (x: positive)
                     (next: forall y, Plt y x -> A -> option B)
                     (s: A) : option B :=
  match peq x xH with
  | left EQ => None
  | right NOTEQ =>
      match step s with
      | inl res => Some res
      | inr s'  => next (Ppred x) (Ppred_Plt x NOTEQ) s'
      end
  end.

Definition iter: positive -> A -> option B := Fix Plt_wf iter_step.

(** The [iterate] function is defined as [iter] up to
    [num_iterations] through the loop. *)

Definition iterate := iter num_iterations.

(** We now prove the invariance property [iterate_prop]. *)

Variable P: A -> Prop.
Variable Q: B -> Prop.

Hypothesis step_prop:
  forall a : A, P a ->
  match step a with inl b => Q b | inr a' => P a' end.

Lemma iter_prop:
  forall n a b, P a -> iter n a = Some b -> Q b.
Proof.
  apply (well_founded_ind Plt_wf
         (fun p => forall a b, P a -> iter p a = Some b -> Q b)).
  intros. unfold iter in H1. rewrite unroll_Fix in H1. unfold iter_step in H1.
  destruct (peq x 1). discriminate.
  specialize (step_prop a H0).
  destruct (step a) as [b'|a'] eqn:?.
  inv H1. auto.
  apply H with (Ppred x) a'. apply Ppred_Plt; auto. auto. auto.
Qed.

Lemma iterate_prop:
  forall a b, iterate a = Some b -> P a -> Q b.
Proof.
  intros. apply iter_prop with num_iterations a; assumption.
Qed.

End ITERATION.

End PrimIter.

(** * General iteration *)

(* An implementation using classical logic and unbounded iteration,
  in the style of Yves Bertot's paper, "Extending the Calculus
  of Constructions with Tarski's fix-point theorem".

  As in the bounded case, the [iterate] function returns an option type.
  [None] means that iteration does not terminate.
  [Some b] means that iteration terminates with the result [b]. *)

Require Import Classical.
Require Import ClassicalDescription.
Require Import Max.

Module GenIter.

Section ITERATION.

Variables A B: Type.
Variable step: A -> B + A.

Definition B_le (x y: option B) : Prop := x = None \/ y = x.
Definition F_le (x y: A -> option B) : Prop := forall a, B_le (x a) (y a).

Definition F_iter (next: A -> option B) (a: A) : option B :=
  match step a with
  | inl b => Some b
  | inr a' => next a'
  end.

Lemma F_iter_monot:
 forall f g, F_le f g -> F_le (F_iter f) (F_iter g).
Proof.
  intros; red; intros. unfold F_iter.
  destruct (step a) as [b | a']. red; auto. apply H.
Qed.

Fixpoint iter (n: nat) : A -> option B :=
  match n with
  | O => (fun a => None)
  | S m => F_iter (iter m)
  end.

Lemma iter_monot:
  forall p q, (p <= q)%nat -> F_le (iter p) (iter q).
Proof.
  induction p; intros.
  simpl. red; intros; red; auto.
  destruct q. elimtype False; omega.
  simpl. apply F_iter_monot. apply IHp. omega.
Qed.

Lemma iter_either:
  forall a,
  (exists n, exists b, iter n a = Some b) \/
  (forall n, iter n a = None).
Proof.
  intro a. elim (classic (forall n, iter n a = None)); intro.
  right; assumption.
  left. generalize (not_all_ex_not nat (fun n => iter n a = None) H).
  intros [n D]. exists n. generalize D.
  case (iter n a); intros. exists b; auto. congruence.
Qed.

Definition converges_to (a: A) (b: option B) : Prop :=
  exists n, forall m, (n <= m)%nat -> iter m a = b.

Lemma converges_to_Some:
  forall a n b, iter n a = Some b -> converges_to a (Some b).
Proof.
  intros. exists n. intros.
  assert (B_le (iter n a) (iter m a)). apply iter_monot. auto.
  elim H1; intro; congruence.
Qed.

Lemma converges_to_exists:
  forall a, exists b, converges_to a b.
Proof.
  intros. elim (iter_either a).
  intros [n [b EQ]]. exists (Some b). apply converges_to_Some with n. assumption.
  intro. exists (@None B). exists O. intros. auto.
Qed.

Lemma converges_to_unique:
  forall a b, converges_to a b -> forall b', converges_to a b' -> b = b'.
Proof.
  intros a b [n C] b' [n' C'].
  rewrite <- (C (max n n')). rewrite <- (C' (max n n')). auto.
  apply le_max_r. apply le_max_l.
Qed.

Lemma converges_to_exists_uniquely:
  forall a, exists! b, converges_to a b .
Proof.
  intro. destruct (converges_to_exists a) as [b CT].
  exists b. split. assumption. exact (converges_to_unique _ _ CT).
Qed.

Definition iterate (a: A) : option B :=
  proj1_sig (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)).

Lemma converges_to_iterate:
  forall a b, converges_to a b -> iterate a = b.
Proof.
  intros. unfold iterate.
  destruct (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)) as [b' P].
  simpl. apply converges_to_unique with a; auto.
Qed.

Lemma iterate_converges_to:
  forall a, converges_to a (iterate a).
Proof.
  intros. unfold iterate.
  destruct (constructive_definite_description (converges_to a) (converges_to_exists_uniquely a)) as [b' P].
  simpl; auto.
Qed.

(** Invariance property. *)

Variable P: A -> Prop.
Variable Q: B -> Prop.

Hypothesis step_prop:
  forall a : A, P a ->
  match step a with inl b => Q b | inr a' => P a' end.

Lemma iter_prop:
  forall n a b, P a -> iter n a = Some b -> Q b.
Proof.
  induction n; intros until b; intro H; simpl.
  congruence.
  unfold F_iter. generalize (step_prop a H).
  case (step a); intros. congruence.
  apply IHn with a0; auto.
Qed.

Lemma iterate_prop:
  forall a b, iterate a = Some b -> P a -> Q b.
Proof.
  intros. destruct (iterate_converges_to a) as [n IT].
  rewrite H in IT. apply iter_prop with n a. auto. apply IT. auto.
Qed.

End ITERATION.

End GenIter.


From discprob.basic Require Import base order nify seq_ext.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat bigop fintype binomial.
Require Import Coq.omega.Omega Coq.Program.Wf.

Lemma uphalf_le n m:
  n <= m →
  uphalf n <= uphalf m.
Proof.
  move /leP => Hle. induction Hle.
  - done.
  - nify; etransitivity; first apply IHHle. clear.
    induction m => //=; first omega.
    rewrite ?uphalf_half; destruct (odd m); nify; omega.
Qed.

Lemma half_double_lt m n: m < n./2 → (m.*2 < n).
Proof.
  assert (Hlt: 0 < 2) by auto.
  rewrite -(ltn_pmul2r Hlt) -{2}(odd_double_half n). rewrite -?muln2.
  destruct (odd n) => //= ?; nify; omega.
Qed.

Lemma uphalf_sum_edge_odd n:
  odd n →
  \sum_(0 <= i < n) (if i + i < n.+1 then 1 else 0) =
  uphalf n.
Proof.
  assert (0 = n ∨ 0 < n)%coq_nat as [Heq|Hgt0] by omega.
  { subst. rewrite ?big_geq => //=. }

  transitivity (\sum_(0 <= i < uphalf n) 1); last first.
  { rewrite sum_nat_const_nat. nify. omega. }

  symmetry; rewrite (big_nat_widen 0 _ n); last first.
  { rewrite -{2}(uphalf_double n). apply uphalf_le; nify; omega. }

  rewrite -big_mkcondr //=. eapply eq_bigl.
             intros k. rewrite addnn. apply /ltP; case: ifP.
  - intros Hlt.
    assert (Hle': k.*2 <= n) by (nify; omega).
    apply half_leq in Hle'. nify.
    eapply le_lt_trans; eauto.
    rewrite //= uphalf_half. destruct (odd n) => //=.
  - move /negbT/ltP => Hlt Hlt'.
    apply Hlt. apply /ltP/half_double_lt. nify. done.
Qed.

Lemma uphalf_sum_edge_even n:
  ~~ odd n →
  \sum_(0 <= i < n) (if i + i < n then 1 else 0) =
  uphalf n.
Proof.
  intros Heven.
  assert (0 = n ∨ 0 < n)%coq_nat as [Heq|Hgt0] by omega.
  { subst. rewrite ?big_geq => //=. }

  transitivity (\sum_(0 <= i < uphalf n) 1); last first.
  { rewrite sum_nat_const_nat. nify. omega. }

  symmetry; rewrite (big_nat_widen 0 _ n); last first.
  { rewrite -{2}(uphalf_double n). apply uphalf_le; nify; omega. }

  rewrite -big_mkcondr //=. eapply eq_bigl.
  intros k. rewrite addnn. apply /ltP; case: ifP.
  - intros Hlt.
    assert (Hle': k.*2 < n - 1).
    { move /ltP in Hlt. inversion Hlt; last (nify; omega).
      subst. rewrite //= odd_double // in Heven. }
    assert (2 <= n).
    { nify.  destruct n; first omega. destruct n; rewrite //= in Heven; omega. }

    rewrite uphalf_half. destruct (odd n) => //=.
    rewrite add0n.
    apply (le_lt_trans _ (n - 2)./2); last first.
    { assert (n = (S (S (n - 2)))) as Hsum by (nify; omega).
      rewrite {2}Hsum => //=. }
    apply /leP.
    rewrite -(half_double k) half_leq => //.
    nify; omega.
  - move /negbT/ltP => Hlt Hlt'.
    apply Hlt. apply /ltP/half_double_lt. rewrite uphalf_half in Hlt'.
    move: Hlt'. destruct (odd n) => //= ?. nify. omega.
Qed.

Lemma odd_half_double_lt n: odd n → n./2 + n./2 < n.
Proof.
  intros Hodd. rewrite -{3}(half_double n) -addnn halfD Hodd => //=.
Qed.

Lemma lt_addnn: ∀ n i, odd n → i ≠ uphalf n → (i + i < n.+2) = (i + i < n.+1).
Proof.
  intros n i Hodd Hneq.
  apply /ltP; case: ifP.
  - intros; nify; omega.
  - move /ltP. intros Hlt. assert (i + i >= S n) by (nify; omega).
    intros Hfalse.
    cut (i + i <> S n).
    { intros. nify. omega. }
    intros Heq. apply Hneq.
    rewrite addnn in Heq.
    apply (f_equal half) in Heq. rewrite /= in Heq.
    nify. done.
Qed.

Lemma uphalf_sum_rec n:
  odd n →
  \sum_(0 <= i < n.+1) (if i + i < n.+2 then 1 else 0) =
  \sum_(0 <= i < n.+1) (if i + i < n.+1 then 1 else 0) + 1.
Proof.
  rewrite ?big_mkord => Hodd.
  assert (Hlt: (n.+1)./2 < n.+1).
  { destruct n; first by rewrite //=.
    nify. eapply (le_lt_trans _ (S n)); auto.
    rewrite -{2}(half_double (S n)).
    apply /leP.
    apply half_leq.
    nify. omega.
  }
  rewrite (bigD1 (Ordinal Hlt)) //.
  rewrite //=. rewrite addnC; f_equal.
  - rewrite big_mkcond //=. eapply eq_bigr. intros (i&Hlt') _.
    rewrite //=.
    case: ifP => Hneq; last first.
    { case: ifP; auto. intros Hcontra. move /eqP in Hneq.
      inversion Hneq; subst.
      rewrite ?uphalf_half in Hcontra. rewrite Hodd //= in Hcontra.
      rewrite -{3}(half_double n) -addnn halfD Hodd //= in Hcontra.
      nify. omega.
    }
    rewrite lt_addnn => //. intros Heq. subst. move /eqP in Hneq.
    apply /Hneq/ord_inj => //=.
  - case: ifP; auto.
    move /ltP. intros Hn. contradiction Hn.
    rewrite uphalf_half Hodd => //=.
    specialize (odd_half_double_lt n Hodd) => ?.
    nify. omega.
Qed.

Lemma uphalf_sum_half n:
  \sum_(0 <= i < n) (if i < n - i then 1 else 0) = uphalf n.
Proof.
  transitivity (\sum_(0 <= i < n) (if i + i < n then 1 else 0)).
  { rewrite ?big_mkord -?big_mkcond. apply eq_bigl. intros (i&Hlt) => //=.
    apply /ltP. case: ifP; move /ltP; rewrite -?plusE -?minusE => ?; omega.
  }
  rewrite uphalf_half.
  elim: n => [|n IHn]; first by rewrite ?big_geq.
  rewrite //= uphalf_half -IHn.
  rewrite big_nat_recr //=. destruct n => //=.
  - rewrite ?big_geq //=.
  - case: ifP.
    { move /ltP. rewrite -?plusE. intros. exfalso. omega. }
    intros. rewrite addn0.
    case_eq (odd n); last first.
    * intros Heven. rewrite uphalf_sum_edge_odd => //=; last by (rewrite Heven => //).
      rewrite IHn //= uphalf_half !Heven /=. nify. omega.
    * intros Hodd. rewrite uphalf_sum_edge_even => //=; last by (rewrite Hodd => //).
      rewrite //= uphalf_half Hodd //= in IHn.
      rewrite uphalf_sum_rec //= IHn. nify; omega.
Qed.

Lemma uphalf_sum_max n:
\sum_(0 <= i < n) Init.Nat.max i (n.+1 - i - 1) =
\sum_(0 <= i < n) Init.Nat.max i (n - i - 1) + uphalf n.
Proof.
  transitivity (\sum_(0 <= i < n) (Init.Nat.max i (n - i - 1) + (if i < n - i then 1 else 0))).
  { rewrite ?big_mkord.
    eapply eq_bigr. intros (i&Hlt) _ => /=.
    case: ifP => Hlt'.
    - rewrite ?Max.max_r => //=; nify; omega.
    - apply negbT in Hlt'. rewrite -leqNgt in Hlt'.
      rewrite ?Max.max_l => //=; nify; omega.
  }
  rewrite big_split //=. f_equal.
  apply uphalf_sum_half.
Qed.

Lemma max_triangular_sum n : \sum_(0 <= i < n) max i (n - i - 1) = 'C(n, 2) + uphalf n * half n.
Proof.
  elim: n => [|n IHn]; first by rewrite big_geq.
  rewrite big_nat_recr //= binS bin1 Max.max_l; last by (nify; omega).
  rewrite uphalf_sum_max IHn. ring.
Qed.


Require Export XR_R.
Require Export XR_Rmult.

Local Open Scope R_scope.
Implicit Type r : R.

Definition Rsqr r : R := r * r.

Notation "r ²" := (Rsqr r) (at level 1, format "r ²") : R_scope.


Set Warnings "-deprecated-hint-without-locality,-deprecated-hint-without-locality".
From PLF Require Import Maps.
From PLF Require Import hoare.

From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Bool.

Hint Constructors ceval : core.

Definition valid (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st',
    st =[ c ]=> st' ->
    P st ->
    Q st'.

Inductive derivable : Assertion -> com -> Assertion -> Type :=
  | H_Skip : forall P,
      derivable P <{skip}> P
  | H_Asgn : forall Q V a,
      derivable (Q [V |-> a]) <{V := a}> Q
  | H_Seq : forall P c Q d R,
      derivable P c Q -> derivable Q d R -> derivable P <{c;d}> R
  | H_If : forall P Q b c1 c2,
    derivable (fun st=> P st /\ bassn b st) c1 Q ->
    derivable (fun st=> P st /\ ~(bassn b st)) c2 Q ->
    derivable P <{if b then c1 else c2 end}> Q
  | H_While : forall P b c,
    derivable (fun st=> P st /\ bassn b st) c P ->
    derivable P <{while b do c end}> (fun st=> P st /\ ~ (bassn b st))
  | H_Consequence : forall (P Q P' Q' : Assertion) c,
    derivable P' c Q' ->
    (forall st, P st -> P' st) ->
    (forall st, Q' st -> Q st) ->
    derivable P c Q.

Lemma H_Consequence_pre: forall (P Q P': Assertion) c,
  derivable P' c Q ->
  (forall st, P st -> P' st) ->
  derivable P c Q.
Proof. eauto using H_Consequence. Qed.

Lemma H_Consequence_post: forall (P Q Q' : Assertion) c,
  derivable P c Q' ->
  (forall st, Q' st -> Q st) ->
  derivable P c Q.
Proof. eauto using H_Consequence. Qed.

Theorem provable_true_post: forall c P,
  derivable P c True.
Proof.
  induction c; intros.
  - eapply H_Consequence_post. apply H_Skip. auto.
  - eapply H_Consequence_pre. apply H_Asgn. auto.
  - eapply H_Seq; auto.
  - eapply H_Consequence_pre. apply H_If; auto. intros. apply H.
  - eapply H_Consequence. apply H_While; auto. auto. auto.
Qed.

Theorem provable_false_pre : forall c Q,
  derivable False c Q.
Proof.
  induction c; intros.
  - eapply H_Consequence_pre. apply H_Skip. intros. inversion H.
  - eapply H_Consequence_pre. apply H_Asgn. intros. inversion H.
  - eapply H_Consequence_pre. eapply H_Seq; auto. trivial.
  - apply H_If. eapply H_Consequence_pre.
    + trivial.
    + intros. destruct H. auto.
    + eapply H_Consequence_pre. auto. intros. destruct H. auto.
  - eapply H_Consequence_post.
    + apply H_While. simpl. eapply H_Consequence_pre.
      trivial. intros. inversion H. eauto.
    + intros. simpl. inversion H. inversion H0.
Qed.

(* A logic is sound if everything that is derivable is valid.
A logic is complete if everything that is valid is derivable. *)
Theorem hoare_sound : forall P c Q,
  derivable P c Q -> valid P c Q.
Proof.
  intros. induction X; intros st st' Hcom H'.
  - inversion Hcom. subst. auto.
  - inversion Hcom. subst. auto.
  - inversion Hcom. subst. auto. eapply IHX2. eauto. eapply IHX1; eauto.
  - inversion Hcom. subst.
    + eapply IHX1. eauto. split; auto.
    + eapply IHX2. eauto. split; auto.
  - remember <{ while b do c end }> as com.
    induction Hcom; try discriminate Heqcom.
    + inversion Heqcom. subst. clear Heqcom. split; auto.
    + inversion Heqcom. subst. clear Heqcom.
      apply IHHcom2. trivial.
      eapply IHX. eauto. split; trivial.
  - apply q. eapply IHX. eauto. apply p. auto.
Qed.

Definition wp (c:com) (Q:Assertion) : Assertion :=
  fun s => forall s', s =[ c ]=> s' -> Q s'.

Hint Unfold wp : core.

Theorem wp_is_precondition : forall c Q,
  {{wp c Q}} c {{Q}}.
Proof. auto. Qed.

Theorem wp_is_weakest : forall c Q P',
    {{P'}} c {{Q}} ->
    P' ->> (wp c Q).
Proof. eauto. Qed.

Lemma wp_seq : forall P Q c1 c2,
    derivable P c1 (wp c2 Q) ->
    derivable (wp c2 Q) c2 Q ->
    derivable P <{c1; c2}> Q.
Proof.
  intros.
  eapply H_Seq; eauto.
Qed.

Lemma wp_invariant : forall b c Q,
    valid (wp <{while b do c end}> Q /\ b) c (wp <{while b do c end}> Q).
Proof.
  unfold valid, wp. intros. destruct H0. specialize H0 with s'.
  apply H0. eauto.
Qed.

Theorem hoare_complete: forall P c Q,
  valid P c Q -> derivable P c Q.
Proof.
  unfold valid. intros P c. generalize dependent P.
  induction c; intros P Q HT.
  - eapply H_Consequence_pre. apply H_Skip.
    intros. apply HT with st; auto.
  - eapply H_Consequence_pre. apply H_Asgn.
    intros. apply HT with st; auto.
  - apply wp_seq.
    + apply IHc1. unfold wp. intros. eapply HT; eauto.
    + apply IHc2. unfold wp. intros. eapply H0; eauto.
  - apply H_If.
    + apply IHc1. intros. apply HT with st; destruct H0; eauto.
    + apply IHc2. intros. apply HT with st; destruct H0; simpl in H1;
      try apply not_true_is_false in H1; eauto.
  - eapply H_Consequence. apply H_While.
    + apply IHc. apply wp_invariant.
    + apply wp_is_weakest. eauto.
    + intros. destruct H. apply H.
      simpl in *. apply not_true_is_false in H0.
      eauto.
      (* b must be explicitly false so that eauto can prove the goal. *)
Qed.


(* week-15_a-commutative-diagram.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Spelled-out version of Sun 26 Nov 2017 *)
(* was: *)
(* Version of Sat 25 Nov 2017 *)

(* ********** *)

(*
   name: Jeremy Yew
   student ID number: A0156262H
   e-mail address: jeremy.yew@u.yale-nus.edu.sg
*)

(* ********** *)
(*

The goal of this term project is to prove the following theorem:

  Theorem the_commutative_diagram :
    forall sp : source_program,
      interpret sp = run (compile sp).

for

* a source language of arithmetic expressions:

    Inductive arithmetic_expression : Type :=
    | Literal : nat -> arithmetic_expression
    | Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
    | Minus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

    Inductive source_program : Type :=
    | Source_program : arithmetic_expression -> source_program.

* a target language of byte-code instructions:

    Inductive byte_code_instruction : Type :=
    | PUSH : nat -> byte_code_instruction
    | ADD : byte_code_instruction
    | SUB : byte_code_instruction.

    Inductive target_program : Type :=
    | Target_program : list byte_code_instruction -> target_program.

* a semantics of expressible values:

    Inductive expressible_value : Type :=
    | Expressible_nat : nat -> expressible_value
    | Expressible_msg : string -> expressible_value.

The source for errors is subtraction,
since subtracting two natural numbers does not always yield a natural number:
for example, 3 - 2 is defined but not 2 - 3.

You are expected, at the very least:

* to implement a source interpreter
  and to verify that it satisfies its specification

* to implement a target interpreter (i.e., a virtual machine)
  and to verify that it satisfies its specification

* to implement a compiler
  and to verify that it satisfies its specification

* to prove that the diagram commutes, i.e., to show that
  interpreting any given expression
  gives the same result as
  compiling this expression and then running the resulting compiled program
  (to this end, the injection tactic illustrated in Lemma new_and_useful just below will come handy)

Beyond this absolute minimum, in decreasing importance, it would be good:

* to write an accumulator-based compiler and to prove that it satisfies the specification

* to investigate byte-code verification

* to revisit good old Magritte

* to write a continuation-based interpreter and to prove that it satisfies the specification

* to prove that each of the specifications specifies a unique function

*)

(* ********** *)

Lemma new_and_useful :
  forall i j : nat,
    Some i = Some j -> i = j.
Proof.
  intros i j H_Some.
  injection H_Some as H_i_j.  (* <--[new and useful]-- *)
  exact H_i_j.
Qed.

(* ********** *)

Ltac unfold_tactic name :=
  intros;
  unfold name; (* fold name; *)
  reflexivity.

Require Import Arith Bool List String.

Fixpoint ltb (n1 n2 : nat) : bool :=
  match n1 with
  | O =>
    match n2 with
    | O =>
      false
    | S n2' =>
      true
    end
  | S n1' =>
    match n2 with
    | O =>
      false
    | S n2' =>
      ltb n1' n2'
    end
  end.

Notation "A =n= B" := (beq_nat A B) (at level 70, right associativity).

(* ********** *)

(* Arithmetic expressions: *)

Inductive arithmetic_expression : Type :=
| Literal : nat -> arithmetic_expression
| Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
| Minus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

(* Source programs: *)

Inductive source_program : Type :=
| Source_program : arithmetic_expression -> source_program.

(* ********** *)

(* Semantics: *)

Inductive expressible_value : Type :=
| Expressible_nat : nat -> expressible_value
| Expressible_msg : string -> expressible_value.

(* ********** *)

Definition specification_of_evaluate (evaluate : arithmetic_expression -> expressible_value) :=
  (forall n : nat,
     evaluate (Literal n) = Expressible_nat n)
  /\
 ((forall (ae1 ae2 : arithmetic_expression)
           (s1 : string),
       evaluate ae1 = Expressible_msg s1 ->
       evaluate (Plus ae1 ae2) = Expressible_msg s1)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 : nat)
           (s2 : string),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_msg s2 ->
       evaluate (Plus ae1 ae2) = Expressible_msg s2)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       evaluate (Plus ae1 ae2) = Expressible_nat (n1 + n2)))
  /\
  ((forall (ae1 ae2 : arithmetic_expression)
           (s1 : string),
       evaluate ae1 = Expressible_msg s1 ->
       evaluate (Minus ae1 ae2) = Expressible_msg s1)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 : nat)
           (s2 : string),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_msg s2 ->
       evaluate (Minus ae1 ae2) = Expressible_msg s2)
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       ltb n1 n2 = true ->
       evaluate (Minus ae1 ae2) = Expressible_msg "numerical underflow")
   /\
   (forall (ae1 ae2 : arithmetic_expression)
           (n1 n2 : nat),
       evaluate ae1 = Expressible_nat n1 ->
       evaluate ae2 = Expressible_nat n2 ->
       ltb n1 n2 = false ->
       evaluate (Minus ae1 ae2) = Expressible_nat (n1 - n2))).

Definition specification_of_interpret (interpret : source_program -> expressible_value) :=
  forall evaluate : arithmetic_expression -> expressible_value,
    specification_of_evaluate evaluate ->
    forall ae : arithmetic_expression,
      interpret (Source_program ae) = evaluate ae.

(* Task 1:
   prove that each of the definitions above specifies a unique function,
   implement these two functions,
   and verify that each of your functions satisfies its specification.
 *)

Theorem there_is_at_most_one_evaluate:
  forall f g : arithmetic_expression -> expressible_value,
    specification_of_evaluate f ->
    specification_of_evaluate g ->
    forall ae : arithmetic_expression,
      f ae = g ae.
Proof.
  intros f g.
  intros [S_f_Literal
            [[S_f_Plus_msg [S_f_Plus_nat_msg S_f_Plus_nat_nat]]
               [S_f_Minus_msg [S_f_Minus_nat_msg
                                 [S_f_Minus_nat_nat_ltbt S_f_Minus_nat_nat_ltbf]]]]]
         [S_g_Literal
            [[S_g_Plus_msg [S_g_Plus_nat_msg S_g_Plus_nat_nat]]
               [S_g_Minus_msg [S_g_Minus_nat_msg
                                 [S_g_Minus_nat_nat_ltbt S_g_Minus_nat_nat_ltbf]]]]].
  intro ae.
  induction ae as [n
                  | ae1 IH_ae1 ae2 IH_ae2
                  | ae1 IH_ae1 ae2 IH_ae2].
  (*Literal*)
  rewrite -> S_f_Literal.
  rewrite -> S_g_Literal.
  reflexivity.

  (*Plus*)
  assert (H_g_ae1 := IH_ae1).
  assert (H_g_ae2 := IH_ae2).
  case (f ae1) as [n1 | s1] eqn: H_f_ae1.
  case (f ae2) as [n2 | s2] eqn: H_f_ae2.
  rewrite -> (S_f_Plus_nat_nat ae1 ae2 n1 n2 H_f_ae1 H_f_ae2).
  rewrite -> (S_g_Plus_nat_nat ae1 ae2 n1 n2).
  reflexivity.
  symmetry; apply H_g_ae1.
  symmetry; apply H_g_ae2.

  rewrite -> (S_f_Plus_nat_msg ae1 ae2 n1 s2 H_f_ae1 H_f_ae2).
  rewrite -> (S_g_Plus_nat_msg ae1 ae2 n1 s2).
  reflexivity.
  symmetry; apply H_g_ae1.
  symmetry; apply H_g_ae2.

  rewrite -> (S_f_Plus_msg ae1 ae2 s1 H_f_ae1).
  rewrite -> (S_g_Plus_msg ae1 ae2 s1).
  reflexivity.
  symmetry; apply H_g_ae1.

  (*Minus*)
  assert (H_g_ae1 := IH_ae1).
  assert (H_g_ae2 := IH_ae2).
  case (f ae1) as [n1 | s1] eqn: H_f_ae1.
  case (f ae2) as [n2 | s2] eqn: H_f_ae2.
  case (ltb n1 n2) as [ true | false ] eqn: H_ltb.
  rewrite -> (S_f_Minus_nat_nat_ltbt ae1 ae2 n1 n2 H_f_ae1 H_f_ae2 H_ltb).
  rewrite -> (S_g_Minus_nat_nat_ltbt ae1 ae2 n1 n2).
  reflexivity.
  symmetry; apply H_g_ae1.
  symmetry; apply H_g_ae2.
  apply H_ltb.

  rewrite -> (S_f_Minus_nat_nat_ltbf ae1 ae2 n1 n2 H_f_ae1 H_f_ae2 H_ltb).
  rewrite -> (S_g_Minus_nat_nat_ltbf ae1 ae2 n1 n2).
  reflexivity.
  symmetry; apply H_g_ae1.
  symmetry; apply H_g_ae2.
  apply H_ltb.

  rewrite -> (S_f_Minus_nat_msg ae1 ae2 n1 s2 H_f_ae1 H_f_ae2).
  rewrite -> (S_g_Minus_nat_msg ae1 ae2 n1 s2).
  reflexivity.
  symmetry; apply H_g_ae1.
  symmetry; apply H_g_ae2.
  rewrite -> (S_f_Minus_msg ae1 ae2 s1 H_f_ae1).
  rewrite -> (S_g_Minus_msg ae1 ae2 s1).
  reflexivity.
  symmetry; apply H_g_ae1.
Qed.

Fixpoint evaluate (ae: arithmetic_expression) : expressible_value :=
  match ae with
  | Literal n =>
    Expressible_nat n
  | Plus ae1 ae2 =>
    match (evaluate ae1) with
    | Expressible_msg s1 =>
      Expressible_msg s1
    | Expressible_nat n1 =>
      match (evaluate ae2) with
      | Expressible_msg s2 =>
        Expressible_msg s2
      | Expressible_nat n2 =>
        Expressible_nat (n1 + n2)
      end
    end
  | Minus ae1 ae2 =>
    match (evaluate ae1) with
    | Expressible_msg s1 =>
      Expressible_msg s1
    | Expressible_nat n1 =>
      match (evaluate ae2) with
      | Expressible_msg s2 =>
        Expressible_msg s2
      | Expressible_nat n2 =>
        match (ltb n1 n2) with
        | true =>
          Expressible_msg "numerical underflow"
        | false =>
          Expressible_nat (n1 - n2)
        end
      end
    end
  end.

Lemma unfold_evaluate_Literal :
  forall n : nat,
    evaluate (Literal n) = Expressible_nat n.
Proof.
  unfold_tactic evaluate.
Qed.

Lemma unfold_evaluate_Plus :
  forall ae1 ae2 : arithmetic_expression,
    evaluate (Plus ae1 ae2) =
    match (evaluate ae1) with
    | Expressible_msg s1 =>
      Expressible_msg s1
    | Expressible_nat n1 =>
      match (evaluate ae2) with
      | Expressible_msg s2 =>
        Expressible_msg s2
      | Expressible_nat n2 =>
        Expressible_nat (n1 + n2)
      end
    end.
Proof.
  unfold_tactic evaluate.
Qed.

Lemma unfold_evaluate_Minus :
  forall ae1 ae2 : arithmetic_expression,
    evaluate (Minus ae1 ae2) =
    match (evaluate ae1) with
    | Expressible_msg s1 =>
      Expressible_msg s1
    | Expressible_nat n1 =>
      match (evaluate ae2) with
      | Expressible_msg s2 =>
        Expressible_msg s2
      | Expressible_nat n2 =>
        match (ltb n1 n2) with
        | true =>
          Expressible_msg "numerical underflow"
        | false =>
          Expressible_nat (n1 - n2)
        end
      end
    end.
Proof.
  unfold_tactic evaluate.
Qed.

Theorem there_is_at_least_one_evaluate:
  specification_of_evaluate evaluate.
Proof.
  unfold specification_of_evaluate.
  split.
    intro n.
    rewrite -> unfold_evaluate_Literal.
    reflexivity.
  split.
    split.
      intros ae1 ae2 s1 H_ae1_msg.
      rewrite -> unfold_evaluate_Plus.
      rewrite -> H_ae1_msg.
      reflexivity.
    split.
      intros ae1 ae2 n1 s2 H_ae1_nat H_ae2_msg.
      rewrite -> unfold_evaluate_Plus.
      rewrite -> H_ae1_nat.
      rewrite -> H_ae2_msg.
      reflexivity.
    intros ae1 ae2 n1 n2 H_ae1_nat H_ae2_nat.
    rewrite -> unfold_evaluate_Plus.
    rewrite -> H_ae1_nat.
    rewrite -> H_ae2_nat.
    reflexivity.
    split.
      intros ae1 ae2 s1 H_ae1_msg.
      rewrite -> unfold_evaluate_Minus.
      rewrite -> H_ae1_msg.
      reflexivity.
    split.
      intros ae1 ae2 n1 s2 H_ae1_nat H_ae2_msg.
      rewrite -> unfold_evaluate_Minus.
      rewrite -> H_ae1_nat.
      rewrite -> H_ae2_msg.
      reflexivity.
    split.
      intros ae1 ae2 n1 n2 H_ae1_nat H_ae2_nat H_ltb_true.
      rewrite -> unfold_evaluate_Minus.
      rewrite -> H_ae1_nat.
      rewrite -> H_ae2_nat.
      rewrite -> H_ltb_true.
      reflexivity.
    intros ae1 ae2 n1 n2 H_ae1_nat H_ae2_nat H_ltb_false.
    rewrite -> unfold_evaluate_Minus.
    rewrite -> H_ae1_nat.
    rewrite -> H_ae2_nat.
    rewrite -> H_ltb_false.
    reflexivity.
Qed.

Theorem there_is_at_most_one_interpret:
  forall f g : source_program -> expressible_value,
    specification_of_interpret f ->
    specification_of_interpret g ->
    forall sp : source_program,
      f sp = g sp.
Proof.
  intros f g.
  unfold specification_of_interpret.
  intros S_f S_g sp.
  case sp as [ae].
  rewrite -> (S_f evaluate there_is_at_least_one_evaluate).
  rewrite -> (S_g evaluate there_is_at_least_one_evaluate).
  reflexivity.
Qed.

Fixpoint interpret (sp : source_program) : expressible_value :=
  match sp with
  | Source_program ae =>
    evaluate ae
  end.

Theorem there_is_at_least_one_interpret:
  specification_of_interpret interpret.
Proof.
  unfold specification_of_interpret.
  intros evaluate S_evaluate ae.
  unfold interpret.
  apply there_is_at_most_one_evaluate.
  apply there_is_at_least_one_evaluate.
  apply S_evaluate.
Qed.

(* ********** *)

(* Task 2 (if there is time):
   Define an interpreter with a function in continuation-passing style
   that satisfies the specification above,
   and that only apply the current continuation to the result of evaluating
   an expression if evaluating this expression did not yield an error.
*)

(* ********** *)

(* Byte-code instructions: *)

Inductive byte_code_instruction : Type :=
| PUSH : nat -> byte_code_instruction
| ADD : byte_code_instruction
| SUB : byte_code_instruction.

(* Target programs: *)

Inductive target_program : Type :=
| Target_program : list byte_code_instruction -> target_program.

(* Data stack: *)

Definition data_stack := list nat.

(* ********** *)

Inductive result_of_decoding_and_execution : Type :=
| OK : data_stack -> result_of_decoding_and_execution
| KO : string -> result_of_decoding_and_execution.

Definition specification_of_decode_execute (decode_execute : byte_code_instruction -> data_stack -> result_of_decoding_and_execution) :=
  (forall (n : nat)
          (ds : data_stack),
     decode_execute (PUSH n) ds = OK (n :: ds))
  /\
  ((decode_execute ADD nil = KO "ADD: stack underflow")
   /\
   (forall (n2 : nat),
       decode_execute ADD (n2 :: nil) = KO "ADD: stack underflow")
   /\
   (forall (n1 n2 : nat)
           (ds : data_stack),
       decode_execute ADD (n2 :: n1 :: ds) = OK ((n1 + n2) :: ds)))
  /\
  ((decode_execute SUB nil = KO "SUB: stack underflow")
   /\
   (forall (n2 : nat),
       decode_execute SUB (n2 :: nil) = KO "SUB: stack underflow")
   /\
   (forall (n1 n2 : nat)
           (ds : data_stack),
       ltb n1 n2 = true ->
       decode_execute SUB (n2 :: n1 :: ds) = KO "numerical underflow")
   /\
   (forall (n1 n2 : nat)
           (ds : data_stack),
       ltb n1 n2 = false ->
       decode_execute SUB (n2 :: n1 :: ds) = OK ((n1 - n2) :: ds))).

(* Task 3:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
*)
Theorem there_is_at_most_one_decode_execute :
    forall f g : byte_code_instruction -> data_stack -> result_of_decoding_and_execution,
    specification_of_decode_execute f ->
    specification_of_decode_execute g ->
    forall (bci : byte_code_instruction) (ds : data_stack),
      f bci ds = g bci ds.
Proof.
  intros f g.
  intros [S_f_PUSH
            [[S_f_ADD_nil [S_f_ADD_n2_nil S_f_ADD_n2_n1]]
               [S_f_SUB_nil [S_f_SUB_n2_nil
                                 [S_f_SUB_n2_n1_ltbt S_f_SUB_n2_n1_ltbf]]]]]
         [S_g_PUSH
            [[S_g_ADD_nil [S_g_ADD_n2_nil S_g_ADD_n2_n1]]
               [S_g_SUB_nil [S_g_SUB_n2_nil
                                 [S_g_SUB_n2_n1_ltbt S_g_SUB_n2_n1_ltbf]]]]].
  intros bci ds.
  induction bci as [ n | ADD | SUB ].

  (*PUSH*)
  rewrite -> S_f_PUSH.
  rewrite -> S_g_PUSH.
  reflexivity.

  (*ADD*)
  case ds as [nil| n2 ds'] eqn: H_ds.
  rewrite -> S_f_ADD_nil.
  rewrite -> S_g_ADD_nil.
  reflexivity.

  case ds' as [nil | n1 ds''] eqn: H_ds'.
  rewrite -> S_f_ADD_n2_nil.
  rewrite -> S_g_ADD_n2_nil.
  reflexivity.

  rewrite -> S_f_ADD_n2_n1.
  rewrite -> S_g_ADD_n2_n1.
  reflexivity.

  (*SUB*)
  case ds as [nil| n2 ds'] eqn: H_ds.
  rewrite -> S_f_SUB_nil.
  rewrite -> S_g_SUB_nil.
  reflexivity.

  case ds' as [nil | n1 ds''] eqn: H_ds'.
  rewrite -> S_f_SUB_n2_nil.
  rewrite -> S_g_SUB_n2_nil.
  reflexivity.

  case (ltb n1 n2) as [true | false ] eqn: H_ltb.
  rewrite -> (S_f_SUB_n2_n1_ltbt).
  rewrite -> S_g_SUB_n2_n1_ltbt.
  reflexivity.
  apply H_ltb.
  apply H_ltb.

  rewrite -> S_f_SUB_n2_n1_ltbf.
  rewrite -> S_g_SUB_n2_n1_ltbf.
  reflexivity.
  apply H_ltb.
  apply H_ltb.
Qed.

Definition decode_execute (bci : byte_code_instruction) (ds : data_stack) : result_of_decoding_and_execution :=
  match bci with
  | PUSH n =>
    OK (n :: ds)
  | ADD =>
    match ds with
    | nil =>
      KO "ADD: stack underflow"
    | n2 :: ds' =>
      match ds' with
      | nil =>
        KO "ADD: stack underflow"
      | n1 :: ds'' =>
        OK ((n1 + n2) :: ds'')
      end
    end
  | SUB =>
    match ds with
    | nil =>
      KO "SUB: stack underflow"
    | n2 :: ds' =>
      match ds' with
      | nil =>
        KO "SUB: stack underflow"
      | n1 :: ds'' =>
        match ltb n1 n2 with
        | true =>
          KO "numerical underflow"
        | false =>
          OK ((n1 - n2) :: ds'')
        end
      end
    end
  end.

Theorem decode_execute_satisfies_the_specification_of_decode_execute :
  specification_of_decode_execute decode_execute.
Proof.
  unfold specification_of_decode_execute.
  unfold decode_execute.
  split.
    intros n ds.
    reflexivity.
  split.
    split.
      reflexivity.
    split.
      reflexivity.
    intros n1 n2 ds.
    reflexivity.
  split.
    reflexivity.
  split.
    reflexivity.
  split.
    intros n1 n2 ds H_ltb.
    rewrite -> H_ltb.
    reflexivity.
  intros n1 n2 ds H_ltb.
  rewrite -> H_ltb.
  reflexivity.
Qed.

(* ********** *)

(* Specification of the virtual machine: *)

Definition specification_of_fetch_decode_execute_loop (fetch_decode_execute_loop : list byte_code_instruction -> data_stack -> result_of_decoding_and_execution) :=
  forall decode_execute : byte_code_instruction -> data_stack -> result_of_decoding_and_execution,
    specification_of_decode_execute decode_execute ->
    (forall ds : data_stack,
        fetch_decode_execute_loop nil ds = OK ds)
    /\
    (forall (bci : byte_code_instruction)
            (bcis' : list byte_code_instruction)
            (ds ds' : data_stack),
        decode_execute bci ds = OK ds' ->
        fetch_decode_execute_loop (bci :: bcis') ds =
        fetch_decode_execute_loop bcis' ds')
    /\
    (forall (bci : byte_code_instruction)
            (bcis' : list byte_code_instruction)
            (ds : data_stack)
            (s : string),
        decode_execute bci ds = KO s ->
        fetch_decode_execute_loop (bci :: bcis') ds =
        KO s).

(* Task 4:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
*)

Theorem there_is_at_most_one_fetch_decode_execute_loop:
    forall f g : list byte_code_instruction -> data_stack -> result_of_decoding_and_execution,
    specification_of_fetch_decode_execute_loop f ->
    specification_of_fetch_decode_execute_loop g ->
    forall (bcis : list byte_code_instruction) (ds : data_stack),
      f bcis ds = g bcis ds.
Proof.
  unfold specification_of_fetch_decode_execute_loop.
  intros f g S_f S_g bcis.
  destruct (S_f decode_execute decode_execute_satisfies_the_specification_of_decode_execute) as [S_f_nil [S_f_bci_OK S_f_bci_KO]].
  destruct (S_g decode_execute decode_execute_satisfies_the_specification_of_decode_execute) as [S_g_nil [S_g_bci_OK S_g_bci_KO]].

  induction bcis as [nil | bci bcis' IH_bcis].
  intro ds.
  rewrite -> S_f_nil.
  rewrite -> S_g_nil.
  reflexivity.

  intro ds.
  case (decode_execute bci ds) as [ds' | s] eqn : H_bci_ds.
  rewrite -> (S_f_bci_OK bci bcis' ds ds' H_bci_ds).
  rewrite -> (S_g_bci_OK bci bcis' ds ds' H_bci_ds).
  rewrite -> IH_bcis.
  reflexivity.

  rewrite -> (S_f_bci_KO bci bcis' ds s H_bci_ds).
  rewrite -> (S_g_bci_KO bci bcis' ds s H_bci_ds).
  reflexivity.
Qed.

Fixpoint fetch_decode_execute_loop (bcis : list byte_code_instruction) (ds : data_stack) : result_of_decoding_and_execution :=
  match bcis with
  | nil =>
    OK ds
  | bci :: bcis' =>
    match decode_execute bci ds with
    | OK ds' =>
      fetch_decode_execute_loop bcis' ds'
    | KO s =>
      KO s
    end
  end.

Lemma unfold_fetch_decode_execute_loop_nil:
  forall ds : data_stack,
    fetch_decode_execute_loop nil ds = OK ds.
Proof.
  unfold_tactic fetch_decode_execute_loop.
Qed.

Lemma unfold_fetch_decode_execute_loop_bcis:
  forall (bci : byte_code_instruction) (bcis' : list byte_code_instruction)
  (ds : data_stack),
    fetch_decode_execute_loop (bci :: bcis') ds =
    match decode_execute bci ds with
    | OK ds' =>
      fetch_decode_execute_loop bcis' ds'
    | KO s =>
      KO s
    end.
Proof.
  unfold_tactic fetch_decode_execute_loop.
Qed.
Theorem fetch_decode_execute_loop_satisfies_the_specification:
  specification_of_fetch_decode_execute_loop fetch_decode_execute_loop.
Proof.
  unfold specification_of_fetch_decode_execute_loop.
  intros decode_execute S_decode_execute.
  split.
    intro ds.
    rewrite -> unfold_fetch_decode_execute_loop_nil.
    reflexivity.
  split.
    intros bci bcis' ds ds' H_bci_ds_OK.
    rewrite -> unfold_fetch_decode_execute_loop_bcis.
    rewrite -> (there_is_at_most_one_decode_execute Top.decode_execute decode_execute decode_execute_satisfies_the_specification_of_decode_execute S_decode_execute).
    rewrite -> (H_bci_ds_OK).
    reflexivity.
  intros bci bcis' ds ds' H_bci_ds_KO.
  rewrite -> unfold_fetch_decode_execute_loop_bcis.
  rewrite -> (there_is_at_most_one_decode_execute Top.decode_execute decode_execute decode_execute_satisfies_the_specification_of_decode_execute S_decode_execute).
  rewrite -> (H_bci_ds_KO).
  reflexivity.
Qed.

  (* ********** *)

(* Task 5:
   Prove that for any lists of byte-code instructions bcis1 and bcis2,
   and for any data stack ds,
   executing the concatenation of bcis1 and bcis2 (i.e., bcis1 ++ bcis2) with ds
   gives the same result as
   (1) executing bcis1 with ds, and then
   (2) executing bcis2 with the resulting data stack, if there exists one.
*)

Lemma unfold_append_nil :
  forall bcis2 : list byte_code_instruction,
    nil ++ bcis2 = bcis2.
Proof.
  unfold_tactic List.app.
Qed.

Lemma unfold_append_nil_r :
  forall bcis2 : list byte_code_instruction,
    bcis2 ++ nil = bcis2.
Proof.
  Admitted.

Lemma unfold_append_cons :
  forall (bci1 : byte_code_instruction)
         (bci1s bci2s : list byte_code_instruction),
    (bci1 :: bci1s) ++ bci2s =
    bci1 :: (bci1s ++ bci2s).
Proof.
  unfold_tactic List.app.
Qed.

Theorem fetch_decode_execute_loop_is_distributive_over_append :
  forall (bcis1 bcis2: list byte_code_instruction)(ds ds': data_stack),
    fetch_decode_execute_loop bcis1 ds = OK ds' ->
        fetch_decode_execute_loop (bcis1 ++ bcis2) ds
        =
        fetch_decode_execute_loop bcis2 (ds').
Proof.
  intros bcis1 bcis2.
  induction bcis1 as [nil | bci1 bci1s IH_bci1s].
  induction bcis2 as [nil | bci2 bci2s IH_bci2s].
  intros ds ds' H_bcis1_OK.
  rewrite -> unfold_append_nil.
  rewrite -> H_bcis1_OK.
  rewrite -> unfold_fetch_decode_execute_loop_nil at 1.
  reflexivity.

  intros ds ds' H_bcis_OK.
  rewrite -> unfold_append_nil.
  (*rewrite -> unfold_append_nil_r.
  rewrite -> H_bcis_OK.
  rewrite -> unfold_fetch_decode_execute_loop_nil at 1.
  reflexivity.
*)
Admitted.

Theorem fetch_decode_execute_loop_is_distributive_over_append' :
  forall (bcis1 bcis2: list byte_code_instruction)(ds : data_stack),
  exists ds': data_stack,
    fetch_decode_execute_loop bcis1 ds = OK ds' ->
        fetch_decode_execute_loop (bcis1 ++ bcis2) ds
        =
        fetch_decode_execute_loop bcis2 (ds').
Proof.
  intros bcis1 bcis2 ds.
  induction bcis1 as [nil | bci1 bci1s IH_bci1s].
  induction bcis2 as [nil | bci2 bci2s IH_bci2s].
  exists ds.
  intro H_bcis1_OK.
  rewrite -> unfold_append_nil.
  rewrite -> H_bcis1_OK.
  reflexivity.

  exists ds.
  intro H_bcis_OK.
  rewrite -> unfold_append_nil.
  reflexivity.

  destruct IH_bci1s as [ds' IH_bci1s].
  case (bci1) as [ | | ] eqn: H.
  exists (ds').
  intro H_bcis_OK.
  rewrite -> unfold_append_cons.
  rewrite -> unfold_fetch_decode_execute_loop_bcis.
  rewrite -> unfold_fetch_decode_execute_loop_bcis in H_bcis_OK.

  Restart.
  intros bcis1 bcis2 ds.
  induction bcis2 as [nil | bci2 bci2s IH_bci2s].
  induction bcis1 as [nil | bci1 bci1s IH_bci1s].
  exists ds.
  intro H_bcis1_OK.
  rewrite -> unfold_append_nil.
  rewrite -> H_bcis1_OK.
  reflexivity.

  exists ds.
  intro H_bcis_OK.
  rewrite -> unfold_append_nil_r.
  rewrite -> H_bcis_OK.
  rewrite -> unfold_fetch_decode_execute_loop_nil at 1.
  reflexivity.

  destruct IH_bci2s as [ds' IH_bci2s].
  exists (ds').
  intro H_bcis_OK.
  assert (IH_bci2s_ds' := H_bcis_OK).
  apply IH_bci2s in IH_bci2s_ds'.
  rewrite -> unfold_fetch_decode_execute_loop_bcis.
Admitted.
  (* ********** *)

Definition specification_of_run (run : target_program -> expressible_value) :=
  forall fetch_decode_execute_loop : list byte_code_instruction -> data_stack -> result_of_decoding_and_execution,
    specification_of_fetch_decode_execute_loop fetch_decode_execute_loop ->
    (forall (bcis : list byte_code_instruction),
       fetch_decode_execute_loop bcis nil = OK nil ->
       run (Target_program bcis) = Expressible_msg "no result on the data stack")
    /\
    (forall (bcis : list byte_code_instruction)
            (n : nat),
       fetch_decode_execute_loop bcis nil = OK (n :: nil) ->
       run (Target_program bcis) = Expressible_nat n)
    /\
    (forall (bcis : list byte_code_instruction)
            (n n' : nat)
            (ds'' : data_stack),
       fetch_decode_execute_loop bcis nil = OK (n :: n' :: ds'') ->
       run (Target_program bcis) = Expressible_msg "too many results on the data stack")
    /\
    (forall (bcis : list byte_code_instruction)
            (s : string),
       fetch_decode_execute_loop bcis nil = KO s ->
       run (Target_program bcis) = Expressible_msg s).

(* Task 6:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
 *)

Theorem there_is_at_most_one_run:
  forall f g : target_program -> expressible_value,
    specification_of_run f ->
    specification_of_run g ->
    forall (tp : target_program),
      f tp = g tp.
Proof.
  intros f g.
  intros S_f S_g tp.
  destruct (S_f fetch_decode_execute_loop) as [S_f_OK_nil [S_f_OK_n_nil [S_f_OK_n_n_ds S_f_KO]]].
  exact fetch_decode_execute_loop_satisfies_the_specification.
  destruct (S_g fetch_decode_execute_loop) as [S_g_OK_nil [S_g_OK_n_nil [S_g_OK_n_n_ds S_g_KO]]].
  exact fetch_decode_execute_loop_satisfies_the_specification.
  case tp as [bcis].

  case (fetch_decode_execute_loop bcis nil) as [nil | [ | n ]] eqn: H_bcis_nil.
  rewrite -> S_f_OK_nil.
  rewrite -> S_g_OK_nil.
  reflexivity.
  (*  exact H_bcis_nil.*)
Admitted.

Fixpoint run (tp : target_program): expressible_value :=
  match tp with
  | Target_program bcis =>
    match (fetch_decode_execute_loop bcis nil) with
    | OK ds =>
      match ds with
      | nil =>
        Expressible_msg "no result on the data stack"
      | n :: ds' =>
        match ds' with
        | nil =>
          Expressible_nat n
        | n' :: ds'' =>
          Expressible_msg "too many results on the data stack"
        end
      end
    | KO s =>
      Expressible_msg s
    end
  end.

Theorem run_satisfies_the_specification_of_run:
  specification_of_run run.
Proof.
  unfold specification_of_run.
  intros fetch_decode_execute_loop S_fetch_decode_execute_loop.
  split.
    intros bcis H_fetch_OK.
    unfold run.
    rewrite -> (there_is_at_most_one_fetch_decode_execute_loop Top.fetch_decode_execute_loop fetch_decode_execute_loop  fetch_decode_execute_loop_satisfies_the_specification S_fetch_decode_execute_loop).
    rewrite -> H_fetch_OK.
    reflexivity.
  split.
    intros bcis n H_fetch_OK.
    unfold run.
    rewrite -> (there_is_at_most_one_fetch_decode_execute_loop Top.fetch_decode_execute_loop fetch_decode_execute_loop fetch_decode_execute_loop_satisfies_the_specification S_fetch_decode_execute_loop).
    rewrite -> H_fetch_OK.
    reflexivity.
  split.
    intros bcis n n' ds'' H_fetch_OK.
    unfold run.
    rewrite -> (there_is_at_most_one_fetch_decode_execute_loop Top.fetch_decode_execute_loop fetch_decode_execute_loop fetch_decode_execute_loop_satisfies_the_specification S_fetch_decode_execute_loop).
    rewrite -> H_fetch_OK.
    reflexivity.
  intros bcis s H_fetch_KO.
  unfold run.
  rewrite -> (there_is_at_most_one_fetch_decode_execute_loop Top.fetch_decode_execute_loop fetch_decode_execute_loop fetch_decode_execute_loop_satisfies_the_specification S_fetch_decode_execute_loop).
  rewrite -> H_fetch_KO.
  reflexivity.
Qed.

  (* ********** *)

Definition specification_of_compile_aux (compile_aux : arithmetic_expression -> list byte_code_instruction) :=
  (forall n : nat,
     compile_aux (Literal n) = PUSH n :: nil)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile_aux (Plus ae1 ae2) = (compile_aux ae1) ++ (compile_aux ae2) ++ (ADD :: nil))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile_aux (Minus ae1 ae2) = (compile_aux ae1) ++ (compile_aux ae2) ++ (SUB :: nil)).

(* Task 6:
   prove that the definition above specifies a unique function,
   implement this function using list concatenation, i.e., ++,
   and verify that your function satisfies the specification.
 *)
Theorem there_is_at_most_one_compile_aux:
  forall f g : arithmetic_expression -> list byte_code_instruction,
    specification_of_compile_aux f ->
    specification_of_compile_aux g ->
    forall (ae : arithmetic_expression),
      f ae = g ae.
Proof.
  intros f g.
  intros [S_f_Literal [S_f_Plus S_f_Minus]] [S_g_Literal [S_g_Plus S_g_Minus ]].
  intro ae.
  induction ae as [n | ae1 IHae1 ae2 IHae2 | ae1 IHae1 ae2 IHae2].

  rewrite -> S_f_Literal.
  rewrite -> S_g_Literal.
  reflexivity.

  rewrite -> S_f_Plus.
  rewrite -> S_g_Plus.
  rewrite -> IHae1.
  rewrite -> IHae2.
  reflexivity.

  rewrite -> S_f_Minus.
  rewrite -> S_g_Minus.
  rewrite -> IHae1.
  rewrite -> IHae2.
  reflexivity.
Qed.

Fixpoint compile_aux (ae : arithmetic_expression) : list byte_code_instruction :=
  match ae with
  | Literal n =>
    PUSH n :: nil
  | Plus ae1 ae2 =>
    (compile_aux ae1) ++ (compile_aux ae2) ++ (ADD :: nil)
  | Minus ae1 ae2 =>
    (compile_aux ae1) ++ (compile_aux ae2) ++ (SUB :: nil)
  end.

Lemma unfold_compile_aux_Literal :
  forall n : nat,
    compile_aux (Literal n) = PUSH n :: nil.
Proof.
  unfold_tactic compile_aux.
Qed.

Lemma unfold_compile_aux_Plus :
  forall ae1 ae2 : arithmetic_expression,
    compile_aux (Plus ae1 ae2) = (compile_aux ae1) ++ (compile_aux ae2) ++ (ADD :: nil).
Proof.
  unfold_tactic compile_aux.
Qed.

Lemma unfold_compile_aux_Minus :
  forall ae1 ae2 : arithmetic_expression,
    compile_aux (Minus ae1 ae2) = (compile_aux ae1) ++ (compile_aux ae2) ++ (SUB :: nil).
Proof.
  unfold_tactic compile_aux.
Qed.

Theorem compile_aux_satisfies_the_specification_of_compile_aux :
  specification_of_compile_aux compile_aux.
Proof.
  unfold specification_of_compile_aux.
  split.
    intro n.
    rewrite -> unfold_compile_aux_Literal.
    reflexivity.
  split.
  intros ae1 ae2.
  rewrite -> unfold_compile_aux_Plus.
  reflexivity.
  intros ae1 ae2.
  rewrite -> unfold_compile_aux_Minus.
  reflexivity.
Qed.

Definition specification_of_compile (compile : source_program -> target_program) :=
  forall compile_aux : arithmetic_expression -> list byte_code_instruction,
    specification_of_compile_aux compile_aux ->
    forall ae : arithmetic_expression,
      compile (Source_program ae) = Target_program (compile_aux ae).

(* Task 7:
   prove that the definition above specifies a unique function,
   implement this function,
   and verify that your function satisfies the specification.
 *)

Theorem there_is_at_most_one_compile:
  forall f g : source_program -> target_program,
    specification_of_compile f ->
    specification_of_compile g ->
    forall (sp : source_program),
      f sp = g sp.
Proof.
  intros f g.
  unfold specification_of_compile.
  intros S_f S_g sp.
  case sp as [ae].
  rewrite -> (S_f compile_aux compile_aux_satisfies_the_specification_of_compile_aux).
  rewrite -> (S_g compile_aux compile_aux_satisfies_the_specification_of_compile_aux).
  reflexivity.
Qed.

Fixpoint compile (sp : source_program) : target_program :=
  match sp with
  | Source_program ae =>
    Target_program (compile_aux ae)
  end.

Theorem compile_satisfies_the_specification_of_compile :
  specification_of_compile compile.
Proof.
  unfold specification_of_compile.
  intros compile_aux S_compile_aux ae.
  unfold compile.
  rewrite -> (there_is_at_most_one_compile_aux Top.compile_aux compile_aux compile_aux_satisfies_the_specification_of_compile_aux S_compile_aux).
  reflexivity.
Qed.

(* Task 8:
   implement an alternative compiler
   using an auxiliary function with an accumulator
   and that does not use ++ but :: instead,
   and prove that it satisfies the specification.
*)

(* ********** *)

(* Task 9 (the capstone):
   Prove that interpreting an arithmetic expression gives the same result
   as first compiling it and then executing the compiled program.
 *)

(* Lemma new_and_useful :
  forall i j : nat,
    Some i = Some j -> i = j.
Proof.
  intros i j H_Some.
  injection H_Some as H_i_j.  (* <--[new and useful]-- *)
  exact H_i_j.
Qed.*)

Lemma Expressible_n1_n2 :
  forall n1 n2 : nat,
    Expressible_nat n1 = Expressible_nat n2
    ->
    n1 = n2.
Proof.
  intros n1 n2 H_Expressible_nat.
  injection H_Expressible_nat as H_i_j.
  exact H_i_j.
Qed.

Theorem the_commutative_diagram :
  forall sp : source_program,
    interpret sp = run (compile sp).
Proof.
  intro sp.
  case sp as [ae].
  unfold interpret.
  unfold compile.
  induction ae as [ n | ae1 IHae1 ae2 IHae2 | ae1 IHae1 ae2 IHae2 ].

  rewrite -> unfold_evaluate_Literal.
  rewrite -> unfold_compile_aux_Literal.
  unfold run.
  rewrite -> unfold_fetch_decode_execute_loop_bcis.
  unfold decode_execute.
  rewrite -> unfold_fetch_decode_execute_loop_nil.
  reflexivity.

  rewrite -> unfold_evaluate_Plus.
  case (evaluate ae1) as [n1 | s1] eqn : H_eval_ae1.
  case (evaluate ae2) as [n2 | s2] eqn : H_eval_ae2.
Abort.

  (* ********** *)

(* Task 10 (if there is time):

   a. Write a Magritte interpreter for the source language
      that does not operate on natural numbers
      but on syntactic representations of natural numbers.

   b. Write a Magritte interpreter for the target language
      that does not operate on natural numbers
      but on syntactic representations of natural numbers.

   c. Prove that interpreting an arithmetic expression with the Magritte source interpreter
      gives the same result as first compiling it and then executing the compiled program
      with the Magritte target interpreter over an empty data stack.

   d. Prove that the Magritte target interpreter is (essentially)
      a left inverse of the compiler, i.e., it is a decompiler.
*)

(* ********** *)

(* Byte-code verification:
   the following verifier symbolically executes a byte-code program
   to check whether no underflow occurs during execution
   and whether when the program completes,
   there is one and one only natural number on top of the stack.
   The second argument of verify_aux is a natural number
   that represents the size of the stack.
*)

Fixpoint verify_aux (bcis : list byte_code_instruction) (n : nat) : option nat :=
  match bcis with
    | nil =>
      Some n
    | bci :: bcis' =>
      match bci with
        | PUSH _ =>
          verify_aux bcis' (S n)
        | _ =>
          match n with
            | S (S n') =>
              verify_aux bcis' (S n')
            | _ =>
              None
          end
      end
  end.

Definition verify (p : target_program) : bool :=
  match p with
  | Target_program bcis =>
    match verify_aux bcis 0 with
    | Some n =>
      match n with
      | 1 =>
        true
      | _ =>
        false
      end
    | _ =>
      false
    end
  end.

(* Task 11:
   Prove that the compiler emits code
   that is accepted by the verifier.
*)

(*
Theorem the_compiler_emits_well_behaved_code :
  forall ae : arithmetic_expression,
    verify (compile ae) = true.
Proof.
Abort.
*)

(* What are the consequences of this theorem? *)

(* ********** *)

(* end of week-15_a-commutative-diagram.v *)


From Coq Require Import Arith Psatz Bool String List Program.Equality Nat.
Add LoadPath "./" as DanTrick.
Require Import DanTrick.StackLanguage.

Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.

(* Function for evaluation, with fuel because of while loops *)

Fixpoint popping_helper (stk: stack) (to_pop: nat): option stack :=
  match to_pop with
  | 0 => Some stk
  | S to_pop' =>
      match stk with
      | nil => None
      | _ :: stk' => popping_helper stk' to_pop'
      end
  end.

Fixpoint aexp_stack_eval (a: aexp_stack) (fuel: nat) (fenv: fun_env_stk) (stk: stack): option (stack * nat) :=
  match fuel with
  | 0 =>
      let big_res :=
        (match a with
         | Const_Stk n => Some (stk, n)
         | Var_Stk k =>
             match nth_error stk (k - 1) with
             | Some val =>
                 Some (stk, val)
             | None => None
             end
         | _ => None
         end) in
      big_res
  | S fuel' =>
      match a with
      | Const_Stk n => Some (stk, n)
      | Var_Stk k =>
          match nth_error stk (k - 1) with
          | Some val =>
              Some (stk, val)
          | None => None
          end
      | Plus_Stk a1 a2 =>
          match (aexp_stack_eval a1 fuel' fenv stk) with
          | Some stk_and_num =>
              match stk_and_num with
              | (stk1, n1) =>
                  match (aexp_stack_eval a2 fuel' fenv stk1) with
                  | Some stk_and_num2 =>
                      match stk_and_num2 with
                      | (stk2, n2) =>
                          Some (stk2, n1 + n2)
                      end
                  | None => None
                  end
              end
          | None => None
          end
      | Minus_Stk a1 a2 =>
          match (aexp_stack_eval a1 fuel' fenv stk) with
          | Some stk_and_num =>
              match stk_and_num with
              | (stk1, n1) =>
                  match (aexp_stack_eval a2 fuel' fenv stk1) with
                  | Some stk_and_num2 =>
                      match stk_and_num2 with
                      | (stk2, n2) =>
                          Some (stk2, n1 - n2)
                      end
                  | None => None
                  end
              end
          | None => None
          end
      | App_Stk f aexps =>
          let func := fenv f in
          let body := (Body func) in
          let ret_expr := (Return_expr func) in
          let ret_pop := (Return_pop func) in
          let num_args := (Args func) in
          if Nat.eqb num_args (List.length aexps) then
            match args_stack_eval aexps fuel' fenv stk with
            | Some stklistnat =>
                let (stk', args) := stklistnat in
                match imp_stack_eval body fuel' fenv (args ++ stk') with
                | Some stk'' =>
                    match aexp_stack_eval ret_expr fuel' fenv stk'' with
                    | Some stknat =>
                        let (stk''', ret_val) := stknat in
                        match popping_helper stk''' (num_args + ret_pop) with
                        | Some stk4 => Some (stk4, ret_val)
                        | None => None
                        end
                    | None => None
                    end
                | None => None
                end
            | None => None
            end
          else None
      end
  end
with args_stack_eval (aexps: list aexp_stack) (fuel: nat) (fenv: fun_env_stk) (stk: stack): option (stack * (list nat)) :=
       match fuel with
       | 0 => None
       | S fuel' =>
           match aexps with
           | a :: aexps' =>
               match aexp_stack_eval a fuel' fenv stk with
               | Some stknat =>
                   let (stk', n) := stknat in
                   match (args_stack_eval aexps' fuel' fenv stk') with
                   | Some stklistnat =>
                       let (stk'', ns) := stklistnat in
                       Some (stk'', n :: ns)
                   | None => None
                   end
               | None => None
               end
           | nil => Some (stk, nil)
           end
       end
with bexp_stack_eval (b: bexp_stack) (fuel: nat) (fenv: fun_env_stk) (stk: stack): option (stack * bool) :=
       match fuel with
       | 0 =>
           let big_res :=
             (match b with
              | True_Stk => Some (stk, true)
              | False_Stk => Some (stk, false)
              | _ => None
              end) in
           big_res
       | S fuel' =>
           match b with
           | True_Stk => Some (stk, true)
           | False_Stk => Some (stk, false)
           | Neg_Stk b =>
               match bexp_stack_eval b fuel' fenv stk with
               | Some stkbool =>
                   match stkbool with
                   | (stk', bval) =>
                       Some (stk', negb bval)
                   end
               | None => None
               end
           | And_Stk b1 b2 =>
               match bexp_stack_eval b1 fuel' fenv stk with
               | Some stkbool1 =>
                   let (stk1, bval1) := stkbool1 in
                   match bexp_stack_eval b2 fuel' fenv stk1 with
                   | Some stkbool2 =>
                       let (stk2, bval2) := stkbool2 in
                       Some (stk2, andb bval1 bval2)
                   | None => None
                   end
               | None => None
               end
           | Or_Stk b1 b2 =>
               match bexp_stack_eval b1 fuel' fenv stk with
               | Some stkbool1 =>
                   match stkbool1 with
                   | (stk1, bval1) =>
                       match bexp_stack_eval b2 fuel' fenv stk1 with
                       | Some stkbool2 =>
                           match stkbool2 with
                           | (stk2, bval2) => Some (stk2, orb bval1 bval2)
                           end
                       | None => None
                       end
                   end
               | None => None
               end
            | Leq_Stk a1 a2 =>
               match aexp_stack_eval a1 fuel' fenv stk with
               | Some stknat1 =>
                   match stknat1 with
                   | (stk1, val1) =>
                       match aexp_stack_eval a2 fuel' fenv stk1 with
                       | Some stknat2 =>
                           match stknat2 with
                           | (stk2, val2) => Some (stk2, Nat.leb val1 val2)
                           end
                       | None => None
                       end
                   end
               | None => None
               end
           | Eq_Stk a1 a2 =>
               match aexp_stack_eval a1 fuel' fenv stk with
               | Some stknat1 =>
                   match stknat1 with
                   | (stk1, val1) =>
                       match aexp_stack_eval a2 fuel' fenv stk1 with
                       | Some stknat2 =>
                           match stknat2 with
                           | (stk2, val2) => Some (stk2, Nat.eqb val1 val2)
                           end
                       | None => None
                       end
                   end
               | None => None
               end
           end
       end
with imp_stack_eval (i: imp_stack) (fuel: nat) (fenv: fun_env_stk) (stk: stack) : option stack :=
       match fuel with
       | 0 =>
           let bigres :=
             match i with
             | Skip_Stk => Some stk
             | Push_Stk => Some (0 :: stk)
             | Pop_Stk =>
                 match stk with
                 | v :: stk' => Some stk'
                 | nil => None
                 end
             | _ => None
             end in
           bigres
       | S fuel' =>
           match i with
           | Skip_Stk => Some stk
           | Assign_Stk k a =>
               match aexp_stack_eval a fuel' fenv stk with
               | Some stknat =>
                   let (stk', n) := stknat in
                   update_stack stk' k n
               | None => None
               end
           | Push_Stk => Some (0 :: stk)
           | Pop_Stk =>
               match stk with
               | v :: stk' => Some stk'
               | nil => None
               end
           | Seq_Stk i1 i2 =>
               match imp_stack_eval i1 fuel' fenv stk with
               | Some stk1 =>
                   imp_stack_eval i2 fuel' fenv stk1
               | None => None
               end
           | If_Stk b i1 i2 =>
               match bexp_stack_eval b fuel' fenv stk with
               | Some stkbool =>
                   let (stk', b') := stkbool in
                   imp_stack_eval (if b' then i1 else i2) fuel' fenv stk'
               | None => None
               end
           | While_Stk b i =>
               match bexp_stack_eval b fuel' fenv stk with
               | Some stkbool =>
                   match stkbool with
                   | (stk', b') =>
                       if b' then
                         imp_stack_eval (Seq_Stk i (While_Stk b i)) fuel' fenv stk'
                       else Some stk'
                   end
               | None => None
               end
           end
       end.

Definition update {T: Type} (x: ident) (v: T) (s: store T): store T :=
fun y => if string_dec x y then v else s y.

Fixpoint construct_fenv_stk lst (f: fun_env_stk) : fun_env_stk :=
match lst with
| nil => f
| foo::foos => construct_fenv_stk foos (update ((foo).(Name)) foo f)
end.

Definition eval_fuel_stack prog fuel stack :=
    match prog with
    |Prog_Stk funs exp =>
    imp_stack_eval exp fuel (construct_fenv_stk funs init_fenv_stk) stack
end.