(** * Properties of cocwp (cwp on cotrees). *)

Set Implicit Arguments.

From Coq Require Import
  Basics
  QArith
  Lra
  Equivalence
  Reals
.

Local Open Scope equiv_scope.
Local Open Scope program_scope.

From algco Require Import
  aCPO
  cocwp
  cotree
  cpo
  geometric_series
  misc
  order
  R
  eR
  tactics
.

Local Open Scope eR_scope.
Local Open Scope order_scope.

Create HintDb cotcwp.

Lemma chain_cotree_loop_approx {A} (x : A) (e : A -> bool)
  (g : A -> cotree bool (unit + A))
  (f : A -> cotree bool (unit + A)) :
  chain (cotree_loop_approx x e g f).
Proof.
  unfold cotree_loop_approx, cotree_loop_F.
  intro i.
  revert x e g f.
  induction i; simpl; intros x e g f.
  - destruct (e x); try reflexivity; constructor.
  - destruct (e x); try reflexivity; apply cotree_le_bind.
    intros [[]|a]; try reflexivity; try constructor; apply IHi.
Qed.

(** Example of Proper_co followed by induction on atree. *)
Lemma cotree_bind_map_sum {A} t g :
  cotree_bind (cotree_map inr t)
    (fun lr : A + (unit + A) => match lr with
                             | inl j => g j
                             | inr x => coleaf x
                             end) = t.
Proof.
  apply cotree_ext, equ_cotree_eq.
  replace t with (co tinj t) by apply co_tinj_t.
  unfold cotree_bind, cotree_map, tcofold.
  rewrite co_co''; eauto with cotree order.
  apply Proper_co'.
  { apply monotone_compose; eauto with cotree order aCPO. }
  { apply Proper_tinj. }
  2: { rewrite co_tinj_t; reflexivity. }
  unfold compose.
  apply equ_arrow; intro a.
  unfold atree_cotree_map, atree_cotree_bind; simpl.
  induction a; unfold compose; simpl.
  - rewrite co_tfold_bot; reflexivity.
  - rewrite co_tfold_leaf; try reflexivity; constructor.
  - rewrite co_tfold_node; auto with cotree order;
      try solve [intros; constructor].
    apply cotree_eq_equ; constructor; intro b; apply equ_cotree_eq, H.
Qed.

Lemma iid_F_cotree_iter_F {A} (a : cotree bool (unit + A)) (b : cotree bool A) :
  iid_F a b = cotree_iter_F (const a) (const b) tt.
Proof. reflexivity. Qed.

Lemma continuous_iid_F {A} (t : cotree bool (unit + A)) :
  continuous (iid_F t).
