Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.

Section ContextProperty.

Context {L: Language}
        {minL: MinimunLanguage L}
        {Gamma: ProofTheory L}
        {fwSC: FiniteWitnessedSequentCalculus L Gamma}.

Lemma can_derive_finite_witnessed: forall x,
  finite_witnessed (can_derive x).
Proof.
  intros; hnf; intros.
  apply derivable_finite_witnessed; auto.
Qed.

Lemma cannot_derive_finite_captured: forall x,
  finite_captured (cannot_derive x).
Proof.
  intros.
  apply (not_finite_witnessed_finite_captured _ (can_derive_finite_witnessed x)).
Qed.

End ContextProperty.


Require Import
        MathClasses.interfaces.abstract_algebra
        MathClasses.theory.nat_pow
        MathClasses.theory.int_pow
        CoRN.algebra.RSetoid
        CoRN.stdlib_omissions.Q
        CoRN.metric2.Metric
        CoRN.metric2.UniformContinuity
        CoRN.reals.fast.CRarctan_small
        CoRN.reals.fast.CRarctan
        CoRN.reals.fast.CRstreams
        CoRN.reals.fast.CRAlternatingSum
        CoRN.reals.faster.ARAlternatingSum
        CoRN.reals.faster.ARsin.
Require Export
  CoRN.reals.faster.ARArith.

