(* This file contains lemmas on polynoms validity propositions, used to deduce more validity propositions from a single one.
We define 2 tactics, [valid_destr] and [weak_valid_destr], which can be applied on an hypothesis to deduce new propositions from validity and weak validity proposition (weak validity is explained below)
*)

Require Import PolyDefs.
Require Import ZArith Arith Bool Lia.
Require Import BoolHelp.

Local Lemma valid_b_more (p q : poly) (i:nat) :
valid_b (Poly p i q) = true -> valid_b p = true /\ valid_b q = true.
Proof.
  intro.
  split.
  induction p; simpl in H; intuition.
  - destruct q.
    destruct (Z.eq_dec z 0); destruct z; intuition; andb_destr H; intuition.
    andb_destr H.
    simpl.
    assumption.
  - destruct p,q; simpl in H; intuition; andb_destr H; simpl; assumption.
Qed.

Local Lemma valid_b_more_r (p q1 q2 : poly) (n n0:nat) :
valid_b (Poly p n (Poly q1 n0 q2)) = true -> valid_b (Poly p n q2) = true.
Proof.
  intro.
  simpl in H.
  destruct p; destruct q2; andb_destr H.
  - destruct q1; destruct z0; intuition.
  - destruct q1; andb_destr H0; simpl; andb_split; try assumption; try apply leb_trans with (j:= n0); intuition.
  - destruct q1; destruct z; simpl; intuition.
  - destruct q1; andb_destr H0; simpl; andb_split; try assumption; try apply leb_trans with (j:= n0); intuition.
Qed.

Local Lemma valid_b_more_l (p1 p2 q : poly) (n n0:nat) :
valid_b (Poly (Poly p1 n0 p2) n q) = true -> valid_b (Poly p1 n q) = true /\ valid_b (Poly p2 n q) = true.
Proof.
  intro.
  destruct p1, q.
  - split; destruct z0; intuition; destruct p2; andb_destr H; try andb_split; intuition; apply ltb_leb_trans with (j:=n0); intuition.
  - split; destruct p2; andb_split; andb_destr H; intuition.
    apply ltb_leb_trans with (j:=n0); intuition.
  - split.
    + destruct z; [intuition| |]; destruct p2.
  	  destruct z; andb_destr H; [ inversion H0| |]; andb_split; intuition; apply ltb_trans with (j:=n0); intuition.
  	  andb_split; andb_destr H; [apply ltb_trans with (j:=n0)|]; intuition.
  	  andb_split; [ destruct z; andb_destr H; apply ltb_trans with (j:=n0)|]; intuition.
  	  destruct z; andb_destr H; [inversion H0| |]; intuition.
  	  andb_destr H; andb_split; [apply ltb_trans with (j:=n0)|]; intuition.
    + destruct p2.
  	  destruct z; intuition.
  	  destruct z; intuition; andb_destr H; andb_split.
  	  1,3: apply ltb_leb_trans with (j:= n0); split; intuition.
  	  1-2: assumption.
  - split.
    + destruct p2. andb_destr H; destruct z; [intuition| |]; andb_destr H1; andb_split; intuition.
  	  apply ltb_trans with (j:=n0); split; intuition.
  	  apply ltb_trans with (j:=n0); split; intuition.
  	  andb_split; andb_destr H; intuition.
  	  apply ltb_trans with (j:=n0); split; intuition.
    + destruct p2. andb_destr H; destruct z; [intuition| |]; andb_destr H1; andb_split; intuition.
  	  andb_split; andb_destr H; intuition.
  	  apply ltb_leb_trans with (j:=n0); split; intuition.
Qed.

Ltac is_valid := match goal with
| H:valid_b (Poly (Poly _ _ _) _ (Poly _ _ _)) = true |- valid_b (Poly _ _ _) = true =>
  let t := type of H in idtac t;
  let H0 := fresh "V" in
  let H1 := fresh "V" in
  let V1 := fresh "V" in
  let V2 := fresh "V" in
  let V3 := fresh "V" in
  specialize H as H0; specialize H as H1;
  apply valid_b_more_l in H as [V1 V2];
  apply valid_b_more_r in H0 as V3;
  apply valid_b_more in H0 as V3;
  assumption || is_valid V1 || is_valid V2 || is_valid V3

| H:valid_b (Poly (_ _ _) _ ?q) = true |- valid_b (Poly _ _ ?q) = true =>
  let H1 := fresh "V" in
  let H2 := fresh "V" in
  apply valid_b_more_l in H as [H1 H2];
  assumption || is_valid H1 || is_valid H2

| H:valid_b (Poly ?p _ (_ _ _)) = true |- valid_b (Poly ?p _ _) = true =>
  let H1 := fresh "V" in
  apply valid_b_more_r in H as H1;
  assumption || is_valid H1

