Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Program.Basics.

Require Import Pro.Preorder.
Require Import Grph.Graph.
Require Import Func.Functor.
Require Import Cat.Category.
Require Import Grph.GraphCat.
Require Import Iso.Isomorphism.
Require Import Iso.IsomorphismSetGrph.

Inductive PrOEdge (T : Type) (rel : T -> T -> Prop) :=
    cons_proedge (a b : T) (proof : rel a b).

Arguments cons_proedge {T} {rel} a b proof.

Definition edge_of (p : PrO) : Type :=
    PrOEdge (undertype_pro p) (ordering p).

Definition pro_src {T : Type} {rel : T -> T -> Prop} (e : PrOEdge T rel) :=
    match e with cons_proedge a _ _ => a end.

Definition pro_tgt {T : Type} {rel : T -> T -> Prop} (e : PrOEdge T rel) :=
    match e with cons_proedge _ b _ => b end.

Theorem proedge_eq (T : Type) (rel : T -> T -> Prop) (a b : PrOEdge T rel)
        : pro_src a = pro_src b -> pro_tgt a = pro_tgt b -> a = b.
    intros seq teq.
    destruct a; destruct b.
    simpl in *.
    subst.
    f_equal.
    apply proof_irrelevance.
Qed.

Hint Resolve proedge_eq.

Definition edge_map {P Q : PrO} (f : PrOHom P Q) (e : edge_of P) : edge_of Q.
    refine (cons_proedge (pro_fn f (pro_src e)) (pro_fn f (pro_tgt e)) _).
    destruct f; destruct e.
    auto.
Defined.

Definition PrOGrph (p : PrO) : Grph :=
    grph (@graph (undertype_pro p) (edge_of p) pro_src pro_tgt).

Definition PrOGrphHom {P Q : PrO} (f : PrOHom P Q) : GrphHom (PrOGrph P) (PrOGrph Q).
    refine (grph_hom (PrOGrph P) (PrOGrph Q) (pro_fn f) (edge_map f) _ _);
        reflexivity.
Defined.

Definition ProGrphFun : Functor PrOCat GrphCat.
    refine (cons_functor PrOCat GrphCat PrOGrph (@PrOGrphHom) _ _);
        intros;
        apply grph_hom_eq;
        try reflexivity;
        apply functional_extensionality;
        intro e; destruct e;
        apply proedge_eq;
        reflexivity.
Defined.

Definition Grph_Not_In_Image : Grph :=
    grph (@graph _ bool (fun _ => tt) (fun _ => tt)).

Theorem singleton_eq : forall a b : unit, a = b.
    intros a b.
    case a; case b;
        reflexivity.
Qed.

Theorem iso_unit_singleton {O : Type} {f : O -> unit} {g : unit -> O}
        : Isomorphism CoqIsCat O unit f g -> forall (a b : O), a = b.
    intros H; inversion H.
    intros a b.
    pose (eqf := singleton_eq (f a) (f b)).
    pose (eqgf := eq_refl (g (f a))).
    pattern (f a) at 1 in eqgf; rewrite eqf in eqgf.
    assert (compose g f b = compose g f a) by (unfold compose; assumption).
    rewrite proof_left in H0.
    unfold id in H0.
    auto.
Qed.

Theorem not_in_image : forall p, not (Isomorphic GrphIsCat (PrOGrph p) Grph_Not_In_Image).
    intros p H.
    destruct p as [O M _refl _trans].
    destruct H as [f [g H]].
    destruct (grph_iso_impl_srctgt_iso f g H) as [proof_v proof_a].
    clear H.
    destruct f as [vf af psf ptf].
    destruct g as [vg ag psg ptg].
    simpl in *.
    pose (o_is_singleton := iso_unit_singleton proof_v).
    destruct proof_a.
    assert (ag true = ag false).
        apply proedge_eq;
        apply o_is_singleton.
    assert (forall b, af (ag b) = b).
        apply equal_f.
        apply proof_right.
    assert (af (ag true) = af (ag false)).
        rewrite H; reflexivity.
    rewrite (H0 true) in H1; rewrite (H0 false) in H1.
    discriminate.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import riscv.util.Monads.
Require Import riscv.util.Word.
Require Import riscv.Utility.
Require Import riscv.Decode.

Inductive AccessType: Set := Instr | Load | Store.

Class RiscvProgram{M}{t}`{Monad M}`{MachineWidth t} := mkRiscvProgram {
  getRegister: Register -> M t;
  setRegister: Register -> t -> M unit;

  loadByte: t -> M (word 8);
  loadHalf: t -> M (word 16);
  loadWord: t -> M (word 32);
  loadDouble: t -> M (word 64);

  storeByte: t -> word 8 -> M unit;
  storeHalf: t -> word 16 -> M unit;
  storeWord: t -> word 32 -> M unit;
  storeDouble: t -> word 64 -> M unit;

  getPC: M t;
  setPC: t -> M unit;

  (* TODO support all get/setCSRField, this ZToReg 1 is just for the exception handler address *)
  getCSRField_MTVecBase: M MachineInt;

  step: M unit; (* updates PC *)

  endCycle: forall {A}, M A;
}.

(* The Haskell spec defines concrete implementations for raiseException and translate,
   but we prefer to leave them abstract, so that we can prove more general theorems *)
