(** *** Przemienność *)

Lemma and_comm :
  forall P Q : Prop, P /\ Q -> Q /\ P.
(* begin hide *)
Proof.
  destruct 1; split; assumption.
Qed.
(* end hide *)

Lemma or_comm :
  forall P Q : Prop, P \/ Q -> Q \/ P.
(* begin hide *)
Proof.
  destruct 1; [right | left]; assumption.
Qed.
(* end hide *)

(** *** Łączność *)

Lemma and_assoc :
  forall P Q R : Prop, P /\ (Q /\ R) <-> (P /\ Q) /\ R.
(* begin hide *)
Proof.
  split; intros.
    destruct H as [p [q r]]. repeat split; assumption.
    destruct H as [[p q] r]. repeat split; assumption.
Restart.
  split; intros; repeat
  match goal with
  | H : _ /\ _ |- _ => destruct H
  end; repeat split; assumption.
Qed.
(* end hide *)

Lemma or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
(* begin hide *)
Proof.
  split; intros.
    destruct H as [p | [q | r]].
      left. left. assumption.
      left. right. assumption.
      right. assumption.
    destruct H as [[p | q] | r].
      left. assumption.
      right. left. assumption.
      right. right. assumption.
Qed.
(* end hide *)

(** *** Rozdzielność *)

Lemma and_dist_or :
  forall P Q R : Prop, P /\ (Q \/ R) <-> (P /\ Q) \/ (P /\ R).
(* begin hide *)
Proof.
  split; intros.
    destruct H as [p [q | r]].
      left. split; assumption.
      right. split; assumption.
    destruct H as [[p q] | [p r]].
      split. assumption. left. assumption.
      split. assumption. right. assumption.
Qed.
(* end hide *)

Lemma or_dist_and :
  forall P Q R : Prop, P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
(* begin hide *)
Proof.
  split; intros.
    destruct H as [p | [q r]].
      split; left; assumption.
      split; right; assumption.
    destruct H as [[p1 | q] [p2 | r]].
      left. assumption.
      left. assumption.
      left. assumption.
      right. split; assumption.
Restart.
  split; intros.
    destruct H as [p | [q r]];
      split; ((left; assumption) || (right; assumption)).
    destruct H as [[p1 | q] [p2 | r]];
      ((left; assumption) || (right; split; assumption)).
Qed.
(* end hide *)

Lemma imp_dist_imp :
  forall P Q R : Prop, (P -> Q -> R) <-> ((P -> Q) -> (P -> R)).
(* begin hide *)
Proof.
  split; intros.
    apply H.
      assumption.
      apply H0. assumption.
    apply H.
      intro. assumption.
      assumption.
Restart.
  split; intros; apply H; intros; try apply H0; assumption.
Qed.
(* end hide *)

(** *** Kuryfikacja i dekuryfikacja *)

Lemma curry :
  forall P Q R : Prop, (P /\ Q -> R) -> (P -> Q -> R).
(* begin hide *)
Proof.
  intros; apply H; split; assumption.
Qed.
(* end hide *)

Lemma uncurry :
  forall P Q R : Prop, (P -> Q -> R) -> (P /\ Q -> R).
(* begin hide *)
Proof.
  intros * pqr pq.
  destruct pq as [p q].
  apply pqr.
    assumption.
    assumption.
Qed.
(* end hide *)

(** *** Prawa de Morgana *)

Lemma deMorgan_1 :
  forall P Q : Prop, ~ (P \/ Q) <-> ~ P /\ ~ Q.
(* begin hide *)
Proof.
  split.
    intro npq. split.
      intro p. apply npq. left. assumption.
      intro q. apply npq. right. assumption.
    intros npnq npq. destruct npnq as [np nq]. destruct npq.
      apply np. assumption.
      apply nq. assumption.
Qed.
(* end hide *)

Lemma deMorgan_2 :
  forall P Q : Prop, ~ P \/ ~ Q -> ~ (P /\ Q).
(* begin hide *)
Proof.
  intros * npnq pq.
  destruct pq as [p q].
  destruct npnq as [np | nq].
    apply np. assumption.
    apply nq. assumption.
Qed.
(* end hide *)

(** *** Niesprzeczność i zasada wyłączonego środka *)

Lemma noncontradiction' :
  forall P : Prop, ~ (P /\ ~ P).
(* begin hide *)
Proof.
  unfold not; intros. destruct H. apply H0. assumption.
Qed.
(* end hide *)

Lemma noncontradiction_v2 :
  forall P : Prop, ~ (P <-> ~ P).
(* begin hide *)
Proof.
  intros * H.
  destruct H as [lr rl].
  apply lr.
    apply rl. intro p. apply lr.
      assumption.
      assumption.
    apply rl. intro p. apply lr.
      assumption.
      assumption.
Qed.
(* end hide *)

Lemma em_irrefutable :
  forall P : Prop, ~ ~ (P \/ ~ P).
(* begin hide *)
Proof.
  intros * H.
  apply H.
  right. intro p.
  apply H.
  left. assumption.
Qed.
(* end hide *)

(** *** Elementy neutralne i absorbujące *)

Lemma and_False_r :
  forall P : Prop, P /\ False <-> False.
(* begin hide *)
Proof.
  split; intro H.
    destruct H. contradiction.
    contradiction.
Qed.
(* end hide *)

Lemma or_False_r :
  forall P : Prop, P \/ False <-> P.
(* begin hide *)
Proof.
  split.
    intro H. destruct H.
      assumption.
      contradiction.
    intro p. left. assumption.
Qed.
(* end hide *)

Lemma and_True_r :
  forall P : Prop, P /\ True <-> P.
(* begin hide *)
Proof.
  split.
    intro H. destruct H as [p t]. assumption.
    intro p. split.
      assumption.
      trivial.
Qed.
(* end hide *)

Lemma or_True_r :
  forall P : Prop, P \/ True <-> True.
(* begin hide *)
Proof.
  split.
    intros _. trivial.
    intros _. right. trivial.
Qed.
(* end hide *)

(** *** Inne *)

Lemma or_imp_and :
  forall P Q R : Prop, (P \/ Q -> R) <-> (P -> R) /\ (Q -> R).
(* begin hide *)
Proof.
  split.
    intro H. split.
      intro p. apply H. left. assumption.
      intro q. apply H. right. assumption.
    intros H1 H2. destruct H1 as [pr qr]. destruct H2 as [p | q].
      apply pr. assumption.
      apply qr. assumption.
Qed.
(* end hide *)

Lemma and_not_imp :
  forall P Q : Prop, P /\ ~ Q -> ~ (P -> Q).
(* begin hide *)
Proof.
  intros * H pq. destruct H as [p nq].
  apply nq. apply pq. assumption.
Qed.
(* end hide *)

Lemma or_not_imp :
  forall P Q : Prop, ~ P \/ Q -> (P -> Q).
(* begin hide *)
Proof.
  intros * H p. destruct H as [np | q].
    contradiction.
    assumption.
Qed.
(* end hide *)

Lemma contraposition :
  forall P Q : Prop, (P -> Q) -> (~ Q -> ~ P).
(* begin hide *)
Proof.
  intros * pq nq p. apply nq, pq, p.
Qed.
(* end hide *)

Lemma absurd :
  forall P Q : Prop, ~ P -> P -> Q.
(* begin hide *)
Proof.
  intros np p. contradiction.
Qed.
(* end hide *)

Lemma impl_and :
  forall P Q R : Prop, (P -> Q /\ R) -> ((P -> Q) /\ (P -> R)).
(* begin hide *)
Proof.
  split; intro H'; destruct (H H'); assumption.
Qed.
(* end hide *)

(** *** Projekcje *)

Lemma forall_and_proj1 :
  forall (A : Type) (P Q : A -> Prop),
    (forall x : A, P x /\ Q x) -> (forall x : A, P x).
(* begin hide *)
Proof.
  intros. destruct (H x). assumption.
Qed.
(* end hide *)

Lemma forall_and_proj2 :
  forall (A : Type) (P Q : A -> Prop),
    (forall x : A, P x /\ Q x) -> (forall x : A, Q x).
(* begin hide *)
Proof.
  intros. destruct (H x). assumption.
Qed.
(* end hide *)

(** *** Rozdzielność *)

Lemma forall_dist_and :
  forall (A : Type) (P Q : A -> Prop),
    (forall x : A, P x /\ Q x) <->
    (forall x : A, P x) /\ (forall x : A, Q x).
(* begin hide *)
Proof.
  split.
    intros. split.
      intros. destruct (H x). assumption.
      intros. destruct (H x). assumption.
    intros. split.
      destruct H. apply H.
      destruct H. apply H0.
Restart.
  split; intros; split; intros; try destruct H; try (destruct (H x));
  try assumption; try apply H; try apply H0.
Qed.
(* end hide *)

Lemma exists_dist_or :
  forall (A : Type) (P Q : A -> Prop),
    (exists x : A, P x \/ Q x) <->
    (exists x : A, P x) \/ (exists x : A, Q x).
(* begin hide *)
Proof.
  split; intros.
    destruct H as [x [HP | HQ]].
      left. exists x. assumption.
      right. exists x. assumption.
    destruct H as [[x HP] | [x HQ]].
      exists x. left. assumption.
      exists x. right. assumption.
Restart.
  split; intros.
    destruct H as [x [HP | HQ]];
      [left | right]; exists x; assumption.
    destruct H as [[x HP] | [x HQ]];
      exists x; [left | right]; assumption.
Qed.
(* end hide *)

Lemma ex_dist_and :
  forall (A : Type) (P Q : A -> Prop),
    (exists x : A, P x /\ Q x) ->
      (exists y : A, P y) /\ (exists z : A, Q z).
(* begin hide *)
Proof.
  intros. destruct H as [x H]. destruct H.
  split; exists x; assumption.
Qed.
(* end hide *)

(** *** Inne *)

Lemma forall_or_imp :
  forall (A : Type) (P Q : A -> Prop),
    (forall x : A, P x) \/ (forall x : A, Q x) ->
      forall x : A, P x \/ Q x.
(* begin hide *)
Proof.
  destruct 1; intros.
    left. apply H.
    right. apply H.
Restart.
  destruct 1; intros; [left | right]; apply H.
Qed.
(* end hide *)

Lemma forall_imp_imp :
  forall (A : Type) (P Q : A -> Prop),
    (forall x : A, P x -> Q x) ->
      (forall x : A, P x) -> (forall x : A, Q x).
(* begin hide *)
Proof.
  intros. apply H. apply H0.
Qed.
(* end hide *)

Lemma forall_inhabited_nondep :
  forall (A : Type) (R : Prop),
    A -> ((forall x : A, R) <-> R).
(* begin hide *)
Proof.
  split; intros.
    apply H. assumption.
    assumption.
Restart.
  split; intros; try apply H; assumption.
Qed.
(* end hide *)

Lemma forall_or_nondep :
  forall (A : Type) (P : A -> Prop) (Q : Prop),
    (forall x : A, P x) \/ Q -> (forall x : A, P x \/ Q).
(* begin hide *)
Proof.
  destruct 1; intros.
    left. apply H.
    right. assumption.
Qed.
(* end hide *)

Lemma forall_nondep_impl :
  forall (A : Type) (P : A -> Prop) (Q : Prop),
    (forall x : A, Q -> P x) <-> (Q -> forall x : A, P x).
(* begin hide *)
Proof.
  split; intros.
    apply H. assumption.
    apply H. assumption.
Restart.
  split; intros; apply H; assumption.
Qed.
(* end hide *)

(** * Inne *)

Lemma constructive_dilemma :
  forall P Q R S : Prop,
    (P -> R) -> (Q -> S) -> P \/ Q -> R \/ S.