Proof.
  intros ch Hch s Hs.
  rewrite iid_F_cotree_iter_F.
  unfold compose.
  replace (fun x => iid_F t (ch x)) with
    (fun x => cotree_iter_F (const t) (const (ch x)) tt).
  2: { ext i; rewrite iid_F_cotree_iter_F; reflexivity. }
  set (ch' := (fun t' => cotree_iter_F (const t) (const t')) ∘ ch).
  replace (fun x : nat => cotree_iter_F (const t) (const (ch x)) tt) with
    (fun i => ch' i tt) by reflexivity.
  apply apply_supremum.
  apply continuous_cotree_iter_F.
  - unfold const.
    intros i j; destruct (Hch i j) as [k [Hk Hk']].
    exists k; split; intros []; auto.
  - unfold const.
    split.
    + intros i []; apply Hs.
    + intros x Hx []; apply Hs; intro i; apply Hx.
Qed.

#[global]
  Instance monotone_btwp {A} (f : A -> eR) : Proper (leq ==> leq) (btwp f).
Proof.
  apply monotone_tfold.
  - intros; eRauto.
  - intros g g' Hg; simpl.
    apply eRle_div, eRplus_le_compat; apply Hg.
Qed.
#[global] Hint Resolve monotone_btwp : cotcwp.

Lemma fold_avg_bounded {A} (f : A -> eR) (t : atree bool A) :
  bounded f 1 ->
  tfold 1 f (fun k : bool -> eR => (k false + k true) / 2) t ⊑ 1.
Proof.
  revert f; induction t; intros f Hf; simpl; eRauto.
  unfold compose.
  apply eRmult_le_reg_r with (r:=2); eRauto.
  unfold eRdiv.
  rewrite eRmult_assoc.
  rewrite eRinv_l; eRauto.
  etransitivity.
  { apply eRplus_le_compat; apply H; auto. }
  constructor; lra.
Qed.

Lemma monotone_avg : monotone (fun k : bool -> eR => (k false + k true) / 2).
Proof.
  intros f g Hfg; simpl.
  apply eRle_div, eRplus_le_compat; apply Hfg.
Qed.

#[global]
  Instance antimonotone_btwlp {A} (f : A -> eR) {Hf: bounded f 1}
  : Proper (leq ==> flip leq) (btwlp f).
Proof.
  apply antimonotone_tfold.
  - intro a; apply fold_avg_bounded; auto.
  - apply monotone_avg.
Qed.
#[global] Hint Resolve antimonotone_btwlp : cotcwp.

Corollary continuous_cotwp {A} (f : A -> eR) : continuous (cotwp f).
Proof. apply continuous_co, monotone_btwp. Qed.
#[global] Hint Resolve continuous_cotwp : cotcwp.

Corollary cocontinuous_cotwlp {A} (f : A -> eR) :
  bounded f 1 ->
  cocontinuous (cotwlp f).
Proof. intro Hf; apply cocontinuous_coop, antimonotone_btwlp; auto. Qed.
#[global] Hint Resolve cocontinuous_cotwlp : cotcwp.

Lemma wcontinuous_avg : wcontinuous (fun k : bool -> eR => (k false + k true) / 2).
Proof.
  intros ch Hch s Hs; unfold compose.
  unfold eRdiv.
  rewrite eRmult_comm.
  replace (fun x : nat => (ch x false + ch x true) * / 2) with
    (fun i => / 2 * (ch i false + ch i true)).
  2: { ext i; apply eRmult_comm. }
  apply supremum_scalar.
  apply supremum_sum.
  { intro i; apply Hch. }
  { intro i; apply Hch. }
  { apply apply_supremum; auto. }
  { apply apply_supremum; auto. }
Qed.

Lemma dec_wcontinuous_avg : dec_wcontinuous (fun k : bool -> eR => (k false + k true) / 2).
Proof.
  intros ch Hch s Hs; unfold compose.
  unfold eRdiv.
  rewrite eRmult_comm.
  replace (fun x : nat => (ch x false + ch x true) * / 2) with
    (fun i => / 2 * (ch i false + ch i true)).
  2: { ext i; apply eRmult_comm. }
  apply infimum_scalar.
  { simpl; destr; try congruence; lra. }
  apply infimum_sum.
  { intro i; apply Hch. }
  { intro i; apply Hch. }
  { apply apply_infimum; auto. }
  { apply apply_infimum; auto. }
Qed.

(** Computation lemmas for cotwp. *)
Lemma cotwp_bot {A} (f : A -> eR) :
  cotwp f cobot = 0.
Proof.
  apply equ_eR.
  unfold cotwp, btwp.
  rewrite co_tfold_bot; reflexivity.
Qed.

Lemma cotwp_leaf {A} (f : A -> eR) (x : A) :
  cotwp f (coleaf x) = f x.
Proof.
  apply equ_eR.
  unfold cotwp, btwp.
  rewrite co_tfold_leaf; eRauto.
Qed.

Lemma cotwp_node {A} (f : A -> eR) (k : bool -> cotree bool A) :
  cotwp f (conode k) = (cotwp f (k false) + cotwp f (k true)) / 2.
Proof.
  apply equ_eR.
  unfold cotwp, btwp.
  rewrite co_tfold_node; eRauto.
  apply wcontinuous_avg.
Qed.

(** An essential lemma about the co-semantics. Proof by using
    co_compose to turn the LHS into a single comorphism, then
    Proper_co to show equality of LHS and RHS. *)
Lemma cotwp_bind {A B} (f : B -> eR) (t : cotree bool A) (k : A -> cotree bool B) :
  cotwp f (cotree_bind t k) = cotwp (cotwp f ∘ k) t.
Proof.
  unfold cotwp.
  unfold cotree_bind, tcofold.
  apply equ_eR.
  set (g := btwp f).
  set (h := atree_cotree_bind k).
  assert (Hg: wcontinuous (co g)).
  { apply continuous_wcontinuous, continuous_co, monotone_btwp. }
  assert (Hh: monotone h).
  { apply monotone_atree_cotree_bind. }
  generalize (@co_co (cotree bool A) (atree bool A) (cotree bool B)
                eR _ _ _ _ _ _ _ _ _ _ h (co g) Hh Hg).
  intro H.
  apply equ_arrow with (x:=t) in H.
  unfold compose, h in H.
  unfold compose in H; rewrite H; clear H.
  revert t.
  apply equ_arrow.
  apply Proper_co.
  { replace (fun x : atree bool A => co g (h x)) with (co g ∘ h) by reflexivity.
    apply monotone_compose.
    - apply monotone_atree_cotree_bind.
    - apply monotone_co, monotone_btwp. }
  { apply monotone_btwp. }
  apply equ_arrow.
  intro t.
  apply equ_eR.
  unfold g, h in *; clear g h Hg Hh.
  unfold compose.
  revert f k.
  induction t; intros f k; simpl.
  - apply cotwp_bot.
  - reflexivity.
  - apply equ_eR.
    unfold btwp, atree_cotree_bind in *; simpl.
    rewrite co_tfold_node; eRauto.
    { apply equ_eR; unfold compose; rewrite 2!H; reflexivity. }
    { apply wcontinuous_avg. }
Qed.

(** Computation lemmas for cotwlp. *)
Lemma cotwlp_bot {A} (f : A -> eR) :
  cotwlp f cobot = 1.
Proof.
  apply equ_eR.
  unfold cotwlp, btwlp.
  rewrite coop_tfold_bot; reflexivity.
Qed.

Lemma cotwlp_leaf {A} (f : A -> eR) (x : A) :
  bounded f 1 ->
  cotwlp f (coleaf x) = f x.
Proof.
  intro Hf; apply equ_eR.
  unfold cotwlp, btwlp.
  rewrite coop_tfold_leaf; eRauto; apply Hf.
Qed.

Lemma cotwlp_node {A} (f : A -> eR) (k : bool -> cotree bool A) :
  bounded f 1 ->
  cotwlp f (conode k) = (cotwlp f (k false) + cotwlp f (k true)) / 2.
Proof.
  intro Hf; apply equ_eR.
  unfold cotwlp, btwlp.
  rewrite coop_tfold_node; eRauto.
  { apply dec_wcontinuous_avg. }
  { intro a; apply fold_avg_bounded; auto. }
  { unfold eRdiv, eRmult; simpl.
    destruct (R_eq_dec 2 0); try lra.
    constructor; lra. }
Qed.

Corollary btwlp_bounded {A} (f : A -> eR) (t : atree bool A) :
  bounded f 1 ->
  btwlp f t ⊑ 1.
Proof. apply fold_avg_bounded. Qed.

(** See above. *)
Lemma cotwlp_bind {A B} (f : B -> eR) (t : cotree bool A) (k : A -> cotree bool B) :
  bounded f 1 ->
  cotwlp f (cotree_bind t k) = cotwlp (cotwlp f ∘ k) t.
Proof.
  intro Hf.
  unfold cotwlp.
  unfold cotree_bind.
  apply equ_eR.
  set (g := btwlp f).
  set (h := atree_cotree_bind k).
  assert (Hg: cocontinuous (coop g)).
  { apply cocontinuous_coop, antimonotone_btwlp; auto. }
  assert (Hh: monotone h).
  { apply monotone_atree_cotree_bind. }
  generalize (@co_coop (cotree bool A) (atree bool A) (cotree bool B)
                eR _ _ _ _ _ _ _ _ _ _ h (coop g) Hh Hg).
  intro H.
  apply equ_arrow with (x:=t) in H.
  unfold compose, h in H; rewrite H; clear H.
  revert t.
  apply equ_arrow.
  apply Proper_coop.
  { replace (fun x : atree bool A => co g (h x)) with (co g ∘ h) by reflexivity.
    intros a b Hab; unfold flip.
    apply antimonotone_coop; auto.
    apply antimonotone_btwlp; auto. }
  { apply antimonotone_btwlp.
    intro x; unfold compose, coop.
    apply leq_eRle.
    unfold g.
    apply lattice_ge_inf with O; auto with eR. }
  apply equ_arrow.
  intro t.
  apply equ_eR.
  unfold g, h in *; clear g h Hg Hh.
  unfold compose.
  revert Hf.
  revert f k.
  induction t; intros f k Hf; simpl.
  - apply cotwlp_bot.
  - reflexivity.
  - apply equ_eR.
    unfold btwlp, atree_cotree_bind in *; simpl.
    rewrite coop_tfold_node; eRauto.
    { apply equ_eR; unfold compose; rewrite 2!H; auto; reflexivity. }
    { apply dec_wcontinuous_avg. }
    { intro; apply fold_avg_bounded; auto. }
    { unfold eRdiv, eRmult; simpl.
      destruct (R_eq_dec 2 0); try lra.
      constructor; lra. }
Qed.

Lemma cotwp_filter {A} (P : A -> bool) (f : A -> eR) :
  cotwp (fun x => if P x then f x else 0) === cotwp f ∘ cotree_filter P.
Proof.
  unfold cotwp, cotree_filter, tcofold.
  rewrite co_co; eauto with cotcwp cotree order.
  apply Proper_co; eauto with cotcwp order.
  { apply monotone_compose; eauto with cotree order.
    apply monotone_co; eauto with cotcwp. }
  apply equ_arrow; intro a.
  unfold compose.
  revert P f; induction a; intros P f; simpl.
  - unfold atree_cotree_filter. simpl.
    unfold btwp; simpl.
    rewrite co_tfold_bot.
    reflexivity.
  - unfold btwp; simpl.
    unfold atree_cotree_filter; simpl.
    destruct (P a).
    + rewrite co_tfold_leaf; eRauto.
    + rewrite co_tfold_bot; reflexivity.
  - unfold btwp, atree_cotree_filter in *; simpl.
    unfold id, compose in *.
    rewrite co_tfold_node; eRauto.
    { unfold compose; apply equ_eR.
      f_equal; f_equal; apply equ_eR, H. }
    { apply wcontinuous_avg. }
Qed.

Lemma btwp_node {A} (f : A -> eR) (g : bool -> atree bool A) :
  btwp f (anode g) = (btwp f (g false) + btwp f (g true)) / 2.
Proof. reflexivity. Qed.

Lemma btwp_strict {A} (t : atree bool A) :
  btwp (fun _ : A => 0) t = 0.
Proof.
  unfold btwp; induction t; simpl; auto.
  unfold compose; rewrite 2!H; eRauto.
Qed.

Lemma btwlp_costrict {A} (t : atree bool A) :
  btwlp (fun _ : A => 1) t = 1.
Proof.
  unfold btwlp; induction t; simpl; auto.
  unfold compose; rewrite 2!H; eRauto.
  rewrite <- eRplus_combine_fract.
  apply eRplus_half_plus_half.
Qed.

Lemma cotwp_strict {A} :
  cotwp (fun _ : A => 0) = const 0.
Proof.
  symmetry; apply co_unique_ext.
  - apply monotone_btwp.
  - apply continuous_wcontinuous, continuous_const.
  - ext t; rewrite btwp_strict; reflexivity.
Qed.

Lemma cotwlp_costrict {A} :
  cotwlp (fun _ : A => 1) = const 1.
Proof.
  symmetry; apply coop_unique_ext.
  - apply antimonotone_btwlp; intro; reflexivity.
  - apply cocontinuous_const.
  - ext t; rewrite btwlp_costrict; reflexivity.
Qed.

Lemma btwp_cotuple {A B} (t : atree bool (A + B)) (f : A -> eR) (g : B -> eR) :
  btwp (cotuple f g) t = btwp (cotuple f (const 0)) t + btwp (cotuple (const 0) g) t.
Proof.
  revert f g; induction t; intros f g; simpl; eRauto.
  - destruct a; simpl; unfold const; eRauto.
  - rewrite btwp_node.
    rewrite 2!H.
    rewrite 2!btwp_node.
    rewrite <- 5!eRplus_combine_fract.
    set (x := btwp (cotuple f (const 0)) (a false) / 2).
    set (y := btwp (cotuple (const 0) (const 0)) (a false) / 2).
    set (z := btwp (cotuple (const 0) g) (a false) / 2).
    set (w := btwp (cotuple f g) (a true) / 2).
    set (y' := btwp (cotuple f (const 0)) (a true) / 2).
    set (w' := btwp (cotuple (const 0) g) (a true) / 2).
    rewrite <- eRplus_assoc.
    cut (y + w = y' + w').
    { intro Heq; destruct x, y, z, w, y', w';
        compute; auto; inv Heq; apply eR_eq; lra. }
    unfold y, y', w, w'.
    rewrite 2!eRplus_combine_fract.
    replace (cotuple (const 0) (const 0)) with (fun _ : A + B => 0).
    2: { ext ab; destruct ab; reflexivity. }
    rewrite btwp_strict; eRauto.
    rewrite H; reflexivity.
Qed.

Lemma cotwp_cotuple {A B} (t : cotree bool (A + B)) (f : A -> eR) (g : B -> eR) :
  cotwp (cotuple f g) t = cotwp (cotuple f (const 0)) t + cotwp (cotuple (const 0) g) t.
Proof.
  unfold cotwp, co.
  rewrite <- sup_sum.
  2: { apply monotone_chain.
       - apply monotone_btwp.
       - apply chain_ideal. }
  2: { apply monotone_chain.
       - apply monotone_btwp.
       - apply chain_ideal. }
  f_equal; ext i; unfold compose.
  apply btwp_cotuple.
Qed.

Lemma tie_cotree_iid_tie_cotree {A} :
  @tie_cotree_iid A = tie_cotree.
Proof.
  ext ct.
  unfold tie_cotree_iid, tie_cotree, cotree_iter, iter.
  apply cotree_ext, equ_cotree_eq; rewrite sup_apply.
  2: { apply chain_directed, chain_iter_n';
       eauto with order cotree; constructor. }
  apply eq_equ; f_equal; ext i.
  revert ct; induction i; intros t; simpl; auto.
  unfold iid_F; simpl; unfold cotree_iter_F, const; f_equal.
  ext lr; destruct lr; simpl; auto.
  f_equal; destruct u; apply IHi.
Qed.

Lemma btwp_scalar {A} (c : eR) (f : A -> eR) (t : atree bool A) :
  c * btwp f t = btwp (fun x => c * f x) t.
Proof.
  unfold btwp.
  revert c f; induction t; intros c f; simpl; eRauto.
  unfold compose.
  rewrite <- 2!H.
  rewrite eRmult_eRdiv_assoc, eRmult_plus_distr_l; reflexivity.
Qed.

Lemma cotwp_scalar {A} (c : eR) (f : A -> eR) (t : cotree bool A) :
  c * cotwp f t = cotwp (fun x => c * f x) t.
Proof.
  unfold cotwp, co.
  unfold compose.
  rewrite sup_scalar.
  f_equal; ext i.
  apply btwp_scalar.
Qed.

Lemma btwp_sum {A} (f g : A -> eR) (t : atree bool A) :
  btwp (fun a => f a + g a) t = btwp f t + btwp g t.
Proof.
  unfold btwp.
  revert f; induction t; intros f; simpl; eRauto.
  unfold compose.
  rewrite 2!H,  eRplus_combine_fract.
  rewrite <- 2!eRplus_assoc, eRplus_comm4; reflexivity.
Qed.

Lemma cotwp_sum {A} (f g : A -> eR) (t : cotree bool A) :
  cotwp (fun a => f a + g a) t = cotwp f t + cotwp g t.
Proof.
  symmetry.
  set (h := fun t => cotwp f t + cotwp g t).
  replace (cotwp f t + cotwp g t) with (h t) by reflexivity.
  cut (h = cotwp (fun a => f a + g a)).
  { intros ->; reflexivity. }
  apply co_unique_ext.
  - apply monotone_btwp.
  - unfold h.
    apply wcontinuous_sum;
      apply continuous_wcontinuous, continuous_co, monotone_btwp.
  - clear t.
    ext t.
    rewrite btwp_sum.
    unfold compose, h.
    f_equal; apply co_incl'_ext, monotone_btwp.
Qed.

Lemma cotwp_linear {A} (c : eR) (f g : A -> eR) (t : cotree bool A) :
  cotwp (fun a => c * f a + g a) t = c * cotwp f t + cotwp g t.
Proof. rewrite cotwp_sum, cotwp_scalar; reflexivity. Qed.

Lemma monotone_btwp' {A} (f g : A -> eR) (t : atree bool A) :
  f ⊑ g ->
  btwp f t <= btwp g t.
Proof.
  unfold btwp.
  revert f g; induction t; intros f g Hfg; simpl.
  - reflexivity.
  - apply Hfg.
  - unfold compose.
    rewrite <- 2!eRplus_combine_fract.
    apply eRplus_le_compat; apply eRmult_le_compat_r, H; auto.
Qed.

Lemma monotone_btwlp' {A} (f g : A -> eR) (t : atree bool A) :
  f ⊑ g ->
  btwlp f t <= btwlp g t.
Proof.
  unfold btwlp.
  revert f g; induction t; intros f g Hfg; simpl.
  - reflexivity.
  - apply Hfg.
  - unfold compose.
    rewrite <- 2!eRplus_combine_fract.
    apply eRplus_le_compat; apply eRmult_le_compat_r, H; auto.
Qed.

Lemma monotone_cotwp {A} (f g : A -> eR) (t : cotree bool A) :
  f ⊑ g ->
  cotwp f t <= cotwp g t.
Proof.
  intro Hfg.
  apply leq_eRle.
  unfold cotwp.
  apply ge_sup.
  { apply monotone_directed.
    - apply monotone_btwp.
    - apply chain_directed, chain_ideal. }
  intro i; unfold compose.
  apply le_sup with i.
  { apply monotone_directed.
    - apply monotone_btwp.
    - apply chain_directed, chain_ideal. }
  unfold compose.
  apply monotone_btwp'; auto.
Qed.

Lemma monotone_cotwlp {A} (f g : A -> eR) (t : cotree bool A) :
  bounded g 1 ->
  f ⊑ g ->
  cotwlp f t <= cotwlp g t.
Proof.
  intros Hg Hfg.
  apply leq_eRle.
  unfold cotwlp.
  apply le_inf.
  { apply antimonotone_downward_directed.
    - apply antimonotone_btwlp; auto.
    - apply chain_directed, chain_ideal. }
  intro i; unfold compose.
  apply ge_inf with i.
  { apply antimonotone_downward_directed.
    - apply antimonotone_btwlp.
      intro a; etransitivity; eauto; apply Hfg.
    - apply chain_directed, chain_ideal. }
  unfold compose.
  apply monotone_btwlp'; auto.
Qed.

Theorem markov_inequality {A} (f : A -> eR) (a : eR) (t : cotree bool A) :
  a <> 0 ->
  a <> infty ->
  cotwp (fun x => if eRle_dec a (f x) then 1 else 0) t <= cotwp f t / a.
Proof.
  intros Ha Ha'.
  unfold eRdiv.
  apply eRmult_le_div; auto.
  rewrite cotwp_scalar.
  apply monotone_cotwp.
  intro x.
  destr; eRauto.
Qed.

Lemma cotree_bind_iid_chain_ {A} t i :
  cotree_bind (iid_chain_ t i)
    (fun x : unit + A => match x with
                      | inl _ => t
                      | inr b => coleaf (inr b)
                      end) =
    cotree_bind t
      (fun x : unit + A => match x with
                        | inl _ => iid_chain_ t i
                        | inr b => coleaf (inr b)
                        end).
Proof.
  revert t; induction i; intro t; simpl.
  { rewrite cotree_bind_leaf.
    replace (fun x : unit + A => match x with
                              | inl _ => coleaf (inl tt)
                              | inr b => coleaf (inr b)
                              end) with
      (@coleaf bool (unit + A)).
    2: { ext lr; destruct lr as [[]|?]; reflexivity. }
    rewrite cotree_bind_id_r; reflexivity. }
  rewrite IHi.
  rewrite cotree_bind_assoc.
  f_equal.
  ext lr; destruct lr as [[]|a]; auto.
  rewrite cotree_bind_leaf; reflexivity.
Qed.

Lemma cotree_bind_iid_chain_snip {A} t i :
  cotree_bind (iid_chain_ t i)
    (fun x : unit + A =>
       match x with
       | inl _ => snip t
       | inr b => coleaf b
       end) =
    cotree_bind t
      (fun x : unit + A =>
         match x with
         | inl _ => snip (iid_chain_ t i)
         | inr b => coleaf b
         end).
Proof.
  replace (fun x : unit + A => match x with
                            | inl _ => snip t
                            | inr b => coleaf b
                            end) with
    (snip ∘ fun x : unit + A => match x with
                             | inl _ => t
                             | inr b => coleaf (inr b)
                             end).
  2: { unfold compose; ext lr; destruct lr; auto; rewrite snip_leaf; auto. }
  rewrite <- snip_bind.
  replace (fun x : unit + A => match x with
                               | inl _ => snip (iid_chain_ t i)
                               | inr b => coleaf b
                               end) with
    (snip ∘ fun x : unit + A => match x with
                             | inl _ => iid_chain_ t i
                             | inr b => coleaf (inr b)
                             end).
  2: { unfold compose; ext lr; destruct lr; auto; rewrite snip_leaf; auto. }
  rewrite <- snip_bind.
  f_equal.
  apply cotree_bind_iid_chain_.
Qed.

Lemma iid_chain_iter_n {A} (t : cotree bool (unit + A)) :
  iid_chain t = iter_n (iid_F' t) cobot.
Proof.
  ext i; revert t; induction i; intro t.
  { unfold iid_chain; simpl; rewrite snip_leaf; reflexivity. }
  unfold iid_chain in *; simpl.
  unfold compose. unfold iid_F' in *.
  unfold snip in *.
  rewrite <- IHi; clear IHi.
  rewrite cotree_bind_assoc.
  etransitivity.
  2: { apply cotree_bind_iid_chain_snip. }
  f_equal.
  ext lr; destruct lr as [[]|a]; simpl; auto.
  rewrite cotree_bind_leaf; reflexivity.
Qed.

Lemma cotwp_cotuple_const_inl {A} a t :
  cotwp (cotuple (fun _ : unit => a) (fun _ : A => 0)) t =
    cotwp (cotuple (const 1) (const 0)) t * a.
Proof.
  rewrite eRmult_comm, cotwp_scalar.
  f_equal; ext lr; destruct lr as [[]|b]; eRauto.
Qed.

Lemma cowp_iid_chain_geometric_series {A}
  (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cowp f (iid_chain_ t i) = geometric_series (cowp f t) (cofail t) i.
Proof.
  unfold cowp.
  revert f t; induction i; intros f t; simpl.
  { rewrite cotwp_leaf; reflexivity. }
  rewrite <- IHi; clear IHi.
  unfold compose, cotuple, const.
  rewrite cotwp_bind.
  unfold compose.
  replace (fun x : unit + A =>
             cotwp (fun x0 : unit + A => match x0 with
                                      | inl _ => 0
                                      | inr b => f b
                                      end) match x with
               | inl _ => t
               | inr b => coleaf (inr b)
               end) with
    (cotuple (fun _ : unit => cotwp (cotuple (const 0) f) t) f).
  2: { ext lr; destruct lr as [[]|a]; simpl; auto.
       rewrite cotwp_leaf; reflexivity. }
  rewrite cotwp_cotuple.
  rewrite eRplus_comm.
  f_equal.
  replace (fun x : unit + A => match x with
                            | inl _ => 0
                            | inr b => f b
                            end) with
    (cotuple (fun _ : unit => 0) f) by reflexivity.
  revert f t; induction i; intros f t; simpl.
  { eRauto; rewrite cotwp_leaf; reflexivity. }
  rewrite eRmult_comm.
  rewrite eRmult_assoc.
  specialize (IHi f t).
  rewrite eRmult_comm in IHi.
  rewrite <- IHi; clear IHi.
  rewrite cotwp_bind.
  unfold compose.
  rewrite cotwp_scalar.
  f_equal; ext lr; destruct lr as [[]|a]; simpl.
  - apply cotwp_cotuple_const_inl.
  - unfold const; eRauto.
    rewrite cotwp_leaf; reflexivity.
Qed.

Lemma cotwp_iid_chain_geometric_series {A}
  (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cotwp f (iid_chain t i) = geometric_series (cowp f t) (cofail t) i.
Proof.
  unfold iid_chain.
  unfold snip.
  rewrite cotwp_bind.
  unfold cotuple, const, compose.
  replace (fun x : unit + A => cotwp f match x with
                                 | inl _ => cobot
                                 | inr b => coleaf b
                                 end) with
    (cotuple (fun _ : unit => 0) f).
  2: { ext lr; destruct lr as [[]|a]; simpl; auto.
       - rewrite cotwp_bot; reflexivity.
       - rewrite cotwp_leaf; reflexivity. }
  apply cowp_iid_chain_geometric_series.
Qed.

Lemma cotwp_iter_n_iid_F_iid_F' {A} (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cotwp f (iter_n (iid_F t) cobot i) = cotwp f (iter_n (iid_F' t) cobot i).
Proof.
  revert f t; induction i; intros f t; simpl; auto.
Qed.

Corollary cotwp_iter_n_geometric_series {A} (f : A -> eR) (t : cotree bool (unit + A)) (i : nat) :
  cotwp f (iter_n (iid_F t) cobot i) = geometric_series (cowp f t) (cofail t) i.
Proof.
  rewrite <- cotwp_iid_chain_geometric_series.
  rewrite cotwp_iter_n_iid_F_iid_F'.
  f_equal; rewrite iid_chain_iter_n; reflexivity.
Qed.

Theorem cotwp_tie_cotree_iid {A} (t : cotree bool (unit + A)) (f : A -> eR) :
  cofail t < 1 -> cotwp f (tie_cotree_iid t) = cowp f t / (1 - cofail t).
Proof.
  intro Hlt.
  unfold tie_cotree_iid.
  unfold cotree_iter.
  unfold iter.
  rewrite continuous_sup_eR; auto with cotcwp.
  2: { apply chain_directed, chain_iter_n'.
       - constructor.
       - apply continuous_monotone, continuous_iid_F. }
  etransitivity.
  2: { apply geometric_series_sup; eRauto. }
  f_equal; ext i.
  unfold compose.
  apply cotwp_iter_n_geometric_series.
Qed.

Lemma btwp_bounded {A} (f : A -> eR) t ub :
  bounded f ub ->
  btwp f t <= ub.
Proof.
  unfold btwp.
  revert f ub; induction t; intros f ub Hf; simpl; eRauto.
  rewrite <- eRplus_combine_fract.
  replace ub with (ub / 2 + ub / 2) by apply eRplus_half_plus_half.
  apply eRplus_le_compat; apply eRle_div, H; auto.
Qed.

Lemma btwp_btwlp_sum_1 {A} (f : A -> eR) t :
  bounded f 1 ->
  btwp f t + btwlp (fun x : A => 1 - f x) t = 1.
Proof.
  unfold btwp, btwlp.
  revert f; induction t; intros f Hf; simpl.
  - eRauto.
  - eRauto.
  - rewrite <- 2!eRplus_combine_fract, <- eRplus_assoc.
    rewrite eRplus_comm4, eRplus_assoc.
    etransitivity.
    2: { apply eRplus_half_plus_half. }
    f_equal; rewrite eRplus_combine_fract; f_equal; apply H; auto.
Qed.

Lemma cotwp_cotwlp_sum_1 {A} (f : A -> eR) (t : cotree bool A) :
  bounded f 1 ->
  cotwp f t + cotwlp (fun x => 1 - f x) t = 1.
Proof.
  intro Hf.
  unfold cotwp, cotwlp.
  unfold co, coop.
  eapply supremum_infimum_sum.
  6: { apply lattice_sup_spec; auto with eR. }
  6: { apply lattice_inf_spec; auto with eR. }
  { apply chain_f_ideal; eauto with cotcwp order. }
  { apply dec_chain_f_ideal, antimonotone_btwlp; intro; eRauto. }
  { intro i; unfold compose. simpl. unfold flip.
    apply btwp_bounded; eauto. }
  { intro i; unfold compose; simpl; unfold flip.
    apply btwlp_bounded; intro; eRauto. }
  intro i; unfold compose.
  apply btwp_btwlp_sum_1; auto.
Qed.

Corollary cofail_cowlp {A} (t : cotree bool (unit + A)) :
  cofail t = 1 - cowlp (const 1) t.
Proof.
  apply eRplus_eq_minus.
  { eRauto. }
  rewrite eRplus_comm.
  unfold cofail, cowpfail.
  etransitivity.
  2: { eapply cotwp_cotwlp_sum_1 with (f := cotuple (const 1) (const 0)).
       intros []; eRauto. }
  f_equal; unfold cowlp; f_equal.
  ext lr; destruct lr as [[]|s]; eRauto.
Qed.

Lemma cotwlp_bounded {A} (t : cotree bool A) (f : A -> eR) :
  bounded f 1 ->
  cotwlp f t <= 1.
Proof.
  intro Hf; apply leq_eRle, lattice_ge_inf with (i:=O); auto with eR.
Qed.

Corollary cowlp_cofail {A} (t : cotree bool (unit + A)) :
  cowlp (const 1) t = 1 - cofail t.
Proof.
  apply eRplus_eq_minus.
  { eRauto. }
  rewrite eRplus_comm.
  apply eRminus_eq_plus.
  { eRauto. }
  - apply cotwlp_bounded; intros [[]|a]; eRauto.
  - apply cofail_cowlp.
Qed.

Lemma cocwp_cotwp_tie_cotree {A} (t : cotree bool (unit + A)) (f : A -> eR) :
  cofail t < 1 ->
  cocwp f t = cotwp f (tie_cotree t).
Proof.
  intro Hlt.
  rewrite <- tie_cotree_iid_tie_cotree.
  rewrite cotwp_tie_cotree_iid; auto.
  unfold cocwp.
  f_equal.
  apply eRplus_eq_minus.
  { eRauto. }
  unfold cofail, cowpfail, cowlp.
  replace (cotuple (const 0) (const 1)) with
    (fun x => 1 - cotuple (fun _ : unit => 1) (fun _ : A => 0) x).
  2: { ext lr; destruct lr; eRauto. }
  apply cotwp_cotwlp_sum_1.
  intros [[]|s]; simpl; eRauto.
Qed.

Corollary cotwp_tie_cotree_iid_wlp {A} (t : cotree bool (unit + A)) (f : A -> eR) :
  0 < cowlp (const 1) t -> cotwp f (tie_cotree_iid t) = cowp f t / cowlp (const 1) t.
Proof.
  intro Hlt; rewrite cowlp_cofail; apply cotwp_tie_cotree_iid.
  rewrite cofail_cowlp.
  apply eRminus_pos_lt; eRauto.
Qed.


(* coq-prelude
 * Copyright (C) 2018 ANSSI
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program. If not, see <http://www.gnu.org/licenses/>.
 *)

From Coq Require Import Setoid.
From Equations Require Import Equations Signature.

From Prelude Require Import Control Equality.

Local Open Scope prelude_scope.
Local Open Scope list_scope.

Add Parametric Morphism
    (a:  Type)
   `{Equality a}
  : cons
    with signature (@equal a _)
                     ==> (@equal (list a) _)
                     ==> (@equal (list a) _)
      as cons_morphism.
Proof.
  intros x y Heqx r q Eqrst.
  constructor.
  exact Heqx.
  cbn in Eqrst.
  exact Eqrst.
Qed.

(* WORK IN PROGRESS *)

Equations list_map {a b:  Type} (f:  a -> b) (l:  list a) : list b :=
list_map _ nil := nil;
list_map f (cons x r) := (f x) :: (list_map f r).

Add Parametric Morphism
    (a b:  Type)
   `{Equality a}
   `{Equality b}
  : list_map
    with signature (@equal (a -> b) _)
                     ==> eq
                     ==> (@equal (list b) _)
      as list_map_morphism.
Proof.
  intros f g Heq s.
  cbn.
  induction s.
  + repeat rewrite list_map_equation_1.
    reflexivity.
  + repeat rewrite list_map_equation_2.
    constructor.
    ++ apply Heq.
    ++ exact IHs.
Qed.

Lemma list_map_nil
      {a b:  Type}
      (f:    a -> b)
  : list_map f nil = nil.
Proof.
 reflexivity.
Qed.

Instance list_Functor
  : Functor list :=
  { map := @list_map
  }.
+ intros a Ha x.
  induction x.
  ++ reflexivity.
  ++ rewrite list_map_equation_2.
     rewrite IHx.
     reflexivity.
+ induction x.
  ++ reflexivity.
  ++ rewrite list_map_equation_2.
     rewrite IHx.
     reflexivity.
Defined.

Definition list_pure
           {a:  Type}
           (x:  a)
  : list a :=
  x :: nil.

Equations concat {a:  Type} (l l':  list a) : list a :=
concat nil l' := l';
concat (cons x r) l' := x :: concat r l'.

Add Parametric Morphism
    (a:  Type)
   `{Equality a}
  : concat
    with signature (@equal (list a) _)
                     ==> (@equal (list a) _)
                     ==> (@equal (list a) _)
      as concat_list_morphism.
Proof.
  induction x.
  + intros y Heq r s Heqr.
    inversion Heq; subst.
    exact Heqr.
  + intros y Heq r s Heqr.
    inversion Heq; subst.
    Search concat.
    repeat rewrite concat_equation_2.
    constructor.
    ++ exact Heq0.
    ++ apply IHx.
       exact Heq'.
       exact Heqr.
Qed.

Lemma concat_nil
      {a:  Type}
      (l:  list a)
  : concat l nil = l.
Proof.
  induction l.
  + reflexivity.
  + rewrite concat_equation_2.
    rewrite IHl.
    reflexivity.
Qed.

Equations list_app {a b:  Type} (f:  list (a -> b)) (l:  list a) : list b :=
list_app (cons f r) l := concat (f <$> l) (list_app r l);
list_app nil _ := nil.

Equations list_app' {a b:  Type} (x:  a) (f:  list (a -> b)) (l:  list a) : list b :=
list_app' x (cons f r) l := concat (list_pure (f x)) (concat (f <$> l) (list_app' x r l));
list_app' _ nil _ := nil.

Lemma list_app_list_app'
      {a b:  Type}
      (lf:   list (a -> b))
      (x:    a)
      (rst:  list a)
  : list_app lf (x :: rst) = list_app' x lf rst.
Proof.
  induction lf.
  + rewrite list_app_equation_1.
    rewrite list_app'_equation_1.
    reflexivity.
  + rewrite list_app_equation_2.
    rewrite list_app'_equation_2.
    rewrite concat_equation_2.
    rewrite concat_equation_1.
    rewrite IHlf.
    cbn.
    rewrite list_map_equation_2.
    rewrite concat_equation_2.
    reflexivity.
Qed.

Lemma list_app_nil
      {a b:  Type}
      (f:    list (a -> b))
  : list_app f nil = nil.
Proof.
  induction f.
  + reflexivity.
  + rewrite list_app_equation_2.
    rewrite concat_equation_1.
    exact IHf.
Qed.

Add Parametric Morphism
    (a b:  Type)
   `{Equality a}
   `{Equality b}
  : list_app
    with signature (@equal (list (a -> b)) _)
                     ==> eq
                     ==> (@equal (list b) _)
      as list_app_morphism.
Proof.
  intros x y Heq.
  induction Heq.
  + intros s.
    repeat rewrite list_app_equation_2.
    rewrite Heq.
    rewrite IHHeq.
    reflexivity.
  + intros s.
    rewrite list_app_equation_1.
    reflexivity.
Qed.

Conjecture list_conjecture_applicative_1
  : forall (a b c:  Type) `{Equality c}
           (u:      list (b -> c))
           (v:      list (a -> b))
           (w:      list a),
    list_app (list_app (list_app (list_pure compose) u) v) w
    == list_app u (list_app v w).

Instance list_Applicative
  : Applicative (list) :=
  { pure   := @list_pure
  ; apply  := @list_app
  }.
Proof.
  + intros a Heq v.
    induction v.
    ++ reflexivity.
    ++ cbn in *.
       rewrite list_app_equation_2.
       rewrite list_app_equation_1.
       rewrite concat_nil.
       rewrite functor_identity.
       reflexivity.
  + apply list_conjecture_applicative_1.
  + intros a b Heq v x.
    rewrite list_app_equation_2.
    rewrite list_app_equation_1.
    rewrite concat_nil.
    cbn.
    rewrite list_map_equation_2.
    rewrite list_map_equation_1.
    reflexivity.
  + intros a b H u y.
    induction u.
    ++ rewrite list_app_equation_1.
       rewrite list_app_nil.
       reflexivity.
    ++ rewrite list_app_equation_2.
       rewrite IHu.
       cbn.
       rewrite list_map_equation_2.
       rewrite concat_equation_2.
       rewrite concat_equation_1.
       rewrite list_app_equation_2.
       rewrite list_app_equation_1.
       rewrite concat_nil.
       rewrite list_app_equation_2.
       rewrite list_app_equation_1.
       rewrite concat_nil.
       cbn.
       rewrite list_map_equation_2.
       reflexivity.
  + intros a b H g x.
    rewrite list_app_equation_2.
    rewrite list_app_equation_1.
    rewrite concat_nil.
    reflexivity.
Defined.


(** Brainfuck *)
(** @suharahiromicihi *)
(** 2019_10_26 *)

From mathcomp Require Import all_ssreflect.
Require Import ssrclosure.
Require Import ssrstring.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Inductive inst : Set :=                     (* c *)
| ileft                                     (* < *)
| iright                                    (* > *)
| iinc                                      (* + *)
| idec                                      (* - *)
| iin                                       (* , *)
| iout                                      (* . *)
| iloop (i : seq inst)                      (* [ と ] *)
.

Definition cstack := seq inst.              (* c :: cs *)
Definition lstack := seq nat.               (* l :: ls *)
Definition rstack := seq nat.               (* r :: rs *)
Definition input := seq nat.                (* x :: ins *)
Definition output := seq nat.               (* x :: outs *)
Definition env := (cstack * lstack * nat * rstack * input * output)%type.

Inductive step : relation env :=            (* env -> env -> Prop *)
| stepdone x rs ls ins outs :
    step (         [::],     ls,     x,      rs,      ins,      outs)
         (         [::],     ls,     x,      rs,      ins,      outs)
| stepleft_z x cs rs ins outs :             (* < *)
    step (ileft   :: cs,    [::],    x,      rs,      ins,      outs)
         (           cs,    [::],    0, x :: rs,      ins,      outs)
| stepleft_v x y cs ls rs ins outs :        (* < *)
    step (ileft   :: cs, y :: ls,    x,      rs,      ins,      outs)
         (           cs,      ls,    y, x :: rs,      ins,      outs)
| stepright_z x cs ls ins outs :            (* > *)
    step (iright  :: cs,      ls,    x,    [::],      ins,      outs)
         (           cs, x :: ls,    0,    [::],      ins,      outs)
| stepright_v x y cs rs ls ins outs :       (* > *)
    step (iright  :: cs,      ls,    x, y :: rs,      ins,      outs)
         (           cs, x :: ls,    y,      rs,      ins,      outs)
| stepinc x cs rs ls ins outs :             (* + *)
    step (iinc    :: cs,      ls,    x,      rs,      ins,      outs)
         (           cs,      ls, x.+1,      rs,      ins,      outs)
| stepdec x cs rs ls ins outs :             (* - *)
    step (idec    :: cs,      ls,    x,      rs,      ins,      outs)
         (           cs,      ls, x.-1,      rs,      ins,      outs)
| stepin_z x cs rs ls outs :                (* . *)
    step (iin     :: cs,      ls,    x,      rs,     [::],      outs)
         (           cs,      ls,    0,      rs,     [::],      outs)
| stepin_v x y cs rs ls ins outs :          (* . *)
    step (iin     :: cs,      ls,    x,      rs, y :: ins,      outs)
         (           cs,      ls,    y,      rs,      ins,      outs)
| stepout x cs rs ls ins outs :             (* , *)
    step (iout    :: cs,      ls,    x,      rs,      ins,      outs)
         (           cs,      ls,    x,      rs,      ins, x :: outs)
| steploop_z c cs rs ls ins outs :          (* [ *)
    step (iloop c :: cs,      ls,    0,      rs,      ins,      outs)
         (           cs,      ls,    0,      rs,      ins,      outs)
| steploop_v x c cs rs ls ins outs :        (* ] *)
    step (iloop c :: cs,      ls, x.+1,      rs,      ins,      outs)
 (c ++  (iloop c :: cs),      ls, x.+1,      rs,      ins,      outs)
.

Hint Constructors step.
Hint Constructors refl_step_closure.

Definition steprec := refl_step_closure step. (* env -> env -> Prop *)

Infix "|=>" := step (at level 50, no associativity).
Infix "|=>*" := steprec (at level 50, no associativity).

Lemma steprsc_refl (e : env) : e |=>* e.
Proof. done. Qed.

Lemma steprsc_refl' (e1 e2 : env) : e1 = e2 -> e1 |=>* e2.
Proof. by move=> <-. Qed.

Lemma steprsc_step' (e1 e2 : env) : e1 |=> e2 -> e1 |=>* e2.
Proof. by apply: rsc_R. Qed.

Lemma steprsc_step (e1 e2 e3 : env) : e1 |=> e2 -> e2 |=>* e3 -> e1 |=>* e3.
Proof. by apply: rsc_step. Qed.

Lemma steprsc_trans (e1 e2 e3 : env) : e1 |=>* e2 -> e2 |=>* e3 -> e1 |=>* e3.
Proof. by apply: rsc_trans. Qed.

Theorem decide_step (e1 : env) : exists (e2 : env), e1 |=> e2.
Proof.
  case: e1  => [[[[[cs ls] x] rs] ins] outs].
  case: cs => [|c cs].
  - by eexists; constructor.
  - case: c.
    + case: ls => [|x' ls']; by eexists; constructor.   (* < *)
    + case: rs => [|x' rs']; by eexists; constructor.   (* > *)
    + by eexists; constructor.                          (* + *)
    + by eexists; constructor.                          (* - *)
    + case: ins => [|x' ins']; by eexists; constructor. (* . *)
    + by eexists; constructor.                          (* , *)
    + move=> cs'.
      case: x => [| x']; by eexists; constructor. (* [ と ] *)
Defined.

Ltac stepstep_0 e1 e2 :=
  match eval hnf in (decide_step e1) with
  | (ex_intro _ _ ?p) => apply: (steprsc_step p)
  end.
Check ex_intro.
(* ex_intro P x H の
   P = (fun e2 : env => e1 |=> e2)
   x = e2
   H : e1 |=> e2、なる 命題
*)

Ltac stepstep :=
  match goal with
  | |- ?e1 |=>* ?e2 => stepstep_0 e1 e2
  end.

Definition sample :=
  [:: ileft;
     iinc;
     iout;
     ileft
  ].

Goal (sample, [::], 0, [::], [::], [::]) |=>*
     ([::],   [::], 0, [:: 1; 0], [::], [:: 1]).
Proof.
  do !stepstep.
  (* これが、無限ループにならないのは、cstack が空になるから。 *)
  done.
Qed.

Lemma test : exists x ls rs outputs,
    (sample, [::], 0, [::], [::], [::]) |=>* ([::], ls, x, rs, [::], outputs).
Proof.
  eexists.
  eexists.
  eexists.
  eexists.
  do !stepstep.
  match goal with
  | |- ?e1 |=>* ?e2 => idtac e2
  end.
  done.
Qed.

Print test.
(*
  これから
  ex_intro _ x (ex_intro ls (ex_intro rs (ex_intro out _)))
  をパターンを取り出すと、より計算しているように見える。
*)

(*
Variable H1 : ([:: vn 1], [:: idrop; idrop]) |=> ([::], [:: idrop]).
Variable H2 : ([::], [:: idrop]) |=> ([::], [::]).
Variable H3 : ([::], [::]) |=> ([::], [::]).

Goal ([:: vn 1], sample) |=>* ([::], [::]).
Proof.
  Check exists e2 : env, ([:: vn 1], sample) |=> e2.
  Check ex_intro (fun e2 : env => ([:: vn 1], [:: idrop; idrop]) |=> e2)
        ([::], [:: idrop])
        H1.
  apply: (steprsc_step H1).

  Check ex_intro (fun e2 : env => ([::], [:: idrop]) |=> e2)
        ([::], [::])
        H2.
  apply: (steprsc_step H2).

  Check ex_intro (fun e2 : env => ([::], [::]) |=> e2)
        ([::], [::])
        H3.
  apply: (steprsc_step H3).                 (* もう、進まない。 *)
  done.
Qed.
*)

(* ********* *)
(* Hello World!\n *)
(* ********* *)

(*
>+++++ +++++             initialize counter (cell #0) to 10
[                       use loop to set 70/100/30/10
    > +++++ ++              add  7 to cell #1
    > +++++ +++++           add 10 to cell #2
    > +++                   add  3 to cell #3
    > +                     add  1 to cell #4
<<<< -                  decrement counter (cell #0)
]
> ++ .                  print 'H'
> + .                   print 'e'
+++++ ++ .              print 'l'
.                       print 'l'
+++ .                   print 'o'
> ++ .                  print ' '
<< +++++ +++++ +++++ .  print 'W'
> .                     print 'o'
+++ .                   print 'r'
----- - .               print 'l'
----- --- .             print 'd'
> + .                   print '!'
> .                     print '\n'
 *)

Definition hello :=
  [::iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; (* 10 *)
     iloop [::iright; iinc; iinc; iinc; iinc; iinc; iinc; iinc; (* 7 *)
              iright; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; (* 10 *)
                iright; iinc; iinc; iinc;   (* 3 *)
                  iright; iinc;             (* 1 *)
                    ileft; ileft; ileft; ileft; idec];
     (* 70 100 30 10 *)
     iright; iinc; iinc; iout;                           (* H *)
       iright; iinc; iout;                               (* e *)
         iinc; iinc; iinc; iinc; iinc; iinc; iinc; iout; (* l *)
           iout;                                         (* l *)
           iinc; iinc; iinc; iout;                       (* o *)
             iright; iinc; iinc; iout;                   (*   *)
               ileft; ileft; iinc; iinc; iinc; iinc; iinc;
                 iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iinc; iout; (* W *)
                   iright; iout;             (* o *)
                     iinc; iinc; iinc; iout; (* r *)
                       idec; idec; idec; idec; idec; idec; iout; (* l *)
                         idec; idec; idec; idec; idec; idec; idec; idec; iout; (* d *)
                           iright; iinc; iout; (* ! *)
                             iright; iout].    (* \n *)

Goal exists ls x rs ins,
    (hello, [::], 0, [::], [::], [::])
      |=>*
      ([::], ls, x, rs, ins,
       [:: 10; 33; 100; 108; 114; 111; 87; 32; 111; 108; 108; 101; 72]).
(* \n ! d l r o W ' ' o l l e H *)
Proof.
  do !eexists.
  do !stepstep => /=.
  done.
Qed.

(* ****** *)
(* Parser *)
(* ****** *)

(* このパーサは、特に以下を参考にしました。 *)
(* https://qiita.com/erutuf13/items/98f15cc7e74b0570c971 *)

Fixpoint parse' (str : string) : (cstack * seq cstack)%type :=
  match str with
  | ""%string => ([::], [::])
  | String x xs =>
    let (body, rest) := parse' xs in
    match x with
    | ">"%char => (iright :: body, rest)
    | "<"%char => (ileft  :: body, rest)
    | "+"%char => (iinc   :: body, rest)
    | "-"%char => (idec   :: body, rest)
    | ","%char => (iin    :: body, rest)
    | "."%char => (iout   :: body, rest)
    | "["%char =>
      match rest with
      | [::]       => ([:: iloop body], [::])
      | s :: rest' => (iloop body :: s, rest')
      end
    | "]"%char => ([::], body :: rest)
    | _        => ([::], [::])
    end
  end.

Definition parse str := (parse' str).1.

Compute parse ",>,<[-<+>]<.".
Compute parse ",>,<[->[->>+<<]>>[-<+<+>>]<<<]>>.".
Compute parse "+[>.+<]".

(* END *)


Require Import VST.floyd.proofauto.
Require Import sha.SHA256.
Require Import sha.sha.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.

Lemma Zland_15:
 forall i, Z.land i 15 = i mod 16.
Proof.
intros.
change 15%Z with (Z.ones 4).
rewrite Z.land_ones by (compute; congruence).
reflexivity.
Qed.

Lemma Znth_nthi:
  forall i b,
  (0 <= i < Zlength b)%Z -> Znth i b = nthi b i.
Proof.
intros; unfold Znth.
rewrite if_false by omega.
reflexivity.
Qed.

Hint Rewrite Znth_nthi using (auto; omega) : sublist.

Lemma Zland_in_range:
  forall i, (0 <= Z.land i 15 < 16)%Z.
Proof.
intros.
rewrite Zland_15. apply Z_mod_lt. compute; congruence.
Qed.
Hint Resolve Zland_in_range.

Lemma and_mone':
 forall x, Int.and x (Int.repr (-1)) = x.
Proof.
apply Int.and_mone.
Qed.

Lemma Sigma_1_eq: forall f_,
  Sigma_1 f_ =
            (Int.xor
              (Int.xor
                 (Int.or (Int.shl f_ (Int.repr 26))
                    (Int.shru (Int.and f_ (Int.repr (-1)))
                       (Int.sub (Int.repr 32) (Int.repr 26))))
                 (Int.or (Int.shl f_ (Int.repr 21))
                    (Int.shru (Int.and f_ (Int.repr (-1)))
                       (Int.sub (Int.repr 32) (Int.repr 21)))))
              (Int.or (Int.shl f_ (Int.repr 7))
                 (Int.shru (Int.and f_ (Int.repr (-1)))
                    (Int.sub (Int.repr 32) (Int.repr 7))))).
Proof.
intros.
unfold Sigma_1, Rotr.
repeat rewrite and_mone'.
repeat rewrite <- Int.or_ror by reflexivity.
change (Int.sub (Int.repr 32) (Int.repr 26)) with (Int.repr 6).
change (Int.sub (Int.repr 32) (Int.repr 21)) with (Int.repr 11).
change (Int.sub (Int.repr 32) (Int.repr 7)) with (Int.repr 25).
reflexivity.
Qed.

Lemma  Sigma_0_eq: forall b_,
   Sigma_0 b_ =
      (Int.xor
        (Int.xor
           (Int.or (Int.shl b_ (Int.repr 30))
              (Int.shru (Int.and b_ (Int.repr (-1)))
                 (Int.sub (Int.repr 32) (Int.repr 30))))
           (Int.or (Int.shl b_ (Int.repr 19))
              (Int.shru (Int.and b_ (Int.repr (-1)))
                 (Int.sub (Int.repr 32) (Int.repr 19)))))
        (Int.or (Int.shl b_ (Int.repr 10))
           (Int.shru (Int.and b_ (Int.repr (-1)))
              (Int.sub (Int.repr 32) (Int.repr 10))))).
Proof.
intros.
unfold Sigma_0, Rotr.
repeat rewrite and_mone'.
repeat rewrite <- Int.or_ror by reflexivity.
change (Int.sub (Int.repr 32) (Int.repr 19)) with (Int.repr 13).
change (Int.sub (Int.repr 32) (Int.repr 10)) with (Int.repr 22).
change (Int.sub (Int.repr 32) (Int.repr 30)) with (Int.repr 2).
reflexivity.
Qed.

Lemma Ch_eq: forall f_ g_ h_,
  Ch f_ g_ h_ =
        (Int.xor (Int.and f_ g_) (Int.and (Int.not f_) h_)).
Proof. reflexivity.
Qed.

Lemma Maj_eq:
  forall b c d,
  Maj b c d =
  (Int.xor (Int.xor (Int.and b c) (Int.and b d)) (Int.and c d)).
Proof.
intros.
unfold Maj.
rewrite (Int.xor_commut) at 1.
rewrite Int.xor_assoc. auto.
Qed.

Lemma sigma_1_eq:
 forall s, sigma_1 s =
   Int.xor
     (Int.xor
        (Int.or (Int.shl s (Int.repr 15))
           (Int.shru s (Int.sub (Int.repr 32) (Int.repr 15))))
        (Int.or (Int.shl s (Int.repr 13))
           (Int.shru s (Int.sub (Int.repr 32) (Int.repr 13)))))
  (Int.shru s (Int.repr 10)).
Proof.
intros.
unfold sigma_1.
f_equal. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
Qed.

Lemma sigma_0_eq:
 forall s, sigma_0 s =
  Int.xor
   (Int.xor
     (Int.or (Int.shl s (Int.repr 25))
        (Int.shru s (Int.sub (Int.repr 32) (Int.repr 25))))
     (Int.or (Int.shl s (Int.repr 14))
        (Int.shru s (Int.sub (Int.repr 32) (Int.repr 14)))))
   (Int.shru s (Int.repr 3)).
Proof.
intros.
unfold sigma_0.
f_equal. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
repeat rewrite <- Int.or_ror by reflexivity.
unfold Rotr. f_equal.
Qed.

Lemma and_mod_15_lem:
 forall (n: Z),
 (0 <= Int.signed (Int.and (Int.repr n) (Int.repr 15)) < 16)%Z.
Proof.
intro n.
unfold Int.and.
rewrite (Int.unsigned_repr 15) by rep_omega.
change 15%Z with (Z.ones 4).
assert (0 <= Z.land (Int.unsigned (Int.repr n)) (Z.ones 4) < 16)%Z.
rewrite Z.land_ones.
apply Z.mod_bound_pos.
apply Int.unsigned_range. clear; omega. clear; omega.
rewrite Int.signed_repr; auto.
rep_omega.
Qed.

Definition c64 := 64%nat.  Global Opaque c64.
Definition c48 := 48%nat.  Global Opaque c48.


(** * Norm_J: STLCの正規化 *)
(* * Norm: Normalization of STLC *)

(* $Date: 2011-04-13 14:34:47 -0400 (Wed, 13 Apr 2011) $ *)
(* Chapter maintained by Andrew Tolmach *)

(* (Based on TAPL Ch. 12.) *)

Require Import Stlc_J.
Require Import Relations.

(*
(This chapter is optional.)

In this chapter, we consider another fundamental theoretical property
of the simply typed lambda-calculus: the fact that the evaluation of a
well-typed program is guaranteed to halt in a finite number of
steps---i.e., every well-typed term is _normalizable_.

Unlike the type-safety properties we have considered so far, the
normalization property does not extend to full-blown programming
languages, because these languages nearly always extend the simply
typed lambda-calculus with constructs, such as general recursion
(as we discussed in the MoreStlc chapter) or recursive types, that can
be used to write nonterminating programs.  However, the issue of
normalization reappears at the level of _types_ when we consider the
metatheory of polymorphic versions of the lambda calculus such as
F_omega: in this system, the language of types effectively contains a
copy of the simply typed lambda-calculus, and the termination of the
typechecking algorithm will hinge on the fact that a ``normalization''
operation on type expressions is guaranteed to terminate.

Another reason for studying normalization proofs is that they are some
of the most beautiful---and mind-blowing---mathematics to be found in
the type theory literature, often (as here) involving the fundamental
proof technique of _logical relations_.

The calculus we shall consider here is the simply typed
lambda-calculus over a single base type [bool] and with pairs. We'll
give full details of the development for the basic lambda-calculus
terms treating [bool] as an uninterpreted base type, and leave the
extension to the boolean operators and pairs to the reader.  Even for
the base calculus, normalization is not entirely trivial to prove,
since each reduction of a term can duplicate redexes in subterms. *)
(**
(この章はオプションです。)

この章では、単純型付きラムダ計算の別の基本的な理論的性質を検討します。
型付けされるプログラムは有限回のステップで停止することが保証されるという事実です。
つまり、すべての型付けされた項は正規化可能(_normalizable_)です。

ここまで考えてきた型安全性とは異なり、
正規化性は本格的なプログラミング言語には拡張されません。
なぜなら、本格的な言語ではほとんどの場合、単純型付きラムダ計算に、
(MoreStlc_J章で議論したような)一般再帰や再帰型が拡張され、
停止しないプログラムが書けるようになっているからです。
しかし、正規化性の問題は「型のレベル」で再度現れます。
それが現れるのは、F_ωのようなラムダ計算の多相バージョンの、メタ理論を考えるときです。
F_ωでは、型の言語は単純型付きラムダ計算のコピーを効果的に包括しており、
型チェックアルゴリズムの停止性は、
型の式の「正規化」操作が停止することが保証されていることに依拠しています。

正規化の証明を学習する別の理由は、それが、
(ここでやっているように)論理的関係の基本的証明テクニックを含むような型理論の文献に見られる、
一番美しい---そして刺激的な---数学だからです。

ここで考える計算は、基本型[bool]と対を持つ単純型付きラムダ計算です。
ここでは[bool]を未解釈基本型として扱う基本ラムダ計算項の処理を細部まで示します。
ブール演算と対の拡張は読者に残しておきます。
基本計算においてさえ、正規化は証明が完全に自明ということはありません。
なぜなら、項の各簡約は部分項のリデックスを複製することがあるからです。 *)

(* **** Exercise: 1 star *)
(** **** 練習問題: ★ *)
(* Where do we fail if we attempt to prove normalization by a
straightforward induction on the size of a well-typed term? *)
(** 型付けされた項のサイズについての素直な帰納法で正規化性を証明しようとしたとき、
    どこで失敗するでしょうか？ *)

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

(* ###################################################################### *)
(* * Language *)
(** * 言語 *)

(* We begin by repeating the relevant language definition, which is
similar to those in the MoreStlc chapter, and supporting results
including type preservation and step determinism.  (We won't need
progress.)  You may just wish to skip down to the Normalization
section... *)
(** 関係する言語の定義から始めます。MoreStlc_J章のものと同様です。
そして、型の保存とステップの決定性を含む結果も成立します。
(進行は使いません。)
正規化の節まで飛ばしても構いません... *)

(* ###################################################################### *)
(* *** Syntax and Operational Semantics *)
(** *** 構文と操作的意味 *)

Inductive ty : Type :=
  | ty_Bool : ty
  | ty_arrow : ty -> ty -> ty
  | ty_prod  : ty -> ty -> ty
.

Tactic Notation "ty_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ty_Bool" | Case_aux c "ty_arrow" | Case_aux c "ty_prod" ].

Inductive tm : Type :=
    (* pure STLC *)
  | tm_var : id -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : id -> ty -> tm -> tm
    (* pairs *)
  | tm_pair : tm -> tm -> tm
  | tm_fst : tm -> tm
  | tm_snd : tm -> tm
    (* booleans *)
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm.
          (* i.e., [if t0 then t1 else t2] *)

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

(* ###################################################################### *)
(* *** Substitution *)
(** *** 置換 *)

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

(* ###################################################################### *)
(* *** Reduction *)
(** *** 簡約 *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tm_abs x T11 t12)
  | v_pair : forall v1 v2,
      value v1 ->
      value v2 ->
      value (tm_pair v1 v2)
  | v_true : value tm_true
  | v_false : value tm_false
.

Hint Constructors value.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tm_app (tm_abs x T11 t12) v2) ==> (subst x v2 t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tm_app t1 t2) ==> (tm_app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tm_app v1 t2) ==> (tm_app v1 t2')
  (* pairs *)
  | ST_Pair1 : forall t1 t1' t2,
        t1 ==> t1' ->
        (tm_pair t1 t2) ==> (tm_pair t1' t2)
  | ST_Pair2 : forall v1 t2 t2',
        value v1 ->
        t2 ==> t2' ->
        (tm_pair v1 t2) ==> (tm_pair v1 t2')
  | ST_Fst : forall t1 t1',
        t1 ==> t1' ->
        (tm_fst t1) ==> (tm_fst t1')
  | ST_FstPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (tm_fst (tm_pair v1 v2)) ==> v1
  | ST_Snd : forall t1 t1',
        t1 ==> t1' ->
        (tm_snd t1) ==> (tm_snd t1')
  | ST_SndPair : forall v1 v2,
        value v1 ->
        value v2 ->
        (tm_snd (tm_pair v1 v2)) ==> v2
  (* booleans *)
  | ST_IfTrue : forall t1 t2,
        (tm_if tm_true t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
        (tm_if tm_false t1 t2) ==> t2
  | ST_If : forall t0 t0' t1 t2,
        t0 ==> t0' ->
        (tm_if t0 t1 t2) ==> (tm_if t0' t1 t2)

where "t1 '==>' t2" := (step t1 t2).

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

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

Hint Constructors step.

Notation step_normal_form := (normal_form step).

Lemma value__normal : forall t, value t -> step_normal_form t.
Proof with eauto.
  intros t H; induction H; intros [t' ST]; inversion ST...
Qed.

(* ###################################################################### *)
(* *** Typing *)
(** *** 型付け *)

Definition context := partial_map ty.

Inductive has_type : context -> tm -> ty -> Prop :=
  (* Typing rules for proper terms *)
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tm_var x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tm_abs x T11 t12) (ty_arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (ty_arrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tm_app t1 t2) T2
  (* pairs *)
  | T_Pair : forall Gamma t1 t2 T1 T2,
      has_type Gamma t1 T1 ->
      has_type Gamma t2 T2 ->
      has_type Gamma (tm_pair t1 t2) (ty_prod T1 T2)
  | T_Fst : forall Gamma t T1 T2,
      has_type Gamma t (ty_prod T1 T2) ->
      has_type Gamma (tm_fst t) T1
  | T_Snd : forall Gamma t T1 T2,
      has_type Gamma t (ty_prod T1 T2) ->
      has_type Gamma (tm_snd t) T2
  (* booleans *)
  | T_True : forall Gamma,
      has_type Gamma tm_true ty_Bool
  | T_False : forall Gamma,
      has_type Gamma tm_false ty_Bool
  | T_If : forall Gamma t0 t1 t2 T,
      has_type Gamma t0 ty_Bool ->
      has_type Gamma t1 T ->
      has_type Gamma t2 T ->
      has_type Gamma (tm_if t0 t1 t2) T
.

Hint Constructors has_type.

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

Hint Extern 2 (has_type _ (tm_app _ _) _) => eapply T_App; auto.
Hint Extern 2 (_ = _) => compute; reflexivity.

(* ###################################################################### *)
(* *** Context Invariance *)
(** *** コンテキスト不変性 *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tm_var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tm_app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tm_app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tm_abs y T11 t12)
  (* pairs *)
  | afi_pair1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tm_pair t1 t2)
  | afi_pair2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tm_pair t1 t2)
  | afi_fst : forall x t,
      appears_free_in x t ->
      appears_free_in x (tm_fst t)
  | afi_snd : forall x t,
      appears_free_in x t ->
      appears_free_in x (tm_snd t)
  (* booleans *)
  | afi_if0 : forall x t0 t1 t2,
      appears_free_in x t0 ->
      appears_free_in x (tm_if t0 t1 t2)
  | afi_if1 : forall x t0 t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (tm_if t0 t1 t2)
  | afi_if2 : forall x t0 t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (tm_if t0 t1 t2)
.

Hint Constructors appears_free_in.

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

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  has_type_cases (induction H) Case;
    intros Gamma' Heqv...
  Case "T_Var".
    apply T_Var... rewrite <- Heqv...
  Case "T_Abs".
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold extend. remember (beq_id x y) as e.
    destruct e...
  Case "T_Pair".
    apply T_Pair...
  Case "T_If".
    eapply T_If...
Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  has_type_cases (induction Htyp) Case; inversion Hafi; subst...
  Case "T_Abs".
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold extend in Hctx.
    apply not_eq_beq_id_false in H2. rewrite H2 in Hctx...
Qed.

Corollary typable_empty__closed : forall t T,
    has_type empty t T  ->
    closed t.
Proof.
  intros. unfold closed. intros x H1.
  destruct (free_in_context _ _ _ _ H1 H) as [T' C].
  inversion C.  Qed.

(* ###################################################################### *)
(* *** Preservation *)
(** *** 保存 *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (extend Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma (subst x v t) S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- (subst x v t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow directly
     from the IH, with the exception of tm_var and tm_abs.
     The former aren't automatic because we must reason about how the
     variables interact. *)
  tm_cases (induction t) Case;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  Case "tm_var".
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [extend Gamma x U y = Some S].  We want to
       show that [Gamma |- subst x v y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then we know that [U = S], and that [subst x v y = v].
       So what we really must show is that if [empty |- v : U] then
       [Gamma |- v : U].  We have already proven a more general version
       of this theorem, called context invariance. *)
      apply beq_id_eq in Heqe. subst.
      unfold extend in H1. rewrite <- beq_id_refl in H1.
      inversion H1; subst. clear H1.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
    (* If [x <> y], then [Gamma y = Some S] and the substitution has no
       effect.  We can show that [Gamma |- y : S] by [T_Var]. *)
      apply T_Var... unfold extend in H1. rewrite <- Heqe in H1...
  Case "tm_abs".
    rename i into y. rename t into T11.
    (* If [t = tm_abs y T11 t0], then we know that
         [Gamma,x:U |- tm_abs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- subst x v t0 S].

       We can calculate that
         subst x v t = tm_abs y T11 (if beq_id x y
                                      then t0
                                      else subst x v t0)
       And we must show that [Gamma |- subst x v t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else subst x v t0 : T12]
       We consider two cases: [x = y] and [x <> y].
    *)
    apply T_Abs...
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
    (* If [x = y], then the substitution has no effect.  Context
       invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
       equivalent.  Since the former context shows that [t0 : T12], so
       does the latter. *)
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
    (* If [x <> y], then the IH and context invariance allow us to show that
         [Gamma,x:U,y:T11 |- t0 : T12]       =>
         [Gamma,y:T11,x:U |- t0 : T12]       =>
         [Gamma,y:T11 |- subst x v t0 : T12] *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.  Many cases are
     contradictory ([T_Var], [T_Abs]).  We show just the interesting ones. *)
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    (* If the last rule used was [T_App], then [t = t1 t2], and three rules
       could have been used to show [t ==> t']: [ST_App1], [ST_App2], and
       [ST_AppAbs]. In the first two cases, the result follows directly from
       the IH. *)
    inversion HE; subst...
    SCase "ST_AppAbs".
      (* For the third case, suppose
           [t1 = tm_abs x T11 t12]
         and
           [t2 = v2].
         We must show that [empty |- subst x v2 t12 : T2].
         We know by assumption that
             [empty |- tm_abs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  Case "T_Fst".
    inversion HT...
  Case "T_Snd".
    inversion HT...
Qed.
(** [] *)

(* ###################################################################### *)
(* *** Determinism *)
(** *** 決定性 *)

Lemma step_deterministic :
   partial_function step.
Proof with eauto.
   unfold partial_function.
   (* FILL IN HERE *)
   (** ここを埋めなさい *) Admitted.

(* ###################################################################### *)
(* * Normalization *)
(** * 正規化 *)

(* Now for the actual normalization proof.

    Our goal is to prove that every well-typed term evaluates to a
    normal form.  In fact, it turns out to be convenient to prove
    something slightly stronger, namely that every well-typed term
    evaluates to a _value_.  This follows from the weaker property
    anyway via the Progress lemma (why?) but otherwise we don't need
    Progress, and we didn't bother re-proving it above.

    Here's the key definition: *)
(** ここからが本当の正規化の証明です。

    ゴールはすべての型付けされた項が正規形になることを証明することです。
    実際のところ、もうちょっと強いことを証明した方が便利です。
    つまり、すべての型付けされた項が値になるということです。
    この強い方は、いずれにしろ弱い方から進行補題を使って得ることができますが(なぜでしょう？)、
    最初から強い方を証明すれば進行性は必要ありません。
    そして、進行性を再び証明することは上では行いませんでした。

    これがキーとなる定義です: *)

Definition halts  (t:tm) : Prop :=  exists t', t ==>* t' /\  value t'.

(* A trivial fact: *)
(** あたりまえの事実: *)

Lemma value_halts : forall v, value v -> halts v.
Proof.
  intros v H. unfold halts.
  exists v. split.
  apply rsc_refl.
  assumption.
Qed.

(* The key issue in the normalization proof (as in many proofs by
induction) is finding a strong enough induction hypothesis.  To this
end, we begin by defining, for each type [T], a set [R_T] of closed
terms of type [T].  We will specify these sets using a relation [R]
and write [R T t] when [t] is in [R_T]. (The sets [R_T] are sometimes
called _saturated sets_ or _reducibility candidates_.)

Here is the definition of [R] for the base language:

- [R bool t] iff [t] is a closed term of type [bool] and [t] halts in a value

- [R (T1 -> T2) t] iff [t] is a closed term of type [T1 -> T2] and [t] halts
  in a value _and_ for any term [s] such that [R T1 s], we have [R
  T2 (t s)]. *)
(** 正規化の証明のキーとなる問題は、
(多くの帰納法による証明と同様に)十分な強さの帰納法の仮定を見つけることです。
このために、それぞれの型[T]に対して型[T]の閉じた項の集合[R_T]を定義することから始めます。
これらの集合を関係[R]を使って定め、[t]が[R_T]の要素であることを [R T t] と書きます。
(集合[R_T]はしばしば飽和集合(_saturated sets_)あるいは簡約可能性候補
(_reducibility candidates_)と呼ばれます。)

基本言語に対する[R]の定義は以下の通りです:

- [R bool t] とは、[t]が型[bool]の閉じた項で[t]が値になることである

- [R (T1 -> T2) t] とは、[t]が型 [T1 -> T2] の閉じた項で、[t]が値になり、かつ、
  [R T1 s] となる任意の項[s]について、[R T2 (t s)] となることである。 *)

(* This definition gives us the strengthened induction hypothesis that we
need.  Our primary goal is to show that all _programs_ ---i.e., all
closed terms of base type---halt.  But closed terms of base type can
contain subterms of functional type, so we need to know something
about these as well.  Moreover, it is not enough to know that these
subterms halt, because the application of a normalized function to a
normalized argument involves a substitution, which may enable more
evaluation steps.  So we need a stronger condition for terms of
functional type: not only should they halt themselves, but, when
applied to halting arguments, they should yield halting results.

The form of [R] is characteristic of the _logical relations_ proof
technique.  (Since we are just dealing with unary relations here, we
could perhaps more properly say _logical predicates_.)  If we want to
prove some property [P] of all closed terms of type [A], we proceed by
proving, by induction on types, that all terms of type [A] _possess_
property [P], all terms of type [A->A] _preserve_ property [P], all
terms of type [(A->A)->(A->A)] _preserve the property of preserving_
property [P], and so on.  We do this by defining a family of
predicates, indexed by types.  For the base type [A], the predicate is
just [P].  For functional types, it says that the function should map
values satisfying the predicate at the input type to values satisfying
the predicate at the output type.

When we come to formalize the definition of [R] in Coq, we hit a
problem.  The most obvious formulation would be as a parameterized
Inductive proposition like this:

[[
Inductive R : ty -> tm -> Prop :=
| R_bool : forall b t, has_type empty t ty_Bool ->
                halts t ->
                R ty_Bool t
| R_arrow : forall T1 T2 t, has_type empty t (ty_arrow T1 T2) ->
                halts t ->
                (forall s, R T1 s -> R T2 (tm_app t s)) ->
                R (ty_arrow T1 T2) t.
]]

Unfortunately, Coq rejects this definition because it violates the
_strict positivity requirement_ for inductive definitions, which says
that the type being defined must not occur to the left of an arrow in
the type of a constructor argument. Here, it is the third argument to
[R_arrow], namely [(forall s, R T1 s -> R TS (tm_app t s))], and
specifically the [R T1 s] part, that violates this rule.  (The
outermost arrows separating the constructor arguments don't count when
applying this rule; otherwise we could never have genuinely inductive
predicates at all!)  The reason for the rule is that types defined
with non-positive recursion can be used to build non-terminating
functions, which as we know would be a disaster for Coq's logical
soundness. Even though the relation we want in this case might be
perfectly innocent, Coq still rejects it because it fails the
positivity test.

Fortunately, it turns out that we _can_ define [R] using a
[Fixpoint]: *)
(** この定義は必要な強化された帰納法の仮定を与えます。
最初のゴールはすべてのプログラム(つまり、基本型のすべての閉じた項)が停止することを示すことです。
しかし、基本型の閉じた項は関数型の部分項を含むこともできるので、
これらについても性質を知ることが必要です。
さらに、これらの部分項が停止することを知るだけでは不十分です。なぜなら、
正規化された関数を正規化された引数へ適用すると置換が行われるため、
さらに評価ステップが発生する可能性があるからです。
これから関数型の項についてより強い条件が必要です。つまり、
自分自身が停止するだけでなく、停止する引数に適用されると停止する結果にならなければならないという条件です。

[R]の形は論理的関係(_logical relations_)証明テクニックの特徴です。
(ここで扱うのは単項関係のみなので、おそらく論理的述語(_logical predicates_)
という方がより適切でしょう。)
型[A]のすべての閉じた項についてある性質[P]を証明したい場合、
型についての帰納法により、型[A]のすべての項が性質[P]を「持ち」、型[A->A]
のすべての項が性質[P]を「保存し」、型[(A->A)->(A->A)]のすべての項が性質[P]を
「保存することを保存し」、...ということを証明していきます。
このために型をインデックスとする述語の族を定義します。
基本型[A]に対しては、述語は単に[P]です。関数型に対しては、述語は、
その関数が入力の型の述語を満たす値を出力の型の述語を満たす値に写像することを言うものです。

Coqで[R]の定義を形式化しようとするとき、問題が生じます。
一番自明な形式化は、次のようなパラメータ化された Inductive による命題でしょう：

[[
Inductive R : ty -> tm -> Prop :=
| R_bool : forall b t, has_type empty t ty_Bool ->
                halts t ->
                R ty_Bool t
| R_arrow : forall T1 T2 t, has_type empty t (ty_arrow T1 T2) ->
                halts t ->
                (forall s, R T1 s -> R T2 (tm_app t s)) ->
                R (ty_arrow T1 T2) t.
]]

残念ながらCoqはこの定義を受け付けません。なぜなら帰納的定義の
_strict positivity requirement_を満たさないからです。
_strict positivity requirement_とは、
定義される型がコンストラクタ引数の型の矢印の左に現れてはいけないというものです。
ここで、この規則を破っているのは、[R_arrow]の第3引数、すなわち、
[(forall s, R T1 s -> R TS (tm_app t s))] の、特に [R T1 s] の部分です。
(一番外側のコンストラクタ引数を分離している矢印は規則の対象外です。
そうでなければ、純粋な帰納的述語はまったく定義できません!)
この規則がある理由は、正ではない再帰(non-positive recursion)
を使って定義された型は停止しない関数を作るのに使うことができ、
それがCoqの論理的健全性を脅かすからです。
ここで定義しようとしている関係が完全に問題ないものであるにもかかわらず、
_strict positivity requirement_のテストを通らないので、Coqはこれを拒否します。

幸い、[Fixpoint]を使うと[R]が定義できます: *)

Fixpoint R (T:ty) (t:tm) {struct T} : Prop :=
  has_type empty t T /\ halts t /\
  (match T with
   | ty_Bool  => True
   | ty_arrow T1 T2 => (forall s, R T1 s -> R T2 (tm_app t s))
(* FILL IN HERE *)
(** ここを埋めなさい *)
   | ty_prod T1 T2 => False (* ... and delete this line *)
   end).

(* As immediate consequences of this definition, we have that every
element of every set [R_T] halts in a value and is closed with type
[t] :*)
(** この定義からすぐに導かれることとして、
すべての集合[R_T]について、
そのすべての要素は停止して値となり、また型[T]について閉じていることが言えます: *)

Lemma R_halts : forall {T} {t}, R T t -> halts t.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1;  assumption.
Qed.

Lemma R_typable_empty : forall {T} {t}, R T t -> has_type empty t T.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1; assumption.
Qed.

(* Now we proceed to show the main result, which is that every
well-typed term of type [T] is an element of [R_T].  Together with
[R_halts], that will show that every well-typed term halts in a
value.  *)
(** さて、メインの結果に進みます。
すべての型[T]の項が[R_T]の要素であることを示すことです。
[R_halts]と組み合わせると、すべての型付けされる項は停止して値になることが示されます。 *)

(* ###################################################################### *)
(* **  Membership in [R_T] is invariant under evaluation *)
(** **  [R_T] の要素であるか否かは評価によって変化しない *)

(* We start with a preliminary lemma that shows a kind of strong
preservation property, namely that membership in [R_T] is _invariant_
under evaluation. We will need this property in both directions,
i.e. both to show that a term in [R_T] stays in [R_T] when it takes a
forward step, and to show that any term that ends up in [R_T] after a
step must have been in [R_T] to begin with.

First of all, an easy preliminary lemma. Note that in the forward
direction the proof depends on the fact that our language is
determinstic. This lemma might still be true for non-deterministic
languages, but the proof would be harder! *)
(** 一種の強保存性を示す予備的補題から始めます。[R_T]の要素であるか否かは
評価によって「不変」(_invariant_)であるという補題です。
この性質は両方向が必要です。つまり、[R_T]の項がステップを進めても[R_T]にあることを示すことと、
ステップ後[R_T]の要素になる任意の項が最初から[R_T]であることを示すことです。

一番最初に、簡単な予備的補題です。
前向き方法については、言語が決定性を持つという事実に証明が依存していることに注意します。
この補題は非決定的な言語でも成立するかもしれませんが、証明はより難しくなるでしょう! *)

Lemma step_preserves_halting : forall t t', (t ==> t') -> (halts t <-> halts t').
Proof.
 intros t t' ST.  unfold halts.
 split.
 Case "->".
  intros [t'' [STM V]].
  inversion STM; subst.
   apply ex_falso_quodlibet.  apply value__normal in V. unfold normal_form in V. apply V. exists t'. auto.
   rewrite (step_deterministic _ _ _ ST H). exists t''. split; assumption.
 Case "<-".
  intros [t'0 [STM V]].
  exists t'0. split; eauto.
Qed.

(* Now the main lemma, which comes in two parts, one for each
   direction.  Each proceeds by induction on the structure of the type
   [T].  In fact, this is where we make fundamental use of the
   finiteness of types.

   One requirement for staying in [R_T] is to stay in type [T]. In the
   forward direction, we get this from ordinary type Preservation. *)
(** さてメインの補題ですが、2つの方向に対応する2つの部分から成ります。
   それぞれは型[T]の構造についての帰納法で進みます。
   事実、ここでは型の有限性を本質的な部分で使っています。

   ステップを進んだ結果が[R_T]の要素であるためには型[T]を持つことが必要です。
   このことは、前向き方向については、もともとの型保存から得られます。 *)

Lemma step_preserves_R : forall T t t', (t ==> t') -> R T t -> R T t'.
Proof.
 induction T;  intros t t' E Rt; unfold R; fold R; unfold R in Rt; fold R in Rt;
               destruct Rt as [typable_empty_t [halts_t RRt]].
  (* ty_Bool *)
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  auto.
  (* ty_arrow *)
  split. eapply preservation; eauto.
  split. apply (step_preserves_halting _ _ E); eauto.
  intros.
  eapply IHT2.
  apply  ST_App1. apply E.
  apply RRt; auto.
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

(* The generalization to multiple steps is trivial: *)
(** 複数ステップへの一般化については自明です: *)

Lemma stepmany_preserves_R : forall T t t',
  (t ==>* t') -> R T t -> R T t'.
Proof.
  intros T t t' STM; induction STM; intros.
  assumption.
  apply IHSTM. eapply step_preserves_R. apply H. assumption.
Qed.

(* In the reverse direction, we must add the fact that [t] has type
   [T] before stepping as an additional hypothesis. *)
(** 逆向き方向については、
   [t]がステップ前に型[T]を持つという事実を追加の仮定として加える必要があります。 *)

Lemma step_preserves_R' : forall T t t',
  has_type empty t T -> (t ==> t') -> R T t' -> R T t.
Proof.
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

Lemma stepmany_preserves_R' : forall T t t',
  has_type empty t T -> (t ==>* t') -> R T t' -> R T t.
Proof.
  intros T t t' HT STM.
  induction STM; intros.
    assumption.
    eapply step_preserves_R'.  assumption. apply H. apply IHSTM.
    eapply preservation;  eauto. auto.
Qed.

(* ###################################################################### *)
(* ** Closed instances of terms of type [T] belong to [R_T] *)
(** ** [R_T]に含まれる型[T]の項の閉じたインスタンス *)

(* Now we proceed to show that every term of type [T] belongs to
[R_T].  Here, the induction will be on typing derivations (it would be
surprising to see a proof about well-typed terms that did not
somewhere involve induction on typing derivations!).  The only
technical difficulty here is in dealing with the abstraction case.
Since we are arguing by induction, the demonstration that a term
[tm_abs x T1 t2] belongs to [R_(T1->T2)] should involve applying the
induction hypothesis to show that [t2] belongs to [R_(T2)].  But
[R_(T2)] is defined to be a set of _closed_ terms, while [t2] may
contain [x] free, so this does not make sense.

This problem is resolved by using a standard trick to suitably
generalize the induction hypothesis: instead of proving a statement
involving a closed term, we generalize it to cover all closed
_instances_ of an open term [t].  Informally, the statement of the
lemma will look like this:

If [x1:T1,..xn:Tn |- t : T] and [v1,...,vn] are values such that
[R T1 v1], [R T2 v2], ..., [R Tn vn], then [R T ([v1/x1][v2/x2]...[vn/xn]t)].

The proof will proceed by induction on the typing derivation
[x1:T1,..xn:Tn |- t : T]; the most interesting case will be the one
for abstraction. *)
(** これから、型[T]のすべての項が[R_T]に含まれることを示すことに取りかかります。
ここで使う帰納法は型付け導出についてのものです
(もし、型付け導出の帰納法と全く関係がない型付けされた項についての証明があったら、
驚くでしょう!)。
ここで技術的に難しいのは、関数抽象の場合だけです。
帰納法で議論していることから、項 [tm_abs x T1 t2] が[R_(T1->T2)]に属していることを示すことには
[t2]が[R_(T2)]に属するという帰納法の仮定を含みます。
しかし[R_(T2)]は「閉じた」項の集合である一方、[t2]は[x]を自由変数として含む可能性があるので、
これは筋が通りません。

この問題は帰納法の仮定を適度に一般化するという標準的なトリックを使うことで解決されます。
閉じた項を含む主張を証明する代わりに、開いた項[t]のすべての閉じたインスタンス(_instances_)
をカバーするように一般化します。非形式的には、補題の主張は次のようになります:

もし [x1:T1,..xn:Tn |- t : T] かつ、 [v1,...,vn] が
[R T1 v1], [R T2 v2], ..., [R Tn vn] となる値ならば、
[R T ([v1/x1][v2/x2]...[vn/xn]t)] である。

証明は、型付け [x1:T1,..xn:Tn |- t : T] の導出についての帰納法で進みます。
一番興味深いのは、関数抽象の場合です。 *)

(* ###################################################################### *)
(* *** Multisubstitutions, multi-extensions, and instantiations *)
(** *** 多重置換、多重拡張、インスタンス化 *)

(* However, before we can proceed to formalize the statement and
proof of the lemma, we'll need to build some (rather tedious)
machinery to deal with the fact that we are performing _multiple_
substitutions on term [t] and _multiple_ extensions of the typing
context.  In particular, we must be precise about the order in which
the substitutions occur and how they act on each other.  Often these
details are simply elided in informal paper proofs, but of course Coq
won't let us do that. Since here we are substituting closed terms, we
don't need to worry about how one substitution might affect the term
put in place by another.  But we still do need to worry about the
_order_ of substitutions, because it is quite possible for the same
identifier to appear multiple times among the [x1,...xn] with
different associated [vi] and [Ti].

To make everything precise, we will assume that environments are
extended from left to right, and multiple substitutions are performed
from right to left.  To see that this is consistent, suppose we have
an environment written as [...,y:bool,...,y:nat,...]  and a
corresponding term substitution written as [...[(tm_bool
true)/y]...[(tm_nat 3)/y]...t].  Since environments are extended from
left to right, the binding [y:nat] hides the binding [y:bool]; since
substitutions are performed right to left, we do the substitution
[(tm_nat 3)/y] first, so that the substitution [(tm_bool true)/y] has
no effect. Substitution thus correctly preserves the type of the term.

With these points in mind, the following definitions should make sense.

A _multisubstitution_ is the result of applying a list of
substitutions, which we call an _environment_. *)
(** しかしながら、主張と補題の証明の形式化に進む前に、項[t]の多重置換(_multiple_
substitutions)と型付けコンテキストの多重拡張(_multiple_ extensions)
についての事実を扱う、ある(かなり退屈な)機構を構築する必要があります。
特に、置換が現れる順序とそれらの相互関係を正確にする必要があります。
これらの詳細は非形式的な紙の証明では単に省略されるのが通常です。
しかしもちろん、Coqはそうはしません。ここでは閉じた項を置換していることから、
1つの置換が他の置換によってできた項に影響するかどうかを心配する必要はありません。
しかしそれでも置換の順序については考慮する必要があります。
なぜなら、[x1,...xn]に同じ識別子が複数回出現しそれらが違う[vi]や[Ti]
と関連付けされている可能性があるからです。

すべてを正確にするために、環境は左から右へ拡張されることとし、
多重置換は右から左へ実行されることとします。
これが整合的であることを見るために、[...,y:bool,...,y:nat,...] と書かれる環境と、
対応する [...[(tm_bool true)/y]...[(tm_nat 3)/y]...t]
と書かれる項の置換があるとします。
環境は左から右に拡張されることから、[y:nat]は[y:bool]を隠します。
置換は右から左に実行されることから、[(tm_nat 3)/y] が最初に実行され、
[(tm_bool true)/y] は何の作用もしません。
これから置換は項の型を正しく保存します。

このポイントを覚えておくと、次の定義が理解できます。

多重置換(_multisubstitution_)は置換のリストの適用結果です。
置換のリストは環境と呼ばれます(_environment_)。 *)

Definition env := list (id * tm).

Fixpoint msubst (ss:env) (t:tm) {struct ss} : tm :=
match ss with
| nil => t
| ((x,s)::ss') => msubst ss' (subst x s t)
end.

(* We need similar machinery to talk about repeated extension of a
    typing context using a list of (identifier, type) pairs, which we
    call a _type assignment_. *)
(** (識別子、型)の対のリストを使った型付けコンテキストの継続的拡張についても同様の機構が必要です。
    この型付けコンテキストを「型割当て」(_type assignment_)と呼びます。 *)

Definition tass := list (id * ty).

Fixpoint mextend (Gamma : context) (xts : tass) :=
  match xts with
  | nil => Gamma
  | ((x,v)::xts') => extend (mextend Gamma xts') x v
  end.

(* We will need some simple operations that work uniformly on
environments and type assigments *)
(** 環境と型割当てに同様にはたらくいくつかの簡単な操作が必要です。 *)

Fixpoint lookup {X:Set} (k : id) (l : list (id * X)) {struct l} : option X :=
  match l with
    | nil => None
    | (j,x) :: l' =>
      if beq_id j k then Some x else lookup k l'
  end.

Fixpoint drop {X:Set} (n:id) (nxs:list (id * X)) {struct nxs} : list (id * X) :=
  match nxs with
    | nil => nil
    | ((n',x)::nxs') => if beq_id n' n then drop n nxs' else (n',x)::(drop n nxs')
  end.

(* An _instantiation_ combines a type assignment and a value
   environment with the same domains, where corresponding elements are
   in R *)
(** インスタンス化(_instantiation_)は型割当てと値環境を同じ定義域で結合します。
   この定義域の要素はRに含まれます。 *)

Inductive instantiation :  tass -> env -> Prop :=
| V_nil : instantiation nil nil
| V_cons : forall x T v c e, value v -> R T v -> instantiation c e -> instantiation ((x,T)::c) ((x,v)::e).

(* We now proceed to prove various properties of these definitions. *)
(** これから、これらの定義についてのいろいろな性質を証明します。 *)

(* ###################################################################### *)
(* *** More Substitution Facts *)
(** *** 置換についてのさらなる事実 *)

(* First we need some additional lemmas on (ordinary) substitution. *)
(** 最初に(もともとの)置換について、ある追加の補題が必要です。 *)

Lemma vacuous_substitution : forall  t x,
     ~ appears_free_in x t  ->
     forall t', subst x t' t = t.
Proof with eauto.
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

Lemma subst_closed: forall t,
     closed t  ->
     forall x t', subst x t' t = t.
Proof.
  intros. apply vacuous_substitution. apply H.  Qed.

Lemma subst_not_afi : forall t x v, closed v ->  ~ appears_free_in x (subst x v t).
Proof with eauto.  (* rather slow this way *)
  unfold closed, not.
  tm_cases (induction t) Case; intros x v P A; simpl in A.
    Case "tm_var".
     remember (beq_id x i) as e; destruct e...
       inversion A; subst. rewrite <- beq_id_refl in Heqe; inversion Heqe.
    Case "tm_app".
     inversion A; subst...
    Case "tm_abs".
     remember (beq_id x i) as e; destruct e...
       apply beq_id_eq in Heqe; subst. inversion A; subst...
       inversion A; subst...
    Case "tm_pair".
     inversion A; subst...
    Case "tm_fst".
     inversion A; subst...
    Case "tm_snd".
     inversion A; subst...
    Case "tm_true".
     inversion A.
    Case "tm_false".
     inversion A.
    Case "tm_if".
     inversion A; subst...
Qed.

Lemma duplicate_subst : forall t' x t v,
  closed v -> subst x t (subst x v t') = subst x v t'.
Proof.
  intros. eapply vacuous_substitution. apply subst_not_afi.  auto.
Qed.

Lemma swap_subst : forall t x x1 v v1, x <> x1 -> closed v -> closed v1 ->
                   subst x1 v1 (subst x v t) = subst x v (subst x1 v1 t).
Proof with eauto.
 tm_cases (induction t) Case; intros; simpl.
  Case "tm_var".
   remember (beq_id x i) as e; destruct e; remember (beq_id x1 i) as e; destruct e.
      apply  beq_id_eq in Heqe. apply beq_id_eq in Heqe0. subst.
         apply ex_falso_quodlibet...
      apply beq_id_eq in Heqe; subst.  simpl.
         rewrite <- beq_id_refl.  apply subst_closed...
      apply beq_id_eq in Heqe0; subst.  simpl.
         rewrite <- beq_id_refl. rewrite subst_closed...
      simpl. rewrite <- Heqe. rewrite <- Heqe0...
  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

(* ###################################################################### *)
(* *** Properties of multi-substitutions *)
(** *** 多重置換の性質 *)

Lemma msubst_closed: forall t, closed t -> forall ss, msubst ss t = t.
Proof.
  induction ss.
    reflexivity.
    destruct a. simpl. rewrite subst_closed; assumption.
Qed.

(* Closed environments are those that contain only closed terms. *)
(** 閉じた環境とは、閉じた項のみを含む環境です。 *)

Fixpoint closed_env (env:env) {struct env} :=
match env with
| nil => True
| (x,t)::env' => closed t /\ closed_env env'
end.

(* Next come a series of lemmas charcterizing how [msubst] of closed terms
    distributes over [subst] and over each term form *)
(** 次は、閉じた項についての[msubst]がどのように[subst]
    や各項の形に分配されるかを特徴づける一連の補題です。 *)

Lemma subst_msubst: forall env x v t, closed v -> closed_env env ->
  msubst env (subst x v t) = subst x v (msubst (drop x env) t).
Proof.
  induction env0; intros.
    auto.
    destruct a. simpl.
    inversion H0. fold closed_env in H2.
    remember (beq_id i x) as e; destruct e.
      apply  beq_id_eq in Heqe; subst.
        rewrite duplicate_subst; auto.
      symmetry in Heqe. apply beq_id_false_not_eq in Heqe.
      simpl. rewrite swap_subst; eauto.
Qed.

Lemma msubst_var:  forall ss x, closed_env ss ->
   msubst ss (tm_var x) =
   match lookup x ss with
   | Some t => t
   | None => tm_var x
  end.
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
     simpl. destruct (beq_id i x).
      apply msubst_closed. inversion H; auto.
      apply IHss. inversion H; auto.
Qed.

Lemma msubst_abs: forall ss x T t,
  msubst ss (tm_abs x T t) = tm_abs x T (msubst (drop x ss) t).
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
      simpl. destruct (beq_id i x); simpl; auto.
Qed.

Lemma msubst_app : forall ss t1 t2, msubst ss (tm_app t1 t2) = tm_app (msubst ss t1) (msubst ss t2).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

(* You'll need similar functions for the other term constructors. *)
(** 他の項コンストラクタに対しても同様の関数が必要になるでしょう。 *)

(* FILL IN HERE *)
(** ここを埋めなさい *)

(* ###################################################################### *)
(* *** Properties of multi-extensions *)
(** *** 多重拡張の性質 *)

(* We need to connect the behavior of type assignments with that of their
   corresponding contexts. *)
(** 型割当てのふるまいを、対応するコンテキストのふるまいと結合する必要があります。 *)

Lemma mextend_lookup : forall (c : tass) (x:id), lookup x c = (mextend empty c) x.
Proof.
  induction c; intros.
    auto.
    destruct a. unfold lookup, mextend, extend. destruct (beq_id i x); auto.
Qed.

Lemma mextend_drop : forall (c: tass) Gamma x x',
       mextend Gamma (drop x c) x' = if beq_id x x' then Gamma x' else mextend Gamma c x'.
   induction c; intros.
      destruct (beq_id x x'); auto.
      destruct a. simpl.
      remember (beq_id i x) as e; destruct e.
        apply beq_id_eq in Heqe; subst. rewrite IHc.
            remember (beq_id x x') as e; destruct e.  auto. unfold extend. rewrite <- Heqe. auto.
        simpl.  unfold extend.  remember (beq_id i x') as e; destruct e.
            apply beq_id_eq in Heqe0; subst.
                              remember (beq_id x x') as e; destruct e.
                  apply beq_id_eq in Heqe0; subst.  rewrite <- beq_id_refl in Heqe.  inversion Heqe.
                  auto.
            auto.
Qed.

(* ###################################################################### *)
(* *** Properties of Instantiations *)
(** *** インスタンス化の性質 *)

(* These are strightforward. *)
(** 以下は簡単です。 *)

Lemma instantiation_domains_match: forall {c} {e},
  instantiation c e -> forall {x} {T}, lookup x c = Some T -> exists t, lookup x e = Some t.
Proof.
  intros c e V. induction V; intros x0 T0 C.
    solve by inversion .
    simpl in *.
    destruct (beq_id x x0); eauto.
Qed.

Lemma instantiation_env_closed : forall c e,  instantiation c e -> closed_env e.
Proof.
  intros c e V; induction V; intros.
    econstructor.
    unfold closed_env. fold closed_env.
    split.  eapply typable_empty__closed. eapply R_typable_empty. eauto.
        auto.
Qed.

Lemma instantiation_R : forall c e, instantiation c e ->
                        forall x t T, lookup x c = Some T ->
                                      lookup x e = Some t -> R T t.
Proof.
  intros c e V. induction V; intros x' t' T' G E.
    solve by inversion.
    unfold lookup in *.  destruct (beq_id x x').
      inversion G; inversion E; subst.  auto.
      eauto.
Qed.

Lemma instantiation_drop : forall c env,
  instantiation c env -> forall x, instantiation (drop x c) (drop x env).
Proof.
  intros c e V. induction V.
    intros.  simpl.  constructor.
    intros. unfold drop. destruct (beq_id x x0); auto. constructor; eauto.
Qed.

(* ###################################################################### *)
(* *** Congruence lemmas on stepmany *)
(** *** stepmany([==>*])についての合同補題 *)

(* We'll need just a few of these; add them as the demand arises. *)
(** これらのいくつかだけが必要になります。必要が生じた時点で追加しなさい。 *)

Lemma stepmany_App2 : forall v t t',
  value v -> (t ==>* t') -> (tm_app v t) ==>* (tm_app v t').
Proof.
  intros v t t' V STM. induction STM.
   apply rsc_refl.
   eapply rsc_step.
     apply ST_App2; eauto.  auto.
Qed.

(* FILL IN HERE *)
(** ここを埋めなさい *)

(* ###################################################################### *)
(* *** The R Lemma. *)
(** *** R補題 *)

(* We finally put everything together.

    The key lemma about preservation of typing under substitution can
    be lifted to multi-substitutions: *)
(** 最後にすべてをまとめます。

    置換についての型付けの保存についてのキーとなる補題は、
    多重置換に対応する形にすることができます: *)

Lemma msubst_preserves_typing : forall c e,
     instantiation c e ->
     forall Gamma t S, has_type (mextend Gamma c) t S ->
     has_type Gamma (msubst e t) S.
Proof.
  induction 1; intros.
    simpl in H. simpl. auto.
    simpl in H2.  simpl.
    apply IHinstantiation.
    eapply substitution_preserves_typing; eauto.
    apply (R_typable_empty H0).
Qed.

(* And at long last, the main lemma. *)
(** そして一番最後に、メインの補題です。 *)

Lemma msubst_R : forall c env t T,
  has_type (mextend empty c) t T -> instantiation c env -> R T (msubst env t).
Proof.
  intros c env0 t T HT V.
  generalize dependent env0.
  (* We need to generalize the hypothesis a bit before setting up the induction. *)
  remember (mextend empty c) as Gamma.
  assert (forall x, Gamma x = lookup x c).
    intros. rewrite HeqGamma. rewrite mextend_lookup. auto.
  clear HeqGamma.
  generalize dependent c.
  has_type_cases (induction HT) Case; intros.

  Case "T_Var".
   rewrite H0 in H. destruct (instantiation_domains_match V H) as [t P].
   eapply instantiation_R; eauto.
   rewrite msubst_var.  rewrite P. auto. eapply instantiation_env_closed; eauto.

  Case "T_Abs".
    rewrite msubst_abs.
    (* We'll need variants of the following fact several times, so its simplest to
       establish it just once. *)
    assert (WT: has_type empty (tm_abs x T11 (msubst (drop x env0) t12)) (ty_arrow T11 T12)).
     eapply T_Abs. eapply msubst_preserves_typing.  eapply instantiation_drop; eauto.
      eapply context_invariance.  apply HT.
      intros.
      unfold extend. rewrite mextend_drop. remember (beq_id x x0) as e; destruct e.  auto.
        rewrite H.
          clear - c Heqe. induction c.
              simpl.  rewrite <- Heqe.  auto.
              simpl. destruct a.  unfold extend. destruct (beq_id i x0); auto.
    unfold R. fold R. split.
       auto.
     split. apply value_halts. apply v_abs.
     intros.
     destruct (R_halts H0) as [v [P Q]].
     pose proof (stepmany_preserves_R _ _ _ P H0).
     apply stepmany_preserves_R' with (msubst ((x,v)::env0) t12).
       eapply T_App. eauto.
       apply R_typable_empty; auto.
       eapply rsc_trans.  eapply stepmany_App2; eauto.
       eapply rsc_R.
       simpl.  rewrite subst_msubst.
       eapply ST_AppAbs; eauto.
       eapply typable_empty__closed.
       apply (R_typable_empty H1).
       eapply instantiation_env_closed; eauto.
       eapply (IHHT ((x,T11)::c)).
          intros. unfold extend, lookup. destruct (beq_id x x0); auto.
       constructor; auto.

  Case "T_App".
    rewrite msubst_app.
    destruct (IHHT1 c H env0 V) as [_ [_ P1]].
    pose proof (IHHT2 c H env0 V) as P2.  fold R in P1.  auto.

  (* FILL IN HERE *)(** ここを埋めなさい *) Admitted.

(* ###################################################################### *)
(* *** Normalization Theorem *)
(** *** 正規化定理 *)

Theorem normalization : forall t T, has_type empty t T -> halts t.
Proof.
  intros.
  replace t with (msubst nil t).
  eapply R_halts.
  eapply msubst_R; eauto. instantiate (2:= nil). eauto.
  eapply V_nil.
  auto.
Qed.