(****************************************************************

   ACGT.v

   ...mathink

 ****************************************************************)

Require Import Arith.
Require Import List.

Set Implicit Arguments.

Notation "[ A ]" := (A::nil).
Notation "[ X , .. , Y ]" := (X:: .. (Y::nil) ..).

(*
   all_cons...

   a, (l1, l2, ... , ln) ~~> (a::l1, a::l2, ... , a::ln)
*)
Fixpoint all_cons (A: Set)(a: A)(ll: list (list A)) :=
  match ll with
    | h::t => (a::h)::(all_cons a t)
    | nil => nil
  end.

Lemma all_cons_length:
  forall (A: Set)(a: A) l ll,
    In l (all_cons a ll) -> 1 <= length l.
Proof.
  intros A a l ll.
  generalize a l; clear a l.
  elim ll; clear ll.
  simpl; intros; contradiction.
  simpl.
  intros l ll IH a l' [Heq | HIn].
  subst; simpl; auto with arith.
  apply IH with a; assumption.
Qed.

Lemma all_cons_In_gen:
  forall (A: Set)(a b: A) l ll,
    In (a::l) (all_cons b ll) -> a=b/\In l ll.
Proof.
  intros A a b l ll.
  elim ll; clear ll.
  simpl; intros; contradiction.
  simpl.
  intros hl ll IH [Heq | HIn].
  injection Heq; intros; subst; split;
    [reflexivity | simpl; left; reflexivity].
  split.
  destruct (IH HIn) as [Heq _]; assumption.
  right; destruct (IH HIn) as [_ H]; assumption.
Qed.

(* 出番がない *)
Lemma all_cons_In:
  forall (A: Set)(a: A) l ll,
    In (a::l) (all_cons a ll) -> In l ll.
Proof.
  intros.
  destruct (all_cons_In_gen _ _ _ _ H) as [_ HIn].
  assumption.
Qed.
(* *)

Lemma all_cons_In_inv:
  forall (A: Set)(a: A) l ll,
    In l ll -> In (a::l) (all_cons a ll).
Proof.
  intros A a l ll; elim ll; clear ll.
  simpl; intros; contradiction.
  simpl; intros hl ll IH [Heq | HIn].
  subst; left; reflexivity.
  right; apply IH; assumption.
Qed.

(*
   DNA_base...

   Adenine Cytosine Guanine Thymine
*)
Inductive base :=
| A | C | G | T.

Definition ACGT := [A,C,G,T].

Definition base_all_cons (ll: list (list base)) :=
  (all_cons A ll)++(all_cons C ll)++(all_cons G ll)++(all_cons T ll).

Lemma bac_length:
  forall l ll,
    In l (base_all_cons ll) -> 1 <= length l.
Proof.
  unfold base_all_cons.
  intros l ll HIn.
  repeat rewrite in_app_iff in HIn.
  destruct HIn as [HIn | [HIn | [HIn | HIn]]];
    generalize HIn; clear HIn; apply all_cons_length.
Qed.

(*
   generate...

   list of (list base) including all n-length list
   ...generate_correct
*)
Fixpoint generate (n: nat): list (list base) :=
  match n with
    | O => [nil]
    | 1 => [[A],[C],[G],[T]]
    | S p => base_all_cons (generate p)
  end.

Eval compute in (generate 2).
Eval compute in (length (generate 2)).

Lemma generate_length:
  forall n l,
    In l (generate n) -> length l = n.
Proof.
  intro n; elim n; clear n.
  simpl.
  intros l [Heq | F]; [subst; simpl; reflexivity | contradiction].
  intro n; case n; clear n.
  intros IH l [Heq | [Heq | [Heq | [Heq | F]]]]; subst; try contradiction;
    simpl; reflexivity.
  intros n IH l; case l; clear l.
  simpl.
  intro HIn.
  apply bac_length in HIn.
  elim (le_Sn_0 _ HIn).
  intros b l HIn.
  simpl.
  apply eq_S; apply IH.
  simpl in HIn; unfold base_all_cons in HIn.
  repeat rewrite in_app_iff in HIn.
  destruct HIn as [HIn | [HIn | [HIn | HIn]]];
    generalize HIn; clear HIn; case b; clear b;
      simpl; intro HIn;
        apply all_cons_In_gen in HIn;
          destruct HIn as [Heq HIn]; try discriminate;
            unfold base_all_cons; assumption.
Qed.

Lemma length_0_nil:
  forall (A: Set)(l: list A), length l = 0 -> l = nil.
Proof.
  intros A l; case l; clear l;
    [reflexivity | intros; discriminate].
Qed.

Lemma generate_all:
  forall n l,
    length l = n -> In l (generate n).
Proof.
  intro n; elim n; clear n.
  simpl.
  intros l Heq; apply length_0_nil in Heq; subst;
    left; reflexivity.
  intro n; case n; clear n.
  intros IH l; case l; clear l.
  simpl; intros; discriminate.
  simpl; intro b; case b; clear b;
    intros l Heq; apply eq_add_S in Heq; apply length_0_nil in Heq; subst;
      [left | right; left | right; right; left | right; right; right; left]; reflexivity.
  intros n IH l; case l; clear l.
  intros; discriminate.
  intros b l Heq; simpl in Heq.
  apply eq_add_S in Heq.
  apply IH in Heq.
  case b; clear b; simpl; unfold base_all_cons;
    repeat rewrite in_app_iff;
      [left | right; left | right; right; left | right; right; right];
      apply all_cons_In_inv; apply IH; apply generate_length; assumption.
Qed.

Theorem generate_correct:
  forall n l,
    In l (generate n) <-> length l = n.
Proof.
  intros n l; split;
    [apply generate_length | apply generate_all].
Qed.

(*
   nat_part...

   all partitions of n
   ..."nat_part_correct"
*)
Fixpoint nat_part_aux (n m: nat) :=
  match n with
    | O => [(n, m)]
    | S p => (n, m)::(nat_part_aux p (S m))
  end.

Eval compute in (nat_part_aux 2 5).

Definition nat_part (n: nat) := nat_part_aux n 0.

Eval compute in (nat_part 5).

Lemma nat_part_aux_trivial_In:
  forall n m,
    In (n, m) (nat_part_aux n m).
Proof.
  intro n; case n; clear n;
    simpl; left; reflexivity.
Qed.

Lemma nat_part_correct_aux:
  forall n m p q,
    n <= p ->
    n + m = p+q ->
    In (n, m) (nat_part_aux p q).
Proof.
  intros n m p q Hle;
    generalize m q; clear m q.
  elim Hle; clear Hle p.
  intros m q Heq.
  apply plus_reg_l in Heq; subst q.
  apply nat_part_aux_trivial_In.
  intros p Hle IH m q Heq.
  rewrite plus_Snm_nSm in Heq.
  simpl; right.
  apply (IH _ _ Heq).
Qed.

Lemma plus_le:
  forall n m p,
    n + m = p -> n <= p.
Proof.
  intros n m; generalize n; clear n.
  case m; clear m;
    simpl; intros; subst; auto with arith.
Qed.

Theorem nat_part_correct:
  forall n m p,
    n + m = p -> In (n, m) (nat_part p).
Proof.
  intros n m p Heq.
  apply nat_part_correct_aux.
  apply (plus_le _ _ Heq).
  rewrite plus_0_r; assumption.
Qed.

(*
   all_tupling...

   (a1, a2, ... , an), (b1, b2, ... bm) ~~>
   ((a1, b1), (a1, b2), ... , (a1, bm), (a2, b1), ... , (an, bm))
*)
Fixpoint tupling (A B: Set)(a: A)(l: list B) :=
  match l with
    | nil => nil
    | h::t => (a, h)::(tupling a t)
  end.

Fixpoint all_tupling (A B: Set)(al: list A)(bl: list B) :=
  match al with
    | nil => nil
    | h::t => (tupling h bl)++(all_tupling t bl)
  end.

Eval compute in (all_tupling (1::3::5::7::nil) (2::4::6::nil)).

Lemma tupling_In:
  forall (A B: Set)(a: A)(b: B) l,
    In b l ->
    In (a, b) (tupling a l).
Proof.
  intros A B a b l.
  generalize A a b;
    clear A a b.
  elim l; clear l; simpl.
  intros; contradiction.
  intros h l IH A a b [Heq | HIn].
  subst h; left; reflexivity.
  right; apply IH; assumption.
Qed.

Lemma all_tupling_In:
  forall (A B: Set)(a: A)(b: B) l1 l2,
    In a l1 ->
    In b l2 ->
    In (a, b) (all_tupling l1 l2).
Proof.
  intros A B a b l1.
  generalize B a b; clear B a b.
  elim l1; clear l1.
  simpl; intros; contradiction.
  simpl; intros h1 l1 IH B a b l2 [Heq | HIn1] HIn2.
  subst h1.
  apply in_app_iff; left.
  apply tupling_In; assumption.
  apply in_app_iff; right; apply IH; assumption.
Qed.

(*
   tuplist_generator_aux...

   all combinations of n-length list and m-length list
*)
Definition tuplist_generator_aux (n m: nat) :=
  all_tupling (generate n) (generate m).

Eval compute in (tuplist_generator_aux 2 2).

Lemma tuplist_generator_aux_all:
  forall n m l1 l2,
    length l1 = n ->
    length l2 = m ->
    In (l1, l2) (tuplist_generator_aux n m).
Proof.
  intros n m l1 l2 Heq1 Heq2.
  apply all_tupling_In;
    apply generate_correct; assumption.
Qed.

Check pair.

(*
   tuplist_generator_with_l...

   list of all combinations of ....
*)
Fixpoint tuplist_generator_with_l (l: list (prod nat nat)) :=
  match l with
    | nil => nil
    | (p, q)::t =>
      (tuplist_generator_aux p q)++(tuplist_generator_with_l t)
  end.

Lemma tuplist_generator_with_l_correct:
  forall n m l pl,
    In (n, m) pl->
    In l (tuplist_generator_aux n m) ->
    In l (tuplist_generator_with_l pl).
Proof.
  intros n m l pl;
    generalize n m l;
      clear n m l.
  elim pl; clear pl.
  simpl; intros; contradiction.
  simpl.
  intros [p q] pl IH n m [l1 l2] [Heq | HIn].
  injection Heq; intros; subst; clear Heq.
  apply in_app_iff; left; assumption.
  intros HIn'; apply in_app_iff;
    right; eapply IH; eassumption.
Qed.

Lemma tuplist_generator_correct_aux:
  forall n m p l l1 l2,
    length l1 = n ->
    length l2 = m ->
    n + m = p ->
    l = nat_part p ->
    In (l1, l2) (tuplist_generator_with_l l).
Proof.
  intros n m p l l1 l2 Heq1 Heq2 Heqp Heql.
  generalize (tuplist_generator_aux_all _ _ Heq1 Heq2).
  generalize (nat_part_correct _ _ Heqp).
  rewrite <- Heql.
  apply tuplist_generator_with_l_correct.
Qed.

(*
   tuplist_generator...

   all combinations of p-length list and q-length list, with p + q = n
*)
Definition tuplist_generator (n: nat) := tuplist_generator_with_l (nat_part n).

Eval compute in (tuplist_generator 3).

(*
   insert...

   l ___ l1 l2 ~~> l1 \\ l // l2
*)
Definition insert (A: Set)(l l1 l2: list A) := l1++l++l2.

Fixpoint insert_all (A: Set)(l: list A)(pll: list (list A*list A)) :=
  match pll with
    | nil => nil
    | (p,q)::t => (insert l p q)::(insert_all l t)
  end.

Eval compute in (insert_all ACGT (tuplist_generator 1)).

Lemma insert_all_app:
  forall (A: Set)(l: list A) l1 l2,
    insert_all l (l1++l2) = (insert_all l l1)++(insert_all l l2).
Proof.
  intros A l l1; elim l1; clear l1.
  simpl; reflexivity.
  intros [p1 p2] l1 IH l2.
  simpl.
  rewrite (IH l2); reflexivity.
Qed.

Lemma insert_In:
  forall (A: Set)(l1 l2: list A) pl,
    In (l1, l2) pl ->
    forall l,
      In (l1++l++l2) (insert_all l pl).
Proof.
  intros A l1 l2 pl;
    generalize l1 l2;
      clear l1 l2.
  elim pl; clear pl.
  simpl; intros; contradiction.
  intros [p q] pl IH l1 l2.
  simpl; intros [Heq | HIn].
  injection Heq; intros; subst p q.
  left; trivial.
  intros; right; apply IH.
  assumption.
Qed.

Lemma insert_tuplist_generator_correct:
  forall l l1 l2 pl,
    In (l1, l2) (tuplist_generator_with_l pl) ->
    In (l1++l++l2) (insert_all l (tuplist_generator_with_l pl)).
Proof.
  intros l l1 l2 pl;
    generalize l l1 l2;
      clear l l1 l2.
  elim pl; clear pl.
  simpl; intros; contradiction.
  intros [p q] pl IH l l1 l2.
  simpl (In (_,_) _); rewrite in_app_iff.
  intros [HIn | HIn].
  simpl.
  generalize (insert_In _ _ _ HIn l).
  rewrite insert_all_app.
  rewrite in_app_iff.
  left; assumption.
  simpl.
  rewrite insert_all_app.
  rewrite in_app_iff; right.
  apply IH; assumption.
Qed.

(*
   insert_generator...

   all lists of m-length lists including l (m = n + length l)
   ..."insert_generator_correct"
*)
Definition insert_generator (l: list base)(n: nat) :=
  insert_all l (tuplist_generator n).

Eval compute in (insert_generator ACGT 1).

Lemma insert_generator_correct_aux:
  forall n m l l1 l2,
    length l1 = n ->
    length l2 = m ->
    In (l1++l++l2) (insert_generator l (n+m)).
Proof.
  intros n m l l1 l2 Heq1 Heq2.
  unfold insert_generator.
  unfold tuplist_generator.
  apply insert_tuplist_generator_correct.
  apply (tuplist_generator_correct_aux _ _ Heq1 Heq2 (eq_refl _) (eq_refl _)).
Qed.

