(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export unsquashed_continuity.
Require Export Coq.Logic.ConstructiveEpsilon.

(*

  Some results from Kripke's
  "Semantical Analysis of Intuitionistic Logic I" (p.104).

  This is a theory of absolutely free choice sequences (afcs)
  but I've used [baire] here, which is bogus (and several concrete
  sequences that are not absolutely free).  For example the
  axiom [continuity_seq_prop] of LC is clearly false if we don't
  restrict ourselves to afcs's...but at least this gives a rough idea
  of what's going on...

  Could I use an axiomatization of afcs's instead of [baire]?

 *)

Definition continuity_seq_prop :=
  forall (A : baire -> Prop) (a : baire),
    A a -> exists (p : nat), forall (b : baire), eq_upto p a b -> A b.

Definition uniform_continuity :=
  forall (F : cantor -> nat),
    {n : nat | forall (f g : cantor), eq_upto n f g -> F f = F g}.

(* sequences can either increase by one or not increase at all *)
Definition increasing (a : baire) : Prop :=
  forall (n : nat), a (S n) = a n \/ a (S n) = S (a n).

Definition init0 (a : baire) : Prop := a 0 = 0.

Definition initF (a : cantor) : Prop := a 0 = false.

(* if a(pred n)=a(n) then b2c(a)(n)=false otherwise b2c(a)(n)=true, meaning it increases *)
Definition baire2cantor (a : baire) : cantor :=
  fun n => if eq_nat_dec (a (pred n)) (a n) then false else true.

(* We have to pick the initial value at 0.  We chose 0, which is why we
   require the [init0] condition below. *)
Fixpoint cantor2baire (a : cantor) (n : nat) : nat :=
  match n with
  | 0 => 0
  | S n =>
    let m := cantor2baire a n in
    if a (S n) then
      S m
    else
      m
  end.

Lemma increasing_cantor2baire :
  forall (a : cantor), increasing (cantor2baire a).
Proof.
  intros a n; simpl.
  destruct (a (S n));[right|left];auto.
Qed.
Hint Resolve increasing_cantor2baire : cont.

Lemma init0_cantor2baire :
  forall (a : cantor), init0 (cantor2baire a).
Proof.
  intros a; simpl.
  unfold init0; simpl; auto.
Qed.
Hint Resolve init0_cantor2baire : cont.

Lemma initF_baire2cantor :
  forall (a : baire), initF (baire2cantor a).
Proof.
  intros a; simpl.
  unfold initF, baire2cantor; simpl.
  destruct (Nat.eq_dec (a 0) (a 0)); auto; omega.
Qed.
Hint Resolve initF_baire2cantor : cont.

Lemma cantor2baire2cantor :
  forall (a : cantor), initF a -> baire2cantor (cantor2baire a) = a.
Proof.
  introv init.
  apply functional_extensionality; introv.

  unfold baire2cantor; simpl.

  destruct x; simpl; auto.
  remember (cantor2baire a x) as m.
  destruct (a (S x)).

  - destruct (Nat.eq_dec m (S m)); auto; try omega.

  - destruct (Nat.eq_dec m m); auto; try omega.
Qed.

Lemma baire2cantor2baire :
  forall (a : baire),
    init0 a
    -> increasing a
    -> cantor2baire (baire2cantor a) = a.
Proof.
  introv init inc.
  apply functional_extensionality; introv.

  induction x; simpl; auto.
  rewrite IHx; clear IHx.
  unfold baire2cantor; simpl.

  destruct (Nat.eq_dec (a x) (a (S x))); try omega.
  pose proof (inc x) as h; destruct h; auto; try omega.
Qed.

(* A non increasing sequence: *)
Definition non_inc_seq : baire :=
  fun n =>
    if eq_nat_dec n 0 then 0
    else if eq_nat_dec n 1 then 1
         else 0.

(* we now prove that we need the [increasing] hypothesis to prove [baire2cantor2baire] *)
Lemma baire2cantor2baire_needs_increassing :
  cantor2baire (baire2cantor non_inc_seq) <> non_inc_seq.
Proof.
  introv h.
  apply equal_f with (x := 2) in h.
  simpl in h.
  unfold non_inc_seq in h; simpl in h; omega.
Qed.

Fixpoint least_greater_aux (b : baire) (n : nat) (x : nat) : option nat :=
  match n with
  | 0 => None
  | S m =>
    match least_greater_aux b m x with
    | Some k => Some k
    | None => if le_lt_dec x (b m) then Some m else None
    end
  end.

Definition least_greater (b : baire) (n : nat) (x : nat) : nat :=
  match least_greater_aux b n x with
  | Some k => k
  | None => n
  end.

Definition least_greater_aux_prop1 :
  forall b n x k,
    least_greater_aux b n x = Some k
    -> x <= b k.
Proof.
  induction n; introv h; simpl in *; try (inversion h; fail).
  remember (least_greater_aux b n x) as l; symmetry in Heql; destruct l.

  - inversion h; subst; clear h.
    apply IHn in Heql; auto.

  - destruct (le_lt_dec x (b n)); inversion h; subst; clear h; auto.
Qed.

Definition increasing_le :
  forall a n m,
    n <= m
    -> increasing a
    -> a n <= a m.
Proof.
  induction m; introv lenm inc.

  - assert (n = 0) by omega; subst; auto.

  - destruct (le_lt_dec n m) as [d|d].

    + repeat (autodimp IHm hyp).
      pose proof (inc m) as q; destruct q; omega.

    + assert (n = S m) by omega; subst; auto.
Qed.

Definition least_greater_aux_prop2 :
  forall b a n x k,
    eq_upto x b a
    -> increasing a
    -> least_greater_aux b n (S (a x)) = Some k
    -> x <= k.
Proof.
  introv equ inca e.
  apply least_greater_aux_prop1 in e.
  destruct (le_lt_dec x k); auto.
  rewrite (equ k l) in e.
  pose proof (increasing_le a k x) as q; repeat (autodimp q hyp); try omega.
Qed.

Lemma implies_eq_upto_baire2cantor :
  forall (a b : baire) n,
    eq_upto n a b
    -> eq_upto n (baire2cantor a) (baire2cantor b).
Proof.
  introv h q.
  unfold baire2cantor.

  destruct m; simpl.

  { destruct (Nat.eq_dec (a 0) (a 0)); try omega.
    destruct (Nat.eq_dec (b 0) (b 0)); try omega.
    auto. }

  destruct (Nat.eq_dec (a m) (a (S m))) as [d1|d1];
    destruct (Nat.eq_dec (b m) (b (S m))) as [d2|d2];
    auto.

  - pose proof (h m) as h1; autodimp h1 hyp; try omega.
    pose proof (h (S m)) as h2; autodimp h2 hyp; try omega.

  - pose proof (h m) as h1; autodimp h1 hyp; try omega.
    pose proof (h (S m)) as h2; autodimp h2 hyp; try omega.
Qed.
Hint Resolve implies_eq_upto_baire2cantor : cont.

Definition baire_eq_from (a : baire) (k : nat) : baire :=
  fun n => if lt_dec n k then a n else a k.

Lemma increasing_baire_eq_from :
  forall (a : baire) n,
    increasing a
    ->  increasing (baire_eq_from a n).
Proof.
  introv inc; introv.
  unfold baire_eq_from.
  destruct (lt_dec (S n0) n); destruct (lt_dec n0 n); auto; try omega.
  assert (n = S n0) as xx by omega; subst; simpl in *; auto.
Qed.
Hint Resolve increasing_baire_eq_from : cont.

Definition baire_diff_from (a : baire) (k : nat) : baire :=
  fun n =>
    if le_lt_dec k n
    then (* k <= n *)
      if eq_nat_dec (a k) (a (pred k))
      then S (a (pred k))
      else a (pred k)
    else (* n < k *) a n.

Lemma eq_upto_baire_diff_from :
  forall n a, eq_upto n a (baire_diff_from a n).
Proof.
  introv h.
  unfold baire_diff_from.
  destruct (le_lt_dec n m); auto; try omega.
Qed.
Hint Resolve eq_upto_baire_diff_from : cont.

Lemma eq_upto0 :
  forall {T} (a b : Seq T), eq_upto 0 a b.
Proof.
  introv h; omega.
Qed.
Hint Resolve eq_upto0 : cont.

Lemma init0_implies_eq_upto1_zeros :
  forall (a : baire), init0 a -> eq_upto 1 a zeros.
Proof.
  introv init h.
  destruct m; try omega; auto.
Qed.
Hint Resolve init0_implies_eq_upto1_zeros : cont.

Lemma init0_zeros : init0 zeros.
Proof.
  compute; auto.
Qed.
Hint Resolve init0_zeros : cont.

Lemma increasing_zeros : increasing zeros.
Proof.
  compute; auto.
Qed.
Hint Resolve increasing_zeros : cont.

Definition change_from1 (a : baire) : cantor :=
  fun n => if eq_nat_dec n 0 then false else
             if eq_nat_dec (a 1) (a 0) then true
             else false.

Lemma init0_baire_diff_from :
  forall a n, 0 < n -> init0 a -> init0 (baire_diff_from a n).
Proof.
  introv lt0 init.
  unfold init0, baire_diff_from.
  destruct (le_lt_dec n 0); try omega; auto.
Qed.
Hint Resolve init0_baire_diff_from : cont.

Lemma increasing_baire_diff_from :
  forall a n, increasing a -> increasing (baire_diff_from a n).
Proof.
  introv cont; introv.
  unfold baire_diff_from.
  destruct (le_lt_dec n (S n0)) as [d1|d1];
    destruct (Nat.eq_dec (a n) (a (Init.Nat.pred n))) as [d2|d2];
    destruct (le_lt_dec n n0) as [d3|d3]; auto; try omega;
      assert (n = S n0) by omega; subst; simpl in *; auto.
Qed.
Hint Resolve increasing_baire_diff_from : cont.

Lemma baire_diff_from_diff :
  forall a n, a n <> baire_diff_from a n n.
Proof.
  introv h.
  unfold baire_diff_from in h.
  destruct (le_lt_dec n n) as [d|d]; try omega.
  clear d.
  destruct (Nat.eq_dec (a n) (a (Init.Nat.pred n))) as [d|d]; auto.
  omega.
Qed.

Lemma eq_upto_baire_eq_from :
  forall a p n,
    p <= n
    -> eq_upto p a (baire_eq_from a n).
Proof.
  introv lepn h.
  unfold baire_eq_from.
  destruct (lt_dec m n); auto; try omega.
Qed.
Hint Resolve eq_upto_baire_eq_from : cont.

Lemma init0_baire_eq_from :
  forall a n, init0 a -> init0 (baire_eq_from a n).
Proof.
  introv inti.
  unfold init0, baire_eq_from; simpl.
  destruct (lt_dec 0 n); auto.
  assert (n = 0) by omega; subst; auto.
Qed.
Hint Resolve init0_baire_eq_from : cont.

Definition baire_inc_from (a : baire) (n : nat) : baire :=
  fun k => if lt_dec k n then a k else (a n) + k - n.

Lemma eq_upto_baire_inc_from :
  forall (a : baire) (p : nat),
    eq_upto p a (baire_inc_from a p).
Proof.
  introv h.
  unfold baire_inc_from.
  destruct (lt_dec m p); auto; omega.
Qed.
Hint Resolve eq_upto_baire_inc_from : cont.

Lemma increasing_baire_inc_from :
  forall (a : baire) (p : nat),
    increasing a
    -> increasing (baire_inc_from a p).
Proof.
  introv inc; introv.
  unfold increasing, baire_inc_from.
  destruct (lt_dec (S n) p) as [d1|d1]; destruct (lt_dec n p) as [d2|d2]; auto; try omega.
  assert (p = S n) by omega; subst.
  rewrite Nat.add_sub; auto.
Qed.
Hint Resolve increasing_baire_inc_from : cont.