Section ARarctan_small.
Context `{AppRationals AQ}
        {num den : AQ} (Pnd : -den < num < den) (dpos : 0 < den).

(*
Split the stream
  (-1)^i a^(2i+1) / (2i+1)
up into the streams
  (-1)^i a^(2i+1)    and    (2i+1)
because we do not have exact division
*)
Definition ARarctanStream (px : positive*(AQ*AQ)) : AQ*AQ
  := (- fst (snd px) * num * num * ZtoAQ (Zpos (Pos.pred (fst px)~0)),
      snd (snd px) * den * den * ZtoAQ (Zpos (fst px)~1)).

Lemma arctanStream_pos : ∀ x : positive * (AQ * AQ),
    0 < snd (snd x) → 0 < snd (ARarctanStream x).
Proof.
  assert (0 = ZtoAQ 0) as zero_int.
  { destruct H4. destruct aq_ints_mor, semiringmor_plus_mor.
    rewrite preserves_mon_unit. reflexivity. }
  intros. destruct x; simpl.
  simpl in H5.
  apply AQmult_lt_0_compat.
  apply AQmult_lt_0_compat.
  apply AQmult_lt_0_compat.
  exact H5. exact dpos. exact dpos.
  rewrite zero_int.
  apply (strictly_order_preserving (cast Z AQ)).
  reflexivity.
Qed.

Lemma arctanStream_correct : ∀ p : positive,
    Str_pth _ (arctanStream (AQtoQ num / AQtoQ den))
            p (1%positive, AQtoQ num / AQtoQ den)
    == let (_, r) := iterate _ (fS ARarctanStream) p (1%positive, (num, den)) in
       AQtoQ (fst r) / AQtoQ (snd r).
Proof.
  assert (forall n:Z, AQtoQ (ZtoAQ n) == (n#1)).
  { intro n. destruct n as [|n|n].
    pose proof (rings.preserves_0 (f:=cast Z AQ)). rewrite H5. clear H5.
    rewrite rings.preserves_0. reflexivity.
    apply ZtoQ. change (Z.neg n) with (-Z.pos n)%Z.
    pose proof (rings.preserves_negate (f:=cast Z AQ)).
    rewrite H5. clear H5. rewrite rings.preserves_negate.
    rewrite ZtoQ. reflexivity. }
  apply Pos.peano_ind.
  - unfold Str_pth, iterate, arctanStream, snd.
    rewrite Qred_correct. simpl.
    do 6 rewrite rings.preserves_mult.
    rewrite rings.preserves_negate.
    rewrite H5, H5.
    unfold dec_recip, stdlib_rationals.Q_recip.
    unfold mult, stdlib_rationals.Q_mult.
    unfold negate, stdlib_rationals.Q_opp.
    rewrite Qmult_1_r.
    change (1#3) with (/3)%Q.
    unfold Qdiv.
    do 3 rewrite Qinv_mult_distr.
    do 3 rewrite Qmult_assoc.
    apply Qmult_comp. 2: reflexivity.
    do 2 rewrite Qmult_assoc.
    apply Qmult_comp. 2: reflexivity.
    ring.
  - intros p IHp. unfold Str_pth. unfold Str_pth in IHp.
    rewrite iterate_succ, iterate_succ.
    pose proof (arctanStream_fst (AQtoQ num / AQtoQ den) p) as H7.
    unfold dec_recip, stdlib_rationals.Q_recip.
    unfold dec_recip, stdlib_rationals.Q_recip in IHp.
    unfold mult, stdlib_rationals.Q_mult.
    unfold mult, stdlib_rationals.Q_mult in IHp.
    unfold Qdiv in H7. unfold Qdiv.
    unfold Qdiv in IHp.
    unfold Q_as_MetricSpace, msp_car.
    unfold Q_as_MetricSpace, msp_car in IHp.
    destruct (iterate _ (arctanStream (AQtoQ num * / AQtoQ den)%Q) p
            (1%positive, (AQtoQ num * / AQtoQ den)%Q)).
    simpl in H7. simpl in IHp. subst p0.
    unfold arctanStream, snd, fst. rewrite Qred_correct.
    rewrite IHp. clear IHp.
    pose proof (fS_fst ARarctanStream p (num, den)) as H6.
    destruct (iterate _ (fS ARarctanStream) p (1%positive, (num, den))) as [p0 p1].
    simpl in H6. subst p0. unfold ARarctanStream, fS.
    simpl (fst (Pos.succ p, p1)).
    simpl (snd (Pos.succ p, p1)).
    replace (Pos.pred (Pos.succ p)~0) with (p~1)%positive.
    do 6 rewrite rings.preserves_mult.
    rewrite rings.preserves_negate.
    unfold mult, stdlib_rationals.Q_mult.
    unfold negate, stdlib_rationals.Q_opp.
    rewrite ZtoQ, ZtoQ.
    do 3 rewrite Qinv_mult_distr.
    setoid_replace (Z.pos p~1 # 2 + p~1)%Q
      with ((Z.pos p~1 # 1) * / (Z.pos (Pos.succ p)~1 # 1))%Q.
    ring.
    unfold Qinv, Qeq, Qmult, Qnum, Qden.
    rewrite Pos.mul_1_l, Z.mul_1_r.
    replace (2 + p~1)%positive with ((Pos.succ p)~1)%positive.
    reflexivity.
    change (p~1)%positive with (2*p+1)%positive.
    change ((Pos.succ p)~1)%positive with (2*Pos.succ p+1)%positive.
    rewrite Pplus_one_succ_l.
    rewrite Pos.mul_add_distr_l. reflexivity.
    rewrite Pplus_one_succ_l.
    change (p~1)%positive with (2*p+1)%positive.
    change ((1+p)~0)%positive with (2*(1+p))%positive.
    rewrite Pos.mul_add_distr_l.
    rewrite Pos.pred_sub.
    rewrite (Pos.add_comm (2*1)).
    rewrite <- Pos.add_sub_assoc. reflexivity. reflexivity.
Qed.

Lemma AQarctan_small_Qprf : -1 < AQtoQ num / AQtoQ den < 1.
Proof.
  split.
  - apply Qlt_shift_div_l.
    pose proof (rings.preserves_0 (f:=cast AQ Q)).
    rewrite <- H5.
    apply (strictly_order_preserving (cast AQ Q)), dpos.
    setoid_replace (-1 * AQtoQ den) with (-AQtoQ den) by reflexivity.
    rewrite <- rings.preserves_negate.
    apply (strictly_order_preserving (cast AQ Q)), Pnd.
  - apply Qlt_shift_div_r.
    pose proof (rings.preserves_0 (f:=cast AQ Q)).
    rewrite <- H5.
    apply (strictly_order_preserving (cast AQ Q)), dpos.
    rewrite Qmult_1_l.
    apply (strictly_order_preserving (cast AQ Q)), Pnd.
Qed.

Definition AQarctan_small : msp_car AR
  := CRtoAR (inject_Q_CR (AQtoQ num / AQtoQ den))
     + AltSeries ARarctanStream arctanStream_pos
                 positive (arctanStream (AQtoQ num / AQtoQ den))
                 (num,den) (xH,AQtoQ num / AQtoQ den) arctanStream_correct _
                 (arctanStream_alt (widen_interval AQarctan_small_Qprf))
                 dpos (arctanStream_zl (widen_interval AQarctan_small_Qprf)).

Lemma AQarctan_small_correct :
  'AQarctan_small = rational_arctan_small (widen_interval AQarctan_small_Qprf).
Proof.
  unfold AQarctan_small, rational_arctan_small.
  rewrite ARtoCR_preserves_plus.
  apply ucFun2_wd.
  pose proof CRAR_id.
  unfold cast. unfold cast in H5.
  rewrite H5. reflexivity.
  apply AltSeries_correct.
Qed.

End ARarctan_small.


From StructTact Require Import StructTactics.
From Coq Require Import FunctionalExtensionality.

Definition update {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) st h (v : B) :=
  fun nm => if A_eq_dec nm h then v else st nm.

Section update.
  Variables A B : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma update_diff :
    forall (sigma : A -> B) x v y,
      x <> y ->
      update A_eq_dec sigma x v y = sigma y.
  Proof using.
    unfold update.
    intros.
    break_if; congruence.
  Qed.

  Lemma update_nop :
    forall (sigma : A -> B) x y,
      update A_eq_dec sigma x (sigma x) y = sigma y.
  Proof using.
    unfold update.
    intros. break_if; congruence.
  Qed.

  Lemma update_eq :
    forall (sigma : A -> B) x y v,
      x = y ->
      update A_eq_dec sigma x v y = v.
  Proof using.
    intros. subst.
    unfold update.
    break_if; congruence.
  Qed.

  Lemma update_same :
    forall (sigma : A -> B) x v,
      update A_eq_dec sigma x v x = v.
  Proof using.
    intros.
    rewrite update_eq; auto.
  Qed.

  Lemma update_nop_ext :
    forall (sigma : A -> B) h,
      update A_eq_dec sigma h (sigma h) = sigma.
  Proof using.
    intros.
    apply functional_extensionality.
    intros.
    apply update_nop.
  Qed.

  Lemma update_nop_ext' :
    forall (sigma : A -> B) y v,
      sigma y = v ->
      update A_eq_dec sigma y v = sigma.
  Proof using.
    intros.
    subst.
    apply update_nop_ext.
  Qed.

  Lemma update_overwrite :
    forall (sigma : A -> B) h st st',
      update A_eq_dec (update A_eq_dec sigma h st) h st' = update A_eq_dec sigma h st'.
  Proof using.
    intros.
    apply functional_extensionality.
    intros. destruct (A_eq_dec h x).
    - repeat rewrite update_eq; auto.
    - repeat rewrite update_diff; auto.
  Qed.
End update.

Lemma update_fun_comm :
  forall A B C A_eq_dec (f : B -> C) (st : A -> B) y v x,
    f (update A_eq_dec st y v x) = update A_eq_dec (fun x => f (st x)) y (f v) x.
Proof.
  intros.
  destruct (A_eq_dec x y); subst;
    repeat first [rewrite update_diff by congruence |
                  rewrite update_eq  by auto ]; auto.
Qed.

Ltac update_destruct_goal :=
  match goal with
    | [ |- context [ update ?eq_dec _ ?y _ ?x ] ] => destruct (eq_dec y x)
  end.

Ltac update_destruct_hyp :=
  match goal with
    | [ _ : context [ update ?eq_dec _ ?y _ ?x ] |- _ ] => destruct (eq_dec y x)
  end.

Ltac update_destruct := update_destruct_goal || update_destruct_hyp.

Ltac rewrite_update' H :=
  first [rewrite update_diff in H by congruence |
         rewrite update_eq in H by auto ].

Ltac rewrite_update :=
  repeat match goal with
           | [ H : context [ update _ _ _ _ _ ] |- _ ] =>
             rewrite_update' H; repeat rewrite_update' H
           | [ |- _ ] => repeat (try rewrite update_diff by congruence;
                                 try rewrite update_eq by auto)
         end.

Ltac destruct_update :=
  repeat (update_destruct; subst; rewrite_update).

Ltac destruct_update_hyp :=
  repeat ((update_destruct_hyp || update_destruct_goal); subst; rewrite_update).

Ltac update_destruct_simplify :=
  update_destruct; subst; rewrite_update; simpl in *.

Ltac update_destruct_simplify_hyp :=
  update_destruct_hyp || update_destruct_goal; subst; rewrite_update; simpl in *.

Ltac update_destruct_max_simplify :=
  update_destruct; subst_max; rewrite_update; simpl in *.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import color.
Require Import chromogram.
Require Import gtree.
Require Import dyck.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* Creation of the initial (full) chromogram tree. We reuse pairs to create  *)
(* the 2D table of trees indexed by (depth, bit0).                           *)

Section InitialGtree.

Lemma gtreeDataP : comparable gtree.
Proof. rewrite /comparable; decide equality. Qed.
Lemma gtreePairDataP : comparable gtree_pair.
Proof. rewrite /comparable; decide equality; apply: gtreeDataP. Qed.
Definition gtreePairData : dataSet := Eval compute in compareData gtreePairDataP.
Canonical Structure gtreePairData.

Definition gtree_table : Set := seq gtreePairData.

Definition init_gtree_h1 : gtree_table :=
  seq3 (Gtree_pair Gtree_leaf01 Gtree_leaf0)
       (Gtree_pair Gtree_leaf13 Gtree_leaf12)
       (Gtree_pair Gtree_leaf23 Gtree_leaf23).

Definition gtree_merge_pairs (pt0 pt1 pt2 : gtree_pair) :=
  let (t0, t0') := pt0 in
  let (t1, t1') := pt1 in
  let (t2, t3) := pt2 in
  Gtree_pair (Gtree_node t0 t1' t2 t3) (Gtree_node t0' t1 t3 t2).

Fixpoint gtree_merge_line (pt0 pt1 pt2 : gtree_pair) (lpt : gtree_table) (d : nat)
               {struct d} : gtree_table :=
  let rest :=
    match d, lpt return gtree_table with
    | 0, _ => seq0
    | S d', seq0 =>
        seq2 (gtree_merge_pairs empty_gtree_pair pt0 pt1)
             (gtree_merge_pairs empty_gtree_pair empty_gtree_pair pt0)
    | S d', Adds pt lpt' => gtree_merge_line pt pt0 pt1 lpt' d'
    end in
  Adds (gtree_merge_pairs pt0 pt1 pt2) rest.

Fixpoint gtree_init_table (d h' : nat) {struct h'} : gtree_table :=
  match h' with
  | 0 => init_gtree_h1
  | S h'' =>
      let tab := gtree_init_table (S d) h'' in
      if tab is Adds pt1 (Adds pt0 lpt) then
        gtree_merge_line pt0 pt1 empty_gtree_pair lpt d
      else tab
  end.

Definition gtree_init_tree h :=
  match h, gtree_init_table 0 (pred h) with
  | S _, Adds (Gtree_pair t _) _ => t
  | _, _ => Gtree_empty
  end.

Definition init_gtree_spec h w :=
  (size w =d h) && gram_balanced 0 false (cgram 0 false w).

Lemma match_count_balanced : forall h et,
  match_count (init_gtree_spec h) Bstack0 et =
    if (size et =d h) && negb (ctrace et Color0) then
      dyck (count_cbit1 (ctrace et))
    else 0.
Proof.
move=> h et; rewrite /init_gtree_spec /ctrace /dyck; pose sb : bitseq := seq0.
rewrite -[Bstack0]/(stack_of_bitseq sb) -{-4}[0]/(size sb) -(add0c (sumt et)).
have Hc1: cbit1 Color0 = odd (size sb) by done.
move Dsbs: (foldr addb false) => sbs.
have Hc0: cbit0 Color0 = addb false (sbs sb) by rewrite -Dsbs.
elim: et h {-4}Color0 sb false Hc0 Hc1.
  move=> [|h] c // [|b lb] b0 /=; first by rewrite -Dsbs /= addbF => <-; case c.
  by clear; case: {lb}(size lb) => /=; case: c => //; case b0.
move=> e et Hrec h c lb b0; rewrite add_last_adds /= addcA; case: h => [|h].
case De: e (match_count_0) => [|||] Em0 Enn /=; auto; rewrite Em0 /addn //=;
 case (stack_of_bitseq lb); auto.
move=> Hc0 Hc1; move: {Hrec}(Hrec h (e +c c)).
rewrite cbit0_addc cbit1_addc (addcC e c) {}Hc0 {}Hc1 -{sbs}Dsbs /=.
move: (add_last et (c +c e +c sumt et)) => cet; rewrite /setU1 eqdSS.
move: {c cet}(size et =d h) (cet Color0) (count_cbit1 cet) => b_h bc0 n23.
move=> Hrec; move: {Hrec}(Hrec (Adds (cbit0 e) lb) b0) (Hrec).
rewrite /eqd /= 2!addbA (addbC b0).
case De: e => [|||] /= Hrec0 Hrec; first
 [ by rewrite andbC
 | exact: Hrec
 | by rewrite {}Hrec0 //; case: lb Hrec => [|b lb''] /=;
     [ clear; case: {3}n23 => *; rewrite /= ?addn0
     | rewrite ?negb_elim 1?addbA -1?(addbC b); case: b => /=; move=> H;
        try rewrite {}H ?negb_elim //; case: (b_h && negb bc0) ] ].
Qed.

Fixpoint gtree_table_sub (tab : gtree_table) (n : nat) {struct tab}
                         : bool -> gtree :=
  match tab, n with
  | seq0, _ => fun _ => Gtree_empty
  | Adds pt _, O => gtree_pair_sub pt
  | Adds _ tab', S n' => gtree_table_sub tab' n'
  end.

Notation Local tsub := gtree_table_sub.

Lemma gtree_mem_init_tree : forall h w,
  gtree_mem (gtree_init_tree h) w = init_gtree_spec h w.
Proof.
move=> [|h] w; [by rewrite gtree_mem_empty; case w | simpl].
transitivity (gtree_mem (gtree_table_sub (gtree_init_table 0 h) 0 false) w).
  by case (gtree_init_table 0 h).
have:= leqnn 0; rewrite /init_gtree_spec; move: 0 {-2 3}0 false w => d.
apply (@proj2 ((if d is 0 then 0 else 1) < size (gtree_init_table d h))).
elim: h d => [|h Hrec] d /=.
  by split; [ case d | move=> [|[|[|d']]] [|] [|s [|s' w']] //; case s ].
  case: {Hrec}(Hrec (S d)); move: (gtree_init_table (S d) h).
move=> [|pt1 [|pt0 lpt]] // _ Hsub.
split; first by case: d {Hsub} => [|[|d]]; case: lpt.
move=> dw bw w Hd.
transitivity
  (gtree_mem (let elt := Seq empty_gtree_pair pt1 pt0 & lpt in
              Gtree_node (tsub elt (S (S dw)) bw) (tsub elt (S dw) (negb bw))
                         (tsub elt dw bw)         (tsub elt dw (negb bw)))
             w).
  elim: dw d Hd pt0 pt1 empty_gtree_pair lpt {Hsub}.
    move=> d Hd [t0 t0'] [t1 t1'] [t2 t3] lpt; rewrite /gtree_merge_line /=.
    by case d; case: bw => /=.
  move=> dw Hrec [|d] Hd // pt0 pt1 pt2 [|pt lpt]; last by apply: (Hrec d).
  case: dw {Hrec Hd} => [|dw]; first by case: pt0 pt1 bw => [t1 t1'] [t2 t3] [|].
  case: dw => [|dw]; first by case: pt0 bw => [t2 t3] [|].
  by case: w bw => [|[|||] w] [|]; rewrite /= ?gtree_mem_empty.
case: w => [|[|||] w] //=; first
 [ exact (Hsub (S dw) _ w Hd)
 | exact (Hsub _ _ w (leqW Hd))
 | case: dw Hd => [|dw] Hd;
    [ rewrite andbF; case bw; exact (gtree_mem_empty w)
    | exact (Hsub _ _ w (leqW (leqW Hd))) ] ].
Qed.

End InitialGtree.

Unset Implicit Arguments.


(** * Stlc: The Simply Typed Lambda-Calculus *)

(* $Date: 2012-07-25 16:43:16 -0400 (Wed, 25 Jul 2012) $ *)

Require Export Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core calculus
    embodying the key concept of _functional abstraction_, which shows
    up in pretty much every real-world programming language in some
    form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous
    chapter when formalizing this calculus (syntax, small-step
    semantics, typing rules) and its main properties (progress and
    preservation).  The new technical challenges (which will take some
    work to deal with) all arise from the mechanisms of _variable
    binding_ and _substitution_. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_ -- booleans,
    numbers, strings, etc.  The exact choice of base types doesn't
    matter -- the construction of the language and its theoretical
    properties work out pretty much the same -- so for the sake of
    brevity let's take just [Bool] for the moment.  At the end of the
    chapter we'll see how to add more base types, and in later
    chapters we'll enrich the pure STLC with other useful constructs
    like pairs, records, subtyping, and mutable state.

    Starting from the booleans, we add three things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out here in informal BNF notation -- we'll
    formalize it below).

*)

(** Informal concrete syntax:
<<
       t ::= x                       variable
           | \x:T.t1                 abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
>>
*)

(** The [\] symbol in a function abstraction [\x:T.t1] is often
    written as a greek "lambda" (hence the name of the calculus).  The
    variable [x] is called the _parameter_ to the function; the term
    [t1] is its _body_.  The annotation [:T] specifies the type of
    arguments that the function can be applied to.

    Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true].

      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (Note that, as in Coq, a two-argument function
        is really a one-argument function whose body is also a
        one-argument function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].
        Note that, as in Coq, application associates to the left --
        i.e., this expression is parsed as [((\x:Bool. \y:Bool. x)
        false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    Another point to note is that the STLC doesn't provide any
    primitive syntax for defining _named_ functions -- all functions
    are "anonymous."  We'll see in chapter [MoreStlc] that it is easy
    to add named functions to what we've got -- indeed, the
    fundamental naming and binding mechanisms are exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**
<<
      T ::= Bool
          | T1 -> T2
>>
    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool] (i.e. [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool]

      - [\f:Bool->Bool. f (f true)] has type [(Bool->Bool) -> Bool]

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)] has type [Bool]
*)

(* ###################################################################### *)
(** ** Syntax *)

Module STLC.

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

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif" ].

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here, to keep things simple. *)

(** Some examples... *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool)->(Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

(* ###################################################################### *)
(** ** Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin -- as
    always -- by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

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

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  (An [if]
    expression is never a value.)

    Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do.

    Third, for abstractions, we have a choice:

      - We can say that [\x:T.t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T.t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq (in its built-in functional programming langauge) makes the
    first choice -- for example,
         Eval simpl in (fun x:bool => 3 + 4)
    yields [fun x:bool => 7].  But most real-world functional
    programming languages make the second choice -- reduction of a
    function's body only begins when the function is actually applied
    to an argument.  We also make the second choice here.

    Finally, having made the choice not to reduce under abstractions,
    we don't need to worry about whether variables are values, since
    we'll always be reducing programs "from the outside in," and that
    means the [step] relation will always be working with closed
    terms (ones with no free variables).  *)

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

Hint Constructors value.

(* ###################################################################### *)
(** *** Free Variables and Substitution *)

(** Now we come to the heart of the matter: the operation of
    substituting one term for a variable in another term.

    This operation will be used below to define the operational
    semantics of function application, where we will need to
    substitute the argument term for the function parameter in the
    function's body.  For example, we reduce
       (\x:Bool. if x then true else x) false
    to [false] by substituting [false] for the parameter [x] in the
    body of the function.  In general, we need to be able to
    substitute some given term [s] for occurrences of some variable
    [x] in another term [t].  In informal discussions, this is usually
    written [ [x:=s]t ] and pronounced "substitute [x] with [s] in [t]."

    Here are some examples:

      - [[x:=true] (if x then x else false)] yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)] yields [\y:Bool. if y then true else false]
      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x]. *)

(** Here is the definition, informally...
   [x:=s]x = s
   [x:=s]y = y                                   if x <> y
   [x:=s](\x:T11.t12)   = \x:T11. t12
   [x:=s](\y:T11.t12)   = \y:T11. [x:=s]t12      if x <> y
   [x:=s](t1 t2)        = ([x:=s]t1) ([x:=s]t2)
   [x:=s]true           = true
   [x:=s]false          = false
   [x:=s](if t1 then t2 else t3) =
                   if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
]]
    ... and formally: *)

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 (subst x s t1))
  | tapp t1 t2 =>
      tapp (subst x s t1) (subst x s t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif (subst x s t1) (subst x s t2) (subst x s t3)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x y] that mention
    variables are not bound by some enclosing lambda), we can avoid
    this extra complexity here. *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the same
    pattern as the ones we have seen before.  Intuitively, to reduce a
    function application, we first reduce its left-hand side until it
    becomes a literal function; then we reduce its right-hand
    side (the argument) until it is also a value; and finally we
    substitute the argument for the bound variable in the body of the
    function.  This last rule, written informally as
      (\x:T.t12) v2 ==> [x:=v2]t12
    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
*)
(** ... plus the usual rules for booleans:
                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

                    ---------------------------------              (ST_IfFalse)
                    (if false then t1 else t2) ==> t2

                              t1 ==> t1'
         ----------------------------------------------------           (ST_If)
         (if t1 then t2 else t3) ==> (if t1' then t2 else t3)
*)

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).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

Hint Constructors step.

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

(* ##################################### *)
(** *** Examples *)

(** Example:
    ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)
i.e.
    (idBB idB) ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** A more automatic proof *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Again, we can use the [normalize] tactic from above to simplify
    the proof. *)

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

(** **** Exercise: 2 stars (step_example3) *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example3 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App1.
    apply ST_AppAbs.
    auto.
  simpl.
  eapply multi_step.
    apply ST_AppAbs.
    auto.
    simpl.
  apply multi_refl.
Qed.

(* ###################################################################### *)
(** ** Typing *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place "typing judgment", informally
    written [Gamma |- t : T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** We hide the definition of partial maps in a module since it is
    actually defined in [SfLib]. *)

Module PartialMap.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

End PartialMap.

Definition context := partial_map ty.

(* ################################### *)
(** *** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x : T

                      Gamma , x:T11 |- t12 : T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 : T11->T12

                        Gamma |- t1 : T11->T12
                          Gamma |- t2 : T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 : T12

                         --------------------                          (T_True)
                         Gamma |- true : Bool

                        ---------------------                         (T_False)
                        Gamma |- false : Bool

       Gamma |- t1 : Bool    Gamma |- t2 : T    Gamma |- t3 : T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 : T
*)

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

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If" ].

Hint Constructors has_type.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  has_type empty (tabs x TBool (tvar x)) (TArrow TBool TBool).
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  has_type empty (tabs x TBool (tvar x)) (TArrow TBool TBool).
Proof. auto.  Qed.

Hint Unfold beq_id beq_nat extend.

(** Another example:
     empty |- \x:A. \y:A->A. y (y x))
           : A -> (A->A) -> A.
*)

Example typing_example_2 :
  has_type empty
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x)))))
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using extend_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full) *)
(** Prove the same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  has_type empty
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x)))))
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3) *)
(** Formally prove the following typing derivation holds: *)
(**
   empty |- (\x:Bool->B. \y:Bool->Bool. \z:Bool.
               y (x z))
         : T.
*)

Example typing_example_3 :
  exists T,
    has_type empty
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z))))))
      T.

Proof with auto.
  eapply ex_intro.
  repeat constructor.
  econstructor.
  constructor.
  rewrite extend_neq.
  apply extend_eq.
  auto.
  econstructor...
  repeat constructor.
  repeat constructor.
Qed.

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,
    ~ exists T,
        empty |- (\x:Bool. \y:Bool, x y) : T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      has_type empty
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y))))
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  (* rewrite extend_neq in H1. rewrite extend_eq in H1. *)
  inversion H1.  Qed.

(** **** Exercise: 3 stars (typing_nonexample_3) *)
(** Another nonexample:
    ~ (exists S, exists T,
          empty |- (\x:S. x x) : T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        has_type empty
          (tabs x S
             (tapp (tvar x) (tvar x)))
          T).
Proof.
  intros Hc. inversion Hc.
  inversion H. subst. clear H.
  inversion H0. subst. clear H0.
  inversion H5. subst. clear H5.
  inversion H2. subst. clear H2.
  inversion H4. subst. clear H4.
  rewrite H1 in H2.
  inversion H2.
  assert (~ exists T T', TArrow T T' = T).
    intros Hc'.
    inversion Hc'.
    induction x1; intros.
    Case "TBool".
      inversion H.
      inversion H3.
    Case "TArrow".
      inversion H.
      eapply IHx1_1.
      inversion H3.
      eapply ex_intro.
      apply H3.

  apply H.
  exists T11, T12.
  apply H0.
Qed.

(** **** Exercise: 1 star, optional (typing_statements) *)

(** Which of the following propositions are provable?
       - [y:Bool |- \x:Bool.x : Bool->Bool]

       - [exists T,  empty |- (\y:Bool->Bool. \x:Bool. y x) : T]

       - [exists T,  empty |- (\y:Bool->Bool. \x:Bool. x y) : T]

       - [exists S, x:S |- (\y:Bool->Bool. y) x : S]

       - [exists S, exists T,  x:S |- (x x x) : T]

[]
*)

(** **** Exercise: 1 star (more_typing_statements) *)

(** Which of the following propositions are provable?  For the
    ones that are, give witnesses for the existentially bound
    variables.
       - [exists T,  empty |- (\y:B->B->B. \x:B, y x) : T]

       - [exists T,  empty |- (\x:A->B, \y:B->C, \z:A, y (x z)):T]

       - [exists S, exists U, exists T,  x:S, y:U |- \z:A. x (y z) : T]

       - [exists S, exists T,  x:S |- \y:A. x (x y) : T]

       - [exists S, exists U, exists T,  x:S |- x (\z:U. z x) : T]

[]
*)

(* ###################################################################### *)
(** ** Properties *)

(* ###################################################################### *)
(** *** Progress *)

(** The _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or
    it can take an evaluation step. *)

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

(** _Proof_: by induction on the derivation of [|- t : T].

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we know immediately that [t] is a value.

    - If the last rule of the derivation was [T_App], then [t = t1
      t2], and we know that [t1] and [t2] are also well typed in the
      empty context; in particular, there exists a type [T2] such that
      [|- t1 : T2 -> T] and [|- t2 : T2].  By the induction
      hypothesis, either [t1] is a value or it can take an evaluation
      step.

        - If [t1] is a value, we now consider [t2], which by the other
          induction hypothesis must also either be a value or take an
          evaluation step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation was [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      is either a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps
          to [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]).

*)

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; 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...
    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is also a value".
        (* Since [t1] is a value and has an arrow type, it
           must be an abs. Sometimes this is proved separately
           and called a "canonical forms" lemma. *)
        inversion H; subst. exists ([x0:=t2]t)...
        solve by inversion. solve by inversion.
      SSCase "t2 steps".
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_If".
    right. destruct IHHt1...

    SCase "t1 is a value".
      (* Since [t1] is a value of boolean type, it must
         be true or false *)
      inversion H; subst. solve by inversion.
      SSCase "t1 = true". eauto.
      SSCase "t1 = false". eauto.

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

(** **** Exercise: 3 stars, optional (progress_from_term_ind) *)
(** Show that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  t_cases (induction t) Case; intros T Ht; auto.
  Case "tvar".
    inversion Ht; subst.
    inversion H1.
  Case "tapp".
    right.
    destruct t1; try (solve by inversion 3).

    inversion Ht.
    assert (value (tapp t1_1 t1_2) \/ (exists t' : tm, tapp t1_1 t1_2 ==> t')).
      eapply IHt1.
      apply H2.
    inversion H5.
    inversion H6.
    inversion H6.

    eapply ex_intro.
    constructor.
    apply H7.

    inversion Ht; subst.
    assert (value t2 \/ (exists t' : tm, t2 ==> t')).
      eapply IHt2.
      eassumption.

    inversion H.
      eapply ex_intro. auto.
      inversion H0.
      eapply ex_intro. apply ST_App2; eauto.

    inversion Ht; subst.
    assert (value (tif t1_1 t1_2 t1_3) \/ (exists t' : tm, tif t1_1 t1_2 t1_3 ==> t')).
      eapply IHt1.
      apply H2.
    inversion H.
    inversion H0.
    inversion H0.
    eapply ex_intro. eauto.
  Case "tif".
    right.
    inversion Ht; subst.
    assert (value t1 \/ (exists t' : tm, t1 ==> t')).
      eapply IHt1.
      apply H3.
    inversion H.
      inversion H0; subst; eauto.
      inversion H3.
    inversion H0.
    eauto.
Qed.

(* ###################################################################### *)
(** *** Free Occurrences *)

(** A variable [x] _appears free in_ a term _t_ if [t] contains some
    occurrence of [x] that is not under an abstraction labeled [x].  For example:
      - [y] appears free, but [x] does not, in [\x:T->U. x y]
      - both [x] and [y] appear free in [(\x:T->U. x y) x]
      - no variables appear free in [\x:T->U. \y:T. x y]  *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  | Case_aux c "afi_if3" ].

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(* ###################################################################### *)
(** *** Substitution *)

(** We first need a technical lemma connecting free variables and
    typing contexts.  If a variable [x] appears free in a term [t],
    and if we know [t] is well typed in context [Gamma], then it must
    be the case that [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.

(** _Proof_: We show, by induction on the proof that [x] appears free
      in [t], that, for all contexts [Gamma], if [t] is well typed
      under [Gamma], then [Gamma] assigns some type to [x].

      - If the last rule used was [afi_var], then [t = x], and from
        the assumption that [t] is well typed under [Gamma] we have
        immediately that [Gamma] assigns a type to [x].

      - If the last rule used was [afi_app1], then [t = t1 t2] and [x]
        appears free in [t1].  Since [t] is well typed under [Gamma],
        we can see from the typing rules that [t1] must also be, and
        the IH then tells us that [Gamma] assigns [x] a type.

      - Almost all the other cases are similar: [x] appears free in a
        subterm of [t], and since [t] is well typed under [Gamma], we
        know the subterm of [t] in which [x] appears is well typed
        under [Gamma] as well, and the IH gives us exactly the
        conclusion we want.

      - The only remaining case is [afi_abs].  In this case [t =
        \y:T11.t12], and [x] appears free in [t12]; we also know that
        [x] is different from [y].  The difference from the previous
        cases is that whereas [t] is well typed under [Gamma], its
        body [t12] is well typed under [(Gamma, y:T11)], so the IH
        allows us to conclude that [x] is assigned some type by the
        extended context [(Gamma, y:T11)].  To conclude that [Gamma]
        assigns a type to [x], we appeal to lemma [extend_neq], noting
        that [x] and [y] are different variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    apply not_eq_beq_id_false in H.
    rewrite extend_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed -- that is, it has no free variables. *)

(** **** Exercise: 2 stars (typable_empty__closed) *)
Corollary typable_empty__closed : forall t T,
    has_type empty t T  ->
    closed t.
Proof.
  intros t T H x H1.
  remember (@empty ty) as Gamma.
  assert (exists t' : _, Gamma x = Some t').
    apply free_in_context with (t := t) (T := T).
    assumption.
    assumption.

  inversion H0.
  rewrite HeqGamma in H2.
  inversion H2.
Qed.

(** Sometimes, when we have a proof [Gamma |- t : T], we will need to
    replace [Gamma] by a different context [Gamma'].  When is it safe
    to do this?  Intuitively, it must at least be the case that
    [Gamma'] assigns the same types as [Gamma] to all the variables
    that appear free in [t]. In fact, this is the only condition that
    is needed. *)

Lemma context_invariance : forall Gamma Gamma' t T,
     has_type Gamma t T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     has_type Gamma' t T.

(** _Proof_: By induction on the derivation of [Gamma |- t : T].

      - If the last rule in the derivation was [T_Var], then [t = x]
        and [Gamma x = T].  By assumption, [Gamma' x = T] as well, and
        hence [Gamma' |- t : T] by [T_Var].

      - If the last rule was [T_Abs], then [t = \y:T11. t12], with [T
        = T11 -> T12] and [Gamma, y:T11 |- t12 : T12].  The induction
        hypothesis is that for any context [Gamma''], if [Gamma,
        y:T11] and [Gamma''] assign the same types to all the free
        variables in [t12], then [t12] has type [T12] under [Gamma''].
        Let [Gamma'] be a context which agrees with [Gamma] on the
        free variables in [t]; we must show [Gamma' |- \y:T11. t12 :
        T11 -> T12].

        By [T_Abs], it suffices to show that [Gamma', y:T11 |- t12 :
        T12].  By the IH (setting [Gamma'' = Gamma', y:T11]), it
        suffices to show that [Gamma, y:T11] and [Gamma', y:T11] agree
        on all the variables that appear free in [t12].

        Any variable occurring free in [t12] must either be [y], or
        some other variable.  [Gamma, y:T11] and [Gamma', y:T11]
        clearly agree on [y].  Otherwise, we note that any variable
        other than [y] which occurs free in [t12] also occurs free in
        [t = \y:T11. t12], and by assumption [Gamma] and [Gamma']
        agree on all such variables, and hence so do [Gamma, y:T11]
        and [Gamma', y:T11].

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 : T2 -> T] and [Gamma |- t2 : T2].  One induction
        hypothesis states that for all contexts [Gamma'], if [Gamma']
        agrees with [Gamma] on the free variables in [t1], then [t1]
        has type [T2 -> T] under [Gamma']; there is a similar IH for
        [t2].  We must show that [t1 t2] also has type [T] under
        [Gamma'], given the assumption that [Gamma'] agrees with
        [Gamma] on all the free variables in [t1 t2].  By [T_App], it
        suffices to show that [t1] and [t2] each have the same type
        under [Gamma'] as under [Gamma].  However, we note that all
        free variables in [t1] are also free in [t1 t2], and similarly
        for free variables in [t2]; hence the desired result follows
        by the two IHs.
*)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var".
    apply T_Var. rewrite <- H0...
  Case "T_Abs".
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold extend. remember (beq_id x0 x1) as e. destruct e...
  Case "T_App".
    apply T_App with T11...
Qed.

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types.

    Formally, the so-called _Substitution Lemma_ says this: suppose we
    have a term [t] with a free variable [x], and suppose we've been
    able to assign a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we should be
    able to substitute [v] for each of the occurrences of [x] in [t]
    and obtain a new term that still has type [T]. *)

(** _Lemma_: If [Gamma,x:U |- t : T] and [|- v : U], then [Gamma |-
    [x:=v]t : T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t t' T,
     has_type (extend Gamma x U) t T ->
     has_type empty t' U   ->
     has_type Gamma ([x:=t']t) T.

(** One technical subtlety in the statement of the lemma is that we
    assign [t'] the type [U] in the _empty_ context -- in other words,
    we assume [t'] is closed.  This assumption considerably simplifies
    the [T_Abs] case of the proof (compared to assuming [Gamma |- t' :
    U], which would be the other reasonable assumption at this point)
    because the context invariance lemma then tells us that [t'] has
    type [U] in any context at all -- we don't have to worry about
    free variables in [t'] clashing with the variable being introduced
    into the context by [T_Abs].

    _Proof_: We prove, by induction on [t], that, for all [T] and
    [Gamma], if [Gamma,x:U |- t : T] and [|- t' : U], then [Gamma |-
    [x:=t']t : T].

      - If [t] is a variable, there are two cases to consider, depending
        on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [Gamma, x:U |- x : T] we
            conclude that [U = T].  We must show that [[x:=t']x = t'] has
            type [T] under [Gamma], given the assumption that [t'] has
            type [U = T] under the empty context.  This follows from
            context invariance: if a closed term has type [T] in the
            empty context, it has that type in any context.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under [Gamma,
            x:U] as under [Gamma].

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [Gamma',x:U |- t12 : T']
        and [|- t' : U], then [Gamma' |- [x:=t']t12 : T'].

        The substitution in the conclusion behaves differently,
        depending on whether [x] and [y] are the same variable name.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=t']t = t], so we just need to show [Gamma |-
        t : T].  But we know [Gamma,x:U |- t : T], and since the
        variable [y] does not appear free in [\y:T11. t12], the
        context invariance lemma yields [Gamma |- t : T].

        Second, suppose [x <> y].  We know [Gamma,x:U,y:T11 |- t12 :
        T12] by inversion of the typing relation, and [Gamma,y:T11,x:U
        |- t12 : T12] follows from this by the context invariance
        lemma, so the IH applies, giving us [Gamma,y:T11 |- [x:=t']t12 :
        T12].  By [T_Abs], [Gamma |- \y:T11. [x:=t']t12 : T11->T12], and
        by the definition of substitution (noting that [x <> y]),
        [Gamma |- \y:T11. [x:=t']t12 : T11->T12] as required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case.

    Another technical note: This proof is a rare case where an
    induction on terms, rather than typing derivations, yields a
    simpler argument.  The reason for this is that the assumption
    [has_type (extend Gamma x U) t T] is not completely generic, in
    the sense that one of the "slots" in the typing relation -- namely
    the context -- is not just a variable, and this means that Coq's
    native induction tactic does not give us the induction hypothesis
    that we want.  It is possible to work around this, but the needed
    generalization is a little tricky.  The term [t], on the other
    hand, _is_ completely generic. *)

Proof with eauto.
  intros Gamma x U t t' T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  t_cases (induction t) Case; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  Case "tvar".
    rename i into y. remember (beq_id x y) as e. destruct e.
    SCase "x=y".
      apply beq_id_eq in Heqe. subst.
      rewrite extend_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      apply T_Var. rewrite extend_neq in H2...
  Case "tabs".
    rename i into y. apply T_Abs.
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
Qed.

(** The substitution lemma can be viewed as a kind of "commutation"
    property.  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way. *)

(* ###################################################################### *)
(** *** Preservation *)

(** We now have the tools we need to prove _preservation_: if a closed
    term [t] has type [T], and takes an evaluation step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    evaluation relation preserves types.
*)

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.

(** _Proof_: by induction on the derivation of [|- t : T].

    - We can immediately rule out [T_Var], [T_Abs], [T_True], and
      [T_False] as the final rules in the derivation, since in each of
      these cases [t] cannot take a step.

    - If the last rule in the derivation was [T_App], then [t = t1
      t2].  There are three cases to consider, one for each rule that
      could have been used to show that [t1 t2] takes a step to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then by the IH [t1'] has the same type as [t1], and
          hence [t1' t2] has the same type as [t1 t2].

        - The [ST_App2] case is similar.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the
          desired result now follows from the fact that substitution
          preserves types.

    - If the last rule in the derivation was [T_If], then [t = if t1
      then t2 else t3], and there are again three cases depending on
      how [t] steps.

        - If [t] steps to [t2] or [t3], the result is immediate, since
          [t2] and [t3] have the same type as [t].

        - Otherwise, [t] steps by [ST_If], and the desired conclusion
          follows directly from the induction hypothesis.
*)

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  has_type_cases (induction HT) Case;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  Case "T_App".
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(** **** Exercise: 2 stars, recommended (subject_expansion_stlc) *)
(** An exercise in Types.v asked about the subject
    expansion property for the simple language of arithmetic and
    boolean expressions.  Does this property hold for STLC?  That
    is, is it always the case that, if [t ==> t'] and [has_type
    t' T], then [has_type t T]?  If so, prove it.  If not, give a
    counter-example.

(* FILL IN HERE *)
[]
*)

(* ###################################################################### *)
(** *** Type Soundness *)

(** **** Exercise: 2 stars, optional (type_soundness) *)

(** Put progress and preservation together and show that a well-typed
    term can _never_ reach a stuck state.  *)

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  has_type empty t T ->
  t ==>* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  assert (value x0 \/ exists t' : tm, x0 ==> t').
    eapply progress.
    eauto.
  inversion Hhas_type; subst; auto; try (solve by inversion).
  Case "tapp".
    apply Hnf.
    inversion H.
    inversion H2.
    apply H2.
  Case "tif".
    apply Hnf.
    inversion H; [solve by inversion | auto].

  (* step *)
  apply IHHmulti; auto.
  eapply preservation; eauto.
Qed.

(* ###################################################################### *)
(** *** Uniqueness of Types *)

(** **** Exercise: 3 stars (types_unique) *)
(** Another pleasant property of the STLC is that types are
    unique: a given term (in a given context) has at most one
    type. *)
(** Formalize this statement and prove it. *)

Theorem types_unique :
  forall t Gamma T1 T2,
    has_type Gamma t T1 ->
    has_type Gamma t T2 ->
    T1 = T2.
Proof.
  induction t;
    intros;
    inversion H;
    inversion H0;
    subst.
  rewrite H3 in H7.
  inversion H7. auto.

  assert ((TArrow T11 T1) = (TArrow T0 T2)).
  eapply IHt1; eauto.
  inversion H1. auto.

  inversion H; try (solve by inversion); subst.
  inversion H0; try (solve by inversion); subst.
  f_equal.
  eapply IHt; eauto.

  reflexivity.
  reflexivity.

  eapply IHt2.
  eauto.
  eauto.
Qed.

(* ###################################################################### *)
(** ** Additional Exercises *)

(** **** Exercise: 1 star (progress_preservation_statement) *)
(** Without peeking, write down the progress and preservation
    theorems for the simply typed lambda-calculus. *)
(** [] *)

(** **** Exercise: 2 stars (stlc_variation1) *)
(** Suppose we add a new term [zap] with the following reduction rule:
                         ---------                  (ST_Zap)
                         t ==> zap
and the following typing rule:
                      ----------------               (T_Zap)
                      Gamma |- zap : T
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation2) *)
(** Suppose instead that we add a new term [foo] with the following reduction rules:
                       -----------------                (ST_Foo1)
                       (\x:A. x) ==> foo

                         ------------                   (ST_Foo2)
                         foo ==> true
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation3) *)
(** Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC remain
    true in the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation4) *)
(** Suppose instead that we add the following new rule to the reduction relation:
            ----------------------------------        (ST_FunnyIfTrue)
            (if true then t1 else t2) ==> true
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars (stlc_variation5) *)
(** Suppose instead that we add the following new rule to the typing relation:
                 Gamma |- t1 : Bool->Bool->Bool
                     Gamma |- t2 : Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 : Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars (stlc_variation6) *)
(** Suppose instead that we add the following new rule to the typing relation:
                     Gamma |- t1 : Bool
                     Gamma |- t2 : Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 : Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

*)

(** **** Exercise: 2 stars (stlc_variation7) *)
(** Suppose we add the following new rule to the typing
    relation of the STLC:
                         ------------------- (T_FunnyAbs)
                         |- \x:Bool.t : Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

End STLC.

(* ###################################################################### *)
(* ###################################################################### *)
(** * Optional Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.

(* ###################################################################### *)
(** ** Syntax and Operational Semantics *)

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity) *)

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

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing... *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat  : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0  : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "tnat"
  | Case_aux c "tsucc" | Case_aux c "tpred"
  | Case_aux c "tmult" | Case_aux c "tif0" ].

(** **** Exercise: 4 stars, optional (stlc_arith) *)
(** Finish formalizing the definition and properties of the STLC extended
    with arithmetic.  Specifically:

    - Copy the whole development of STLC that we went through above (from
      the definition of values through the Progress theorem), and
      paste it into the file at this point.

    - Extend the definitions of the [subst] operation and the [step]
      relation to include appropriate clauses for the arithmetic operators.

    - Extend the proofs of all the properties of the original STLC to deal
      with the new syntactic forms.  Make sure Coq accepts the whole file. *)

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

End STLCArith.


(** Inductive NetKAT semantics. Big Step and Small Step. *)

Require Export NetKAT Misc Tactics.
Require Import List Coq.Program.Equality Bool Omega
  Relations Relations.Relation_Operators Arith.Wf_nat.
Import ListNotations.

Module NetKAT (F : FIELDSPEC) (V : VALUESPEC(F)).

Include NetKAT.NetKAT(F)(V).

(** Big Step Semantics ***************************************************)

Inductive bstep : policy -> H.t -> H.t -> Prop :=
  | BstepId : forall h, bstep Id h h
  | BstepFilter : forall f v pk h, pk f = v -> bstep (f==v) (pk,h) (pk,h)
  | BstepNFilter : forall f v pk h, pk f <> v -> bstep (f!=v) (pk,h) (pk,h)
  | BstepMod : forall f v pk h, bstep (f<-v) (pk,h) (pk[f:=v], h)
  | BstepPlusLeft : forall h h' p q, bstep p h h' -> bstep (p+q) h h'
  | BstepPlusRight : forall h h' p q, bstep q h h' -> bstep (p+q) h h'
  | BstepSeq : forall h h' h'' p q, bstep p h h' -> bstep q h' h'' -> bstep (p;;q) h h''
  | BstepStarRefl : forall h p, bstep (p*) h h
  | BstepStarTrans : forall h h' h'' p, bstep p h h' -> bstep (p*) h' h'' -> bstep (p*) h h''
  | BstepDup : forall pk h, bstep Dup (pk,h) (pk,pk::h).
Hint Constructors bstep.

Notation "'(|' p '|)'" := (bstep p) (at level 1) : netkat_scope.

Lemma bstep_denot p h h' : (|p|) h h' -> [|p|] h h'.
Proof.
  intros.
  induction H; simpl; try (simpl in H); try split_if; auto.
  - left; assumption.
  - right; assumption.
  - exists h'. intuition.
  - exists 0; simpl; auto.
  - destruct IHbstep2 as [n].
    exists (S n). simpl. exists h'. intuition.
Qed.

Lemma denot_bstep p h h' : [|p|] h h' -> (|p|) h h'.
Proof.
  gd h'; gd h; induction p; intros h h' H; destruct h as [pk h];
  simpl in H; try (unfold empty in H); try (unfold singleton in H);
  try (subst h'; constructor); intuition.
  - split_if; try subst h'; intuition.
  - split_if; simpl in H; try subst h'; intuition.
  - destruct H; [apply BstepPlusLeft|apply BstepPlusRight]; intuition.
  - destruct H as [h'']. eapply BstepSeq; intuition eauto.
  - destruct H as [n].
    gd pk; gd h; gd h'; induction n; intros h' h pk H; simpl in H.
    + unfold singleton in H. subst h'. constructor.
    + destruct H as [h'']. eapply BstepStarTrans; intuition eauto.
      destruct h'' as [pk'' h'']; intuition.
Qed.

Lemma bstep_prefix {p pk pk' h h'} :
  (|p|) (pk,h) (pk',h') -> exists h'', h' = h''++ h.
Proof.
  intro H.
  dependent induction H;
  try destruct h'0 as [pk'' h''];
  solve [
    eauto |
    exists []; auto |
    exists [pk']; auto |
    assert(exists x, h'' = x ++ h) as H1 by eauto; destruct H1 as [x H1];
    assert(exists y, h' = y ++ h'') as H2 by eauto; destruct H2 as [y H2];
    exists (y++x); rewrite <- app_assoc; congruence
  ].
Qed.

(** Small Step Semantics ***************************************************)

Inductive sstep : prod policy H.t -> prod policy H.t -> Prop :=
| sstep_Filter_pass :
    forall pk h f v, (pk f) = v -> sstep (f==v, (pk,h)) (Id, (pk,h))
| sstep_Filter_drop :
    forall pk h f v, (pk f) <> v -> sstep (f==v, (pk,h)) (Drop, (pk,h))
| sstep_NFilter_pass :
    forall f v pk h, (pk f) <> v -> sstep (f!=v, (pk,h)) (Id, (pk,h))
| sstep_NFilter_drop :
    forall f v pk h, (pk f) = v -> sstep (f!=v, (pk,h)) (Drop, (pk,h))
| sstep_Mod :
    forall f v pk h, sstep (f<-v, (pk,h)) (Id, (pk[f:=v],h))
| sstep_Union_left :
    forall p q h, sstep (p+q, h) (p, h)
| sstep_Union_right :
    forall p q h, sstep (p+q, h) (q, h)
| sstep_Seq_progress :
    forall p q h r h', sstep (p, h) (r, h') -> sstep (p;;q, h) (r;;q, h')
| sstep_Seq_finish :
    forall q h, sstep (Id;;q, h) (q, h)
| sstep_Seq_fail :
    forall q h, sstep (Drop;;q, h) (Drop, h)
| sstep_Star_unfold :
    forall p h, sstep (p*,h) (p;;p*, h)
| sstep_Star_finish :
    forall p h, sstep (p*, h) (Id,h)
| sstep_Dup :
    forall pk h, sstep (Dup, (pk,h)) (Id, (pk,pk::h)).

Hint Constructors sstep.

Lemma sstep_mono p pk h q pk' h' :
  sstep (p,(pk,h)) (q,(pk',h')) -> length h <= length h'.
Proof. intros. dependent induction H; simpl; eauto. Qed.

Lemma sstep_progress p :
  (p=Id) \/ (p=Drop) \/ (forall h, exists r h', sstep (p,h) (r,h')).
Proof.
  induction p; first [auto;fail | right;right;intro;destruct h as [pk h] ]; eauto.
  + destruct (pk f =d= t); eauto.
  + destruct (pk f =d= t); eauto.
  + dependent destruction IHp1; eauto; dependent destruction H; subst; eauto.
    assert (H':= H (pk,h)); clear H.
    destruct H' as [r]; destruct H as [h']; exists (r;;p2); exists h'; eauto.
Qed.

Inductive npower {A : Type} (R : relation A) : nat -> relation A :=
| npower0 : forall x, npower R 0 x x
| npowerS : forall n x y z, R x y -> npower R n y z -> npower R (S n) x z.
Hint Constructors npower.

Hint Constructors clos_refl_trans_1n.

Lemma clos_trans_refl_nat :
  forall {A} R x y, clos_refl_trans_1n A R x y <-> exists n, npower R n x y.
Proof.
  split; intros.
  + dependent induction H.
    - exists 0; eauto.
    - destruct IHclos_refl_trans_1n as [n]; exists (S n). eauto.
  + destruct H as [n].
    generalize dependent x; generalize dependent y.
    dependent induction n; intros; invert H.
Qed.

Definition ssteps := clos_refl_trans_1n (prod policy H.t) sstep.
Hint Unfold ssteps.

Lemma clos_rt1n_trans : forall X R x y z, clos_refl_trans_1n X R x y ->
  clos_refl_trans_1n X R y z -> clos_refl_trans_1n X R x z.
Proof. intros.
  apply clos_rt_rt1n; eapply rt_trans; eapply clos_rt1n_rt; eauto.
Qed.

Lemma ssteps_bstep : forall p h1 h2, ssteps (p,h1) (Id,h2) -> (|p|) h1 h2.
Proof.
  intros.
  unfold ssteps in H.
  apply clos_trans_refl_nat in H.
  destruct H as [n].
  generalize dependent h2; generalize dependent h1; generalize dependent p.
  dependent induction n; intros; invert H.
  destruct y as [q h3].
  assert ( (|q|) h3 h2) by intuition.
  clear IHn H H2.
  generalize dependent h2.
  dependent induction H1; intros; invert H0.
Qed.

Lemma ssteps_seq_assoc : forall p q r h1 h2,
  ssteps (p;;(q;;r), h1) (r, h2) -> ssteps (p;;q;;r, h1) (r, h2).
Proof.
  intros.
  unfold ssteps in H.
  apply clos_trans_refl_nat in H.
  destruct H as [n].
  dependent induction H.
  - (* x is a contradiction. How to tell Coq? *) admit.
  - invert H; eright; eauto.
    * apply IHnpower; eauto.
    * apply clos_trans_refl_nat. exists n; assumption.
    * invert H0. invert H1.
Qed.

Lemma bstep_ssteps : forall p q h1 h2, (|p|) h1 h2 -> ssteps (p;;q,h1) (q,h2).
Proof.
  intros. generalize dependent q.
  dependent induction H; intros; subst; eauto 7.
  + assert (H0 := IHbstep q0); eauto.
  + assert (H0 := IHbstep q0); eauto.
  + assert (H1 := IHbstep1 (q;;q0)); assert (H2 := IHbstep2 q0).
    apply ssteps_seq_assoc. eauto using clos_rt1n_trans.
  + clear H H0. assert (H0 := IHbstep1 (p*;;q)); assert (H1 := IHbstep2 q).
    eright. apply sstep_Seq_progress. apply sstep_Star_unfold.
    apply ssteps_seq_assoc. eauto using clos_rt1n_trans.
Qed.

Lemma sstep_id_right : forall p h1 h2,
  ssteps (p;;Id, h1) (Id, h2) -> ssteps (p,h1) (Id,h2).
Proof.
  intros.
  apply clos_rt1n_rt in H; apply clos_rt_rtn1 in H.
  invert H. destruct y as [q h3]. cut (q = Id;;Id).
  + intro H2. subst q. apply clos_rtn1_rt in H1. apply clos_rt_rt1n in H1.
    apply clos_trans_refl_nat in H1.
    destruct H1 as [n].
    generalize dependent h3; generalize dependent h2;
    generalize dependent h1; generalize dependent p.
    dependent induction n; intros; invert H1.
    - inversion H0; eauto.
    - invert H0. destruct y as [q h3]. invert H3.
      * eright; eauto. eapply IHn; eauto. eright; eauto.
        apply clos_rt_rtn1. apply clos_rt1n_rt.
        eapply clos_trans_refl_nat. eauto.
      * invert H4; invert H2.
      * invert H4; invert H2.
  + apply clos_rtn1_rt in H1; apply clos_rt_rt1n in H1;
    apply clos_trans_refl_nat in H1; destruct H1 as [n].
    generalize dependent p; generalize dependent h1;
    generalize dependent q; generalize dependent h2;
    generalize dependent h3.
    dependent induction n; intros; invert H1.
    - invert H0.
    - destruct y as [r h4]. invert H3.
      * assert (H6:=H4);
        pattern n in H6; apply ex_intro in H6.
        apply clos_trans_refl_nat in H6.
        apply (IHn h3 h2 q H0 h4 r0).
        eright; eauto.
        apply clos_rt_rtn1; apply clos_rt1n_rt; assumption.
        assumption.
      * invert H4. invert H0. invert H2.
      * invert H4. invert H0. invert H2.
Qed.

Corollary bstep_ssteps_iff : forall p h1 h2,
  (|p|) h1 h2 <-> ssteps (p,h1) (Id,h2).
Proof.
  split.
  + intro H. apply sstep_id_right. apply bstep_ssteps. assumption.
  + apply ssteps_bstep.
Qed.

End NetKAT.