(*
   include...
*)
Definition include (A: Set)(l l': list A) :=
  exists l1, exists l2, l' = l1++l++l2.

Lemma include_length:
  forall (A: Set)(l l': list A),
    include l l' ->
    length l <= length l'.
Proof.
  intros A l l' [l1 [l2 Heq]]; subst.
  repeat rewrite app_length.
  rewrite plus_comm; simpl.
  auto with arith.
Qed.

Lemma le_plus:
  forall n p,
    n <= p -> exists m, n+m=p.
Proof.
  intros n p Hle.
  elim Hle; clear Hle p.
  exists 0; rewrite plus_0_r; reflexivity.
  intros p Hle [m Heq]; subst; exists (S m).
  rewrite <- (plus_Snm_nSm n m); simpl; reflexivity.
Qed.

Theorem insert_generator_correct:
  forall n l l',
    include l l' ->
    length l + n = length l' ->
    In l' (insert_generator l n).
Proof.
  intros n l l' Hinc.
  generalize Hinc;
    intros [l1 [l2 Heq]];
      apply include_length in Hinc.
  apply le_plus in Hinc.
  subst l'.
  destruct Hinc as [m Heq].
  intro Heq'.
  generalize (eq_trans Heq (eq_sym Heq')).
  intro Heq''.
  apply plus_reg_l in Heq''; subst n.
  clear Heq'.
  repeat rewrite app_length in Heq.
  rewrite (plus_comm (length l1) _) in Heq.
  rewrite <- plus_assoc in Heq.
  apply plus_reg_l in Heq.
  rewrite plus_comm in Heq.
  subst m.
  eapply insert_generator_correct_aux;
    reflexivity.
Qed.

(*
   AAG_generator
*)
Definition AAG := [A,A,G].
Definition AAG_generator (n: nat) := insert_generator AAG n.

Theorem AAG_generator_correct:
  forall n l,
    include AAG l ->
    3 + n = length l ->
    In l (AAG_generator n).
Proof.
  intros.
  apply insert_generator_correct;
    simpl; assumption.
Qed.

Eval compute in (AAG_generator 2).


Require Import Coq.Classes.Morphisms.
Require Import RamifyCoq.lib.Relation_ext.
Require Import RamifyCoq.lib.Equivalence_ext.
Require Export Coq.Lists.List.

Local Open Scope equiv_scope.

Section ListFun2.

Context {A B: Type}.
Context {RA: relation A}.
Context {RB: relation B}.
Context {EqRA: Equivalence RA}.
Context {EqRB: Equivalence RB}.

Instance proper_fold_left: forall (f: A -> B -> A) {Proper_f: Proper (equiv ==> equiv ==> equiv) f}, Proper (Forall2 equiv ==> equiv ==> equiv) (fold_left f).
Proof.
  intros.
  hnf; intros.
  induction H; hnf; intros; simpl.
  + auto.
  + apply IHForall2.
    apply Proper_f; auto.
Qed.

Lemma monoid_fold_left_tail: forall {f: A -> B -> A} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) a l,
  fold_left f (l ++ a :: nil) e === f (fold_left f l e) a.
Proof.
  intros.
  simpl.
  pose proof (proper_fold_left f).
  revert e; induction l; intros; simpl.
  + reflexivity.
  + apply IHl.
Qed.

End ListFun2.

Section ListFun1.

Context {A: Type}.
Context {RA: relation A}.
Context {EqRA: Equivalence RA}.

Lemma monoid_fold_left_head: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) a l,
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f (a :: l) e === f a (fold_left f l e).
Proof.
  intros.
  simpl.
  pose proof (proper_fold_left f).
  rewrite H.
  revert a; induction l; intros; simpl.
  + symmetry; auto.
  + rewrite (IHl (f a0 a)), H, (IHl a).
    rewrite H1.
    reflexivity.
Qed.

Lemma monoid_fold_symm: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) l,
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f l e === fold_right f e l.
Proof.
  intros.
  pose proof (proper_fold_left f).
  destruct l.
  + simpl.
    reflexivity.
  + simpl.
    rewrite H.
    revert a; induction l; intros; simpl.
    - symmetry; auto.
    - rewrite <- H1.
      apply IHl.
Qed.

Lemma monoid_fold_left_app: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) l l',
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f (l ++ l') e === f (fold_left f l e) (fold_left f l' e).
Proof.
  intros.
  rewrite fold_left_app.
  generalize (fold_left f l e) as a; clear l; intros.
  pose proof @monoid_fold_left_head f _ e a l'.
  simpl in H2.
  pose proof (proper_fold_left f).
  rewrite H in H2.
  auto.
Qed.

End ListFun1.


Theorem impl : forall A C, A /\ C -> C.
Proof.
  intros.
  inversion H.
  auto.
Defined.

Theorem impl2 : forall F S, F /\ S -> F.
Proof.
  intros.

  inversion H.
    intros.
  inversion H.
  exact H1.
exact H0.
Defined.

Theorem impl3 : forall (A B:Prop), A -> A \/ B.
  intros.
  left.
  exact H.
Defined.

Theorem ggg : forall (A B:Prop), A /\ B -> B /\ A.
Proof.
  intros.
  split.
  inversion H.
  exact H1.

  inversion H.
  exact H0.
Defined.

Theorem


Require Import mdp fixed_point pmf_monad FiniteType ListAdd Reals.
Require Import Coq.Lists.List LibUtils.
Require Import micromega.Lra. (*  qlearn. *)
Require Import micromega.Lia. (*  qlearn. *)
Require Import ClassicalDescription.
Require Import RealAdd LibUtilsListAdd EquivDec.
Require Import IndefiniteDescription ClassicalDescription.

Import ListNotations.
Set Bullet Behavior "Strict Subproofs".

Section bellmanQbar.
Open Scope R_scope.
Context {M : MDP} (γ : R).
Context (σ : dec_rule M) (init : M.(state)) (hγ : (0 <= γ < 1)%R).
Arguments reward {_}.
Arguments outcomes {_}.
Arguments t {_}.

Definition act_expt_reward : forall s : M.(state), M.(act) s -> R :=
  (fun s a => expt_value (t s a) (reward s a)).

Definition Qvalue : forall s: M.(state), (M.(act) s) -> R :=
  fun s a => act_expt_reward s a + γ*expt_value (t s a) (ltv γ σ).