(* This is Kripke's lemma (a) in section 2 p.104 *)
Lemma kripke2a :
  continuity_seq_prop
  ->
  forall (a : baire) (m : nat),
    increasing a
    -> !!{n : nat | a(n) >= m}.
Proof.
  introv cont inv h.

  pose proof (cont (fun a => !{n : nat | a n >= m}) a) as q; simpl in q.
  autodimp q hyp.
  exrepnd.

  assert (a(p) < m) as lem.
  {
    destruct (lt_dec (a p) m); auto.
    destruct h; exists p; omega.
  }

  assert (forall (y : nat), y < p -> a y < m) as ltym.
  {
    introv z.
    pose proof (increasing_le a y p) as w; repeat (autodimp w hyp); try omega.
  }

  pose proof (q0 (baire_inc_from a p))  as z.
  repeat (autodimp z hyp); eauto 2 with cont.
  destruct z.
  exists (p + m - a p).
  unfold baire_inc_from.
  assert (a p + (p + m - a p) - p = m) as xx by omega; rewrite xx; clear xx.
  destruct (lt_dec (p + m - a p) p); auto; omega.
Qed.

(* This is meant to be only true for absolutely free choice sequences *)
Lemma kripke2a_concl_false :
  !forall (a : baire) (m : nat),
      increasing a
      -> !!{n : nat | a(n) >= m}.
Proof.
  introv h.
  pose proof (h zeros 1) as z; clear h.
  autodimp z hyp; eauto 2 with cont.
  unfold zeros in z.
  destruct z; intro z; exrepnd; omega.
Qed.

(* This is meant to be only true for absolutely free choice sequences *)
Lemma continuity_seq_prop_false :
  !continuity_seq_prop.
Proof.
  introv C.
  pose proof (C (fun a => forall n, a n = 0) zeros) as q; simpl in q.
  autodimp q hyp.
  exrepnd.
  pose proof (q0 (fun n => if lt_dec n p then 0 else 1)) as h; simpl in h; clear q0.
  autodimp h hyp.

  {
    introv ltn.
    unfold zeros.
    destruct (lt_dec m p); omega.
  }

  {
    pose proof (h p) as q; clear h.
    destruct (lt_dec p p); omega.
  }
Qed.

Lemma kripke2a_prop :
  continuity_seq_prop
  ->
  forall (a : baire) (m : nat),
    increasing a
    -> !!exists (n : nat), a(n) >= m.
Proof.
  introv cont inc h.
  pose proof (kripke2a cont a m inc) as q.
  destruct q; intro q; exrepnd.
  destruct h; exists n; auto.
Qed.

(* This is Kripke's lemma (b) in section 2 p.104 *)
Lemma kripke2b :
  continuity_seq_prop
  ->
  uniform_continuity
  ->
  forall (a : baire),
    init0 a
    -> increasing a
    -> !forall (m : nat), {n : nat | a(n) >= m}.
Proof.
  introv pcont ucont init inc.
  introv h.

  pose proof (pcont (fun a => forall m : nat, Cast {n : nat | a n >= m}) a) as q.
  simpl in q.
  autodimp q hyp.
  exrepnd.

  assert (forall (b : baire), eq_upto p a b -> forall (m : nat), {n : nat | b n >= m}) as w.
  {
    introv equ; introv.
    pose proof (q0 b equ m) as z.
    apply (constructive_indefinite_ground_description nat (fun n => n) (fun n => n)); auto.
    { introv; apply ge_dec. }
    inversion z; exrepnd; eexists; eauto.
  }

  clear q0.

  assert (forall (b : baire), eq_upto p a b -> {n : nat | b(n) >= S (a p)}) as z.
  {
    introv equ.
    apply w; auto.
  }

  clear w.

  remember (fun (b : cantor) =>
              match eq_upto_dec p a (cantor2baire b) with
              | left q => least_greater
                            (cantor2baire b)
                            (proj1_sig (z (cantor2baire b) q))
                            (S (a p))
              | right _ => 0
              end) as c.

  pose proof (ucont c) as q; exrepnd.
  rename q0 into q.

  assert (p <= n) as lepn.
  {
    (* change a starting at n *)
    destruct (le_lt_dec p n) as [ltnp|ltnp]; auto.
    assert False as xx;[|destruct xx];[].

    destruct (eq_nat_dec n 0) as [ez|ez].

    {
      subst n.

      destruct (eq_nat_dec p 1) as [po|po].

      - subst p.
        pose proof (z zeros) as w.
        repeat (autodimp w hyp); eauto 3 with cont.
        exrepnd.
        compute in w0; omega.

      - pose proof (q (baire2cantor a) (change_from1 a)) as w.
        autodimp w hyp; eauto 2 with cont.
        clear q.
        subst c.
        destruct (eq_upto_dec p a (cantor2baire (baire2cantor a))) as [d1|d1];
          [|destruct d1; rewrite baire2cantor2baire; eauto 2 with cont];[].
        destruct (eq_upto_dec p a (cantor2baire (change_from1 a))) as [d2|d2].

        { pose proof (d2 1) as xx; autodimp xx hyp; try omega.
          unfold change_from1, cantor2baire in xx; simpl in xx.
          destruct (Nat.eq_dec (a 1) (a 0)) as [d|d]; auto;
            rewrite xx in d; rewrite init in d; omega. }

        match type of w with
        | context[proj1_sig ?a] => remember a as xx; exrepnd; simpl in *
        end.
        clear Heqxx.

        rewrite baire2cantor2baire in *; auto;[].
        unfold least_greater in w.
        remember (least_greater_aux a n (S (a p))) as lg; destruct lg; symmetry in Heqlg; subst;
          [|rewrite init in xx0; omega].

        pose proof (least_greater_aux_prop2 a a n p 0) as zz.
        repeat (autodimp zz hyp); omega.
    }

    assert (0 < n) as gz by omega; clear ez.

    pose proof (q (baire2cantor a)
                  (baire2cantor (baire_diff_from a n))) as w.
    autodimp w hyp; eauto with cont; eauto with cont;[].

    clear q; subst c.

    repeat match type of w with
           | context[eq_upto_dec ?a ?b ?c] =>
             let d := fresh "d" in
             destruct (eq_upto_dec a b c) as [d|d]
           end;
      repeat match type of w with
             | context[proj1_sig ?a] =>
               let q := fresh "q" in
               remember a as q; exrepnd; simpl in *;
                 match goal with
                 | [ H : _ = a |- _ ] => clear H
                 end
             end;
      try (complete (destruct d; rewrite baire2cantor2baire in *; eauto 2 with cont));
      repeat (rewrite baire2cantor2baire in *; eauto 3 with cont);[|].

    - pose proof (d0 n) as xx; autodimp xx hyp.
      apply baire_diff_from_diff in xx; auto.

    - unfold least_greater in w.
      remember (least_greater_aux a n0 (S (a p))) as lg; destruct lg; symmetry in Heqlg; subst;
        [|rewrite init in q0; omega].

      pose proof (least_greater_aux_prop2 a a n0 p 0) as zz.
      repeat (autodimp zz hyp); omega.
  }

  pose proof (z (baire_eq_from a p)) as xx.
  repeat (autodimp xx hyp); eauto 3 with cont.
  exrepnd.

  unfold baire_eq_from in xx0.
  destruct (lt_dec n0 p) as [d|d]; try omega.

  pose proof (increasing_le a n0 p) as zz.
  repeat (autodimp zz hyp); try omega.
Qed.

Lemma kripke2b_prop :
  continuity_seq_prop
  ->
  uniform_continuity
  ->
  forall (a : baire),
    init0 a
    -> increasing a
    -> !forall (m : nat), exists (n : nat), a(n) >= m.
Proof.
  introv cont ucont init inc; intro h.
  pose proof (kripke2b cont ucont a init inc) as q.
  destruct q; introv.
  pose proof (h m) as w; clear h.

  apply (constructive_indefinite_ground_description nat (fun n => n) (fun n => n)); auto.
  introv; apply ge_dec.
Qed.

Definition kuroda :=
  forall (A : nat -> Prop),
    (forall (m : nat), !!(A m)) -> (!!forall (m : nat), A m).

Definition markov :=
  forall (A : nat -> Prop),
    (forall m, A m \/ !A m)
    -> (!!exists (n : nat), A n)
    -> exists (n : nat), A n.

(* For this we don't actually need kripke2b
   and we only need kripke2a on the zero sequence
   --- This is because we're cheating:
       zero is not an absolutely free choice sequence

   Which means that we've cheated above in the proofs of kripke2a and kripke2b
   because I probably used many non-absolutely free choice sequences
 *)
Lemma continuity_contradicts_kuroda :
  continuity_seq_prop
  -> !kuroda.
Proof.
  introv cont K.

  pose proof (K (fun m => exists (n : nat), zeros n >= m)) as q; simpl in q.
  autodimp q hyp.

  {
    introv.
    apply kripke2a_prop; eauto 2 with cont.
  }

  {
    destruct q; intro h.
    pose proof (h 1) as z; clear h.
    exrepnd.
    unfold zeros in z0.
    omega.
  }
Qed.


Require Import Category.Setoids.
Require Import Category.Types.
Require Import Category.Types_Setoids.
Require Import Category.RComod.
Require Import Category.RComonad.
Require Import Category.RComonadWithCut.
Require Import Category.TriMat.Category.
Require Import Category.TriMat.Axioms.
Require Import Theory.Category.
Require Import Theory.InitialTerminal.
Require Import Theory.Functor.
Require Import Theory.RelativeComonad.
Require Import Theory.RelativeComonadWithCut.
Require Import Theory.Comodule.
Require Import Theory.Product.
Require Import Theory.PrecompositionWithProduct.
Require Import Theory.PushforwardComodule.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＴＲＩ  ＩＳ  ＴＥＲＭＩＮＡＬ  ＩＮ  ＴＲＩＭＡＴ
  ----------------------------------------------------------------------------*)
(** * Tri is terminal in TriMat **)

(* begin hide *)
Ltac clean_hyps := repeat match goal with H : _ |- _ => clear H end.
(* end hide *)

Module TriMatTerminal (Import TE : Typ) (Import Ax : TriMatAxioms TE).

  Local Notation E := TE.t (only parsing).

  Local Notation coRec hd tl := (corec (λ _ ∙ hd) (λ _ ∙ tl)) (only parsing).

  (** ** -∼- is an equivalence relation **)
  Lemma bisim_refl : ∀ {A} {s : Tri A}, s ∼ s.
  Proof.
    intros. apply bisim_intro with (R := λ _ s₁ s₂ ∙ s₁ = s₂); [clean_hyps; intros..|auto].
    - subst; reflexivity.
    - subst; reflexivity.
  Qed.

  Lemma bisim_sym : ∀ {A} {s₁ s₂ : Tri A}, s₁ ∼ s₂ → s₂ ∼ s₁.
  Proof.
    intros.
    apply bisim_intro with (R := λ _ s₁ s₂ ∙ s₂ ∼ s₁); [clean_hyps; intros..|auto].
    - symmetry; now apply ∼-top.
    - now apply ∼-rest.
  Qed.

  Lemma bisim_trans : ∀ {A} {s₁ s₂ s₃ : Tri A}, s₁ ∼ s₂ → s₂ ∼ s₃ → s₁ ∼ s₃.
  Proof.
    intros.
    apply bisim_intro with (R := λ _ s₁ s₃ ∙ ∃ s₂, s₁ ∼ s₂ ∧ s₂ ∼ s₃);
    [clean_hyps; intros.. | eauto].
    - destruct H as (? & ? & ?).
      etransitivity. eapply ∼-top; eauto.
      now apply ∼-top.
    - destruct H as (? & ? & ?).
      eexists; split; eapply ∼-rest; eauto.
  Qed.

  Instance bisim_equiv : ∀ {A}, Equivalence (@bisim A).
  Proof.
    constructor; repeat intro.
    - now apply bisim_refl.
    - now apply bisim_sym.
    - eapply bisim_trans; eauto.
  Qed.

  Lemma eq_bisim : ∀ {A} {s₁ s₂ : Tri A}, s₁ = s₂ → s₁ ∼ s₂.
  Proof.
    intros. now rewrite H.
  Qed.

  (** ** Tri as a setoid **)
  Program Definition TRI (A : Type) : Setoids.Obj :=
    Setoids.make ⦃ Carrier ≔ Tri A ; Equiv ≔ bisim ⦄.

  (** ** top & rest are setoids morphisms **)
  Lemma top_cong : ∀ {A} {s₁ s₂ : Tri A}, s₁ ∼ s₂ → top s₁ = top s₂.
  Proof.
    intros A s₁ s₂ eq_s₁s₂. now apply ∼-top.
  Qed.

  Lemma rest_cong : ∀ {A} {s₁ s₂ : Tri A}, s₁ ∼ s₂ → rest s₁ ∼ rest s₂.
  Proof.
    intros A s₁ s₂ eq_s₁s₂. now apply ∼-rest.
  Qed.

  Lemma bisim_intro_bis : ∀ {A} {t₁ t₂ : Tri A}, top t₁ = top t₂ → rest t₁ ∼ rest t₂ → t₁ ∼ t₂.
  Proof.
    intros.
    apply bisim_intro with (R := λ A (s₁ s₂ : Tri A) ∙ top s₁ = top s₂ ∧ rest s₁ ∼ rest s₂);
      [ clean_hyps; intros..|].
    - tauto.
    - split. destruct H.
      + now apply top_cong.
      + destruct H.
        now apply rest_cong.
    - tauto.
  Qed.

  Program Definition 𝒕𝒐𝒑 {A} : TRI A ⇒ 𝑬𝑸 A := Setoids.Morphism.make top.
  (** top-cong **)
  Next Obligation.
    now apply top_cong.
  Qed.

  Program Definition 𝒓𝒆𝒔𝒕 {A} : TRI A ⇒ TRI (E ⟨×⟩ A) := Setoids.Morphism.make rest.
  (** rest-cong **)
  Next Obligation.
    now apply rest_cong.
  Qed.

  (** ** Redecoration for infinite triangular matrices **)
  Definition cut {A} : Tri (E ⟨×⟩ A) → Tri A := coRec (λ x ∙ snd (top x)) rest.

  Lemma top_cut : ∀ {A} {t : Tri (E ⟨×⟩ A)}, top (cut t) = snd (top t).
  Proof.
    intros. unfold cut. rewrite (top_corec (T := λ A ∙ Tri (E ⟨×⟩ A))). reflexivity.
  Qed.

  Lemma rest_cut : ∀ {A} {t : Tri (E ⟨×⟩ A)}, rest (cut t) = cut (rest t).
  Proof.
    intros. unfold cut. rewrite (rest_corec (T := λ A ∙ Tri (E ⟨×⟩ A))). reflexivity.
  Qed.

  Lemma cut_cong : ∀ {A} (x y : Tri (E ⟨×⟩ A)), x ∼ y → cut x ∼ cut y.
  Proof.
    intros.
    apply bisim_intro with (R := λ A (s₁ s₂ : Tri A) ∙ ∃ x y, x ∼ y ∧ s₁ = cut x ∧ s₂ = cut y);
    [clean_hyps;intros..|].
    - destruct H as (x & y & eq_xy & -> & ->).
      repeat rewrite top_cut. f_equal. now apply top_cong.
    - destruct H as (x & y & eq_xy & -> & ->).
      exists (rest x). exists (rest y). repeat split.
      + now apply rest_cong.
      + now apply rest_cut.
      + now apply rest_cut.
    - exists x. exists y. tauto.
  Qed.

  Definition lift {A B : Type} (f : Tri A → B) : Tri (E ⟨×⟩ A) → E ⟨×⟩ B := λ x ∙ (fst (top x) , f (cut x)).

  Lemma lift_cong :
    ∀ {A B} {f : Tri A → B}  {t₁ t₂ : Tri (E ⟨×⟩ A)},
      (∀ {t₁ t₂}, t₁ ∼ t₂ → f t₁ = f t₂) → t₁ ∼ t₂ → lift f t₁ = lift f t₂.
  Proof.
    intros.
    unfold lift. f_equal.
    - f_equal. now apply top_cong.
    - apply H. now apply cut_cong.
  Qed.

  Lemma lift_ext : ∀ {A B} {f g : Tri A ⇒ B}, f ≈ g → ∀ {t}, lift f t = lift g t.
  Proof.
    intros. unfold lift. f_equal.
    apply H.
  Qed.

  Definition redec {A B} (f : Tri A → B) (t : Tri A) : Tri B :=
    @corec (λ B ∙ { A : Type & Tri A → B & Tri A})
           (* top *)
           (λ _ t ∙ let '(existT2 A f t) := t
                    in f t)
           (* rest *)
           (λ _ t ∙ let '(existT2 A f t) := t
                    in existT2 _ _ (E ⟨×⟩ A) (lift f) (rest t))
           B (existT2 (λ A ∙ Tri A → B) (λ A ∙ Tri A) A f t).

  Lemma top_redec : ∀ {A B} (f : Tri A → B) (t : Tri A), top (redec f t) = f t.
  Proof.
    intros. unfold redec.
    now rewrite (top_corec (T := λ B ∙ {A : Type & Tri A → B & Tri A})).
  Qed.

  Lemma rest_redec : ∀ {A B} (f : Tri A → B) (t : Tri A), rest (redec f t) = redec (lift f) (rest t).
  Proof.
    intros. unfold redec.
    now rewrite (rest_corec (T := λ B ∙ {A : Type & Tri A → B & Tri A})).
  Qed.

  Lemma redec_cong:
    ∀ {A B} {f : Tri A → B} {t₁ t₂}, (∀ t₁ t₂, t₁ ∼ t₂ → f t₁ = f t₂) → t₁ ∼ t₂ → redec f t₁ ∼ redec f t₂.
  Proof.
    intros.
    apply bisim_intro
      with (R := λ B (s₁ s₂ : Tri B) ∙
                  ∃ A (x y : Tri A) f,
                      x ∼ y ∧ (∀ t₁ t₂, t₁ ∼ t₂ → f t₁ = f t₂)
                    ∧ s₁ = redec f x ∧ s₂ = redec f y); [clean_hyps; intros..|].
    - destruct H as (B & x & y & f & eq_xy & f_proper & -> & ->).
      repeat rewrite top_redec. now apply f_proper.
    - destruct H as (B & x & y & f & eq_xy & f_proper & -> & ->).
      eexists. exists (rest x). exists (rest y). exists (lift f). repeat split.
      + now apply ∼-rest.
      + intros. now apply lift_cong.
      + now apply rest_redec.
      + now apply rest_redec.
    - repeat eexists; eauto.
  Qed.

  Lemma redec_ext : ∀ {A B} {f g : Tri A ⇒ B} {t}, f ≈ g → redec f t ∼ redec g t.
  Proof.
    intros.
    apply bisim_intro
      with (R := λ B (s₁ s₂ : Tri B) ∙ ∃ A x (f g : Tri A ⇒ B), f ≈ g ∧ s₁ = redec f x ∧ s₂ = redec g x);
      [clean_hyps; intros..|].
    - destruct H as (B & x & f & g & eq_fg & -> & ->).
      repeat rewrite top_redec. now apply eq_fg.
    - destruct H as (B & x & f & g & eq_fg & -> & ->).
      eexists. exists (rest x). exists (lift f). exists (lift g). repeat split.
      + intro. now apply lift_ext.
      + now rewrite rest_redec.
      + now rewrite rest_redec.
    - do 2 eexists. exists f. exists g. repeat eexists; eauto.
  Qed.

  Lemma redec_cut : ∀ {A B} {f : Tri A → B} {t}, redec f (cut t) ∼ cut (redec (lift f) t).
  Proof.
    intros.
    apply bisim_intro with (R := λ B (s₁ s₂ : Tri B) ∙
                                  exists A (x : Tri (E ⟨×⟩ A)) f,
                                    s₁ = redec f (cut x) ∧ s₂ = cut (redec (lift f) x));
      [ clean_hyps; intros..|].
    - destruct H as (B & x & f & -> & ->).
      rewrite top_redec. rewrite top_cut. rewrite top_redec. reflexivity.
    - destruct H as (B & x & f & -> & ->).
      eexists. exists (rest x). exists (lift f). split.
      + rewrite rest_redec. rewrite rest_cut. reflexivity.
      + rewrite rest_cut. rewrite rest_redec. reflexivity.
    - repeat eexists.
  Qed.

  (** ** Tri is a relative comonad with cut over EQ **)
  Obligation Tactic := idtac.
  Program Definition 𝑻𝒓𝒊 : ‵ 𝑹𝑪𝒐𝒎𝒐𝒏𝒂𝒅𝑾𝒊𝒕𝒉𝑪𝒖𝒕 𝑬𝑸 E ′ :=
    RelativeComonadWithCut.make ⦃ T ≔ TRI
                                ; counit ≔ λ X ∙ 𝒕𝒐𝒑
                                ; cobind ≔ λ X Y ∙ λ f ↦ Setoids.Morphism.make (redec f)
                                ; cut ≔ λ A ∙ Setoids.Morphism.make cut ⦄.
  (** redec-cong **)
  Next Obligation.
    intros. apply redec_cong; auto. intros. now rewrite H0.
  Qed.
  (** redec-cong₂ **)
  Next Obligation.
    intros X Y f g eq_fg x y eq_xy. rewrite eq_xy. apply redec_ext. intro t. now apply eq_fg.
  Qed.
  (** cobind_counit **)
  Next Obligation.
    simpl. intros.
    apply bisim_intro with (λ A (s₁ s₂ : Tri A) ∙ ∃ x y, x ∼ y ∧ s₁ ∼ redec top x ∧ s₂ = y);
      [clean_hyps; intros..|].
    - destruct H as (x & y & eq_xy & eq & ->).
      etransitivity. eapply top_cong. apply eq.
      rewrite top_redec. now apply top_cong.
    - destruct H as (x & y & eq_xy & eq & ->).
      exists (rest x). exists (rest y). repeat split.
      + now apply ∼-rest.
      + etransitivity. eapply rest_cong. apply eq.
        rewrite rest_redec. apply redec_ext.
        intro . unfold lift. rewrite top_cut. revert x0.
        evar (top' : ∀ {A}, Tri A ⇒ A).
        instantiate (1 := @top) in (Value of top').
        change (⟨ π₁ ∘ top' _ , (π₂ (A := E) (B := A) (p := E × A)) ∘ top' _ ⟩ ≈ top' _).
        symmetry. apply Pmor_universal; reflexivity.
    - exists x. exists y. repeat split.
      + apply H.
      + reflexivity.
  Qed.
  (** counit-cobind **)
  Next Obligation.
    repeat intro. rewrite H. simpl. now rewrite top_redec.
  Qed.
  (** cobind-cobind **)
  Next Obligation.
    intros X Y Z f g x y eq_xy. rewrite <- eq_xy. clear y eq_xy. simpl.
    apply bisim_intro with (λ Z (s₁ s₂ : Tri Z) ∙
                              ∃ X Y (x : Tri X) (f : Tri X → Y) (g : Tri Y → Z),
                                  (∀ t₁ t₂, t₁ ∼ t₂ → g t₁ = g t₂)
                                ∧ s₁ = redec g (redec f x) ∧ s₂ ∼ redec (λ y ∙ g (redec f y)) x);
    [clean_hyps; intros..|].
    - destruct H as (X & Y & x & f & g & g_prp & -> & eq).
      symmetry. etransitivity. eapply top_cong; exact eq.
      now repeat rewrite top_redec.
    - destruct H as (X & Y & x & f & g & g_prp & -> & eq).
      do 2 eexists. exists (rest x). exists (lift f). exists (lift g). repeat split.
      + intros. apply lift_cong; auto.
      + now repeat rewrite rest_redec.
      + etransitivity. eapply rest_cong; exact eq.
        repeat rewrite rest_redec. apply redec_ext.
        intro t. unfold lift. f_equal.
        * rewrite top_redec. reflexivity.
        * apply g_prp. apply redec_cut.
    - do 2 eexists. exists x. exists f. exists g. repeat split.
      + intros. now rewrite H.
      + reflexivity.
  Qed.
  (** cut-cong **)
  Next Obligation.
    intros. now apply cut_cong.
  Qed.
  (** cut-counit **)
  Next Obligation.
    intros A x y eq_xy. rewrite eq_xy. simpl. now rewrite top_cut.
  Qed.
  (** cut-cobind **)
  Next Obligation.
    intros A B f x y eq_xy. rewrite eq_xy. simpl.
    apply redec_cut.
  Qed.

  (** ** Tri coalgebra **)
  Program Definition 𝑹𝒆𝒔𝒕 : ‵ [𝑻𝒓𝒊] ⇒ [𝑻𝒓𝒊][E×─] ′ :=
    Comodule.make ⦃ α ≔ λ A ∙ Setoids.Morphism.make (@rest A) ⦄.
  (** rest-cong **)
  Next Obligation.
    intros A x y eq_xy. now apply rest_cong.
  Qed.
  (** rest-cong2 **)
  Next Obligation.
    intros A B f x y eq_xy. rewrite eq_xy.
    simpl. rewrite rest_redec. reflexivity.
  Qed.

  Program Definition 𝑪𝒖𝒕 : ‵ [𝑻𝒓𝒊][E×─] ⇒ [𝑻𝒓𝒊] ′ :=
    Comodule.make ⦃ α ≔ λ A ∙ Setoids.Morphism.make (@cut A) ⦄.
  (** cut-cong **)
  Next Obligation.
    intros A x y eq_xy. now apply cut_cong.
  Qed.
  (** cut-cong2 **)
  Next Obligation.
    intros A B f x y eq_xy. rewrite eq_xy.
    symmetry. simpl. apply redec_cut.
  Qed.

  Program Definition 𝑻𝑹𝑰 : ‵ 𝑻𝒓𝒊𝑴𝒂𝒕 E ′ :=
    TriMat.make  ⦃ T     ≔ 𝑻𝒓𝒊
                 ; rest  ≔ 𝑹𝒆𝒔𝒕 ⦄.
  (** α-cut **)
  Next Obligation.
    intros A; repeat intro. rewrite H.
    simpl. now rewrite rest_cut.
  Qed.

  (** ** 𝑻𝑹𝑰 is a terminal object **)
  Section Defs.

    Variable (Tr : 𝑻𝒓𝒊𝑴𝒂𝒕 E).

    Notation T                  := (TriMat.T Tr).
    Notation "'T⋅rest'"         := (TriMat.rest Tr _).
    Notation "'T⋅rest[' A ]"    := (TriMat.rest Tr A) (only parsing).
    Notation TRI                := (TriMat.T 𝑻𝑹𝑰).
    Notation "'TRI⋅rest'"       := (TriMat.rest 𝑻𝑹𝑰 _).
    Notation "'TRI⋅rest[' A ]"  := (TriMat.rest 𝑻𝑹𝑰 A) (only parsing).

    Definition tau {A} (t : T A) : TRI A := coRec T⋅counit T⋅rest t.

    Lemma top_tau : ∀ A (t : T A), top (tau t) = T⋅counit t.
    Proof.
      intros. unfold tau. simpl. rewrite @top_corec. reflexivity.
    Qed.

    Lemma rest_tau : ∀ A (t : T A), rest (tau t) = tau (T⋅rest t).
    Proof.
      intros. unfold tau. simpl. now rewrite @rest_corec.
    Qed.

    Infix "∼" := SEquiv.

    Lemma tau_cong : ∀ A (x y : T A), x ∼ y → tau x ∼ tau y.
    Proof.
      intros.
      apply bisim_intro with (R := λ B (s₁ s₂ : TRI B) ∙ ∃ (x y : T B), x ∼ y ∧ s₁ = tau x ∧ s₂ = tau y);
        [clean_hyps; intros..|].
      - destruct H as (x & y & eq_xy & -> & ->).
        repeat rewrite top_tau. now rewrite eq_xy.
      - destruct H as (x & y & eq_xy & -> & ->).
        exists (T⋅rest x). exists (T⋅rest y). repeat split.
        + now rewrite eq_xy.
        + now rewrite rest_tau.
        + now rewrite rest_tau.
      - repeat eexists. apply H.
    Qed.

    Program Definition Tau {A} : T A ⇒ TRI A :=
      Setoids.Morphism.make tau.
    Next Obligation.
      intros. now apply tau_cong.
    Qed.

    Lemma tau_counit : ∀ A (t t' : T A), t ∼ t' → T⋅counit t ∼ TRI⋅counit (tau t').
    Proof.
      intros A t t' eq_tt'. simpl. rewrite top_tau. now rewrite eq_tt'.
    Qed.

    Lemma tau_cut : ∀ A (x y : T (E × A)), x ∼ y → tau (T⋅cut x) ∼ TRI⋅cut (tau y).
    Proof.
      intros.
      apply bisim_intro
        with (R := λ B (s₁ s₂ : TRI B) ∙ exists (x y : T (E ⟨×⟩ B)), x ∼ y ∧ s₁ ∼ tau (T⋅cut x) ∧ s₂ = TRI⋅cut (tau y));
        [clean_hyps; intros..|].
      - destruct H as (x & y & eq_xy & eq & ->).
        etransitivity. eapply top_cong; exact eq.
        rewrite top_tau. etransitivity. apply (cut_counit T _ x). reflexivity.
        simpl. rewrite top_cut. rewrite top_tau. f_equal. now rewrite eq_xy.
      - destruct H as (x & y & eq_xy & eq & ->).
        exists (T⋅rest x). exists (T⋅rest y). repeat split.
        + now rewrite eq_xy.
        + etransitivity. eapply rest_cong; exact eq.
          rewrite rest_tau. apply tau_cong. now apply (TriMat.rest_cut Tr).
        + simpl. rewrite rest_cut. rewrite rest_tau. reflexivity.
      - repeat eexists. apply H. reflexivity.
    Qed.

    Lemma tau_cobind : ∀ A B (f : TRI A ⇒ 𝑬𝑸 B) x y, x ∼ y → Tau (T⋅cobind (f ∘ Tau) x) ∼ TRI⋅cobind f (Tau y).
    Proof.
      intros A B f x y eq_xy. rewrite <- eq_xy. clear eq_xy.
      apply bisim_intro
        with (R := λ B (s₁ s₂ : TRI B) ∙
                    ∃ A (x : T A) (f : TRI A ⇒ 𝑬𝑸 B),
                      s₁ ∼ Tau (T⋅cobind (f ∘ Tau) x) ∧ s₂ = TRI⋅cobind f (Tau x));
        [clean_hyps; intros..|].
      - destruct H as (B & x & f & eq & ->).
        etransitivity. eapply top_cong; exact eq.
        etransitivity. apply top_tau.
        etransitivity. apply (counit_cobind T). reflexivity.
        simpl. now rewrite top_redec.
      - destruct H as (B & x & f & eq & ->).
        eexists. exists (T⋅rest x). exists (TRI⋅extend f). repeat split.
        + etransitivity. eapply rest_cong; exact eq.
          simpl. rewrite rest_tau. apply tau_cong.
          etransitivity. apply (α_commutes (TriMat.rest Tr)). reflexivity.
          apply (Π.cong _ _ (T⋅cobind)). intros u v eq_uv. simpl. f_equal.
          f_equal. rewrite top_tau. now rewrite eq_uv.
          apply (Setoids.cong f). now apply tau_cut. reflexivity.
        + simpl. rewrite rest_redec, rest_tau. reflexivity.
      - repeat eexists. reflexivity.
    Qed.

  End Defs.

  (** printing τ #◯# *)

  (** ◯ is a morphism of triangles **)
  Program Definition τ (T : 𝑻𝒓𝒊𝑴𝒂𝒕 E) : T ⇒ 𝑻𝑹𝑰 :=
    TriMat.make ⦃ τ ≔ RelativeComonadWithCut.make ⦃ τ ≔ λ A ∙ Tau T ⦄ ⦄.
  (** τ-counit **)
  Next Obligation.
    repeat intro. now apply tau_counit.
  Qed.
  (** τ-cobind **)
  Next Obligation.
    repeat intro. now apply tau_cobind.
  Qed.
  (** τ-cut **)
  Next Obligation.
    repeat intro. symmetry. apply tau_cut. now symmetry.
  Qed.
  (** τ-commutes **)
  Next Obligation.
    repeat intro. rewrite H. simpl. now rewrite rest_tau.
  Qed.

  (* begin hide *)
  Local Notation "⟨ f ⟩" := (RelativeComonadWithCut.τ (TriMat.τ f)) (only parsing).
  (* end hide *)

  (** 𝑻𝑹𝑰 is a terminal object **)
  Program Definition Terminality : Terminal (𝑻𝒓𝒊𝑴𝒂𝒕 E) :=
    Terminal.make  ⦃ one  ≔ 𝑻𝑹𝑰
                   ; top  ≔ τ ⦄.
  (** top-unique **)
  Next Obligation.
    intros T f A x y eq_xy. rewrite <- eq_xy. clear eq_xy; simpl.
    apply bisim_intro
      with (R := λ A (s₁ s₂ : TRI A) ∙ ∃ x (f : T ⇒ 𝑻𝑹𝑰), s₁ ∼ ⟨f⟩ A x ∧ s₂ = tau T x);
      [clean_hyps; intros..|].
    - destruct H as (x & f & eq & ->).
      etransitivity. eapply top_cong; exact eq.
      rewrite top_tau. simpl. etransitivity. symmetry. apply (τ_counit ⟨f⟩). reflexivity. reflexivity.
    - destruct H as (x & f & eq & ->).
      exists (TriMat.rest T _ x). exists f. split.
      + etransitivity. eapply rest_cong; exact eq.
        symmetry. eapply (TriMat.τ_commutes f). reflexivity.
      + rewrite rest_tau. reflexivity.
    - repeat eexists. reflexivity.
  Qed.

End TriMatTerminal.


Set Implicit Arguments.

Require Import TLC.LibLN.
Implicit Types x : var.
Require Import DeclDef.

(** Syntax **)

Inductive ptrm : Set :=
  | ptrm_bvar   : nat -> ptrm
  | ptrm_fvar   : var -> ptrm
  | ptrm_nat    : nat -> ptrm
  | ptrm_absann : dtyp -> ptrm -> ptrm
  | ptrm_app    : ptrm -> ptrm -> ptrm
  | ptrm_cast   : dtyp -> dtyp -> ptrm -> ptrm
  | ptrm_tabs   : ptrm -> ptrm
.

(** Opening up a term binder occuring in a term *)

Fixpoint popen_ee_rec (k : nat) (f : ptrm) (e : ptrm) {struct e} : ptrm :=
  match e with
  | ptrm_bvar i       => If k = i then f else (ptrm_bvar i)
  | ptrm_fvar x       => ptrm_fvar x
  | ptrm_nat i        => ptrm_nat i
  | ptrm_absann V e1  => ptrm_absann V (popen_ee_rec (S k) f e1)
  | ptrm_app e1 e2    => ptrm_app (popen_ee_rec k f e1) (popen_ee_rec k f e2)
  | ptrm_cast A B e1  => ptrm_cast A B (popen_ee_rec k f e1)
  | ptrm_tabs e1      => ptrm_tabs (popen_ee_rec k f e1)
  end.

Definition popen_ee t u := popen_ee_rec 0 u t.

Notation "t 'popen_ee_var' x" := (popen_ee t (ptrm_fvar x)) (at level 67).

Fixpoint popen_te_rec (k : nat) (f : dtyp) (e : ptrm) {struct e} : ptrm :=
  match e with
  | ptrm_bvar i       => ptrm_bvar i
  | ptrm_fvar x       => ptrm_fvar x
  | ptrm_nat i        => ptrm_nat i
  | ptrm_absann V e1  => ptrm_absann (dopen_tt_rec k f V) (popen_te_rec k f e1)
  | ptrm_app e1 e2    => ptrm_app (popen_te_rec k f e1) (popen_te_rec k f e2)
  | ptrm_cast A B e1  => ptrm_cast (dopen_tt_rec k f A) (dopen_tt_rec k f B)
                                  (popen_te_rec k f e1)
  | ptrm_tabs e1      => ptrm_tabs (popen_te_rec (S k) f e1)
  end.

Definition popen_te t u := popen_te_rec 0 u t.

Notation "t 'popen_te_var' x" := (popen_te t (dtyp_fvar x)) (at level 67).

(** Terms as locally closed pre-terms *)

Inductive pterm : ptrm -> Prop :=
  | pterm_var : forall x,
      pterm (ptrm_fvar x)
  | pterm_nat : forall i,
      pterm (ptrm_nat i)
  | pterm_absann : forall L V e1,
      dtype V ->
      (forall x, x \notin L -> pterm (e1 popen_ee_var x)) ->
      pterm (ptrm_absann V e1)
  | pterm_app : forall e1 e2,
      pterm e1 ->
      pterm e2 ->
      pterm (ptrm_app e1 e2)
  | pterm_cast : forall A B e,
      dtype A ->
      dtype B ->
      pterm e ->
      pterm (ptrm_cast A B e)
  | pterm_tabs : forall L e1,
      (forall x, x \notin L -> pterm (e1 popen_te_var x)) ->
      pterm (ptrm_tabs e1)
.

Inductive pcompatible : dtyp -> dtyp -> Prop :=
  | pcompatible_refl: forall A,
      pcompatible A A
  | pcompatible_unknown_r : forall A,
      pcompatible A dtyp_unknown
  | pcompatible_unknown_l : forall A,
      pcompatible dtyp_unknown A
  | pcompatible_arrow : forall A1 A2 B1 B2,
      pcompatible B1 A1 ->
      pcompatible A2 B2 ->
      pcompatible (dtyp_arrow A1 A2) (dtyp_arrow B1 B2)
  | pcompatible_allR: forall L A B,
      (forall x, x \notin L ->
           pcompatible A (B dopen_tt_var x)) ->
      pcompatible A (dtyp_all B)
  | pcompatible_allL: forall A B,
      pcompatible (dopen_tt A dtyp_unknown) B ->
      pcompatible (dtyp_all A) B
.

(** Typing *)

Inductive ptyping : denv -> ptrm -> dtyp -> Prop :=
  | ptyping_var : forall E x T,
      dokt E ->
      binds x (dbind_typ T) E ->
      ptyping E (ptrm_fvar x) T
  | ptyping_nat : forall E i,
      dokt E ->
      ptyping E (ptrm_nat i) (dtyp_nat)
  | ptyping_absann_i : forall L E A B e,
      (forall x, x \notin L ->
            ptyping (E & x ~: A) (e popen_ee_var x) B) ->
      ptyping E (ptrm_absann A e) (dtyp_arrow A B)
  | ptyping_app : forall E e1 e2 A1 A2,
      ptyping E e1 (dtyp_arrow A1 A2) ->
      ptyping E e2 A1 ->
      ptyping E (ptrm_app e1 e2) A2
  | ptyping_cast : forall E e A B,
      ptyping E e A ->
      dwft E B ->
      pcompatible A B ->
      ptyping E (ptrm_cast A B e) B
  | ptyping_tabs : forall L E A e,
      (forall a, a \notin L ->
            ptyping (E & a ~tvar) (e popen_te_var a) (A dopen_tt_var a)) ->
      ptyping E (ptrm_tabs e) (dtyp_all A)
.


(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)
Require Import graphInt.
Require Import dgraph.
Require Import zorder.

Require Import Relations.

Module GProp (G: graphSig).

(*Module G := (Dgraph Zequal).*)

(*-------------------------------------------------------------------------------*)
(* some generic graph properties *)

Inductive Id (g : G.DGraph) (x : NodeId) : Prop :=
    is_id : G.g_in g x = true -> Id g x.

(* -------------------- Pathes definitions ----------------------- *)

Inductive Dpath : Set :=
  | bpath : NodeId -> NodeId -> Dpath
  | mpath : NodeId -> Dpath -> Dpath.

(* nodes just have to be adjacent, no orientation is required *)
Inductive Adjacent (g : G.DGraph) (x1 x2 : NodeId) : Prop :=
    adj :
      ZSet.s_in x1 (G.children g x2) = true \/
      ZSet.s_in x2 (G.children g x1) = true -> Adjacent g x1 x2.

Fixpoint AdjPath (g : G.DGraph) (path : Dpath) {struct path} : Prop :=
  match path with
  | bpath x1 x2 => Adjacent g x2 x1
  | mpath x p =>
      match p with
      | bpath x1 x2 => Adjacent g x1 x /\ Adjacent g x2 x1
      | mpath x1 p2 => Adjacent g x1 x /\ AdjPath g p
      end
  end.

Fixpoint Path (g : G.DGraph) (path : Dpath) {struct path} : Prop :=
  match path with
  | bpath x1 x2 => ZSet.s_in x2 (G.children g x1) = true
  | mpath x p =>
      match p with
      | bpath x1 x2 =>
          ZSet.s_in x1 (G.children g x) = true /\
          ZSet.s_in x2 (G.children g x1) = true
      | mpath x1 p2 => ZSet.s_in x1 (G.children g x) = true /\ Path g p
      end
  end.

(* A directed path is also an adjacent path *)
Axiom
  Path_AdjPath : forall (g : G.DGraph) (p : Dpath), Path g p -> AdjPath g p.

Definition From (path : Dpath) : NodeId :=
  match path with
  | bpath x x' => x
  | mpath x pp => x
  end.

Fixpoint To (path : Dpath) : NodeId :=
  match path with
  | bpath x1 x2 => x2
  | mpath x1 pp => To pp
  end.

Fixpoint In (x : NodeId) (path : Dpath) {struct path} : Prop :=
  match path with
  | bpath x1 x2 => x = x1 \/ x = x2
  | mpath x1 pp => x = x1 \/ In x pp
  end.

Inductive Nested (x : NodeId) (p : Dpath) : Prop :=
    nested : x <> From p /\ In x p /\ x <> To p -> Nested x p.

Fixpoint Join (p1 p2 : Dpath) {struct p1} : Dpath :=
  match p1 with
  | bpath x1 _ => mpath x1 p2
  | mpath x1 pp => mpath x1 (Join pp p2)
  end.

Inductive ConnectedPath (g : G.DGraph) (p1 p2 : Dpath) : Prop :=
    pconn :
      Path g p1 -> Path g p2 -> To p1 = From p2 -> ConnectedPath g p1 p2.

Inductive Link (g : G.DGraph) (p : Dpath) (x1 x2 : NodeId) : Prop :=
    link : Path g p -> From p = x1 -> To p = x2 -> Link g p x1 x2.

Fixpoint Length (path : Dpath) : Z :=
  match path with
  | bpath x1 x2 => 1%Z
  | mpath x1 pp => (1 + Length pp)%Z
  end.

Axiom PathLengthInf : forall p : Dpath, (1 <= Length p)%Z.

(* -------------------- Relation definitions ----------------------- *)

Inductive Child (g : G.DGraph) (x1 x2 : NodeId) : Prop :=
    child : Path g (bpath x2 x1) -> Child g x1 x2.

Inductive Parent (g : G.DGraph) (x1 x2 : NodeId) : Prop :=
    parent : Path g (bpath x1 x2) -> Parent g x1 x2.

Inductive Descendant (g : G.DGraph) (x1 x2 : NodeId) : Prop :=
    descendant : (exists p : Dpath, Link g p x2 x1) -> Descendant g x1 x2.

Inductive Ancestor (g : G.DGraph) (x1 x2 : NodeId) : Prop :=
    ancestor : (exists p : Dpath, Link g p x1 x2) -> Ancestor g x1 x2.

Inductive Root (g : G.DGraph) (x : NodeId) : Prop :=
    root : forall x' : NodeId, ~ Ancestor g x' x -> Root g x.

Inductive Brother (g : G.DGraph) (x1 x2 : NodeId) : Prop :=
    brother :
      forall x : NodeId, Parent g x x1 -> Parent g x x2 -> Brother g x1 x2.

Inductive Dominates (g : G.DGraph) (x1 x2 : NodeId) : Prop :=
    domin :
      (forall x : NodeId,
       Root g x -> forall p : Dpath, Link g p x x2 -> In x1 p) ->
      Dominates g x1 x2.

(* ------------------------ Properties ----------------------- *)

(* this is a weak connectivity: no partitions *)
Inductive Connected (g : G.DGraph) : Prop :=
    is_connected :
      (forall x1 x2 : NodeId,
       exists p : Dpath, AdjPath g p /\ From p = x1 /\ To p = x2) ->
      Connected g.

Inductive StronglyConnected (g : G.DGraph) : Prop :=
    is_sconnected :
      (forall x1 x2 : NodeId, exists p : Dpath, Link g p x1 x2) ->
      StronglyConnected g.

Inductive Cyclic (g : G.DGraph) : Prop :=
    is_cyclic : (exists e : NodeId, Id g e -> Descendant g e e) -> Cyclic g.

Inductive Dag (g : G.DGraph) : Prop :=
    is_dag : (forall e : NodeId, Id g e -> ~ Descendant g e e) -> Dag g.

(* only one input arc ("left", i.e. incoming  arc) *)
Inductive LLinear (g : G.DGraph) : Prop :=
    l_linear :
      (forall e : NodeId,
       Id g e ->
       G.parents g e = emptyNS \/
       (exists e' : NodeId, G.parents g e = single e')) ->
      LLinear g.

(* only one output arc ("right", i.e. outgoing  arc) *)
Inductive RLinear (g : G.DGraph) : Prop :=
    r_linear :
      (forall e : NodeId,
       Id g e ->
       G.children g e = emptyNS \/
       (exists e' : NodeId, G.children g e = single e')) ->
      RLinear g.

Inductive Tree (g : G.DGraph) : Prop :=
    is_tree : Connected g -> Dag g -> LLinear g -> Tree g.

(* note that forests cannot be connected, as defined above *)
(* It exactly means that all partitions are trees *)
Inductive Forest (g : G.DGraph) : Prop :=
    is_forest :
      (forall e : NodeId,
       Root g e -> Tree (G.project g (ZSet.add e (G.descendants g e)))) ->
      Forest g.

Section LemUtils.

Variable g : G.DGraph.

Lemma Brother_comm :
 forall x1 x2 : NodeId, Brother g x1 x2 -> Brother g x2 x1.
intros x1 x2 H; elim H; intros x H1 H2.
constructor 1 with (x := x).
auto.
auto.
Qed.

Lemma Dec_Anc : forall x1 x2 : NodeId, Descendant g x1 x2 -> Ancestor g x2 x1.

intros x1 x2 H.
constructor; elim H; trivial.
Qed.

Lemma Anc_Dec : forall x1 x2 : NodeId, Ancestor g x1 x2 -> Descendant g x2 x1.

intros x1 x2 H.
constructor; elim H; trivial.
Qed.

Lemma Child_Parent : forall x1 x2 : NodeId, Child g x1 x2 -> Parent g x2 x1.

intros x1 x2 H.
constructor; elim H; trivial.
Qed.

Lemma Parent_Child : forall x1 x2 : NodeId, Parent g x1 x2 -> Child g x2 x1.

intros x1 x2 H.
constructor; elim H; trivial.
Qed.

Lemma mpath_elim :
 forall (p : Dpath) (x : NodeId), Path g (mpath x p) -> Path g p.
intros p x.
case p.
simpl in |- *; intros n n0 H; elim H; auto.
simpl in |- *; intros n n0 H; elim H; auto.
Qed.

Lemma Child_elim :
 forall x1 x2 : NodeId,
 Child g x1 x2 -> ZSet.s_in x1 (G.children g x2) = true.
intros x1 x2 H; elim H.
simpl in |- *; trivial.
Qed.

Lemma Parent_elim :
 forall x1 x2 : NodeId,
 Parent g x1 x2 -> ZSet.s_in x2 (G.children g x1) = true.
intros x1 x2 H; elim H.
simpl in |- *; trivial.
Qed.

Lemma Path_Path :
 forall (p : Dpath) (x : NodeId), Path g (mpath x p) -> Path g p.
simple induction p.
simpl in |- *.
intros n n0 x H; elim H; auto.

intros n d Hind.
intro x.
simpl in |- *.
intro H; elim H.
intro H1; case d.
auto.

auto.
Qed.

Lemma To_In : forall p : Dpath, Path g p -> In (To p) p.
Proof.
simple induction p.
simpl in |- *.
intros; right; trivial.

intros n d Hind H.
simpl in |- *.
right.
apply Hind.
apply Path_Path with (x := n).
exact H.
Qed.

Lemma Child_child :
 forall x1 x2 : NodeId,
 Child g x1 x2 -> ZSet.s_in x1 (G.children g x2) = true.
intros x1 x2 H; elim H.
simpl in |- *; trivial.
Qed.

Lemma mpath_intro :
 forall (x : NodeId) (p : Dpath),
 Path g p -> Child g (From p) x -> Path g (mpath x p).
intros.
elim H0.
intro H1.
simpl in H1.
simpl in |- *.
generalize H.
generalize H0.
case p.
simpl in |- *.
intros; split.
apply Child_child; trivial.

trivial.

simpl in |- *.
intros; split.
apply Child_child; trivial.

trivial.
Qed.

Lemma Path_Child :
 forall (p : Dpath) (x y : NodeId),
 Path g (mpath x p) -> y = From p -> Child g y x.
intros p x y.
case p.
simpl in |- *.
intros n n0 H H1; elim H; rewrite H1.
intros H2 H3.
constructor.
unfold Path in |- *.
trivial.

intros n d.
simpl in |- *.
intros H H1; elim H; intros H2 H3; rewrite H1.
constructor; simpl in |- *.
exact H2.
Qed.

Lemma Join_mpath :
 forall (x : NodeId) (p1 p2 : Dpath),
 Join (mpath x p1) p2 = mpath x (Join p1 p2).
auto.
Qed.

Lemma Join_bpath :
 forall (x1 x2 : NodeId) (p2 : Dpath), Join (bpath x1 x2) p2 = mpath x1 p2.
auto.
Qed.

Lemma To_To : forall (x : NodeId) (p : Dpath), To (mpath x p) = To p.
auto.
Qed.

Lemma Conn_mpath :
 forall (x : NodeId) (p1 p2 : Dpath),
 ConnectedPath g (mpath x p1) p2 -> ConnectedPath g p1 p2.
intros.
elim H.
intros.
constructor.
apply Path_Path with (x := x).
trivial.

trivial.

rewrite To_To in H2.
exact H2.
Qed.

Lemma From_Join : forall p1 p2 : Dpath, From (Join p1 p2) = From p1.
intros p1 p2; case p1.
auto.
auto.
Qed.

Lemma To_Join : forall p1 p2 : Dpath, To (Join p1 p2) = To p2.
simple induction p1; simple induction p2.
simpl in |- *.
auto.

simpl in |- *.
auto.

simpl in |- *.
intros n0 n1.
cut (n1 = To (bpath n0 n1)).
intro H1; rewrite H1; apply H.

auto.

simpl in |- *.
intros n0 d0 H1.
cut (To d0 = To (mpath n0 d0)).
intro H2; rewrite H2; apply H.

auto.
Qed.

Lemma Path_Join :
 forall p1 p2 p : Dpath, ConnectedPath g p1 p2 -> p = Join p1 p2 -> Path g p.
simple induction p1.
simpl in |- *.
intros.
elim H.
simpl in |- *.
intros.
rewrite H0.
apply mpath_intro.
elim H.
auto.

elim H.
intros.
constructor.
rewrite H3 in H4; exact H4.

intros n d Hind p2 p H1 H2.
rewrite Join_mpath in H2.
rewrite H2.
apply mpath_intro.
apply Hind with (p2 := p2).
apply Conn_mpath with (x := n).
assumption.

reflexivity.

elim H1.
intros H3 H4 H5.
generalize H3.
case d.
simpl in |- *.
intros n0 n1 H; elim H; intros H6 H7.
constructor.
simpl in |- *.
exact H6.

simpl in |- *.
intros n0 d0 H; elim H; intros H6 H7.
constructor; simpl in |- *.
exact H6.
Qed.

Lemma Path_Link :
 forall p1 p2 : Dpath,
 ConnectedPath g p1 p2 ->
 forall p : Dpath, p = Join p1 p2 -> Link g p (From p1) (To p2).
intros.
constructor.
apply Path_Join with (p1 := p1) (p2 := p2).
auto.

auto.

rewrite H0; apply From_Join; auto.

rewrite H0; apply To_Join; auto.
Qed.

Lemma Anc_Trans : transitive NodeId (Ancestor g).
unfold transitive in |- *.
intros x y z H1 H2.
constructor.
elim H1.
elim H2.
intros HH1 HH2.
elim HH1.
intro P1.
elim HH2; intro P2.
intros H3 H4.
split with (Join P2 P1).
constructor.
apply Path_Join with (p1 := P2) (p2 := P1).
constructor.
elim H3.
trivial.

elim H4; trivial.

elim H3.
elim H4.
intros.
rewrite H0; rewrite H8; reflexivity.

trivial.

rewrite From_Join; elim H3; auto.

rewrite To_Join; elim H4; auto.
Qed.

Lemma Dec_Trans : transitive NodeId (Descendant g).
unfold transitive in |- *.
intros x y z.
intros H1 H2.
apply Anc_Dec.
cut (Ancestor g z y); cut (Ancestor g y x).
intros; apply Anc_Trans with (y := y); auto.

apply Dec_Anc; auto.

intro; apply Dec_Anc; auto.

apply Dec_Anc; auto.
Qed.

Lemma Join_Path1 :
 forall p1 p2 : Dpath, Path g (Join p1 p2) -> To p1 = From p2 -> Path g p1.
simple induction p1; simple induction p2.
simpl in |- *.
intros n1 n2 H; elim H; intros H1 H2 H3; rewrite H3; trivial.

simpl in |- *.
intros.
rewrite H1; elim H0; trivial.

intros.
apply mpath_intro.
apply H with (p2 := bpath n0 n1).
rewrite Join_mpath in H0.
exact (Path_Path (Join d (bpath n0 n1)) n H0).

rewrite To_To in H1.
exact H1.

rewrite Join_mpath in H0.
apply Path_Child with (p := Join d (bpath n0 n1)).
exact H0.

apply sym_eq.
apply From_Join.

intros n0 d0 Hind H1 H2.
apply mpath_intro.
apply (H (mpath n0 d0)).
rewrite Join_mpath in H1.
exact (Path_Path (Join d (mpath n0 d0)) n H1).

rewrite To_To in H2.
exact H2.

apply Path_Child with (p := Join d (mpath n0 d0)).
rewrite Join_mpath in H1.
exact H1.

rewrite From_Join.
reflexivity.
Qed.

Lemma Join_Path2 :
 forall p1 p2 : Dpath, Path g (Join p1 p2) -> To p1 = From p2 -> Path g p2.
simple induction p1.
intros n n0 p2.
case p2.
simpl in |- *.
intros n1 n2 H; elim H; auto.

unfold Join in |- *.
intros.
exact (Path_Path (mpath n1 d) n H).

intros n d Hind p2 H1 H2.
apply (Hind p2).
rewrite Join_mpath in H1.
apply Path_Path with (x := n).
exact H1.

rewrite To_To in H2.
exact H2.
Qed.

Lemma Join_Path : forall p1 p2 : Dpath, Path g (Join p1 p2) -> Path g p2.
simple induction p1; simple induction p2.
simpl in |- *.
intros; elim H; auto.

intros n1 d H.
unfold Join in |- *.
intro H1.
apply mpath_elim with (x := n).
trivial.

intros n0 n1.
rewrite Join_mpath.
intro H1.
apply H.
apply mpath_elim with (x := n).
exact H1.

intros n0 d0 HH.
rewrite Join_mpath in HH.
rewrite Join_mpath.
intro H1.
apply H.
apply mpath_elim with (x := n).
trivial.
Qed.

Lemma CutLink :
 forall (p : Dpath) (x1 x2 x : NodeId),
 Link g p x1 x2 ->
 Nested x p ->
 forall p1 p2 : Dpath, Link g p1 x1 x -> p = Join p1 p2 -> Link g p2 x x2.
Abort.

End LemUtils.

(* to be proved *)
Axiom
  TreeRoot :
    forall g : G.DGraph,
    Tree g ->
    forall x : NodeId,
    Id g x -> exists r : NodeId, Id g r /\ G.roots g x = single r.

End GProp.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import GRing.Theory Num.Def Num.Theory.

Require Import extrema general dist.

Local Open Scope ring_scope.

(** This module defines an interface over multiplayer games. *)

(** Operational type classes for 'cost' and 'moves';
    cf. "Type Classes for Mathematics in Type Theory",
        Spitters and van der Weegen,
        http://www.eelis.net/research/math-classes/mscs.pdf*)

Class CostClass (cN : nat) (rty : realFieldType) (cT : finType) :=
  cost_fun : 'I_cN -> {ffun 'I_cN -> cT} -> rty.
Notation "'cost'" := (@cost_fun _ _ _) (at level 30).

Class CostAxiomClass cN rty cT `(CostClass cN rty cT) :=
  cost_axiom (i : 'I_cN) (f : {ffun 'I_cN -> cT}) : 0 <= cost i f.

Section costLemmas.
  Context {N rty T} `(CostAxiomClass N rty T).

  Lemma cost_nonneg i f : 0 <= cost i f.
  Proof. apply: cost_axiom. Qed.
End costLemmas.

Class MovesClass (mN : nat) (mT : finType) :=
  moves_fun : 'I_mN -> rel mT.
Notation "'moves'" := (@moves_fun _ _) (at level 50).

Class game (T : finType) (N : nat) (rty : realFieldType)
      `(costAxiomClass : CostAxiomClass N rty T)
       (movesClass : MovesClass N T)
  : Type := {}.

(***********************)
(** Negative cost game *)

Class NegativeCostAxiomClass cN rty cT `(CostClass cN rty cT) :=
  negative_cost_axiom (i : 'I_cN) (f : {ffun 'I_cN -> cT}) : cost i f <= 0.

Section negativeCostLemmas.
  Context {N rty T} `(NegativeCostAxiomClass N rty T).

  Lemma cost_neg i f : cost i f <= 0.
  Proof. apply: negative_cost_axiom. Qed.
End negativeCostLemmas.

Class negative_cost_game (T : finType) (N : nat) (rty : realFieldType)
      `(negativeCostAxiomClass : NegativeCostAxiomClass N rty T)
       (movesClass : MovesClass N T)
  : Type := {}.

(** End negative cost game *)
(***************************)

(****************)
(** Payoff game *)

Class PayoffClass (cN : nat) (rty : realFieldType) (cT : finType) :=
  payoff_fun : 'I_cN -> {ffun 'I_cN -> cT} -> rty.
Notation "'payoff'" := (@payoff_fun _ _ _) (at level 30).

Class PayoffAxiomClass cN rty cT `(PayoffClass cN rty cT) :=
  payoff_axiom (i : 'I_cN) (f : {ffun 'I_cN -> cT}) : 0 <= payoff i f.

Section payoffLemmas.
  Context {N rty T} `(PayoffAxiomClass N rty T).

  Lemma payoff_pos i f : 0 <= payoff i f.
  Proof. apply: payoff_axiom. Qed.
End payoffLemmas.

Class payoff_game (T : finType) (N : nat) (rty : realFieldType)
      `(payoffAxiomClass : PayoffAxiomClass N rty T)
       (movesClass : MovesClass N T)
  : Type := {}.

(** End payoff game *)
(********************)

(**************************************)
(** Payoff game -> negative cost game *)

Instance negativeCostInstance_of_payoffInstance
         N rty (T : finType)
         `(payoffInstance : @PayoffClass N rty T)
  : CostClass _ _ _ :=
  fun i f => - payoff i f.

(* 0 <= payoff -> cost <= 0 *)

Instance negativeCostAxiomInstance_of_payoffAxiomInstance
         N rty (T : finType)
         `(payoffAxiomInstance : PayoffAxiomClass N rty T) :
  NegativeCostAxiomClass (negativeCostInstance_of_payoffInstance _).
Proof.
  move=> i f. rewrite /cost_fun /negativeCostInstance_of_payoffInstance.
  rewrite /PayoffAxiomClass in payoffAxiomInstance.
    by rewrite oppr_le0.
Qed.

Instance negative_cost_game_of_payoff_game
         N rty (T : finType)
         `(_ : payoff_game T N rty)
  : negative_cost_game _ _ :=
  Build_negative_cost_game
    (@negativeCostAxiomInstance_of_payoffAxiomInstance
       N rty T _ payoffAxiomClass)
    _. (* payoffAxiomClass is an auto-generated name
          from using the ` thing *)

(******************************************)
(** End payoff game -> negative cost game *)

Local Open Scope ring_scope.

(** An arithmetic fact that should probably be moved elsewhere, and
    also generalized. *)
Lemma ler_mull (rty : realFieldType) (x y z : rty) (Hgt0 : 0 <= z) :
  x <= y -> z * x <= z * y.
Proof.
  move=> H.
  rewrite le0r in Hgt0. move: Hgt0 => /orP [Heq0|Hgt0].
  move: Heq0 => /eqP ->. by rewrite 2!mul0r.
  rewrite -ler_pdivr_mull=> //; rewrite mulrA.
  rewrite [z^(-1) * _]mulrC divff=> //; first by rewrite mul1r.
  apply/eqP=> H2; rewrite H2 in Hgt0.
  by move: (ltr0_neq0 Hgt0); move/eqP.
Qed.

(** The iff version of this was causing the apply tactic to hang
    in the gen_smooth proof for the location residual game. *)
Lemma ler_mull2 (rty : realFieldType) (x y z : rty) (Hgt0 : 0 < z) :
  z * x <= z * y -> x <= y.
Proof.
   move=> H. rewrite -ler_pdivr_mull in H=> //. rewrite mulrA in H.
  rewrite [z^(-1) * _]mulrC divff in H=> //. rewrite mul1r in H.
  apply H.
  apply/eqP=> H2; rewrite H2 in Hgt0.
  by move: (ltr0_neq0 Hgt0); move/eqP.
Qed.

(** A state is a finite function from player indices to strategies. *)
Definition state N T := ({ffun 'I_N -> T})%type.

Section payoffGameDefs.
  Context {T} {N} `(gameAxiomClassA : payoff_game T N).
  Definition Payoff (t : state N T) : rty := \sum_i (payoff i t).
End payoffGameDefs.

(** All equilibrium notions are parameterized by a [moves] relation
    (via the typeclass [Moveable T]). *)
Section gameDefs.
  Context {T} {N} `(gameAxiomClassA : game T N).

  (** We assume there's at least one strategy vector.
      (In fact, we assume two -- though they may equal one another.
       This makes it easier to state potentially conflicting assumptions on
       distinct uses of t0 and t1.*)
  Variable t0 : state N T.
  Variable t1 : state N T.

  Definition upd (i : 'I_N) :=
    [fun t : (T ^ N)%type =>
       [fun t_i' : T =>
          finfun (fun j => if i == j then t_i' else t j)]].

  (** [t] is a Pure Nash Equilibrium (PNE) if no player is better off
      by moving to another strategy. *)
  Definition PNE (t : state N T) : Prop :=
    forall (i : 'I_N) (t_i' : T),
      moves i (t i) t_i' -> cost i t <= cost i (upd i t t_i').

  (** PNE is decidable. *)
  Definition PNEb (t : state N T) : bool :=
    [forall i : 'I_N,
      [forall t_i' : T,
        moves i (t i) t_i' ==> (cost i t <= cost i (upd i t t_i'))]].

  Lemma PNE_PNEb t : PNE t <-> PNEb t.
  Proof.
    split.
    { move=> H1; apply/forallP=> x //.
      by apply/forallP=> x0; apply/implyP=> H2; apply: H1.
    }
    by move/forallP=> H1 x t' H2; apply: (implyP (forallP (H1 x) t')).
  Qed.

  Lemma PNEP t : reflect (PNE t) (PNEb t).
  Proof.
    move: (PNE_PNEb t).
    case H1: (PNEb t).
    { by move=> H2; constructor; rewrite H2.
    }
    move=> H2; constructor=> H3.
    suff: false by [].
    by rewrite -H2.
  Qed.

  (** The social Cost of a state is the sum of all players' costs. *)
  Definition Cost (t : state N T) : rty := \sum_i (cost i t).

  Lemma Cost_nonneg t : 0 <= Cost t.
  Proof. by apply: sumr_ge0 => i _; apply: cost_nonneg. Qed.

  (** A state is optimal if its social cost can't be improved. *)
  Definition optimal : pred (state N T) :=
    fun t => [forall t0, Cost t <= Cost t0].

  Lemma arg_min_optimal_eq : optimal (arg_min predT Cost t0).
  Proof.
    have Hx: predT t0 by [].
    case: (andP (@arg_minP _ _ predT Cost t0 Hx)) => Hy Hz.
    apply/forallP => t2; apply: (forallP Hz).
  Qed.

  (** The Price of Anarchy for game [T] is the ratio of WORST
      equilibrium social cost to optimal social cost. We want the
      ratio to be as close to 1 as possible. *)
  Definition POA : rty :=
    Cost (arg_max PNEb Cost t0) / Cost (arg_min predT Cost t1).

  (** The Price of Stability for game [T] is the ratio of BEST
      equilibrium social cost to optimal social cost. We want the
      ratio to be as close to 1 as possible. *)
  Definition POS : rty :=
    Cost (arg_min PNEb Cost t0) / Cost (arg_min predT Cost t1).

  Lemma POS_le_POA (H1 : PNEb t0) : POS <= POA.
  Proof.
    rewrite /POS /POA.
    move: (min_le_max Cost H1); rewrite /min /max=> H2.
    case Hx: (Cost (arg_min predT Cost t1) == 0).
    { by move: (eqP Hx) => ->; rewrite invr0 2!mulr0. }
    rewrite ler_pdivr_mulr=> //.
    move: H2 Hx; move: (Cost _)=> x; move: (Cost _)=> y.
    move: (Cost _)=> z Hx H2.
    have H3: (z = z / 1) by rewrite (GRing.divr1 z).
    rewrite {2}H3 mulf_div GRing.mulr1 -GRing.mulrA GRing.divff=> //.
    by rewrite GRing.mulr1.
    by apply/eqP => H4; rewrite H4 eq_refl in H2.
    move: (Cost_nonneg (arg_min predT Cost t1)); rewrite le0r; move/orP; case => //.
    by move/eqP => Hy; rewrite Hy eq_refl in Hx.
  Qed.

  (** The expected cost (to player [i]) of a particular distribution
      over configurations.  Note that the distribution [d] need not
      be a product distribution -- in order to define Coarse
      Correlated Equilibria (below), we allow player distributions to
      be correlated with one another. *)
  Definition expectedCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty) :=
    expectedValue d (cost i).

  Definition ExpectedCost (d : dist [finType of state N T] rty) :=
    \sum_(i : 'I_N) expectedCost i d.

  Lemma ExpectedCost_linear d :
    ExpectedCost d
    = expectedValue d (fun v => \sum_(i : 'I_N) (cost i v)).
  Proof.
    rewrite /ExpectedCost /expectedCost /expectedValue.
    by rewrite -exchange_big=> /=; apply/congr_big=> //= i _; rewrite mulr_sumr.
  Qed.

  Definition expectedCondCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty)
             (t_i : T) :=
    expectedCondValue
      d
      (fun t : state N T => cost i t)
      [pred tx : state N T | tx i == t_i].

  (** The expected cost of an i-unilateral deviation to strategy [t' i] *)
  Definition expectedUnilateralCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty)
             (t_i' : T) :=
    expectedValue d (fun t : state N T => cost i (upd i t t_i')).

  Lemma expectedUnilateralCost_linear d t' :
    \sum_(i < N) expectedUnilateralCost i d (t' i)
    = expectedValue d (fun t : state N T =>
                         \sum_(i : 'I_N) cost i (upd i t (t' i))).
  Proof.
    rewrite /expectedUnilateralCost /expectedValue.
    by rewrite -exchange_big=> /=; apply/congr_big=> //= i _; rewrite mulr_sumr.
  Qed.

  (** The expected cost of an i-unilateral deviation to strategy [t' i],
      conditioned on current i-strategy equal [t_i]. *)
  Definition expectedUnilateralCondCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty)
             (t_i t_i' : T) :=
    expectedCondValue
      d
      (fun t : state N T => cost i (upd i t t_i'))
      [pred tx : state N T | tx i == t_i].

  (** \epsilon-Approximate Correlated Equilibria
      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      The expected cost of a unilateral deviation to state (t' i),
      conditioned on current strategy (t i), is no greater than
       \epsilon plus the expected cost of distribution [d].

      NOTES:
      - [t' i] must be a valid move for [i] from [t i].
   *)
  Definition eCE (epsilon : rty) (d : dist [finType of state N T] rty) : Prop :=
    forall (i : 'I_N) (t_i t_i' : T),
      (forall t : state N T, t i = t_i -> t \in support d -> moves i t_i t_i') ->
      expectedCondCost i d t_i <= expectedUnilateralCondCost i d t_i t_i' + epsilon.

  Definition eCEb (epsilon : rty) (d : dist [finType of state N T] rty) : bool :=
    [forall i : 'I_N,
      [forall t_i : T,
        [forall t_i' : T,
          [forall t : state N T, (t i == t_i) ==> (t \in support d) ==> moves i t_i t_i']
          ==> (expectedCondCost i d t_i <= expectedUnilateralCondCost i d t_i t_i' + epsilon)]]].

  Lemma eCE_eCEb eps d : eCE eps d <-> eCEb eps d.
  Proof.
    split.
    { move=> H1; apply/forallP=> x; apply/forallP=> y; apply/forallP=> z; apply/implyP=> H2.
      apply: H1=> // t H3; move: H2; move/forallP/(_ t)/implyP => H4 H5.
      by rewrite H3 in H4; move: (H4 (eq_refl y)); move/implyP; apply.
    }
    move/forallP => H1 ix t_i t' H2.
    move: (forallP (H1 ix)); move/(_ t_i)/forallP/(_ t')/implyP; apply.
    apply/forallP => t''; apply/implyP; move/eqP => He; subst t_i.
    by apply/implyP => H4; apply: H2.
  Qed.

  Lemma eCEP eps d : reflect (eCE eps d) (eCEb eps d).
  Proof.
    move: (eCE_eCEb eps d); case H1: (eCEb eps d).
    by move=> H2; constructor; rewrite H2.
    by move=> H2; constructor; rewrite H2.
  Qed.

  Definition CE (d : dist [finType of state N T] rty) : Prop := eCE 0 d.

  Definition CEb (d : dist [finType of state N T] rty) : bool := eCEb 0 d.

  Lemma CE_CEb d : CE d <-> CEb d.
  Proof. apply: eCE_eCEb. Qed.

  Lemma CEP d : reflect (CE d) (CEb d).
  Proof. apply: eCEP. Qed.

  (** Mixed Nash Equilibria
      ~~~~~~~~~~~~~~~~~~~~~
      The expected cost of a unilateral deviation to state (t' i) is greater
      or equal to the expected cost of distribution [d].

      NOTES:
      - [d] must be a product distribution, of the form
        [d_0 \times d_1 \times ... \times d_{#players-1}].

      - [t'] must be a valid move for [i] from any state in the
        support of [d].
   *)
  Definition MNE (f : {ffun 'I_N -> dist T rty}) : Prop :=
    CE (prod_dist f).

  Definition MNEb (f : {ffun 'I_N -> dist T rty}) : bool :=
    CEb (prod_dist f).

  Lemma MNE_MNEb d : MNE d <-> MNEb d.
  Proof. by apply: CE_CEb. Qed.

  Lemma MNEP d : reflect (MNE d) (MNEb d).
  Proof. by apply: CEP. Qed.

  (** \epsilon-Approximate Coarse Correlated Equilibria
      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      The expected cost of a unilateral deviation to state (t' i) is no greater
       \epsilon plus the expected cost of distribution [d].

      NOTES:
      - [t' i] must be a valid move for [i] from any state in the
        support of [d].
   *)
  Definition eCCE (epsilon : rty) (d : dist [finType of state N T] rty) : Prop :=
    forall (i : 'I_N) (t_i' : T),
      (forall t : state N T, t \in support d -> moves i (t i) t_i') ->
      expectedCost i d <= expectedUnilateralCost i d t_i' + epsilon.

  Lemma ler_psum
     : forall (R : numDomainType) (I : Type) (r : seq I)
              (P Q : pred I) (F : I -> R),
       (forall i, 0 <= F i) ->
       (forall i : I, P i -> Q i) ->
       \sum_(i <- r | P i) F i <= \sum_(i <- r | Q i) F i.
  Proof.
    move => R I r P Q F Hpos Hx; elim: r; first by rewrite !big_nil.
    move => a l IH; rewrite !big_cons.
    case Hp: (P a).
    { rewrite (Hx _ Hp); apply: ler_add => //. }
    case Hq: (Q a) => //.
    rewrite -[\sum_(j <- l | P j) F j]addr0 addrC; apply ler_add => //.
  Qed.

  Lemma ler_psum_simpl
     : forall (R : numDomainType) (I : Type) (r : seq I)
              (P : pred I) (F : I -> R),
       (forall i, 0 <= F i) ->
       \sum_(i <- r | P i) F i <= \sum_(i <- r) F i.
  Proof.
    move => R I r P F Hpos.
    have ->: \sum_(i <- r) F i = \sum_(i <- r | predT i) F i.
    { apply: congr_big => //. }
    apply ler_psum => //.
  Qed.

  Definition eCCEb (epsilon : rty) (d : dist [finType of state N T] rty) : bool :=
    [forall i : 'I_N,
       [forall t_i' : T,
          [forall t : state N T, (t \in support d) ==> moves i (t i) t_i']
      ==> (expectedCost i d <= expectedUnilateralCost i d t_i' + epsilon)]].

  Lemma eCCE_eCCEb eps d : eCCE eps d <-> eCCEb eps d.
  Proof.
    split.
    { move=> H1; apply/forallP=> x; apply/forallP=> y; apply/implyP=> H2.
      by apply: H1=> // t H3; move: H2; move/forallP/(_ t)/implyP/(_ H3).
    }
    move/forallP=> H1 x y; move: (forallP (H1 x)); move/(_ y)/implyP=> H2.
    by move=> H3; apply: H2; apply/forallP=> x0; apply/implyP=> H4; apply: H3.
  Qed.

  Lemma eCCEP eps d : reflect (eCCE eps d) (eCCEb eps d).
  Proof.
    move: (eCCE_eCCEb eps d); case H1: (eCCEb eps d).
    by move=> H2; constructor; rewrite H2.
    by move=> H2; constructor; rewrite H2.
  Qed.

  (** Coarse Correlated Equilibria
      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      The expected cost of a unilateral deviation to state (t' i) is greater
      or equal to the expected cost of distribution [d].

      NOTES:
      - [t'] must be a valid move for [i] from any state in the
        support of [d].
   *)
  Definition CCE (d : dist [finType of state N T] rty) : Prop := eCCE 0 d.

  Lemma marginal_unfold (F : {ffun 'I_N -> T} -> rty) i :
    let P t (p : {ffun 'I_N -> T}) := p i == t in
    \sum_(p : [finType of (T * {ffun 'I_N -> T})] | P p.1 p.2) (F p.2) =
    \sum_(p : {ffun 'I_N -> T}) (F p).
  Proof.
    move => P.
    set (G (x : T) y := F y).
    have ->:
      \sum_(p | P p.1 p.2) F p.2 =
      \sum_(p | predT p.1 && P p.1 p.2) G p.1 p.2 by apply: eq_big.
    rewrite -pair_big_dep /= /G /P.
    have ->:
         \sum_i0 \sum_(j : {ffun 'I_N -> T} | j i == i0) F j =
    \sum_i0 \sum_(j : {ffun 'I_N -> T} | predT j && (j i == i0)) F j.
    { by apply: eq_big. }
    rewrite -partition_big //.
  Qed.

  Lemma sum1_sum (f : state N T -> rty) i :
    \sum_(ti : T) \sum_(t : state N T | [pred tx | tx i == ti] t) f t =
    \sum_t f t.
  Proof. by rewrite -(marginal_unfold f i) pair_big_dep //. Qed.

  Lemma CE_CCE d : CE d -> CCE d.
  Proof.
    move => Hx i t_i' H2; rewrite /CE in Hx; move: (Hx i).
    rewrite /expectedUnilateralCost /expectedUnilateralCondCost
            /expectedCost /expectedCondCost /expectedValue /expectedCondValue.
    move => Hy.
    rewrite addr0.
    have ->: \sum_t d t * (cost) i t =
             \sum_ti \sum_(t : state N T | [pred tx | tx i == ti] t) d t * (cost) i t.
    { by rewrite -(sum1_sum _ i). }
    have Hz:
      \sum_(ti : T) \sum_(t : state N T | [pred tx | tx i == ti] t) d t * (cost) i t <=
      \sum_(ti : T) (\sum_(t : state N T | [pred tx | tx i == ti] t) d t * (cost) i (upd i t t_i')).
    { apply: ler_sum => tx _ //.
      move: (Hy tx t_i'); rewrite addrC add0r / probOf => Hz; clear Hy.
      have Hw:
        (\sum_(t : state N T | [pred tx0 | tx0 i == tx] t) d t * (cost) i t) /
        (\sum_(t : state N T | [pred tx0 | tx0 i == tx] t) d t) <=
        (\sum_(t : state N T | [pred tx0 | tx0 i == tx] t) d t * (cost) i (((upd i) t) t_i')) /
        (\sum_(t : state N T | [pred tx0 | tx0 i == tx] t) d t).
      { apply: Hz => t <-; apply: H2. } clear Hz H2.
      move: Hw; move: [pred tx0 | _] => p.
      (*TODO: clean up and refactor this proof! *)
      case Heq: (\sum_(t : state N T | p t) d t == 0).
      { move: (eqP Heq) => Heq'.
        have: \sum_(t : state N T | p t) d t * (cost) i t = 0.
        { set (F t := d t * (cost) i t).
          have ->: \sum_(t : state N T | p t) d t * (cost) i t
                 = \sum_(t : state N T| p t) (F t).
          { apply: congr_big => //. }
          apply/eqP; rewrite psumr_eq0; last first.
          { move => ix; rewrite /F => _; apply: mulr_ge0; first by apply: dist_positive.
            apply: costAxiomClass. }
          apply/allP => t Hin; apply/implyP => Hp; apply/eqP; rewrite /F.
          rewrite psumr_eq0 in Heq => //=; last first.
          { move => ix _; apply: dist_positive. }
          by move: (allP Heq); move/(_ t)/(_ Hin)/implyP/(_ Hp)/eqP => ->; rewrite mul0r. }
        have: \sum_(t : state N T | p t) d t * (cost) i (((upd i) t) t_i') = 0.
        { set (F t := d t * (cost) i (((upd i) t) t_i')).
          have ->: \sum_(t : state N T | p t) d t * (cost) i (((upd i) t) t_i')
                 = \sum_(t : state N T| p t) (F t).
          { apply: congr_big => //. }
          apply/eqP; rewrite psumr_eq0; last first.
          { move => ix; rewrite /F => _; apply: mulr_ge0; first by apply: dist_positive.
            apply: costAxiomClass. }
          apply/allP => t Hin; apply/implyP => Hp; apply/eqP; rewrite /F.
          rewrite psumr_eq0 in Heq => //=; last first.
          { move => ix _; apply: dist_positive. }
          by move: (allP Heq); move/(_ t)/(_ Hin)/implyP/(_ Hp)/eqP => ->; rewrite mul0r. }
        move => -> -> //. }
      (* \sum_(t | p t) d t > 0 *)
      have Hgt: \sum_(t : state N T | p t) d t > 0.
      { rewrite ltr_def; apply/andP; rewrite Heq; split => //.
        apply: sumr_ge0 => ix _; apply: dist_positive. }
      move: Hgt.
      move: (\sum_(t : state N T | _) d t * _) => x.
      move: (\sum_(t : state N T | _) d t * _) => y.
      move: (\sum_(t : state N T | _) d t) => r.
      rewrite mulrC [_ / _]mulrC => H3.
      by apply: ler_mull2; rewrite invr_gte0. }
    apply: ler_trans.
    { apply: Hz; move => t <- Hs; apply: H2. }
    have ->:
      \sum_t d t * (cost) i (((upd i) t) t_i') =
      \sum_ti \sum_(t : state N T | [pred tx | tx i == ti] t)
         d t * (cost) i (((upd i) t) t_i').
    { by rewrite -(sum1_sum _ i). }
    by [].
  Qed.

  Lemma CCE_elim (d : dist [finType of state N T] rty) (H1 : CCE d) :
    forall (i : 'I_N) (t_i' : T),
    (forall t : state N T, t \in support d -> moves i (t i) t_i') ->
    expectedCost i d <= expectedUnilateralCost i d t_i'.
  Proof.
    rewrite /CCE /eCCE in H1 => i t' H2.
    by move: (H1 i t' H2); rewrite addr0.
  Qed.

  Definition CCEb (d : dist [finType of state N T] rty) : bool := eCCEb 0 d.

  Lemma CCE_CCEb d : CCE d <-> CCEb d.
  Proof. apply: eCCE_eCCEb. Qed.

  Lemma CCEP d : reflect (CCE d) (CCEb d).
  Proof. apply: eCCEP. Qed.
End gameDefs.

Section PNE_implies_MNE.
  Context {T} {N} `(gameAxiomClassA : game T N) {t0:T}.

  (** Product with a zero is equal to 0 *)
  (*  May be much more general *)
  Lemma exists0_prod0:
    forall (f : 'I_N -> rty),
    (exists i0:'I_N, (f i0 = 0)%R) -> (\prod_(i < N) f i)%R = 0%R.
  Proof.
  move=> f Hexists.
  have [i Hi] := Hexists.
  rewrite (bigD1 i) => //=.
  by rewrite Hi mul0r.
  Qed.

  (** State equality = vector equality *)
  (*  May be much more general *)
  Lemma eq_stateE:
    forall (t st : state N T),
    t == st <-> (forall i : 'I_N, t i == st i).
  Proof.
  move=>t st; split=> Hst.
  { move/eqP/ffunP in Hst.
    by move=> i; rewrite Hst.
  }
  { by apply/eqP/ffunP=> i; apply/eqP; rewrite Hst.
  }
  Qed.

  Lemma eq_stateP:
    forall (t st : state N T),
    reflect (t == st)
            [forall i : 'I_N, t i == st i].
  Proof.
  move=>t st; apply/iffP.
  + exact: forallP.
  + by rewrite -eq_stateE.
  + by rewrite -eq_stateE.
  Qed.

  (** State inequality == vector inequality *)
  (*  May be much more general *)
  Lemma neq_stateE:
    forall (t st : state N T),
    t != st <-> (exists i: 'I_N, t i != st i).
  Proof.
  move=>t st.
  split.
  + move/negP/eq_stateP; exact/existsP.
  + move=> Hexi; exact/negP/eq_stateP/existsP.
  Qed.

  Lemma neq_stateP:
    forall (t st : state N T),
    reflect [exists i : 'I_N, t i != st i]
            (t != st).
  Proof.
  move=> t st.
  case (boolP (t != st)) => /= Ht; constructor.
  + by apply/existsP; move: Ht; rewrite neq_stateE.
  + apply/negP.
    rewrite negb_exists.
    apply/forallP => x.
    apply/negP.
    move: Ht.
    move/negP.
    apply/impliesPn.
    apply: Implies => Htx.
    rewrite neq_stateE.
    by exists x.
  Qed.

  (** Dirac probability distribution == Dirac delta function *)
  (* Could be generalized *)
  Definition dirac_dist (st : state N T) (n : 'I_N) :
    {ffun T -> rty } :=
    finfun (fun (x:T)=> if x == (st n) then 1%R else 0%R).

  (** Equal to one when evaluated with (st n) *)
  Lemma dirac_dist_eq1R:
    forall (st : state N T) (n : 'I_N),
    (dirac_dist st n) (st n) = 1%R.
  Proof.
  by move=>st n; rewrite /dirac_dist ffunE eqxx.
  Qed.

  (** Equal to zero when evaluated with x != (st n) *)
  Lemma dirac_dist_eq0R:
    forall (st:state N T) (n : 'I_N) (x : T),
    x != st n -> (dirac_dist st n) x = 0%R.
  Proof.
  move=>st n x IHx.
  by rewrite /dirac_dist ffunE ifN_eq.
  Qed.

  Lemma dirac_dist_sum_eq0R:
    forall (st : state N T) (n : 'I_N) ,
    (\sum_(i | i != st n) (dirac_dist st n) i)%R = 0%R.
  Proof.
  move=>st n.
  transitivity (\sum_(i in T | i != st n) (0:rty))%R.
  + apply: eq_bigr; exact: dirac_dist_eq0R.
  + by rewrite big_const iter_add_const mul0rn.
  Qed.

  (** Distribution axiom : any >= 0 /\ sum = 1 *)
  Lemma dirac_dist_axiom (st : state N T) (n : 'I_N) :
    dist_axiom (dirac_dist st n).
  Proof.
  rewrite /dist_axiom; apply/andP; split.
  + apply/eqP.
    rewrite (bigD1 (st n)) => //=.
    by rewrite dirac_dist_eq1R dirac_dist_sum_eq0R addr0.
  + apply/forallP=> t.
    rewrite /dirac_dist ffunE.
    by case (t == st n) => //=; rewrite ler01.
  Qed.

  (** Dirac distribution = Dirac delta function *)
  Definition diracDist st n : dist T rty :=
    mkDist (dirac_dist_axiom st n).

  (** Only 'st' is in Dirac_dist's support *)
  (*  -> useful for moves_t_eq_st lemma *)
  Lemma in_support_ddistP:
    forall (t st : state N T),
    reflect
    (t \in support (prod_dist [ffun x => diracDist st x]))
    (t == st).
  Proof.
  move=>t st.
  case (boolP (t == st)) => Ht //=.
  { constructor.
    apply/supportP.
    rewrite /prod_dist /prod_pmf ffunE.
    rewrite (eq_big xpredT (fun x => diracDist st x (t x))) => //=.
    + move/eqP in Ht.
      rewrite Ht (eq_big xpredT (fun _ => 1%R)) => //=.
      - by rewrite prod_eq1 ltr01.
      - move=> i Htrue.
        by rewrite dirac_dist_eq1R.
    + move=>i Htrue.
      by rewrite ffunE.
  }
  { constructor.
    apply/supportP.
    rewrite /prod_dist /prod_pmf ffunE exists0_prod0.
    + by rewrite ltrr.
    + have th: (exists i0 : 'I_N, t i0 != st i0) by rewrite -neq_stateE.
      move: th.
      case=> i Hexists //=.
      exists i.
      rewrite ffunE /diracDist => //=.
      by rewrite dirac_dist_eq0R.
  }
  Qed.

  Lemma in_support_ddistE:
    forall (t st : state N T),
    (t \in support (prod_dist [ffun x => diracDist st x]))
    <->
    (t == st).
  Proof. by move=>t st; split; move/in_support_ddistP. Qed.

  (** A product of Dirac distributions is equal to one when evaluated
      with 'st' *)
  Lemma prod_ddist_eq1:
    forall (st : state N T),
    (prod_pmf [ffun x => diracDist st x]) st = 1%R.
  Proof.
  move=> st.
  rewrite /prod_pmf ffunE.
  rewrite (eq_big xpredT (fun x => diracDist st x (st x))) => //=.
  { rewrite /diracDist /dirac_dist => //=.
    rewrite (eq_big xpredT (fun x => 1%R)) => //=.
    + by rewrite prod_eq1.
    + by move=>i Htrue; rewrite ffunE eqxx.
  }
  { by move=>i Htrue; rewrite ffunE.
  }
  Qed.

  (** A product of Dirac distributions is equal to zero when evaluated
      with x != st *)
  Lemma prod_ddist_eq0:
    forall (t st : state N T),
    t != st ->
    (prod_pmf [ffun x => diracDist st x]) t = 0%R.
  Proof.
  move=> t st Ht.
  rewrite /prod_pmf ffunE.
  rewrite (eq_big xpredT (fun x=> diracDist st x (t x))) =>//=.
  + rewrite exists0_prod0 => //=.
    have th: (exists i0 : 'I_N, t i0 != st i0) by rewrite -neq_stateE.
    move: th.
    case => i Hexists //=.
    exists i.
    by rewrite dirac_dist_eq0R.
  + move=>i Htrue.
    by rewrite ffunE.
  Qed.

  (** Condition for PNE and MNE are equal when we use diracDist st*)
  Lemma moves_t_eq_st:
    forall (st : state N T) (i : 'I_N) (t_i' : T),
    (forall t : state N T,
      t i = st i ->
      t \in support (prod_dist [ffun x => diracDist st x]) ->
      (moves) i (st i) t_i')
    <->
    (moves) i (st i) t_i'.
  Proof.
  move=> st i t_i'.
  split=>//.
  { move/(_ st erefl).
    rewrite in_support_ddistE eqxx; exact.
  }
  Qed.

  (** Sub-proof for:
      - prod_ddist_eccost_eq_cost
      - prod_ddist_euccost_eq_costupd *)
  (* TODO: shorten or subdivide proof *)
  Lemma _prod_ddist_cost_eqcost:
    forall (st : state N T) (i : 'I_N) a_cost,
    ((\sum_(t : state N T | [pred tx | tx i == st i] t)
       (prod_dist [ffun x => diracDist st x]) t * a_cost t)
     /
     probOf
     (prod_dist [ffun x => diracDist st x])
     [pred tx : state N T | tx i == st i])%R
    =
    a_cost st.
  Proof.
  move=> st i a_cost.
  rewrite (bigD1 (st)) => //=.
  rewrite prod_ddist_eq1.
  have th2:
    (\sum_(t : state N T | (t i == st i) && (t != st))
     (prod_pmf [ffun x => diracDist st x]) t * (a_cost t)
    =
    0)%R.
  { transitivity (\sum_(t:state N T | (t i == st i) && (t != st))
                   (0:rty))%R.
    + rewrite big_mkcond => //=.
      rewrite (eq_big xpredT (fun _ => 0%R)) => //=.
      - by rewrite sum_eq0 sum_pred_eq0.
      - move=> t Htrue.
        case (boolP (t i == st i)) => Hti //=.
        case (boolP (t != st)) => Ht //=.
        rewrite prod_ddist_eq0.
          by rewrite mulrC mulr0.
        by rewrite Ht.
    + by rewrite sum_pred_eq0.
  }
  rewrite th2.
  have th3: (probOf (prod_dist [ffun x => diracDist st x])
                    [pred tx : state N T | tx i == st i])%R
             =
             1%R.
  { rewrite /probOf.
    rewrite (bigD1 st) => //=.
    + rewrite prod_ddist_eq1 (eq_bigr (fun _ => 0%R)).
      by rewrite sum_pred_eq0 addr0.
    + move=>t.
      case (t i == st i) => //= Ht.
      by rewrite prod_ddist_eq0 => //=.
  }
  rewrite th3.
  rewrite addr0.
  rewrite (mulrC 1%R (a_cost _)).
  rewrite -mulrA  mulrC divff.
    by rewrite mulrC mulr1.
  by rewrite oner_neq0.
  Qed.

  (** Cost and expectedCondCost of dirac distribution are equal *)
  Lemma prod_ddist_eccost_eq_cost:
    forall (st : state N T) (i : 'I_N),
    expectedCondCost i
           (prod_dist [ffun x => diracDist st x]) (st i)
    =
    cost i st.
  Proof.
  move=> st i.
  by rewrite /expectedCondCost /expectedCondValue _prod_ddist_cost_eqcost.
  Qed.

  (** Cost of updated state and expectedUnilateralCondCost of Dirac
      distribution are equal *)
  Lemma prod_ddist_euccost_eq_costupd:
    forall (st : state N T) (i : 'I_N) (t_i' : T),
    (expectedUnilateralCondCost i
            (prod_dist [ffun x => diracDist st x]) (st i) t_i' + 0
    = cost i (((upd i) st) t_i') )%R.
  Proof.
  move=>st i t_i'.
  rewrite /expectedUnilateralCondCost /expectedCondValue.
  by rewrite _prod_ddist_cost_eqcost addr0.
  Qed.

  (** Sub-proof for :
      - expectedCondCost_eq0
      - expectedUnilateralCondCost_eq0 *)
  (* Remark: provable with GRing.Theory even when a_prob == 0 *)
  Lemma _prod_ddist_cost_eq0:
    forall (st : state N T) (i : 'I_N) (t_i : T) a_cost a_prob,
    (t_i != st i)
    ->
    ((\sum_(t : state N T | [pred tx | tx i == t_i] t)
       (prod_dist [ffun x => diracDist st x]) t *
      (a_cost t)) / a_prob)%R
    =
    0%R.
  Proof.
  move=> st i t_i a_cost a_prob Hti.
  rewrite (eq_bigr (fun _ => 0%R)) => //=.
  + by rewrite mulrC sum_pred_eq0 mulr0.
  + move=>t Hti2.
    move/eqP in Hti2.
    rewrite -Hti2 in Hti.
    rewrite /prod_pmf /prod_dist ffunE => //=.
    rewrite exists0_prod0.
    - by rewrite mulrC mulr0.
    - exists i.
      rewrite /diracDist ffunE => //=.
      by rewrite dirac_dist_eq0R.
  Qed.

  (** The cost of (t i), t != st is equal to zero *)
  Lemma expectedCondCost_eq0:
    forall (st : state N T) (i : 'I_N) (t_i : T),
    (t_i != st i)
    ->
    (expectedCondCost
     i (prod_dist [ffun x => diracDist st x]) t_i = 0)%R.
  Proof.
  move=> st i t_i Hti.
  rewrite /expectedCondCost /expectedCondValue.
  by rewrite _prod_ddist_cost_eq0.
  Qed.

  Lemma expectedUnilateralCondCost_eq0:
    forall (st : state N T) (i : 'I_N) (t_i t_i' : T),
     (t_i != st i)
    ->
    (expectedUnilateralCondCost
     i (prod_dist [ffun x => diracDist st x]) t_i t_i' = 0)%R.
  Proof.
  move=> st i t_i t_i' Hti.
  rewrite /expectedUnilateralCondCost /expectedCondValue.
  by rewrite _prod_ddist_cost_eq0.
  Qed.

  (** Every PNE is a MNE of a corresponding Dirac distribution *)
  Lemma PNE_MNE:
    forall (st: state N T),
    PNE st -> MNE (finfun (diracDist st)).
  Proof.
  move=> st Hpne i t_i t_i'.
  case (boolP (t_i == st i)) => Hti //=.
  { move/eqP in Hti.
    rewrite Hti.
    move/ moves_t_eq_st.
    rewrite prod_ddist_eccost_eq_cost.
    rewrite prod_ddist_euccost_eq_costupd.
    exact: Hpne.
  }
  { move=> Hforall.
    rewrite expectedCondCost_eq0 => //=.
    rewrite expectedUnilateralCondCost_eq0 => //=.
    by rewrite addr0 lerr.
  }
  Qed.

End PNE_implies_MNE.


Require Import String Morph Var.

Inductive context {A : Set} : Set :=
| ctx_empty
| ctx_cons (Γ : @context A) (a : name) (val : A).

Notation "Γ & x ~ A" := (ctx_cons Γ x A) (at level 50).

Fixpoint has {A} (ctx : @context A) (x : @var 0) (a : A) :=
  match ctx with
  | ctx_empty => False
  | ctx_cons ctx y b =>
    match bindv (closev y x) with
    | None => b = a
    | Some x' => has ctx x' a
    end
  end.

Notation "Γ ∋ x ~ a" := (has Γ x a) (at level 60).

Hint Extern 2 (?Γ ∋ ?x ~ ?a) =>
  solve [cbn; easy] : contexts.

(* TODO this should be done with a renaming now *)
Lemma has_swap {A : Set} {Γ : @context A} {x a y b} :
  distinct_names x y ->
  forall z c,
    ((Γ & y ~ b) & x ~ a) ∋ z ~ c ->
    ((Γ & x ~ a) & y ~ b) ∋ z ~ c.
Proof.
  intros H z c; cbn.
  destruct (compare_vars x z) as [|z'];
    autorewrite with rw_vars; cbn.
  - rewrite (substv_distinct (distinct_names_symmetric H)).
    autorewrite with rw_vars; easy.
  - destruct (compare_vars y z').
    + autorewrite with rw_vars; cbn.
      rewrite rw_shift_name_distinct by easy.
      autorewrite with rw_vars; easy.
    + autorewrite with rw_vars.
      rewrite swap_shiftv_shiftv_distinct by easy.
      autorewrite with rw_vars; easy.
Qed.

Definition forall_has {A : Set} Γ (P : var -> A -> Prop) :=
  (forall x a, Γ ∋ x ~ a -> P x a).

Hint Unfold forall_has.

Lemma forall_has_cons {A : Set} {Γ : @context A}
      {P : var -> A -> Prop} {x a} :
  P (free x) a ->
  forall_has Γ (fun y b => P (shiftv x y) b) ->
  forall_has (Γ & x ~ a) P.
Proof.
  intros Hp Hf y b.
  destruct (compare_vars x y);
    cbn; autorewrite with rw_vars; cbn;
      intros; subst; auto.
Qed.

Lemma forall_has_map {A : Set} {Γ : @context A}
      {P Q : var -> A -> Prop} :
  forall_has Γ P ->
  (forall x a, P x a -> Q x a) ->
  forall_has Γ Q.
Proof.
  unfold forall_has.
  auto.
Qed.

Inductive relates {trm A : Set}
  : @context A -> @renaming trm -> @context A -> Prop :=
  | relates_intro :
      forall (Γ Δ : @context A) (s : @renaming trm)
             (total : total s),
        forall_has Γ (fun v a => has Δ (applyt s total v) a) ->
        relates Γ s Δ.

Definition relates_total {trm A : Set}
           {Γ Δ : @context A} {r : @renaming trm}
           (rl : relates Γ r Δ) :=
  match rl with
  | relates_intro _ _ _ rn _ => rn
  end.

Definition relates_contexts {trm A : Set}
           {Γ Δ : @context A} {r : @renaming trm}
           (rl : relates Γ r Δ) :=
  match rl in relates Γ r' Δ return
    (forall v a, has Γ v a ->
                 has Δ (applyt r' (relates_total rl) v) a) with
  | relates_intro _ _ _ _ cs => cs
  end.

Hint Resolve relates_total relates_contexts : contexts.

Notation "Γ =[ r ]=> Δ" :=
  (relates Γ (r)%ren Δ) (at level 60).

Lemma ctx_shift {trm A : Set} :
  forall Γ Δ x (a : A) (r : @renaming trm),
    Γ =[r]=> Δ ->
    Γ =[r,, ^x]=> (Δ & x ~ a).
Proof.
  intros * H.
  destruct H as [? ? r rn H].
  apply relates_intro with (s := (r,, ^x)%ren) (total := rn).
  apply (forall_has_map H); intros y b.
  cbn; autorewrite with rw_vars rw_names.
  auto.
Qed.

Lemma ctx_rename {trm A : Set} :
  forall Γ Δ x y (a : A) (r : @renaming trm),
    Γ =[r]=> Δ ->
    (Γ & x ~ a) =[r,, y <- x]=> (Δ & y ~ a).
Proof.
  intros * H.
  destruct H as [? ? r rn H].
  apply relates_intro
    with (s := (r,, y <- x)%ren) (total := rn); cbn.
  apply forall_has_cons;
    autorewrite with rw_vars rw_names; cbn; auto.
  apply (forall_has_map H); intros z c.
  autorewrite with rw_vars rw_names; auto.
Qed.

Lemma ctx_id {trm A : Set} :
  forall (Γ : @context A), Γ =[(r_id : @renaming trm)]=> Γ.
Proof.
  intros.
  apply relates_intro with (total := I).
  easy.
Qed.

Hint Resolve ctx_shift ctx_rename ctx_id : contexts.

Lemma relates_swap_right {trm A : Set} {Γ Δ : @context A}
      {x a y b} {r : @renaming trm}:
  distinct_names x y ->
  Γ =[r]=> Δ & y ~ b & x ~ a ->
  Γ =[r]=> Δ & x ~ a & y ~ b.
Proof.
  intros Heq H.
  inversion H as [? ? ? tl H']; subst.
  apply relates_intro with (total := tl).
  auto using has_swap.
Qed.

Lemma relates_swap_left {trm A : Set} {Γ Δ : @context A}
      {x a y b} {r : @renaming trm}:
  distinct_names y x ->
  Γ & y ~ b & x ~ a =[r]=> Δ ->
  Γ & x ~ a & y ~ b =[r]=> Δ.
Proof.
  intros Heq H.
  inversion H as [? ? ? tl H']; subst.
  apply relates_intro with (total := tl).
  auto using has_swap.
Qed.


Require Import Examples.AutoSep Examples.Malloc Examples.Sets.

Set Implicit Arguments.

Local Hint Extern 3 (himp _ _ _) => apply himp_star_frame.
Local Hint Extern 3 (himp _ _ _) => apply himp_star_frame_comm.

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

Module Type BST.
  Parameter bst' : set -> tree -> W -> HProp.
  Parameter bst : set -> W -> HProp.

  Axiom bst'_extensional : forall s t p, HProp_extensional (bst' s t p).
  Axiom bst_extensional : forall s p, HProp_extensional (bst s p).

  Axiom bst'_set_extensional : forall t s s' p, s %= s' -> bst' s t p ===> bst' s' t p.

  Axiom bst_fwd : forall s p, bst s p ===> [| freeable p 2 |]
    * Ex t, Ex r, Ex junk, p =*> r * (p ^+ $4) =*> junk * bst' s t r.
  Axiom bst_bwd : forall s p, ([| freeable p 2 |]
    * Ex t, Ex r, Ex junk, p =*> r * (p ^+ $4) =*> junk * bst' s t r) ===> bst s p.

  Axiom nil_fwd : forall s t (p : W), p = 0 -> bst' s t p ===> [| s %= empty /\ t = Leaf |].
  Axiom nil_bwd : forall s t (p : W), p = 0 -> [| s %= empty /\ t = Leaf |] ===> bst' s t p.

  Axiom cons_fwd : forall s t (p : W), p <> 0 -> bst' s t p ===>
    Ex t1, Ex t2, Ex p1, Ex v, Ex p2, (p ==*> p1, v, p2) * bst' (s %< v) t1 p1 * bst' (s %> v) t2 p2
    * [| freeable p 3 /\ t = Node t1 t2 /\ v %in s |].

  Axiom cons_bwd : forall s t (p : W), p <> 0 ->
    (Ex t1, Ex t2, Ex p1, Ex v, Ex p2, (p ==*> p1, v, p2) * bst' (s %< v) t1 p1 * bst' (s %> v) t2 p2
      * [| freeable p 3 /\ t = Node t1 t2 /\ v %in s |]) ===> bst' s t p.
End BST.

Module Bst : BST.
  Open Scope Sep_scope.

  Fixpoint bst' (s : set) (t : tree) (p : W) : HProp :=
    match t with
      | Leaf => [| p = 0 /\ s %= empty |]
      | Node t1 t2 => [| p <> 0 /\ freeable p 3 |] * Ex p1, Ex v, Ex p2, (p ==*> p1, v, p2)
        * bst' (s %< v) t1 p1
        * bst' (s %> v) t2 p2
        * [| v %in s |]
    end.

  Definition bst (s : set) (p : W) := [| freeable p 2 |]
    * Ex t, Ex r, Ex junk, p =*> r * (p ^+ $4) =*> junk * bst' s t r.

  Theorem bst'_extensional : forall s t p, HProp_extensional (bst' s t p).
    destruct t; reflexivity.
  Qed.

  Theorem bst_extensional : forall s p, HProp_extensional (bst s p).
    reflexivity.
  Qed.

  Theorem bst'_set_extensional : forall t s s' p, s %= s' -> bst' s t p ===> bst' s' t p.
    induction t; sepLemma.
  Qed.

  Theorem bst_fwd : forall s p, bst s p ===> [| freeable p 2 |]
    * Ex t, Ex r, Ex junk, p =*> r * (p ^+ $4) =*> junk * bst' s t r.
    unfold bst; sepLemma.
  Qed.

  Theorem bst_bwd : forall s p, ([| freeable p 2 |]
    * Ex t, Ex r, Ex junk, p =*> r * (p ^+ $4) =*> junk * bst' s t r) ===> bst s p.
    unfold bst; sepLemma.
  Qed.

  Theorem nil_fwd : forall s t (p : W), p = 0 -> bst' s t p ===> [| s %= empty /\ t = Leaf |].
    destruct t; sepLemma.
  Qed.

  Theorem nil_bwd : forall s t (p : W), p = 0 -> [| s %= empty /\ t = Leaf |] ===> bst' s t p.
    destruct t; sepLemma.
  Qed.

  Theorem cons_fwd : forall s t (p : W), p <> 0 -> bst' s t p ===>
    Ex t1, Ex t2, Ex p1, Ex v, Ex p2, (p ==*> p1, v, p2) * bst' (s %< v) t1 p1 * bst' (s %> v) t2 p2
    * [| freeable p 3 /\ t = Node t1 t2 /\ v %in s |].
    destruct t; sepLemma.
  Qed.

  Theorem cons_bwd : forall s t (p : W), p <> 0 ->
    (Ex t1, Ex t2, Ex p1, Ex v, Ex p2, (p ==*> p1, v, p2) * bst' (s %< v) t1 p1 * bst' (s %> v) t2 p2
    * [| freeable p 3 /\ t = Node t1 t2 /\ v %in s |]) ===> bst' s t p.
    destruct t; sepLemma;
      match goal with
        | [ H : Node _ _ = Node _ _ |- _ ] => injection H; sepLemma
      end.
  Qed.
End Bst.

Import Bst.
Export Bst.
Hint Immediate bst_extensional bst'_extensional.

(*TIME Clear Timing Profile. *)

Definition hints : TacPackage.
(*TIME idtac "tree-set:prepare1". Time *)
  prepare (bst_fwd, nil_fwd, cons_fwd) (bst_bwd, nil_bwd, cons_bwd).
(*TIME Time *)Defined.

Definition removeMaxS : spec := SPEC("prev") reserving 6
  Al s, Al t, Al p,
  PRE[V] V "prev" =*> p * [| p <> 0 |] * bst' s t p * mallocHeap
  POST[R] Ex t', Ex p', [| R %in s |] * [| s %> R %= empty |]
    * V "prev" =*> p' * bst' (s %- R) t' p' * mallocHeap.

Definition initS := initS bst 7.
Definition lookupS := lookupS bst 1.
Definition addS := addS bst 7.
Definition removeS := removeS bst 10.

Definition bstM := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "bst" {{
  bfunction "init"("r") [initS]
    "r" <-- Call "malloc"!"malloc"(0)
    [PRE[_, R] R =?> 2 * [| freeable R 2 |]
     POST[R'] [| R' = R |] * bst empty R ];;
    "r" *<- 0;;
    Return "r"
  end with bfunction "lookup"("s", "k", "tmp") [lookupS]
    "s" <-* "s";;

    [Al s, Al t,
      PRE[V] bst' s t (V "s") * mallocHeap
      POST[R] [| (V "k" %in s) \is R |] * bst' s t (V "s") * mallocHeap]
    While ("s" <> 0) {
      "tmp" <- "s" + 4;;
      "tmp" <-* "tmp";;
      If ("k" = "tmp") {
        (* Key matches! *)
        Return 1
      } else {
        If ("k" < "tmp") {
          (* Searching for a lower key *)
          "s" <-* "s"
        } else {
          (* Searching for a higher key *)
          "s" <- "s" + 8;;
          "s" <-* "s"
        }
      }
    };;
    Return 0
  end with bfunction "add"("s", "k", "tmp") [addS]
    "tmp" <-* "s";;
    [Al s, Al t,
      PRE[V] V "s" =*> V "tmp" * bst' s t (V "tmp") * mallocHeap
      POST[_] Ex t', Ex p', V "s" =*> p' * bst' (s %+ V "k") t' p' * mallocHeap]
    While ("tmp" <> 0) {
      "tmp" <- "tmp" + 4;;
      "tmp" <-* "tmp";;
      If ("k" = "tmp") {
        (* Key matches!  No need for changes. *)
        Return 0
      } else {
        "s" <-* "s";;
        If ("k" < "tmp") {
          (* Searching for a lower key *)
          Skip
        } else {
          (* Searching for a higher key *)
          "s" <- "s" + 8
        };;
        "tmp" <-* "s"
      }
    };;

    (* Found a spot for a new node.  Allocate and initialize it. *)

    "tmp" <-- Call "malloc"!"malloc"(1)
    [PRE[V, R] V "s" =?> 1 * R =?> 3
     POST[_] V "s" =*> R * (R ==*> $0, V "k", $0)];;
    "s" *<- "tmp";;
    "tmp" *<- 0;;
    "tmp" <- "tmp" + 4;;
    "tmp" *<- "k";;
    "tmp" <- "tmp" + 4;;
    "tmp" *<- 0;;
    Return 0
  end with bfunction "removeMax"("prev", "s", "tmp") [removeMaxS]
    "s" <-* "prev";;

    [Al s, Al t,
      PRE[V] [| V "s" <> 0 |] * V "prev" =*> V "s" * bst' s t (V "s") * mallocHeap
      POST[R] Ex t', Ex p', [| R %in s |] * [| s %> R %= empty |]
        * V "prev" =*> p' * bst' (s %- R) t' p' * mallocHeap ]
    While (1 = 1) {
      "tmp" <- "s" + 8;;
      "tmp" <-* "tmp";;

      If ("tmp" <> 0) {
        (* Right subtree is nonempty.  Keep looping. *)
        "prev" <- "s" + 8;;
        "s" <- "tmp"
      } else {
        (* Right subtree is empty.  We can free this node and return its key. *)

        (* Overwrite pointer into this node with its left subtree. *)
        "tmp" <-* "s";;
        "prev" *<- "tmp";;

        (* Save key. *)
        "tmp" <- "s" + 4;;
        "tmp" <-* "tmp";;

        (* Free node. *)
        Call "malloc"!"free"("s", 1)
        [PRE[V] Emp
         POST[R] [| R = V "tmp" |] ];;

        (* Return key. *)
        Return "tmp"
      }
    };;

    Fail (* Unreachable! *)
  end with bfunction "remove"("s", "k", "prev", "tmp") [removeS]
    "prev" <- "s";;
    "s" <-* "prev";;

    [Al s, Al t,
      PRE[V] V "prev" =*> V "s" * bst' s t (V "s") * mallocHeap
      POST[_] Ex t', Ex p', V "prev" =*> p' * bst' (s %- V "k") t' p' * mallocHeap ]
    While ("s" <> 0) {
      "tmp" <- "s" + 4;;
      "tmp" <-* "tmp";;

      If ("k" = "tmp") {
        (* Key matches!  Now the hard part: pulling another node's data value up here (if possible),
         * and then deleting this node. *)
        "tmp" <-* "s";;
        If (0 = "tmp") {
          (* Oh my goodness!  This test expression is a hack to prevent unfolding from firing!
           * (Since the provers don't understand symmetry of [<>]) *)

          (* Empty left subtree.  Promote the right subtree to this position. *)

          "tmp" <- "s" + 8;;
          "tmp" <-* "tmp";;
          "prev" *<- "tmp";;

          Call "malloc"!"free"("s", 1)
          [PRE[_] Emp
           POST[_] Emp ];;

          Return 0
        } else {
          "tmp" <- "s" + 8;;
          "tmp" <-* "tmp";;
          If (0 = "tmp") {
            (* Empty right subtree.  Promote the left subtree to this position. *)

            "tmp" <-* "s";;
            "prev" *<- "tmp";;

            Call "malloc"!"free"("s", 1)
            [PRE[_] Emp
             POST[_] Emp ];;

            Return 0
          } else {
            (* Both subtrees nonempty.  Remove minimum from right subtree and put it in this position. *)

            "tmp" <-- Call "bst"!"removeMax"("s")
            [PRE[V, R] (V "s" ^+ $4) =?> 1
             POST[_] (V "s" ^+ $4) =*> R];;

            "s" <- "s" + 4;;
            "s" *<- "tmp";;
            Return 0
          }
        }
      } else {
        If ("k" < "tmp") {
          (* Searching for a lower key *)
          Skip
        } else {
          (* Searching for a higher key *)
          "s" <- "s" + 8
        };;
        "prev" <- "s";;
        "s" <-* "prev"
      }
    };;

    (* Key not found!  So deletion is an easy no-op. *)
    Return 0
  end
}}.

Hint Rewrite Nat2N.id : N.

Lemma exhausted_cases : forall a b : W, a <> b
  -> ~(a < b)
  -> a > b.
  intros.
  assert (wordToN a <> wordToN b) by (generalize wordToN_inj; firstorder).
  nomega.
Qed.

Local Hint Resolve exhausted_cases.
Local Hint Extern 5 (@eq W _ _) => words.
Local Hint Extern 3 (himp _ _ _) => apply bst'_set_extensional.

Theorem bstMOk : moduleOk bstM.
(*TIME idtac "tree-set:verify". Time *)
  vcgen; abstract (sep hints; auto).
(*TIME Time *)Qed.

(*TIME Print Timing Profile. *)