(* begin hide *)
Proof.
  intros P Q R S PR QS H.
  destruct H as [p | q].
    left. apply PR. assumption.
    right. apply QS. assumption.
Qed.
(* end hide *)

Lemma destructive_dilemma :
  forall P Q R S : Prop,
    (P -> R) -> (Q -> S) -> ~ R \/ ~ S -> ~ P \/ ~ Q.
(* begin hide *)
Proof.
  intros P Q R S PR QS H.
  destruct H as [nr | ns].
    left. intro p. apply nr, PR. assumption.
    right. intro q. apply ns, QS. assumption.
Qed.
(* end hide *)

Lemma idempotency_of_entailment :
  forall P Q : Prop,
    (P -> Q) <-> (P -> P -> Q).
(* begin hide *)
Proof.
  split.
    intros pq p1 p2. apply pq. assumption.
    intros ppq p. apply ppq.
      assumption.
      assumption.
Qed.
(* end hide *)

(** ** Klasyczny rachunek zdań (i kwantyfikatorów) *)

Require Import Classical.

Lemma imp_and_or :
  forall P Q R : Prop,
    (P -> Q \/ R) -> ((P -> Q) \/ (P -> R)).
(* begin hide *)
Proof.
  intros. destruct (classic P) as [HP | HnotP].
    destruct (H HP); [left | right]; intro; assumption.
    left. intro. cut False.
      inversion 1.
      apply HnotP. apply H0.
Qed.
(* end hide *)

Lemma deMorgan_2_conv :
  forall P Q : Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
(* begin hide *)
Proof.
  intros P Q npq.
  destruct (classic P) as [p | np].
    destruct (classic Q) as [q | nq].
      contradiction npq. split; assumption.
      right. assumption.
    left. assumption.
Qed.
(* end hide *)

Lemma not_impl :
  forall P Q : Prop,
    ~ (P -> Q) -> P /\ ~ Q.
(* begin hide *)
Proof.
  intros * npq. split.
    destruct (classic P).
      assumption.
      exfalso. apply npq. intro p. contradiction.
    intro q. apply npq. intros _. assumption.
Qed.
(* end hide *)

Lemma impl_not_or :
  forall P Q : Prop,
    (P -> Q) -> (~ P \/ Q).
(* begin hide *)
Proof.
  intros P Q pq.
  destruct (classic P).
    right. apply pq. assumption.
    left. assumption.
Qed.
(* end hide *)

Lemma material_implication :
  forall P Q : Prop, (P -> Q) <-> (~P \/ Q).
(* begin hide *)
Proof.
  split; intros.
    destruct (classic P).
      right. apply H. assumption.
      left. intro. contradiction.
    destruct H.
      contradiction.
      assumption.
Qed.
(* end hide *)

Lemma contraposition_conv :
  forall P Q : Prop,
    (~ Q -> ~ P) -> (P -> Q).
(* begin hide *)
Proof.
  intros * qp p.
  destruct (classic Q).
    assumption.
    exfalso. apply qp; assumption.
Qed.
(* end hide *)

Lemma excluded_middle :
  forall P : Prop, P \/ ~P.
(* begin hide *)
Proof.
  apply classic.
Qed.
(* end hide *)

Lemma peirce :
  forall P Q : Prop, ((P -> Q) -> P) -> P.
(* begin hide *)
Proof.
  intros * pqp.
  destruct (classic P).
    assumption.
    apply pqp. intro p. contradiction.
Qed.
(* end hide *)


Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.

Class Equiv (A : Type) := equiv : relation A.
Infix "===" := equiv (at level 70, no associativity).

Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv.

(* allows setoid rewriting with types *)
Instance type_equiv {T} {e : Equiv T} {t : type T} : Equivalence equiv := eq_equiv.

(* setoid morphisms *)
Definition setoid_resp {T T'} (f : T -> T') `{e : type T} `{e' : type T'} :=
  forall x y, x === y -> f x === f y.

Record morphism T T' `{e : type T} `{e' : type T'} :=
  mkMorph {
    morph :> T -> T';
    morph_resp : setoid_resp morph}.

Implicit Arguments mkMorph [T T' e e0 e' e1].
Implicit Arguments morph_resp.

Infix "-s>" := morphism (at level 45, right associativity).
Ltac resp_set :=
  intros t1 t2 HEqt; repeat (intros ?); simpl in *; try rewrite !HEqt; reflexivity.

Section Morphisms.
  Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}.

  Global Instance morph_equiv : Equiv (S -s> T) :=
    fun f g => forall x, f x === g x.

  Global Instance morph_type : type (S -s> T).
  Proof.
    split.
      intros f x; reflexivity.
      intros f g HS x; symmetry; apply HS.
    intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
  Qed.

  Program Definition mcomp (f: T -s> U) (g: S -s> T) : (S -s> U) :=
    mkMorph (fun x => f (g x)) _.
  Next Obligation.
    intros x y HEq; apply f, g; assumption.
  Qed.

  Global Instance equiv_morph :
    Proper (equiv ==> equiv ==> equiv) (morph S T).
  Proof.
    intros f g HEq x y HEq'; etransitivity; [apply HEq | apply g, HEq'].
  Qed.

End Morphisms.

Infix "<<" := mcomp (at level 35).

Section MorphConsts.
  Context {S T U V} `{eS : type S} `{eT : type T} `{eU : type U} `{eV : type V}.

  Global Instance equiv_mcomp :
    Proper (equiv (A := T -s> U) ==> equiv ==> equiv) mcomp.
  Proof.
    intros f f' HEq g g' HEq' x; simpl; rewrite HEq, HEq'; reflexivity.
  Qed.

  Lemma mcomp_assoc
    (f: U -s> V) (g: T -s> U) (h: S -s> T) : f << (g << h) === (f << g) << h.
  Proof. intros x; reflexivity. Qed.

  Definition lift2s (f : S -> T -> U) p q : (S -s> T -s> U) :=
    mkMorph (fun x => mkMorph (f x) (p x)) q.

  Definition lift3s (f : S -> T -> U -> V) p q r : (S -s> T -s> U -s> V) :=
    mkMorph (fun x => mkMorph (fun y => mkMorph (f x y) (p x y)) (q x)) r.

End MorphConsts.

Instance Equiv_PropP : Equiv Prop := iff.
Instance type_PropP : type Prop := iff_equivalence.

Section SetoidProducts.
  Context {A B : Type} `{eA : type A} `{eB : type B}.

  Global Instance Equiv_prod : Equiv (A * B) :=
    fun p1 p2 => (fst p1 === fst p2) /\ (snd p1 === snd p2).

  Global Instance prod_proper : Proper (equiv ==> equiv ==> equiv) (@pair A B).
  Proof.
    intros a a' Ha b b' Hb; split; assumption.
  Qed.

  Global Instance type_prod : type (A * B).
  Proof.
    split.
      intros [a b]; split; reflexivity.
      intros [a1 b1] [a2 b2] [Ha Hb]; split; symmetry; assumption.
    intros [a1 b1] [a2 b2] [a3 b3] [Ha12 Hb12] [Ha23 Hb23];
      split; etransitivity; eassumption.
  Qed.

  Global Instance mfst_proper : Proper (equiv ==> equiv) (@fst A B).
  Proof.
    intros [a1 b1] [a2 b2] [Ha Hb]; assumption.
  Qed.

  Global Instance msnd_proper : Proper (equiv ==> equiv) (@snd A B).
  Proof.
    intros [a1 b1] [a2 b2] [Ha Hb]; assumption.
  Qed.

  Program Definition mfst : (A * B) -s> A :=
    mkMorph (fun p => fst p) _.
  Next Obligation. resp_set. Qed.

  Program Definition msnd : (A * B) -s> B :=
    mkMorph (fun p => snd p) _.
  Next Obligation. resp_set. Qed.

  Context {C} `{eC : type C}.

  Program Definition mprod (f: C -s> A) (g: C -s> B) : C -s> (A * B) :=
    mkMorph (fun c => (f c, g c)) _.
  Next Obligation. resp_set. Qed.

  Lemma mprod_unique (f: C -s> A) (g: C -s> B) (h: C -s> A * B) :
    mfst << h === f -> msnd << h === g -> h === mprod f g.
  Proof.
    intros HL HR x; split; simpl; [rewrite <- HL | rewrite <- HR]; reflexivity.
  Qed.

End SetoidProducts.

Section IndexedProducts.

  Record ttyp := {carr :> Type; eqc : Equiv carr; eqok : type carr}.
  Global Instance ttyp_proj_eq {A : ttyp} : Equiv A := eqc A.
  Global Instance ttyp_proj_prop {A : ttyp} : type A := eqok A.
  Context {I : Type} {P : I -> ttyp}.

  Global Program Instance Equiv_prodI : Equiv (forall i, P i) :=
    fun p p' : forall i, P i => (forall i : I, @equiv _ (eqc _) (p i) (p' i)).

  Global Instance type_prodI : type (forall i, P i).
  Proof.
    split.
      intros X x; reflexivity.
      intros X Y HS x; symmetry; apply HS.
    intros X Y Z HPQ HQR x; etransitivity; [apply HPQ | apply HQR].
  Qed.

  Program Definition mprojI (i : I) : (forall i, P i) -s> P i :=
    mkMorph (fun X => X i) _.
  Next Obligation.
    intros X Y HXY; apply HXY.
  Qed.

  Context {C : Type} `{eC : type C}.

  Program Definition mprodI (f : forall i, C -s> P i) : C -s> (forall i, P i) :=
    mkMorph (fun c i => f i c) _.
  Next Obligation. resp_set. Qed.

  Lemma mprod_projI (f : forall i, C -s> P i) i : mprojI i << mprodI f === f i.
  Proof. intros X; reflexivity. Qed.

  Lemma mprodI_unique (f : forall i, C -s> P i) (h : C -s> forall i, P i) :
    (forall i, mprojI i << h === f i) -> h === mprodI f.
  Proof.
    intros HEq x i; simpl; rewrite <- HEq; reflexivity.
  Qed.

End IndexedProducts.

Section Exponentials.

  Context {A B C D} `{eA : type A} `{eB : type B} `{eC : type C} `{eD : type D}.

  Program Definition comps : (B -s> C) -s> (A -s> B) -s> A -s> C :=
    lift2s (fun f g => f << g) _ _.
  Next Obligation. resp_set. Qed.
  Next Obligation. resp_set. Qed.

  Program Definition muncurry (f : A -s> B -s> C) : A * B -s> C :=
    mkMorph (fun p => f (fst p) (snd p)) _.
  Next Obligation. resp_set. Qed.

  Program Definition mcurry (f : A * B -s> C) : A -s> B -s> C :=
    lift2s (fun a b => f (a, b)) _ _.
  Next Obligation. resp_set. Qed.
  Next Obligation. resp_set. Qed.

  Definition mprod_map (f : A -s> C) (g : B -s> D) := mprod (f << mfst) (g << msnd).

  Program Definition meval : (B -s> A) * B -s> A :=
    mkMorph (fun p => fst p (snd p)) _.
  Next Obligation. resp_set. Qed.

  Program Definition mid : A -s> A := mkMorph (fun x => x) _.
  Next Obligation. resp_set. Qed.

  Program Definition mconst (b : B) : A -s> B := mkMorph (fun _ => b) _.
  Next Obligation. resp_set. Qed.

End Exponentials.

Section Exp_props.
  Context {A B C D} `{eA : type A} `{eB : type B} `{eC : type C} `{eD : type D}.

  Lemma mcurry_com (f : A * B -s> C) : f === meval << (mprod_map (mcurry f) mid).
  Proof. intros [a b]; reflexivity. Qed.

  Lemma mcurry_uniqe (f : A * B -s> C) h :
    f === meval << (mprod_map h mid) -> h === mcurry f.
  Proof. intros HEq a b; simpl; rewrite HEq; reflexivity. Qed.

