semantics-2023/theories/type_systems/stlc/auto_step.v

From stdpp Require Import base relations tactics.
From iris Require Import prelude.
From semantics.lib Require Import sets maps.
From semantics.ts.stlc Require Import lang notation.

Fixpoint eval_step (e: expr): option expr :=
  match e with
    | Var _ => None
    | Lam x body => None
    | LitInt n => None
    | App lhs rhs => match to_val rhs, to_val lhs with
      | None, _ => fmap (λ (rhs': expr), App lhs rhs') (eval_step rhs)
      | Some _, None => fmap (λ (lhs': expr), App lhs' rhs) (eval_step lhs)
      | Some rhs', Some (LamV name body) => Some (subst' name rhs' body)
      | _, _ => None
      end
    | Plus lhs rhs => match to_val rhs, to_val lhs with
      | None, _ => fmap (λ (rhs': expr), Plus lhs rhs') (eval_step rhs)
      | Some _, None => fmap (λ (lhs': expr), Plus lhs' rhs) (eval_step lhs)
      | Some (LitIntV rhs'), Some (LitIntV lhs') => Some (LitInt (lhs' + rhs'))
      | _, _ => None
      end
  end.

Theorem step_eval_step (e e': expr): step e e' → eval_step e = Some e'.
Proof.
  intro H_step.
  induction H_step; unfold eval_step; fold eval_step.
  - unfold to_val.
    destruct e'; try (unfold is_val in H; exfalso; exact H).
    reflexivity.
    reflexivity.
  - destruct e1; try (unfold eval_step in IHH_step; discriminate IHH_step).
    + unfold to_val.
      destruct e2; try (unfold is_val in H; exfalso; exact H).
      all: rewrite IHH_step; reflexivity.
    + unfold to_val.
      destruct e2; try (unfold is_val in H; exfalso; exact H).
      all: rewrite IHH_step; reflexivity.
  - destruct (to_val e2) eqn:H_to_val.
    {
      apply of_to_val in H_to_val.
      assert (is_val (of_val v)); try exact (is_val_of_val v).
      apply val_no_step in H_step.
      exfalso; exact H_step.
      rewrite <-H_to_val.
      assumption.
    }
    rewrite IHH_step.
    reflexivity.
  - unfold to_val.
    rewrite H.
    reflexivity.
  - destruct e2; try (unfold is_val in H; exfalso; exact H).
    unfold to_val.

    destruct H_step; try (rewrite IHH_step; reflexivity).
    unfold to_val.
    rewrite IHH_step; simpl.
    destruct e1.
    + inversion H_step.
    + val_no_step.
    + reflexivity.
    + val_no_step.
    + reflexivity.
  - destruct (to_val e2) eqn:H_to_val.
    {
      apply of_to_val in H_to_val.
      assert (is_val (of_val v)); try exact (is_val_of_val v).
      apply val_no_step in H_step.
      exfalso; exact H_step.
      rewrite <-H_to_val.
      assumption.
    }
    rewrite IHH_step.
    reflexivity.
Qed.

Theorem eval_step_step (e e': expr): eval_step e = Some e' → step e e'.
Proof.
  revert e'.
  induction e; intros e' H_eq.
  all: try (unfold eval_step in H_eq; discriminate H_eq).
  - unfold eval_step in H_eq; fold eval_step in H_eq.

    induction (eval_step e2).
    + remember (IHe2 a (eq_refl _)) as H_appr.
      unfold eval_step in H_eq; fold eval_step in H_eq.
      destruct (to_val e2) eqn:H_to_val.
      clear HeqH_appr.
      {
        apply of_to_val in H_to_val.
        assert (is_val (of_val v)); try exact (is_val_of_val v).
        apply val_no_step in H_appr.
        exfalso; exact H_appr.
        rewrite <-H_to_val.
        assumption.
      }
      simpl in H_eq.
      injection H_eq; intro H_eq'.
      rewrite <-H_eq'.
      apply StepAppR.
      assumption.
    + destruct (to_val e2) eqn:H_e2_to_val.
      all: destruct (to_val e1) eqn:H_e1_to_val.
      all: try (simpl in H_eq; discriminate H_eq).
      all: try remember (of_to_val _ _ H_e1_to_val) as H_e1_val.
      all: try remember (of_to_val _ _ H_e2_to_val) as H_e2_val.
      {
        subst.
        induction v0.
        discriminate H_eq.
        injection H_eq; intro H_eq'; subst.
        apply StepBeta.
        eauto.
      }
      induction (eval_step e1).
      {
        simpl in H_eq.
        injection H_eq; intro H_eq'.
        rewrite <-H_eq'.
        eapply StepAppL.
        rewrite <-H_e2_val.
        apply is_val_of_val.
        apply (IHe1 a (eq_refl _)).
      }
      simpl in H_eq; discriminate H_eq.
  - unfold eval_step in H_eq; fold eval_step in H_eq.
    destruct (to_val e2) eqn:H_e2_to_val.
    all: destruct (to_val e1) eqn:H_e1_to_val.
    all: try remember (of_to_val _ _ H_e1_to_val) as H_e1_val.
    all: try remember (of_to_val _ _ H_e2_to_val) as H_e2_val.
    + induction v; induction v0; try discriminate H_eq.
      rewrite <-H_e2_val.
      rewrite <-H_e1_val.
      unfold of_val.
      injection H_eq; intro H_eq'.
      rewrite <-H_eq'.
      eauto.
    + induction v; try discriminate H_eq.
      all: (
        unfold of_val in H_e2_val;
        rewrite <-H_e2_val;
        induction (eval_step e1); try (simpl in H_eq; discriminate H_eq);
        simpl in H_eq;
        injection H_eq; intro H_eq';
        subst;
        eapply StepPlusL;
        unfold is_val; intuition;
        exact (IHe1 a (eq_refl _))
      ).
    + induction (eval_step e2); try (simpl in H_eq; discriminate H_eq).
      simpl in H_eq; injection H_eq; intro H_eq'.
      subst.
      eapply StepPlusR.
      exact (IHe2 a (eq_refl _)).
    + induction (eval_step e2); try (simpl in H_eq; discriminate H_eq).
      simpl in H_eq; injection H_eq; intro H_eq'.
      subst.
      eapply StepPlusR.
      exact (IHe2 a (eq_refl _)).
Qed.


Ltac auto_subst :=
  (rewrite subst_closed_nil; last assumption) ||
  (unfold subst'; unfold subst; simpl; fold subst).

Ltac auto_step := (simpl;
  repeat (eapply rtc_l;
    first apply eval_step_step;
    first simpl;
    first reflexivity;
    try (reflexivity; done)
  );
  reflexivity
).