(**
Coqで継続モナド
=========================

2014_05_15 @suharahiromichi

モナドと継続の話を一度で片付けてしまおうと思う。
継続モナドについて解説したページは多いけれど、
大部分がHaskellであるから、Coq SSReflect で書いてみた。
もっとも、本資料の内容もHaskellについて解説した
文献2.を多く参考にさせていただいた。

また、フィボナッチ関数の証明は文献3.
のCoqによる証明をSSReflectに修正したものである。

Coqのモナドのパッケージは文献1.にあるが、
これは使用していない。ただし「>>=」演算子の優先順位はあわせた。

本資料のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/ssr/ssr_monad_continuation_monad.v
*)

Require Import ssreflect ssrbool ssrnat seq.

(**
# 継続モナド

## 定義

A->Rの型の関数が「継続」である。その「継続」を受け取るのが継続モナド
であり、(A->R)->Rの型をもつ。
モナドであることを強調するために、大文字のMContとラベルする。
*)
Definition MCont R A := (A -> R) -> R.

Definition bind {R A : Type} (c : MCont R A)
           (f : A -> MCont R A) : MCont R A :=
  fun (k : A -> R) => c (fun (a : A) => f a k).

Definition ret {R A : Type} (a : A) : MCont R A :=
  fun k => k a.

(* call/cc *)
Definition callcc {R A B : Type}
           (f : (A -> MCont R B) -> MCont R A) : MCont R A :=
  fun (k : A -> R) => f (fun (a : A) => fun _ => k a) k.

(**
演算子と、do記法も定義しておく。
*)
Notation "c >>= f" :=
  (bind c f)
    (at level 42, left associativity).      (* 文献1. *)

Notation "s1 >> s2" :=
  (s1 >>= fun _ => s2)
    (at level 42, left associativity).

Notation "'DO' a <- A ; b <- B ; C 'OD'" :=
  (A >>= fun a => B >>= fun b => C)
    (at level 100, no associativity).

Notation "'DO' A ; B ; C 'OD'" :=
  (A >> B >> C)
    (at level 100, no associativity).

(**
## モナド則の証明

モナド則の証明は簡単である。
*)
Lemma monad_1 : forall (R A : Type) (a : A) (f : A -> MCont R A),
                  ret a >>= f = f a.
Proof.
  by [].
Qed.

Lemma monad_2 : forall (R A : Type) (m : MCont R A),
                  m >>= ret = m.
Proof.
  by [].
Qed.

Lemma monad_3 : forall (R A : Type) (f g : A -> MCont R A) (m : MCont R A),
                  (m >>= f) >>= g = m >>= fun x => f x >>= g.
(* 右結合なので、実際は、この括弧は不要である。 *)
Proof.
  by [].
Qed.

(**
# 階乗の計算
*)
Section factorial.
(**
## 定義

階乗を再帰で計算する関数と、CPSで計算する関数を定義する。
*)
Fixpoint fact (n : nat) : nat :=
  match n with
    | 0     => 1
    | n'.+1 => n * fact n'
  end.

Fixpoint fact_cps (n : nat) : MCont nat nat :=
  match n with
    | 0     => ret 1
    | n'.+1 => fact_cps n' >>= fun (m : nat) => ret (m * n)
  end.

(**
## 実行例
*)
Eval cbv in fact_cps 0 id.                  (* 1 *)
Eval cbv in fact_cps 2 id.                  (* 2 *)
Eval cbv in fact_cps 3 id.                  (* 6 *)
Eval cbv in fact_cps 4 id.                  (* 24 *)

(**
## 証明

任意の自然数に対して、両者が同じ結果になることを証明する。

補題として、fact_cpsの計算の一段階分の証明しておく。
*)
Lemma fact_cps_Sn :
  forall n f,
    fact_cps n.+1 f =
    fact_cps n (fun (m : nat) => f (m * n.+1)).
Proof.
    by [].
Qed.

(**
任意の継続fについて証明する。
*)
Lemma eq_f_fact_fact_cps_f :
  forall (n : nat),
    (forall f, f (fact n) = fact_cps n f).
Proof.
  elim.
    by [].
  move=> n IHn f.
  by rewrite fact_cps_Sn -IHn mulnC.
Qed.

(**
証明したい定理
*)
Theorem eq_fact_fact_cps :
  forall (n : nat), fact n = fact_cps n id.
Proof.
  move=> n.
  apply (eq_f_fact_fact_cps_f n id).
Qed.

End factorial.

(**
# フィボナッチ関数
*)
Section fibonacci.
(**
## 定義

フィボナッチ数を再帰で計算する関数と、CPSで計算する関数を定義する。
後者の中でdo記法を使ってみた。
*)
Fixpoint fib (n : nat) : nat :=
  match n with
    | 0 => 1
    | 1 => 1
    | (m.+1 as sm).+1 => fib sm + fib m
  end.

Fixpoint fib_cps (n : nat) : MCont nat nat :=
  match n with
    | 0 => ret 1
    | 1 => ret 1
    | (m.+1 as sm).+1 =>
      DO
        a <- fib_cps sm;
        b <- fib_cps m;
        ret (a + b)
      OD
  end.

(**
## 実行例
*)
Eval cbv in fib_cps 0 id.                  (* 1 *)
Eval cbv in fib_cps 1 id.                  (* 1 *)
Eval cbv in fib_cps 2 id.                  (* 2 *)
Eval cbv in fib_cps 3 id.                  (* 3 *)
Eval cbv in fib_cps 4 id.                  (* 5 *)
Eval cbv in fib_cps 6 id.                  (* 13 *)

(**
## 証明

任意の自然数に対して、両者が同じ結果になることを証明する。
この証明は文献3.を参考にした。
*)

(**
補題: fib_cpsの定義の三番目の節を取り出したもので、fib_cpsの
計算を一段進めるのに使う。
 *)
Lemma fib_cps_SSn : forall n f,
  fib_cps n.+2 f =
  fib_cps n.+1 (fun r1 => fib_cps n (fun r2 => f (r1 + r2))).
Proof.
  by [].
Qed.

(**
より強い定理
 *)
Lemma eq_fib_fib_cps_aux :
  forall n,
    (forall f, f (fib n) = fib_cps n f) /\
    (forall g, g (fib n.+1) = fib_cps n.+1 g).
Proof.
  elim.
  (* fib 0 = fib_cps 0 /\ fib 1 = fib_cps 1 を証明する。 *)
    by [].

  (* fib n = fib_cps n /\ fib n+1 = fib_cps n+1 ならば、
     fib n+1 = fib_cps n+1 /\ fib n+2 = fib_cps n+2 を証明する。 *)
  case=> n.

  (* fib 0 = fib_cps 0 /\ fib 1 = fib_cps 1 ならば、
     fib 1 = fib_cps 1 /\ fib 2 = fib_cps 2 を証明する。 *)
    by [].

  (* fib n+1 = fib_cps n+1 /\ fib n+2 = fib_cps n+2 ならば、
     fib n+2 = fib_cps n+2 /\ fib n+3 = fib_cps n+3 を証明する。 *)
  case=> Hf Hg.
  split; move=> f; rewrite fib_cps_SSn.
  (* ゴールの/\の左を証明する。 *)
    by rewrite Hg.
  (* ゴールの/\の右を証明する。 *)
  by rewrite -Hg -Hf.
Qed.

(**
任意の継続fについて証明する。
*)
Lemma eq_f_fib_fib_cps_f : forall n f, f (fib n) = fib_cps n f.
Proof.
  move=> n f.
  apply (eq_fib_fib_cps_aux n).
Qed.

(**
証明したい定理
*)
Theorem eq_fib_fib_cps : forall n, fib n = fib_cps n id.
Proof.
  move=> n.
  apply (eq_f_fib_fib_cps_f n id).
Qed.

End fibonacci.

(**
# 文献

1. Library lc.Monad
   http://coq.inria.fr/pylons/contribs/files/lc/trunk/lc.Monad.html

2. お気楽 Haskell プログラミング入門 ●継続渡しスタイル
   http://www.geocities.jp/m_hiroi/func/haskell38.html

3. CPS変換されたフィボナッチ関数の証明をしてみた
   http://d.hatena.ne.jp/yoshihiro503/20100830#p2

*)

(* END *)


Require Import Coq.Arith.Arith.

Module A.

  Fixpoint foo (n:nat) :=
  match n with
  | 0 => 0
  | S n => bar n
  end

  with bar (n:nat) :=
  match n with
  | 0 => 0
  | S n => foo n
  end.

  Lemma using_foo:
    forall (n:nat), foo n = 0 /\ bar n = 0.
  Proof.
    induction n ; split ; auto ;
    destruct IHn ; auto.
  Qed.

End A.

Module B.

  Module A := A.
  Import A.

End B.

Module E.

  Module B := B.
  Import B.A.

  (* Bug 1 *)
  Lemma test_1:
    forall (n:nat), foo n = 0.
  Proof.
    intros ; destruct n.
    reflexivity.
    specialize (A.using_foo (S n)) ; intros.
    simpl in H.
    simpl.
    destruct H.
    assumption.
  Qed.

End E.


Require Import List.

Require Import Cpdt.CpdtTactics.

(* Fixpoint bad (u : unit) : Prop := bad u. *)
(* Inductive term : Set :=
| App : term -> term -> term
| Abs : (term -> term) -> term. *)

Definition bad : unit := tt.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section stream.
  Variable A : Type.

  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