End Exp_props.

Instance unit_Equiv : Equiv unit := (fun _ _ => True).
Instance unit_type : type unit.
Proof.
  split.
    intros x; exact I.
    intros x y _; exact I.
  intros x y z _ _; exact I.
Qed.

Inductive empty : Set := .
Instance empty_Equiv : Equiv empty := (fun _ _ => False).
Instance empty_type : type empty.
Proof.
  split; intros x; case x.
Qed.

Section Initials.
  Context {A} `{eA : type A}.

  Program Definition mzero_init : empty -s> A := mkMorph (fun x => match x with end) _.
  Next Obligation. intros x; case x; fail. Qed.

  Lemma mzero_init_unique (f g : empty -s> A) : f === g.
  Proof. intros x; case x. Qed.

End Initials.

Section Subsetoid.

  Context {A} `{eA : type A} {P : A -> Prop}.

  Global Instance subset_Equiv : Equiv {a : A | P a} :=
    fun x y => proj1_sig x === proj1_sig y.
  Global Instance subset_type : type {a : A | P a}.
  Proof.
    split.
      intros [x Hx]; red; red; reflexivity.
      intros [x Hx] [y Hy] HS; red; red; symmetry; exact HS.
    intros [x Hx] [y Hy] [z Hz] Hxy Hyz; red; red; etransitivity; [apply Hxy | apply Hyz].
  Qed.

  Global Instance proj1sig_proper :
    Proper (equiv (A := {a : A | P a}) ==> equiv (A := A)) (@proj1_sig A (fun x => P x)).
  Proof. intros [x Hx] [y Hy] HEq; simpl; apply HEq. Qed.

  Program Definition mforget : {a : A | P a} -s> A :=
    mkMorph (fun x => x) _.
  Next Obligation. resp_set. Qed.

  Context {B} `{eB : type B}.
  Program Definition minherit (f : B -s> A) (HB : forall b, P (f b)) : B -s> {a : A | P a} :=
    mkMorph (fun b => exist P (f b) (HB b)) _.
  Next Obligation.
    intros x y HEq; unfold equiv; red; simpl; rewrite HEq; reflexivity.
  Qed.

  Lemma mforget_mono (f g : B -s> {a : A | P a}) : mforget << f === mforget << g -> f === g.
  Proof.
    intros HEq x; red; red; simpl; rewrite (HEq x); reflexivity.
  Qed.

End Subsetoid.

Section Option.

  Context {A} `{eA : type A}.

  Global Instance option_Equiv : Equiv (option A) := fun x y =>
    match x, y with
      | None, None => True
      | Some x, Some y => x === y
      | _, _ => False
    end.

  Global Instance option_type : type (option A).
  Proof.
    split.
      intros [a |]; red; red; reflexivity.
      intros [a |] [b |] HS; red; red; exact I || contradiction HS || symmetry; exact HS.
    intros [a |] [b |] [c |] Hab Hbc; simpl in *; try (contradiction || exact I); [].
    red; red; etransitivity; [apply Hab | apply Hbc].
  Qed.

End Option.

Section OptDefs.
  Context {A B} `{eA : type A} `{eB : type B}.

  Global Instance Some_proper : Proper (equiv ==> equiv (A := option A)) (@Some A).
  Proof. intros a b HEq; simpl; apply HEq. Qed.

  Program Definition msome : A -s> option A := mkMorph (fun a => Some a) _.
  Next Obligation. resp_set. Qed.

  Program Definition moptionbind (f : A -s> option B) : option A -s> option B :=
    mkMorph (fun oa => match oa with None => None | Some a => f a end) _.
  Next Obligation.
    intros [x |] [y |] HEq; contradiction || trivial || apply f, HEq.
  Qed.

End OptDefs.


Require Import VST.floyd.proofauto.
Require Import VST.progs.dotprod.

Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

Fixpoint map2 {A B C: Type} (f: A -> B -> C) (al: list A) (bl: list B) : list C :=
 match al, bl with
  | a::al', b::bl' => f a b :: map2 f al' bl'
  | _, _ => nil
  end.

Definition add_spec :=
 DECLARE _add
  WITH x: val, y : val, z: val, fy : list float, fz: list float
  PRE  [ tptr tdouble, tptr tdouble, tptr tdouble]
      PROP ()
      PARAMS (x; y; z)
      SEP (data_at_ Tsh (tarray tdouble 3)  x ;
             data_at Tsh (tarray tdouble 3) (map Vfloat fy) y;
             data_at Tsh (tarray tdouble 3) (map Vfloat fz) z)
  POST [ tvoid ]
      PROP ()
      RETURN ()
      SEP (data_at Tsh (tarray tdouble 3) (map Vfloat (map2 Float.add fy fz)) x;
             data_at Tsh (tarray tdouble 3) (map Vfloat fy) y;
             data_at Tsh (tarray tdouble 3) (map Vfloat fz) z).

Definition dotprod (fx fy : list float) : float :=
  fold_left Float.add (map2 Float.mul fx fy) Float.zero .

Definition dotprod_spec :=
 DECLARE _dotprod
  WITH n: Z, x: val, y : val, fx : list float, fy: list float, sh: share
  PRE  [ tint, tptr tdouble, tptr tdouble]
      PROP (0 <= n < Int.max_signed)
      PARAMS (Vint (Int.repr n); x; y)
      SEP (data_at Tsh (tarray tdouble n) (map Vfloat fx) x;
             data_at Tsh (tarray tdouble n) (map Vfloat fy) y)
  POST [ tdouble ]
      PROP ()
      RETURN (Vfloat (dotprod fx fy))
      SEP (data_at Tsh (tarray tdouble n) (map Vfloat fx) x;
             data_at Tsh (tarray tdouble n) (map Vfloat fy) y).

Definition Gprog : funspecs :=   ltac:(with_library prog [add_spec; dotprod_spec]).

Lemma map2_app:
 forall (A B C: Type) (f: A -> B -> C) al al' bl bl',
  Zlength al = Zlength bl ->
  Zlength al' = Zlength bl' ->
   map2 f (al ++ al') (bl ++ bl') = map2 f al bl ++ map2 f al' bl'.
Proof.
intros.
rewrite !Zlength_correct in *.
apply Nat2Z.inj in H. apply Nat2Z.inj in H0.
revert bl H al' bl' H0; induction al; intros.
*
destruct bl; inv H.
simpl. auto.
*
destruct bl.
inv H.
simpl.
f_equal.
auto.
Qed.

Lemma Zlength_map2: forall A B C (f: A -> B -> C) fy fz,
  Zlength fy = Zlength fz -> Zlength (map2 f fy fz) = Zlength fy.
Proof.
intros.
rewrite !Zlength_correct in *.
apply Nat2Z.inj in H. f_equal.
revert fz H; induction fy; destruct fz; intros; inv H.
auto.
simpl. f_equal; auto.
Qed.

Lemma Znth_map2:
 forall A B C (a: Inhabitant A) (b: Inhabitant B) (c: Inhabitant C) (f: A -> B -> C) (al: list A) (bl: list B) i,
  Zlength al = Zlength bl ->
  0 <= i < Zlength al ->
  Znth i (map2 f al bl) = f (Znth i al) (Znth i bl).
Proof.
intros.
rewrite !Zlength_correct in *.
apply Nat2Z.inj in H. f_equal.
unfold Znth.
if_tac. lia.
assert (Z.to_nat i < length al)%nat.
rewrite <- (Nat2Z.id (length al)).
apply Z2Nat.inj_lt; try lia.
clear H0 H1.
forget (Z.to_nat i) as j. clear i.
revert al bl H H2; induction j; intros.
destruct al; inv H2.
destruct bl; inv H.
simpl. auto.
destruct bl; inv H.
simpl. auto.
destruct al; simpl in H2; try lia.
destruct bl; inv H.
simpl.
apply IHj; auto.
lia.
Qed.

Lemma body_dotprod:  semax_body Vprog Gprog f_dotprod dotprod_spec.
Proof.
start_function.
forward. (* sum = 0.0; *)
forward_for_simple_bound n
   (EX i:Z,
      PROP ()
      LOCAL (temp _sum (Vfloat (dotprod (sublist 0 i fx) (sublist 0 i fy))); temp _x x; temp _y y; temp _n (Vint (Int.repr n)))
      SEP (data_at Tsh (tarray tdouble n) (map Vfloat fx) x;
             data_at Tsh (tarray tdouble n) (map Vfloat fy) y)).
* (* initializer *)
entailer!.
* (* body *)
assert_PROP (Zlength fx = n /\ Zlength fy = n). {
    entailer!. autorewrite with sublist in *; split; auto.
} destruct H1.
forward.
forward.
rewrite !Znth_map by lia.
forward.
  entailer!.
  autorewrite with sublist in *.
  f_equal.
  rewrite (sublist_split 0 i _ fx) by lia.
  rewrite (sublist_split 0 i _ fy) by lia.
  unfold dotprod.
 rewrite map2_app by list_solve.
 rewrite fold_left_app.
 rewrite !sublist_len_1 by list_solve.
 simpl. auto.
*
 forward.
 autorewrite with sublist in *.
 autorewrite with sublist.
 entailer!.
Qed.

Lemma body_add:  semax_body Vprog Gprog f_add add_spec.
Proof.
start_function.
Hint Rewrite Zlength_map2 using (try Zlength_solve; fail 4) : Zlength.
pose (fx := map2 Float.add fy fz).
assert_PROP (Zlength fx = 3 /\ Zlength fy = 3 /\ Zlength fz = 3). {
  entailer!. subst fx. list_solve.
} destruct H as [Hx [Hy Hz]].
forward_for_simple_bound 3
   (EX i:Z,
      PROP ()
      LOCAL (temp _x x; temp _y y; temp _z z)
      SEP (data_at Tsh (tarray tdouble 3)
          (map Vfloat (sublist 0 i fx) ++ repeat Vundef (Z.to_nat (3-i))) x;
   data_at Tsh (tarray tdouble 3) (map Vfloat fy) y;
   data_at Tsh (tarray tdouble 3) (map Vfloat fz) z)).
* (* initializer *)
entailer!. simpl; entailer!.
* (* body *)
forward. (* x[i] = y[i] + z[i]; *)
forward.
forward.
entailer!. {
  simpl force_val.
  Hint Rewrite (Znth_map2 _ _ _ Inhabitant_float Inhabitant_float Inhabitant_float) using Zlength_solve : Znth.
  Hint Rewrite (@Znth_map _ Inhabitant_float) using Zlength_solve : Znth.
  subst fx. list_solve.
}
*
 forward.
 autorewrite with sublist. subst fx. auto.
Qed.

Definition Svector_add (n: Z) (_i _x _y _z : ident) :=
   Ssequence (Sset _i (Econst_int (Int.repr 0) tint))
     (Sloop
        (Ssequence
           (Sifthenelse
              (Ebinop Olt (Etempvar _i tint) (Econst_int (Int.repr n) tint) tint)
              Sskip
              Sbreak)
           (Sassign
              (Ederef
                 (Ebinop Oadd (Etempvar _x (tptr tdouble)) (Etempvar _i tint)
                    (tptr tdouble)) tdouble)
              (Ebinop Oadd
                 (Ederef
                    (Ebinop Oadd (Etempvar _y (tptr tdouble))
                       (Etempvar _i tint) (tptr tdouble)) tdouble)
                 (Ederef
                    (Ebinop Oadd (Etempvar _z (tptr tdouble))
                       (Etempvar _i tint) (tptr tdouble)) tdouble) tdouble)))
        (Sset _i
           (Ebinop Oadd (Etempvar _i tint) (Econst_int (Int.repr 1) tint)
              tint))).