Class RiscvState`{MP: RiscvProgram} := mkRiscvState {
  (* ends current cycle, sets exception flag, and sets PC to exception handler address *)
  raiseException{A: Type}(isInterrupt: t)(exceptionCode: t): M A;

  (* checks that addr is aligned, and translates the (possibly virtual) addr to a physical
     address, raising an exception if the address is invalid *)
  translate(accessType: AccessType)(alignment: t)(addr: t): M t;
}.

Section Riscv.
  (* monad (will be instantiated with some kind of state monad) *)
  Context {M: Type -> Type}.
  Context {MM: Monad M}.

  (* type of register values *)
  Context {t: Set}.

  (* provides operations on t *)
  Context {MW: MachineWidth t}.

  Definition default_raiseException{A: Type}{MP: RiscvProgram}
    (isInterrupt: t)(exceptionCode: t): M A :=
    pc <- getPC;
    addr <- getCSRField_MTVecBase;
    setPC (fromImm (addr * 4)%Z);;
    endCycle.

  Local Open Scope alu_scope.
  Local Open Scope Z_scope.

  (* in a system with virtual memory, this would also do the translation, but in our
     case, we only verify the alignment *)
  Definition default_translate{MP: RiscvProgram}
    (accessType: AccessType)(alignment: t)(addr: t): M t :=
    if remu addr alignment /= ZToReg 0
    then default_raiseException (ZToReg 0) (ZToReg 4)
    else Return addr.

  Instance DefaultRiscvState{MP: RiscvProgram}: RiscvState := {|
    raiseException A := default_raiseException;
    translate := default_translate;
  |}.

End Riscv.

Definition Register0: Register := 0%Z.

Arguments RiscvProgram: clear implicits.
Arguments RiscvProgram (M) (t) {_} {_}.
Arguments RiscvState: clear implicits.
Arguments RiscvState (M) (t) {_} {_} {_}.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1 A2 B1 B2 C1 C2 P : Universe, ((wd_ A1 A2 /\ (wd_ B1 B2 /\ (wd_ C1 C2 /\ (col_ A1 A2 B1 /\ (col_ A1 A2 B2 /\ (col_ P B1 B2 /\ (col_ A1 A2 C1 /\ (col_ A1 A2 C2 /\ col_ P C1 C2)))))))) -> col_ C2 B1 B2)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
Copyright (C) 2010-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Error of the rounded-to-nearest addition is representable. *)

Require Import Psatz.
Require Import Raux Defs Float_prop Generic_fmt.
Require Import FIX FLX FLT Ulp Operations.
Require Import Relative.

Section Fprop_plus_error.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.

Section round_repr_same_exp.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma round_repr_same_exp :
  forall m e,
  exists m',
  round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e).
Proof with auto with typeclass_instances.
intros m e.
set (e' := cexp beta fexp (F2R (Float beta m e))).
unfold round, scaled_mantissa. fold e'.
destruct (Zle_or_lt e' e) as [He|He].
exists m.
unfold F2R at 2. simpl.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- IZR_Zpower. 2: omega.
rewrite <- mult_IZR, Zrnd_IZR...
unfold F2R. simpl.
rewrite mult_IZR.
rewrite Rmult_assoc.
rewrite IZR_Zpower. 2: omega.
rewrite <- bpow_plus.
apply (f_equal (fun v => IZR m * bpow v)%R).
ring.
exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z.
unfold F2R. simpl.
rewrite mult_IZR.
rewrite IZR_Zpower. 2: omega.
rewrite 2!Rmult_assoc.
rewrite <- 2!bpow_plus.
apply (f_equal (fun v => _ * bpow v)%R).
ring.
Qed.

End round_repr_same_exp.

Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Variable choice : Z -> bool.

Lemma plus_error_aux :
  forall x y,
  (cexp beta fexp x <= cexp beta fexp y)%Z ->
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y.
set (ex := cexp beta fexp x).
set (ey := cexp beta fexp y).
intros He Hx Hy.
destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0].
rewrite H0.
apply generic_format_0.
set (mx := Ztrunc (scaled_mantissa beta fexp x)).
set (my := Ztrunc (scaled_mantissa beta fexp y)).
(* *)
assert (Hxy: (x + y)%R = F2R (Float beta (mx + my * beta ^ (ey - ex)) ex)).
rewrite Hx, Hy.
fold mx my ex ey.
rewrite <- F2R_plus.
unfold Fplus. simpl.
now rewrite Zle_imp_le_bool with (1 := He).
(* *)
rewrite Hxy.
destruct (round_repr_same_exp (Znearest choice) (mx + my * beta ^ (ey - ex)) ex) as (mxy, Hxy').
rewrite Hxy'.
assert (H: (F2R (Float beta mxy ex) - F2R (Float beta (mx + my * beta ^ (ey - ex)) ex))%R =
  F2R (Float beta (mxy - (mx + my * beta ^ (ey - ex))) ex)).
now rewrite <- F2R_minus, Fminus_same_exp.
rewrite H.
apply generic_format_F2R.
intros _.
apply monotone_exp.
rewrite <- H, <- Hxy', <- Hxy.
apply mag_le_abs.
exact H0.
pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring.
rewrite Rabs_Ropp.
now apply (round_N_pt beta _ choice (x + y)).
Qed.

(** Error of the addition *)
Theorem plus_error :
  forall x y,
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y Hx Hy.
destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)).
now apply plus_error_aux.
rewrite Rplus_comm.
apply plus_error_aux ; try easy.
now apply Zlt_le_weak.
Qed.

End Fprop_plus_error.

Section Fprop_plus_zero.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { exp_not_FTZ : Exp_not_FTZ fexp }.
Notation format := (generic_format beta fexp).

Section round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma round_plus_neq_0_aux :
  forall x y,
  (cexp beta fexp x <= cexp beta fexp y)%Z ->
  format x -> format y ->
  (0 < x + y)%R ->
  round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
intros x y He Hx Hy Hxy.
destruct (mag beta (x + y)) as (exy, Hexy).
simpl.
specialize (Hexy (Rgt_not_eq _ _ Hxy)).
destruct (Zle_or_lt exy (fexp exy)) as [He'|He'].
(* . *)
assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) +
  Ztrunc (y * bpow (- fexp exy))) (fexp exy))).
rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1.
rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1.
now rewrite <- F2R_plus, Fplus_same_exp.
rewrite H.
rewrite round_generic...
rewrite <- H.
now apply Rgt_not_eq.
apply generic_format_F2R.
intros _.
rewrite <- H.
unfold cexp.
rewrite mag_unique with (1 := Hexy).
apply Z.le_refl.
(* . *)
intros H.
elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hxy)).
rewrite H.
rewrite round_generic...
apply bpow_gt_0.
apply generic_format_bpow.
apply Zlt_succ_le.
now rewrite (Zsucc_pred exy) in He'.
Qed.

End round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *)
Theorem round_plus_neq_0 :
  forall x y,
  format x -> format y ->
  (x + y <> 0)%R ->
  round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hxy.
destruct (Rle_or_lt 0 (x + y)) as [H1|H1].
(* . *)
destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)) as [H2|H2].
apply round_plus_neq_0_aux...
lra.
rewrite Rplus_comm.
apply round_plus_neq_0_aux ; try easy.
now apply Zlt_le_weak.
lra.
(* . *)
rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr.
rewrite round_opp.
apply Ropp_neq_0_compat.
destruct (Zle_or_lt (cexp beta fexp (-x)) (cexp beta fexp (-y))) as [H2|H2].
apply round_plus_neq_0_aux; try apply generic_format_opp...
lra.
rewrite Rplus_comm.
apply round_plus_neq_0_aux; try apply generic_format_opp...
now apply Zlt_le_weak.
lra.
Qed.

Theorem round_plus_eq_0 :
  forall x y,
  format x -> format y ->
  round beta fexp rnd (x + y) = 0%R ->
  (x + y = 0)%R.
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
destruct (Req_dec (x + y) 0) as [H'|H'].
exact H'.
contradict H.
now apply round_plus_neq_0.
Qed.

End Fprop_plus_zero.

Section Fprop_plus_FLT.
Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Theorem FLT_format_plus_small: forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
   (Rabs (x+y) <= bpow (prec+emin))%R ->
    generic_format beta (FLT_exp emin prec) (x+y).
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
apply generic_format_FLT_FIX...
rewrite Zplus_comm; assumption.
apply generic_format_FIX_FLT, FIX_format_generic in Fx.
apply generic_format_FIX_FLT, FIX_format_generic in Fy.
destruct Fx as [nx H1x H2x].
destruct Fy as [ny H1y H2y].
apply generic_format_FIX.
exists (Float beta (Fnum nx+Fnum ny)%Z emin).
rewrite H1x,H1y; unfold F2R; simpl.
rewrite H2x, H2y.
rewrite plus_IZR; ring.
easy.
Qed.

Variable choice : Z -> bool.

Lemma FLT_plus_error_N_ex : forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
  exists eps,
  (Rabs eps <= u_ro beta prec / (1 + u_ro beta prec))%R /\
  round beta (FLT_exp emin prec) (Znearest choice) (x + y)
  = ((x + y) * (1 + eps))%R.
Proof.
intros x y Fx Fy.
assert (Pb := u_rod1pu_ro_pos beta prec).
destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs (x + y))) as [M|M].
{ destruct (relative_error_N_FLX'_ex beta prec prec_gt_0_ choice (x + y))
    as (d, (Bd, Hd)).
  now exists d; split; [exact Bd|]; rewrite <- Hd; apply round_FLT_FLX. }
exists 0%R; rewrite Rabs_R0; split; [exact Pb|]; rewrite Rplus_0_r, Rmult_1_r.
apply round_generic; [apply valid_rnd_N|].
apply FLT_format_plus_small; [exact Fx|exact Fy|].
apply Rlt_le, (Rlt_le_trans _ _ _ M), bpow_le; lia.
Qed.

Lemma FLT_plus_error_N_round_ex : forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
  exists eps,
  (Rabs eps <= u_ro beta prec)%R /\
  (x + y
   = round beta (FLT_exp emin prec) (Znearest choice) (x + y) * (1 + eps))%R.
Proof.
intros x y Fx Fy.
now apply relative_error_N_round_ex_derive, FLT_plus_error_N_ex.
Qed.

End Fprop_plus_FLT.

Section Fprop_plus_mult_ulp.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Notation format := (generic_format beta fexp).
Notation cexp := (cexp beta fexp).

Lemma ex_shift :
  forall x e, format x -> (e <= cexp x)%Z ->
  exists m, (x = IZR m * bpow e)%R.
Proof with auto with typeclass_instances.
intros x e Fx He.
exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z.
rewrite Fx at 1; unfold F2R; simpl.
rewrite mult_IZR, Rmult_assoc.
f_equal.
rewrite IZR_Zpower.
2: omega.
rewrite <- bpow_plus; f_equal; ring.
Qed.

Lemma mag_minus1 :
  forall z, z <> 0%R ->
  (mag beta z - 1)%Z = mag beta (z / IZR beta).
Proof.
intros z Hz.
unfold Zminus.
rewrite <- mag_mult_bpow by easy.
now rewrite bpow_opp, bpow_1.
Qed.

Theorem round_plus_F2R :
  forall x y, format x -> format y -> (x <> 0)%R ->
  exists m,
  round beta fexp rnd (x+y) = F2R (Float beta m (cexp (x / IZR beta))).
Proof with auto with typeclass_instances.
intros x y Fx Fy Zx.
case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1.
pose (e:=cexp (x / IZR beta)).
destruct (ex_shift x e) as (nx, Hnx); try exact Fx.
apply monotone_exp.
rewrite <- (mag_minus1 x Zx); omega.
destruct (ex_shift y e) as (ny, Hny); try assumption.
apply monotone_exp...
destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn).
exists n.
fold e.
rewrite <- Hn; f_equal.
rewrite Hnx, Hny; unfold F2R; simpl; rewrite plus_IZR; ring.
unfold F2R; simpl.
(* *)
destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/IZR beta))) as (n,Hn).
apply generic_format_round...
apply Z.le_trans with (cexp (x+y)).
apply monotone_exp.
rewrite <- mag_minus1 by easy.
rewrite <- (mag_abs beta (x+y)).
(* . *)
assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R).
assert (V: forall x y, (Rabs y <= Rabs x)%R ->
   (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R).
clear; intros x y.
case (Rle_or_lt 0 y); intros Hy.
case Hy; intros Hy'.
case (Rle_or_lt 0 x); intros Hx.
intros _; rewrite (Rabs_pos_eq y) by easy.
rewrite (Rabs_pos_eq x) by easy.
left; apply Rabs_pos_eq.
now apply Rplus_le_le_0_compat.
rewrite (Rabs_pos_eq y) by easy.
rewrite (Rabs_left x) by easy.
intros H; right; split.
now apply Rgt_not_eq.
rewrite Rabs_left1.
ring.
apply Rplus_le_reg_l with (-x)%R; ring_simplify; assumption.
intros _; left.
now rewrite <- Hy', Rabs_R0, 2!Rplus_0_r.
case (Rle_or_lt 0 x); intros Hx.
rewrite (Rabs_left y) by easy.
rewrite (Rabs_pos_eq x) by easy.
intros H; right; split.
now apply Rlt_not_eq.
rewrite Rabs_pos_eq.
ring.
apply Rplus_le_reg_l with (-y)%R; ring_simplify; assumption.
intros _; left.
rewrite (Rabs_left y) by easy.
rewrite (Rabs_left x) by easy.
rewrite Rabs_left1.
ring.
lra.
apply V; left.
apply lt_mag with beta.
now apply Rabs_pos_lt.
rewrite <- mag_minus1 in H1; try assumption.
rewrite 2!mag_abs; omega.
(* . *)
destruct U as [U|U].
rewrite U; apply Z.le_trans with (mag beta x).
omega.
rewrite <- mag_abs.
apply mag_le.
now apply Rabs_pos_lt.
apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify.
apply Rabs_pos.
destruct U as (U',U); rewrite U.
rewrite <- mag_abs.
apply mag_minus_lb.
now apply Rabs_pos_lt.
now apply Rabs_pos_lt.
rewrite 2!mag_abs.
assert (mag beta y < mag beta x - 1)%Z.
now rewrite (mag_minus1 x Zx).
omega.
apply cexp_round_ge...
apply round_plus_neq_0...
contradict H1; apply Zle_not_lt.
rewrite <- (mag_minus1 x Zx).
replace y with (-x)%R.
rewrite mag_opp; omega.
lra.
now exists n.
Qed.

Context {exp_not_FTZ : Exp_not_FTZ fexp}.

Theorem round_plus_ge_ulp :
  forall x y, format x -> format y ->
  round beta fexp rnd (x+y) <> 0%R ->
  (ulp beta fexp (x/IZR beta) <= Rabs (round beta fexp rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y Fx Fy KK.
case (Req_dec x 0); intros Zx.
(* *)
rewrite Zx, Rplus_0_l.
rewrite round_generic...
unfold Rdiv; rewrite Rmult_0_l.
rewrite Fy.
unfold F2R; simpl; rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0.
case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm.
contradict KK.
rewrite Zx, Fy, Hm; unfold F2R; simpl.
rewrite Rplus_0_l, Rmult_0_l.
apply round_0...
apply Rle_trans with (1*bpow (cexp y))%R.
rewrite Rmult_1_l.
rewrite <- ulp_neq_0.
apply ulp_ge_ulp_0...
intros K; apply Hm.
rewrite K, scaled_mantissa_0.
apply Ztrunc_IZR.
apply Rmult_le_compat_r.
apply bpow_ge_0.
rewrite <- abs_IZR.
apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
(* *)
destruct (round_plus_F2R x y Fx Fy Zx) as (m,Hm).
case (Z.eq_dec m 0); intros Zm.
contradict KK.
rewrite Hm, Zm.
apply F2R_0.
rewrite Hm, <- F2R_Zabs.
rewrite ulp_neq_0.
rewrite <- (Rmult_1_l (bpow _)).
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
apply Rmult_integral_contrapositive_currified with (1 := Zx).
apply Rinv_neq_0_compat.
apply Rgt_not_eq, radix_pos.
Qed.

End Fprop_plus_mult_ulp.

Section Fprop_plus_ge_ulp.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Theorem round_FLT_plus_ge :
  forall x y e,
  generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
  (bpow (e + prec) <= Rabs x)%R ->
  round beta (FLT_exp emin prec) rnd (x + y) <> 0%R ->
  (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x + y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
  contradict He.
  apply Rlt_not_le; rewrite He, Rabs_R0.
  apply bpow_gt_0.
apply Rle_trans with (ulp beta (FLT_exp emin prec) (x/IZR beta)).
2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
unfold cexp.
rewrite <- mag_minus1; try assumption.
unfold FLT_exp; apply bpow_le.
apply Z.le_trans with (2:=Z.le_max_l _ _).
destruct (mag beta x) as (n,Hn); simpl.
assert (e + prec < n)%Z; try omega.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
apply Rmult_integral_contrapositive_currified; try assumption.
apply Rinv_neq_0_compat.
apply Rgt_not_eq.
apply radix_pos.
Qed.

Lemma round_FLT_plus_ge' :
  forall x y e,
  generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
  (x <> 0%R -> (bpow (e+prec) <= Rabs x)%R) ->
  (x = 0%R -> y <> 0%R -> (bpow e <= Rabs y)%R) ->
  round beta (FLT_exp emin prec) rnd (x+y) <> 0%R ->
  (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy H1 H2 H3.
case (Req_dec x 0); intros H4.
case (Req_dec y 0); intros H5.
contradict H3.
rewrite H4, H5, Rplus_0_l; apply round_0...
rewrite H4, Rplus_0_l.
rewrite round_generic...
apply round_FLT_plus_ge; try easy.
now apply H1.
Qed.

Theorem round_FLX_plus_ge :
  forall x y e,
  generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y ->
  (bpow (e+prec) <= Rabs x)%R ->
  (round beta (FLX_exp prec) rnd (x+y) <> 0)%R ->
  (bpow e <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R.
Proof with auto with typeclass_instances.
intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
  contradict He.
  apply Rlt_not_le; rewrite He, Rabs_R0.
  apply bpow_gt_0.
apply Rle_trans with (ulp beta (FLX_exp prec) (x/IZR beta)).
2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
unfold cexp.
rewrite <- mag_minus1 by easy.
unfold FLX_exp; apply bpow_le.
destruct (mag beta x) as (n,Hn); simpl.
assert (e + prec < n)%Z; try omega.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
apply Rmult_integral_contrapositive_currified; try assumption.
apply Rinv_neq_0_compat.
apply Rgt_not_eq.
apply radix_pos.
Qed.

End Fprop_plus_ge_ulp.

Section Fprop_plus_le_ops.

Variable beta : radix.
Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Variable choice : Z -> bool.

Lemma plus_error_le_l :
  forall x y,
  generic_format beta fexp x -> generic_format beta fexp y ->
  (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs x)%R.
Proof.
intros x y Fx Fy.
apply (Rle_trans _ (Rabs (y - (x + y)))); [now apply round_N_pt|].
rewrite Rabs_minus_sym; right; f_equal; ring.
Qed.

Lemma plus_error_le_r :
  forall x y,
  generic_format beta fexp x -> generic_format beta fexp y ->
  (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs y)%R.
Proof. now intros x y Fx Fy; rewrite Rplus_comm; apply plus_error_le_l. Qed.

End Fprop_plus_le_ops.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_digits.
Require Import Fcore_float_prop.
Require Import Fcalc_bracket.
Require Import Fcalc_digits.

Section Fcalc_sqrt.

Variable beta : radix.
Notation bpow e := (bpow beta e).

(** Computes a mantissa of precision p, the corresponding exponent,
    and the position with respect to the real square root of the
    input floating-point number.

The algorithm performs the following steps:
- Shift the mantissa so that it has at least 2p-1 digits;
  shift it one digit more if the new exponent is not even.
- Compute the square root s (at least p digits) of the new
  mantissa, and its remainder r.
- Compute the position according to the remainder:
  -- r == 0  =>  Eq,
  -- r <= s  =>  Lo,
  -- r >= s  =>  Up.

Complexity is fine as long as p1 <= 2p-1.
*)

Definition Fsqrt_core prec m e :=
  let d := Zdigits beta m in
  let s := Z.max (2 * prec - d) 0 in
  let e' := (e - s)%Z in
  let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in
  let m' :=
    match s' with
    | Zpos p => (m * Zpower_pos beta p)%Z
    | _ => m
    end in
  let (q, r) := Z.sqrtrem m' in
  let l :=
    if Zeq_bool r 0 then loc_Exact
    else loc_Inexact (if Zle_bool r q then Lt else Gt) in
  (q, Z.div2 e'', l).

Theorem Fsqrt_core_correct :
  forall prec m e,
  (0 < m)%Z ->
  let '(m', e', l) := Fsqrt_core prec m e in
  (prec <= Zdigits beta m')%Z /\
  inbetween_float beta m' e' (sqrt (F2R (Float beta m e))) l.
Proof.
intros prec m e Hm.
unfold Fsqrt_core.
set (d := Zdigits beta m).
set (s := Z.max (2 * prec - d) 0).
(* . exponent *)
case_eq (if Zeven (e - s) then (s, (e - s)%Z) else ((s + 1)%Z, (e - s - 1)%Z)).
intros s' e' Hse.
assert (He: (Zeven e' = true /\ 0 <= s' /\ 2 * prec - d <= s' /\ s' + e' = e)%Z).
revert Hse.
case_eq (Zeven (e - s)) ; intros He Hse ; inversion Hse.
repeat split.
exact He.
unfold s.
apply Z.le_max_r.
apply Z.le_max_l.
ring.
assert (H: (Z.max (2 * prec - d) 0 <= s + 1)%Z).
fold s.
apply Zle_succ.
repeat split.
unfold Zminus at 1.
now rewrite Zeven_plus, He.
apply Z.le_trans with (2 := H).
apply Z.le_max_r.
apply Z.le_trans with (2 := H).
apply Z.le_max_l.
ring.
clear -Hm He.
destruct He as (He1, (He2, (He3, He4))).
(* . shift *)
set (m' := match s' with
  | Z0 => m
  | Zpos p => (m * Zpower_pos beta p)%Z
  | Zneg _ => m
  end).
assert (Hs: F2R (Float beta m' e') = F2R (Float beta m e) /\ (2 * prec <= Zdigits beta m')%Z /\ (0 < m')%Z).
rewrite <- He4.
unfold m'.
destruct s' as [|p|p].
repeat split ; try easy.
fold d.
omega.
fold (Zpower beta (Zpos p)).
split.
replace (Zpos p) with (Zpos p + e' - e')%Z by ring.
rewrite <- F2R_change_exp.
apply (f_equal (fun v => F2R (Float beta m v))).
ring.
assert (0 < Zpos p)%Z by easy.
omega.
split.
rewrite Zdigits_mult_Zpower.
fold d.
omega.
apply sym_not_eq.
now apply Zlt_not_eq.
easy.
apply Zmult_lt_0_compat.
exact Hm.
now apply Zpower_gt_0.
now elim He2.
clearbody m'.
destruct Hs as (Hs1, (Hs2, Hs3)).
generalize (Z.sqrtrem_spec m' (Zlt_le_weak _ _ Hs3)).
destruct (Z.sqrtrem m') as (q, r).
intros (Hq, Hr).
rewrite <- Hs1. clear Hs1.
split.
(* . mantissa width *)
apply Zmult_le_reg_r with 2%Z.
easy.
rewrite Zmult_comm.
apply Z.le_trans with (1 := Hs2).
rewrite Hq.
apply Z.le_trans with (Zdigits beta (q + q + q * q)).
apply Zdigits_le.
rewrite <- Hq.
now apply Zlt_le_weak.
omega.
replace (Zdigits beta q * 2)%Z with (Zdigits beta q + Zdigits beta q)%Z by ring.
apply Zdigits_mult_strong.
omega.
omega.
(* . round *)
unfold inbetween_float, F2R. simpl.
rewrite sqrt_mult.
2: now apply (Z2R_le 0) ; apply Zlt_le_weak.
2: apply Rlt_le ; apply bpow_gt_0.
destruct (Zeven_ex e') as (e2, Hev).
rewrite He1, Zplus_0_r in Hev. clear He1.
rewrite Hev.
replace (Z.div2 (2 * e2)) with e2 by now case e2.
replace (2 * e2)%Z with (e2 + e2)%Z by ring.
rewrite bpow_plus.
fold (Rsqr (bpow e2)).
rewrite sqrt_Rsqr.
2: apply Rlt_le ; apply bpow_gt_0.
apply inbetween_mult_compat.
apply bpow_gt_0.
rewrite Hq.
case Zeq_bool_spec ; intros Hr'.
(* .. r = 0 *)
rewrite Hr', Zplus_0_r, Z2R_mult.
fold (Rsqr (Z2R q)).
rewrite sqrt_Rsqr.
now constructor.
apply (Z2R_le 0).
omega.
(* .. r <> 0 *)
constructor.
split.
(* ... bounds *)
apply Rle_lt_trans with (sqrt (Z2R (q * q))).
rewrite Z2R_mult.
fold (Rsqr (Z2R q)).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply (Z2R_le 0).
omega.
apply sqrt_lt_1.
rewrite Z2R_mult.
apply Rle_0_sqr.
rewrite <- Hq.
apply (Z2R_le 0).
now apply Zlt_le_weak.
apply Z2R_lt.
omega.
apply Rlt_le_trans with (sqrt (Z2R ((q + 1) * (q + 1)))).
apply sqrt_lt_1.
rewrite <- Hq.
apply (Z2R_le 0).
now apply Zlt_le_weak.
rewrite Z2R_mult.
apply Rle_0_sqr.
apply Z2R_lt.
ring_simplify.
omega.
rewrite Z2R_mult.
fold (Rsqr (Z2R (q + 1))).
rewrite sqrt_Rsqr.
apply Rle_refl.
apply (Z2R_le 0).
omega.
(* ... location *)
rewrite Rcompare_half_r.
rewrite <- Rcompare_sqr.
replace ((2 * sqrt (Z2R (q * q + r))) * (2 * sqrt (Z2R (q * q + r))))%R
  with (4 * Rsqr (sqrt (Z2R (q * q + r))))%R by (unfold Rsqr ; ring).
rewrite Rsqr_sqrt.
change 4%R with (Z2R 4).
rewrite <- Z2R_plus, <- 2!Z2R_mult.
rewrite Rcompare_Z2R.
replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
generalize (Zle_cases r q).
case (Zle_bool r q) ; intros Hr''.
change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
omega.
change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
omega.
rewrite <- Hq.
apply (Z2R_le 0).
now apply Zlt_le_weak.
apply Rmult_le_pos.
now apply (Z2R_le 0 2).
apply sqrt_ge_0.
rewrite <- Z2R_plus.
apply (Z2R_le 0).
omega.
Qed.

End Fcalc_sqrt.


Require Export Iron.Language.SimpleData.TyJudge.
Require Export Iron.Language.SimpleData.Exp.
Require Export Iron.Language.SimpleData.SubstExpExp.

(* The body of an alternative is well typed under an environment
   that includes the arguments of the constructor being matched. *)
Lemma getAlt_bodyIsWellTyped_fromAlts
 :  forall ds te tPat tResult alts dc tsArgs x
 ,  Forall (fun a => TYPEA ds te a tPat tResult) alts
 -> In (AAlt dc tsArgs x) alts
 -> TYPE ds (te >< tsArgs) x tResult.
Proof.
 intros.
 norm. spec H H0.
 inverts_type. auto.
Qed.

(* The body of an alternative of a case expression is well typed
   under an environment that includes the arguments of the constructor
   being matched. *)
Lemma getAlt_bodyIsWellTyped_fromCase
 :  forall ds te tResult tCon alts dc tsArgs x1 x2
 ,  TYPE ds te (XCase x1 alts) tResult
 -> getDataDef dc ds   = Some (DefData dc tsArgs tCon)
 -> getAlt     dc alts = Some (AAlt    dc tsArgs x2)
 -> TYPE ds (te >< tsArgs) x2 tResult.
Proof.
 intros.
 inverts keep H.
 lets HA:  getAlt_in H1.
 lets HXT: getAlt_bodyIsWellTyped_fromAlts H5 HA.
 auto.
Qed.

(* If an alternative is well typed then the types of the ctor
   args embedded in it match those in the data type definition *)
Lemma getAlt_ctorArgTypesMatchDataDef
 :  forall ds te tCon tResult alts dc x tsArgs tsArgs'
 ,  Forall (fun alt => TYPEA ds te alt tCon tResult) alts
 -> getDataDef dc ds = Some (DefData dc tsArgs  tCon)
 -> getAlt dc alts   = Some (AAlt    dc tsArgs' x)
 -> tsArgs = tsArgs'.
Proof.
 intros. norm.
 lets D: getAlt_in H1. spec H D.
 inverts_type. rip.
Qed.


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

(* $Date: 2011-06-09 16:11:42 -0400 (Thu, 09 Jun 2011) $ *)

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 above when formalizing
    of 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):
<<<
       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 :=
  | ty_Bool  : ty
  | ty_arrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm.

(** Something to note here is that an abstraction [\x:T.t] (formally,
    [tm_abs x T t]) is always annotated with the type ([T]) of its
    parameter.  This is in contrast to Coq (and other functional
    languages like ML, Haskell, etc.), which use _type inference_ to
    fill in missing annotations. *)

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tm_var" | Case_aux c "tm_app"
  | Case_aux c "tm_abs" | Case_aux c "tm_true"
  | Case_aux c "tm_false" | Case_aux c "tm_if" ].

(** Some examples... *)

Notation a := (Id 0).
Notation b := (Id 1).
Notation c := (Id 2).

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

Notation idB :=
  (tm_abs a ty_Bool (tm_var a)).

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

Notation idBB :=
  (tm_abs a (ty_arrow ty_Bool ty_Bool) (tm_var a)).

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

Notation idBBBB :=
  (tm_abs a (ty_arrow (ty_arrow ty_Bool ty_Bool)
                      (ty_arrow ty_Bool ty_Bool))
    (tm_var a)).

(** [k = \a:Bool. \b:Bool. a] *)

Notation k := (tm_abs a ty_Bool (tm_abs b ty_Bool (tm_var a))).

(** (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 [\a:A.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 [\a:A.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 makes the first choice -- for example,
[[
         Eval simpl in (fun a:bool => 3 + 4)
]]
    yields [fun a:bool => 7].  But most real 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 (tm_abs x T t)
  | t_true :
      value tm_true
  | t_false :
      value tm_false.

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 [ [s/x]t ] and pronounced "substitute [s] for [x] in [t]."

    Here are some examples:

      - [[true / a] (if a then a else false)] yields [if true then true else false]

      - [[true / a] a] yields [true]

      - [[true / a] (if a then a else b)] yields [if true then true else b]

      - [[true / a] b] yields [b]

      - [[true / a] false] yields [false] (vacuous substitution)

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

      - [[true / a] (\y:Bool. y)] yields [\y:Bool. y]

      - [[true / a] (\a:Bool. a)] yields [\a:Bool. a]

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

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

Fixpoint subst (s:tm) (x:id) (t:tm) : tm :=
  match t with
  | tm_var x' => if beq_id x x' then s else t
  | tm_abs x' T t1 => tm_abs x' T (if beq_id x x' then t1 else (subst s x t1))
  | tm_app t1 t2 => tm_app (subst s x t1) (subst s x t2)
  | tm_true => tm_true
  | tm_false => tm_false
  | tm_if t1 t2 t3 => tm_if (subst s x t1) (subst s x t2) (subst s x t3)
  end.

(** 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 in defining the [step] relation on
    closed terms here, we can avoid this extra complexity. *)

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

(** The small-step reduction relation for STLC 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
[[
      (\a:T.t12) v2 ==> [v2/a]t12
]]
    is traditionally called "beta-reduction".

    Informally:
[[[
                     ---------------------------                    (ST_AppAbs)
                     (\a:T.t12) v2 ==> [v2/a]t12

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

                              t2 ==> t2'
                           ----------------                        (ST_App2)
                           v1 t2 ==> v1 t2'
]]]
   (plus the usual rules for booleans).

   Formally:
*)

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tm_app (tm_abs x T t12) v2) ==> (subst v2 x t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tm_app t1 t2 ==> tm_app t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tm_app v1 t2 ==> tm_app v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tm_if tm_true t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tm_if tm_false t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tm_if t1 t2 t3) ==> (tm_if 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" ].

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

Hint Constructors step.

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

Lemma step_example1 :
  (tm_app idBB idB) ==>* idB.
Proof.
  eapply rsc_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply rsc_refl.  Qed.

(* A more automatic proof *)
Lemma step_example1' :
  (tm_app idBB idB) ==>* idB.
Proof. normalize.  Qed.

Lemma step_example2 :
  (tm_app idBB (tm_app idBB idB)) ==>* idB.
Proof.
  eapply rsc_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply rsc_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply rsc_refl.  Qed.

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

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

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

Lemma step_example3 :
       (tm_app (tm_app idBBBB idBB) idB)
  ==>* idB.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

Definition context := partial_map ty.

Module Context.

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

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

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

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

(** Informally:
[[[
                             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
]]]
The notation [ Gamma , x:T ] means "extend the partial function [Gamma]
to also map [x] to [T]."
*)

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tm_var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tm_abs x T11 t12) (ty_arrow T11 T12)
  | T_App : forall T11 T12 Gamma t1 t2,
      has_type Gamma t1 (ty_arrow T11 T12) ->
      has_type Gamma t2 T11 ->
      has_type Gamma (tm_app t1 t2) T12
  | T_True : forall Gamma,
       has_type Gamma tm_true ty_Bool
  | T_False : forall Gamma,
       has_type Gamma tm_false ty_Bool
  | T_If : forall t1 t2 t3 T Gamma,
       has_type Gamma t1 ty_Bool ->
       has_type Gamma t2 T ->
       has_type Gamma t3 T ->
       has_type Gamma (tm_if 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 (tm_abs a ty_Bool (tm_var a)) (ty_arrow ty_Bool ty_Bool).
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 (tm_abs a ty_Bool (tm_var a)) (ty_arrow ty_Bool ty_Bool).
Proof. auto.  Qed.

Hint Unfold beq_id beq_nat extend.

(** Written informally, the next one is:
[[
     empty |- \a:A. \b:A->A. b (b a))
           : A -> (A->A) -> A.
]]
*)

Example typing_example_2 :
  has_type empty
    (tm_abs a ty_Bool
       (tm_abs b (ty_arrow ty_Bool ty_Bool)
          (tm_app (tm_var b) (tm_app (tm_var b) (tm_var a)))))
    (ty_arrow ty_Bool (ty_arrow (ty_arrow ty_Bool ty_Bool) ty_Bool)).
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 *)
(** Prove the same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  has_type empty
    (tm_abs a ty_Bool
       (tm_abs b (ty_arrow ty_Bool ty_Bool)
          (tm_app (tm_var b) (tm_app (tm_var b) (tm_var a)))))
    (ty_arrow ty_Bool (ty_arrow (ty_arrow ty_Bool ty_Bool) ty_Bool)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3) *)
(** Formally prove the following typing derivation holds:
[[
   empty |- (\a:Bool->B. \b:Bool->Bool. \c:Bool.
               b (a c))
         : T.
]]
*)

Example typing_example_3 :
  exists T,
    has_type empty
      (tm_abs a (ty_arrow ty_Bool ty_Bool)
         (tm_abs b (ty_arrow ty_Bool ty_Bool)
            (tm_abs c ty_Bool
               (tm_app (tm_var b) (tm_app (tm_var a) (tm_var c))))))
      T.

Proof with auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** 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 [\a:Bool. \b:Bool, a b] -- i.e.,
[[
    ~ exists T,
        empty |- (\a:Bool. \b:Bool, a b) : T.
]]
*)
Example typing_nonexample_1 :
  ~ exists T,
      has_type empty
        (tm_abs a ty_Bool
            (tm_abs b ty_Bool
               (tm_app (tm_var a) (tm_var b))))
        T.
Proof.
  intros C. destruct C.
  (* 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 |- (\a:S. a a) : T).
]]
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        has_type empty
          (tm_abs a S
             (tm_app (tm_var a) (tm_var a)))
          T).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

       - [exists T,  empty |- (\b:Bool->Bool. \a:Bool. b a) : T]

       - [exists T,  empty |- (\b:Bool->Bool. \a:Bool. a b) : T]

       - [exists S, a:S |- (\b:Bool->Bool. b) a : S]

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

[]
*)

(** **** Exercise: 1 star, optional (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 |- (\b:B->B->B. \a:B, b a) : T]

       - [exists T,  empty |- (\a:A->B, \b:B-->C, \c:A, b (a c)):T]

       - [exists S, exists U, exists T,  a:S, b:U |- \c:A. a (b c) : T]

       - [exists S, exists T,  a:S |- \b:A. a (a b) : T]

       - [exists S, exists U, exists T,  a:S |- a (\c:U. c a) : T]

[]
*)

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

(* ###################################################################### *)
(** *** 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 (tm_var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tm_abs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tm_if t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tm_if t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tm_if 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. 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.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** 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 S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     has_type Gamma' t S.

(** _Proof_: By induction on a 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 x0 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold extend. remember (beq_id x x0) 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 |-
    [v/x]t : T]. *)

Lemma substitution_preserves_typing : forall Gamma x U v t T,
     has_type (extend Gamma x U) t T ->
     has_type empty v U   ->
     has_type Gamma (subst v x t) T.

(** One technical subtlety in the statement of the lemma is that we
    assign [v] the type [U] in the _empty_ context -- in other words,
    we assume [v] is closed.  This assumption considerably simplifies
    the [T_Abs] case of the proof (compared to assuming [Gamma |- v :
    U], which would be the other reasonable assumption at this point)
    because the context invariance lemma then tells us that [v] has
    type [U] in any context at all -- we don't have to worry about
    free variables in [v] 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 [|- v : U], then [Gamma |-
    [v/x]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 [[v/x]x = v] has
            type [T] under [Gamma], given the assumption that [v] 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 [|- v : U], then [Gamma' |- [v/x]t12 : T'].  In
        particular, if [Gamma,y:T11,x:U |- t12 : T12] and [|- v : U],
        then [Gamma,y:T11 |- [v/x]t12 : T12].  There are again two
        cases to consider, depending on whether [x] and [y] are the
        same variable name.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[v/x]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 |- [v/x]t12 :
        T12].  By [T_Abs], [Gamma |- \y:T11. [v/x]t12 : T11->T12], and
        by the definition of substitution (noting that [x <> y]),
        [Gamma |- \y:T11. [v/x]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 v t T Ht Hv.
  generalize dependent Gamma. generalize dependent T.
  tm_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 "tm_var".
    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 "tm_abs".
    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 [ [v/x] 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 [subst t2 x 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 [auto] 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 earlier in this file 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 *)
[]
*)

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

(** Finally, the _progress_ theorem tells us that closed, well-typed
    terms are never stuck: either a well-typed term is a value, or
    else 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 (subst t2 x t)...
        solve by inversion. solve by inversion.
      SSCase "t2 steps".
        destruct H0 as [t2' Hstp]. exists (tm_app t1 t2')...

    SCase "t1 steps".
      destruct H as [t1' Hstp]. exists (tm_app 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".
      destruct H as [t1' Hstp]. exists (tm_if 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 types. *)

Theorem progress' : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  tm_cases (induction t) Case; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

(* ###################################################################### *)
(** ** 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, optional (stlc_variation1) *)
(** Suppose we add the following new rule to the evaluation
    relation of the STLC:
[[
      | T_Strange : forall x t,
           has_type empty (tm_abs 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.

      - Determinacy of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation2) *)
(** Suppose we remove the rule [ST_App1] from the [step]
    relation. Which of the three properties in the previous
    exercise become false in the absence of this rule? For each
    that becomes false, give a counterexample.

[]
*)

End STLC.

(* ###################################################################### *)
(* ###################################################################### *)
(** * 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 :=
  | ty_arrow : ty -> ty -> ty
  | ty_Nat   : ty.

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

Inductive tm : Type :=
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
  | tm_nat  : nat -> tm
  | tm_succ : tm -> tm
  | tm_pred : tm -> tm
  | tm_mult : tm -> tm -> tm
  | tm_if0  : tm -> tm -> tm -> tm.

Tactic Notation "tm_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tm_var" | Case_aux c "tm_app"
  | Case_aux c "tm_abs" | Case_aux c "tm_nat"
  | Case_aux c "tm_succ" | Case_aux c "tm_pred"
  | Case_aux c "tm_mult" | Case_aux c "tm_if0" ].

(** **** Exercise: 4 stars, recommended (STLCArith) *)
(** 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.


Require Import StLib.Main StLib.Kernels.
Require Import Psatz.
Require Import Utils.

Parameters P N : Z.
Axiom Ngt0 : N > 0.
Axiom Pgt0 : P > 0.

(** Let's start with the 1D Jacobi kernel. *)
Module Jacobi1D <: (PROBLEM Z2).
  Local Open Scope aexpr.

  Definition space := 〚0, N-1〛 × 〚0, N*P-1〛.
  Definition target := 〚0, N-1〛 × 〚0, N*P-1〛.
  (** Every cell depends on its former value, as well as the one of its
   * neighbors. *)
  Definition dep c :=
    match c with
      | (t,i) =>
        [(t-1,i); (t-1,i-1); (t-1,i+1)]
    end.
End Jacobi1D.

(** Specialize the library for this stencil. *)
Module P := Kern Z2 Jacobi1D.
Import P.

Definition my_comp :=
  (If "T" <? N Then
     For "x" From N*"id" To N*"id" + N-1 Do
       Fire ("T":aexpr, "x" : aexpr)
   Else
     Nop)%code.

Definition my_send :=
  (If "to" =? "id" - 1 Then
     Fire ("T":aexpr, N*"id")
   Else
     If "to" =? "id" + 1 Then
       Fire ("T":aexpr, N*"id" + N-1)
     Else
       Nop)%code.

Definition my_code :=
  makeKernel my_comp my_send.

Theorem my_code_correct :
  kcorrect my_code (P-1) (N-1).
Proof.

  synthesize trace; intros.

  (** First goal is the verification conditions for the computation steps,
   * which encapsulate the dependencies. *)
  - destr_case_lt (T <? N); forward; simplify sets with ceval.

    (* South dependency. *)
    decide T=0; [right; unfold space; forward; unfold fst, snd in *; omega|left].
    lhs; lhs; forward.
    exists (T-1); forward; try omega.
    unfold computes_synth; simpl; simplify sets with ceval.
    destr_case_lt (T - 1 <? N); forward.
    exists i; forward'; omega.

    (* South-west dependency. *)
    decide T=0; [right; unfold space; forward; unfold fst, snd in *; omega|].
    decide i=(N*id).

    decide id=0; [right; unfold space; forward; unfold fst, snd in *; omega|].
    left; lhs; rhs; forward.
    exists (T - 1); forward; try omega.
    exists (id - 1); forward; try omega.
    unfold sends_synth; simpl; simplify sets with ceval.
    destr_case (id =? id - 1 - 1); destr_case (id =? id - 1 + 1); forward; nia.

    left; lhs; lhs; forward.
    exists (T - 1); forward; try omega.
    unfold computes_synth; simpl; simplify sets with ceval.
    destr_case_lt (T - 1 <? N); forward.
    exists (i-1); forward'; omega.

    (* South-east dependency. *)
    decide T=0; [right; unfold space; forward; unfold fst, snd in *; omega|].
    decide i=(N*id + N-1).

    decide id=(P-1); [right; unfold space; forward; unfold fst, snd in *; nia|].
    left; lhs; rhs; forward.
    exists (T - 1); forward; try omega.
    exists (id + 1); forward; try omega.
    unfold sends_synth; simpl; simplify sets with ceval.
    destr_case (id =? id + 1 - 1); forward; nia.

    left; lhs; lhs; forward.
    exists (T - 1); forward; try omega.
    unfold computes_synth; simpl; simplify sets with ceval.
    destr_case_lt (T - 1 <? N); forward.
    exists (i+1); forward'; omega.

  (** Second goal is the verification conditions for the communication steps,
   * which are trivial. *)
  - destruct (to =? id - 1); forward.
    destruct (to =? id + 1); forward.

  (** Third goal is "conservation of knowledge": we are not allowed to send
   * a value that we don't know. *)
  - unfold af_synth, computes_synth, sends_synth in *; simpl in *.
    simplify sets with ceval.
    repeat intro; lhs.

    (* Left side *)
    destruct (to =? id - 1); forward.
    exists T; forward.
    destr_case_lt (T <? N); forward.
    exists (N*id); forward'; omega.

    (* Right side *)
    destruct (to =? id + 1); forward.
    exists T; forward.
    destr_case_lt (T <? N); forward.
    exists (N*id + N-1); forward'; omega.

  (** Last goal is completeness: we computed all the cells we were supposed
   * to compute. *)
  - unfold target, bf_synth, computes_synth, sends_synth; simpl.
    repeat intro.
    destruct x; forward; unfold fst, snd in *.

    (** We have to prove that [x] belongs to some T[I], TL[I] or TR[I], for
     * some "I". This "I" is obtained by take the quotient of x's abscissa
     * by 2N. *)
    pose (I := z0 / N).
    to_ctx (Z_div_mod_spec z0 N Ngt0).
    exists I; forward.
    unfold I; nia.
    unfold I; nia.

    lhs; forward.
    exists z; forward. omega.
    destr_case_lt (z <? N); forward.
    simplify sets with ceval.
    exists z0; forward; unfold I; omega.
Qed.


From Coq.Unicode Require Import Utf8.
From Coq.Lists Require Import List.
From Autosubst Require Import Autosubst.
From Coq.Relations Require Import Relations.
From ShortLogrels Require Import prelude language.

Inductive expr :=
| Var (v : var)
| TT
| Pair (e1 e2 : expr)
| Fst (e : expr)
| Snd (e : expr)
| Lam (e : {bind expr})
| App (e1 e2 : expr)
| TLam (e : expr)
| TApp (e : expr)
| Fold (e : expr)
| Unfold (e : expr).

Global Instance Ids_expr : Ids expr. derive. Defined.
Global Instance Rename_expr : Rename expr. derive. Defined.
Global Instance Subst_expr : Subst expr. derive. Defined.
Global Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

Inductive is_val : expr → Prop :=
| IVTT : is_val TT
| IVPair e1 e2 : is_val e1 → is_val e2 → is_val (Pair e1 e2)
| IVLam e : is_val (Lam e)
| IVTLam e : is_val (TLam e)
| IVFold e : is_val e → is_val (Fold e).

Inductive type :=
| TUnit
| TVar (X : var)
| TProd (τ1 τ2 : type)
| TFun (τ1 τ2 : type)
| TForAll (τ : {bind type})
| TRec (τ : {bind type}).

Global Instance Ids_type : Ids type. derive. Defined.
Global Instance Rename_type : Rename type. derive. Defined.
Global Instance Subst_type : Subst type. derive. Defined.
Global Instance SubstLemmas_type : SubstLemmas type. derive. Qed.

Definition context := environment type.

Inductive typed : context → expr → type → Prop :=
| TPVar Γ v τ : lookup Γ v = Some τ → typed Γ (Var v) τ
| TPTT Γ : typed Γ TT TUnit
| TPPAIR Γ e1 τ1 e2 τ2 : typed Γ e1 τ1 → typed Γ e2 τ2 → typed Γ (Pair e1 e2) (TProd τ1 τ2)
| TPFst Γ e τ1 τ2 : typed Γ e (TProd τ1 τ2) → typed Γ (Fst e) τ1
| TPSnd Γ e τ1 τ2 : typed Γ e (TProd τ1 τ2) → typed Γ (Snd e) τ2
| TPLam Γ e τ1 τ2 : typed (τ1 :: Γ) e τ2 → typed Γ (Lam e) (TFun τ1 τ2)
| TPApp Γ e1 e2 τ1 τ2 : typed Γ e1 (TFun τ1 τ2) → typed Γ e2 τ1 → typed Γ (App e1 e2) τ2
| TPTLam Γ e τ : typed (map (rename (+1)) Γ) e τ → typed Γ (TLam e) (TForAll τ)
| TPTApp Γ e τ τ' : typed Γ e (TForAll τ) → typed Γ (TApp e) τ.[τ'/]
| TPFold Γ e τ : typed Γ e τ.[TRec τ/] → typed Γ (Fold e) (TRec τ)
| TPUnfold Γ e τ : typed Γ e (TRec τ) → typed Γ (Unfold e) τ.[TRec τ/].

Inductive head_step : expr → expr → Prop :=
| SFst e1 e2 : is_val e1 → is_val e2 → head_step (Fst (Pair e1 e2)) e1
| SSnd e1 e2 : is_val e1 → is_val e2 → head_step (Snd (Pair e1 e2)) e2
| SApp e1 e2 : is_val e2 → head_step (App (Lam e1) e2) e1.[e2/]
| STApp e : head_step (TApp (TLam e)) e
| STUnfold e : is_val e → head_step (Unfold (Fold e)) e.

Inductive is_ectx : (expr → expr) → Prop :=
| ECTX_id : is_ectx (λ e, e)
| ECTX_Fst K : is_ectx K → is_ectx (λ e, Fst (K e))
| ECTX_Snd K : is_ectx K → is_ectx (λ e, Snd (K e))
| ECTX_Pair1 K e2 : is_ectx K → is_ectx (λ e, Pair (K e) e2)
| ECTX_Pair2 e1 K : is_val e1 → is_ectx K → is_ectx (λ e, Pair e1 (K e))
| ECTX_App1 K e2 : is_ectx K → is_ectx (λ e, App (K e) e2)
| ECTX_App2 e1 K : is_val e1 → is_ectx K → is_ectx (λ e, App e1 (K e))
| ECTX_TApp K : is_ectx K → is_ectx (λ e, TApp (K e))
| ECTX_Fold K : is_ectx K → is_ectx (λ e, Fold (K e))
| ECTX_Unfold K : is_ectx K → is_ectx (λ e, Unfold (K e)).

Local Hint Constructors is_ectx : is_ectx.

Lemma is_ectx_val : ∀ (e : expr) (K : expr → expr), is_ectx K → is_val (K e) → is_val e.
Proof.
  intros e K HK; revert e.
  induction HK; [trivial; fail|inversion 1; subst; auto .. ].
Qed.

Lemma is_val_dec e : is_val e ∨ ¬ is_val e.
Proof.
  induction e; try (right; inversion 1; fail).
  - left; constructor.
  - destruct IHe1; destruct IHe2; [left; constructor; auto; fail|right; inversion 1; tauto .. ].
  - left; constructor.
  - left; constructor.
  - destruct IHe; [left; constructor; assumption|right; inversion 1; subst; tauto].
Qed.

Lemma ectx_head_step K e e' : is_ectx K → head_step (K e) e' → (∀ f : expr, K f = f) ∨ is_val e.
Proof.
  intros HK; revert e e'.
  induction HK.
  - left; trivial.
  - inversion HK; inversion 1; subst; right; [econstructor; eauto|eapply is_ectx_val; eauto .. ].
  - inversion HK; inversion 1; subst; right; [econstructor; eauto|eapply is_ectx_val; eauto .. ].
  - inversion HK; inversion 1.
  - inversion HK; inversion 1.
  - inversion HK; inversion 1; subst; right; constructor.
  - inversion 1; subst; right; eapply is_ectx_val; eauto.
  - inversion HK;inversion 1; subst; right; constructor.
  - inversion HK;inversion 1; subst; right; constructor.
  - inversion HK;inversion 1; subst; right; [constructor; assumption|eapply is_ectx_val; eauto].
Qed.

Lemma ectx_inj K e e' : is_ectx K → K e = K e' → e = e'.
Proof.
  intros HK; revert e e'.
  induction HK; intros e e' Hee.
  - trivial.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
  - intros; assert (K e = K e') by congruence; auto.
Qed.

Lemma ectx_compose K K' : is_ectx K → is_ectx K' → is_ectx (λ e : expr, K (K' e)).
Proof.
  intros HK; revert K'.
  induction HK; [trivial| intros; econstructor; eauto .. ].
Qed.

Lemma ectxs_nesting K e K' e' :
  is_ectx K → is_ectx K' → K e = K' e' → ¬ is_val e → ¬ is_val e' →
  (∃ K'' : expr → expr, is_ectx K'' ∧ (∀ f : expr, K f = K' (K'' f)))
  ∨ (∃ K'' : expr → expr, is_ectx K'' ∧ (∀ f : expr, K' f = K (K'' f))).
Proof.
  intros HK; revert e e' K'.
  induction HK as [|?? IHK|?? IHK | K e2 ? IHK|e1 K Hval ? IHK|K e2 ? IHK|e1 K Hval ? IHK|
                    K HK IHK| K HK IHK|K HK IHK];
    intros e e' K' HK' Hee Hnve Hnve'.
  - right; exists K'; auto.
  - destruct HK'; [left; exists (λ e, Fst (K e)); auto with is_ectx; fail| |congruence ..].
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
      (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK'; [left; exists (λ e, Snd (K e)); auto with is_ectx; fail|
                    congruence| |congruence ..].
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption| assumption|left|right];
      (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK' as [| | | |? ? Hval | | | | |];
      [left; eexists (λ e, Pair (K e) e2); eauto with is_ectx; fail|
        congruence|congruence | | |congruence .. ].
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
        [congruence|assumption|assumption|left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
  - destruct HK'; [left; eexists (λ e, Pair e1 (K e)); eauto with is_ectx; fail|
        congruence|congruence | | |congruence .. ].
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
        [congruence|assumption|assumption|left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK' as [| | | | | |? ? Hval | | |];
      [left; exists (λ e, App (K e) e2); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence| | |congruence|congruence|congruence].
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
  - destruct HK';
      [left; exists (λ e, App e1 (K e)); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence| | |congruence|congruence|congruence].
    + simplify_eq Hee; intros; subst.
      apply is_ectx_val in Hval; tauto.
    + simplify_eq Hee; intros; subst.
      destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK';
      [left; exists (λ e, TApp (K e)); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence|congruence|congruence| |congruence|congruence].
    simplify_eq Hee; intros; subst.
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK';
      [left; exists (λ e, Fold (K e)); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence|congruence|congruence|congruence| |congruence].
    simplify_eq Hee; intros; subst.
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
  - destruct HK';
      [left; exists (λ e, Unfold (K e)); auto with is_ectx; fail|
        congruence|congruence| congruence|congruence|congruence|congruence|congruence|congruence|].
    simplify_eq Hee; intros; subst.
    destruct (IHK e e' _ HK') as [[K'' [? HK'']]|[K'' [? HK'']]];
      [congruence|assumption|assumption| left|right];
        (exists K''; split; [assumption|intros ?; rewrite HK''; trivial]).
Qed.

Global Instance stlc_valid_language : valid_language is_val is_ectx head_step.
Proof.
  split.
  - inversion 1; inversion 1.
  - apply is_ectx_val.
  - constructor.
  - apply is_val_dec.
  - apply ectx_head_step.
  - apply ectx_inj.
  - apply ectx_compose.
  - apply ectxs_nesting.
Qed.

Lemma det_head_step_fst v1 v2 : is_val v1 → is_val v2 → det_head_step (Fst (Pair v1 v2)) v1.
Proof.
  intros; split; [constructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_snd v1 v2 : is_val v1 → is_val v2 → det_head_step (Snd (Pair v1 v2)) v2.
Proof.
  intros; split; [constructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_app e v : is_val v → det_head_step (App (Lam e) v) e.[v/].
Proof.
  intros; split; [econstructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_tapp e : det_head_step (TApp (TLam e)) e.
Proof.
  intros; split; [econstructor; assumption| inversion 1; subst; reflexivity].
Qed.

Lemma det_head_step_unfold e : is_val e → det_head_step (Unfold (Fold e)) e.
Proof.
  intros; split; [econstructor; assumption| inversion 1; subst; reflexivity].
Qed.

Ltac solve_det_head_step :=
  solve [eapply det_head_step_fst; eassumption|
          eapply det_head_step_snd; eassumption|
          eapply det_head_step_app; eassumption|
          eapply det_head_step_tapp; eassumption|
          eapply det_head_step_unfold; eassumption].