| H:valid_b (Poly _ _ _) = true |- valid_b ?p' = true =>
  let H1 := fresh H in
  let H2 := fresh H in
  apply valid_b_more in H as [H H'];
  assumption || is_valid H1 || is_valid H2
end.

(* The tactic [valid_destr] can be applied on a hypothesis of the form [valid_b _ = true]
and produces
*)

Ltac valid_destr H :=
let H0 := fresh "V" in specialize H as H0;
match type of H0 with
| valid_b (Poly (Poly _ _ _) _ (Poly _ _ _)) = true =>
  let H1 := fresh "V" in
  let H2 := fresh "V" in
  let V0 := fresh "V" in
  let V1 := fresh "V" in
  let V2 := fresh "V" in
  let V3 := fresh "V" in
  let V4 := fresh "V" in
  specialize H0 as H1; specialize H0 as H2;
  apply valid_b_more in H0 as (V0 & V1);
  apply valid_b_more_l in H1 as (V2 & V3);
  apply valid_b_more_r in H2 as V4

| valid_b (Poly _ _ (Poly _ _ _)) = true  =>
  let H1 := fresh "V" in
  let V0 := fresh "V" in
  let V1 := fresh "V" in
  let V2 := fresh "V" in
  specialize H0 as H1;
  apply valid_b_more in H0 as (V0 & V1);
  apply valid_b_more_r in H1 as V2

| valid_b (Poly (Poly _ _ _) _ _) = true  =>
  let H1 := fresh "V" in
  let V0 := fresh "V" in
  let V1 := fresh "V" in
  let V2 := fresh "V" in
  specialize H0 as H1;
  apply valid_b_more in H0 as (V0 & V1);
  apply valid_b_more_l in H1 as (H1 & V2)

| valid_b (Poly _ _ _) = true  =>
  let H1 := fresh "V" in
  let H2 := fresh "V" in
  apply valid_b_more in H0 as (H1 & H2)
end.

Lemma le_valid (p p' q q' : poly) (i j:nat)  :
i>j ->
valid_b (Poly p i q) = true ->
valid_b (Poly p' j q') = true ->
valid_b (Poly (Poly p i q) j q') = true.
Proof.
  intros.
  destruct p,p',q'.
  2,4,6,8 : andb_destr H1; andb_split; intuition.
  - destruct z1; [inversion H1| |];  andb_split; intuition.
  - destruct z0; [inversion H1| |];  andb_split; intuition.
  - destruct z0; [inversion H1| |];  andb_split; intuition.
  - destruct z; [inversion H1| |];  andb_split; intuition.
Qed.

Lemma valid_le (p q1 q2:poly) (i j:nat) : valid_b (Poly (Poly p i q1) j q2) = true -> j < i.
Proof.
  intro.
  simpl in H.
  destruct q2.
  - destruct z; [inversion H| |]; andb_destr H; apply ltb_complete; assumption.
  - andb_destr H; apply ltb_complete; assumption.
Qed.

Lemma valid_leq (p q1 q2:poly) (i j:nat) : valid_b (Poly p i (Poly q1 j q2) )  = true -> i <= j.
Proof.
  intro.
  simpl in H.
  destruct p; andb_destr H; apply leb_complete; assumption.
Qed.

Lemma leq_valid (p p' q q' : poly) (i j:nat)  :
i <= j ->
valid_b (Poly p i q) = true ->
valid_b (Poly p' j q') = true ->
valid_b (Poly p i (Poly p' j q')) = true.
Proof.
  intros.
  simpl in *.
  destruct p,q.
  - andb_split. auto. assumption.
  - andb_split. auto. assumption.
  - destruct z; [inversion H0| |]; andb_destr H0; andb_split; auto.
  - andb_destr H0. andb_split; auto.
Qed.

(* For any valid polynom [Poly p i (Cst z)] the constant [z] is not 0 *)
Lemma valid_not0 (p:poly) (i:nat) (z:Z) : valid_b (Poly p i (Cst z))  = true -> z <> 0%Z.
Proof.
  intro.
  simpl in H.
  destruct p; destruct z; intuition.
Qed.

(* Weak validity is the same as Validity but it allows the rightmost constant to be zero.
  Polynoms additions and multipications can produce polynoms with the rightmost constant as zero,
  but we we will remove those null constants after the operation, so the resulting polynom will be valid.
*)
Fixpoint weak_valid_b (pol:poly) : bool :=
  match pol with
  |Cst _ => true
  |Poly p i q =>
    match p,q with
    | (Cst _), (Cst _) => true
    | (Poly _ j1 _), (Cst _) => (i <? j1) && weak_valid_b p
    | (Cst _),  (Poly p2 j2 q2) => (i <=? j2) && weak_valid_b q
    |(Poly p1 j1 q1),  (Poly p2 j2 q2) =>
      (i <? j1) && (i <=? j2)
      && weak_valid_b p
      && weak_valid_b q
    end
  end
.

Lemma weaken_valid (p:poly) (H:valid_b p = true) : weak_valid_b p = true.
Proof.
  induction p.
  - simpl. reflexivity.
  - valid_destr H.
    specialize (IHp1 V0).
    specialize (IHp2 V1).
    simpl in *.
    destruct p1.
    * destruct p2.
      destruct z0; reflexivity.
      andb_split. andb_destr H. assumption.
      assumption.
    * destruct p2.
      destruct z. inversion H.
      1-3 : andb_destr H; andb_split; assumption.
Qed.

(* Same properties as for Validity *)

Lemma weak_valid_le (p q1 q2:poly) (i j:nat) : weak_valid_b (Poly (Poly p i q1) j q2) = true -> j < i.
Proof.
  intro.
  simpl in H.
  destruct q2.
  - destruct z; [inversion H| |]; andb_destr H; apply ltb_complete; assumption.
  - andb_destr H; apply ltb_complete; assumption.
Qed.

Lemma weak_valid_leq (p q1 q2:poly) (i j:nat) : weak_valid_b (Poly p i (Poly q1 j q2) )  = true -> i <= j.
Proof.
  intro.
  simpl in H.
  destruct p; andb_destr H; apply leb_complete; assumption.
Qed.

Lemma le_weak_valid (p p' q q' : poly) (i j:nat)  :
i>j ->
weak_valid_b (Poly p i q) = true ->
weak_valid_b (Poly p' j q') = true ->
weak_valid_b (Poly (Poly p i q) j q') = true.
Proof.
  intros.
  simpl in *.
  destruct p.
  - destruct p'.
    + destruct q'.
      *  andb_split; intuition.
      * andb_destr H1.  andb_split; intuition.
    +  destruct q'.
      * andb_split; intuition.
      * andb_destr H1.  andb_split; intuition.
  - destruct p'.
    + destruct q'.
      * andb_split; intuition.
      * andb_destr H1. andb_split; intuition.
    +  destruct q'.
      * andb_split; intuition.
      * andb_destr H1.  andb_split; intuition.
Qed.

Lemma leq_weak_valid (p p' q q' : poly) (i j:nat)  :
i<=j ->
weak_valid_b (Poly p i q) = true ->
weak_valid_b (Poly p' j q') = true ->
weak_valid_b (Poly p i (Poly p' j q')) = true.
Proof.
  intros.
  simpl in *.
  destruct p.
  - destruct p'.
    + destruct q'.
      * andb_split; intuition.
      * andb_destr H1.  andb_split; intuition.
    +  destruct q'.
      * andb_destr H1. andb_split; intuition.
      * andb_destr H1.  andb_split; intuition.
  - destruct p'.
    + destruct q'.
      * destruct q; andb_destr H0; andb_split; intuition.
      * andb_destr H1; destruct q; andb_destr H0; andb_split; intuition.
    +  destruct q'.
      * andb_destr H1. destruct q; andb_destr H0; andb_split; intuition.
      * andb_destr H1. destruct q; andb_destr H0; andb_split; intuition.
Qed.

Local Lemma weak_valid_b_more (p q : poly) (i:nat) :
  weak_valid_b (Poly p i q) = true -> weak_valid_b p = true /\ weak_valid_b q = true.
Proof.
  intro.
  split.
  induction p; simpl in H; intuition.
  - destruct q.
  elim (Z.eq_dec z 0); intro; destruct z; intuition; andb_destr H; intuition.
    andb_destr H.
    simpl.
    assumption.
  - destruct p,q; simpl in H; intuition; andb_destr H; simpl; assumption.
Qed.

Local Lemma weak_valid_b_more_r (p q1 q2 : poly) (n n0:nat) :
  weak_valid_b (Poly p n (Poly q1 n0 q2)) = true -> weak_valid_b (Poly p n q2) = true.
Proof.
  intro.
  simpl in H.
  destruct p; destruct q2; andb_destr H.
  - destruct q1; destruct z0; intuition.
  - destruct q1; andb_destr H0; simpl; andb_split; try assumption; try apply leb_trans with (j:= n0); intuition.
  - destruct q1; destruct z; simpl; intuition.
  - destruct q1; andb_destr H0; simpl; andb_split; try assumption; try apply leb_trans with (j:= n0); intuition.
Qed.

Local Lemma weak_valid_b_more_l (p1 p2 q : poly) (n n0:nat) :
  weak_valid_b (Poly (Poly p1 n0 p2) n q) = true -> weak_valid_b (Poly p1 n q) = true /\ weak_valid_b (Poly p2 n q) = true.
Proof.
  intro.
  destruct p1;  destruct q; simpl in H; simpl.
  - split; destruct z0; intuition; destruct p2; andb_destr H; try andb_split; intuition; apply ltb_leb_trans with (j:=n0); intuition.
  - split; destruct p2; andb_split; andb_destr H; intuition.
    apply ltb_leb_trans with (j:=n0); intuition.
  - split.
    +  destruct p2;
      andb_destr H; andb_split.  apply ltb_trans with (j:=n0); intuition.
      assumption. apply ltb_trans with (j:=n0); intuition. assumption.
    + destruct p2.
      trivial.
      andb_destr H; andb_split.
      apply ltb_leb_trans with (j:= n0); split; intuition.
      assumption.
  - split.
    +  destruct p2; andb_destr H; andb_destr H1; andb_split; intuition.
      apply ltb_trans with (j:=n0); split; intuition.
      apply ltb_trans with (j:=n0); split; intuition.
    + destruct p2; andb_destr H; andb_destr H1; andb_split; intuition.
      apply ltb_leb_trans with (j:=n0); split; intuition.
Qed.

(* If a polynom (Poly p i (Poly q1 j q2)) is weak valid
  then we can remove the q2 part, and the resulting polynom
   is still weak valid *)
Local Lemma weak_valid_b_rem (p q1 q2 :poly) (i j:nat):
weak_valid_b (Poly p i (Poly q1 j q2)) = true -> weak_valid_b (Poly p i q1) = true.
Proof.
  intro.
  induction p.
  - simpl in *.
    andb_destr H.
    destruct q1; [trivial|].
    andb_split.
    + destruct q2; andb_destr H0; apply leb_trans with (j:=j); auto.
    + destruct q2; andb_destr H0; assumption.
  - specialize H as V. specialize H as V'.
    apply weak_valid_b_more in V as (V1 & V2).
    apply weak_valid_b_more_l in V' as (V3 & V4) .
    intuition.
    destruct q1.
    + simpl.
      andb_split.
      apply weak_valid_le in H. auto.
      simpl in V2.
      assumption.
    + apply weak_valid_leq in V4 as leq1.
      apply weak_valid_le in V2 as le1.
      apply weak_valid_le in H as le2.
      simpl.
      andb_split. auto. apply leb_trans with (j:=j). auto.
      assumption.
      simpl in H0.
      destruct p1; andb_destr H0; assumption.
Qed.

(* Same tactic as valid_destr but on weak valid, and we use the above lemma [weak_valid_b_rem] which is specific to weak validity *)
Ltac weak_valid_destr H :=
  let H0 := fresh "V" in specialize H as H0;
  match type of H0 with
  | weak_valid_b (Poly (Poly _ _ _) _ (Poly _ _ _)) = true =>
    let H1 := fresh "V" in
    let H2 := fresh "V" in
    let V0 := fresh "V" in
    let V1 := fresh "V" in
    let V2 := fresh "V" in
    let V3 := fresh "V" in
    let V4 := fresh "V" in
    specialize H0 as H1; specialize H0 as H2;
    apply weak_valid_b_more in H0 as (V0 & V1);
    apply weak_valid_b_more_l in H1 as (V2 & V3);
    apply weak_valid_b_more_r in H2 as V4

  | weak_valid_b (Poly _ _ (Poly _ _ _)) = true  =>
    let H1 := fresh "V" in
    let V0 := fresh "V" in
    let V1 := fresh "V" in
    let V2 := fresh "V" in
    let V3 := fresh "V" in
    specialize H0 as H1;  specialize H0 as V3;
    apply weak_valid_b_rem in V3;
    apply weak_valid_b_more in H0 as (V0 & V1);
    apply weak_valid_b_more_r in H1 as V2

  | weak_valid_b (Poly (Poly _ _ _) _ _) = true  =>
    let H1 := fresh "V" in
    let H2 := fresh "V" in
    let V0 := fresh "V" in
    let V1 := fresh "V" in
    let V2 := fresh "V" in
    let V3 := fresh "V" in
    let V4 := fresh "V" in
    specialize H0 as H1; specialize H0 as H2;
    apply weak_valid_b_more in H0 as (V0 & V1);
    apply weak_valid_b_more_l in H1 as (V2 & V3)
  | weak_valid_b (Poly _ _ _) = true  =>
    let V1 := fresh "V" in
    let V2 := fresh "V" in
    apply weak_valid_b_more in H0 as (V1 & V2)
end.


(**
Coq/SSReflect/MathComp による定理証明

6.1 テーマ1 整数がその加法で可換群になること（テキスト見直し版）
======
2018_04_21 @suharahiromichi
2021_01_30 @suharahiromichi
 *)
From mathcomp Require Import all_ssreflect. (* eqType 他 *)
From mathcomp Require Import ssralg.        (* zmodType の定義 *)
Require Import ZArith.                      (* Standard Coq の整数型 *)

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

(**
# 可換群の定義

説明： MathComp の型クラスのインスタンスとしての整数型を定義します。
整数型の定義は、Standard Coq の ZArith を使用します。
MathCompの整数型は、ssrintで定義されていますが、これとは別に定義をするわけです。

補足：
zmodMixion と zmodType の定義のある ssralg はimportしますが、
MathComp の整数型である ssrint は import しません。

補足： テキストでいう「可換群」は、Z-Module や Z加群 ともいい、
整数環(環Z)上の加法についての群のことです。アーベル群といったほうが判りやすいかもしれません。
MathComp では zmodType 型クラスとして定義されています。

「整数がその加法で可換群になること」というテーマは、
Standard Coqで定義された整数が、その加法についてアーベル群になることを証明する。
具体的にいうと、zmodType型クラスのインスタンスとして、z_zmodType型が定義できることを示します。

----------------------------------------------------------------------------------
型インスタンス           型クラス      説明
Z_eqType                 eqType       決定可能な同値関係を持つ（整数）型
Z_choiceType             choiceType   有限選択公理のある（整数）型
Z_countType              countType    数え上げ可能な（整数）型
Z_zmodType               zmodType     可換群である（整数）型
Z_ringType               ringType     環である（整数）型（演習問題 6.1）
----------------------------------------------------------------------------------

この階層の順番に定義していくのが自然です。テキストではこの順番になっていないのですが、
CanChoiceMixin と CanCountMixin を使うことで、この順番で証明します。
このような定義の方法は、MCB の 7.5節でも用いられています。

参考： Mathematical Components (MCB) 7.5 Linking a custom data type to the library

補足： テキスト 176ページの図6.1にあるように、Z_zmodType を作るためには、
Z_choiceType があればよく、Z_countType は必要ではありません。

補足： テキストでは自然数から整数の対応を部分関数にしていますが、これは関数になるはずです。
そのため、pcancel ではなく cancel が成立するはずなので、そのようにしています。
部分関数 で pcancel のままであっても、
PcanChoiceMixin と PcanCountMixin を使うことで証明できます。

おまけ（テキスト 6.1.7節に対応) として、
MathComp で zmodType の上で定義された演算子 「*+」 が、
Standard Coq の整数型に対して適用できることを確認します。
*)

(* まだ、それらの演算子は使えない。 *)
Fail Compute 1%Z == 1%Z.
Open Scope ring_scope.
Fail Compute 3%Z *+ 2%N.

Section ZtoRing.
(**
## 整数型どうしのbool型の同値関係 Zeq_bool が「=」と同値であることを証明する。
*)
  Compute Zeq_bool 0%Z 0%Z.                 (* true *)
  Compute Zeq_bool 0%Z 1%Z.                 (* false *)
  Compute Zeq_bool 1%Z 1%Z.                 (* true *)

  Compute 1%Z = 1%Z.                        (* Prop *)
  Check reflect (1%Z = 1%Z) (Zeq_bool 1%Z 1%Z).
  Print Equality.axiom.
  (*
Equality.axiom =
fun (T : Type) (e : rel T) => forall x y : T, reflect (x = y) (e x y)
   *)
  Lemma Zeq_boolP : Equality.axiom Zeq_bool.
  Proof.
    move=> x y.
      by apply: (iffP idP); rewrite Zeq_is_eq_bool.
  Qed.

(**
## Z_eqType 決定可能な同値関係を持つ整数型
*)
  Definition Z_eqMixin := EqMixin Zeq_boolP.
  Canonical Z_eqType := EqType Z Z_eqMixin.

(**
## 整数が自然数と1対1対応することを証明する。
*)
  Definition Z_pickle (z : Z) : nat :=
    if (0 <=? z)%Z then
      (Z.abs_nat z).*2
    else
      (Z.abs_nat (- z)).*2.+1.

  Definition Z_unpickle (n : nat) : Z :=
    if odd n then
      (- (Z.of_nat n.-1./2))%Z
    else
      Z.of_nat n./2.

  Compute Z_pickle 1%Z.                     (* 2 *)
  Compute Z_unpickle 2.                     (* 1%Z *)

  Lemma Z_pickleK : cancel Z_pickle Z_unpickle.
  Proof.
    move=> z; rewrite /Z_pickle.
    case: ifP => z0;
    rewrite /Z_unpickle /= odd_double
            doubleK                      (* half_bit_double _ false *)
            Zabs2Nat.id_abs Z.abs_eq ?Z.opp_nonneg_nonpos
            ?Z.opp_involutive //.
    + by apply: Zle_bool_imp_le.
    + move: z0.                             (* z0 に適用していく。 *)
        by move /Z.leb_nle /Znot_le_gt /Z.gt_lt /Z.lt_le_incl.
  Qed.

  (* ハンズオン用の証明 *)
  (* Standard Coq の ZArith の下にある定理を使用して証明することの注意してください。 *)
  Lemma Z_pickleK' : cancel Z_pickle Z_unpickle.
  Proof.
    move=> z; rewrite /Z_pickle.
    case: ifP => Hz.
    - rewrite /Z_unpickle /=.
      (* if の true は成り立たないので捨てる。 *)
      rewrite odd_double /=.
      rewrite doubleK.

      Locate "_ <=? _".                     (* Z.leb x y : Z_scope *)
      Locate "_ <= _".                      (* Z.le x y : Z_scope *)
      Check Z.of_nat : nat -> Z.
      Check Z.abs_nat : Z -> nat.

      (* Hz : (0 <=? z)%Z *)
      (* Z.of_nat (Z.abs_nat z) = z *)

      (* z が0以上の場合、
         整数zの絶対値を自然数で得たものを整数に変換したものは、
         もとの自然数zに等しい。 *)
      rewrite Zabs2Nat.id_abs.
      Search _ (Z.abs _ = _).
      rewrite Z.abs_eq.
      + done.
      + by apply: Zle_bool_imp_le.

    - rewrite /Z_unpickle /=.
      (* if の false は成り立たないので捨てる。 *)
      rewrite odd_double /=.
      rewrite doubleK.

      (* Hz : (0 <=? z)%Z = false *)
      (* (- Z.of_nat (Z.abs_nat (- z)))%Z = z *)

      (* z が0以上ではない場合、
         整数(- z)の絶対値を自然数で得たものを整数に変換したものの(-)は、
         もとの自然数zに等しい。 *)
      Search _ (Z.abs_nat _).
      Search _ (Z.abs _).
      rewrite Nat2Z.inj_abs_nat.
      rewrite Z.abs_eq.
      + rewrite Z.opp_involutive.
        Check Z.opp_involutive.
        done.
      + rewrite Z.opp_nonneg_nonpos.
        move/Z.leb_gt : Hz.
          by apply: Z.lt_le_incl.
  Qed.

(**
## Z_choiceType   有限選択公理のある整数型
*)
  Definition Z_choiceMixin := CanChoiceMixin Z_pickleK.
  Canonical Z_choiceType := ChoiceType Z Z_choiceMixin.

(**
## Z_countType    数え上げ可能な整数型
*)
  Definition Z_countMixin := CanCountMixin Z_pickleK.
  Canonical Z_countType := CountType Z Z_countMixin.

(**
## Z_zmodType     可換群である整数型
*)
(**
必要な補題は Coq.ZArith.BinInt. で証明されたものを使う。
*)
  Check Z.add_assoc : forall n m p : Z, (n + (m + p))%Z = (n + m + p)%Z.
  Check Z.add_comm : forall n m : Z, (n + m)%Z = (m + n)%Z.
  Check Z.add_0_l : forall n : Z, (0 + n)%Z = n.
  Check Z.add_opp_diag_l : forall n : Z, (- n + n)%Z = 0%Z.

  Definition Z_zmodMixin := ZmodMixin
                              Z.add_assoc Z.add_comm Z.add_0_l Z.add_opp_diag_l.
  Canonical Z_zmodType := ZmodType Z Z_zmodMixin.
  (* Z_choiceType が必要である。Z_countType は必要ない。 *)

  (* 確認 *)
  Check Z_eqType : eqType.
  Check Z_choiceType : choiceType.
  Check Z_countType : countType.
  Check Z_zmodType : zmodType.

End ZtoRing.

(**
Z_ringType の定義は演習 6.1 を参照してください；

https://gitlab.com/proofcafe/csm/-/blob/master/csm_ex_6_1.v
*)

(**
# MathComp で定義された演算子が、Starndard Coq の整数型に使える
*)

Section TEST.
(**
## 演算子の定義
*)
(**
### 演算子 「==」 の定義。bool値の同値関係

これは、MathComp で eqType の上で定義された演算子である。
*)
  Locate "_ == _".                          (* eq_op *)
  Check nat_eqType : eqType.
  Check @eq_op : forall T : eqType, T -> T -> bool.
  Check @eq_op nat_eqType : nat -> nat -> bool.

  Compute 1%Z == 1%Z.                       (* true *)
  Compute 1%Z == - 1%Z.                     (* false *)

(**
### 演算子 「*+」 の定義。整数と自然数の掛け算

これは、MathComp で zmodType の上で定義された演算子である。
*)
  Locate "_ *+ _".               (* GRing.natmul x n   : ring_scope *)
  Check Z_zmodType : zmodType.
  Check GRing.natmul : forall V : zmodType, V -> nat -> V.
  Compute GRing.Zmodule.sort Z_zmodType.     (* Z *)

(**
整数を自然数回足し算する。整数×自然数 の演算子である。
*)
  Open Scope ring_scope.
  Compute 3%Z *+ 2%N.                       (* 6%Z *)
  Compute (- 3)%Z *+ 2%N.                   (* (- 6)%Z *)

  Check @GRing.natmul : forall V : zmodType, (* sort のコアーションを明示しない。 *)
      V -> nat -> V.
  Check @GRing.natmul Z_zmodType :           (* 型の引数を与える。 *)
    Z_zmodType -> nat -> Z_zmodType.

  Check @GRing.natmul : forall V : zmodType, (* sort のコアーションを明示する。 *)
      GRing.Zmodule.sort V -> nat -> GRing.Zmodule.sort V.
  Check @GRing.natmul Z_zmodType :          (* 型の引数を与える。 *)
    GRing.Zmodule.sort Z_zmodType -> nat -> GRing.Zmodule.sort Z_zmodType.
  Check @GRing.natmul Z_zmodType :          (* sort Z_zmodType = Z を反映する。 *)
    Z -> nat -> Z.

(**
## Canonical Z_zmodType の必要性の説明
*)

  (* ○ : Canonical Z_zmodType でなくてもよい。 *)
  (* × : Canonical Z_zmodType でないとエラーになる。 *)

(**
### x を Z 型で定義する。
 *)
  Variable x : Z.

  Check @GRing.natmul Z_zmodType x 2 : Z_zmodType. (* ○ *)
  Check GRing.natmul x 2.                          (* × *)
  Check x *+ 2.                                    (* × *)

  (** Z_zmodType から、コアーションで sort Z_zmodType を計算して Z を求めることはできる。 *)
  Print Graph.                              (* コアーションの表示 *)
  (** [GRing.Zmodule.sort : GRing.Zmodule.type >-> Sortclass] *)
  (** しかし、x の型 Z から、Z_zmodType を見つけて補うことはできない。なので、*)
  Print Canonical Projections.              (* カノニカルの表示 *)
  (** [Z <- GRing.Zmodule.sort ( Z_zmodType )] *)
  (** Z_zmodType が、 Z のカノニカルであるこを宣言しておく。 *)

  (* カノニカル [Z <- GRing.Zmodule.sort Z_zmodType] を使う。 *)
  Check GRing.mulr2n x : x *+ 2 = x + x.             (* × *)
  Check @GRing.mulr2n Z_zmodType x : x *+ 2 = x + x. (* × *)

(**
### x を Z_zmodType 型で定義する。
 *)
  Variable x' : Z_zmodType.
  Check x' *+ 2.                                         (* ○ *)
  Check GRing.mulr2n x' : x' *+ 2 = x' + x'.             (* ○ *)
  Check @GRing.mulr2n Z_zmodType x' : x' *+ 2 = x' + x'. (* ○ *)

(**
### x を (GRing.Zmodule.sort Z_zmodType) 型で定義する。
 *)
  Variable x'' : GRing.Zmodule.sort Z_zmodType.
  Compute GRing.Zmodule.sort Z_zmodType.        (* Z *)
(**
GRing.Zmodule.sort Z_zmodType を計算すると Z になるが、カノニカル宣言がなくてもよい。
 *)
  Check x'' *+ 2.                                            (* ○ *)
  Check GRing.mulr2n x'' : x'' *+ 2 = x'' + x''.             (* ○ *)
  Check @GRing.mulr2n Z_zmodType x'' : x'' *+ 2 = x'' + x''. (* ○ *)
End TEST.

(**
# [x *+ 2 = 2 * x] の証明 (テキスト 6.1.7節)
*)
Goal forall x : Z, x *+ 2 = (2%Z * x)%Z.
Proof.
  case=> // x; rewrite GRing.mulr2n Z.mul_comm.
    by rewrite -(Zred_factor1 (Z.pos x)).
    by rewrite -(Zred_factor1 (Z.neg x)).
Qed.

(** END *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** This module defines type constructors for types in [Type]
    ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)

Set Implicit Arguments.

Require Import Datatypes.
Local Open Scope identity_scope.
Require Export Logic.

(** Negation of a type in [Type] *)

Definition notT (A:Type) := A -> False.

(** Properties of [identity] *)

Section identity_is_a_congruence.

 Variables A B : Type.
 Variable f : A -> B.

 Variables x y z : A.

 Lemma identity_sym : identity x y -> identity y x.
 Proof.
  destruct 1; trivial.
 Defined.

 Lemma identity_trans : identity x y -> identity y z -> identity x z.
 Proof.
  destruct 2; trivial.
 Defined.

 Lemma identity_congr : identity x y -> identity (f x) (f y).
 Proof.
  destruct 1; trivial.
 Defined.

 Lemma not_identity_sym : notT (identity x y) -> notT (identity y x).
 Proof.
  red; intros H H'; apply H; destruct H'; trivial.
 Qed.

 Definition f_equal (e : x = y) : f x = f y :=
   match e with identity_refl => identity_refl end.

Theorem f_equal2 :
  forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1)
    (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
Proof.
  destruct 1; destruct 1; reflexivity.
Qed.

End identity_is_a_congruence.

Definition identity_ind_r :
  forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rec_r :
  forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rect_r :
  forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Hint Immediate identity_sym not_identity_sym: core v62.

(* Notation refl_id := identity_refl (compat "8.3"). *)
(* Notation sym_id := identity_sym (compat "8.3"). *)
(* Notation trans_id := identity_trans (compat "8.3"). *)
(* Notation sym_not_id := not_identity_sym (compat "8.3"). *)


Require Import Decidable.
Require Import Bool.BoolEq.
Require Import Setoid.

(* We start off by defining symbols.

We create a module, but leave it uninstantiated.
 *)
Module Type Sym.
  Parameter Symbol: Type.
  Parameter sym_beq: Symbol -> Symbol -> bool.

  Axiom sym_eq_dec: forall x y: Symbol, decidable (x = y).
End Sym.

Module Stlc (Symbol: Sym).
Import Symbol.

(* We claim that our boolean equality function corresponds to actual
equality, and show that this also holds true for disequality. *)
Axiom sym_beq_eq: forall x y, (sym_beq x y = true) <-> x = y.
Lemma sym_nbeq_neq: forall x y, (sym_beq x y = false) <-> x <> y.
intros.
split; intros.
intro.
case (sym_beq_eq x y); intros.
apply H2 in H0.
rewrite H0 in H.
contradict H.
discriminate.
case (sym_beq_eq x y); intros.
destruct (sym_beq x y).
contradict H.
auto.
auto.
Qed.

(* We define expressions, which consist of variables, lambdas,
applications, and units. Unit creates an instance of the base type. *)
Inductive Expr :=
| Unit : Expr
| Var : Symbol -> Expr
| App : Expr -> Expr -> Expr
| Lambda : Symbol -> Expr -> Expr.

(* Both our interpreter and our typing rules will need
environments. We define environments to map symbols onto some other
thing, such as values or types. *)
Inductive Env Val :=
| EmptyEnv : Env Val
| ExtendEnv : Symbol -> Val -> Env Val -> Env Val.

(* There are two values: units and closures. *)
Inductive Value :=
| VUnit : Value
| Closure : Symbol -> Expr -> (Env Value) -> Value.

(* The two values correspond to two types, one for units and another
for closures. *)
Inductive StlcType :=
| TUnit : StlcType
| Fn : StlcType -> StlcType -> StlcType.

(* This is the function for looking up in an environment. I defined it
using tactics instead of writing it myself. *)
Fixpoint lookup {T: Type} (x: Symbol) (env: (Env T)) : option T.
intros.
destruct env.
refine None.
refine (if sym_beq x s then _ else _).
refine (Some t).
apply (lookup T x env).
(* Since we defined our function this way, it's good to look over it
and make sure we defined what we meant to. *)
Show Proof.
Defined.

(* To facilitate stepping through proofs, we define the interpreter in
continuation passing style, representing continuations as data
structures.

We define two functions, step and apply_k. Step takes an expression,
environment and continuation and returns a new continuation. Apply_k
takes one of these continuations and continues the computation.

Originally I defined step and apply_k as mutually recursive, but it
was tough to convince Coq that these would each terminate. Instead, I
split the result into two continuation types, and step returns an
ApplyK instead of directly calling apply_k. *)
Inductive Cont :=
| EmptyK : Cont
| RatorK : Expr -> Env Value -> Cont -> Cont
| RandK : Value -> Cont -> Cont.

Inductive StepCont :=
| ApplyK : Cont -> Value -> StepCont
| FinalK : Value -> StepCont
| Error : StepCont.

Fixpoint step (e: Expr) (env : Env Value) (k: Cont) : StepCont :=
  match e with
    | Unit => ApplyK k VUnit
    | Var x => match lookup x env with
                 | Some v => ApplyK k v
                 | None => Error
               end
    | Lambda x b => ApplyK k (Closure x b env)
    | App e1 e2 => step e1 env (RatorK e2 env k)
  end.

Definition apply_k (k: Cont) v : StepCont :=
  match k with
    | EmptyK => FinalK v
    | RatorK e2 env k => step e2 env (RandK v k)
    | RandK v' k => match v' with
                      | Closure x b env =>
                        step b (ExtendEnv Value x v env) k
                      | _ => Error
                    end
  end.

(* This data type represents a proof that a continuation will result
in the given value if it executes long enough.

There are two branches: Either we are already at the final value, or
we have an ApplyK, meaning we need to take another step. *)
Inductive steps_to_cont : StepCont -> Value -> Prop :=
| step_final : forall v, steps_to_cont (FinalK v) v
| step_apply : forall k v' v,
  steps_to_cont (apply_k k v') v -> steps_to_cont (ApplyK k v') v.

Definition steps_to e env v := steps_to_cont (step e env EmptyK) v.

(* This type encodes the typing rules for STLC. There is one variant
for each of the inference rules. *)
Inductive type_expr : (Env StlcType) -> Expr -> StlcType -> Prop :=
| type_unit : forall env, type_expr env Unit TUnit
| type_var : forall x t env, lookup x env = Some t -> type_expr env (Var x) t
| type_lambda : forall env x b t' t,
  type_expr (ExtendEnv _ x t' env) b t
  -> type_expr env (Lambda x b) (Fn t' t)
| type_app : forall e1 e2 t1 t2 env,
  type_expr env e1 (Fn t1 t2) -> type_expr env e2 t1
  -> type_expr env (App e1 e2) t2.

(* For type safety, we want to prove that if an expression evaluates to a value, the value has the type it should. Thus, we need typing rules for values.

Closures include an environment, so we also need a way of relating
type environments to runtime environments. These are mutually
recursive because type checking closures needs a way to get a type
environment from the captured value environment, but the related
environment rules need to be able to typecheck values.

Alternatively, we could store the types in the value environment, but
my goal was to keep the typing rules and the interpreter entirely
separate. *)
Inductive type_value : Value -> StlcType -> Prop :=
| type_vunit : type_value VUnit TUnit
| type_closure : forall x b env tenv t' t,
  related_env env tenv ->
  type_expr (ExtendEnv _ x t' tenv) b t ->
  type_value (Closure x b env) (Fn t' t)
with related_env : (Env Value) -> (Env StlcType) -> Prop :=
| relate_empty : related_env (EmptyEnv _) (EmptyEnv _)
| relate_extend : forall x v t env tenv,
  related_env env tenv ->
  type_value v t ->
  related_env (ExtendEnv _ x v env) (ExtendEnv _ x t tenv).

(* We also need type checking rules for both types of continuations.

The first kind is expecting a value, so (type_cont t' k t) says that
continuation k will produce a value of type t if given a value of type
t'. *)
Inductive type_cont : (StlcType) -> Cont -> StlcType -> Prop :=
| type_empty_k : forall t, type_cont t EmptyK t
| type_ratork : forall t2 t1 e2 env tenv k t',
  related_env env tenv ->
  type_expr tenv e2 t2 ->
  type_cont t1 k t' ->
  type_cont (Fn t2 t1) (RatorK e2 env k) t'
| type_randk : forall t1 t2 t3 v k,
  type_cont t2 k t3 ->
  type_value v (Fn t1 t2) ->
  type_cont t1 (RandK v k) t3.

(* For step continuations, we just say that if this ran to completion
then we would get a value of type t. *)
Inductive type_step : StepCont -> StlcType -> Prop :=
| type_final : forall v t, type_value v t -> type_step (FinalK v) t
| type_apply : forall t' k v t,
  type_value v t' -> type_cont t' k t -> type_step (ApplyK k v) t.

(* These next two lemmas are very important. The first one says that
if a type and value environment are related and you look up a type in
the type environment, then you can also get a value from the value
environment, and vice-versa.

The second lemma says that if you look up a value and a type from
related environments, the value has the type from the type
environment. *)
Lemma related_env_compat : forall env tenv,
  related_env env tenv ->
  forall x,
    (forall v, lookup x env = Some v -> exists t, lookup x tenv = Some t)
    /\
    (forall t, lookup x tenv = Some t -> exists v, lookup x env = Some v).
(* This proof proceeds by induction on the related_environment judgment. *)
intros env tenv H; induction H; intros; split; intros.

(* This case is impossible because looking up anything in an empty
environment fails. *)
contradict H; discriminate.
(* This case is impossible for the same reason. *)
contradict H; discriminate.
(* Now we know that looking up in the environment gives us something,
but we need to consider whether we're at the current symbol or
not. This is what we get by destructing on (sym_eq_dec x x0). *)
case (sym_eq_dec x x0); intros; subst.
(* If they're equal, we know that t is the right type. We'll have to
do some simplification to make this clear to Coq though. *)
exists t; simpl.
assert (sym_beq x0 x0 = true).
apply sym_beq_eq; reflexivity.
rewrite H2; reflexivity.
(* Now we consider the case where the symbols x and x0 are not equal. *)
simpl.
assert (sym_beq x0 x = false).
apply (sym_nbeq_neq x0 x).
intro; apply H2; auto.
rewrite H3.
(* At this point we invoke the induction hypothesis to lookup in the
remainder of the environment. *)
destruct (IHrelated_env x0).
case (H4 v0); intros.
simpl in H1.
rewrite H3 in H1. exact H1.
exists x1; auto.
(* Now we repeat the process for value environments. *)
simpl.
destruct (sym_eq_dec x0 x).
rewrite H2.
assert (sym_beq x x = true).
apply (sym_beq_eq x x); auto.
rewrite H3.
exists v; auto.
assert (sym_beq x0 x = false).
apply (sym_nbeq_neq x0 x); auto.
rewrite H3.
destruct (IHrelated_env x0).
apply (H5 t0).
simpl in H1.
rewrite H3 in H1.
exact H1.
Qed.

(* This is the second part, if you get a type and a value from two
related environments, they go together. *)
Lemma related_env_equiv : forall env tenv,
  related_env env tenv ->
  forall x v t,
    lookup x env = Some v ->
    lookup x tenv = Some t ->
    type_value v t.
(* Again, by induction on the related_env judgment *)
intros env tenv H;
induction H; intros.
(* This case is obviously impossible *)
contradict H0; simpl; discriminate.
(* Again, consider the case where x0 = x and x0 <> x *)
destruct (sym_eq_dec x0 x); subst.
simpl in H1.
assert (sym_beq x x = true).
apply  (sym_beq_eq x x).
reflexivity.
rewrite H3 in H1.
(* Injection says that since Some v = Some v0, v must equal v0 *)
injection H1; intros; subst.
simpl in H2.
rewrite H3 in H2; injection H2; intros; subst.
exact H0.
(* Now we consider where x0 <> x *)
simpl in H1; simpl in H2.
assert (sym_beq x0 x = false).
apply (sym_nbeq_neq x0 x).
exact H3.
rewrite H4 in H1; rewrite H4 in H2.
(* We use the induction hypothesis to search the rest of the environment. *)
apply (IHrelated_env x0).
exact H1.
exact H2.
Qed.

(* Next we have a bunch of preservation lemmas. We have a couple of
ways of taking steps, so each of these say that the types do not
change as we do this. *)

Lemma preserve_eval : forall e tenv t',
  type_expr tenv e t' ->
  forall env k t,
  related_env env tenv ->
  type_cont t' k t ->
  type_step (step e env k) t.
intros e tenv t' H.
(* By induction on the typing of expressions *)
induction H; intros; simpl.
apply (type_apply TUnit).
apply type_vunit.
auto.
(* Here's a case of us using the related_env_compat lemmas from above
to show we can get a value of of env0. *)
case (related_env_compat env0 env H0 x); intros.
(* case (H3 t) let's us talk about the value that related_env_compat
guarantees must exist. *)
case (H3 t); auto; intros.
rewrite H4.
apply (type_apply t).
(* We know this value has the right type, because we pulled it from a
related environment. *)
apply (related_env_equiv env0 env H0 x).
exact H4.
exact H.
exact H1.
simpl.
apply (type_apply (Fn t' t)).
apply (type_closure _ _ _ env); auto.
auto.
apply IHtype_expr1; auto.
apply (type_ratork _ _ _ _ env); auto.
Qed.

Lemma preserve_step : forall t k v,
  type_step (ApplyK k v) t -> type_step (apply_k k v) t.
intros.
(* By induction over the typing rules for step continuation. We use
eauto to dispatch the easy cases automatically. *)
inversion H; subst; simpl; eauto using type_step.
(* The inversion tactic tells us which cases would have led to H4
being true. Once again, eauto helps us dispatch the easy cases. *)
inversion H4; subst; eauto using type_step.

simpl.
apply (preserve_eval _ tenv t2); eauto using type_cont.

simpl.
inversion H4; subst; eauto using type_step.
inversion H9; subst; eauto using type_step.
apply (preserve_eval _ (ExtendEnv _ x t' tenv) t0); eauto using type_step.
eauto using related_env.
Qed.

Lemma preserve_steps_to_cont : forall t s v,
  steps_to_cont s v ->
  type_step s t ->
  type_value v t.
intros.
induction H.
inversion H0; subst; auto.
apply IHsteps_to_cont.
apply preserve_step.
apply H0.
Qed.

Lemma preserve_step1 :
  forall e env tenv k t' t,
    related_env env tenv ->
    type_expr tenv e t' ->
    type_cont t' k t ->
    type_step (step e env k) t.
intro.
induction e; intros; simpl.
inversion H0; subst.
apply (type_apply TUnit); eauto using type_value.
inversion H0; subst.
case (related_env_compat env tenv H s); intros.
case (H3 t'); auto; intros.
rewrite H5.
apply (type_apply t').
apply (related_env_equiv env tenv H s); auto.
auto.
inversion H0; subst.
apply (IHe1 _ tenv _ (Fn t1 t')); auto.
apply (type_ratork _ _ _ _ tenv); auto.
apply (type_apply t').
inversion H0; subst; eauto using type_value.
auto.
Qed.

(* Finally, we can prove type safety *)
Theorem type_safe : forall e env tenv t,
  related_env env tenv ->
  type_expr tenv e t ->
  forall v, steps_to e env v -> type_value v t.
(* We go by induction over expressions. *)
intro; induction e; intros; simpl.

(* Unit Case *)
inversion H0; subst.
inversion H1; subst.
simpl in H5.
inversion H5; subst; eauto using type_value.

(* Variable Lookup Case *)
inversion H0; subst.
inversion H1; subst.
(* H3 is a impossible, since there is no way to make a FinalK equal to
a ApplyK or an Error. discriminate is a useful tactic to prove things
aren't equal. *)
contradict H3; destruct (lookup s env); discriminate.
assert (lookup s env = Some v).
(* The `; try discriminate` attempts to automatically dispatch that
case, letting us look at the slightly more interesting one. *)
destruct (lookup s env); try discriminate.
injection H2; intros; subst.
inversion H3; subst.
reflexivity.
apply (related_env_equiv env tenv H s); auto.

(* Coq wants us to do the application line next, but that's hard, so
we'll tackle the easy Lambda case first. *)
Focus 2.
inversion H1; subst.
inversion H5; subst.
inversion H0; subst.
apply (type_closure _ _ _ tenv); auto.

(* Application Line *)
unfold steps_to in H1.
apply (preserve_steps_to_cont _ (step (App e1 e2) env EmptyK)); auto.
apply (preserve_step1 _ _ tenv _ t); eauto using type_cont.
(* Actually, that wasn't so hard, since most of the work was in the
preservation lemmas. *)
Qed.

(* Unfortunately, the previous theorem isn't strong enough. We can't
claim that the program does not get stuck. We'll do this now by
showing that all well-typed terms produce a value. The theorem we
utlimately want is `evaluates_to_value`, but there will almost
certainly be some lemmas before then. *)

Lemma step_progress:
  forall tenv env,
    related_env env tenv ->
    forall e t k,
      type_expr tenv e t ->
      exists k' v,
        step e env k = ApplyK k' v.
intros tenv env H.

induction e; simpl; intros.

(* Unit line *)
exists k; exists VUnit; auto.

(* Variable line *)
case (related_env_compat env tenv H s); intros.
destruct (H2 t); auto.
inversion H0; auto.
rewrite H3.
exists k; exists x; auto.

(* Application line *)
inversion H0; subst.
case (IHe1 (Fn t1 t) (RatorK e2 env k)); auto; intros.
case H1; intros.
exists x; exists x0; auto.

(* Lambda line *)
exists k; exists (Closure s e env); auto.
Qed.

Lemma apply_progress:
  forall k v t' t,
    type_cont t' k t ->
    type_value v t' ->
    apply_k k v <> Error.
induction k; simpl; auto; intros; try discriminate.

inversion H; subst.
Check step_progress.
case (step_progress tenv e0 H5 e t2 (RandK v k)); auto; intros.
case H1; intros.
rewrite H2; discriminate.

inversion H; subst.
inversion H6; subst.
assert (related_env (ExtendEnv _ x v0 env) (ExtendEnv _ x t' tenv)).
eauto using related_env.
case (step_progress (ExtendEnv _ x t' tenv) (ExtendEnv _ x v0 env) H1 b t2 k);
auto; intros.
case H2; intros.
rewrite H3; discriminate.
Qed.

End Stlc.

Lemma eval_rator :
  forall e1 e2 env k v1 v2 t2 t,
    steps_to_cont (step e1 env EmptyK) v1 ->
    type_value v1 (Fn t2 t) ->
    steps_to_cont (step e2 env EmptyK) v2 ->
    type_value v2 t2 ->
    forall v,
      steps_to_cont (step e2 env (RandK v1 k)) v ->
      steps_to_cont (step e1 env (RatorK e2 env k)) v.
induction e1; simpl; intros.

(* Unit line *)
inversion H; subst.
inversion H7; subst.
inversion H0.

(* Variable line *)
destruct (lookup s env); try inversion H; subst.
inversion H; inversion H8; subst.
apply step_apply.
simpl.
exact H3.

(* Application line *)
apply (IHe1_1 _ _ _ v1 v2 t2 t).

Theorem evaluates_to_value :
  forall tenv env e t,
    type_expr tenv e t ->
    related_env env tenv ->
    exists v, steps_to e env v /\ type_value v t.
intros.
unfold steps_to.
induction H; subst; simpl.
(* Unit line *)
exists VUnit; eauto using steps_to_cont, type_value.

(* Variable line *)
Check related_env_compat.
case (related_env_compat env env0 H0 x); intros.
destruct (H2 t); auto.
rewrite H3.
exists x0; split; eauto using steps_to_cont.
Check related_env_equiv.
apply (related_env_equiv env env0 H0 x); auto.

(* Lambda line *)
exists (Closure x b env); eauto using steps_to_cont, type_value.

(* Application line. This one seems hard. *)
case IHtype_expr1; auto; intros.
destruct H2.
case IHtype_expr2; auto; intros.
destruct H4.