Definition vector_add (fx fy: Z -> float) i :=
    Float.add (fx i) (fy i).


Require Export GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Tarski_dev.Ch06_out_lines.

Require Import Classical.

Section Dedekind_variant.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma dedekind_equiv : dedekind_s_axiom <-> dedekind_variant.
Proof.
  split; intros dede Alpha Beta.
    intros A C HA HC Hdij Hcut.
    apply dede.
    exists A.
    intros; apply Hcut; assumption.
  intros [A Hcut].
  destruct (classic (Beta A)) as [|HNA].
    exists A; intros X Y HX HY; assert (Bet A X A) by (apply Hcut; assumption); treat_equalities; Between.
  destruct (classic (exists C, Beta C)) as [[C HC]|HN];
    [|exists A; intros X Y HX HY; exfalso; apply HN; exists Y; apply HY].
  destruct (classic (exists P, Alpha P /\ Beta P)) as [[P []]|HNconj].
    exists P; intros; apply (between_exchange3 A); auto.
  destruct (classic (exists X, Alpha X /\ X <> A)) as [HAlpha|HN];
    [|exists A; intros X Y HX HY;
      destruct (eq_dec_points X A); [subst; Between|exfalso; apply HN; exists X; split; assumption]].
  pose (Alpha' := fun X' => X' = A \/ exists X, Alpha X /\ Bet A X' X).
  pose (Beta' := fun Y' => Out A Y' C /\ ~ exists X, Alpha X /\ Bet A Y' X).
  cut (exists B, forall X Y, Alpha' X -> Beta' Y -> Bet X B Y).
  { intros [B HB].
    exists B.
    intros X Y HX HY.
    apply HB.
      right; exists X; split; Between.
    clear X HX.
    split.
      destruct HAlpha as [X [HX HXA]].
      apply l6_7 with X; Out.
    intros [X [HX HAYX]].
    apply HNconj; exists Y.
    assert (Bet A X Y) by auto.
    treat_equalities; split; assumption.
  }
  apply (dede Alpha' Beta' A C).
  - left; reflexivity.
  - split.
      apply out_trivial; intro; subst; auto.
    intros [X [HX HACX]].
    apply HNconj; exists C.
    assert (C = X) by (apply (between_equality_2 A); auto).
    subst; split; assumption.
  - intros P HP.
    destruct (classic (exists X : Tpoint, Alpha X /\ Bet A P X)); [left; right|right; split]; auto.
  - intros X' Y' HX' [HY' HN].
    destruct (eq_dec_points X' A).
      subst; split; [Between|destruct HY'; auto].
    destruct HX' as [|[X [HX HAX'X]]]; [contradiction|].
    assert (HOut : Out A X' Y').
      assert (Bet A X C) by (apply Hcut; assumption).
      assert (A <> X) by (apply bet_neq21__neq with X'; assumption).
      apply l6_7 with X; [|apply l6_7 with C]; Out.
    assert (HOut' : Out Y' A X').
      apply not_bet_out; Col.
      intro; apply HN; exists X; split; [|apply between_exchange4 with X']; assumption.
    split.
      apply out2__bet; assumption.
    destruct HOut' as [_ []]; auto.
Qed.

End Dedekind_variant.


From Equations Require Import Equations.

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.

Require Export SystemFR.ErasedLet2.

Opaque reducible_values.
Opaque makeFresh.

Lemma reducible_refine:
  forall ρ t A b,
    [ ρ ⊨ t : A ] ->
    wf b 1 ->
    wf t 0 ->
    valid_interpretation ρ ->
    is_erased_term b ->
    fv b = nil ->
    (forall v,
      [ ρ ⊨ v : A ]v ->
      [ t ≡ v ] ->
      [ open 0 b v ≡ ttrue ]) ->
    [ ρ ⊨ t : T_refine A b ].
Proof.
  unfold reduces_to in *; repeat step;
    eauto with wf; eauto with fv.

  eexists; steps; eauto.
  repeat step || simp_red || apply equivalent_true || apply_any || apply equivalent_star;
    t_closer.
Qed.

Lemma open_reducible_refine:
  forall Θ Γ t A b x p,
    wf b 1 ->
    wf t 0 ->
    subset (fv t) (support Γ) ->
    ~(p ∈ fv b) ->
    ~(p ∈ fv t) ->
    ~(p ∈ fv A) ->
    ~(p ∈ fv_context Γ) ->
    ~(x ∈ fv b) ->
    ~(x ∈ fv A) ->
    ~(x ∈ fv_context Γ) ->
    ~(x = p) ->
    is_erased_term b ->
    subset (fv b) (support Γ) ->
    (forall ρ l,
        valid_interpretation ρ ->
        support ρ = Θ ->
        satisfies (reducible_values ρ) ((p,T_equiv (fvar x term_var) t) :: (x, A) :: Γ) l ->
        [ substitute (open 0 b (fvar x term_var)) l ≡ ttrue ]) ->
    [ Θ; Γ ⊨ t : A ] ->
    [ Θ; Γ ⊨ t : T_refine A b ].
Proof.
  unfold open_reducible; repeat step || t_instantiate_sat3.

  apply reducible_refine; steps; t_closer.

  unshelve epose proof (H12 ρ ((p, uu) :: (x,v) :: lterms) _ _ _);
    repeat step || apply SatCons || list_utils || t_substitutions || simp_red;
    eauto using equivalent_sym;
    eauto with fv wf twf.
Qed.

Lemma subtype_refine:
  forall ρ (Γ : context) A B p q (x : nat) t l,
    wf q 1 ->
    is_erased_term q ->
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv A) ->
    ~(x ∈ fv p) ->
    ~(x ∈ fv q) ->
    subset (fv q) (support Γ) ->
    valid_interpretation ρ ->
    (forall l,
        satisfies (reducible_values ρ) ((x, T_refine A p) :: Γ) l ->
        [ substitute (open 0 q (fvar x term_var)) l ≡ ttrue ]) ->
    (forall t l,
        satisfies (reducible_values ρ) Γ l ->
        [ ρ ⊨ t : substitute A l ]v -> [ ρ ⊨ t : substitute B l ]v) ->
    satisfies (reducible_values ρ) Γ l ->
    reducible_values ρ t (T_refine (substitute A l) (substitute p l)) ->
    reducible_values ρ t (T_refine (substitute B l) (substitute q l)).
Proof.
  repeat step || simp_red || unshelve eauto with wf erased fv.

  unshelve epose proof (H7 ((x,t) :: l) _);
    repeat step || apply SatCons || list_utils || t_substitutions || simp_red;
    eauto using equivalent_true;
    eauto with fv wf twf.
Qed.

Lemma subtype_refine4:
  forall ρ (Γ : context) T A p (x : nat) t l,
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv T) ->
    ~(x ∈ fv p) ->
    is_erased_term p ->
    wf p 1 ->
    subset (fv p) (support Γ) ->
    valid_interpretation ρ ->
    (forall l,
        satisfies (reducible_values ρ) ((x, T) :: Γ) l ->
        [ substitute (open 0 p (fvar x term_var)) l ≡ ttrue ]) ->
    (forall t l,
        satisfies (reducible_values ρ) Γ l ->
        [ ρ ⊨ t : substitute T l ]v -> [ ρ ⊨ t : substitute A l ]v) ->
      satisfies (reducible_values ρ) Γ l ->
      [ ρ ⊨ t : substitute T l ]v ->
      reducible_values ρ t (T_refine (substitute A l) (substitute p l)).
Proof.
  repeat step || simp_red || unshelve t_closer.

  unshelve epose proof (H6 ((x,t) :: l) _);
    repeat step || apply SatCons || list_utils || t_substitutions || simp_red;
    eauto using equivalent_true;
    eauto with fv wf twf.
Qed.

Lemma subtype_refine5:
  forall ρ Γ T A b (x p : nat) t l,
    ~(p ∈ fv_context Γ) ->
    ~(p ∈ fv A) ->
    ~(p ∈ fv T) ->
    ~(p ∈ fv b) ->
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv A) ->
    ~(x ∈ fv T) ->
    ~(x ∈ fv b) ->
    ~(x = p) ->
    [ support ρ; (p, T_equiv (open 0 b (fvar x term_var)) ttrue) :: (x, A) :: Γ ⊨
        fvar x term_var : T ] ->
    valid_interpretation ρ ->
    satisfies (reducible_values ρ) Γ l ->
    reducible_values ρ t (T_refine (substitute A l) (substitute b l)) ->
    [ ρ ⊨ t : substitute T l ]v.
Proof.
  unfold open_reducible; repeat step || simp_red; eauto with wf.

  unshelve epose proof (H8 ρ ((p, uu) :: (x,t) :: l) _ _ _);
    repeat step || apply SatCons || list_utils || t_substitutions || simp_red || fv_open;
    eauto with fv wf twf;
    eauto using red_is_val, reducible_expr_value;
    try solve [ equivalent_star ].
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 12: More on Evaluation Contexts
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(** * Evaluation Contexts for Lambda Calculus *)

(* Let's revisit the typed language from the end of the previous chapter, this
 * time casting its small-step semantics using evaluation contexts. *)