(*Fixpoint needs at least one parameter in the following example. And that's why we need CoInductive*)

(* Variable B : Type.
Inductive stream_ : Type :=
| Cons_ : B -> stream_ -> stream_.
Fixpoint zeros_ : stream nat := Cons_ 0 zeros_. *)

CoInductive evilStream := Nil.

CoFixpoint zeroes : stream nat := Cons 0 zeroes.

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.

Fixpoint approx A (s : stream A) (n : nat) : list A :=
  match n with
    | O => nil
    | S n' =>
      match s with
        | Cons h t => h :: approx t n'
      end
  end.

Print filter.

Eval simpl in approx zeroes 10.
Eval simpl in approx trues_falses 10.
(* CoFixpoint looper : stream nat := looper. *)
Definition looper := 0.

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

  CoFixpoint map (s : stream A) : stream B :=
    match s with
      | Cons h t => Cons (f h) (map t)
    end.
End map.

Definition filter := 0.

Section interleave.
  Variable A : Type.

  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
      | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.

Section map'.
  Variables A B : Type.
  Variable f : A -> B.
End map'.

Definition tl A (s : stream A) : stream A :=
  match s with
    | Cons _ s' => s'
  end.

CoFixpoint ones : stream nat := Cons 1 ones.
Definition ones' := map S zeroes.

Theorem ones_eq : ones = ones'.

Definition foo := @eq.
Abort.

Section stream_eq.
  Variable A : Type.

  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2,
    stream_eq t1 t2
    -> stream_eq (Cons h t1) (Cons h t2).
End stream_eq.

Theorem ones_eq : stream_eq ones ones'.
  cofix ones_eq.
  assumption.
  Undo.
  simpl.
Abort.

Definition frob A (s : stream A) : stream A :=
  match s with
    | Cons h t => Cons h t
  end.

Theorem frob_eq : forall A (s : stream A), s = frob s.
  destruct s; reflexivity.
Qed.

Theorem ones_eq : stream_eq ones ones'.
  cofix ones_eq.
  rewrite (frob_eq ones).
  rewrite (frob_eq ones').
  simpl.
  constructor.
  assumption.
Qed.

Theorem ones_eq' : stream_eq ones ones'.
  cofix one_eq'; crush.
Abort.

Definition hd A (s : stream A) : A :=
  match s with
    | Cons x _ => x
  end.

Section stream_eq_coind.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.

  Hypothesis Cons_case_hd : forall s1 s2, R s1 s2 -> hd s1 = hd s2.
  Hypothesis Cons_case_tl : forall s1 s2, R s1 s2 -> R (tl s1) (tl s2).

  Theorem stream_eq_coind : forall s1 s2, R s1 s2 -> stream_eq s1 s2.
    cofix stream_eq_coind; destruct s1; destruct s2; intro.
    generalize (Cons_case_hd H); intro Heq; simpl in Heq; rewrite Heq.
    constructor.
    apply stream_eq_coind.
    apply (Cons_case_tl H).
  Qed.
End stream_eq_coind.

Print stream_eq_coind.

Theorem ones_eq'' : stream_eq ones ones'.
  apply (stream_eq_coind (fun s1 s2 => s1 = ones /\ s2 = ones')); crush.
Qed.

Section stream_eq_loop.
  Variable A : Type.
  Variables s1 s2 : stream A.

  Hypothesis Cons_case_hd : hd s1 = hd s2.
  Hypothesis loop1 : tl s1 = s1.
  Hypothesis loop2 : tl s2 = s2.

  Theorem stream_eq_loop : stream_eq s1 s2.
    apply (stream_eq_coind (fun s1' s2' => s1' = s1 /\ s2' = s2)); crush.
  Qed.
End stream_eq_loop.

Theorem ones_eq''' : stream_eq ones ones'.
  apply stream_eq_loop; crush.
Qed.

Require Import Arith.
Print fact.

CoFixpoint fact_slow' (n : nat) := Cons (fact n) (fact_slow' (S n)).
Definition fact_slow := fact_slow' 1.

CoFixpoint fact_iter' (cur acc : nat) := Cons acc (fact_iter' (S cur) (acc * cur)).
Definition fact_iter := fact_iter' 2 1.

Eval simpl in approx fact_iter 5.
Eval simpl in approx fact_slow 5.
Lemma fact_def : forall x n,
  fact_iter' x (fact n * S n) = fact_iter' x (fact (S n)).
  simpl; intros; f_equal; ring.
Qed.

Hint Resolve fact_def.

Lemma fact_eq' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  intro; apply (stream_eq_coind (fun s1 s2 => exists n, s1 = fact_iter' (S n) (fact n)
    /\ s2 = fact_slow' n)); crush; eauto.
Qed.

Theorem fact_eq : stream_eq fact_iter fact_slow.
  apply fact_eq'.
Qed.

Section stream_eq_onequant.
  Variables A B : Type.
  Variables f g : A -> stream B.
  Hypothesis Cons_case_hd : forall x, hd (f x) = hd (g x).
  Hypothesis Cons_case_tl : forall x, exists y, tl (f x) = f y /\ tl (g x) = g y.

  Theorem stream_eq_onequant : forall x, stream_eq (f x) (g x).
    intro; apply (stream_eq_coind (fun s1 s2 => exists x, s1 = f x /\ s2 = g x)); crush; eauto.
  Qed.
End stream_eq_onequant.

Lemma fact_eq'' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  apply stream_eq_onequant; crush; eauto.
Qed.

Definition var := nat.

Definition vars := var -> nat.
Definition set (vs : vars) (v : var) (n : nat) : vars :=
  fun v' => if beq_nat v v' then n else vs v'.

Inductive exp : Set :=
| Const : nat -> exp
| Var : var -> exp
| Plus : exp -> exp -> exp.

Fixpoint evalExp (vs : vars) (e : exp) : nat :=
  match e with
    | Const n => n
    | Var v => vs v
    | Plus e1 e2 => evalExp vs e1 + evalExp vs e2
  end.

Inductive cmd : Set :=
| Assign : var -> exp -> cmd
| Seq : cmd -> cmd -> cmd
| While : exp -> cmd -> cmd.

CoInductive evalCmd : vars -> cmd -> vars -> Prop :=
| EvalAssign : forall vs v e, evalCmd vs (Assign v e) (set vs v (evalExp vs e))
| EvalSeq : forall vs1 vs2 vs3 c1 c2, evalCmd vs1 c1 vs2
  -> evalCmd vs2 c2 vs3
  -> evalCmd vs1 (Seq c1 c2) vs3
| EvalWhileFalse : forall vs e c, evalExp vs e = 0
  -> evalCmd vs (While e c) vs
| EvalWhileTrue : forall vs1 vs2 vs3 e c, evalExp vs1 e <> 0
  -> evalCmd vs1 c vs2
  -> evalCmd vs2 (While e c) vs3
  -> evalCmd vs1 (While e c) vs3.

Section evalCmd_coind.
  Variable R : vars -> cmd -> vars -> Prop.

  Hypothesis AssignCase : forall vs1 vs2 v e, R vs1 (Assign v e) vs2
    -> vs2 = set vs1 v (evalExp vs1 e).

  Hypothesis SeqCase : forall vs1 vs3 c1 c2, R vs1 (Seq c1 c2) vs3
    -> exists vs2, R vs1 c1 vs2 /\ R vs2 c2 vs3.

  Hypothesis WhileCase : forall vs1 vs3 e c, R vs1 (While e c) vs3
    -> (evalExp vs1 e = 0 /\ vs3 = vs1)
    \/ exists vs2, evalExp vs1 e <> 0 /\ R vs1 c vs2 /\ R vs2 (While e c) vs3.

  Theorem evalCmd_coind : forall vs1 c vs2, R vs1 c vs2 -> evalCmd vs1 c vs2.
    cofix evalCmd_coind; intros; destruct c.
    rewrite (AssignCase H); constructor.
    destruct (SeqCase H) as [? [? ?]]; econstructor; eauto.
    destruct (WhileCase H) as [[? ?] | [? [? [? ?]]]]; subst; econstructor; eauto.
  Qed.
End evalCmd_coind.

Fixpoint optExp (e : exp) : exp :=
  match e with
    | Plus (Const 0) e => optExp e
    | Plus e1 e2 => Plus (optExp e1) (optExp e2)
    | _ => e
  end.

Fixpoint optCmd (c : cmd) : cmd :=
  match c with
    | Assign v e => Assign v (optExp e)
    | Seq c1 c2 => Seq (optCmd c1) (optCmd c2)
    | While e c => While (optExp e) (optCmd c)
  end.

Lemma optExp_correct : forall vs e, evalExp vs (optExp e) = evalExp vs e.
  induction e; crush;
    repeat (match goal with
              | [ |- context[match ?E with Const _ => _ | _ => _ end] ] => destruct E
              | [ |- context[match ?E with O => _ | S _ => _ end] ] => destruct E
            end; crush).
Qed.

Hint Rewrite optExp_correct.

Ltac finisher := match goal with
                   | [ H : evalCmd _ _ _ |- _ ] => ((inversion H; [])
                     || (inversion H; [|])); subst
                 end; crush; eauto 10.

Lemma optCmd_correct1 : forall vs1 c vs2, evalCmd vs1 c vs2
  -> evalCmd vs1 (optCmd c) vs2.
  intros; apply (evalCmd_coind (fun vs1 c' vs2 => exists c, evalCmd vs1 c vs2
    /\ c' = optCmd c)); eauto; crush;
    match goal with
      | [ H : _ = optCmd ?E |- _ ] => destruct E; simpl in *; discriminate
        || injection H; intros; subst
    end; finisher.
Qed.

Lemma optCmd_correct2 : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
  -> evalCmd vs1 c vs2.
  intros; apply (evalCmd_coind (fun vs1 c vs2 => evalCmd vs1 (optCmd c) vs2));
    crush; finisher.
Qed.

Theorem optCmd_correct : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
  <-> evalCmd vs1 c vs2.
  intuition; apply optCmd_correct1 || apply optCmd_correct2; assumption.
Qed.


Generalizable All Variables.

Require Import facts.
Require Import ch03_1_categories.

(*** =============== Functors =============== ***)

(****************** Definition 3.17 ******************)

Class Functor (C : Category) (D : Category) :=
  {
    fobj      : (@Ob C) -> (@Ob D);
    fmor      : forall {a b}, a ~> b -> (fobj a) ~> (fobj b);
    fmor_comp : forall `(f: a ~> b) `(g: b ~> c),
                  fmor (g << f) = (fmor g) << (fmor f);
    fmor_id   : forall a, fmor (id a) = id (fobj a)
  }.

Implicit Arguments fobj [ C D ].
Implicit Arguments fmor [ C D a b ].

Lemma Functor_eq :
  forall `(C: Category) `(D: Category) (F G: Functor C D)
    (Oeq: fobj F = fobj G),
    ((fun a b =>
        match Oeq in _ = V return a ~> b -> (V a) ~> (V b)
        with
          eq_refl => @fmor _ _ F a b
        end)
     = (fmor G))
    -> F = G.
Proof.
  intros C D F G Oeq Meq.
  destruct F; destruct G; simpl in *.
  destruct Oeq.
  assert ((fun a b : Ob => fmor0 a b) = fmor0);
    try apply eta_expansion_dep.
  rewrite H in Meq.
  destruct Meq.
  destruct (proof_irrelevance _ fmor_comp0 fmor_comp1).
  destruct (proof_irrelevance _ fmor_id0 fmor_id1).
  reflexivity.
Qed.

(*** =============== Properties of Functors =============== ***)

(****************** Example 3.20 ******************)
Instance Fnt_id (C: Category) : Functor C C :=
  {
    fmor := fun _ _ f => f
  }.
Proof.
  reflexivity.
  reflexivity.
Defined.

Instance Fnt_const (C D: Category)(b: @Ob D) : Functor C D :=
  {
    fmor := fun _ _ _ => id b
  }.
Proof.
  rewrite -> id_r; reflexivity.
  reflexivity.
Defined.

(****************** Proposition 3.21 ******************)
Theorem Fnt_preserv_iso :
  forall `(F: Functor) `(f: A ~> B),
    Isomorphism f -> Isomorphism (fmor F f).
Proof.
  intros C D F A B f Hf.
  destruct Hf as [[f' [inv_comp_a inv_comp_b]]].
  apply Build_Isomorphism.
  exists (fmor F f').
  apply Build_Inversion; rewrite <- fmor_comp; rewrite <- fmor_id.
  - rewrite -> inv_comp_a; reflexivity.
  - rewrite -> inv_comp_b; reflexivity.
Qed.

(****************** Proposition 3.23 ******************)
Definition Fnt_comp
           (C D E: Category)
           (F: @Functor C D) (G: @Functor D E) : Functor C E.
Proof.
  apply Build_Functor
  with (fmor := (fun _ _ f => fmor G (fmor F f))).
  - intros; repeat rewrite -> fmor_comp; reflexivity.
  - intros; repeat rewrite -> fmor_id; reflexivity.
Defined.
Notation "G <<< F" := (@Fnt_comp _ _ _ F G)  :category_scope.

Lemma Fnt_id_l :
  forall `(F: Functor), F <<< (Fnt_id C) = F.
Proof.
  intros C D F.
  assert (fobj (F <<< Fnt_id C) = fobj F) as Hfobj.
  { simpl. apply eta_expansion_dep. }
  apply Functor_eq with (Oeq := Hfobj); simpl.
  extensionality a; extensionality b; extensionality f.
  transitivity (match Hfobj in _ = V return (V a) ~> (V b) with eq_refl => (fun f0 : a ~> b => fmor F f0) f end).
  destruct Hfobj; trivial.
  apply JMeq_eq.
  destruct Hfobj; trivial.
Qed.

Lemma Fnt_id_r :
  forall `(F: Functor), (Fnt_id D) <<< F = F.
  intros C D F.
  assert (fobj (Fnt_id D <<< F) = fobj F) as Hfobj.
  { simpl; apply eta_expansion_dep. }
  apply Functor_eq with (Oeq := Hfobj); simpl.
  extensionality a; extensionality b; extensionality f.
  transitivity (match Hfobj in _ = V return (V a) ~> (V b) with eq_refl => (fun f0 : a ~> b => fmor F f0) f end).
  destruct Hfobj; trivial.
  apply JMeq_eq.
  destruct Hfobj; trivial.
Qed.

Lemma Fnt_assoc :
  forall `{C0: Category} `{C1: Category} `{C2: Category} `{C3: Category}
    (F: Functor C0 C1) (G: Functor C1 C2) (H: Functor C2 C3),
    H <<< (G <<< F) = (H <<< G) <<< F.
Proof.
  intros C0 C1 C2 C3 F G H.
  assert (fobj (H <<< (G <<< F)) = fobj ((H <<< G) <<< F)) as Hfobj;
    try trivial.
  apply Functor_eq with (Oeq := Hfobj); simpl.
  extensionality a; extensionality b; extensionality f.
  transitivity (match Hfobj in _ = V return (V a) ~> (V b) with eq_refl => (fun f0 : a ~> b => fmor H (fmor G (fmor F f0))) f end).
  destruct Hfobj; trivial.
  apply JMeq_eq.
Admitted.

Lemma fjuggle :
  forall `{C0: Category} `{C1: Category} `{C2: Category}
    `{C3: Category} `{C4: Category}
    (F: Functor C0 C1) (G: Functor C1 C2)
    (H: Functor C2 C3) (K: Functor C3 C4),
    (K <<< H) <<< (G <<< F) = K <<< (H <<< G) <<< F.
Proof.
  intros; repeat rewrite -> Fnt_assoc; reflexivity.
Qed.

(* Instance catCategory : Category := *)
(*   { *)
(*     Ob   := Category; *)
(*     hom  := fun C D => Functor C D; *)
(*     id   := fun C => Fnt_id C; *)
(*     comp := Fnt_comp *)
(*   }. *)
(* Proof. *)
(*   intros; apply Fnt_assoc. *)
(*   intros; apply Fnt_id_l. *)
(*   intros; apply Fnt_id_r. *)
(* Defined. *)

(****************** Definition 3.24 ******************)
Class F_Inversion
      {C D: Category} (F: Functor C D) (G: Functor D C) :=
  {
    finv_comp1 : G <<< F = Fnt_id C;
    finv_comp2 : F <<< G = Fnt_id D
  }.

Class F_Isomorphism
      `(F: Functor) :=
  {
    fiso_comp1:
      exists G : Functor D C, F_Inversion F G
  }.

Class F_Isomorphic (C D: Category) : Prop :=
  {
    fiso_ex : exists F: Functor C D, F_Isomorphism F
  }.

(****************** Remark 3.25 ******************)
(*** The lemmas and theorems are identical to those in 3.14 ***)
Lemma FInv_symm :
  forall `(F: Functor) G,
    F_Inversion F G -> F_Inversion G F.
Proof.
  intros C D F G HFG.
  apply Build_F_Inversion; destruct HFG; assumption.
Qed.

Lemma FIso_finv :
  forall `(F: Functor) G,
    F_Isomorphism F -> F_Inversion F G -> F_Isomorphism G.
Proof.
  intros C D F G HF HFG.
  apply Build_F_Isomorphism.
  exists F.
  apply FInv_symm; assumption.
Qed.

Lemma Fnt_equal :
  forall {C D: Category} (F: Functor C D) (G H: Functor D C),
    G <<< F = Fnt_id C -> F <<< H = Fnt_id D -> G = H.
Proof.
  intros C D F G H Hfg Hhf.
  rewrite <- Fnt_id_r.
  rewrite <- Hfg.
  rewrite <- Fnt_assoc.
  rewrite -> Hhf.
  rewrite -> Fnt_id_l.
  reflexivity.
Qed.

Theorem double_finv :
  forall `(F: Functor) G H,
    F_Inversion F G -> F_Inversion G H -> F = H.
Proof.
  intros C D F G H Hfg Hgh.
  apply (Fnt_equal _ F _).
  - destruct Hfg; assumption.
  - destruct Hgh; assumption.
Qed.

Theorem finv_comp :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E) F' G',
    F_Inversion F F' ->
    F_Inversion G G' ->
    F_Inversion (G <<< F) (F' <<< G').
Proof.
  intros C D E F G F' G' HF HG.
  destruct HF; destruct HG.
  apply Build_F_Inversion.
  - rewrite -> fjuggle; rewrite -> finv_comp5.
    rewrite -> Fnt_id_l; assumption.
  - rewrite -> fjuggle; rewrite -> finv_comp4.
    rewrite -> Fnt_id_l; assumption.
Qed.

(****************** Definition 3.27 ******************)
Definition F_Injective {C D: Category} (F: Functor C D) :=
  forall (c c': @Ob C), fobj F c = fobj F c' -> c = c'.

Definition F_Surjective {C D: Category} (F: Functor C D) :=
  forall (d: @Ob D), {c: @Ob C | fobj F c = d}.

Definition F_Faithful {C D: Category} (F: Functor C D) :=
  forall (a b: @Ob C) (h h': a ~> b), fmor F h = fmor F h' -> h = h'.

Definition F_Full {C D: Category} (F: Functor C D) :=
  forall (a b: @Ob C) (h': fobj F a ~> fobj F b),
    {h: a ~> b | fmor F h = h'}.

(**
 * A faithful but not injective functor is not an embedding.
 * To see why, think of a functor (Functor C D) that is faithful
 * but all objects in C are mapped to the same object in D. In
 * this case there can exist multiple morphisms (with different
 * domain and codomain) in C that maps to the same morphism in D.
 *)

Class Embedding `(F: Functor):=
  {
    emb_f         := F;
    emb_faithful  :  F_Faithful emb_f;
    emb_injective :  F_Injective emb_f
  }.
Coercion emb_f : Embedding >-> Functor.

(****************** Proposition 3.30 ******************)
Theorem fiso_comp :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    F_Isomorphism F -> F_Isomorphism G -> F_Isomorphism (G <<< F).
Proof.
  intros C D E F G HF HG.
  apply Build_F_Isomorphism.
  destruct HF as [comp_F]; destruct HG as [comp_G].
  destruct comp_F as [F' HF']; destruct comp_G as [G' HG'].
  exists (F' <<< G').
  apply finv_comp; assumption.
Qed.

Theorem Fnt_comp_injective :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    F_Injective F -> F_Injective G -> F_Injective (G <<< F).
Proof.
  unfold F_Injective; intros C D E F G HF HG c c' H.
  apply HF; apply HG; assumption.
Qed.

Theorem Fnt_comp_faithful :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    F_Faithful F -> F_Faithful G -> F_Faithful (G <<< F).
Proof.
  unfold F_Faithful; intros C D E F G HF HG a b h h' H.
  apply HF; apply HG; assumption.
Qed.

Theorem Fnt_comp_full :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    F_Full F -> F_Full G -> F_Full (G <<< F).
Proof.
  unfold F_Full; intros C D E F G HF HG a b h'.
  destruct HG with (a := fobj F a)(b := fobj F b)(h' := h') as [h2 Hh2].
  destruct HF with (a := a)(b := b)(h' := h2) as [h1 Hh1].
  exists h1.
  rewrite <- Hh1 in Hh2; assumption.
Qed.

Theorem Emb_comp :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    Embedding F -> Embedding G -> Embedding (G <<< F).
Proof.
  intros C D E F G HF HG.
  destruct HF as [F' F_faithful F_injective];
    destruct HG as [G' G_faithful G_injective].
  apply Build_Embedding.
  apply Fnt_comp_faithful; assumption.
  apply Fnt_comp_injective; assumption.
Qed.

Lemma Fnt_injective_partial :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    F_Injective (G <<< F) -> F_Injective F.
Proof.
  unfold F_Injective; intros C D E F G HFG c c' H.
  apply HFG; simpl. rewrite -> H. reflexivity.
Qed.

Lemma Fnt_faithful_partial :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    F_Faithful (G <<< F) -> F_Faithful F.
Proof.
  unfold F_Faithful. intros C D E F G HFG a b h h' H.
  apply HFG; simpl. rewrite -> H. reflexivity.
Qed.

Theorem Emb_partial :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    Embedding (G <<< F) -> Embedding F.
Proof.
  intros C D E F G HFG.
  destruct HFG as [FG FG_faithful FG_injective].
  apply Build_Embedding.
  apply (Fnt_faithful_partial F G); assumption.
  apply (Fnt_injective_partial F G); assumption.
Qed.

Theorem Prop_3_30_3 :
  forall {C D E: Category} (F: Functor C D) (G: Functor D E),
    F_Surjective F -> F_Full (G <<< F) -> F_Full G.
Proof.
  unfold F_Surjective; unfold F_Full; intros C D E F G HF HFG a' b' h'.
  destruct HF with (d := a') as [a Ha].
  destruct HF with (d := b') as [b Hb].
  destruct Ha; destruct Hb.
  destruct HFG with (a := a)(b := b)(h' := h') as [h Hh].
  exists (fmor F h). apply Hh.
Qed.

(****************** Proposition 3.31 ******************)
Theorem Prop_3_31_1 :
  forall A B (F: Functor A B),
    F_Full F -> F_Faithful F ->
    forall a a' g,
      (exists (f: a ~> a'), fmor F f = g) /\
      (forall (f1 f2: a ~> a'), fmor F f1 = fmor F f2 -> f1 = f2).
Proof.
  intros A B F full faithful a a' g.
  split.
  - destruct full with (a := a)(b := a')(h' := g).
    exists x; assumption.
  - intros f1 f2 Heq.
    apply faithful with (a := a)(b := a')(h := f1)(h' := f2);
      trivial.
Qed.

Theorem Prop_3_31_2 :
  forall A B (F: Functor A B),
    F_Full F -> F_Faithful F ->
    forall a a' (f : a ~> a'),
      (Isomorphism f <-> Isomorphism (fmor F f)).
Proof.
  intros A B F full faithful a a' f.
  split; intros Hiso.
  - apply Fnt_preserv_iso; assumption.
  - destruct Hiso as [[g' [inv_comp1]]].
    (* Here we need fullness *)
    assert (exists (f: a' ~> a), fmor F f = g').
    { apply Prop_3_31_1; assumption. }
    destruct H as [f' Hf'].
    rewrite <- Hf' in *.
    rewrite <- fmor_comp in inv_comp1;
      rewrite <- fmor_comp in inv_comp2;
      rewrite <- fmor_id in inv_comp1;
      rewrite <- fmor_id in inv_comp2.
    (* Here we need faithfulness *)
    assert (forall (f1 f2: a ~> a), fmor F f1 = fmor F f2 -> f1 = f2).
    { apply Prop_3_31_1; try trivial; apply id. }
    apply H in inv_comp1.
    assert (forall (f1 f2: a' ~> a'), fmor F f1 = fmor F f2 -> f1 = f2).
    { apply Prop_3_31_1; try trivial; apply id. }
    apply H0 in inv_comp2.
    apply Build_Isomorphism; exists f'; apply Build_Inversion; trivial.
Qed.


(** * RecordSub: Subtyping with Records *)

Require Export MoreStlc.

(* ###################################################### *)
(** * Core Definitions *)

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

Inductive ty : Type :=
  (* proper types *)
  | TTop   : ty
  | TBase  : id -> ty
  | TArrow : ty -> ty -> ty
  (* record types *)
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TTop" | Case_aux c "TBase" | Case_aux c "TArrow"
  | Case_aux c "TRNil" | Case_aux c "TRCons" ].

Inductive tm : Type :=
  (* proper terms *)
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tproj : tm -> id -> tm
  (* record terms *)
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp" | Case_aux c "tabs"
  | Case_aux c "tproj" | Case_aux c "trnil" | Case_aux c "trcons" ].

(* ################################### *)
(** *** Well-Formedness *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTTop :
        well_formed_ty TTop
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

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

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if eq_id_dec x y then s else t
  | tabs y T t1 =>  tabs y T (if eq_id_dec x y then t1 else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr2 => trcons i (subst x s t1) (subst x s tr2)
  end.

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

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

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_rnil : value trnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (trcons i v vr).

Hint Constructors value.

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' => if eq_id_dec i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' => if eq_id_dec i i' then Some t else tlookup i tr'
  | _ => None
  end.

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr ==> tr' ->
        (tproj tr i) ==> (tproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi    ->
       (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

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_Proj1" | Case_aux c "ST_ProjRcd" | Case_aux c "ST_Rcd"
  | Case_aux c "ST_Rcd_Head" | Case_aux c "ST_Rcd_Tail" ].

Hint Constructors step.

(* ###################################################################### *)
(** * Subtyping *)

(** Now we come to the interesting part.  We begin by defining
    the subtyping relation and developing some of its important
    technical properties. *)

(* ################################### *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we
    sketched in the motivating discussion, but we need to add
    well-formedness side conditions to some of the rules. *)

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    subtype T T
  | S_Trans : forall S U T,
    subtype S U ->
    subtype U T ->
    subtype S T
  | S_Top : forall S,
    well_formed_ty S ->
    subtype S TTop
  | S_Arrow : forall S1 S2 T1 T2,
    subtype T1 S1 ->
    subtype S2 T2 ->
    subtype (TArrow S1 S2) (TArrow T1 T2)
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (TRCons i T1 T2) ->
    subtype (TRCons i T1 T2) TRNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    subtype S1 T1 ->
    subtype Sr2 Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    subtype (TRCons i S1 Sr2) (TRCons i T1 Tr2)
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (TRCons i1 T1 (TRCons i2 T2 Tr3)) ->
    i1 <> i2 ->
    subtype (TRCons i1 T1 (TRCons i2 T2 Tr3))
            (TRCons i2 T2 (TRCons i1 T1 Tr3)).

Hint Constructors subtype.

Tactic Notation "subtype_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "S_Refl" | Case_aux c "S_Trans" | Case_aux c "S_Top"
  | Case_aux c "S_Arrow" | Case_aux c "S_RcdWidth"
  | Case_aux c "S_RcdDepth" | Case_aux c "S_RcdPerm" ].

(* ############################################### *)
(** ** Subtyping Examples and Exercises *)

Module Examples.

Notation x := (Id 0).
Notation y := (Id 1).
Notation z := (Id 2).
Notation j := (Id 3).
Notation k := (Id 4).
Notation i := (Id 5).
Notation A := (TBase (Id 6)).
Notation B := (TBase (Id 7)).
Notation C := (TBase (Id 8)).

Definition TRcd_j  :=
  (TRCons j (TArrow B B) TRNil).     (* {j:B->B} *)
Definition TRcd_kj :=
  TRCons k (TArrow A A) TRcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (TArrow C TRcd_kj)
          (TArrow C TRNil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get
    full benefit from the exercises, make sure you also
    understand how to prove them on paper! *)

(** **** Exercise: 2 stars  *)
Hint Extern 2 (_ <> _) => intros contra; inversion contra.

Example subtyping_example_1 :
  subtype TRcd_kj TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  unfold TRcd_kj, TRcd_j.
  eapply S_Trans. apply S_RcdPerm...
  apply S_RcdDepth...
Qed.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_2 :
  subtype (TArrow TTop TRcd_kj)
          (TArrow (TArrow C C) TRcd_j).
(* Top->{k:A->A,j:B->B} <: (C->C)->{j:B->B} *)
Proof with eauto using subtyping_example_1.
  apply S_Arrow...
Qed.
(** [] *)

(** **** Exercise: 1 star  *)
Example subtyping_example_3 :
  subtype (TArrow TRNil (TRCons j A TRNil))
          (TArrow (TRCons k B TRNil) TRNil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  apply S_Arrow...
Qed.
(** [] *)

(** **** Exercise: 2 stars  *)
Example subtyping_example_4 :
  subtype (TRCons x A (TRCons y B (TRCons z C TRNil)))
          (TRCons z C (TRCons y B (TRCons x A TRNil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  apply S_Trans with (TRCons y B (TRCons x A (TRCons z C TRNil))).
  apply S_RcdPerm...
  apply S_Trans with (TRCons y B (TRCons z C (TRCons x A TRNil))).
  apply S_RcdDepth...
  apply S_RcdPerm...
Qed.
(** [] *)

Definition trcd_kj :=
  (trcons k (tabs z A (tvar z))
           (trcons j (tabs z B (tvar z))
                      trnil)).

End Examples.

(* ###################################################################### *)
(** ** Properties of Subtyping *)

(** *** Well-Formedness *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  subtype_cases (induction Hsub) Case;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  Case "S_RcdPerm".
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  T_cases (induction T) Case; intros; try solve by inversion.
  Case "TRCons".
    inversion H. subst. unfold Tlookup in H0.
    destruct (eq_id_dec i i0)...  inversion H0; subst...  Qed.

(** *** Field Lookup *)

(** Our record matching lemmas get a little more complicated in
    the presence of subtyping for two reasons: First, record
    types no longer necessarily describe the exact structure of
    corresponding terms.  Second, reasoning by induction on
    [has_type] derivations becomes harder in general, because
    [has_type] is no longer syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  subtype_cases (induction Hsub) Case; intros Ti Hget;
    try solve by inversion.
  Case "S_Refl".
    exists Ti...
  Case "S_Trans".
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  Case "S_RcdDepth".
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (eq_id_dec i k)...
    SCase "i = k -- we're looking up the first field".
      inversion Hget. subst. exists S1...
  Case "S_RcdPerm".
    exists Ti. split.
    SCase "lookup".
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (eq_id_dec i i1)...
      SSCase "i = i1 -- we're looking up the first field".
        destruct (eq_id_dec i i2)...
        SSSCase "i = i2 - -contradictory".
          destruct H0.
          subst...
    SCase "subtype".
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars (rcd_types_match_informal)  *)
(** Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(* ... *)
(** [] *)

(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, optional (sub_inversion_arrow)  *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (TArrow V1 V2) ->
     exists U1, exists U2,
       (U=(TArrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (TArrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  induction Hs; intros; try solve by inversion.
  subst. inversion H. exists V1. exists V2...
  apply IHHs2 in HeqV. destruct HeqV as [W1 [W2 [H1 [H2 H3]]]].
  apply IHHs1 in H1. destruct H1 as [X1 [X2 [H4 [H5 H6]]]].
  exists X1. exists X2...
  inversion HeqV; subst. exists S1. exists S2...
Qed.
(** [] *)

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

Definition context := id -> (option ty).
Definition empty : context := (fun _ => None).
Definition extend (Gamma : context) (x:id) (T : ty) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      has_type Gamma (tvar x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      has_type Gamma t1 (TArrow T1 T2) ->
      has_type Gamma t2 T1 ->
      has_type Gamma (tapp t1 t2) T2
  | T_Proj : forall Gamma i t T Ti,
      has_type Gamma t T ->
      Tlookup i T = Some Ti ->
      has_type Gamma (tproj t i) Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      has_type Gamma t S ->
      subtype S T ->
      has_type Gamma t T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      has_type Gamma trnil TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      has_type Gamma t T ->
      has_type Gamma tr Tr ->
      record_ty Tr ->
      record_tm tr ->
      has_type Gamma (trcons i t tr) (TRCons i T Tr)

where "Gamma '|-' t '\in' T" := (has_type Gamma t 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_Proj" | Case_aux c "T_Sub"
  | Case_aux c "T_RNil" | Case_aux c "T_RCons" ].

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

Module Examples2.
Import Examples.

Hint Extern 2 (has_type _ (trcons _ _ _) _) =>
  eapply T_RCons; auto.
Hint Extern 2 (has_type _ (tapp _ _) _) =>
  eapply T_App; auto.
Hint Extern 2 (has_type _ (tabs _ _ _) _) =>
  eapply T_Abs; auto.
Hint Extern 2 (has_type _ (tproj _ _) _) =>
  eapply T_Proj; auto.
Hint Extern 2 (_ = _) => compute; reflexivity.

(** **** Exercise: 1 star  *)
Example typing_example_0 :
  has_type empty
           (trcons k (tabs z A (tvar z))
                     (trcons j (tabs z B (tvar z))
                               trnil))
           TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof with eauto.
  unfold TRcd_kj, TRcd_j...
Qed.
(** [] *)

(** **** Exercise: 2 stars  *)
Example typing_example_1 :
  has_type empty
           (tapp (tabs x TRcd_j (tproj (tvar x) j))
                   (trcd_kj))
           (TArrow B B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j) {k=(\z:A.z), j=(\z:B.z)} : B->B *)
Proof with eauto using subtyping_example_1.
  unfold trcd_kj, TRcd_j...
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Example typing_example_2 :
  has_type empty
           (tapp (tabs z (TArrow (TArrow C C) TRcd_j)
                           (tproj (tapp (tvar z)
                                            (tabs x C (tvar x)))
                                    j))
                   (tabs z (TArrow C C) trcd_kj))
           (TArrow B B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto using subtyping_example_1.
  unfold trcd_kj, TRcd_j...
Qed.
(** [] *)

End Examples2.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  has_type_cases (induction Htyp) Case...
  Case "T_App".
    inversion IHHtyp1...
  Case "T_Proj".
    eapply wf_rcd_lookup...
  Case "T_Sub".
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  has_type_cases (induction Htyp) Case; intros; subst; try solve by inversion.
  Case "T_Sub".
    apply (rcd_types_match S) in H0... destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  Case "T_RCons".
    simpl in H0. simpl. simpl in H1.
    destruct (eq_id_dec i i0).
    SCase "i is first".
      inversion H1. subst. exists t...
    SCase "i in tail".
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval...  Qed.

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

(** **** Exercise: 3 stars (canonical_forms_of_arrow_types)  *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (TArrow T1 T2) ->
     value s ->
     exists x, exists S1, exists s2,
        s = tabs x S1 s2.
Proof with eauto.
  intros.
  remember (TArrow T1 T2) as ta.
  generalize dependent T1.
  generalize dependent T2.
  induction H; intros; subst; try solve by inversion.
  inversion Heqta; subst...
  apply sub_inversion_arrow in H1.
  destruct H1 as [U1 [U2 [H2 [H3 H4]]]]...
Qed.
(** [] *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  has_type_cases (induction Ht) Case;
    intros HeqGamma; subst...
  Case "T_Var".
    inversion H.
  Case "T_App".
    right.
    destruct IHHt1; subst...
    SCase "t1 is a value".
      destruct IHHt2; subst...
      SSCase "t2 is a value".
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      SSCase "t2 steps".
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    SCase "t1 steps".
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  Case "T_Proj".
    right. destruct IHHt...
    SCase "rcd is value".
      destruct (lookup_field_in_value t T i Ti) as [t' [Hget Ht']]...
    SCase "rcd_steps".
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  Case "T_RCons".
    destruct IHHt1...
    SCase "head is a value".
      destruct IHHt2...
      SSCase "tail steps".
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    SCase "head steps".
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)...  Qed.

(** Informal proof of progress:

    Theorem : For any term [t] and type [T], if [empty |- t : T]
      then [t] is a value or [t ==> t'] for some term [t'].

    Proof : Let [t] and [T] be given such that [empty |- t : T].  We go
      by induction on the typing derivation.  Cases [T_Abs] and
      [T_RNil] are immediate because abstractions and [{}] are always
      values.  Case [T_Var] is vacuous because variables cannot be
      typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that
        [t = t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and
        [empty |- t2 : T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.  We consider each case:

        - Suppose [t1 ==> t1'] for some term [t1'].  Then
          [t1 t2 ==> t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 ==> t2'] for some term [t2'].  Then
            [t1 t2 ==> t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for some
            [x], [S1], and [s2].  And [(\x:S1.s2) t2 ==> [x:=t2]s2] by
            [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        is a term [tr], type [Tr] and label [i] such that [t = tr.i],
        [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        The IH for the typing subderivation gives us that either [tr]
        is a value or it steps.  If [tr ==> tr'] for some term [tr'],
        then [tr.i ==> tr'.i] by rule [ST_Proj1].

        Otherwise, [tr] is a value.  In this case, lemma
        [lookup_field_in_value] yields that there is a term [ti] such
        that [tlookup i tr = Some ti].  It follows that [tr.i ==> ti]
        by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then there
        exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
        that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm tr],
        [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 ==> t1'] for some term [t1'].  Then
          [{i=t1, tr} ==> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr ==> tr'] for some term [tr'].  Then
            [{i=t1, tr} ==> {i=t1, tr'}] by rule [ST_Rcd_Tail],
            since [t1] is a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ########################################## *)
(** *** Inversion Lemmas *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (tvar x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (tvar x) as t.
  has_type_cases (induction Hty) Case; intros;
    inversion Heqt; subst; try solve by inversion.
  Case "T_Var".
    exists T...
  Case "T_Sub".
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (tapp t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (TArrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (tapp t1 t2) as t.
  has_type_cases (induction Hty) Case; intros;
    inversion Heqt; subst; try solve by inversion.
  Case "T_App".
    exists T1...
  Case "T_Sub".
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1...  Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (tabs x S1 t2) T ->
     (exists S2, subtype (TArrow S1 S2) T
              /\ has_type (extend Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (tabs x S1 t2) as t.
  has_type_cases (induction H) Case;
    inversion Heqt; subst; intros; try solve by inversion.
  Case "T_Abs".
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  Case "T_Sub".
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (tproj t1 i) Ti ->
  exists T, exists Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (tproj t1 i) as t.
  has_type_cases (induction H) Case;
    inversion Heqt; subst; intros; try solve by inversion.
  Case "T_Proj".
    assert (well_formed_ty Ti) as Hwf.
      SCase "pf of assertion".
        apply (wf_rcd_lookup i T Ti)...
        apply has_type__wf in H...
    exists T. exists Ti...
  Case "T_Sub".
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U. exists Ui...  Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (trcons i ti tr) T ->
  exists Si, exists Sr,
    subtype (TRCons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (trcons i ti tr) as t.
  has_type_cases (induction Hty) Case;
    inversion Heqt; subst...
  Case "T_Sub".
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri. exists Rr...
  Case "T_RCons".
    assert (well_formed_ty (TRCons i T Tr)) as Hwf.
      SCase "pf of assertion".
        apply has_type__wf in Hty1.
        apply has_type__wf in Hty2...
    exists T. exists Tr...  Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (tabs x S1 s2) (TArrow T1 T2) ->
     subtype T1 S1
  /\ has_type (extend empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ########################################## *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (tproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (trcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i t tr).

Hint Constructors appears_free_in.

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 x0 Hafi.
    unfold extend. destruct (eq_id_dec x x0)...
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; subst; inversion Hafi; subst...
  Case "T_Abs".
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold extend in Hctx. rewrite neq_id in Hctx...  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 ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  t_cases (induction t) Case; intros; simpl.
  Case "tvar".
    rename i into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold extend in Hctx.
    destruct (eq_id_dec x y)...
    SCase "x=y".
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      destruct (subtype__wf _ _ Hsub)...
  Case "tapp".
    destruct (typing_inversion_app _ _ _ _ Htypt) as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  Case "tabs".
    rename i into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (TArrow T1 T2)... apply T_Abs...
    destruct (eq_id_dec x y).
    SCase "x=y".
      eapply context_invariance...
      subst.
      intros x Hafi. unfold extend.
      destruct (eq_id_dec y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      destruct (eq_id_dec y z)...
      subst.  rewrite neq_id...
  Case "tproj".
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  Case "trnil".
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  Case "trcons".
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (TRCons i Ti Tr)...
    apply T_RCons...
    SCase "record_ty Tr".
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    SCase "record_tm ([x:=v]t2)".
      inversion Hrcdt2; subst; simpl...  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.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  has_type_cases (induction HT) Case;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  Case "T_App".
    inversion HE; subst...
    SCase "ST_AppAbs".
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
  Case "T_Proj".
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  Case "T_RCons".
    eauto using step_preserves_record_tm.  Qed.

(** Informal proof of [preservation]:

    Theorem: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t ==> t'], then [empty |- t' : T].

    Proof: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and {} don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr ==> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr.i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_tm tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

(* ###################################################### *)
(** ** Exercises on Typing *)

(** **** Exercise: 2 stars, optional (variations)  *)
(** Each part of this problem suggests a different way of
    changing the definition of the STLC with records and
    subtyping.  (These changes are not cumulative: each part
    starts from the original language.)  In each part, list which
    properties (Progress, Preservation, both, or neither) become
    false.  If a property becomes false, give a counterexample.
    - Suppose we add the following typing rule:
                            Gamma |- t : S1->S2
                    S1 <: T1      T1 <: S1     S2 <: T2
                    -----------------------------------              (T_Funny1)
                            Gamma |- t : T1->T2
neither
    - Suppose we add the following reduction rule:
                             ------------------                     (ST_Funny21)
                             {} ==> (\x:Top. x)
Preservation, TRNil ==> TArrow TTop TTop
    - Suppose we add the following subtyping rule:
                               --------------                        (S_Funny3)
                               {} <: Top->Top
Progress, tapp trnil trnil
    - Suppose we add the following subtyping rule:
                               --------------                        (S_Funny4)
                               Top->Top <: {}
Progress, tproj (tabs x TTop (tvar x)) x
    - Suppose we add the following evaluation rule:
                             -----------------                      (ST_Funny5)
                             ({} t) ==> (t {})
neither
    - Suppose we add the same evaluation rule *and* a new typing rule:
                             -----------------                      (ST_Funny5)
                             ({} t) ==> (t {})

                           ----------------------                    (T_Funny6)
                           empty |- {} : Top->Top
neither
    - Suppose we *change* the arrow subtyping rule to:
                          S1 <: T1       S2 <: T2
                          -----------------------                    (S_Arrow')
                               S1->S2 <: T1->T2
Preservation, (\x:Person -> Nat. (x A_person)) \x:Student. x.gpa ==>
   (\x:Student. x.gpa) A_person
(** [] *)

*)

(** $Date: 2014-12-31 11:17:56 -0500 (Wed, 31 Dec 2014) $ *)


Require Import Coq.Strings.String.
Open Scope nat_scope.
Open Scope list_scope.

(************************************************************************)
(* Copyright 2018 Nilson de Lima, Walber de Macedo, Orlando Neto        *)
(* MIT License                                                          *)
(************************************************************************)

(* As funções e provas já estão em ordem de execução*)

(* Uma lista de prioridade (priqueue), é um tipo de dados que visa simplificar as operações de junção de duas ávores ordenadas. Essa priq é uma lista de árvores que deve obedecer os requisitos:

    1- A lista não deve ter seus elementos com tamanho igual. Cada posição da lista corresponde a uma altura diferente de uma árvore.

    2- As árvores precisam ser uma power of 2 heap (pow2heap). Essa power of 2 heap é apenas uma árvore ordenada como max heap e sua raiz tem seu filho a direita uma árvore vazia, e seu filho a esquerda uma árvore completa. Isso faz com que as árvores tenham uma altura máxima de n. Olhando para a priqueue, temos que para cada índice da lista é o numero n da árvore: a posição 0 da arvore deve ter uma árvore de altura 0 e assim por diante.

   Essa definição facilita a inserção e junção de duas priqueue, fazendo com que a junção seja reduzida a junção de árvores binárias, resultando em um algoritmo parecido com uma soma binária, onde caso uma posição da lista exceda o seu valor máximo de elementos, toda essa árvore seja passada para a próxima posição e tente ser encaixada nessa nova árvore.
*)

(* Representação simplificada de a maior que ou igual a b para ser usada *)

Notation "a >? b" := (Nat.ltb b a)
                     (at level 70, only parsing) : nat_scope.

Definition key := nat.

(* Uma árvore é definida como para uma chave, existem duas subárvores onde uma folha não
   possui chave nem subárvores *)

Inductive tree : Type :=
| Node: key -> tree -> tree -> tree
| Leaf : tree.

Definition priqueue := list tree.

Definition empty : priqueue := nil.

(* Um smash representa a junção de duas árvores, fazendo sempre a ordenação ser preservada *)

Definition smash (t u: tree) : tree :=
  match t , u with
  | Node x t1 Leaf, Node y u1 Leaf =>
                   if x >? y then Node x (Node y u1 t1) Leaf
                                else Node y (Node x t1 u1) Leaf
  | _ , _ => Leaf
  end.

(* Carry é a fase em que uma árvore não pode ficar mais em sua posição atual por ter excedido o tamanho máximo, então ela é passada para a próxima posição sendo somada à próxima árvore. Isso é feito recursivamente até que a árvore resultante tenha tamanho suficiente para ser acomodada naquela posição. *)

Fixpoint carry (q: list tree) (t: tree) : list tree :=
  match q, t with
  | nil, Leaf => nil
  | nil, _ => t :: nil
  | Leaf :: q', _ => t :: q'
  | u :: q', Leaf => u :: q'
  | u :: q', _ => Leaf :: carry q' (smash t u)
 end.

(* Um insert é apenas uma inserção em uma priqueue, o novo numero é colocado na primeira árvore e é visto
   se a árvore resultante pode ser encaixada nessa posição, utilizando o carry. *)

Definition insert (x: key) (q: priqueue) : priqueue :=
     carry q (Node x Leaf Leaf).

(* Find max retorna o valor máximo em uma priqueue. *)

Fixpoint find_max' (current: key) (q: priqueue) : key :=
  match q with
  | nil => current
  | Leaf :: q' => find_max' current q'
  | Node y _ _ :: q' => find_max' (if current >? y then current else y) q'
  end.

Fixpoint find_max (q: priqueue) : option key :=
  match q with
  | nil => None
  | Leaf :: q' => find_max q'
  | Node x _ _ :: q' => Some (find_max' x q')
  end.

Compute (find_max (Node 1 Leaf Leaf
       :: Node 3 (Node 1 Leaf Leaf) Leaf
          :: Node 5 (Node 3 (Node 2 Leaf Leaf) (Node 2 Leaf Leaf)) Leaf
             :: Node 9
                  (Node 4 (Node 3 (Node 1 Leaf Leaf) (Node 1 Leaf Leaf))
                     (Node 3 (Node 2 Leaf Leaf) (Node 5 Leaf Leaf))) Leaf
                :: nil)).

(*
  Join adiciona uma árvore numa junção de duas priority queues.
  Tal procedimento 'simula' uma soma binária entre essas filas e uma árvore
  podendo resultar numa nova priority queue de tamanho N + 1
*)

Fixpoint join (p q: priqueue) (t: tree) : priqueue :=
  match p, q, t with
  | nil, _, _ => carry q t
  | _, nil, _ => carry p t
  | Leaf :: p', Leaf :: q', _ => t :: join p' q' Leaf
  | Leaf :: p', q1 :: q', Leaf => q1 :: join p' q' Leaf
  | Leaf :: p', q1 :: q', Node _ _ _ => Leaf :: join p' q' (smash t q1)
  | p1 :: p', Leaf :: q', Leaf => p1 :: join p' q' Leaf
  | p1 :: p', Leaf :: q', Node _ _ _ => Leaf :: join p' q' (smash t p1)
  | p1 :: p', q1 :: q', _ => t :: join p' q' (smash p1 q1)
  end.

(* Para facilitar a utilização do join, é criada uma função auxiliar chamada merge. *)

Definition merge (p q: priqueue) := join p q Leaf.

(* Essa função diz se uma árvore é uma pow2heap, ela verifica se o nó raiz tem uma subárvore vazia a direita e se possui uma subárvore completa a esquerda. *)

Fixpoint pow2heap' (n: nat) (m: key) (t: tree) :=
 match n, m, t with
    0, m, Leaf => True
  | 0, m, Node _ _ _=> False
  | S _, m,Leaf => False
  | S n', m, Node k l r =>
       (m >= k) /\ pow2heap' n' k l /\ pow2heap' n' m r
 end.

Definition pow2heap (n: nat) (t: tree) :=
  match t with
  | Node m t1 Leaf => pow2heap' n m t1
  | _ => False
  end.

(* Para saber se realmente uma lista de árvores é uma priqueue, temos que garantir que cada árvore seja uma pow2heap de tamanho único, assim a cada nova árvore avaliada na lista, o tamanho é incrementado e verificado se é uma pow2heap daquele tamanho. *)

Fixpoint priq' (i: nat) (l: list tree) : Prop :=
   match l with
  | t :: l'=> (t = Leaf \/ pow2heap i t) /\ priq' (S i) l'
  | nil => True
 end.

Definition priq (q: priqueue) : Prop := priq' 0 q.

(* A prova de uma priqueue vazia é trivial, já que foi definida que uma lista vazia é uma priqueue. *)

Theorem empty_priq : priq empty.
Proof. reflexivity. Qed.

(* Para provar que uma junção de duas pow2heap de tamanho n é valida, é necessário checar se a junção das duas leva a uma pow2heap de tamanho n+1. Isso é feito tomando os casos base de cada árvore e checando se de fato a propriedade da max heap é satisfeita. *)

Theorem smash_valid : forall (n: nat) (t: tree) (u: tree),
  pow2heap n t -> pow2heap n u -> pow2heap (S n) (smash t u).
Proof.
  intros. destruct t, u.
    - destruct t2, u2.
      + simpl in H. inversion H.
      + simpl in H. inversion H.
      + simpl in H0. inversion H0.
      + unfold smash. destruct (Nat.ltb k0 k) as []eqn:?.
        * simpl. intuition. Search (_ >= _).
          apply Compare_dec.not_lt. Search (~ _ < _).
          apply PeanoNat.Nat.lt_asymm. apply PeanoNat.Nat.ltb_lt. apply Heqb.
        * simpl. intuition. apply Compare_dec.not_lt.
          apply PeanoNat.Nat.ltb_nlt. apply Heqb.
   - inversion H0.
   - inversion H.
   - inversion H.
Qed.

(* Um carry é valido para toda a priqueue q de tamanho n, para uma árvore t sendo pow2heap ou uma árvore vazia, o resultado do carry é uma priqueue de tamanho n. Isso é feito aplicando uma indução em q e sempre reduzindo t para casos conhecidos, tudo feito sem necessariamente saber, induzir ou destruir o tamanho (n) das priqueues. *)

Theorem carry_valid : forall (n: nat) (q: priqueue),
  priq' n q -> forall (t: tree), (t = Leaf \/ pow2heap n t) ->
  priq' n (carry q t).
Proof.
  intros n q. revert n. induction q.
    - intros. destruct t.
      + unfold carry. simpl. split.
        * apply H0.
        * reflexivity.
      + simpl. reflexivity.
    - intros. destruct a, t.
      + unfold carry. fold carry. unfold priq'. split.
        * left. reflexivity.
        * fold priq'. apply IHq.
          { inversion H. apply H2. }
          { right. apply smash_valid.
            { intuition.
              { inversion H1. } }
            { inversion H. inversion H1.
              { inversion H3. }
              { apply H3. } } }
      + unfold carry. apply H.
      + unfold carry. simpl. split.
        * apply H0.
        * inversion H. apply H2.
      + simpl. split.
        * left. reflexivity.
        * inversion H. apply H2.
Qed.

(* Ao fazer uma inserção de um natural em uma priqueue q, ela deve continuar sendo uma priqueue. A prova deve ser feita utilizando o caso base de uma priqueue vazia, e ao ser feita a inserção numa árvore, pode ser utilizada a prova carry_valid. *)

Theorem insert_priq : forall (x: nat) (q: priqueue),
  priq q -> priq (insert x q).
Proof.
  intros. destruct q.
  - unfold priq. simpl. split.
    + right. apply I.
    + apply I.
  - inversion H. unfold insert. apply carry_valid.
    + simpl. split.
      * apply H0.
      * apply H1.
    + simpl. intuition.
Qed.

(*
  O seguinte teorema diz que se duas priqueues de ordem 'n' e uma árvore (heap de potência de dois)
  são unidas por 'join', então essa junção também é uma priqueue de ordem 'n'.
  A prova desse teorema é longa, porém cada passo é razoalvemente factivel.
  O 'truque' que destrava a prova em alguns pontos é criar uma hipótese indutiva genérica o suficiente
  para casar padrão com todas as variáveis. O procedimento de prova utiliza as provas de carry_valid e smash_valid
  provadas previamente.
*)

Theorem join_valid: forall (p: priqueue) (q: priqueue) (n: nat) (c: tree),
  priq' n p -> priq' n q -> (c = Leaf \/ pow2heap n c) -> priq' n (join p q c).
Proof.
  induction p.
    - intros. destruct q, c.
      + simpl. split.
        * apply H1.
        * apply I.
      + simpl. apply I.
      + unfold join. apply carry_valid.
        * apply H0.
        * apply H1.
      + unfold join. apply carry_valid.
        * apply H0.
        * apply H1.
    - intros. destruct a, q, c.
      + unfold join. apply carry_valid.
        * apply H.
        * apply H1.
      + unfold join. unfold carry. apply H.
      + unfold join. fold join. destruct t.
        * unfold priq'. split.
          { apply H1. }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { right. apply smash_valid.
              { inversion H. inversion H2.
                { inversion H4. }
                { apply H4. } }
              { inversion H0. inversion H2.
                { inversion H4. }
                { apply H4. } } } }
        * unfold priq'. split.
          { left. reflexivity. }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { right. apply smash_valid.
              { inversion H1.
                { inversion H2. }
                { apply H2. } }
              { inversion H. inversion H2.
                { inversion H4. }
                { apply H4. } } } }
     + destruct t.
        * unfold join. fold join. unfold priq'. split.
          { apply H1. }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { right. apply smash_valid.
              { inversion H. inversion H2.
                { inversion H4. }
                { apply H4. } }
              { inversion H0. inversion H2.
                { inversion H4. }
                { apply H4. } } } }
        * unfold join. fold join. unfold priq'. split.
          { right. inversion H. inversion H2.
            { inversion H4. }
            { apply H4. } }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { left. reflexivity. } }
    + unfold join. unfold carry. simpl. split.
      * apply H1.
      * inversion H. apply H3.
    + simpl. split.
      * left. reflexivity.
      * inversion H. apply H3.
    + destruct t.
        * unfold join. fold join. unfold priq'. split.
          { left. reflexivity. }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { right. apply smash_valid.
              { inversion H. inversion H2.
                { inversion H4. inversion H1.
                  { inversion H5. }
                  { apply H5. } }
                { inversion H0. inversion H2.
                { inversion H4. }
                { inversion H4. } } }
            { inversion H0.
              { inversion H2.
                { inversion H4. }
                { apply H4. } } } } }
        * unfold join. fold join. unfold priq'. split.
          { apply H1. }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { left. reflexivity. } }
    + destruct t.
        * unfold join. fold join. unfold priq'. split.
          { right. inversion H0. inversion H2.
             { inversion H4. }
              { apply H4. } }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { left. reflexivity. } }
        * unfold join. fold join. unfold priq'. split.
          { left. reflexivity. }
          { fold priq'. apply IHp.
            { inversion H. apply H3. }
            { inversion H0. apply H3. }
            { left. reflexivity. } }
Qed.

(* Ao fazer um merge entre duas priqueue, o resultado deve ser uma priqueue. Isso é facilmente feito utilizando a prova para o join, já que merge é definido em a partir do join. *)

Theorem merge_priq: forall (p: priqueue) (q: priqueue),
  priq p -> priq q -> priq (merge p q).
Proof.
  intros. unfold merge. apply join_valid; auto.
Qed.


(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.
Require Import PRF.
Require Import RndInList.

Local Open Scope list_scope.

Inductive in_oc_supp : forall (A B C : Set), C -> OracleComp A B C -> Prop :=
| in_oc_supp_Bind :
    forall (A B C C' : Set)(c : OracleComp A B C')(f : C' -> OracleComp A B C) x y,
      in_oc_supp x c ->
      in_oc_supp y (f x) ->
      in_oc_supp y (OC_Bind c f)
| in_oc_supp_Query :
    forall (A B : Set)(a : A)(b : B),
      in_oc_supp b (OC_Query B a)
| in_oc_supp_Ret :
  forall (A B C : Set)(c : Comp C) x,
    In x (getSupport c) ->
    in_oc_supp x (OC_Ret A B c)
| in_oc_supp_Run :
  forall (A A' B B' C S : Set)(eqds : EqDec S)(eqda : EqDec A)(eqdb : EqDec B)
    (c : OracleComp A B C)(oc : S -> A -> OracleComp A' B' (B * S)) s x s',
    in_oc_supp x c ->
    in_oc_supp (x, s') (OC_Run _ _ _ c oc s).

Theorem in_oc_supp_complete :
  forall (A B C : Set){eqdc : EqDec C}(c : OracleComp A B C) x
    (S : Set)(eqds : EqDec S)(o : S -> A -> Comp (B * S))(s : S) s',
    In (x, s') (getSupport (c _ _ o s)) ->
    in_oc_supp x c .

  induction c; intuition; repeat simp_in_support.
  econstructor.

  Local Opaque getSupport.
  simpl in *.
  repeat simp_in_support.
  destruct x.
  simpl.
  destruct p.
  simpl.

  econstructor.
  eapply (@IHc _ _ (S * S0)%type).
  eapply H1.

  simpl in *.
  repeat simp_in_support.
  econstructor.
  intuition.

  assert (EqDec C).
  eapply oc_EqDec.
  eapply c.
  intuition.
  assert (B * S).
  eapply comp_base_exists.
  eapply o0.
  trivial.
  intuition.
  intuition.
  intuition.
  assert (EqDec (B * S)).
  eapply comp_EqDec.
  eapply o0; trivial.
  eapply EqDec_pair_l.
  eapply H2.
  trivial.

  simpl in *.
  repeat simp_in_support.
  destruct x0.
  econstructor.
  eapply (@H0 _ S).
  eapply H2.
  eapply (@H _ _ _ S).
  eapply H3.

  Grab Existential Variables.
  eapply EqDec_pair_l.
  eauto.
  trivial.

Qed.

Local Open Scope nat_scope.

Inductive queries_at_most' : forall (A B C : Set), OracleComp A B C -> nat -> Prop :=
| qam_Bind :
  forall (A B C C' : Set)(eqdc' : EqDec C')(c : OracleComp A B C')(f : C' -> OracleComp A B C) q1 q2,
    queries_at_most' c q1 ->
    (forall c',
       in_oc_supp c' c ->
       queries_at_most' (f c') q2) ->
    queries_at_most' (OC_Bind c f) (q1 + q2)
| qam_Query :
  forall (A B : Set)(a : A),
  queries_at_most' (OC_Query B a) 1
| qam_Ret :
  forall (A B C : Set)(c : Comp C),
    queries_at_most' (OC_Ret A B c) 0
| qam_Run :
  forall (A A' B B' C S : Set)(eqds : EqDec S)(eqda : EqDec A)(eqdb : EqDec B)
    (c : OracleComp A B C)(oc : S -> A -> OracleComp A' B' (B * S)) s q1 q2,
    queries_at_most' c q1 ->
    (forall s a, queries_at_most' (oc s a) q2) ->
    queries_at_most' (OC_Run _ _ _ c oc s) (q1 * q2)
| qam_le :
  forall (A B C : Set)(c : OracleComp A B C) q1 q2,
    queries_at_most' c q1 ->
    q1 <= q2 ->
    queries_at_most' c q2.

Theorem qam_count_gen' :
  forall (A B C : Set)(c : OracleComp A B C)(q : nat),
    queries_at_most' c q ->
    forall (S : Set)(count : S -> nat)(eqds : EqDec S)(o : S -> A -> Comp (B * S))(s : S)(n : nat),
      (forall a b x y,
        In (a, b) (getSupport (o x y)) ->
          count b <= n + (count x)) ->
      forall a b,
      In (a, b) (getSupport (c _ _ o s)) ->
      count b <= q * n + (count s).

  Opaque getSupport.
  induction 1; intuition; simpl in *.

  (* Bind case *)
  repeat simp_in_support.
  destruct x.
  rewrite mult_plus_distr_r.
  pose proof H4.
  eapply (IHqueries_at_most' _ count) in H4.
  eapply (H1 _ _ _ count) in H5.
  rewrite H5.
  rewrite plus_comm.
  rewrite <- (plus_assoc).
  rewrite (plus_comm (q2 * n)).
  rewrite plus_assoc.
  eapply plus_le_compat.
  eauto.
  eapply le_refl.
  intuition.
  intuition.

  (* query case *)
  rewrite plus_0_r.
  eapply H; eauto.

  (* ret case *)
  Transparent getSupport.
  repeat simp_in_support.
  intuition.

  (* run case *)
  repeat simp_in_support.

  destruct x.
  simpl in *.

  specialize (IHqueries_at_most' (S * S0)%type (fun p =>  count (snd p)) _
  (fun (x : S * S0) (y : A) =>
                p <-$ (oc (fst x) y) S0 eqds0 o (snd x);
                ret (fst (fst p), (snd (fst p), snd p)))
  (s, s0) (q2 * n)
  ).

  eapply le_trans.
  eapply IHqueries_at_most'.
  intuition.
  simpl.
  repeat simp_in_support.
  destruct x.
  simpl in *.
  eapply H1.
  eauto.
  eauto.
  eauto.
  simpl.
  rewrite mult_assoc.
  intuition.

  (* trans case *)
  eapply le_trans.
  eapply IHqueries_at_most'.
  eauto.
  eauto.
  eapply plus_le_compat; intuition.
  eapply mult_le_compat; intuition.

  Grab Existential Variables.
  eapply in_oc_supp_complete; eauto.

Qed.

(*
Definition countOracle{A B State : Set}{eqdb : EqDec B}{eqds : EqDec State}(defB : B)(o : State -> A -> Comp (B * State)) p a :=
  [s, n] <-2 p;
  match n with
    | 0 => ret (defB, p)
    | S n' =>
      [b', s'] <-$2 o s a;
        ret (b', (s', n'))
  end.

Theorem countOracle_equiv :
  forall (A B C : Set)(defB : B)(eqdb : EqDec B)(eqdc : EqDec C)(c : OracleComp A B C) n,
    queries_at_most' c n ->
    forall (S : Set)(eqd : EqDec S)(o : S -> A -> Comp (B * S))(s : S),
      comp_spec
        (fun a b => fst a = fst b /\ snd a = fst (snd b))
        (c _ _ o s)
        (c _ _ (countOracle defB o) (s, n)).

  induction 1; intuition; simpl in *.

  admit.
  admit.
  admit.

  comp_skip.
  admit.
  admit.
  assert (EqDec C).
  eapply EqDec_pair_l.
  eauto.
  trivial.

  assert (B * S).
  eapply oc_base_exists.
  eapply oc

  specialize (@IHqueries_at_most' eqdb0 H2 defB (S * S0)%type).
  eapply H1.
  eapply oc_comp_spec_eq.

Qed.

*)

Local Open Scope rat_scope.

Theorem evalDist_bind_event_le :
  forall (A : Set)(c : Comp A)(f : A -> Comp bool)(evta : A -> bool) (k1 k2 : Rat),
    Pr[a <-$ c; ret (evta a)] <= k1 ->
    (forall a, In a (getSupport c) -> evta a = false -> Pr[f a] <= k2) ->
    Pr[a <-$ c; f a] <= k1 + k2.

  intuition.
  simpl in *.
  rewrite (sumList_partition evta).

  eapply ratAdd_leRat_compat.
  assert ( sumList (getSupport c)
     (fun a : A => evalDist c a * Pr  [f a ] * (if evta a then 1 else 0)) <=
            sumList (getSupport c)
        (fun b : A =>
         evalDist c b * (if EqDec_dec bool_EqDec (evta b) true then 1 else 0)) ).

  eapply sumList_le; intuition.
  destruct (EqDec_dec bool_EqDec (evta a) true ).
  rewrite e.

  eapply ratMult_leRat_compat; intuition.
  eapply leRat_trans.
  eapply ratMult_leRat_compat.
  eapply leRat_refl.
  eapply evalDist_le_1.
  rewrite ratMult_1_r.
  intuition.

  destruct (evta a); intuition.
  repeat rewrite ratMult_0_r.
  eapply rat0_le_all.
  rewrite H1.
  eapply H.

  assert ( sumList (getSupport c)
     (fun a : A => evalDist c a * Pr  [f a ] * (if evta a then 0 else 1)) <=
            sumList (getSupport c)
     (fun a : A => k2 * (evalDist c a * (if evta a then 0 else 1)))).

  eapply sumList_le.
  intuition.
  case_eq (evta a); intuition.
  eapply eqRat_impl_leRat.
  repeat rewrite ratMult_0_r.
  intuition.
  rewrite H0.
  eapply eqRat_impl_leRat.
  repeat rewrite ratMult_1_r.
  eapply ratMult_comm.
  trivial.
  trivial.

  rewrite H1.
  rewrite sumList_factor_constant_l.

  eapply leRat_trans.
  2:{
    eapply eqRat_impl_leRat.
    eapply ratMult_1_r.
  }
  eapply ratMult_leRat_compat; intuition.

  assert (sumList (getSupport c)
     (fun a : A => evalDist c a * (if evta a then 0 else 1)) <=
          sumList (getSupport c)
     (fun a : A => evalDist c a)).

  eapply sumList_le.
  intuition.
  eapply leRat_trans.
  2:{
    eapply eqRat_impl_leRat.
    eapply ratMult_1_r.
  }
  eapply ratMult_leRat_compat; intuition.
  destruct (evta a); intuition.
  eapply rat0_le_all.
  rewrite H2.
  eapply evalDist_sum_le_1.
Qed.

Theorem oc_eventProb :
  forall (A B C : Set)(c : OracleComp A B C) n,
    queries_at_most' c n ->
    forall
    (S : Set)(eqds : EqDec S)(o : S -> A -> Comp (B * S))
    (count : S -> nat)(evt : S -> bool)(s : S)(k : nat -> Rat) i,
      (forall (n1 n2 : nat), (n1 <= n2)%nat -> (k n1 <= k n2)) ->
      evt s = false ->
      (forall s a, evt s = false -> Pr[p <-$ o s a; ret (evt (snd p))] <= (k (i + (count s))%nat)) ->
      (forall s s' a b, In (b, s') (getSupport (o s a)) ->
                        count s' <= i + (count s))%nat ->
      Pr[p <-$ c _ _ o s; ret (evt (snd p))] <= (n / 1) * (k (i * n + (count s))%nat).

  Local Opaque evalDist.

  induction 1; intuition; simpl in *.
  inline_first.

  assert (
       Pr
   [a <-$ c S eqds o s;
    p <-$ ([z, s']<-2 a; (f z) S eqds o s'); ret evt (snd p) ] <=
   q1 / 1 * k (i * q1 + count s)%nat +
   q2 / 1 * k (i * q2 + (i * q1 + count s))%nat
                     ).

  eapply evalDist_bind_event_le.
  eapply (@IHqueries_at_most' _ _ _ count evt); intuition.
  intros.
  comp_simp.
  eapply leRat_trans.
  eapply (@H1 _ _ _ _ _ count evt).
  eapply H2.
  trivial.
  intuition.
  intuition.
  eapply ratMult_leRat_compat; intuition.
  eapply H2.
  eapply plus_le_compat; intuition.

  Require Import RndInList.
  eapply le_trans.
  eapply (qam_count_gen' _ _ _ _ _ i).
  intuition.
  eapply H5.
  eauto.
  eauto.
  rewrite mult_comm.
  intuition.

  rewrite H6.
  clear H6.

  eapply leRat_trans.
  2:{
    eapply eqRat_impl_leRat.
    symmetry.
    rewrite ratAdd_num.
    eapply ratMult_distrib_r.
  }
  eapply ratAdd_leRat_compat;
  eapply ratMult_leRat_compat.
  reflexivity.
  intuition.
  reflexivity.
  eapply H2.
  rewrite mult_plus_distr_l.
  rewrite plus_comm.
  repeat rewrite <- plus_assoc.
  eapply plus_le_compat; intuition.

  rewrite H1; intuition.
  rewrite <- ratMult_1_l.
  eapply ratMult_leRat_compat; intuition.
  eapply leRat_terms; intuition.

  inline_first.
  eapply distro_irr_le.
  intuition.
  comp_simp.
  simpl.
  rewrite H0.
  rewrite evalDist_ret_0.
  eapply rat0_le_all.
  congruence.

  inline_first.

  assert (EqDec C).
  eapply oc_EqDec; intros.
  eapply c.
  assert (B * S).
  eapply oc_base_exists.
  eapply oc.
  trivial.
  trivial.
  intuition.
  assert (B' * S0).
  eapply comp_base_exists.
  eapply o.
  trivial.
  trivial.
  intuition.
  intuition.
  trivial.

  assert
    (
      (evalDist
        (Bind
           (c (prod S S0) (pair_EqDec eqds eqds0)
              (fun (x : prod S S0) (y : A) =>
               Bind ((oc (fst x) y) S0 eqds0 o (snd x))
                 (fun p : prod (prod B S) S0 =>
                  Ret (EqDec_dec (pair_EqDec eqdb (pair_EqDec eqds eqds0)))
                    (pair (fst (fst p)) (pair (snd (fst p)) (snd p)))))
              (pair s s0))
           (fun a : prod C (prod S S0) =>
            Bind
              (Ret
                 (EqDec_dec
                    (pair_EqDec
                       (pair_EqDec
                          (oc_EqDec c
                             (fun x : A =>
                              fst
                                (oc_base_exists (oc s x)
                                   (fun y : A' =>
                                    fst (comp_base_exists (o s0 y)))))
                             (fun x : A =>
                              EqDec_pair_l
                                (oc_EqDec (oc s x)
                                   (fun y : A' =>
                                    fst (comp_base_exists (o s0 y)))
                                   (fun y : A' =>
                                    EqDec_pair_l (comp_EqDec (o s0 y)) s0)) s))
                          eqds) eqds0))
                 (pair (pair (fst a) (fst (snd a))) (snd (snd a))))
              (fun p : prod (prod C S) S0 =>
               Ret (EqDec_dec bool_EqDec) (evt (snd p))))) true)
   ==
   Pr
   [a <-$
    c (S * S0)%type (pair_EqDec eqds eqds0)
      (fun (x : S * S0) (y : A) =>
       p <-$ (oc (fst x) y) S0 eqds0 o (snd x);
       ret (fst (fst p), (snd (fst p), snd p))) (s, s0);
     ret (evt (snd (snd a))) ]
   ).

  comp_skip.
  simpl.
  intuition.
  rewrite H7.
  clear H7.

  eapply leRat_trans.
  eapply (@IHqueries_at_most' _ _
                             ((fun (x : S * S0) (y : A) =>
       p <-$ (oc (fst x) y) S0 eqds0 o (snd x);
       ret (fst (fst p), (snd (fst p), snd p))))
                             (fun p => count (snd p)) (fun p => evt (snd p))
         _ (fun x => q2 / 1 * k (x)%nat) (i * q2)%nat).
  intuition.
  eapply ratMult_leRat_compat; intuition.
  trivial.
  intuition.

  comp_inline_l.
  assert (
      Pr
   [a1 <-$ (oc (fst (a, b)) a0) S0 eqds0 o (snd (a, b));
    p <-$ ret (fst (fst a1), (snd (fst a1), snd a1)); ret evt (snd (snd p)) ]
   ==
   Pr
   [a1 <-$ (oc (fst (a, b)) a0) S0 eqds0 o (snd (a, b));
    ret evt (snd a1) ]
   ).

  comp_skip.
  simpl.
  intuition.
  rewrite H8.
  clear H8.
  simpl.
  eapply leRat_trans.

  eapply (@H1 ); intuition.
  reflexivity.
  intuition.
  repeat simp_in_support.
  destruct x.
  simpl in *.
  rewrite mult_comm.
  eapply qam_count_gen'.
  eapply H0.
  intuition.
  eapply H5.
  eapply H7.
  eapply H8.
  simpl.
  rewrite <- ratMult_assoc.
  eapply ratMult_leRat_compat.
  eapply eqRat_impl_leRat.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms; intuition.
  eapply H2.
  eapply plus_le_compat. 2: reflexivity.
  rewrite <- mult_assoc.
  eapply mult_le_compat. reflexivity.
  rewrite mult_comm.
  reflexivity.

  rewrite IHqueries_at_most'.
  eapply ratMult_leRat_compat; intuition.
  eapply leRat_terms; intuition.
  intuition.
  trivial.
  intuition.
  intuition.

  Grab Existential Variables.
  trivial.
  eapply in_oc_supp_complete; eauto.

Qed.

Theorem oc_eventProb_0_1 :
  forall (S : Set)(count : S -> nat)(evt : S -> bool)(k : nat -> Rat)
         (A B C : Set)(c : OracleComp A B C) n,
    queries_at_most' c n ->
    forall
    (eqds : EqDec S)(o : S -> A -> Comp (B * S))
    (s : S),
      (forall (n1 n2 : nat), (n1 <= n2)%nat -> (k n1 <= k n2)) ->
      evt s = false ->
      (forall s a, evt s = false -> Pr[p <-$ o s a; ret (evt (snd p))] <= (k (1 + (count s))%nat)) ->
      (forall s s' a b, In (b, s') (getSupport (o s a)) ->
                        count s' <= 1 + (count s))%nat ->
      count s = 0%nat ->
      Pr[p <-$ c _ _ o s; ret (evt (snd p))] <= (n / 1) * (k n).

  intuition.
  eapply leRat_trans.
  eapply oc_eventProb; intuition.
  eauto.
  rewrite H4.
  rewrite mult_1_l.
  rewrite plus_0_r.
  intuition.
Qed.

(*
Definition maxCount_o(D R S : Set){eqdr : EqDec R}{eqds : EqDec S}(count : S -> nat)(o : S -> D -> Comp (R * S))
           (defR : R)(m : nat)(s : S)(d : D) :=
  if (ge_dec (count s) m) then (ret (defR, s)) else
    o s d.

Theorem maxCount_o_equiv :
    forall (D R C: Set)(A : OracleComp D R C) (n1: nat),
      queries_at_most A n1 ->
      forall (S : Set)(count : S -> nat)(o : S -> D -> Comp (R * S))(defR : R)(eqdr : EqDec R)(eqds : EqDec S)(RndR : Comp R) s x n2,
        (n1 + (count s) <= n2)%nat ->
        evalDist (A _ _ o s) x ==
        evalDist (A _ _ (maxCount_o count o defR n2) s) x.

  Local Opaque evalDist.
  induction 1; intuition; simpl in *.

  comp_skip.
  comp_simp.
  eapply H1.

  specialize (qam_count_gen H (fun (p : list (A * B)) => length p) _ (randomFunc RndR eqdd) ls); intuition.
  eapply le_trans.
  eapply plus_le_compat.
  eapply le_refl.
  eapply H4.
  intuition; simpl in *.
  unfold randomFunc in *.
  destruct (arrayLookup eqdd x y); repeat simp_in_support.
  lia.
  simpl.
  assert ( (S (length x) <= 1+ length x)%nat).
  lia.
  eapply H5.
  eapply H3.
  lia.

  unfold randomFunc, randomFunc_max.
  destruct (arrayLookup eqdd ls a).
  eapply evalDist_ret_eq; intuition.
  comp_skip.
  destruct (ge_dec (length ls) n2).
  lia.
  eapply evalDist_ret_eq; intuition.

  eapply eqRat_refl.

  comp_skip.
  remember (map

  eapply (@IHqueries_at_most _ _ RndR ls.

  trivial.

  erewrite H4.

  Print RndInList.

  rewrite <- H2.
  eapply plus_le_compat; intuition.
  lia.

Qed.
*)

Section RandPermSwitching.

  Variable A D R : Set.
  Variable RndR : Comp R.
  Hypothesis RndR_wf : well_formed_comp RndR.

  Variable A2 : OracleComp D R bool.

  Hypothesis eqdd : EqDec D.
  Hypothesis eqdr : EqDec R.

  Variable fBad : list (D * R) -> D -> R -> bool.
  Variable badProb : nat -> Rat.
  Hypothesis badProb_mono : forall n1 n2, (n1 <= n2)%nat -> badProb n1 <= badProb n2.

  Hypothesis A2_wf : well_formed_oc A2.
  Variable A2_queries : nat.
  Hypothesis A2_queries_correct : queries_at_most' A2 A2_queries.
  Hypothesis badProb_correct :
    forall d f,
      Pr [r <-$ RndR;
           ret (fBad f d r)] <= badProb (S (length f)).

   Hypothesis goodExists :
    forall d f,
      (length f <= A2_queries) %nat ->
      exists r,
        In r (getSupport RndR) /\
        fBad f d r = false.

  (*
  Hypothesis fBad_single :
    forall d r,
      fBad ((d, r) :: nil) = false.
*)

  (*
  Hypothesis goodExists :
    forall d f,
      arrayLookup _ f d = None ->
      exists r,
        In r (getSupport RndR) /\
        fBad f d r = false.
*)

  Definition rndNotBad(d : D)(f : list (D * R)):=
    Repeat RndR (fun r => negb (fBad f d r)).

  Definition GenRP(s : list (D * R))(d : D) : Comp (R * list (D * R)) :=
    match arrayLookup _ s d with
      | Some r => ret (r, s)
      | None => r <-$ (rndNotBad d s); ret (r, (d, r) :: s)
    end.

  Definition RPS_G0  :=
    [b, _] <-$2 A2 _ _ (@randomFunc D R RndR _ ) nil;
    ret b.

  Definition RPS_G1 :=
    [b, _] <-$2 A2 _ _ GenRP nil;
    ret b.

   Definition randomFunc_bad (s : list (D * R) * bool) d :=
    [s, bad] <-2 s;
    match (arrayLookup _ s d) with
        | Some r => ret (r, (s, bad))
        | None =>
          r <-$ RndR;
          newF <- ((d, r) :: s);
          bad' <- fBad s d r;
          ret (r, (newF, bad || bad'))
    end.

   Definition GenRP_bad (s : list (D * R) * bool) d :=
    [s, bad] <-2 s;
    match (arrayLookup _ s d) with
        | Some r => ret (r, (s, bad))
        | None =>
          r <-$ RndR;
          newF <- ((d, r) :: s);
          bad' <- fBad s d r;
          if (bad') then
            (r <-$ rndNotBad d s;
            ret (r, ((d, r) :: s, bad || bad')))
          else
            ret (r, (newF, bad || bad'))
    end.

  Definition RPS_G_1 :=
    [b, s] <-$2 A2 _ _ (randomFunc_bad) (nil, false);
    ret (b, snd s).

  Definition RPS_G_2 :=
    [b, s] <-$2 A2 _ _ (GenRP_bad) (nil, false);
    ret (b, snd s).

  Theorem randomFunc_bad_wf :
    forall a b,
      well_formed_comp (randomFunc_bad a b).

    intuition.
    unfold randomFunc_bad.
    destruct (arrayLookup eqdd a0 b0); wftac.

  Qed.

  Theorem GenRP_bad_wf :
    forall a b,
      (length (fst a) <= A2_queries)%nat ->
      well_formed_comp (GenRP_bad a b).

    intuition.
    simpl in *.
    case_eq (arrayLookup eqdd a0 b0); intuition; wftac.
    unfold rndNotBad; wftac.
    edestruct goodExists ; eauto.
    intuition.
    econstructor.
    unfold eq_dec; intuition.
    eapply (EqDec_dec _).
    trivial.
    eapply filter_In; intuition.
    eauto.
    rewrite H4.
    trivial.

  Qed.

  Theorem rf_rp_oc_eq_until_bad :
    comp_spec
      (fun y1 y2 =>
         snd (snd y1) = snd (snd y2) /\
          (snd (snd y1) = false -> fst (snd y1) = fst (snd y2) /\ fst y1 = fst y2))
      (A2 (list (D * R) * bool)%type _
          randomFunc_bad (nil, false))
      (A2 (list (D * R) * bool)%type _
          GenRP_bad (nil, false)).

    eapply comp_spec_consequence.
    eapply (@oc_comp_spec_eq_until_bad _ _ _ _ _ _ _ _ _ _ _ _ _
                                       (fun a => snd a)
                                       (fun a => snd a)
                                       (fun a b => (fst a = fst b))).
    intros.
    eapply randomFunc_bad_wf.
    intros.
    eapply GenRP_bad_wf.
    admit.

    intuition.
    simpl in *.
    subst.

    case_eq (arrayLookup eqdd a0 a1); intuition.
    eapply comp_spec_ret; intuition.

    comp_skip.
    eapply comp_base_exists; eauto.
    eapply comp_base_exists; eauto.

    destruct ( fBad a0 a1 b) eqn:?.
    comp_irr_r.
    unfold rndNotBad.
    edestruct goodExists.
    eauto.
    admit.
    econstructor.
    unfold eq_dec; intuition.
    eapply (EqDec_dec _).
    trivial.
    eapply filter_In; intuition.
    eauto.
    match goal with H5:_|-_ => rewrite H5; reflexivity end.
    eapply comp_spec_ret.
    simpl.
    split.
    intuition.
    intros.
    rewrite orb_true_r in *.
    discriminate.
    eapply comp_spec_ret; intuition.
    intuition.
    simpl in *.
    case_eq (arrayLookup eqdd a1 d); intuition.
    rewrite H1 in H0.
    repeat simp_in_support.
    trivial.
    rewrite H1 in H0.
    repeat simp_in_support.
    trivial.

    intuition.
    simpl in *.
    case_eq (arrayLookup eqdd a1 d ); intuition;
    rewrite H1 in H0;
    repeat simp_in_support;
    trivial.

    trivial.
    trivial.

    intuition.

    Grab Existential Variables.
    admit.
    admit.
    trivial.

  Admitted.

  Theorem RPS_G_1_2_bad_same :
     Pr  [x <-$ RPS_G_1; ret snd x ] == Pr  [x <-$ RPS_G_2; ret snd x ].

    unfold RPS_G_1, RPS_G_2.
    inline_first.

    eapply comp_spec_impl_eq.
    comp_skip.
    eapply rf_rp_oc_eq_until_bad.

    intuition.
    simpl in *.
    intuition.
    destruct b.
    simpl in *.
    destruct p; simpl in *.
    subst.
    comp_simp.
    simpl.
    eapply comp_spec_ret; intuition.

  Qed.

  Theorem RPG_G_1_2_eq_until_bad :
    forall a : bool,
      evalDist RPS_G_1 (a, false) == evalDist RPS_G_2 (a, false).

    intuition.
    unfold RPS_G_1, RPS_G_2.
    eapply comp_spec_impl_eq.
    comp_skip.
    eapply rf_rp_oc_eq_until_bad.

    intuition.
    simpl in *.
    intuition.
    destruct b.
    simpl in *.
    destruct p; simpl in *.
    eapply comp_spec_ret; intuition.
    pairInv.
    subst.
    intuition.
    subst.
    intuition.
    subst.
    pairInv.
    intuition.
    subst.
    trivial.

  Qed.

  Theorem RPS_G_1_bad_small :
    Pr  [x <-$ RPS_G_1; ret snd x ] <= A2_queries / 1 * badProb A2_queries.

    unfold RPS_G_1.
    inline_first.

    assert (Pr
   [a <-$
    A2 (list (D * R) * bool)%type _
      (randomFunc_bad) (nil, false);
    x <-$ ([b, s]<-2 a; ret (b, snd s)); ret snd x ]
   ==
   Pr
   [a <-$
    A2 (list (D * R) * bool)%type _
      (randomFunc_bad) (nil, false);
    ret snd (snd a) ]
   ).
    comp_skip.
    comp_simp.
    reflexivity.
    rewrite H.
    clear H.

    eapply leRat_trans.
    eapply (@oc_eventProb_0_1 _ (fun p => length (fst p)) _ badProb).
    eauto.
    eapply badProb_mono.
    trivial.
    intuition.
    simpl in *.
    subst.
    case_eq (arrayLookup eqdd a a0); intuition.
    comp_simp.
    simpl.
    rewrite evalDist_ret_0.
    eapply rat0_le_all.
    congruence.

    simpl in *.
    eapply leRat_trans.
    2:{
      eapply badProb_correct.
    }
    inline_first.
    comp_skip.
    simpl.
    eapply leRat_refl.
    intuition.
    simpl in *.
    destruct (arrayLookup eqdd a a1);
    repeat simp_in_support.
    lia.
    simpl.
    intuition.

    trivial.
    intuition.

  Qed.

  Theorem RPS_G_1_2_close :
  | Pr[x <-$ RPS_G_1; ret fst x] - Pr[x <-$ RPS_G_2; ret fst x] | <= (A2_queries / 1)  * badProb A2_queries.

    intuition.
    eapply leRat_trans.
    eapply fundamental_lemma_h.

    (* badness is the same. *)
    eapply RPS_G_1_2_bad_same.

    eapply RPG_G_1_2_eq_until_bad.

    eapply RPS_G_1_bad_small.

  Qed.

  Theorem RPS_G0_equiv :
    Pr[RPS_G0] == Pr[x <-$ RPS_G_1; ret fst x].

    unfold RPS_G0, RPS_G_1.
    inline_first.
    eapply (comp_spec_eq_impl_eq).
    comp_skip.
    eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ (fun a b => a = fst b)); trivial.
    intuition.
    subst.
    unfold randomFunc, randomFunc_bad.
    comp_simp.
    simpl.
    case_eq ( arrayLookup eqdd l a ); intuition.
    eapply comp_spec_ret; intuition.
    comp_skip.
    eapply comp_base_exists; eauto.
    eapply comp_base_exists; eauto.
    eapply comp_spec_ret; intuition.

    comp_simp.
    simpl in *; intuition.
    subst.
    eapply comp_spec_eq_refl.

  Qed.

  Theorem RPS_G1_equiv :
    Pr[x <-$ RPS_G_2; ret fst x] == Pr[RPS_G1].

    unfold RPS_G_2, RPS_G1.
    inline_first.
    eapply comp_spec_eq_impl_eq.
    comp_skip.
    eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ (fun a b => fst a = b)); trivial.
    intuition.
    unfold GenRP, GenRP_bad.
    subst.
    simpl.
    case_eq (arrayLookup eqdd a0 a); intuition.
    eapply comp_spec_ret; intuition.

    unfold rndNotBad.

    assert (
        comp_spec
          eq
          (r <-$ (r <-$ RndR; if (negb (fBad a0 a r)) then (ret r) else (Repeat RndR (fun r : R => negb (fBad a0 a r))));

           ret (r, (a, r) :: a0))
          (r <-$ Repeat RndR (fun r : R => negb (fBad a0 a r));
           ret (r, (a, r) :: a0))
      ).

    eapply eq_impl_comp_spec_eq.
    intuition.
    symmetry.
    comp_skip.
    eapply repeat_unroll_eq.
    trivial.
    edestruct goodExists; eauto.
    admit.
    eexists.
    eapply filter_In; intuition.
    eauto.
    rewrite H2.
    trivial.
    eapply comp_spec_eq_trans_r.
    2:{
      eapply H0.
    }
    clear H0.
    inline_first.
    comp_skip.
    eapply comp_base_exists; eauto.
    eapply comp_base_exists; eauto.
    case_eq (fBad a0 a b0); intuition.
    simpl.
    comp_skip.
    eapply comp_spec_ret; intuition.
    simpl.
    comp_simp.
    eapply comp_spec_ret; intuition.
    comp_simp.
    simpl in *.
    intuition; subst.
    eapply comp_spec_eq_refl.
  Admitted.

  Theorem RPS_G0_1_close :
  | Pr[RPS_G0] - Pr[RPS_G1] | <= (A2_queries / 1)  * badProb A2_queries.

    rewrite RPS_G0_equiv.
    rewrite <- RPS_G1_equiv.
    eapply RPS_G_1_2_close.
  Qed.
End RandPermSwitching.