Lemma Qvalue_expt_value : forall s a,
    Qvalue s a = expt_value (t s a) (fun s' => reward s a s' + γ*(ltv γ σ s')).
Proof.
  intros; unfold Qvalue.
  unfold act_expt_reward.
  rewrite <-expt_value_const_mul.
  now rewrite expt_value_add.
Qed.

Lemma ltv_Qvalue : ltv γ σ init = Qvalue init (σ init).
Proof.
  now rewrite ltv_corec.
Qed.

Definition bellmanQbar : Rfct (sigT M.(act)) -> Rfct (sigT M.(act))
  := fun W => fun sa => let (s,a) := sa in
                  act_expt_reward s a +
                  γ*expt_value (t s a)(fun s' => Max_{act_list s'}(fun a => W (existT _ s' a) ) ).

Definition bellmanQbar_expt_value : forall s a W,
    bellmanQbar W (existT _ s a) =
    expt_value (t s a) (fun s' => reward s a s' + γ*(Max_{act_list s'}(fun a => W (existT _ s' a)))).
Proof.
  intros; unfold bellmanQbar.
  unfold act_expt_reward.
  rewrite <-expt_value_const_mul.
  now rewrite expt_value_add.
Qed.

Lemma Rabs_helper : forall a b c : R, Rabs ( (a + b) + -(a + c)) = Rabs (b - c).
Proof.
  intros.
  f_equal. lra.
Qed.

Theorem is_contraction_bellmanQbar :
  @is_contraction (Rfct_UniformSpace (sigT M.(act))) (Rfct_UniformSpace (sigT M.(act)))
                  bellmanQbar.
Proof.
  unfold is_contraction.
  destruct (Req_EM_T γ 0).
  ++ unfold bellmanQbar.
     exists (1/2). split; [lra |].
     unfold is_Lipschitz. split;trivial;[lra |].
     destruct (fs M) as [ls ?].
     intros f g r Hr Hfgr.
     rewrite e. unfold ball_x,ball_y in *.
     simpl in *. unfold Rmax_ball,Rmax_norm in *.
     destruct act_finite as [acts ?].
     rewrite Rmax_list_lt_iff; intros ;
       try (apply map_not_nil; apply not_nil_exists ;
            exists (existT _ (ne M) ((na M) (ne M))); auto).
     rewrite in_map_iff in H.
     destruct H.
     unfold minus,plus,opp in H.
     destruct x0 as [s a].
     simpl in H. destruct H as [H1 H2].
     do 2 rewrite Rmult_0_l in H1.
     subst.
     apply Rabs_def1 ; ring_simplify.
     replace (0) with ((1/2)*0) by lra.
     apply Rmult_lt_compat_l; trivial; lra.
     rewrite Ropp_mult_distr_l_reverse.
     eapply Ropp_lt_gt_0_contravar with (r := (1/2)*r).
     replace (0) with ((1/2)*0) by lra.
     apply Rmult_lt_compat_l; trivial; lra.
  ++ exists γ ; split.
  - now destruct hγ.
  - unfold is_Lipschitz.
    unfold ball_x,ball_y. simpl.
    destruct (fs M) as [ls Hls].
    split.
    -- now destruct hγ.
    -- intros f g r Hr Hx.
       repeat red in Hx |-.
       unfold Rmax_ball, Rmax_norm.
       destruct (act_finite M) as [la Hla].
       rewrite Rmax_list_lt_iff; intros; try(apply map_not_nil; apply not_nil_exists).
       rewrite in_map_iff in H.
       destruct H as [sa [Q HQ]]; subst.
       unfold minus, plus, opp. simpl.
       unfold bellmanQbar; destruct sa. rewrite Rabs_helper.
       rewrite <-Rmult_minus_distr_l.
       rewrite Rabs_mult.
       assert (Hrγ : Rabs γ = γ) by (apply Rabs_pos_eq; lra). rewrite Hrγ.
       apply Rmult_lt_compat_l; try (destruct hγ; lra).
       rewrite <-expt_value_sub.
       eapply Rle_lt_trans; eauto.
       unfold Rmax_norm.
       eapply Rle_trans. apply expt_value_Rabs_Rle.
       apply expt_value_bdd; intro s0.
       unfold act_list.
       destruct (M s0).
       eapply Rle_trans. apply Rmax_list_minus_le_abs.
       rewrite Rmax_list_le_iff; try (rewrite map_not_nil).
       intros r'.
       rewrite in_map_iff; intros.
       destruct H as [a0 [Ha0 Helms]].
       subst. apply Rmax_spec.
       rewrite in_map_iff.
       exists (existT _ s0 a0); now split.
       rewrite not_nil_exists.
       generalize (na _ s0); intros a0; now exists a0.
       generalize (ne M); intros s0.
       generalize (na M); intros a0.
       specialize (a0 s0). now exists (existT _ s0 a0).
Qed.

Theorem isContraction_bellmanQbar_gamma (Hg : 0 < γ) :
  @is_Lipschitz (Rfct_NormedModule (sigT M.(act))) (Rfct_NormedModule (sigT M.(act)))
                                      bellmanQbar γ.
  Proof.
  unfold is_Lipschitz.
    unfold ball_x,ball_y. simpl.
    destruct (fs M) as [ls Hls].
    split.
    -- now destruct hγ.
    -- intros f g r Hr Hx.
       repeat red in Hx |-.
       unfold Rmax_ball, Rmax_norm.
       destruct (act_finite M) as [la Hla].
       rewrite Rmax_list_lt_iff; intros; try(apply map_not_nil; apply not_nil_exists).
       rewrite in_map_iff in H.
       destruct H as [sa [Q HQ]]; subst.
       unfold minus, plus, opp. simpl.
       unfold bellmanQbar; destruct sa. rewrite Rabs_helper.
       rewrite <-Rmult_minus_distr_l.
       rewrite Rabs_mult.
       assert (Hrγ : Rabs γ = γ) by (apply Rabs_pos_eq; lra). rewrite Hrγ.
       apply Rmult_lt_compat_l; try (destruct hγ; lra).
       rewrite <-expt_value_sub.
       eapply Rle_lt_trans; eauto.
       unfold Rmax_norm.
       eapply Rle_trans. apply expt_value_Rabs_Rle.
       apply expt_value_bdd; intro s0.
       unfold act_list.
       destruct (M s0).
       eapply Rle_trans. apply Rmax_list_minus_le_abs.
       rewrite Rmax_list_le_iff; try (rewrite map_not_nil).
       intros r'.
       rewrite in_map_iff; intros.
       destruct H as [a0 [Ha0 Helms]].
       subst. apply Rmax_spec.
       rewrite in_map_iff.
       exists (existT _ s0 a0); now split.
       rewrite not_nil_exists.
       generalize (na _ s0); intros a0; now exists a0.
       generalize (ne M); intros s0.
       generalize (na M); intros a0.
       specialize (a0 s0). now exists (existT _ s0 a0).
  Qed.

End bellmanQbar.

Section bellmanQ.
Open Scope R_scope.
Context {M : MDP} (γ : R).
Context (σ : dec_rule M) (init : M.(state)) (hγ : (0 <= γ < 1)%R).
Arguments reward {_}.
Arguments outcomes {_}.
Arguments t {_}.

Definition fun_inner_prod {A : Type} (f g : A -> R) (ls : list A) : R :=
  (list_sum (map (fun a => (f a)*(g a)) ls)).

Lemma fun_inner_prod_self {A : Type} (l : list A) (f : A -> R) :
  fun_inner_prod f f l = list_sum (map (fun a => Rsqr (f a)) l).
Proof.
  unfold fun_inner_prod.
  now apply list_sum_map_ext.
Qed.

Definition Rfct_inner {A : Type} (finA : FiniteType A) (f g : Rfct A) : R :=
  let (ls, _) := finA in fun_inner_prod f g ls.

Lemma Rfct_expt_inner {A B : Type} (finA : FiniteType A)
      (f : B -> Rfct A) (p : Pmf B):
  let (la, _) := finA in
  expt_value p (fun b => Rfct_inner _ (f b) (f b)) =
  list_sum (List.map (fun a => expt_value p (fun b => (f b a)*(f b a))) la).
Proof.
  unfold Rfct_inner.
  destruct finA.
  destruct p as [lp Hlp]. unfold expt_value.
  simpl. clear Hlp.
  revert lp.
  induction lp.
  + simpl. symmetry.
    apply list_sum_map_zero.
  + simpl. rewrite IHlp.
    rewrite list_sum_map_add.
    f_equal. rewrite Rmult_comm.
    unfold fun_inner_prod.
    rewrite <-list_sum_const_mul.
    f_equal. apply List.map_ext; intros.
    lra.
Qed.

Definition bellmanQ : Rfct(sigT M.(act)) -> M.(state) -> Rfct(sigT M.(act))
  := fun W => fun s' sa => let (s,a) := sa in
                  reward s a s' + γ*Max_{act_list s'}(fun a => W (existT _ s' a)).

(* Move this to somewhere nice.*)
Lemma expt_value_le_max {A : Type} (finA : FiniteType A) (p : Pmf A) (f : A -> R):
  let (la,_) := finA in
  expt_value p f <= Max_{la}(f).
Proof.
  destruct finA.
  apply expt_value_bdd.
  intros. apply Rmax_spec.
  rewrite List.in_map_iff.
  exists a. split; auto.
Qed.

Lemma Rmax_list_Rsqr_Rabs_1 {A : Type} (f : A -> R) (l : list A):
[] <> l -> Max_{l}(fun a => Rsqr (f a)) <= Max_{l}(fun a => Rsqr (Rabs (f a))).
Proof.
  intros Hn.
  apply Rmax_spec.
  rewrite in_map_iff.
  destruct (Rmax_list_map_exist (fun a => Rsqr (f a)) l Hn) as [a [Ha1 Ha2]].
  exists a.  rewrite <-Rsqr_abs.
  split; trivial.
Qed.

Lemma Rmax_list_Rsqr_Rabs_2 {A : Type} (f : A -> R) (l : list A):
  [] <> l -> Max_{l}(fun a => Rsqr (Rabs (f a))) <= Rsqr(Max_{l}(fun a => Rabs(f a))).
Proof.
  intros Hn.
  destruct (Rmax_list_map_exist (fun a => Rsqr (Rabs (f a))) l Hn) as [a [Ha1 Ha2]].
  rewrite <-Ha2.
  apply neg_pos_Rsqr_le; try (apply Rmax_spec ; rewrite in_map_iff ; exists a; split; trivial).
  replace (Rabs (f a)) with (- (- (Rabs (f a)))) by lra.
  apply Ropp_le_contravar.
  transitivity (Rabs (f a)) ; try (apply Rmax_spec ; rewrite in_map_iff ; exists a; split; trivial).
  rewrite Rminus_le_0.
  ring_simplify.
  apply Rmult_le_pos; try (left; apply Rlt_0_2).
  apply Rabs_pos.
Qed.

Lemma Rmax_list_Rsqr_Rabs_3 {A : Type} (f g : A -> R) (l : list A):
  [] <> l -> (Max_{l}(fun a => Rabs (f a + g a)))² <=
           (Max_{l}(fun a => Rabs(f a)) + Max_{l}(fun a => Rabs (g a)))².
Proof.
  intros Hn.
  apply Rsqr_incr_1; try (apply Rmax_list_map_nonneg).
  + apply Rmax_list_map_triangle.
  + intros a.
    apply Rabs_pos.
  + replace 0 with (0+0) by lra.
    apply Rplus_le_compat; apply Rmax_list_map_nonneg; intros; apply Rabs_pos.
Qed.

Lemma minus_Rsqr_le (a b : R):
  a - b² <= a.
Proof.
  rewrite <-Rminus_0_r.
  unfold Rminus. apply Rplus_le_compat_l.
  apply Ropp_le_contravar.
  rewrite Rsqr_pow2. apply pow2_ge_0.
Qed.

Definition summand_bound W := fun (s : M.(state)) a => let (ls,_) := fs M in
                      (Max_{ ls}(fun a0 : state M => Rabs ((fun _ : state M => act_expt_reward s a) a0)) +
     (Max_{ ls} (fun a0 : state M => Rabs ((fun a1 : state M => γ * (Max_{ act_list a1}(fun a2 : act M a1 => W (existT (act M) a1 a2)))) a0))))².

(* Proves that each individual summand is bounded. *)
Lemma summand_bounded W :
  forall (s : M.(state)) (a: M.(act) s),
    let (ls,_) := fs M in
    variance (t s a) (fun s' => act_expt_reward s a + γ*Max_{act_list s'} (fun a => W (existT _ s' a)))
             <= summand_bound W s a.
Proof.
  intros s a.
  unfold summand_bound.
  generalize (expt_value_le_max (fs M) (t s a)); intros.
  destruct (fs M) as [ls ?].
  assert (Hls: [] <> ls) by (apply not_nil_exists; exists (ne M); trivial).
  eapply Rle_trans; try apply variance_le_expt_value_sqr.
  eapply Rle_trans; try eapply H.
  eapply Rle_trans; try (eapply (Rmax_list_Rsqr_Rabs_1) ; trivial).
  eapply Rle_trans; try (eapply (Rmax_list_Rsqr_Rabs_2) ; trivial).
  eapply Rle_trans; try (eapply (Rmax_list_Rsqr_Rabs_3) ; trivial).
  right; trivial.
Qed.

  Lemma Rmax_list_map_add {A} (f g : A -> R) (l : list A):
    Max_{ l}(fun a : A => (f a + g a)) <=
    Max_{ l}(fun a : A => (f a)) + (Max_{ l}(fun a : A => (g a))).
  Proof.
    destruct (is_nil_dec l).
    - subst; simpl. lra.
    - rewrite Rmax_list_le_iff.
      intros x Hx. rewrite in_map_iff in Hx.
      destruct Hx as [a [Ha Hina]].
      rewrite <-Ha.
      apply Rplus_le_compat; try (apply Rmax_spec; rewrite in_map_iff; exists a; split ; trivial).
      rewrite map_not_nil.
      congruence.
  Qed.

  Lemma Rmax_list_map_indep {A} (l : list A) (c : R):
    Max_{l}(fun _ => c) = if is_nil_dec l then 0 else c.
  Proof.
    destruct (is_nil_dec l); try now subst.
    apply Rle_antisym.
    + rewrite Rmax_list_le_iff; try rewrite map_not_nil; try easy.
      intros x Hx. rewrite in_map_iff in Hx.
      destruct Hx as [x0 [Hx0 Hx0']].
      now subst. congruence.
    + apply Rmax_spec.
      rewrite in_map_iff.
      rewrite BasicUtils.ne_symm in n.
      rewrite not_nil_exists in n.
      destruct n as [x Hx].
      exists x; easy.
  Qed.

Lemma Rmax_list_const_add' {A}(l : list A) (f : A -> R) (d : R) :
    Rmax_list (List.map (fun x => f x + d) l) =
    if (is_nil_dec l) then 0 else ((Rmax_list (map f l)) + d).
Proof.
  destruct (is_nil_dec l); subst; try easy.
  induction l.
    - simpl; intuition reflexivity.
    - simpl in *.
      destruct l.
      + simpl ; reflexivity.
      + simpl in * ; rewrite IHl.
        now rewrite Rcomplements.Rplus_max_distr_r.
        rewrite BasicUtils.ne_symm. rewrite not_nil_exists.
        exists a0; simpl. now left.
  Qed.

Lemma Q_is_bounded W :
    let (ls, _) := fs M in
    let (las,_) := act_finite M in
    Max_{ls}(fun s' => Max_{las}(bellmanQ W s')) <= Max_{ ls}
  (fun s' : state M =>
   Max_{ las}(fun sa : {x : state M & act M x} => let (s, a) := sa in reward s a s')) + γ*Max_{las}(W).
Proof.
  destruct (fs M) as [states ?].
  destruct (act_finite M) as [stacts ?].
  unfold bellmanQ.
  assert (G1 : [] <> states) by (rewrite not_nil_exists; now exists (@ne M)).
  assert (H0 : [] <> stacts) by (rewrite not_nil_exists; now exists (existT _ (@ne M) (@na M (@ne M)))).
  assert (G2 : forall s : M.(state), [] <> act_list s) by (intros s; apply act_list_not_nil).
  assert (H1 : Max_{states} (fun s' =>
              Max_{stacts}(fun sa : {x : state M & act M x} => let (s,a):= sa in
                           reward s a s' + γ*(Max_{ act_list s' }(fun a => W(existT _ s' a))))) <=
               Max_{states} (fun s' => Max_{stacts}(fun sa : {x : state M & act M x} =>
                                                   let (s,a):= sa in reward s a s'))
              +  γ*( Max_{states}(fun s' => Max_{stacts}(fun sa => Max_{ act_list s' }(fun a => W(existT _ s' a)))))).
  {
    setoid_rewrite <-Rmax_list_map_const_mul; try lra.
    eapply Rle_trans.
    2: apply Rmax_list_map_add. simpl.
    apply Rmax_list_fun_le; intros s.
    setoid_rewrite Rmax_list_map_indep; trivial.
    destruct (is_nil_dec stacts); try subst. intuition.
    generalize  (γ *(Max_{ act_list s}
                         (fun a0 : act M s => W (existT (act M) s a0)))); intros.
    generalize (Rmax_list_map_add (fun sa : {x : state M & act M x} => let (s0, a) := sa in reward s0 a s) (fun _ => r) stacts); intros.
    rewrite (Rmax_list_map_indep) with (c := r) in H; trivial.
    match_destr_in H; simpl. intuition.
    eapply Rle_trans. 2: apply H.
    right. apply Rmax_list_map_ext.
    intros a.
    now destruct a.
  }
  eapply Rle_trans; eauto. clear H1.
  apply Rplus_le_compat.
  + now right.
  + apply Rmult_le_compat_l; try lra.
    setoid_rewrite Rmax_list_map_indep.
    match_destr; subst. intuition.
    apply Rmax_spec. rewrite in_map_iff.
    generalize (Rmax_list_map_exist (fun s' => Max_{ act_list s'}(fun a => W (existT _ s' a))) _ G1); intros.
    destruct H as [s0 [Hs0 Heq1]].
    generalize (Rmax_list_map_exist (fun a => W (existT _ s0 a)) _ (G2 s0)); intros.
    destruct H as [a [Ha1 Heq2]].
    exists (existT _ s0 a).
    rewrite <-Heq1. rewrite Heq2.
    split; trivial.
Qed.

Local Instance EqDecsigT : EqDec (sigT M.(act)) eq.
Proof.
  intros x y.
  apply ClassicalDescription.excluded_middle_informative.
Qed.

Definition bellmanQ' (sa0 : sigT M.(act)) : Rfct(sigT M.(act)) -> M.(state) -> Rfct(sigT M.(act))
  := fun W => fun s' sa => if (sa == sa0) then
                       let (s,a) := sa in
                       reward s a s' + γ*Max_{act_list s'}(fun a => W (existT _ s' a))
                       else W sa.

Definition bellmanQbar' (sa0 : sigT M.(act)) : Rfct (sigT M.(act)) -> Rfct (sigT M.(act))
  := fun W => fun sa => if (sa == sa0) then
                  let (s,a) := sa in
                  act_expt_reward s a +
                  γ*expt_value (t s a)(fun s' => Max_{act_list s'}(fun a => W (existT _ s' a)))
                  else let (s,a) := sa in W (existT _ s a).

(* This is w. *)
Definition stochasticBellmanQ' (sa0 : sigT M.(act)) :=
  fun W => fun s' sa => (bellmanQ' sa0 W s' sa - bellmanQbar' sa0 W sa).

(* Lemma 12 *)
Theorem expt_value_stochasticBellmanQ' W :
  forall (sa sa0 : sigT M.(act)),
    let (s,a) := sa in
    expt_value (t s a) (fun s' => stochasticBellmanQ' sa0 W s' sa) = 0.
Proof.
  intros.
  destruct sa.
  unfold stochasticBellmanQ'.
  rewrite expt_value_sub.
  rewrite expt_value_const.
  unfold bellmanQbar', bellmanQ'.
  match_destr.
  + rewrite expt_value_add.
    rewrite expt_value_const_mul. unfold act_expt_reward. lra.
  + rewrite expt_value_const; lra.
Qed.

 Theorem expt_value_bellmanQbar sa0 W :
   forall sa : sigT M.(act), let (s,a) := sa in
                        expt_value (t s a) (fun a0 : state M => bellmanQ' sa0 W a0 (existT (act M) s a)) =
                        (bellmanQbar' sa0 W (existT (act M) s a)).
 Proof.
   intros [s a].
   unfold bellmanQbar'.
   unfold bellmanQ'.
   match_destr.
   + now rewrite expt_value_add, expt_value_const_mul.
   + now rewrite expt_value_const.
 Qed.

Theorem expt_value_rsqr_stochasticBellmanQ' W :
  forall (sa sa0 : sigT M.(act)),
    let (s,a) := sa in
    expt_value (t s a) (fun s' => (stochasticBellmanQ' sa0 W s' sa)²) =
    expt_value (t s a) (fun s' => (bellmanQ' sa0 W s' sa)²) - (bellmanQbar' sa0 W sa)².
Proof.
  intros [s a] sa0.
  unfold stochasticBellmanQ'.
  setoid_rewrite Rsqr_minus.
  rewrite expt_value_sub.
  rewrite expt_value_add.
  rewrite expt_value_const.
  setoid_rewrite Rmult_assoc.
  rewrite expt_value_const_mul.
  setoid_rewrite Rmult_comm at 4.
  rewrite expt_value_const_mul.
  rewrite (expt_value_bellmanQbar sa0 W (existT _ s a)).
  rewrite <-Rmult_assoc. unfold Rsqr. ring.
Qed.

Lemma Rmax_list_const {A : Type} (r : R) (l : list A):
  [] <> l -> Max_{l}(fun _ => r) = r.
Proof.
  intros Hl.
  symmetry.
  apply Rle_antisym.
  + apply Rmax_spec.
    rewrite in_map_iff.
    rewrite not_nil_exists in Hl.
    destruct Hl as [a Ha].
    exists a. split; trivial.
  + rewrite Rmax_list_le_iff.
    -- intros a Ha.
       rewrite in_map_iff in Ha.
       destruct Ha as [b [? ?]].
       subst; lra.
    -- now rewrite map_not_nil.
Qed.

Lemma Rmax_list_Rabs_pos {A : Type} (l : list A) (f : A -> R) :
  0 <= Max_{l} (fun a => Rabs (f a)).
Proof.
  destruct (is_nil_dec l); try subst.
  + now simpl.
  + rewrite BasicUtils.ne_symm in n.
    generalize (Rmax_list_map_exist (fun a => Rabs(f a)) l n).
    intros [a [Ha1 Ha2]].
    rewrite <-Ha2.
    apply Rabs_pos.
Qed.

Lemma Rplus_le_compat_Rsqr {a b c d : R} (hab : 0 <= a <= c) (hbd : 0 <= b <= d) :
  (a + b)² <= (c + d)².
Proof.
  do 2 rewrite Rsqr_plus.
  apply Rplus_le_compat.
  apply Rplus_le_compat.
  + apply Rsqr_le_abs_1.
    rewrite Rabs_right; try rewrite Rabs_right; try intuition lra.
  + apply Rsqr_le_abs_1.
    rewrite Rabs_right; try rewrite Rabs_right; try intuition lra.
  + apply Rmult_le_compat; try intuition lra.
Qed.

(* Move this somewhere else. *)
Lemma Rmax_list_map_dep_prod {A : Type} {B : A -> Type} (la : list A) (lb : forall a, list (B a))
      (Hb : forall a, [] <> lb a) (f : forall x :A, B x -> R):
         Max_{ la}(fun a => Max_{lb a} (fun b => f a b)) =
         Max_{list_dep_prod la lb}(fun ab : {x : A & B x} => let (a,b) := ab in f a b).
 Proof.
   destruct (is_nil_dec la); subst; try simpl; try easy.
   assert (Ha : [] <> la) by congruence. clear n.
   apply Rle_antisym.
    ++  rewrite Rmax_list_le_iff.
    -- intros x Hx. eapply (@Rmax_list_ge _ _ x).
       ** rewrite in_map_iff in *.
          destruct Hx as [a [Hx' HInx']].
          set (Hmax := Rmax_list_map_exist (fun b : B a=> f a b) (lb a) (Hb a)).
          destruct Hmax as [b [Hb1 Hb2]].
          exists (existT _ a b). simpl. split; [now rewrite <-Hx' |].
          apply in_dep_prod; trivial.
       ** now right.
    -- now rewrite map_not_nil.
       ++ rewrite Rmax_list_le_iff.
    * intros x Hx.
      rewrite in_map_iff in Hx.
      destruct Hx as [ab [Hab1 HInab1]].
      eapply Rmax_list_ge.
      --- rewrite in_map_iff.
          exists (projT1 ab). split ; trivial.
          destruct ab; simpl.
          setoid_rewrite in_dep_prod_iff in HInab1.
          destruct HInab1 ; trivial.
      --- eapply (Rmax_list_ge _ _ (f (projT1 ab) (projT2 ab))).
          +++ rewrite in_map_iff. exists (projT2 ab). split ; trivial.
              destruct ab as [a b]; simpl.
              rewrite in_dep_prod_iff in HInab1.
              destruct HInab1 ; trivial.
          +++ rewrite <-Hab1; destruct ab; simpl. right ; trivial.
    * rewrite map_not_nil.
      rewrite not_nil_exists in Ha.
      destruct Ha as [a H]. specialize (Hb a).
      rewrite not_nil_exists in Hb.
      destruct Hb as [b Hb].
      rewrite not_nil_exists.
      exists (existT _ a b). rewrite in_dep_prod_iff; split; trivial.
 Qed.

(* Lemma 13. *)
Theorem noise_variance_bound' (sa0 : sigT M.(act)) W :
  forall sa : sigT M.(act), let (s,a) := sa in
                       let (ls,_) := fs M in
                       variance (t s a) (fun s' => stochasticBellmanQ' sa0 W s' sa) <=
                       (Max_{ls}(fun s' => Max_{ls}(fun s => Max_{act_list s}( fun a => Rabs (reward s a s')))) +
                        γ*(Max_{ ls} (fun a0 : state M => Rabs (Max_{ act_list a0}(fun a1 : act M a0 => W (existT (act M) a0 a1))))))².
Proof.
  intros [s a].
  assert (Ha : forall s : M.(state), [] <> act_list s) by (intros s0; apply act_list_not_nil).
  generalize (expt_value_le_max (fs M) (t s a)); intros.
  destruct (fs M) as [ls ?].
  assert (Hls: [] <> ls) by (apply not_nil_exists; exists (ne M); trivial).
  assert (Hγ1 : Rabs (γ) = γ) by (apply Rabs_pos_eq; lra).
  assert (Hγ2 : 0 <= Rabs γ) by (apply Rabs_pos).
  destruct (existT _ s a == sa0).
  rewrite variance_eq.
  rewrite (expt_value_rsqr_stochasticBellmanQ' W (existT _ s a) sa0).
  unfold stochasticBellmanQ'. rewrite expt_value_sub.
  rewrite expt_value_const. rewrite Rsqr_minus at 1.
  rewrite (expt_value_bellmanQbar sa0 W (existT _ s a)).
  rewrite Rsqr_pow2. ring_simplify.
  rewrite <-Rsqr_pow2.
  eapply Rle_trans; try apply minus_Rsqr_le.
  eapply Rle_trans; try apply H.
  eapply Rle_trans; try (eapply (Rmax_list_Rsqr_Rabs_1) ; trivial).
  eapply Rle_trans; try (eapply (Rmax_list_Rsqr_Rabs_2) ; trivial).
  unfold bellmanQ'; match_destr.
  + eapply Rle_trans; try (eapply (Rmax_list_Rsqr_Rabs_3) ; trivial).
    apply Rplus_le_compat_Rsqr.
    -- split; [apply Rmax_list_Rabs_pos|].
       apply Rmax_list_fun_le; intros s'.
       unfold act_list.
       rewrite Rmax_list_map_dep_prod.
       +++  apply Rmax_spec; rewrite in_map_iff.
            exists (existT _ s a). split; trivial.
            rewrite in_dep_prod_iff; split; trivial.
            apply fa.
       +++ intros. apply act_list_not_nil.
    -- split; [apply Rmax_list_Rabs_pos|].
       setoid_rewrite Rabs_mult.
       rewrite Hγ1. rewrite Rmax_list_map_const_mul; lra.
  + intuition.
  + rewrite variance_eq.
    unfold stochasticBellmanQ', bellmanQ', bellmanQbar'.
    match_destr. intuition.
    do 2 rewrite expt_value_const.
    rewrite Rminus_eq_0.
    rewrite Rsqr_pow2. apply pow2_ge_0.
Qed.

Theorem noise_total_variance_bound (sa0 : sigT M.(act)) W : exists c : R,
  let (lsa,_) := act_finite M in
  list_sum (map (fun sa : {x : state M & _}  => let (s,a) := sa in
                variance (t s a) (fun s' => stochasticBellmanQ' sa0 W s' sa)) lsa)
  <= c.
Proof.
  generalize (noise_variance_bound' sa0 W); intros Hnvb.
  destruct (fs M) as [ls ?].
  destruct (act_finite M) as [lsa ?].
  exists (list_sum (map (fun _ => (Max_{ls}(fun s' => Max_{ls}(fun s => Max_{act_list s}( fun a => Rabs (reward s a s')))) +
                        γ*(Max_{ ls} (fun a0 : state M => Rabs (Max_{ act_list a0}(fun a1 : act M a0 => W (existT (act M) a0 a1))))))²) lsa)).
  apply list_sum_le; intros sa.
  specialize (Hnvb sa).
  destruct sa as [s a].
  apply Hnvb.
Qed.

Theorem stochasticBellmanQ'_false W :
  forall (sa sa0 : sigT M.(act)), (sa =/= sa0) -> (forall s', stochasticBellmanQ' sa0 W s' sa = 0).
Proof.
  intros.
  unfold stochasticBellmanQ', bellmanQbar'.
  match_destr. intuition.
  unfold bellmanQ'.
  match_destr. intuition.
  destruct sa; lra.
Qed.

Lemma list_sum_split_ind {A : Type} {eq : EqDec A eq} (l : list A) (a0 : A)
  (f : A -> R):
  list_sum (map (fun a => if (a == a0) then f a else 0) l) =
  f a0 * list_sum (map (fun a => if (a == a0) then 1 else 0) l).
Proof.
  induction l.
  + simpl. lra.
  + simpl. match_destr.
    rewrite Rmult_plus_distr_l.
    rewrite IHl. rewrite Rmult_1_r.
    rewrite e. reflexivity.
    rewrite IHl. lra.
Qed.

Lemma list_sum_split {A : Type} {eq : EqDec A eq} (l : list A) (a0 : A)
  (f : A -> R):
  list_sum (map f l) = list_sum (map (fun a => if (a == a0) then f a0 else 0) l) +
                       list_sum (map (fun a => if (a <> a0) then f a else 0) l).
Proof.
  induction l.
  + simpl. lra.
  + simpl. match_destr; case (a <> a0); intros; try intuition; try lra.
    rewrite IHl. rewrite e; lra.
Qed.

Lemma list_sum_ind_count_occ {A : Type} {eq : EqDec A eq}(l : list A)(a0 : A):
  list_sum (map (fun a => if (a == a0) then 1 else 0) l) =
  INR (count_occ eq l a0).
Proof.
  induction l; try now simpl.
  simpl; match_destr.
  + match_destr.
    -- rewrite IHl.
       rewrite S_INR; lra.
    -- intuition.
  + match_destr.
    -- intuition.
    -- rewrite Rplus_0_l.
       assumption.
Qed.

Theorem total_variance_stochasticBellmanQ' (sa0 : sigT M.(act)) W :
  let (lsa,_) := act_finite M in
  let lsa_nodup := nodup EqDecsigT lsa in
  list_sum (map (fun sa : {x : M.(state) & _} => let (s,a) := sa in
                                              variance (t s a) (fun s' => stochasticBellmanQ' sa0 W s' sa)) lsa_nodup) =
  let (s0,a0) := sa0 in
variance (t s0 a0) (fun s' => stochasticBellmanQ' (existT _ s0 a0) W s' (existT _ s0 a0)).
Proof.
  destruct (act_finite M) as [lsa ?].
  intros lsa_nodup.
  rewrite list_sum_split with (a0 := sa0).
  rewrite <-Rplus_0_r.
  f_equal.
  + destruct sa0 as [s0 a0].
    rewrite list_sum_split_ind.
    rewrite <-Rmult_1_r. f_equal.
    rewrite list_sum_ind_count_occ.
    replace 1 with (INR 1) by reflexivity.
    f_equal.
    generalize (nodup_In EqDecsigT lsa); intros.
    assert (Hf : forall x, In x (nodup EqDecsigT lsa)).
    {
      intros x. rewrite H. apply fin_finite.
    }
    revert Hf.
    generalize (NoDup_count_occ' EqDecsigT lsa_nodup); intros.
    assert (Hnd : NoDup lsa_nodup) by (apply NoDup_nodup).
    rewrite H0 in Hnd. apply Hnd.
    unfold lsa_nodup.
    rewrite nodup_In. apply fin_finite.
  + apply list_sum0_is0.
    rewrite Forall_map.
    rewrite Forall_forall; intros sa Hsa.
    match_destr.
    generalize (stochasticBellmanQ'_false W sa sa0 c); intros Hz.
    destruct sa as [s a].
    unfold variance. setoid_rewrite Hz.
    setoid_rewrite expt_value_zero.
    setoid_rewrite Rminus_eq_0.
    setoid_rewrite Rsqr_0. apply expt_value_zero.
Qed.

(* Move these.*)
Ltac solve_exists_in :=
  match goal with
  | [a : ?A, fin : forall x : ?A, In x ?ls |- exists a : ?A, In a ?ls] => exists a; try (apply fin)
  end.

Ltac rmax_compare :=
  match goal with
    | [ |- Rmax_list _ <= _] => rewrite Rmax_list_le_iff;
                    [intros ?x [?s [<-?Hs]] %in_map_iff |
                     rewrite map_not_nil, not_nil_exists; solve_exists_in]
    | [ |- _ <= Rmax_list _ ] =>  apply Rmax_spec; rewrite in_map_iff; try solve_exists_in
  end.

Lemma Q_is_bounded' W sa0 :
    let (ls, _) := fs M in
    let (las,_) := act_finite M in
    Max_{ls} (fun s' => Max_{las}(fun sa => bellmanQ' sa0 W s' sa)) <=
    Rmax(Max_{ ls}
  (fun s' : state M =>
     Max_{ las}(fun sa : {x : state M & act M x} => let (s, a) := sa in reward s a s')) +
    γ*Max_{las}(W)) (Max_{las}(W)).
Proof.
  destruct act_finite as [lsa ?].
  destruct fs as [ls ?].
  rmax_compare.
  rmax_compare.
  unfold bellmanQ'.
  match_destr.
  + rewrite e.
    destruct sa0 as [s1 a1].
    rewrite Rmax_Rle. left.
    apply Rplus_le_compat.
    -- rewrite Rmax_list_map_dep_prod.
       rmax_compare. exists (existT _ s (existT _ s1 a1)).
       split; [trivial | intuition].
       apply in_dep_prod; trivial.
       intros. rewrite not_nil_exists.
       now exists s0.
    -- apply Rmult_le_compat_l; try intuition lra.
       rmax_compare.
       generalize (Rmax_list_map_exist (fun a => W (existT _ s a)) (act_list s) (act_list_not_nil s)); intros [a [Ha1 Ha2]].
       exists (existT _ s a). split; trivial.
  + rewrite Rmax_Rle. right.
    rmax_compare. exists s0.
    split; trivial.
Qed.

End bellmanQ.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                podefs_1.v                                *)
(****************************************************************************)

Require Import Ensembles.
Require Import Relations_1.
Require Import podefs.

Section Bounds.
   Variable U : Type.
   Variable D : PO U.

   Let C := Carrier_of U D.

   Let R := Rel_of U D.

   Inductive Totally_ordered (B : Ensemble U) : Prop :=
       Totally_ordered_definition :
         (Included U B C ->
          forall x y : U, Included U (Couple U x y) B -> R x y \/ R y x) ->
         Totally_ordered B.

   Inductive Upper_Bound (B : Ensemble U) (x : U) : Prop :=
       Upper_Bound_definition :
         In U C x -> (forall y : U, In U B y -> R y x) -> Upper_Bound B x.

   Inductive Lower_Bound (B : Ensemble U) (x : U) : Prop :=
       Lower_Bound_definition :
         In U C x -> (forall y : U, In U B y -> R x y) -> Lower_Bound B x.

   Inductive Lub (B : Ensemble U) (x : U) : Prop :=
       Lub_definition :
         Upper_Bound B x ->
         (forall y : U, Upper_Bound B y -> R x y) -> Lub B x.

   Inductive Glb (B : Ensemble U) (x : U) : Prop :=
       Glb_definition :
         Lower_Bound B x ->
         (forall y : U, Lower_Bound B y -> R y x) -> Glb B x.

   Inductive Bottom (bot : U) : Prop :=
       Bottom_definition :
         In U C bot -> (forall y : U, In U C y -> R bot y) -> Bottom bot.

   Definition Compatible (x y : U) : Prop :=
     exists z : U,
       In U C x -> In U C y -> In U C z /\ Upper_Bound (Couple U x y) z.

   Inductive Directed (X : Ensemble U) : Prop :=
       Definition_of_Directed :
         Included U X C ->
         Non_empty U X ->
         (forall x1 x2 : U,
          Included U (Couple U x1 x2) X ->
          exists x3 : U, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) ->
         Directed X.

   Inductive Complete : Prop :=
       Definition_of_Complete :
         (exists bot : U, Bottom bot) ->
         (forall X : Ensemble U, Directed X -> exists bsup : U, Lub X bsup) ->
         Complete.

   Definition Cpo : Prop := Complete.

   Definition Chain : Prop := Totally_ordered C.

   Inductive Conditionally_complete : Prop :=
       Definition_of_Conditionally_complete :
         (forall X : Ensemble U,
          Included U X C ->
          (exists maj : U, Upper_Bound X maj) -> exists bsup : U, Lub X bsup) ->
         Conditionally_complete.

End Bounds.
Hint Unfold Carrier_of.
Hint Unfold Rel_of.
Hint Resolve Totally_ordered_definition Upper_Bound_definition
  Lower_Bound_definition Lub_definition Glb_definition Bottom_definition
  Definition_of_Complete Definition_of_Complete
  Definition_of_Conditionally_complete.


Require Import Classes.Morphisms.
Require Import Relations.
Require Import Structures.Equalities.
Require Import Omega.
Require Import Unicode.Utf8_core.
Require PreOrderTactic.
Notation "x ⇒ y" := (x -> y)
                      (at level 99, y at level 200, right associativity): type_scope.

(* Dummy module type *)
Module Type SetTyp <: Typ.
  Parameter t : Set.
End SetTyp.

(* Module type for the variables: equality has to be decidable *)
Module Type VariableAlphabet <: UsualDecidableType :=
  SetTyp <+ HasUsualEq <+ UsualIsEq <+ HasEqDec.

Module Types (𝕍 : VariableAlphabet).

  (* Our type syntax *)
  Inductive term : Set :=
  | Var : 𝕍.t ⇒ term
  | Arrow : term ⇒ term ⇒ term
  | Inter : term ⇒ term ⇒ term
  | Union : term ⇒ term ⇒ term
  | Omega : term.
  Infix "⟶" := (Arrow) (at level 60, right associativity).
  Notation "(⟶)" := Arrow (only parsing).
  Infix "∩" := (Inter) (at level 35, right associativity).
  Notation "(∩)" := (Inter) (only parsing).
  Infix "∪" := (Union) (at level 30, right associativity).
  Notation "(∪)" := (Union) (only parsing).
  Notation "'ω'" := (Omega).

  (* measure on the types *)
  Fixpoint size (σ : term) : nat :=
    match σ with
    | Var α => 0
    | σ ⟶ τ => S((size σ) + (size τ))
    | σ ∩ τ => S((size σ) + (size τ))
    | σ ∪ τ => S((size σ) + (size τ))
    | ω => 0
    end.
  Definition pair_size (x : term * term) : nat :=
    let (s,t) := x in size s + size t.

  (* Well-foundedness principle for the main algorithm *)
  Definition main_algo_order : relation (term * term) :=
    λ x y, pair_size x < pair_size y.
  Definition wf_main_algo : well_founded main_algo_order := well_founded_ltof _ _.

  Module SubtypeRelation.
    Reserved Infix "≤" (at level 70).
    Reserved Infix "~=" (at level 70).

    (* The subtyping axioms, as defined in the theory Ξ of
       Barbanera, Franco, Mariangiola Dezani-Ciancaglini, and Ugo Deliguoro. "Intersection and union types: syntax and semantics." Information and Computation 119.2 (1995): 202-230. *)
    Inductive Subtype : term ⇒ term ⇒ Prop :=
    | R_InterMeetLeft : ∀ σ τ, σ ∩ τ ≤ σ
    | R_InterMeetRight : ∀ σ τ, σ ∩ τ ≤ τ
    | R_InterIdem : ∀ τ, τ ≤ τ ∩ τ
    | R_UnionMeetLeft : ∀ σ τ, σ ≤ σ ∪ τ
    | R_UnionMeetRight : ∀ σ τ, τ ≤ σ ∪ τ
    | R_UnionIdem : ∀ τ, τ ∪ τ ≤ τ
    | R_InterDistrib : ∀ σ τ ρ,
        (σ ⟶ ρ) ∩ (σ ⟶ τ) ≤ σ ⟶ ρ ∩ τ
    | R_UnionDistrib : ∀ σ τ ρ,
        (σ ⟶ ρ) ∩ (τ ⟶ ρ) ≤ σ ∪ τ ⟶ ρ
    | R_InterSubtyDistrib: ∀ σ σ' τ τ',
        σ ≤ σ' ⇒ τ ≤ τ' ⇒ σ ∩ τ ≤ σ' ∩ τ'
    | R_UnionSubtyDistrib: ∀ σ σ' τ τ',
        σ ≤ σ' ⇒ τ ≤ τ' ⇒ σ ∪ τ ≤ σ' ∪ τ'
    | R_InterUnionDistrib: ∀ σ τ ρ,
        σ ∩ (τ ∪ ρ) ≤ (σ ∩ τ) ∪ (σ ∩ ρ)
    | R_CoContra : ∀ σ σ' τ τ',
        σ ≤ σ' ⇒ τ ≤ τ' ⇒ σ' ⟶ τ ≤ σ ⟶ τ'
    | R_OmegaTop : ∀ σ, σ ≤ ω
    | R_OmegaArrow : ω ≤ ω ⟶ ω
    | R_Reflexive : ∀ σ, σ ≤ σ
    | R_Transitive : ∀ σ τ ρ, σ ≤ τ ⇒ τ ≤ ρ ⇒ σ ≤ ρ
    where "σ ≤ τ" := (Subtype σ τ).
    Notation "(≤)" := (Subtype) (only parsing).

    (* The equivalence relation *)
    Definition equiv (σ τ : term) : Prop := (σ ≤ τ) ∧ (τ ≤ σ).
    Notation "σ ~= τ" := (equiv σ τ).
    Notation "(~=)" := (equiv) (only parsing).

    (* SubtypeHints database *)
    Create HintDb SubtypeHints.
    Hint Constructors Subtype : SubtypeHints.
    Hint Unfold equiv : SubtypeHints.

    (* Add some useful tactics *)
    Ltac preorder := PreOrderTactic.preorder.
    Ltac inv H := inversion H; clear H; subst.

    (* Boost auto *)
    Local Hint Extern 0 (_ ≠ _) => discriminate.
    Local Hint Extern 0 => lazymatch goal with
                     | H : ?x ≠ ?x |- _ => contradiction
                     end.
    Local Hint Extern 1 => lazymatch goal with
                     | H : _ ∧ _ |- _ => destruct H
                     | H : _ ∨ _ |- _ => destruct H
                     end.

    (* Unlock all the preorder-related tactics for ≤ *)
    Instance Subtypes_Reflexive : Reflexive (≤) := R_Reflexive.
    Instance Subtypes_Transitive : Transitive (≤) := R_Transitive.
    Instance Subtypes_Preorder : PreOrder (≤) :=
      {| PreOrder_Reflexive := Subtypes_Reflexive;
         PreOrder_Transitive := Subtypes_Transitive |}.

    (* Unlock all the equivalence-related tactics for ~= *)
    Instance equiv_Reflexive: Reflexive (~=).
    Proof.
      auto with SubtypeHints.
    Qed.
    Hint Immediate equiv_Reflexive : SubtypeHints.
    Instance equiv_Transitive: Transitive (~=).
    Proof.
      compute.
      intros ? ? ? [? ?] [? ?].
      split; etransitivity; eassumption.
    Qed.
    Instance equiv_Symmetric: Symmetric (~=).
    Proof.
      compute; auto.
    Qed.
    Hint Immediate equiv_Symmetric : SubtypeHints.
    Instance equiv_Equivalence: Equivalence (~=) :=
      {| Equivalence_Reflexive := equiv_Reflexive;
         Equivalence_Transitive := equiv_Transitive;
         Equivalence_Symmetric := equiv_Symmetric |}.
    Instance Subtypes_PartialOrder : PartialOrder (~=) (≤).
    Proof.
      compute; auto.
    Qed.

    (* Let's make the SubtypeHints database bigger *)
    (* ≤-related facts *)
    Fact Inter_inf : ∀ σ τ ρ, σ ≤ τ ⇒ σ ≤ ρ ⇒ σ ≤ τ ∩ ρ.
    Proof with auto with SubtypeHints.
      intros.
      transitivity (σ ∩ σ)...
    Qed.
    Hint Resolve Inter_inf : SubtypeHints.

    Fact Inter_inf' : ∀ σ τ ρ, σ ≤ τ ∩ ρ ⇒ (σ ≤ τ) ∧ (σ ≤ ρ).
    Proof with auto with SubtypeHints.
      intros; split;
        etransitivity;
        try eassumption...
    Qed.

    (* Don't put it in auto or it may be slow *)
    Fact Inter_inf_dual : ∀ σ τ ρ, (σ ≤ ρ) ∨ (τ ≤ ρ) ⇒ σ ∩ τ ≤ ρ.
    Proof with auto with SubtypeHints.
      intros σ τ ? [? | ?];
        [transitivity σ | transitivity τ]...
    Qed.

    Fact Union_sup : ∀ σ τ ρ, σ ≤ ρ ⇒ τ ≤ ρ ⇒ σ ∪ τ ≤ ρ.
    Proof with auto with SubtypeHints.
      intros.
      transitivity (ρ ∪ ρ)...
    Qed.
    Hint Resolve Union_sup : SubtypeHints.

    Fact Union_sup' : ∀ σ τ ρ, σ ∪ τ ≤ ρ ⇒ (σ ≤ ρ) ∧ (τ ≤ ρ).
    Proof with auto with SubtypeHints.
      intros; split;
        etransitivity;
        try eassumption...
    Qed.

    (* Don't put it in auto or it may be slow *)
    Fact Union_sup_dual : ∀ σ τ ρ, (σ ≤ τ) ∨ (σ ≤ ρ) ⇒ σ ≤ τ ∪ ρ.
    Proof with auto with SubtypeHints.
      intros ? τ ρ [? | ?];
        [transitivity τ | transitivity ρ]...
    Qed.

    Fact OmegaArrow : ∀ σ τ, ω ≤ τ ⇒ ω ≤ σ ⟶ τ.
    Proof with auto with SubtypeHints.
      intro; transitivity (ω ⟶ ω)...
    Qed.
    Hint Resolve OmegaArrow : SubtypeHints.

    Fact UnionInterDistrib : ∀ σ τ ρ, (σ ∪ τ) ∩ (σ ∪ ρ) ≤ σ ∪ (τ ∩ ρ).
    Proof with auto with SubtypeHints.
      intros.
      etransitivity; [apply R_InterUnionDistrib|]...
      apply Union_sup; [apply Union_sup_dual|]...
      transitivity (ρ ∩ (σ ∪ τ))...
      etransitivity; [apply R_InterUnionDistrib|]...
    Qed.
    Hint Resolve UnionInterDistrib : SubtypeHints.

    (* For more tactics, we show the operators are compatible with the relations *)
    Instance Inter_Proper_ST : Proper ((≤) ==> (≤) ==> (≤)) (∩).
    Proof with auto with SubtypeHints.
      compute...
    Qed.

    Instance Union_Proper_ST : Proper ((≤) ==> (≤) ==> (≤)) (∪).
    Proof with auto with SubtypeHints.
      compute...
    Qed.

    Instance Arr_Proper_ST : Proper (transp _ (≤) ==> (≤) ==> (≤)) (⟶).
    Proof with auto with SubtypeHints.
      compute...
    Qed.

    Instance Inter_Proper_EQ : Proper ((~=) ==> (~=) ==> (~=)) (∩).
    Proof with auto with SubtypeHints.
      compute...
    Qed.

    Instance Union_Proper_EQ : Proper ((~=) ==> (~=) ==> (~=)) (∪).
    Proof with auto with SubtypeHints.
      compute...
    Qed.

    Instance Arr_Proper_EQ : Proper ((~=) ==> (~=) ==> (~=)) (⟶).
    Proof with auto with SubtypeHints.
      compute...
    Qed.

    (* Help auto use these properties *)
    Hint Extern 2 (?R _ _ ~= ?R _ _) =>
    lazymatch R with
    | (∩) => apply Inter_Proper_EQ
    | (∪) => apply Union_Proper_EQ
    | (⟶) => apply Arr_Proper_EQ
    end : SubtypeHints.

    (* Ask auto to automatically simplify the hypotheses *)
    Hint Extern 1 (_ ≤ _) =>
    lazymatch goal with
    | H : ω ≤ _ |- _ => try rewrite <- H; (clear H) + (try rewrite <- H in *; clear H)
    | H : ?σ ≤ ?τ ∩ ?ρ |- _ => apply Inter_inf' in H; destruct H
    | H : ?σ ∪ ?τ ≤ ?ρ |- _ => apply Union_sup' in H; destruct H
    end : SubtypeHints.

    (* Ask auto to use preorder if the goal is atomic *)
    Hint Extern 300 (?σ ≤ ?τ) =>
    lazymatch σ with
    | _ _ _ => fail
    | _ => lazymatch τ with
           | _ _ _ => fail
           | _ => preorder
           end
    end : SubtypeHints.

    (* ~=-related facts *)
    Fact InterArrowEquiv : ∀ σ1 σ2 τ ρ1 ρ2, σ1 ~= τ ⟶ ρ1 ⇒ σ2 ~= τ ⟶ ρ2 ⇒ σ1 ∩ σ2 ~= τ ⟶ ρ1 ∩ ρ2.
    Proof.
      intros ? ? ? ? ? H H'.
      rewrite H, H'.
      auto with SubtypeHints.
    Qed.
    Hint Resolve InterArrowEquiv : SubtypeHints.

    Fact UnionArrowEquiv : ∀ σ1 σ2 τ1 τ2 ρ, σ1 ~= τ1 ⟶ ρ ⇒ σ2 ~= τ2 ⟶ ρ ⇒ σ1 ∩ σ2 ~= τ1 ∪ τ2 ⟶ ρ.
    Proof.
      intros ? ? ? ? ? H H'.
      rewrite H, H'.
      auto with SubtypeHints.
    Qed.
    Hint Resolve UnionArrowEquiv : SubtypeHints.

    Fact UnionEquiv1 : ∀ σ1 σ2 τ1 τ2 τ3, σ1 ~= τ1 ∪ τ2 ⇒ σ2 ~= τ1 ∪ τ3 ⇒ σ1 ∩ σ2 ~= τ1 ∪ (τ2 ∩ τ3).
    Proof.
      intros ? ? ? ? ? H H'.
      rewrite H, H'.
      auto with SubtypeHints.
    Qed.
    Hint Resolve UnionEquiv1 : SubtypeHints.

    Fact UnionEquiv2 : ∀ σ1 σ2 τ1 τ2 τ3, σ1 ~= τ1 ∪ τ3 ⇒ σ2 ~= τ2 ∪ τ3 ⇒ σ1 ∩ σ2 ~= (τ1 ∩ τ2) ∪ τ3.
    Proof.
      intros ? ? ? ? ? H H'.
      rewrite H, H'.
      transitivity (τ3 ∪ (τ1 ∩ τ2)); auto with SubtypeHints.
    Qed.
    Hint Resolve UnionEquiv2 : SubtypeHints.

    Fact InterEquiv1 : ∀ σ1 σ2 τ1 τ2 τ3, σ1 ~= τ1 ∩ τ2 ⇒ σ2 ~= τ1 ∩ τ3 ⇒ σ1 ∪ σ2 ~= τ1 ∩ (τ2 ∪ τ3).
    Proof.
      intros ? ? ? ? ? H H'.
      rewrite H, H'.
      auto with SubtypeHints.
    Qed.
    Hint Resolve InterEquiv1 : SubtypeHints.

    Fact InterEquiv2 : ∀ σ1 σ2 τ1 τ2 τ3, σ1 ~= τ1 ∩ τ3 ⇒ σ2 ~= τ2 ∩ τ3 ⇒ σ1 ∪ σ2 ~= (τ1 ∪ τ2) ∩ τ3.
    Proof.
      intros ? ? ? ? ? H H'.
      rewrite H, H'.
      transitivity (τ3 ∩ (τ1 ∪ τ2)); auto with SubtypeHints.
    Qed.
    Hint Resolve InterEquiv2 : SubtypeHints.

    Hint Extern 1 (_ ~= _ ) =>
    repeat lazymatch goal with
           | H : ?x ~= ω |- context[?x] => rewrite H; clear H
           | H : ω ~= ?x |- context[?x] => rewrite <- H; clear H
           | H : ?x ~= _ |- context[?x] => rewrite H; clear H
           end : SubtypeHints.

    (* Syntactical predicates on terms *)

    (* Generalized intersection and union *)
    Inductive Generalize (c : term ⇒ term ⇒ term) (P : term ⇒ Prop) : term ⇒ Prop :=
    | G_nil : ∀ σ, P σ ⇒ Generalize c P σ
    | G_cons : ∀ σ τ, Generalize c P σ ⇒ Generalize c P τ ⇒ Generalize c P (c σ τ).
    Hint Constructors Generalize : SubtypeHints.

    (* Notations: [ ⋂ P ] x means x is a generalized intersection of terms verifying P *)
    Notation "[ ⋂ P ]" := (Generalize (∩) P).
    Notation "[ ⋃ P ]" := (Generalize (∪) P).

    Fact general_inheritance : ∀ f g P s, Generalize f P s ⇒ Generalize f (Generalize g P) s.
    Proof.
      intros ? ? ? ? H; induction H.
      - constructor; constructor; assumption.
      - constructor 2; assumption.
    Qed.
    Hint Resolve general_inheritance : SubtypeHints.

    (* Arrow Normal Form *)
    Inductive ANF : term ⇒ Prop :=
    | VarisANF : ∀ α, ANF (Var α)
    | ArrowisANF : ∀ σ τ, [⋂ ANF] σ ⇒ [⋃ ANF] τ ⇒ ANF (σ ⟶ τ)
    | ArrowisANF' : ∀ τ, [⋃ ANF] τ ⇒ ANF (ω ⟶ τ).
    Hint Constructors ANF : SubtypeHints.

    (* Conjunctive/Disjunctive Normal Forms *)
    Definition CANF (σ : term) : Prop := [⋂ [⋃ ANF]] σ ∨ σ = ω.
    Definition DANF (σ : term) : Prop := [⋃ [⋂ ANF]] σ ∨ σ = ω.
    Hint Unfold CANF : SubtypeHints.
    Hint Unfold DANF : SubtypeHints.

    (* Terms without Omega (with one exception, in Of_Arrow1) *)
    Inductive Omega_free : term ⇒ Prop :=
    | Of_Var : ∀ α, Omega_free (Var α)
    | Of_Union : ∀ σ τ, Omega_free σ ⇒ Omega_free τ ⇒ Omega_free (σ ∪ τ)
    | Of_Inter : ∀ σ τ, Omega_free σ ⇒ Omega_free τ ⇒ Omega_free (σ ∩ τ)
    | Of_Arrow1 : ∀ σ, Omega_free σ ⇒ Omega_free (ω ⟶ σ)
    | Of_Arrow2 : ∀ σ τ, Omega_free σ ⇒ Omega_free τ ⇒ Omega_free (σ ⟶ τ).
    Hint Constructors Omega_free : SubtypeHints.
    Hint Extern 1 =>
    match goal with
    | H : Omega_free ω |- _ => inversion H
    | H : Omega_free (_ _ _) |- _ => inv H
    end : SubtypeHints.

    (* Terms on which we'll define filters *)
    Unset Elimination Schemes.
    Inductive isFilter : term ⇒ Prop :=
    | OmegaisFilter : isFilter ω
    | VarisFilter : ∀ α, isFilter (Var α)
    | ArrowisFilter : ∀ σ τ, isFilter (σ ⟶ τ)
    | InterisFilter : ∀ σ τ, isFilter σ ⇒ isFilter τ ⇒ isFilter (σ ∩ τ).
    Set Elimination Schemes.
    Hint Constructors isFilter : SubtypeHints.

    Fact InterANF_isFilter : ∀ σ, [ ⋂ ANF] σ ⇒ isFilter σ.
    Proof.
      induction 1 as [? H|].
      inversion H; auto with SubtypeHints.
      constructor; trivial.
    Qed.
    Hint Extern 0 (isFilter ?σ) =>
    match goal with
    | H : [ ⋂ ANF] σ |- _ => apply InterANF_isFilter
    end : SubtypeHints.

    (* Huge tactics that deals with these forms *)
    Ltac decide_nf :=
      try (lazymatch goal with
           | H : ANF _ |- _ => idtac
           | H : Generalize _ _ _ |- _ => idtac
           | H : CANF _ |- _ => idtac
           | H : DANF _ |- _ => idtac
           | _ => fail
           end;
           repeat lazymatch goal with
                  | H : DANF (_ _ _) |- _ => inversion H as [?|H']; [|inversion H']; subst; clear H
                  | H : CANF (_ _ _) |- _ => inversion H as [?|H']; [|inversion H']; subst; clear H
                  | H : [⋃ ANF] (_ ∪ _) |- _ => inversion H as [? H'|]; [inversion H'|]; subst; clear H
                  | H : [⋃ [⋂ ANF]] (_ ∪ _) |- _ => inversion H as [? H'|];
                                                    [inversion H' as [? H''|]; inversion H''|];
                                                    subst; clear H
                  | H : [⋃ _] (_ ∩ _) |- _ => inv H
                  | H : [⋃ _] (_ ⟶ _) |- _ => inv H
                  | H : [⋃ _] (Var _) |- _ => inv H
                  | H : [⋃ _] ω |- _ => inv H
                  | H : [⋂ ANF] (_ ∩ _) |- _ => inversion H as [? H'|]; [inversion H'|]; subst; clear H
                  | H : [⋂ [⋃ ANF]] (_ ∩ _) |- _ => inversion H as [? H'|];
                                                    [inversion H' as [? H''|]; inversion H''|];
                                                    subst; clear H
                  | H : [⋂ _] (_ ∪ _) |- _ => inv H
                  | H : [⋂ _] (_ ⟶ _) |- _ => inv H
                  | H : [⋂ _] (Var _) |- _ => inv H
                  | H : [⋂ _] ω |- _ => inv H
                  | H : ANF (ω ⟶ _) |- _ => inversion H as [|? ? H'|];
                                            [inversion H' as [? H''|]; inversion H''|]; subst; clear H
                  | H : ANF (_ ⟶ _) |- _ => inv H
                  | H : ANF (_ ∩ _) |- _ => inversion H
                  | H : ANF (_ ∪ _) |- _ => inversion H
                  | H : ANF ω |- _ => inversion H
                  | H : Omega_free (_ _ _) |- _ => inv H
                  end);
      repeat lazymatch goal with
             | H : ?x |- ?x => assumption
             | |- [⋃ _] (_ ∪ _) => apply G_cons
             | |- [⋃ _] _ => apply G_cons
             | |- [⋂ _] (_ ∩ _) => apply G_cons
             | |- [⋂ _] _ => apply G_nil
             | |- ANF (Var _) => constructor
             | |- ANF (ω ⟶ _) => apply ArrowisANF'
             | |- ANF (_ ⟶ _) => constructor
             | |- CANF ω => right; reflexivity
             | |- DANF ω => right; reflexivity
             | |- CANF (Var _) => left; repeat constructor
             | |- DANF (Var _) => left; repeat constructor
             | |- CANF (_ _ _) => left
             | |- DANF (_ _ _) => left
             end.
    Hint Extern 1 (CANF _) => decide_nf : SubtypeHints.
    Hint Extern 1 (DANF _) => decide_nf : SubtypeHints.
    Hint Extern 1 (ANF _) => decide_nf : SubtypeHints.
    Hint Extern 1 (Generalize _ _ _) => decide_nf : SubtypeHints.

    (* The recursion scheme for isFilter uses P ω as an inductive hypothesis *)
    Lemma isFilter_ind : ∀ P : term ⇒ Prop,
        P ω ⇒
        (∀ α : 𝕍.t, P ω ⇒ P (Var α)) ⇒
        (∀ σ τ : term, P ω ⇒ P (σ ⟶ τ)) ⇒
        (∀ σ τ : term, isFilter σ ⇒ P σ ⇒ isFilter τ ⇒ P τ ⇒ P ω ⇒ P (σ ∩ τ)) ⇒
        ∀ σ : term, isFilter σ ⇒ P σ.
    Proof.
      intros P fω fα fA fI.
      exact (fix foo σ Fσ : P σ := match Fσ in isFilter σ return P σ with
                                   | OmegaisFilter => fω
                                   | VarisFilter α => fα α fω
                                   | ArrowisFilter σ τ => fA σ τ fω
                                   | InterisFilter σ τ Fσ Fτ => fI σ τ Fσ (foo σ Fσ) Fτ (foo τ Fτ) fω
                                   end).
    Qed.

    (* Recursion scheme for [⋃ ANF] *)
    Lemma Uanf_ind : ∀ P : term ⇒ Prop,
        (∀ α, P (Var α)) ⇒
        (∀ σ τ, P σ ⇒ P τ ⇒ P (σ ∪ τ)) ⇒
        (∀ σ τ, P τ ⇒ P (σ ⟶ τ)) ⇒
        (∀ σ, [⋃ ANF] σ ⇒ P σ).
      intros P fV fU fA.
      refine (fix foo (σ : term) := match σ with
                                    | Var α => λ _, fV α
                                    | σ ⟶ τ => λ pf, fA _ τ (foo τ _)
                                    | σ ∪ τ => λ pf, fU σ τ (foo σ _) (foo τ _)
                                    | σ ∩ τ => λ pf, _
                                    | ω => λ pf, _
                                    end);
        try(inversion pf as [? pf'|]; inv pf'); decide_nf.
    Qed.
    Ltac uanf_ind σ :=
      let foo HH :=
          repeat match goal with
                 | H : context[σ] |- _ => lazymatch H with
                                          | HH => fail
                                          | _ => revert H
                                          end
                 end;
          revert HH; revert σ;
          refine (Uanf_ind _ _ _ _); intros
      in
      lazymatch goal with
      | HH : [⋃ ANF] σ |- _ => foo HH
      | _ =>
        assert (HH : [⋃ ANF] σ) by (auto with SubtypeHints);
        foo HH
      end.

    (* Filters and ideals *)
    Reserved Notation "↑[ σ ] τ" (at level 65).
    Reserved Notation "↓[ σ ] τ" (at level 65).
    Inductive Filter : term ⇒ term ⇒ Prop :=
    | F_Refl : ∀ σ : term, isFilter σ ⇒ ↑[σ] σ
    | F_Inter : ∀ σ τ ρ : term, ↑[σ] τ ⇒ ↑[σ] ρ ⇒ ↑[σ] τ ∩ ρ
    | F_Union1 : ∀ σ τ ρ : term, ↑[σ] τ ⇒ ↑[σ] τ ∪ ρ
    | F_Union2 : ∀ σ τ ρ : term, ↑[σ] ρ ⇒ ↑[σ] τ ∪ ρ
    | F_Arrow1 : ∀ σ1 σ2 τ1 τ2 : term, σ2 ≤ σ1 ⇒ τ1 ≤ τ2 ⇒ ↑[σ1 ⟶ τ1] σ2 ⟶ τ2
    | F_Arrow2 : ∀ σ1 σ2 τ1 τ2 ρ1 ρ2 : term, ↑[σ1 ∩ σ2] τ1 ⟶ ρ1 ⇒ τ2 ≤ τ1 ⇒ ρ1 ≤ ρ2 ⇒ ↑[σ1 ∩ σ2] τ2 ⟶ ρ2
    | F_OmegaTopV : ∀ (α : 𝕍.t) (τ : term), ↑[ω] τ ⇒ ↑[Var α] τ
    | F_OmegaTopA : ∀ σ1 σ2 τ : term, ↑[ω] τ ⇒ ↑[σ1 ⟶ σ2] τ
    | F_OmegaTopI : ∀ σ1 σ2 τ : term, isFilter (σ1 ∩ σ2) ⇒ ↑[ω] τ ⇒ ↑[σ1 ∩ σ2] τ
    | F_Omega : ∀ σ τ : term, ↑[ω] τ ⇒ ↑[ω] σ ⟶ τ
    | F_Inter1 : ∀ σ1 σ2 τ : term, isFilter σ2 ⇒ ↑[σ1] τ ⇒ ↑[σ1 ∩ σ2] τ
    | F_Inter2 : ∀ σ1 σ2 τ : term, isFilter σ1 ⇒ ↑[σ2] τ ⇒ ↑[σ1 ∩ σ2] τ
    | F_ArrowInter : ∀ σ1 σ2 τ ρ1 ρ2 : term, ↑[σ1 ∩ σ2] (τ ⟶ ρ1) ∩ (τ ⟶ ρ2) ⇒ ↑[σ1 ∩ σ2] τ ⟶ ρ1 ∩ ρ2
    | F_ArrowUnion : ∀ σ1 σ2 τ1 τ2 ρ : term, ↑[σ1 ∩ σ2] (τ1 ⟶ ρ) ∩ (τ2 ⟶ ρ) ⇒ ↑[σ1 ∩ σ2] τ1 ∪ τ2 ⟶ ρ
    where "↑[ σ ] τ" := (Filter σ τ).
    Hint Constructors Filter : SubtypeHints.

    Inductive Ideal : term ⇒ term ⇒ Prop :=
    | I_Refl : ∀ σ : term,  [⋃ ANF] σ ⇒ ↓[σ] σ
    | I_Inter1 : ∀ σ τ ρ : term, ↓[σ] τ ⇒ ↓[σ] τ ∩ ρ
    | I_Inter2 : ∀ σ τ ρ : term, ↓[σ] ρ ⇒ ↓[σ] τ ∩ ρ
    | I_Union : ∀ σ τ ρ : term, ↓[σ] τ ⇒ ↓[σ] ρ ⇒ ↓[σ] τ ∪ ρ
    | I_Arrow1 : ∀ σ1 σ2 τ1 τ2 : term, [⋂ ANF] σ1 ⇒ ↑[σ1] σ2 ⇒ ↓[τ1] τ2 ⇒ ↓[σ1 ⟶ τ1] σ2 ⟶ τ2
    | I_Arrow2 : ∀ σ τ1 τ2 : term, ↑[ω] σ ⇒ ↓[τ1] τ2 ⇒ ↓[ω ⟶ τ1] σ ⟶ τ2
    | I_Union1 : ∀ σ1 σ2 τ : term, [⋃ ANF] σ2 ⇒ ↓[σ1] τ ⇒ ↓[σ1 ∪ σ2] τ
    | I_Union2 : ∀ σ1 σ2 τ : term, [⋃ ANF] σ1 ⇒ ↓[σ2] τ ⇒ ↓[σ1 ∪ σ2] τ
    where "↓[ σ ] τ" := (Ideal σ τ).
    Hint Constructors Ideal : SubtypeHints.

    (* Correctness of filters and ideals *)
    Theorem Filter_correct : ∀ σ τ, ↑[σ] τ ⇒ σ ≤ τ.
    Proof with auto using Inter_inf_dual, Union_sup_dual with SubtypeHints.
      intros ? ? H.
      induction H...
      - etransitivity; [eassumption|]...
      - etransitivity; [|apply R_InterDistrib]...
      - etransitivity; [|apply R_UnionDistrib]...
    Qed.
    Hint Resolve Filter_correct : SubtypeHints.
    Hint Extern 1 (_ ≤ _) =>
    lazymatch goal with
    | H : ↑[ω] _ |- _ => apply (Filter_correct) in H; try rewrite <- H; (clear H) + (try rewrite <- H in *; clear H)
    end : SubtypeHints.

    Theorem Ideal_correct : ∀ σ τ, ↓[σ] τ ⇒ τ ≤ σ.
    Proof with auto using Inter_inf_dual, Union_sup_dual with SubtypeHints.
      intros ? ? H.
      induction H...
    Qed.
    Hint Resolve Ideal_correct : SubtypeHints.

    (* Filters and ideals have some normal form *)
    Lemma Filter_isFilter: ∀ σ τ, ↑[σ] τ ⇒ isFilter σ.
    Proof.
      intros ? ? H; induction H; auto; constructor; auto.
    Qed.
    Hint Extern 0 (isFilter ?σ) =>
      match goal with
      | H : ↑[?σ] _ |- _ => apply (Filter_isFilter _ _ H)
      end : SubtypeHints.

    Lemma Ideal_isDANF: ∀ σ τ, ↓[σ] τ ⇒ [⋃ ANF] σ.
    Proof.
      intros ? ? H; induction H; auto with SubtypeHints.
    Qed.
    Hint Resolve Ideal_isDANF : SubtypeHints.
    Hint Extern 0 ([⋃ ANF] ?σ) =>
      match goal with
      | H : ↓[?σ] _ |- _ => apply (Ideal_isDANF _ _ H)
      end : SubtypeHints.

    (* Tactic: cast ρ to σ in filter (or ideals) (may produce new goals) *)
    Ltac cast_filter ρ σ :=
      lazymatch σ with
      | ω => match ρ with
             | Var _ => apply F_OmegaTopV
             | _ ⟶ _ => apply F_OmegaTopA
             | _ ∩ _ => apply F_OmegaTopI
             end
      | _ => lazymatch ρ with
             | σ ∩ _ => apply F_Inter1
             | _ ∩ σ => apply F_Inter2
             end
      end.
    Ltac cast_ideal ρ σ :=
      lazymatch ρ with
      | σ ∪ _ => apply I_Union1
      | _ ∪ σ => apply I_Union2
      end.

    (* Helper lemmas to destruct filter and ideal hypotheses *)
    Lemma FilterInter : ∀ σ τ ρ, ↑[σ] τ ∩ ρ ⇒ ↑[σ] τ ∧ ↑[σ] ρ.
      intros ? ? ? H.
      assert (Fσ : isFilter σ) by (auto with SubtypeHints).
      induction Fσ; split; inv H;
        auto with SubtypeHints;
        lazymatch goal with
        (* Inductive case *)
        | IH : ↑[?σ] ?τ ⇒ _, H : ↑[?σ] ?τ |- ↑[?ρ] _ =>
          (* cast ρ to σ *)
          cast_filter ρ σ; trivial;
            (* apply the inductive hypothesis *)
            apply IH; trivial
        end.
    Qed.

    Lemma IdealInter : ∀ σ τ ρ, ↓[σ] τ ∩ ρ ⇒ ↓[σ] τ ∨ ↓[σ] ρ.
      intros ? ? ? H.
      assert (Iσ : [⋃ ANF] σ) by (auto with SubtypeHints).
      induction Iσ; inv H; auto with SubtypeHints; decide_nf;
        lazymatch goal with
        (* Inductive case *)
        | IH : ↓[?σ] ?τ1 ∩ ?τ2 ⇒ ?prop, H : ↓[?σ] ?τ1 ∩ ?τ2 |- ↓[?ρ] ?τ1 ∨ ↓[?ρ] ?τ2 =>
          (* apply the inductive hypothesis *)
          destruct (IH H); [left|right];
            (* cast ρ to σ *)
            cast_ideal ρ σ; assumption
        end.
    Qed.

    Lemma FilterUnion : ∀ σ τ ρ, ↑[σ] τ ∪ ρ ⇒ ↑[σ] τ ∨ ↑[σ] ρ.
      intros ? ? ? H.
      assert (Fσ : isFilter σ) by (auto with SubtypeHints).
      induction Fσ; inv H; auto;
        lazymatch goal with
        (* Inductive case *)
        | IH : ↑[?σ] ?τ1 ∪ ?τ2 ⇒ ?prop, H : ↑[?σ] ?τ1 ∪ ?τ2 |- ↑[?ρ] ?τ1 ∨ ↑[?ρ] ?τ2 =>
          (* apply the inductive hypothesis *)
          destruct (IH H); [left|right];
            (* cast ρ to σ *)
            cast_filter ρ σ; assumption
        end.
    Qed.

    Lemma IdealUnion : ∀ σ τ ρ, ↓[σ] τ ∪ ρ ⇒ ↓[σ] τ ∧ ↓[σ] ρ.
      intros ? ? ? H.
      assert (Iσ : [⋃ ANF] σ) by (auto with SubtypeHints).
      induction Iσ; split; inv H;
        auto with SubtypeHints; decide_nf;
          lazymatch goal with
          (* Inductive case *)
          | IH : ↓[?σ] ?τ ⇒ _, H : ↓[?σ] ?τ |- ↓[?ρ] _ =>
            (* cast ρ to σ *)
            cast_ideal ρ σ; trivial;
              (* apply the inductive hypothesis *)
              apply IH; trivial
          end.
    Qed.

    Lemma FilterArrow : ∀ σ σ' τ τ', ↑[σ ⟶ σ'] τ ⟶ τ' ⇒ (↑[ω] τ ⟶ τ' ∨ (τ ≤ σ  ∧ σ' ≤ τ')).
    Proof.
      intros ? ? ? ? H; inv H; auto 3 with SubtypeHints.
    Qed.

    Lemma Filter_omega : ∀ σ τ, isFilter σ ⇒ ↑[ω] τ ⇒ ↑[σ] τ.
    Proof.
      induction 1; auto with SubtypeHints.
    Qed.

    Lemma IdealnoOmega : ∀ σ, ¬ ↓[ σ] ω.
    Proof.
      induction σ; intro H; inv H;
        auto with SubtypeHints; decide_nf.
    Qed.

    Lemma IdealnoOmegaArrow : ∀ σ, ¬ ↓[ σ] ω ⟶ ω.
    Proof.
      induction σ; intro H; inv H;
        auto with SubtypeHints; decide_nf;
        eapply IdealnoOmega; eassumption.
    Qed.

    Hint Extern 1 =>
    lazymatch goal with
    | H : ↑[?σ ∩ ?τ] (?ρ ⟶ _) ∩ (?ρ ⟶ _) |- _ => apply F_ArrowInter in H
    | H : ↑[?σ ∩ ?τ] (_ ⟶ ?ρ) ∩ (_ ⟶ ?ρ) |- _ => apply F_ArrowUnion in H
    | H : ↑[_] _ ∪ _ |- _ => apply FilterUnion in H; destruct H
    | H : ↑[_] _ ∩ _ |- _ => apply FilterInter in H; destruct H
    | H : ↑[_ ⟶ _] _ ⟶ _ |- _ => apply FilterArrow in H; destruct H as [|[ ]]
    | H : ↑[ω] _ ⟶ _ |- _ => inv H
    | H : ↑[Var _] _ ⟶ _ |- _ => inv H
    end : SubtypeHints.

    Ltac destruct_ideal :=
      repeat lazymatch goal with
             | H : ↓[_] ω |- _ => apply IdealnoOmega in H; exfalso; trivial
             | H : ↓[_] ω ⟶ ω |- _ => apply IdealnoOmegaArrow in H; exfalso; trivial
             | H : ↓[_] _ ∪ _ |- _ => apply IdealUnion in H; destruct H
             | H : ↓[_] _ ∩ _ |- _ => apply IdealInter in H; destruct H
             | H : ↓[_ ∪ _] _ ⟶ _ |- _ => inv H
             | H : ↓[_ ⟶ _] _ ⟶ _ |- _ => inv H
             | H : ↓[Var _] _ ⟶ _ |- _ => inv H
             end.

    Lemma FilterArrow' : ∀ σ τ' ρ, ↑[ σ] τ' ⟶ ρ ⇒ ∀ τ ρ', τ ≤ τ' ⇒ ρ ≤ ρ' ⇒ ↑[ σ] τ ⟶ ρ'.
    Proof.
      intros ? ? ? H.
      assert (Fσ : isFilter σ) by (auto with SubtypeHints).
      induction Fσ.
      - intros ? ? ? H1.
        constructor; inv H.
        induction H1; auto 10 with SubtypeHints.
      - auto with SubtypeHints.
      - apply FilterArrow in H; destruct H as [|[ ]]; auto with SubtypeHints.
      - eauto with SubtypeHints.
    Qed.

    (* Main properties: filters (resp. ideal) are closed by upcasting (resp. downcasting) *)
    (* As a result, we get completeness of filters and ideals *)
    Lemma Filter_closed : ∀ σ τ1 τ2,
        ↑[σ] τ1 ⇒ τ1 ≤ τ2 ⇒ ↑[σ] τ2.
    Proof.
      induction 2; auto with SubtypeHints;
        solve [eapply FilterArrow'; eassumption|
               apply Filter_omega; auto with SubtypeHints|
               assert (Fσ : isFilter σ) by (auto with SubtypeHints);
               induction Fσ; auto 10 with SubtypeHints].
    Qed.
    Hint Extern 0 (↑[?σ] ?τ2) =>
    lazymatch goal with
    | H : ↑[σ] ?τ1, H' : ?τ1 ≤ τ2 |- ↑[σ] τ2 => apply (Filter_closed _ _ _ H H')
    end : SubtypeHints.

    Theorem Filter_complete : ∀ σ, isFilter σ ⇒ ∀ τ, σ ≤ τ ⇒ ↑[σ] τ.
    Proof.
      intros; eapply Filter_closed; try eassumption.
      apply F_Refl; assumption.
    Qed.
    Hint Resolve Filter_complete : SubtypeHints.

    Section Ideal_closed.
      (* This hint is local to the section; and help use the inductive hypotheses *)
      Hint Extern 1 (↓[?ρ] _) =>
      (* Because of a bug in auto, auto fails to use the generated hypothesis; so foo helps it *)
      let foo σ HHH :=
          lazymatch ρ with
          | _ ∪ _ => cast_ideal ρ σ; trivial; apply HHH
          | ω ⟶ _ => apply I_Arrow2; [|apply HHH]
          | _ ⟶ _ => apply I_Arrow1; [| |apply HHH]
          end
      in
      (* The variable τ of the inductive hypothesis cannot be infered by auto,
         so this tactic instantiates it *)
      lazymatch goal with
      | H : ∀ τ, ↓[?σ] τ ⇒ ∀ τ' : term, τ' ≤ τ ⇒ ↓[?σ] τ', H' : ↓[?σ] ?τ |- _ =>
      assert (HHH : ∀ τ' : term, τ' ≤ τ ⇒ ↓[ σ] τ') by (exact (H τ H')); clear H H'; foo σ HHH
    | H : ∀ τ, ↓[?σ] τ ⇒ ∀ τ' : term, τ' ≤ τ ⇒ ↓[?σ] τ', H' : ?τ ≤ ?σ |- _ =>
      assert (HHH : ↓[ σ] τ) by (refine (H _ (I_Refl _ _) _ H'); trivial); clear H H'; foo σ HHH
      end.

      Lemma Ideal_closed : ∀ σ, [⋃ ANF] σ ⇒ ∀ τ1, ↓[σ] τ1 ⇒ ∀ τ2, τ2 ≤ τ1 ⇒ ↓[σ] τ2.
      Proof.
        intros until 1; uanf_ind σ;
          lazymatch goal with
          | H : _ ≤ _ |- _ => induction H;
                                destruct_ideal;
                                decide_nf;
                                auto with SubtypeHints
          end.
      Qed.
    End Ideal_closed.

    Theorem Ideal_complete : ∀ σ, [⋃ ANF] σ ⇒ ∀ τ, τ ≤ σ ⇒ ↓[σ] τ.
    Proof.
      intros; eapply Ideal_closed; try eassumption.
      apply I_Refl; assumption.
    Qed.

    (* Now we can use filters and ideals to prove lemmas about subtyping *)
    Lemma Omega_free_Omega : ∀ s, Omega_free s ⇒ ¬ s ~= Omega.
    Proof.
      intros ? H [_ H2].
      apply Filter_complete in H2; trivial with SubtypeHints.
      induction s; inv H; inv H2; auto with SubtypeHints.
    Qed.

    Lemma Omega_IUANF : ∀ σ, [ ⋂ [ ⋃ ANF]] σ ⇒ ¬ ω ≤ σ.
    Proof.
      induction σ as [|? H1 ? H2|? H1 ? H2|? H1 ? H2|];
        intros; intro Hyp; (apply Filter_complete in Hyp; [|constructor]); inv Hyp;
          solve [apply H2; auto 2 with SubtypeHints|
                 apply H1; auto 2 with SubtypeHints|
                 decide_nf].
    Qed.

    (* Rewriting functions *)

    (* First rewriting function: do Omega-related simplifications *)
    Fixpoint deleteOmega (σ : term) : {τ | τ ~= σ ∧ (Omega_free τ ∨ τ = ω)}.
      refine(match σ with
             | σ ⟶ τ => let (σ,pfσ) := deleteOmega σ in
                        let (τ,pfτ) := deleteOmega τ in
                        match τ as x return τ = x ⇒ _ with
                        | ω => λ _, exist _ ω _
                        | _ => λ _, exist _ (σ ⟶ τ) _
                        end eq_refl
             | σ ∩ τ => let (σ,pfσ) := deleteOmega σ in
                        let (τ,pfτ) := deleteOmega τ in
                        match σ as x return σ = x ⇒ _ with
                        | ω => λ _, exist _ τ _
                        | _ => λ _, match τ as x return τ = x ⇒ _ with
                                    | ω => λ _, exist _ σ _
                                        | _ => λ _, exist _ (σ ∩ τ) _
                                        end eq_refl
                        end eq_refl
             | σ ∪ τ => let (σ,pfσ) := deleteOmega σ in
                        let (τ,pfτ) := deleteOmega τ in
                        match σ as x return σ = x ⇒ _ with
                        | ω => λ _, exist _ ω _
                        | _ => λ _, match τ as x return τ = x ⇒ _ with
                                        | ω => λ _, exist _ ω _
                                        | _ => λ _, exist _ (σ ∪ τ) _
                                        end eq_refl
                        end eq_refl
             | Var α => exist _ (Var α) _
             | ω => exist _ ω _
             end); clear deleteOmega; subst; simpl in *;
        first[destruct pfσ as [? [|]];
              destruct pfτ as [? [|]]; subst|
              auto with SubtypeHints];
        first[match goal with | H : Omega_free ω |- _ => inversion H end|
              discriminate|
              split; auto with SubtypeHints].
    Defined.

    (* Distribution functions *)
    Fixpoint distrArrow (σ τ : term) (pfσ : [⋃ [⋂ ANF]] σ ∨ σ = ω) (pfτ : [⋂ [⋃ ANF]] τ) :
      {σ' | σ' ~= σ ⟶ τ ∧ [⋂ ANF] σ'}.
      refine(match σ as x return σ = x ⇒ _ with
             | σ1 ∪ σ2 => λ _, let (σ1,pfσ1) := distrArrow σ1 τ _ _ in
                                   let (σ2,pfσ2) := distrArrow σ2 τ _ _ in
                                   exist _ (σ1 ∩ σ2) _
             | _ => λ _,
                      (fix distrArrow' σ τ (pfσ:[⋂ ANF] σ ∨ σ = ω) (pfτ:[⋂ [⋃ ANF]] τ) : {σ' | σ' ~= σ ⟶ τ ∧ [⋂ ANF] σ'} :=
                         match τ as x return τ = x ⇒ _ with
                         | τ1 ∩ τ2 => λ _, let (τ1,pfτ1) := distrArrow' σ τ1 _ _ in
                                               let (τ2,pfτ2) := distrArrow' σ τ2 _ _ in
                                               exist _ (τ1 ∩ τ2) _
                         | _ => λ _, exist _ (σ ⟶ τ) _
                         end eq_refl) σ τ _ pfτ
             end eq_refl); subst; (destruct pfσ; [|try discriminate]); simpl in *;
        auto with SubtypeHints.
    Defined.

    Fixpoint distrUnion (σ τ : term) (pfσ : [⋂ [⋃ ANF]] σ) (pfτ : [⋂ [⋃ ANF]] τ) :
      {σ' | σ' ~= σ ∪ τ ∧ [⋂ [⋃ ANF]] σ'}.
      refine(match σ as x return σ = x ⇒ _ with
             | σ1 ∩ σ2 => λ _, let (σ1,pfσ1) := distrUnion σ1 τ _ _ in
                                   let (σ2,pfσ2) := distrUnion σ2 τ _ _ in
                                   exist _ (σ1 ∩ σ2) _
             | _ => λ _,
                      (fix distrUnion' σ τ (pfσ:[⋃ ANF] σ) (pfτ:[⋂ [⋃ ANF]] τ) : {σ' | σ' ~= σ ∪ τ ∧ [⋂ [⋃ ANF]] σ'} :=
                         match τ as x return τ = x ⇒ _ with
                         | τ1 ∩ τ2 => λ _, let (τ1,pfτ1) := distrUnion' σ τ1 _ _ in
                                               let (τ2,pfτ2) := distrUnion' σ τ2 _ _ in
                                               exist _ (τ1 ∩ τ2) _
                         | _ => λ _, exist _ (σ ∪ τ) _
                         end eq_refl) σ τ _ pfτ
             end eq_refl); subst; simpl in *;
        auto with SubtypeHints.
    Defined.

    Fixpoint distrInter (σ τ : term) (pfσ : [⋃ [⋂ ANF]] σ) (pfτ : [⋃ [⋂ ANF]] τ) :
      {σ' | σ' ~= σ ∩ τ ∧ [⋃ [⋂ ANF]] σ'}.
      refine(match σ as x return σ = x ⇒ _ with
             | σ1 ∪ σ2 => λ _, let (σ1,pfσ1) := distrInter σ1 τ _ _ in
                                   let (σ2,pfσ2) := distrInter σ2 τ _ _ in
                                   exist _ (σ1 ∪ σ2) _
             | _ => λ _,
                      (fix distrInter' σ τ (pfσ:[⋂ ANF] σ) (pfτ:[⋃ [⋂ ANF]] τ) : {σ' | σ' ~= σ ∩ τ ∧ [⋃ [⋂ ANF]] σ'} :=
                         match τ as x return τ = x ⇒ _ with
                         | τ1 ∪ τ2 => λ _, let (τ1,pfτ1) := distrInter' σ τ1 _ _ in
                                               let (τ2,pfτ2) := distrInter' σ τ2 _ _ in
                                               exist _ (τ1 ∪ τ2) _
                         | _ => λ _, exist _ (σ ∩ τ) _
                         end eq_refl) σ τ _ pfτ
             end eq_refl); subst; simpl in *;
        auto with SubtypeHints.
    Defined.

    (* Mutually recursive functions for CANF and DANF *)
    Fixpoint _CANF  (σ : term) : (Omega_free σ ∨ σ = ω) ⇒ {τ | τ ~= σ ∧ CANF τ}
    with _DANF  (σ : term) : (Omega_free σ ∨ σ = ω) ⇒ {τ | τ ~= σ ∧ DANF τ}.
    Proof.
      - refine(match σ with
               | Var α => λ _, exist _ (Var α) _
               | σ ⟶ τ => λ pf,
                            let (σ,pfσ) := _DANF σ _ in
                            let (τ,pfτ) := _CANF τ _ in
                            let (σ',pfσ') := distrArrow σ τ _ _ in
                            exist _ σ' _
               | σ ∩ τ => λ pf,
                            let (σ,pfσ) := _CANF σ _ in
                            let (τ,pfτ) := _CANF τ _ in
                            exist _ (σ ∩ τ) _
               | σ ∪ τ => λ pf, let (σ,pfσ) := _CANF σ _ in
                                let (τ,pfτ) := _CANF τ _ in
                                let (σ',pfσ') := distrUnion σ τ _ _ in
                                exist _ σ' _
               | ω => λ _, exist _ ω _
               end); try (destruct pf; [|discriminate]); simpl in *;
          match goal with
          | |- _ ∨ _ => auto with SubtypeHints
          | |- _ ∧ _ => split; [trivial|]
          | _ => idtac
          end;
          try (destruct pfσ as [Hσ [?|?]]; [|subst; exfalso; match type of Hσ with
                                                             | ω ~= ?σ' => apply (Omega_free_Omega σ')
                                                             end; auto 2 with SubtypeHints; fail]);
          try (destruct pfτ as [Hτ [?|?]]; [|subst; exfalso; match type of Hτ with
                                                             | ω ~= ?τ' => apply (Omega_free_Omega τ')
                                                             end; auto 2 with SubtypeHints; fail]);
          auto with SubtypeHints.
      - refine(match σ with
               | Var α => λ _, exist _ (Var α) _
               | σ ⟶ τ => λ pf,
                            let (σ,pfσ) := _DANF σ _ in
                            let (τ,pfτ) := _CANF τ _ in
                            let (σ',pfσ') := distrArrow σ τ _ _ in
                            exist _ σ' _
               | σ ∪ τ => λ pf,
                            let (σ,pfσ) := _DANF σ _ in
                            let (τ,pfτ) := _DANF τ _ in
                            exist _ (σ ∪ τ) _
               | σ ∩ τ => λ pf,
                            let (σ,pfσ) := _DANF σ _ in
                            let (τ,pfτ) := _DANF τ _ in
                            let (σ',pfσ') := distrInter σ τ _ _ in
                            exist _ σ' _
               | ω => λ _, exist _ ω _
               end); try (destruct pf; [|discriminate]); simpl in *;
          match goal with
          | |- _ ∨ _ => auto with SubtypeHints
          | |- _ ∧ _ => split; [trivial|]
          | _ => idtac
          end;
          try (destruct pfσ as [Hσ [?|?]]; [|subst; exfalso; match type of Hσ with
                                                             | ω ~= ?σ' => apply (Omega_free_Omega σ')
                                                             end; auto 2 with SubtypeHints; fail]);
          try (destruct pfτ as [Hτ [?|?]]; [|subst; exfalso; match type of Hτ with
                                                             | ω ~= ?τ' => apply (Omega_free_Omega τ')
                                                             end; auto 2 with SubtypeHints; fail]);
          auto with SubtypeHints.
    Defined.

    (* Main subtyping algorithm *)
    Definition main_algo : ∀ pair : term * term,
        DANF (fst pair) ⇒ CANF (snd pair) ⇒
        {fst pair ≤ snd pair} + {¬ fst pair ≤ snd pair}.
      refine (Fix wf_main_algo _ _). intros [σ τ] rec.
      refine (match (σ,τ) as x return x = (σ,τ) ⇒ _ with
              | (_, ω) => λ eq _ _, left _
              | (ω, _) => λ eq _ Cτ, right _
              | (σ1 ∪ σ2, _) => λ eq _ _, match rec (σ1,τ) _ _ _ with
                                              | left _ => match rec (σ2,τ) _ _ _ with
                                                          | left _ => left _
                                                          | right _ => right _
                                                          end
                                              | right _ => right _
                                              end
              | (_, τ1 ∩ τ2) => λ eq _ _, match rec (σ,τ1) _ _ _ with
                                              | left _ => match rec (σ,τ2) _ _ _ with
                                                          | left _ => left _
                                                          | right _ => right _
                                                          end
                                              | right _ => right _
                                              end
              | (σ1 ⟶ σ2, τ1 ⟶ τ2) => λ eq Dσ Cτ, match rec (τ1,σ1) _ _ _ with
                                                      | left _ => match rec (σ2,τ2) _ _ _ with
                                                                  | left _ => left _
                                                                  | right HAA => right _
                                                                  end
                                                      | right HAA => right _
                                                      end
              | (σ1 ∩ σ2, _) => λ eq Dσ Cτ, match rec (σ1,τ) _ _ _ with
                                                | left _ => left _
                                                | right _ => match rec (σ2,τ) _ _ _ with
                                                             | left _ => left _
                                                             | right _ => right _
                                                             end
                                                end
              | (_, τ1 ∪ τ2) => λ eq Dσ Cτ, match rec (σ,τ1) _ _ _ with
                                                | left _ => left _
                                                | right _ => match rec (σ,τ2) _ _ _ with
                                                             | left _ => left _
                                                             | right _ => right _
                                                             end
                                                end
              | (Var α, Var β) => λ eq _ _, if 𝕍.eq_dec α β then left _ else right _
              | _ => λ eq _ _, right _
              end eq_refl); inv eq; simpl in *;
        match goal with
        | |- main_algo_order _ _ => red; simpl; omega
        | |- ?σ ≤ ?σ => reflexivity
        | H : ?x |- ?x => assumption
        | |- CANF _ => auto with SubtypeHints
        | |- DANF _ => auto with SubtypeHints
        (* Correctness *)
        | |- _ ≤ ω => auto with SubtypeHints
        | |- _ ≤ _ ∩ _ => auto with SubtypeHints
        | |- _ ∪ _ ≤ _ => auto with SubtypeHints
        | |- _ ∩ _ ≤ _ => apply Inter_inf_dual; auto
        | |- _ ≤ _ ∪ _ => apply Union_sup_dual; auto
        | |- _ ⟶ _ ≤ _ ⟶ _ => apply R_CoContra; trivial
        (* Completeness *)
        | |- ¬ ω ≤ _ => apply Omega_IUANF; auto with SubtypeHints
        | |- ¬ _ ∪ _ ≤ _ => intro; apply Union_sup' in H; auto
        | |- ¬ _ ≤ _ ∩ _ => intro; apply Inter_inf' in H; auto
        | |- ¬ ?σ ≤ _ => intro H; apply Ideal_complete in H; [|auto with SubtypeHints];
                           match σ with
                           | _ ∩ _ => apply IdealInter in H; inversion H as [H'|H'];
                                        apply Ideal_correct in H'; auto
                           | _ ⟶ _ => inv H; [apply HAA; reflexivity| |]; auto with SubtypeHints
                           | _ => inv H; auto with SubtypeHints
                           end
        end.
    Defined.

    (* Composition of all the previous algorithms *)
    Definition decide_subtype : ∀ σ τ, {σ ≤ τ} + {¬ σ ≤ τ}.
    Proof.
      intros.
      refine (let (σ1,pfσ) := deleteOmega σ in let (Hσ1,pfσ) := pfσ in
              let (τ1,pfτ) := deleteOmega τ in let (Hτ1,pfτ) := pfτ in
              let (σ2,pfσ) := _DANF σ1 pfσ in let (Hσ2,pfσ) := pfσ in
              let (τ2,pfτ) := _CANF τ1 pfτ in let (Hτ2,pfτ) := pfτ in
              match main_algo (σ2,τ2) pfσ pfτ with
              | left H => left _
              | right H => right _
              end);
        rewrite <- Hτ1, <- Hσ1, <- Hτ2, <- Hσ2; assumption.
    Defined.
  End SubtypeRelation.
End Types.

(* Module nat_var <: VariableAlphabet. *)
(*   Definition t := nat. *)
(*   Definition eq := @eq nat. *)
(*   Definition eq_equiv : Equivalence eq. *)
(*   Proof. *)
(*     constructor. *)
(*     constructor. *)
(*     red. *)
(*     intros. *)
(*     now symmetry. *)
(*     red. *)
(*     intros; etransitivity; eauto. *)
(*   Defined. *)

(*   Definition eq_dec : ∀ x y : t, {x = y} + {x ≠ y}. *)
(*     decide equality. *)
(*   Defined. *)
(* End nat_var. *)

(* Module foo := nat_var <+ Types. *)

(* Import foo. *)
(* Definition is_subtype := SubtypeRelation.decide_subtype. *)

(* Definition s1 := Var 0. *)
(* Definition s2 := Var 1. *)
(* Definition t1 := Var 2. *)
(* Definition t2 := Var 3. *)

(* Definition type_1 := (t1 ⟶ s1) ∩ (t2 ⟶ s2). *)
(* Definition type_2 := (t1 ∪ t2) ⟶ (s1 ∩ s2). *)

(* Eval hnf in (is_subtype type_1 type_2). (* explodes my computer *) *)
(* Eval hnf in (is_subtype type_2 type_1). (* explodes my computer *) *)