Module Stlc.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp).

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
    end.

  (* Here's the first difference from last chapter.  This is our grammar of
   * contexts.  Note a difference from the book: we don't enforce here that
   * the first argument of a [Plus1] or [App1] is a value, but rather that
   * constraint comes in the next relation definition. *)
  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context.

  (* Again, note how two of the rules include [value] premises. *)
  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e').

  (* Small-step, call-by-value evaluation, using our evaluation contexts *)

  (* First: the primitive reductions *)
  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
    step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2)).

  (* Then: running them in context *)
  Inductive step : exp -> exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

  (* It's easy to wrap everything as a transition system. *)
  Definition trsys_of (e : exp) := {|
    Initial := {e};
    Step := step
  |}.

  (* Typing details are the same as last chapter. *)
  Inductive type :=
  | Nat                  (* Numbers *)
  | Fun (dom ran : type) (* Functions *).

  Inductive has_ty : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> has_ty G (Var x) t
  | HtConst : forall G n,
    has_ty G (Const n) Nat
  | HtPlus : forall G e1 e2,
    has_ty G e1 Nat
    -> has_ty G e2 Nat
    -> has_ty G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    has_ty (G $+ (x, t1)) e1 t2
    -> has_ty G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    has_ty G e1 (Fun t1 t2)
    -> has_ty G e2 t1
    -> has_ty G (App e1 e2) t2.

  Local Hint Constructors value plug step0 step has_ty : core.

  (** * Now we adapt the automated proof of type soundness. *)

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : has_ty _ ?e _, H' : value ?e |- _ ] => invert H'; invert H
             | [ H : has_ty _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 6.

  Lemma progress : forall e t,
    has_ty $0 e t
    -> value e
    \/ (exists e' : exp, step e e').
  Proof.
    induct 1; t.
  Qed.

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  Local Hint Resolve weakening_override : core.

  Lemma weakening : forall G e t,
    has_ty G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> has_ty G' e t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve weakening : core.

  (* Replacing a typing context with an equal one has no effect (useful to guide
   * proof search as a hint). *)
  Lemma has_ty_change : forall G e t,
    has_ty G e t
    -> forall G', G' = G
      -> has_ty G' e t.
  Proof.
    t.
  Qed.

  Local Hint Resolve has_ty_change : core.

  Lemma substitution : forall G x t' e t e',
    has_ty (G $+ (x, t')) e t
    -> has_ty $0 e' t'
    -> has_ty G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve substitution : core.

  Lemma preservation0 : forall e1 e2,
    step0 e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation0 : core.

  Lemma preservation' : forall C e1 e1',
      plug C e1 e1'
      -> forall e2 e2' t, plug C e2 e2'
      -> step0 e1 e2
      -> has_ty $0 e1' t
      -> has_ty $0 e2' t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve preservation' : core.

  Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve progress preservation : core.

  Theorem safety : forall e t, has_ty $0 e t
    -> invariantFor (trsys_of e)
                    (fun e' => value e'
                               \/ exists e'', step e' e'').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun e' => has_ty $0 e' t); eauto.
    apply invariant_induction; simplify; eauto; equality.
  Qed.

  (* It may not be obvious that this way of defining the semantics gives us a
   * unique evaluation sequence for every well-typed program.  Let's prove
   * it. *)

  Lemma plug_not_value : forall C e v,
      value v
      -> plug C e v
      -> C = Hole /\ e = v.
  Proof.
    invert 1; invert 1; auto.
  Qed.

  Lemma step0_value : forall v e,
      value v
      -> step0 v e
      -> False.
  Proof.
    invert 1; invert 1.
  Qed.

  Lemma plug_det : forall C e1 e2 e1' f1 f1',
      step0 e1 e1'
      -> step0 f1 f1'
      -> plug C e1 e2
      -> forall C', plug C' f1 e2
      -> C = C' /\ e1 = f1.
  Proof.
    induct 3; invert 1;
      repeat match goal with
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => eapply plug_not_value in H; [ | solve [ eauto ] ];
                                            propositional; subst
             | [ IH : step0 _ _ -> _, H : plug _ _ _ |- _ ] => eapply IH in H; [ | solve [ auto ] ];
                                                                 equality
             | [ _ : value ?v, _ : step0 ?v _ |- _ ] => exfalso; eapply step0_value; eauto
             end; equality.
  Qed.

  Lemma step0_det : forall e e', step0 e e'
                                 -> forall e'', step0 e e''
                                                -> e' = e''.
  Proof.
    invert 1; invert 1; auto.
  Qed.

  Lemma plug_func : forall C e e1,
      plug C e e1
      -> forall e2, plug C e e2
                    -> e1 = e2.
  Proof.
    induct 1; invert 1; auto; f_equal; auto.
  Qed.

  Theorem deterministic : forall e e', step e e'
                                       -> forall e'', step e e''
                                                      -> e' = e''.
  Proof.
    invert 1; invert 1.

    assert (C = C0 /\ e1 = e0) by (eapply plug_det; eassumption).
    propositional; subst.
    assert (e2 = e3) by (eapply step0_det; eassumption).
    subst.
    eapply plug_func; eassumption.
  Qed.
End Stlc.

(** * Some More Classic Features *)

(* Here's how easy it is to extend those definitions and proofs to two other
 * common features of functional-programming languages.  We'll use comments to
 * mark the only places where code is added.  Very little old code needs to be
 * changed!  The version in the book PDF shows even more clearly how evaluation
 * contexts make for compact descriptions of features, since here we are
 * manually writing [plug] relations, following clear conventions in
 * evaluation-context grammars. *)

Module StlcPairs.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)

  (* We can combine two values together into a pair, and then we can use
   * projection functions to retrieve the first and second components,
   * respectively. *)
  | Pair (e1 e2 : exp)
  | Fst (e1 : exp)
  | Snd (e2 : exp).

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1)
  (* A pair of values is a value.  (Now this relation finally becomes
   * recursive.) *)
  | VPair : forall v1 v2, value v1 -> value v2 -> value (Pair v1 v2).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
      (* Some bureaucratic work here to add predictable cases *)
      | Pair e2' e2'' => Pair (subst e1 x e2') (subst e1 x e2'')
      | Fst e2' => Fst (subst e1 x e2')
      | Snd e2' => Snd (subst e1 x e2')
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context
  (* Two new context kinds, indicating left-to-right evaluation order for
   * pairs *)
  | Pair1 : context -> exp -> context
  | Pair2 : exp -> context -> context
  (* And similar for projections *)
  | Fst1 : context -> context
  | Snd1 : context -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')

  (* Our new plugging rules *)
  | PlugPair1 : forall e e' C e2,
    plug C e e'
    -> plug (Pair1 C e2) e (Pair e' e2)
  | PlugPair2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Pair2 v1 C) e (Pair v1 e')
  | PlugFst1 : forall e e' C,
    plug C e e'
    -> plug (Fst1 C) e (Fst e')
  | PlugSnd1 : forall e e' C,
    plug C e e'
    -> plug (Snd1 C) e (Snd e').

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
      step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))

  (* Reducing projections *)
  | FstPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Fst (Pair v1 v2)) v1
  | SndPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Snd (Pair v1 v2)) v2.

  Inductive step : exp -> exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

  Definition trsys_of (e : exp) := {|
    Initial := {e};
    Step := step
  |}.

  Inductive type :=
  | Nat
  | Fun (dom ran : type)
  | Prod (t1 t2 : type) (* "Prod" for "product," as in Cartesian product *).

  Inductive has_ty : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> has_ty G (Var x) t
  | HtConst : forall G n,
    has_ty G (Const n) Nat
  | HtPlus : forall G e1 e2,
    has_ty G e1 Nat
    -> has_ty G e2 Nat
    -> has_ty G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    has_ty (G $+ (x, t1)) e1 t2
    -> has_ty G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    has_ty G e1 (Fun t1 t2)
    -> has_ty G e2 t1
    -> has_ty G (App e1 e2) t2
  | HtPair : forall G e1 e2 t1 t2,
    has_ty G e1 t1
    -> has_ty G e2 t2
    -> has_ty G (Pair e1 e2) (Prod t1 t2)
  | HtFst : forall G e1 t1 t2,
    has_ty G e1 (Prod t1 t2)
    -> has_ty G (Fst e1) t1
  | HtSnd : forall G e1 t1 t2,
    has_ty G e1 (Prod t1 t2)
    -> has_ty G (Snd e1) t2.

  Local Hint Constructors value plug step0 step has_ty : core.

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : has_ty _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; []
               (* Change here!  We need to enforce there is at most one
                * remaining subgoal, or we'll keep doing useless [value]
                * inversions ad infinitum. *)
             | [ H : has_ty _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 6.

  Lemma progress : forall e t,
    has_ty $0 e t
    -> value e
    \/ (exists e' : exp, step e e').
  Proof.
    induct 1; t.
  Qed.

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  Local Hint Resolve weakening_override : core.

  Lemma weakening : forall G e t,
    has_ty G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> has_ty G' e t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve weakening : core.

  (* Replacing a typing context with an equal one has no effect (useful to guide
   * proof search as a hint). *)
  Lemma has_ty_change : forall G e t,
    has_ty G e t
    -> forall G', G' = G
      -> has_ty G' e t.
  Proof.
    t.
  Qed.

  Local Hint Resolve has_ty_change : core.

  Lemma substitution : forall G x t' e t e',
    has_ty (G $+ (x, t')) e t
    -> has_ty $0 e' t'
    -> has_ty G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve substitution : core.

  Lemma preservation0 : forall e1 e2,
    step0 e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation0 : core.

  Lemma preservation' : forall C e1 e1',
      plug C e1 e1'
      -> forall e2 e2' t, plug C e2 e2'
      -> step0 e1 e2
      -> has_ty $0 e1' t
      -> has_ty $0 e2' t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve preservation' : core.

  Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve progress preservation : core.

  Theorem safety : forall e t, has_ty $0 e t
    -> invariantFor (trsys_of e)
                    (fun e' => value e'
                               \/ exists e'', step e' e'').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun e' => has_ty $0 e' t); eauto.
    apply invariant_induction; simplify; eauto; equality.
  Qed.
End StlcPairs.

(* Next, the dual feature of *variants*, corresponding to the following type
 * family from Coq's standard library. *)

Print sum.

Module StlcSums.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)
  | Pair (e1 e2 : exp)
  | Fst (e1 : exp)
  | Snd (e2 : exp)

  (* New cases: *)
  | Inl (e1 : exp)
  | Inr (e2 : exp)
  | Match (e' : exp) (x1 : var) (e1 : exp) (x2 : var) (e2 : exp).
  (* The last one roughly means "match e' with inl x1 => e1 | inr x2 => e2". *)

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1)
  | VPair : forall v1 v2, value v1 -> value v2 -> value (Pair v1 v2)
  | VInl : forall v, value v -> value (Inl v)
  | VInr : forall v, value v -> value (Inr v).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
      | Pair e2' e2'' => Pair (subst e1 x e2') (subst e1 x e2'')
      | Fst e2' => Fst (subst e1 x e2')
      | Snd e2' => Snd (subst e1 x e2')
      (* Some bureaucratic work here to add predictable cases *)
      | Inl e2' => Inl (subst e1 x e2')
      | Inr e2' => Inr (subst e1 x e2')
      | Match e2' x1 e21 x2 e22 => Match (subst e1 x e2')
                                         x1 (if x1 ==v x then e21 else subst e1 x e21)
                                         x2 (if x2 ==v x then e22 else subst e1 x e22)
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context
  | Pair1 : context -> exp -> context
  | Pair2 : exp -> context -> context
  | Fst1 : context -> context
  | Snd1 : context -> context

  (* New cases: *)
  | Inl1 : context -> context
  | Inr1 : context -> context
  | Match1 : context -> var -> exp -> var -> exp -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')
  | PlugPair1 : forall e e' C e2,
    plug C e e'
    -> plug (Pair1 C e2) e (Pair e' e2)
  | PlugPair2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Pair2 v1 C) e (Pair v1 e')
  | PlugFst1 : forall e e' C,
    plug C e e'
    -> plug (Fst1 C) e (Fst e')
  | PlugSnd1 : forall e e' C,
    plug C e e'
    -> plug (Snd1 C) e (Snd e')

  (* Our new plugging rules *)
  | PlugInl1 : forall e e' C,
    plug C e e'
    -> plug (Inl1 C) e (Inl e')
  | PlugInr1 : forall e e' C,
    plug C e e'
    -> plug (Inr1 C) e (Inr e')
  | PluMatch1 : forall e e' C x1 e1 x2 e2,
    plug C e e'
    -> plug (Match1 C x1 e1 x2 e2) e (Match e' x1 e1 x2 e2).

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
      step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))
  | FstPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Fst (Pair v1 v2)) v1
  | SndPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Snd (Pair v1 v2)) v2

  (* Reducing a [Match] *)
  | MatchInl : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inl v) x1 e1 x2 e2) (subst v x1 e1)
  | MatchInr : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inr v) x1 e1 x2 e2) (subst v x2 e2).

  Inductive step : exp -> exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

  Definition trsys_of (e : exp) := {|
    Initial := {e};
    Step := step
  |}.

  Inductive type :=
  | Nat
  | Fun (dom ran : type)
  | Prod (t1 t2 : type)
  (* New case: *)
  | Sum (t1 t2 : type).

  Inductive has_ty : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> has_ty G (Var x) t
  | HtConst : forall G n,
    has_ty G (Const n) Nat
  | HtPlus : forall G e1 e2,
    has_ty G e1 Nat
    -> has_ty G e2 Nat
    -> has_ty G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    has_ty (G $+ (x, t1)) e1 t2
    -> has_ty G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    has_ty G e1 (Fun t1 t2)
    -> has_ty G e2 t1
    -> has_ty G (App e1 e2) t2
  | HtPair : forall G e1 e2 t1 t2,
    has_ty G e1 t1
    -> has_ty G e2 t2
    -> has_ty G (Pair e1 e2) (Prod t1 t2)
  | HtFst : forall G e1 t1 t2,
    has_ty G e1 (Prod t1 t2)
    -> has_ty G (Fst e1) t1
  | HtSnd : forall G e1 t1 t2,
    has_ty G e1 (Prod t1 t2)
    -> has_ty G (Snd e1) t2

  (* New cases: *)
  | HtInl : forall G e1 t1 t2,
      has_ty G e1 t1
      -> has_ty G (Inl e1) (Sum t1 t2)
  | HtInr : forall G e1 t1 t2,
      has_ty G e1 t2
      -> has_ty G (Inr e1) (Sum t1 t2)
  | HtMatch : forall G e t1 t2 x1 e1 x2 e2 t,
      has_ty G e (Sum t1 t2)
      -> has_ty (G $+ (x1, t1)) e1 t
      -> has_ty (G $+ (x2, t2)) e2 t
      -> has_ty G (Match e x1 e1 x2 e2) t.

  Local Hint Constructors value plug step0 step has_ty : core.

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : has_ty _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; []

             (* New case!  For sums, we sometimes need to consider two rules for
              * one [value] inversion. *)
             | [ H : has_ty _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; [|]

             | [ H : has_ty _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 7.
                                                                 (* change! --^ *)

  Lemma progress : forall e t,
    has_ty $0 e t
    -> value e
    \/ (exists e' : exp, step e e').
  Proof.
    induct 1; t.
  Qed.

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  Local Hint Resolve weakening_override : core.

  Lemma weakening : forall G e t,
    has_ty G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> has_ty G' e t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve weakening : core.

  (* Replacing a typing context with an equal one has no effect (useful to guide
   * proof search as a hint). *)
  Lemma has_ty_change : forall G e t,
    has_ty G e t
    -> forall G', G' = G
      -> has_ty G' e t.
  Proof.
    t.
  Qed.

  Local Hint Resolve has_ty_change : core.

  Lemma substitution : forall G x t' e t e',
    has_ty (G $+ (x, t')) e t
    -> has_ty $0 e' t'
    -> has_ty G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve substitution : core.

  Lemma preservation0 : forall e1 e2,
    step0 e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation0 : core.

  Lemma preservation' : forall C e1 e1',
      plug C e1 e1'
      -> forall e2 e2' t, plug C e2 e2'
      -> step0 e1 e2
      -> has_ty $0 e1' t
      -> has_ty $0 e2' t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve preservation' : core.

  Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve progress preservation : core.

  Theorem safety : forall e t, has_ty $0 e t
    -> invariantFor (trsys_of e)
                    (fun e' => value e'
                               \/ exists e'', step e' e'').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun e' => has_ty $0 e' t); eauto.
    apply invariant_induction; simplify; eauto; equality.
  Qed.
End StlcSums.

(** * Exceptions *)

(* Evaluation contexts are very helpful for concise modeling of control-flow
 * constructs like exceptions.  Let's look at an example where exceptions are
 * just numbers, for simplicity. *)

Module StlcExceptions.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)
  | Pair (e1 e2 : exp)
  | Fst (e1 : exp)
  | Snd (e2 : exp)
  | Inl (e1 : exp)
  | Inr (e2 : exp)
  | Match (e' : exp) (x1 : var) (e1 : exp) (x2 : var) (e2 : exp)

  | Throw (e1 : exp)
  | Catch (e1 : exp) (x : var) (e2 : exp).
  (* The last one roughly means "try e1 catch x => e2". *)

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1)
  | VPair : forall v1 v2, value v1 -> value v2 -> value (Pair v1 v2)
  | VInl : forall v, value v -> value (Inl v)
  | VInr : forall v, value v -> value (Inr v).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
      | Pair e2' e2'' => Pair (subst e1 x e2') (subst e1 x e2'')
      | Fst e2' => Fst (subst e1 x e2')
      | Snd e2' => Snd (subst e1 x e2')
      | Inl e2' => Inl (subst e1 x e2')
      | Inr e2' => Inr (subst e1 x e2')
      | Match e2' x1 e21 x2 e22 => Match (subst e1 x e2')
                                         x1 (if x1 ==v x then e21 else subst e1 x e21)
                                         x2 (if x2 ==v x then e22 else subst e1 x e22)

      (* New cases: *)
      | Throw e2' => Throw (subst e1 x e2')
      | Catch e2' x1 e2'' => Catch (subst e1 x e2')
                                   x1 (if x1 ==v x then e2'' else subst e1 x e2'')
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context
  | Pair1 : context -> exp -> context
  | Pair2 : exp -> context -> context
  | Fst1 : context -> context
  | Snd1 : context -> context
  | Inl1 : context -> context
  | Inr1 : context -> context
  | Match1 : context -> var -> exp -> var -> exp -> context

  (* New cases: *)
  | Throw1 : context -> context
  | Catch1 : context -> var -> exp -> context.

  (* We modify [plug] with a new Boolean argument, to control whether [Catch1]
   * context kinds are allowed. *)
  Inductive plug : bool -> context -> exp -> exp -> Prop :=
  | PlugHole : forall ac e, plug ac Hole e e
  | PlugPlus1 : forall ac e e' C e2,
    plug ac C e e'
    -> plug ac (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall ac e e' v1 C,
    value v1
    -> plug ac C e e'
    -> plug ac (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall ac e e' C e2,
    plug ac C e e'
    -> plug ac (App1 C e2) e (App e' e2)
  | PlugApp2 : forall ac e e' v1 C,
    value v1
    -> plug ac C e e'
    -> plug ac (App2 v1 C) e (App v1 e')
  | PlugPair1 : forall ac e e' C e2,
    plug ac C e e'
    -> plug ac (Pair1 C e2) e (Pair e' e2)
  | PlugPair2 : forall ac e e' v1 C,
    value v1
    -> plug ac C e e'
    -> plug ac (Pair2 v1 C) e (Pair v1 e')
  | PlugFst1 : forall ac e e' C,
    plug ac C e e'
    -> plug ac (Fst1 C) e (Fst e')
  | PlugSnd1 : forall ac e e' C,
    plug ac C e e'
    -> plug ac (Snd1 C) e (Snd e')
  | PlugInl1 : forall ac e e' C,
    plug ac C e e'
    -> plug ac (Inl1 C) e (Inl e')
  | PlugInr1 : forall ac e e' C,
    plug ac C e e'
    -> plug ac (Inr1 C) e (Inr e')
  | PluMatch1 : forall ac e e' C x1 e1 x2 e2,
    plug ac C e e'
    -> plug ac (Match1 C x1 e1 x2 e2) e (Match e' x1 e1 x2 e2)
  | PlugThrow1 : forall ac e e' C,
    plug ac C e e'
    -> plug ac (Throw1 C) e (Throw e')
  | PlugCatch1 : forall e e' C x1 e1,
    plug true C e e'
    -> plug true (Catch1 C x1 e1) e (Catch e' x1 e1).

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
      step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))
  | FstPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Fst (Pair v1 v2)) v1
  | SndPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Snd (Pair v1 v2)) v2
  | MatchInl : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inl v) x1 e1 x2 e2) (subst v x1 e1)
  | MatchInr : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inr v) x1 e1 x2 e2) (subst v x2 e2)

  | ThrowBubble : forall v C e,
      plug false C (Throw v) e
      -> value v
      -> C <> Hole
      -> step0 e (Throw v)
  | CatchValue : forall v x1 e1,
      value v
      -> step0 (Catch v x1 e1) v
  | CatchThrow : forall v x1 e1,
      value v
      -> step0 (Catch (Throw v) x1 e1) (subst v x1 e1).

  Inductive step : exp -> exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2',
    plug true C e1 e1'
    -> plug true C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

  Definition trsys_of (e : exp) := {|
    Initial := {e};
    Step := step
  |}.

  Inductive type :=
  | Nat
  | Fun (dom ran : type)
  | Prod (t1 t2 : type)
  | Sum (t1 t2 : type).

  Inductive has_ty : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> has_ty G (Var x) t
  | HtConst : forall G n,
    has_ty G (Const n) Nat
  | HtPlus : forall G e1 e2,
    has_ty G e1 Nat
    -> has_ty G e2 Nat
    -> has_ty G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    has_ty (G $+ (x, t1)) e1 t2
    -> has_ty G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    has_ty G e1 (Fun t1 t2)
    -> has_ty G e2 t1
    -> has_ty G (App e1 e2) t2
  | HtPair : forall G e1 e2 t1 t2,
    has_ty G e1 t1
    -> has_ty G e2 t2
    -> has_ty G (Pair e1 e2) (Prod t1 t2)
  | HtFst : forall G e1 t1 t2,
    has_ty G e1 (Prod t1 t2)
    -> has_ty G (Fst e1) t1
  | HtSnd : forall G e1 t1 t2,
    has_ty G e1 (Prod t1 t2)
    -> has_ty G (Snd e1) t2
  | HtInl : forall G e1 t1 t2,
      has_ty G e1 t1
      -> has_ty G (Inl e1) (Sum t1 t2)
  | HtInr : forall G e1 t1 t2,
      has_ty G e1 t2
      -> has_ty G (Inr e1) (Sum t1 t2)
  | HtMatch : forall G e t1 t2 x1 e1 x2 e2 t,
      has_ty G e (Sum t1 t2)
      -> has_ty (G $+ (x1, t1)) e1 t
      -> has_ty (G $+ (x2, t2)) e2 t
      -> has_ty G (Match e x1 e1 x2 e2) t

  (* New cases: *)
  | HtThrow : forall G e1 t,
      has_ty G e1 Nat
      -> has_ty G (Throw e1) t
  | HtCatch : forall G e x1 e1 t,
      has_ty G e t
      -> has_ty (G $+ (x1, Nat)) e1 t
      -> has_ty G (Catch e x1 e1) t.

  Local Hint Constructors value plug step0 step has_ty : core.

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : has_ty _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; []

             | [ H : has_ty _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; [|]

             | [ H : has_ty _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ _ |- _ ] => invert1 H (* added an underscore *)
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 7.

  Local Hint Extern 1 (_ <> Hole) => equality : core.

  Lemma progress : forall e t,
    has_ty $0 e t
    -> value e
    \/ (exists n : nat, e = Throw (Const n))
    \/ (exists e' : exp, step e e').
  Proof.
    induct 1; t.
  Qed.

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  Local Hint Resolve weakening_override : core.

  Lemma weakening : forall G e t,
    has_ty G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> has_ty G' e t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve weakening : core.

  (* Replacing a typing context with an equal one has no effect (useful to guide
   * proof search as a hint). *)
  Lemma has_ty_change : forall G e t,
    has_ty G e t
    -> forall G', G' = G
      -> has_ty G' e t.
  Proof.
    t.
  Qed.

  Local Hint Resolve has_ty_change : core.

  Lemma substitution : forall G x t' e t e',
    has_ty (G $+ (x, t')) e t
    -> has_ty $0 e' t'
    -> has_ty G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve substitution : core.

  Lemma throw_well_typed : forall C v e,
      plug false C (Throw v) e
      -> forall t, has_ty $0 e t
      -> has_ty $0 v Nat.
  Proof.
    induct 1; invert 1; t.
  Qed.

  Local Hint Resolve throw_well_typed : core.

  Lemma preservation0 : forall e1 e2,
    step0 e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation0 : core.

  Lemma preservation' : forall C e1 e1',
      plug true C e1 e1'
      -> forall e2 e2' t, plug true C e2 e2'
      -> step0 e1 e2
      -> has_ty $0 e1' t
      -> has_ty $0 e2' t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve preservation' : core.

  Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, has_ty $0 e1 t
      -> has_ty $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve progress preservation : core.

  Theorem safety : forall e t, has_ty $0 e t
    -> invariantFor (trsys_of e)
                    (fun e' => value e'
                               \/ (exists n, e' = Throw (Const n))
                               \/ exists e'', step e' e'').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun e' => has_ty $0 e' t); eauto.
    apply invariant_induction; simplify; eauto; equality.
  Qed.
End StlcExceptions.

(** * Mutable Variables *)

(* Let's show how to add in another classic language feature, showing off how
 * abstracting with the idea of evaluation contexts saves us a lot of effort
 * adapting old definitions.  So far, variables have been read-only, but we can
 * easily enough make them mutable.  The types of some of our relations will
 * change, but surprisingly much will remain intact. *)

Module StlcMutable.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)
  | Pair (e1 e2 : exp)
  | Fst (e1 : exp)
  | Snd (e2 : exp)
  | Inl (e1 : exp)
  | Inr (e2 : exp)
  | Match (e' : exp) (x1 : var) (e1 : exp) (x2 : var) (e2 : exp)

  (* New cases: *)
  | GetVar (x : var)
  | SetVar (x : var) (e : exp).
  (* Note that we are distinguishing between mutable and immutable variables,
   * keeping the latter to bind in [Abs] and [Match]. *)

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1)
  | VPair : forall v1 v2, value v1 -> value v2 -> value (Pair v1 v2)
  | VInl : forall v, value v -> value (Inl v)
  | VInr : forall v, value v -> value (Inr v).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
      | Pair e2' e2'' => Pair (subst e1 x e2') (subst e1 x e2'')
      | Fst e2' => Fst (subst e1 x e2')
      | Snd e2' => Snd (subst e1 x e2')
      | Inl e2' => Inl (subst e1 x e2')
      | Inr e2' => Inr (subst e1 x e2')
      | Match e2' x1 e21 x2 e22 => Match (subst e1 x e2')
                                         x1 (if x1 ==v x then e21 else subst e1 x e21)
                                         x2 (if x2 ==v x then e22 else subst e1 x e22)
      | GetVar y => GetVar y
      | SetVar y e2' => SetVar y (subst e1 x e2')
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context
  | Pair1 : context -> exp -> context
  | Pair2 : exp -> context -> context
  | Fst1 : context -> context
  | Snd1 : context -> context
  | Inl1 : context -> context
  | Inr1 : context -> context
  | Match1 : context -> var -> exp -> var -> exp -> context
  (* New case: *)
  | SetVar1 : var -> context -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')
  | PlugPair1 : forall e e' C e2,
    plug C e e'
    -> plug (Pair1 C e2) e (Pair e' e2)
  | PlugPair2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Pair2 v1 C) e (Pair v1 e')
  | PlugFst1 : forall e e' C,
    plug C e e'
    -> plug (Fst1 C) e (Fst e')
  | PlugSnd1 : forall e e' C,
    plug C e e'
    -> plug (Snd1 C) e (Snd e')
  | PlugInl1 : forall e e' C,
    plug C e e'
    -> plug (Inl1 C) e (Inl e')
  | PlugInr1 : forall e e' C,
    plug C e e'
    -> plug (Inr1 C) e (Inr e')
  | PluMatch1 : forall e e' C x1 e1 x2 e2,
    plug C e e'
    -> plug (Match1 C x1 e1 x2 e2) e (Match e' x1 e1 x2 e2)

  (* Our new plugging rules *)
  | PluSetVar1 : forall x e e' C,
      plug C e e'
      -> plug (SetVar1 x C) e (SetVar x e').

  Definition valuation := fmap var exp.

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
      step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))
  | FstPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Fst (Pair v1 v2)) v1
  | SndPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Snd (Pair v1 v2)) v2
  | MatchInl : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inl v) x1 e1 x2 e2) (subst v x1 e1)
  | MatchInr : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inr v) x1 e1 x2 e2) (subst v x2 e2).

  (* We build an intermediate relation on top of [step0], allowing for
   * consultation of the mutable-variable valuation. *)
  Inductive step1 : valuation * exp -> valuation * exp -> Prop :=
  | Lift : forall env e1 e2,
    step0 e1 e2
    -> step1 (env, e1) (env, e2)
  | Read : forall env x v,
      env $? x = Some v
      -> step1 (env, GetVar x) (env, v)
  | Overwrite : forall env x v,
      value v
      -> step1 (env, SetVar x v) (env $+ (x, v), v).

  Inductive step : valuation * exp -> valuation * exp -> Prop :=
  | StepRule : forall C env1 e1 env2 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step1 (env1, e1) (env2, e2)
    -> step (env1, e1') (env2, e2').

  Definition trsys_of (env : valuation) (e : exp) := {|
    Initial := {(env, e)};
    Step := step
  |}.

  Inductive type :=
  | Nat
  | Fun (dom ran : type)
  | Prod (t1 t2 : type)
  | Sum (t1 t2 : type).

  (* Now there will be two typing contexts, one for mutable variables and one
   * for immutable. *)
  Inductive has_ty (M : fmap var type) : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> has_ty M G (Var x) t
  | HtConst : forall G n,
    has_ty M G (Const n) Nat
  | HtPlus : forall G e1 e2,
    has_ty M G e1 Nat
    -> has_ty M G e2 Nat
    -> has_ty M G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    has_ty M (G $+ (x, t1)) e1 t2
    -> has_ty M G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    has_ty M G e1 (Fun t1 t2)
    -> has_ty M G e2 t1
    -> has_ty M G (App e1 e2) t2
  | HtPair : forall G e1 e2 t1 t2,
    has_ty M G e1 t1
    -> has_ty M G e2 t2
    -> has_ty M G (Pair e1 e2) (Prod t1 t2)
  | HtFst : forall G e1 t1 t2,
    has_ty M G e1 (Prod t1 t2)
    -> has_ty M G (Fst e1) t1
  | HtSnd : forall G e1 t1 t2,
    has_ty M G e1 (Prod t1 t2)
    -> has_ty M G (Snd e1) t2
  | HtInl : forall G e1 t1 t2,
      has_ty M G e1 t1
      -> has_ty M G (Inl e1) (Sum t1 t2)
  | HtInr : forall G e1 t1 t2,
      has_ty M G e1 t2
      -> has_ty M G (Inr e1) (Sum t1 t2)
  | HtMatch : forall G e t1 t2 x1 e1 x2 e2 t,
      has_ty M G e (Sum t1 t2)
      -> has_ty M (G $+ (x1, t1)) e1 t
      -> has_ty M (G $+ (x2, t2)) e2 t
      -> has_ty M G (Match e x1 e1 x2 e2) t

  (* New cases: *)
  | HtGetVar : forall G x t,
      M $? x = Some t
      -> has_ty M G (GetVar x) t
  | HtSetVar : forall G x e t,
      M $? x = Some t
      -> has_ty M G e t
      -> has_ty M G (SetVar x e) t.

  Local Hint Constructors value plug step0 step1 step has_ty : core.

  (* Let's characterize what makes a typing context and a variable valuation
   * compatible. *)
  Definition compatible (M : fmap var type) (env : valuation) :=
    forall x t, M $? x = Some t
                -> exists v, env $? x = Some v
                             /\ has_ty M $0 v t.

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             (* Add a few extra underscores below, for new [has_ty] argument. *)
             | [ H : has_ty _ _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; []
             | [ H : has_ty _ _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; [|]

             | [ H : has_ty _ _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H

             (* New cases: *)
             | [ H1 : compatible ?M ?env, H2 : ?M $? ?x = Some _ |- _ ] =>
               (assert (exists v, env $? x = Some v) by eauto; fail 1)
               || (pose proof (H1 _ _ H2); first_order)
             | [ H1 : forall env, compatible ?M env -> _, H2 : compatible ?M _ |- _ ] =>
               specialize (H1 _ H2); first_order
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 7.

  Lemma progress : forall M e t,
    has_ty M $0 e t
    -> forall env, compatible M env
    -> value e
    \/ exists st', step (env, e) st'.
  Proof.
    induct 1; t.
  Qed.

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  Local Hint Resolve weakening_override : core.

  Lemma weakening : forall M G e t, has_ty M G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> has_ty M G' e t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve weakening : core.

  Lemma has_ty_change : forall M G e t,
    has_ty M G e t
    -> forall G', G' = G
      -> has_ty M G' e t.
  Proof.
    t.
  Qed.

  Local Hint Resolve has_ty_change : core.

  Lemma substitution : forall M G x t' e t e',
    has_ty M (G $+ (x, t')) e t
    -> has_ty M $0 e' t'
    -> has_ty M G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve substitution : core.

  Lemma compatible_bind : forall M env x v t,
      compatible M env
      -> M $? x = Some t
      -> has_ty M $0 v t
      -> compatible M (env $+ (x, v)).
  Proof.
    unfold compatible; first_order.
    cases (x ==v x0); subst; simplify.
    rewrite H0 in H2.
    invert H2.
    eauto.
    apply H in H0; first_order.
  Qed.

  Local Hint Resolve compatible_bind : core.

  Lemma compatible_has_ty : forall M env x v t,
      compatible M env
      -> env $? x = Some v
      -> M $? x = Some t
      -> has_ty M $0 v t.
  Proof.
    t.
    specialize (H _ _ H1); first_order.
    rewrite H0 in H.
    invert H.
    assumption.
  Qed.

  Local Hint Immediate compatible_has_ty : core.

  Lemma preservation0 : forall M e1 e2,
    step0 e1 e2
    -> forall t, has_ty M $0 e1 t
      -> has_ty M $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation0 : core.

  Lemma preservation1_exp : forall M env1 e1 env2 e2,
    step1 (env1, e1) (env2, e2)
    -> forall t, has_ty M $0 e1 t
      -> compatible M env1
      -> has_ty M $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Lemma preservation1_env : forall M env1 e1 env2 e2,
    step1 (env1, e1) (env2, e2)
    -> forall t, has_ty M $0 e1 t
      -> compatible M env1
      -> compatible M env2.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation1_exp preservation1_env : core.

  Lemma preservation'_exp : forall M C e1 e1',
      plug C e1 e1'
      -> forall e2 e2' t env1 env2, plug C e2 e2'
      -> step1 (env1, e1) (env2, e2)
      -> has_ty M $0 e1' t
      -> compatible M env1
      -> has_ty M $0 e2' t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve preservation'_exp : core.

  Lemma preservation'_env' : forall M C e1 e1',
      plug C e1 e1'
      -> forall t e2 env1 env2, step1 (env1, e1) (env2, e2)
      -> has_ty M $0 e1' t
      -> compatible M env1
      -> compatible M env2.
  Proof.
    induct 1; t.
  Qed.

  Lemma preservation'_env : forall M C e1 e1' t e2 env1 env2,
      step1 (env1, e1) (env2, e2)
      -> plug C e1 e1'
      -> has_ty M $0 e1' t
      -> compatible M env1
      -> compatible M env2.
  Proof.
    simplify; eapply preservation'_env' with (e2 := e2); eauto.
  Qed.

  Local Hint Immediate preservation'_env : core.

  Lemma preservation : forall M env1 e1 env2 e2,
    step (env1, e1) (env2, e2)
    -> forall t, has_ty M $0 e1 t
      -> compatible M env1
      -> has_ty M $0 e2 t /\ compatible M env2.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve progress preservation : core.

  Theorem safety : forall M env e t, has_ty M $0 e t
    -> compatible M env
    -> invariantFor (trsys_of env e)
                    (fun st => value (snd st)
                               \/ exists st', step st st').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun st => has_ty M $0 (snd st) t /\ compatible M (fst st)); eauto.
    apply invariant_induction; simplify.
    propositional; subst; auto.
    invert H1.
    cases s; cases s'; simplify.
    eauto.
    propositional.
    cases s; simplify.
    eauto.
  Qed.
End StlcMutable.

(** * Concurrency *)

(* As we saw in Chapter 8, it's actually not all that much work to add
 * concurrency, once we have evaluation contexts.  Let's replicate that result
 * for our functional language. *)

Module StlcConcur.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)
  | Pair (e1 e2 : exp)
  | Fst (e1 : exp)
  | Snd (e2 : exp)
  | Inl (e1 : exp)
  | Inr (e2 : exp)
  | Match (e' : exp) (x1 : var) (e1 : exp) (x2 : var) (e2 : exp)
  | GetVar (x : var)
  | SetVar (x : var) (e : exp)

  (* New cases: *)
  | Par (e1 e2 : exp).
  (* This form evaluates both expressions and forms a pair of their
   * results, if they terminate. *)

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1)
  | VPair : forall v1 v2, value v1 -> value v2 -> value (Pair v1 v2)
  | VInl : forall v, value v -> value (Inl v)
  | VInr : forall v, value v -> value (Inr v).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
      | Pair e2' e2'' => Pair (subst e1 x e2') (subst e1 x e2'')
      | Fst e2' => Fst (subst e1 x e2')
      | Snd e2' => Snd (subst e1 x e2')
      | Inl e2' => Inl (subst e1 x e2')
      | Inr e2' => Inr (subst e1 x e2')
      | Match e2' x1 e21 x2 e22 => Match (subst e1 x e2')
                                         x1 (if x1 ==v x then e21 else subst e1 x e21)
                                         x2 (if x2 ==v x then e22 else subst e1 x e22)
      | GetVar y => GetVar y
      | SetVar y e2' => SetVar y (subst e1 x e2')
      | Par e2' e2'' => Par (subst e1 x e2') (subst e1 x e2'')
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context
  | Pair1 : context -> exp -> context
  | Pair2 : exp -> context -> context
  | Fst1 : context -> context
  | Snd1 : context -> context
  | Inl1 : context -> context
  | Inr1 : context -> context
  | Match1 : context -> var -> exp -> var -> exp -> context
  | SetVar1 : var -> context -> context

  (* New cases: *)
  | Par1 : context -> exp -> context
  | Par2 : exp -> context -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')
  | PlugPair1 : forall e e' C e2,
    plug C e e'
    -> plug (Pair1 C e2) e (Pair e' e2)
  | PlugPair2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Pair2 v1 C) e (Pair v1 e')
  | PlugFst1 : forall e e' C,
    plug C e e'
    -> plug (Fst1 C) e (Fst e')
  | PlugSnd1 : forall e e' C,
    plug C e e'
    -> plug (Snd1 C) e (Snd e')
  | PlugInl1 : forall e e' C,
    plug C e e'
    -> plug (Inl1 C) e (Inl e')
  | PlugInr1 : forall e e' C,
    plug C e e'
    -> plug (Inr1 C) e (Inr e')
  | PluMatch1 : forall e e' C x1 e1 x2 e2,
    plug C e e'
    -> plug (Match1 C x1 e1 x2 e2) e (Match e' x1 e1 x2 e2)
  | PluSetVar1 : forall x e e' C,
      plug C e e'
      -> plug (SetVar1 x C) e (SetVar x e')

  (* Our new plugging rules: *)
  | PlugPar1 : forall e e' C e2,
    plug C e e'
    -> plug (Par1 C e2) e (Par e' e2)
  | PlugPar2 : forall e e' e1 C,
    plug C e e'
    -> plug (Par2 e1 C) e (Par e1 e').

  Definition valuation := fmap var exp.

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
      step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2))
  | FstPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Fst (Pair v1 v2)) v1
  | SndPair : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Snd (Pair v1 v2)) v2
  | MatchInl : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inl v) x1 e1 x2 e2) (subst v x1 e1)
  | MatchInr : forall v x1 e1 x2 e2,
      value v
      -> step0 (Match (Inr v) x1 e1 x2 e2) (subst v x2 e2)

  (* New case: *)
  | ParDone : forall v1 v2,
      value v1
      -> value v2
      -> step0 (Par v1 v2) (Pair v1 v2).

  Inductive step1 : valuation * exp -> valuation * exp -> Prop :=
  | Lift : forall env e1 e2,
    step0 e1 e2
    -> step1 (env, e1) (env, e2)
  | Read : forall env x v,
      env $? x = Some v
      -> step1 (env, GetVar x) (env, v)
  | Overwrite : forall env x v,
      value v
      -> step1 (env, SetVar x v) (env $+ (x, v), v).

  Inductive step : valuation * exp -> valuation * exp -> Prop :=
  | StepRule : forall C env1 e1 env2 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step1 (env1, e1) (env2, e2)
    -> step (env1, e1') (env2, e2').

  Definition trsys_of (env : valuation) (e : exp) := {|
    Initial := {(env, e)};
    Step := step
  |}.

  Inductive type :=
  | Nat
  | Fun (dom ran : type)
  | Prod (t1 t2 : type)
  | Sum (t1 t2 : type).

  Inductive has_ty (M : fmap var type) : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> has_ty M G (Var x) t
  | HtConst : forall G n,
    has_ty M G (Const n) Nat
  | HtPlus : forall G e1 e2,
    has_ty M G e1 Nat
    -> has_ty M G e2 Nat
    -> has_ty M G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    has_ty M (G $+ (x, t1)) e1 t2
    -> has_ty M G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    has_ty M G e1 (Fun t1 t2)
    -> has_ty M G e2 t1
    -> has_ty M G (App e1 e2) t2
  | HtPair : forall G e1 e2 t1 t2,
    has_ty M G e1 t1
    -> has_ty M G e2 t2
    -> has_ty M G (Pair e1 e2) (Prod t1 t2)
  | HtFst : forall G e1 t1 t2,
    has_ty M G e1 (Prod t1 t2)
    -> has_ty M G (Fst e1) t1
  | HtSnd : forall G e1 t1 t2,
    has_ty M G e1 (Prod t1 t2)
    -> has_ty M G (Snd e1) t2
  | HtInl : forall G e1 t1 t2,
      has_ty M G e1 t1
      -> has_ty M G (Inl e1) (Sum t1 t2)
  | HtInr : forall G e1 t1 t2,
      has_ty M G e1 t2
      -> has_ty M G (Inr e1) (Sum t1 t2)
  | HtMatch : forall G e t1 t2 x1 e1 x2 e2 t,
      has_ty M G e (Sum t1 t2)
      -> has_ty M (G $+ (x1, t1)) e1 t
      -> has_ty M (G $+ (x2, t2)) e2 t
      -> has_ty M G (Match e x1 e1 x2 e2) t
  | HtGetVar : forall G x t,
      M $? x = Some t
      -> has_ty M G (GetVar x) t
  | HtSetVar : forall G x e t,
      M $? x = Some t
      -> has_ty M G e t
      -> has_ty M G (SetVar x e) t

  (* New cases: *)
  | HtPar : forall G e1 t1 e2 t2,
      has_ty M G e1 t1
      -> has_ty M G e2 t2
      -> has_ty M G (Par e1 e2) (Prod t1 t2).

  Local Hint Constructors value plug step0 step1 step has_ty : core.

  Definition compatible (M : fmap var type) (env : valuation) :=
    forall x t, M $? x = Some t
                -> exists v, env $? x = Some v
                             /\ has_ty M $0 v t.

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : has_ty _ _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; []
             | [ H : has_ty _ _ ?e _, H' : value ?e |- _ ] => invert H'; invert H; [|]

             | [ H : has_ty _ _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H

             | [ H1 : compatible ?M ?env, H2 : ?M $? ?x = Some _ |- _ ] =>
               (assert (exists v, env $? x = Some v) by eauto; fail 1)
               || (pose proof (H1 _ _ H2); first_order)
             | [ H1 : forall env, compatible ?M env -> _, H2 : compatible ?M _ |- _ ] =>
               specialize (H1 _ H2); first_order
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 7.

  Lemma progress : forall M e t,
    has_ty M $0 e t
    -> forall env, compatible M env
    -> value e
    \/ exists st', step (env, e) st'.
  Proof.
    induct 1; t.
  Qed.

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  Local Hint Resolve weakening_override : core.

  Lemma weakening : forall M G e t, has_ty M G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> has_ty M G' e t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve weakening : core.

  Lemma has_ty_change : forall M G e t,
    has_ty M G e t
    -> forall G', G' = G
      -> has_ty M G' e t.
  Proof.
    t.
  Qed.

  Local Hint Resolve has_ty_change : core.

  Lemma substitution : forall M G x t' e t e',
    has_ty M (G $+ (x, t')) e t
    -> has_ty M $0 e' t'
    -> has_ty M G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve substitution : core.

  Lemma compatible_bind : forall M env x v t,
      compatible M env
      -> M $? x = Some t
      -> has_ty M $0 v t
      -> compatible M (env $+ (x, v)).
  Proof.
    unfold compatible; first_order.
    cases (x ==v x0); subst; simplify.
    rewrite H0 in H2.
    invert H2.
    eauto.
    apply H in H0; first_order.
  Qed.

  Local Hint Resolve compatible_bind : core.

  Lemma compatible_has_ty : forall M env x v t,
      compatible M env
      -> env $? x = Some v
      -> M $? x = Some t
      -> has_ty M $0 v t.
  Proof.
    t.
    specialize (H _ _ H1); first_order.
    rewrite H0 in H.
    invert H.
    assumption.
  Qed.

  Local Hint Immediate compatible_has_ty : core.

  Lemma preservation0 : forall M e1 e2,
    step0 e1 e2
    -> forall t, has_ty M $0 e1 t
      -> has_ty M $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation0 : core.

  Lemma preservation1_exp : forall M env1 e1 env2 e2,
    step1 (env1, e1) (env2, e2)
    -> forall t, has_ty M $0 e1 t
      -> compatible M env1
      -> has_ty M $0 e2 t.
  Proof.
    invert 1; t.
  Qed.

  Lemma preservation1_env : forall M env1 e1 env2 e2,
    step1 (env1, e1) (env2, e2)
    -> forall t, has_ty M $0 e1 t
      -> compatible M env1
      -> compatible M env2.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve preservation1_exp preservation1_env : core.

  Lemma preservation'_exp : forall M C e1 e1',
      plug C e1 e1'
      -> forall e2 e2' t env1 env2, plug C e2 e2'
      -> step1 (env1, e1) (env2, e2)
      -> has_ty M $0 e1' t
      -> compatible M env1
      -> has_ty M $0 e2' t.
  Proof.
    induct 1; t.
  Qed.

  Local Hint Resolve preservation'_exp : core.

  Lemma preservation'_env' : forall M C e1 e1',
      plug C e1 e1'
      -> forall t e2 env1 env2, step1 (env1, e1) (env2, e2)
      -> has_ty M $0 e1' t
      -> compatible M env1
      -> compatible M env2.
  Proof.
    induct 1; t.
  Qed.

  Lemma preservation'_env : forall M C e1 e1' t e2 env1 env2,
      step1 (env1, e1) (env2, e2)
      -> plug C e1 e1'
      -> has_ty M $0 e1' t
      -> compatible M env1
      -> compatible M env2.
  Proof.
    simplify; eapply preservation'_env' with (e2 := e2); eauto.
  Qed.

  Local Hint Immediate preservation'_env : core.

  Lemma preservation : forall M env1 e1 env2 e2,
    step (env1, e1) (env2, e2)
    -> forall t, has_ty M $0 e1 t
      -> compatible M env1
      -> has_ty M $0 e2 t /\ compatible M env2.
  Proof.
    invert 1; t.
  Qed.

  Local Hint Resolve progress preservation : core.

  Theorem safety : forall M env e t, has_ty M $0 e t
    -> compatible M env
    -> invariantFor (trsys_of env e)
                    (fun st => value (snd st)
                               \/ exists st', step st st').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun st => has_ty M $0 (snd st) t /\ compatible M (fst st)); eauto.
    apply invariant_induction; simplify.
    propositional; subst; auto.
    invert H1.
    cases s; cases s'; simplify.
    eauto.
    propositional.
    cases s; simplify.
    eauto.
  Qed.
End StlcConcur.