(*********************************************************************)
(*             Stability in Weak Memory Models                       *)
(*                                                                   *)
(*   Jade Alglave INRIA Paris-Rocquencourt, France                   *)
(*                University of Oxford, UK                           *)
(*                                                                   *)
(*  Copyright 2010 Institut National de Recherche en Informatique et *)
(*  en Automatique. All rights reserved. This file is distributed    *)
(*  under the terms of the Lesser GNU General Public License.        *)
(*********************************************************************)

Require Import Ensembles.
Require Import Bool.
From CoqCat Require Import util.
From CoqCat Require Import wmm.
From CoqCat Require Import basic.
From CoqCat Require Import hierarchy.
From CoqCat Require Import valid.
From CoqCat Require Import covering.
From CoqCat Require Import crit_sc.
Require Import Classical_Prop.
Import OEEvt.
Set Implicit Arguments.

Module StableSC (A1 A2: Archi) (dp:Dp).
Module Wk := (* Hierarchy.*)Weaker A1 A2 dp.
Import Wk.
Module Covering := Covering A1b A2 dp.
Import Covering.
Module Crit := CritSC A1b A2 dp.
Import Crit.
Module VA1 := Valid A1b dp.
Import VA1.
Module A1Basic := Basic A1b dp.

Module Preservation := Preservation Cm.
Import Preservation.

(*A2n=SC*)
Hypothesis rfe2_glob : forall E X,
  rel_incl (rf_inter X) (A2nWmm.mhb E X).
Hypothesis ppo2_po : forall E, A2.ppo E = po_iico E.
Hypothesis rfi2_ppo2 : forall E X,
  rel_incl (rf_intra X) (A2.ppo E).

Lemma v1_and_no_cy_implies_covered :
  forall E X,
  well_formed_event_structure E ->
  A1bWmm.valid_execution E X ->
  ~ (exists cy : Rln Event, crit_cy E cy) ->
  Cm.covered E X Cm.s.
Proof.
intros E X Hwf Hv1 Hncy e1 e2 [Hc12 [sigma [Hsigma ?]]].
assert (exists cy : Rln Event, crit_cy E cy) as Hc.
  exists sigma; auto.
contradiction.
Qed.

Lemma write_or_read :
  forall E x,
  events E x ->
  writes E x \/ reads E x.
Proof.
intros E x Hex.
case_eq (action x); intros d l v Hax;
case_eq d; intro Hd; [right | left];
  split; auto; exists l; exists v; subst; auto.
Qed.

Lemma tc_dom_in_evts :
  forall E cy e1 e2,
  well_formed_event_structure E ->
  tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) e1 e2 ->
  In _ (events E) e1.
Proof.
intros E cy e1 e2 Hwf Htc.
induction Htc as [e1 e2 Hu |]; auto.
  inversion Hu as [Hcy | Hpo].
    destruct Hcy as [? [? [? ?]]]; auto.
    apply A1Basic.po_iico_domain_in_events with e2; auto.
      inversion Hpo as [Hppo | Hpio].
      apply A1b.ppo_valid; auto.
      destruct Hpio as [? [? ?]]; auto.
Qed.

Lemma tc_ran_in_evts :
  forall E cy e1 e2,
  well_formed_event_structure E ->
  tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) e1 e2 ->
  In _ (events E) e2.
Proof.
intros E cy e1 e2 Hwf Htc.
induction Htc as [e1 e2 Hu |]; auto.
  inversion Hu as [Hcy | Hpo].
    destruct Hcy as [? [? [? ?]]]; auto.
    apply A1Basic.po_iico_range_in_events with e1; auto.
      inversion Hpo as [Hppo | Hpio].
      apply A1b.ppo_valid; auto.
      destruct Hpio as [? [? ?]]; auto.
Qed.

Lemma cy_inter_conflict_ppo1_partial_order :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  partial_order (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))
  (events E).
Proof.
intros E cy Hwf Hac.
  split; [|split].

    intros e1 Hu; inversion Hu as [e Hd | e Hr].
    destruct Hd as [e2 H12].
      apply tc_dom_in_evts with cy e2; auto.

    destruct Hr as [e2 H12].
      apply tc_ran_in_evts with cy e2; auto.

    intros x1 x2 x3 [H12 H23]; apply trc_ind with x2; auto.

    intros e He; apply (Hac e He).
Qed.

Lemma ppo1_in_le :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  rel_incl (A1b.ppo E) (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))).
Proof.
intros E cy Hwf Hacy;
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].
intros x y Hxy.
apply Hinc; apply trc_step; right; left; auto.
Qed.

Lemma pio_in_le :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  rel_incl (pio_llh E) (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))).
Proof.
intros E cy Hwf Hacy;
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].
intros x y Hxy.
apply Hinc; apply trc_step; right; right; auto.
Qed.

Lemma le_ac :
  forall E cy,
  linear_strict_order
        (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))))
        (events E) ->
  acyclic (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))).
Proof.
intros E cy Hle x Hx; generalize Hle; intro Hlin;
destruct_lin Hle; apply (Hac x).
rewrite (lso_is_tc Hlin) in Hx; auto.
Qed.

Lemma cy_inter_conflict_ppo1_vexec :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  vexec E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))).
Proof.
intros E cy Hwf Hacy;
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].
split; [|split]; auto.

  apply ac_incl with (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))); auto.
    apply le_ac; auto.
    intros x y Hxy; inversion Hxy; auto.
    apply ppo1_in_le; auto.

  apply ac_incl with (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))); auto.
    apply le_ac; auto.
    intros x y Hxy; inversion Hxy; auto.
    apply pio_in_le; auto.
Qed.

Lemma cy_is_or :
  forall E Y cy,
  well_formed_event_structure E ->
  A1bWmm.valid_execution E Y ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  rel_incl cy (tc (rel_union (rel_inter cy (conflict E)) (A2n.ppo E))) ->
  (rf Y =
      so_rfm E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) ->
  (ws Y = so_ws (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) ->
  rel_incl cy (tc (rel_union ((mhbd E Y)) (A2n.ppo E))).
Proof.
intros E Y cy Hwf Hv Hacy Hi Hrf Hws x y Hxy.
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].

generalize (Hi x y Hxy); intro Htc.
clear Hxy.
induction Htc as [x y Hu |]; auto.
  inversion Hu as [Hc | Hppo].
  destruct Hc as [Hxy Hc].
  generalize Hc; intros [Hex [Hey [? [? Hw]]]].
  inversion Hw as [Hwx | Hwy].

    generalize (write_or_read E y Hey); intro Hory.
    inversion Hory as [Hwy | Hry].

    (*Wx Wy*)
      apply trc_step; left;
      split; auto.
       (*split; auto.*)
       apply A2nBasic.ws_in_mhb.
        rewrite Hws; split.
          apply Hinc; apply trc_step; left; split; auto.
          exists (loc x); split; split.
            left; exists y.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwx as [? [lx [vx Hax]]]; unfold write_to; rewrite Hax.
              exists vx; unfold loc; rewrite Hax; auto.
            right; exists x.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwy as [? [ly [vy Hay]]]; unfold write_to; rewrite Hay.
              exists vy; rewrite H; unfold loc; rewrite Hay; auto.

     (*Wx Ry -> (ws)?;rf*)
     destruct_valid Hv.
     generalize (Hrf_init y Hry); intros [wy [Hwy ?]].
     generalize (eqEv_dec x wy); intros [Heq | Hneq].
     apply trc_step; left; split; auto.
     (*split; auto.*) apply rfe2_glob; split; auto.
       subst; auto.

       apply trc_ind with wy.
     assert (ws Y x wy \/ ws Y wy x) as Horxwy.
       generalize (Hws_tot (loc x)); intro Hl.
       destruct_lin Hl.
         assert (In Event (writes_to_same_loc_l (events E) (loc x)) x) as Hx.
           split; auto.
             destruct Hwx as [? [? [vx Hwx]]]; unfold write_to;
             rewrite Hwx; unfold loc; exists vx; rewrite Hwx; auto.
         assert (In Event (writes_to_same_loc_l (events E) (loc x)) wy) as Hwwy.
           split.
             apply A1Basic.dom_rf_in_events with Y y; auto.
               split; auto.
             rewrite H.
               rewrite <- A1Basic.rf_implies_same_loc2 with E Y wy y.
             generalize (A1Basic.dom_rf_is_write E Y wy y Hrf_cands H1);
             intros [? [vy Hwwy]]; unfold write_to;
             rewrite Hwwy; unfold loc; exists vy; rewrite Hwwy; auto.
       split; split; auto. auto.
       generalize (Htot x wy Hneq Hx Hwwy); intro Hor;
       inversion Hor as [Hxwy | Hwyx]; [left | right].
         destruct Hxwy; auto. destruct Hwyx; auto.

     inversion Horxwy as [Hxwy | Hwyx].
     destruct (eqProc_dec (proc_of x) (proc_of wy)) as [Heqp | Hneqp].
       apply trc_step; right; rewrite ppo2_po.
       assert (In _ (events E) wy) as Hewy.
         apply A2nBasic.ran_ws_in_events with Y x; auto.
         split; auto.
       generalize (A2nBasic.same_proc_implies_po x wy Hwf Heqp Hex Hewy);
       intro Hor; inversion Hor; auto.
       assert (tc (rel_union (com E Y) (pio_llh E)) x x) as Hcuni.
         apply trc_ind with wy; apply trc_step.
           left; right; auto.
           right; split; [|split]; auto.
           apply sym_eq.
           apply A1bBasic.ws_implies_same_loc with E Y; auto.
             split; split; auto.
           intros [Hrwy [? [lx [vx Hax]]]].
           destruct Hwx as [? [? [? Hwx]]].
           rewrite Hax in Hwx; inversion Hwx.
           unfold acyclic in Hsp; generalize (Hsp x); intro; contradiction.

       apply trc_step; left; split; auto.
         apply A2nBasic.ws_in_mhb; auto.

       rewrite Hrf in H1; destruct H1 as [? [? Hmax]].
       assert (In Event
         (previous_writes E
            (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) y)
         x) as Hpwx.
         split; auto.
         split; auto.
         apply Hinc; apply trc_step; inversion Hu as [|Hppo2]; [left | right]; auto.
         generalize (A2.ppo_valid Hppo2); intro Hpo.
         generalize (A2nBasic.po_implies_same_proc Hwf Hex Hey Hpo); intro; contradiction.

       assert (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))) wy x) as Hle_wyx.
         rewrite Hws in Hwyx.
         destruct Hwyx; auto.

       assert (In Event
         (previous_writes E
            (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) y)
         x /\
       LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))) wy x) as Hand.
         split; auto.

      generalize (Hmax x Hand); intro Heqwyx.
      assert (x = wy) as Heq'.
        auto.
      contradiction.

     destruct (eqProc_dec (proc_of wy) (proc_of y)) as [Heqp | Hneqp].
       apply trc_step; right.
       assert (rf_intra Y wy y) as Hrfi.
         split; auto.
       apply (rfi2_ppo2 E Hrfi).

       apply trc_step; left; split; auto.
       apply rfe2_glob; auto. split; auto.

    generalize (write_or_read E x Hex); intro Horx.
    inversion Horx as [Hwx | Hrx];
      apply trc_step; left; split; auto.

    (*Wx Wy*)
       (*split; auto.*)
       apply A2nBasic.ws_in_mhb.
        rewrite Hws; split.
          apply Hinc; apply trc_step; left; split; auto.
          exists (loc x); split; split.
            left; exists y.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwx as [? [lx [vx Hax]]]; unfold write_to; rewrite Hax.
              unfold loc; exists vx; rewrite Hax; auto.
            right; exists x.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwy as [? [ly [vy Hay]]]; unfold write_to; exists vy; rewrite Hay.
              rewrite H; unfold loc; rewrite Hay; auto.

   (*Rx Wy*)
      (*split; auto.*)
      apply A2nBasic.fr_in_mhb.
        generalize Hrx; intros [Heex Hrrx]; destruct Hwy as [Heey Hwy];
        split; [|split]; auto.
        destruct_valid Hv.
          generalize (Hrf_init x Hrx); intros [wx [Hewx Hwx]];
          exists wx; split; auto.
          rewrite Hws; split.
          destruct_lin Hle.
          apply Htrans with x; split.
            rewrite Hrf in Hwx; destruct Hwx as [? Hmax].
            destruct Hmax as [[? [? ?]] ?]; auto.
            apply Hinc; apply trc_step; left; split; auto.

            exists (loc x); split; split.
              left; exists x.
                rewrite Hrf in Hwx; destruct Hwx as [Hrfx Hmax].
                destruct Hmax as [Hpw ?].
                destruct Hpw as [? [? ?]]; auto.
                generalize (Hrf_cands wx x Hwx);
                intros [? [? [lx [Hwwx [[vx Hrrrx] ?]]]]].
                unfold loc; rewrite Hrrrx; auto.

              right; exists x.
                apply Hinc; apply trc_step; left; split; auto.
              destruct Hwy as [ly [vy Hay]]; unfold write_to; rewrite Hay.
              rewrite H; unfold loc; exists vy; rewrite Hay; auto.

  (*x ppo2 y*)
  apply trc_step; right; auto.

  apply trc_ind with z; auto.
Qed.

Lemma mv_implies_mvor :
  forall E X cy,
  well_formed_event_structure E ->
  A1bWmm.valid_execution E X ->
  crit_cy E cy ->
  (exists Y, A1bWmm.valid_execution E Y /\
     exists cy', crit_cy_or E Y cy').
Proof.
intros E X cy Hwf Hv1 Hcy.
destruct Hcy as [Hmcy [Hnac [Hi Hac1]]].

assert (exists so, vexec E so /\
    so_rfm E so = so_rfm E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))  /\
    so_ws so = so_ws (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) as Heex.
  exists (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))); split; [|split]; auto.
  apply cy_inter_conflict_ppo1_vexec; auto.

generalize (VA1.ScModel.vexec_is_valid E
  (so_rfm E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))))
  (so_ws (tc ((rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))))) Hwf Heex);
intros [Y [HvY [Hrf Hws]]]; exists Y; split; auto.

exists cy; split; [|split]; auto.
  apply cy_is_or; auto.
  unfold sigma_wf in Hmcy; rewrite union_triv in Hmcy; auto.
Qed.

Lemma cy_or_in_ghb2 :
  forall E X cy,
  well_formed_event_structure E ->
  crit_cy_or E X cy ->
  rel_incl cy (tc (A2nWmm.ghb E X)).
Proof.
intros E X cy Hwf [Hmcy [? [? ?]]] x y Hxy.
rewrite ghb2_is_mhb_ppo2.
generalize (Hmcy x y Hxy); intro Htc.
generalize Htc; apply tc_incl.
intros e1 e2 Hor.
inversion Hor as [Hmhbd | Hppo2].
  destruct Hmhbd as [Hmhb ?].
    left; auto.
  right; auto.
Qed.

Set Implicit Arguments.
Lemma tc_tc :
  forall A (r: Rln A) x y,
  tc (tc r) x y ->
  tc r x y.
Proof.
intros A r x y Hxy.
induction Hxy; auto.
apply trc_ind with z; auto.
Qed.

Lemma ac_implies_tc_ac :
  forall A (r:Rln A),
  acyclic r ->
  acyclic (tc r).
Proof.
intros A r Hac x Hx.
generalize (tc_tc Hx); intro Htc.
apply (Hac x Htc); auto.
Qed.
Unset Implicit Arguments.

Lemma stability_to_SC :
  forall E, well_formed_event_structure E ->
               (exists X, A1bWmm.valid_execution E X) ->
  ((forall X, (A1bWmm.valid_execution E X -> A2nWmm.valid_execution E X)) <->
  (~(exists cy, crit_cy E cy))).
Proof.
intros E Hwf [X Hv1]; split.
  intros Hp [cy Hcy].
  generalize (mv_implies_mvor Hwf Hv1 Hcy);
    intros [Y [Hv1Y [cy' Hcy']]].
  generalize (Hp Y Hv1Y); intro Hv2.
  generalize (cy_or_in_ghb2 Hwf Hcy'); intro Hincl.
  destruct_valid Hv2.
  assert (acyclic (tc (A2nWmm.ghb E Y))) as Hac.
    apply ac_implies_tc_ac; auto.
  generalize (incl_ac Hincl Hac); intro Haccy.
  destruct Hcy' as [? [? [Hnac ?]]].
  contradiction.

  intros Hncy Y Hv1Y.
      generalize (v1_and_no_cy_implies_covered Hwf Hv1Y Hncy); intro Hc.
      apply prop_implies_v2; auto.
Qed.

End StableSC.


Require Import Blech.Defaults.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Category.Bsh.
Require Import Blech.Category.Op.
Require Import Blech.Category.Funct.

Import OpNotations.

Definition PSh (C: Category): Category := Funct (C ᵒᵖ) Bsh.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Computation of resource bounds for Linear code. *)

Require Import FSets FSetAVL.
Require Import Coqlib Ordered.
Require Intv.
Require Import AST.
Require Import Op.
Require Import Machregs Locations.
Require Import Linear.
Require Import Conventions.

Module RegOrd := OrderedIndexed (IndexedMreg).
Module RegSet := FSetAVL.Make (RegOrd).

(** * Resource bounds for a function *)

(** The [bounds] record capture how many local and outgoing stack slots
  and callee-save registers are used by a function. *)

(** We demand that all bounds are positive or null.
  These properties are used later to reason about the layout of
  the activation record. *)

Record bounds : Type := mkbounds {
  used_callee_save: list mreg;
  bound_local: Z;
  bound_outgoing: Z;
  bound_stack_data: Z;
  bound_local_pos: bound_local >= 0;
  bound_outgoing_pos: bound_outgoing >= 0;
  bound_stack_data_pos: bound_stack_data >= 0;
  used_callee_save_norepet: list_norepet used_callee_save;
  used_callee_save_prop: forall r, In r used_callee_save -> is_callee_save r = true
}.

(** The following predicates define the correctness of a set of bounds
    for the code of a function. *)

Section WITHIN_BOUNDS.

Variable b: bounds.

Definition mreg_within_bounds (r: mreg) :=
  is_callee_save r = true -> In r (used_callee_save b).

Definition slot_within_bounds (sl: slot) (ofs: Z) (ty: typ) :=
  match sl with
  | Local => ofs + typesize ty <= bound_local b
  | Outgoing => ofs + typesize ty <= bound_outgoing b
  | Incoming => True
  end.

Definition instr_within_bounds (i: instruction) :=
  match i with
  | Lgetstack sl ofs ty r => slot_within_bounds sl ofs ty /\ mreg_within_bounds r
  | Lsetstack r sl ofs ty => slot_within_bounds sl ofs ty
  | Lop op args res => mreg_within_bounds res
  | Lload chunk addr args dst => mreg_within_bounds dst
  | Lcall sig ros => size_arguments sig <= bound_outgoing b
  | Lbuiltin ef args res =>
       (forall r, In r (params_of_builtin_res res) \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r)
    /\ (forall sl ofs ty, In (S sl ofs ty) (params_of_builtin_args args) -> slot_within_bounds sl ofs ty)
  | _ => True
  end.

End WITHIN_BOUNDS.

Definition function_within_bounds (f: function) (b: bounds) : Prop :=
  forall instr, In instr f.(fn_code) -> instr_within_bounds b instr.

(** * Inference of resource bounds for a function *)

(** The resource bounds for a function are computed by a linear scan
  of its instructions. *)

Section BOUNDS.

Variable f: function.

Definition record_reg (u: RegSet.t) (r: mreg) : RegSet.t :=
  if is_callee_save r then RegSet.add r u else u.

Definition record_regs (u: RegSet.t) (rl: list mreg) : RegSet.t :=
  fold_left record_reg rl u.

(** In the proof of the [Stacking] pass, we only need to bound the
  registers written by an instruction.  Therefore, we examine the
  result registers only, not the argument registers. *)

Definition record_regs_of_instr (u: RegSet.t) (i: instruction) : RegSet.t :=
  match i with
  | Lgetstack sl ofs ty r => record_reg u r
  | Lsetstack r sl ofs ty => record_reg u r
  | Lop op args res => record_reg u res
  | Lload chunk addr args dst => record_reg u dst
  | Lstore chunk addr args src => u
  | Lcall sig ros => u
  | Ltailcall sig ros => u
  | Lbuiltin ef args res =>
      record_regs (record_regs u (params_of_builtin_res res)) (destroyed_by_builtin ef)
  | Llabel lbl => u
  | Lgoto lbl => u
  | Lcond cond args lbl => u
  | Ljumptable arg tbl => u
  | Lreturn => u
  end.

Definition record_regs_of_function : RegSet.t :=
  fold_left record_regs_of_instr f.(fn_code) RegSet.empty.

Fixpoint slots_of_locs (l: list loc) : list (slot * Z * typ) :=
  match l with
  | nil => nil
  | S sl ofs ty :: l' => (sl, ofs, ty) :: slots_of_locs l'
  | R r :: l' => slots_of_locs l'
  end.

Definition slots_of_instr (i: instruction) : list (slot * Z * typ) :=
  match i with
  | Lgetstack sl ofs ty r => (sl, ofs, ty) :: nil
  | Lsetstack r sl ofs ty => (sl, ofs, ty) :: nil
  | Lbuiltin ef args res => slots_of_locs (params_of_builtin_args args)
  | _ => nil
  end.

Definition max_over_list {A: Type} (valu: A -> Z) (l: list A) : Z :=
  List.fold_left (fun m l => Z.max m (valu l)) l 0.

Definition max_over_instrs (valu: instruction -> Z) : Z :=
  max_over_list valu f.(fn_code).

Definition max_over_slots_of_instr (valu: slot * Z * typ -> Z) (i: instruction) : Z :=
  max_over_list valu (slots_of_instr i).

Definition max_over_slots_of_funct (valu: slot * Z * typ -> Z) : Z :=
  max_over_instrs (max_over_slots_of_instr valu).

Definition local_slot (s: slot * Z * typ) :=
  match s with (Local, ofs, ty) => ofs + typesize ty | _ => 0 end.

Definition outgoing_slot (s: slot * Z * typ) :=
  match s with (Outgoing, ofs, ty) => ofs + typesize ty | _ => 0 end.

Definition outgoing_space (i: instruction) :=
  match i with Lcall sig _ => size_arguments sig | _ => 0 end.

Lemma max_over_list_pos:
  forall (A: Type) (valu: A -> Z) (l: list A),
  max_over_list valu l >= 0.
Proof.
  intros until valu. unfold max_over_list.
  assert (forall l z, fold_left (fun x y => Z.max x (valu y)) l z >= z).
  induction l; simpl; intros.
  lia. apply Zge_trans with (Z.max z (valu a)).
  auto. apply Z.le_ge. apply Z.le_max_l. auto.
Qed.

Lemma max_over_slots_of_funct_pos:
  forall (valu: slot * Z * typ -> Z), max_over_slots_of_funct valu >= 0.
Proof.
  intros. unfold max_over_slots_of_funct.
  unfold max_over_instrs. apply max_over_list_pos.
Qed.

(* Move elsewhere? *)

Remark fold_left_preserves:
  forall (A B: Type) (f: A -> B -> A) (P: A -> Prop),
  (forall a b, P a -> P (f a b)) ->
  forall l a, P a -> P (fold_left f l a).
Proof.
  induction l; simpl; auto.
Qed.

Remark fold_left_ensures:
  forall (A B: Type) (f: A -> B -> A) (P: A -> Prop) b0,
  (forall a b, P a -> P (f a b)) ->
  (forall a, P (f a b0)) ->
  forall l a, In b0 l -> P (fold_left f l a).
Proof.
  induction l; simpl; intros. contradiction.
  destruct H1. subst a. apply fold_left_preserves; auto. apply IHl; auto.
Qed.

Definition only_callee_saves (u: RegSet.t) : Prop :=
  forall r, RegSet.In r u -> is_callee_save r = true.

Lemma record_reg_only: forall u r, only_callee_saves u -> only_callee_saves (record_reg u r).
Proof.
  unfold only_callee_saves, record_reg; intros.
  destruct (is_callee_save r) eqn:CS; auto.
  destruct (mreg_eq r r0). congruence. apply H; eapply RegSet.add_3; eauto.
Qed.

Lemma record_regs_only: forall rl u, only_callee_saves u -> only_callee_saves (record_regs u rl).
Proof.
  intros. unfold record_regs. apply fold_left_preserves; auto using record_reg_only.
Qed.

Lemma record_regs_of_instr_only: forall u i, only_callee_saves u -> only_callee_saves (record_regs_of_instr u i).
Proof.
  intros. destruct i; simpl; auto using record_reg_only, record_regs_only.
Qed.

Lemma record_regs_of_function_only:
  only_callee_saves record_regs_of_function.
Proof.
  intros. unfold record_regs_of_function.
  apply fold_left_preserves. apply record_regs_of_instr_only.
  red; intros. eelim RegSet.empty_1; eauto.
Qed.

Program Definition function_bounds := {|
  used_callee_save := RegSet.elements record_regs_of_function;
  bound_local := max_over_slots_of_funct local_slot;
  bound_outgoing := Z.max (max_over_instrs outgoing_space) (max_over_slots_of_funct outgoing_slot);
  bound_stack_data := Z.max f.(fn_stacksize) 0
|}.
Next Obligation.
  apply max_over_slots_of_funct_pos.
Qed.
Next Obligation.
  apply Z.le_ge. eapply Z.le_trans. 2: apply Z.le_max_r.
  apply Z.ge_le. apply max_over_slots_of_funct_pos.
Qed.
Next Obligation.
  apply Z.le_ge. apply Z.le_max_r.
Qed.
Next Obligation.
  generalize (RegSet.elements_3w record_regs_of_function).
  generalize (RegSet.elements record_regs_of_function).
  induction 1. constructor. constructor; auto.
  red; intros; elim H. apply InA_alt. exists x; auto.
Qed.
Next Obligation.
  apply record_regs_of_function_only. apply RegSet.elements_2.
  apply InA_alt. exists r; auto.
Qed.

(** We now show the correctness of the inferred bounds. *)

Lemma record_reg_incr: forall u r r', RegSet.In r' u -> RegSet.In r' (record_reg u r).
Proof.
  unfold record_reg; intros. destruct (is_callee_save r); auto. apply RegSet.add_2; auto.
Qed.

Lemma record_reg_ok: forall u r, is_callee_save r = true -> RegSet.In r (record_reg u r).
Proof.
  unfold record_reg; intros. rewrite H. apply RegSet.add_1; auto.
Qed.

Lemma record_regs_incr: forall r' rl u, RegSet.In r' u -> RegSet.In r' (record_regs u rl).
Proof.
  intros. unfold record_regs. apply fold_left_preserves; auto using record_reg_incr.
Qed.

Lemma record_regs_ok: forall r rl u, In r rl -> is_callee_save r = true -> RegSet.In r (record_regs u rl).
Proof.
  intros. unfold record_regs. eapply fold_left_ensures; eauto using record_reg_incr, record_reg_ok.
Qed.

Lemma record_regs_of_instr_incr: forall r' u i, RegSet.In r' u -> RegSet.In r' (record_regs_of_instr u i).
Proof.
  intros. destruct i; simpl; auto using record_reg_incr, record_regs_incr.
Qed.

Definition defined_by_instr (r': mreg) (i: instruction) :=
  match i with
  | Lgetstack sl ofs ty r => r' = r
  | Lop op args res => r' = res
  | Lload chunk addr args dst => r' = dst
  | Lbuiltin ef args res => In r' (params_of_builtin_res res) \/ In r' (destroyed_by_builtin ef)
  | _ => False
  end.

Lemma record_regs_of_instr_ok: forall r' u i, defined_by_instr r' i -> is_callee_save r' = true -> RegSet.In r' (record_regs_of_instr u i).
Proof.
  intros. destruct i; simpl in *; try contradiction; subst; auto using record_reg_ok.
  destruct H; auto using record_regs_incr, record_regs_ok.
Qed.

Lemma record_regs_of_function_ok:
  forall r i, In i f.(fn_code) -> defined_by_instr r i -> is_callee_save r = true -> RegSet.In r record_regs_of_function.
Proof.
  intros. unfold record_regs_of_function.
  eapply fold_left_ensures; eauto using record_regs_of_instr_incr, record_regs_of_instr_ok.
Qed.

Lemma max_over_list_bound:
  forall (A: Type) (valu: A -> Z) (l: list A) (x: A),
  In x l -> valu x <= max_over_list valu l.
Proof.
  intros until x. unfold max_over_list.
  assert (forall c z,
            let f := fold_left (fun x y => Z.max x (valu y)) c z in
            z <= f /\ (In x c -> valu x <= f)).
    induction c; simpl; intros.
    split. lia. tauto.
    elim (IHc (Z.max z (valu a))); intros.
    split. apply Z.le_trans with (Z.max z (valu a)). apply Z.le_max_l. auto.
    intro H1; elim H1; intro.
    subst a. apply Z.le_trans with (Z.max z (valu x)).
    apply Z.le_max_r. auto. auto.
  intro. elim (H l 0); intros. auto.
Qed.

Lemma max_over_instrs_bound:
  forall (valu: instruction -> Z) i,
  In i f.(fn_code) -> valu i <= max_over_instrs valu.
Proof.
  intros. unfold max_over_instrs. apply max_over_list_bound; auto.
Qed.

Lemma max_over_slots_of_funct_bound:
  forall (valu: slot * Z * typ -> Z) i s,
  In i f.(fn_code) -> In s (slots_of_instr i) ->
  valu s <= max_over_slots_of_funct valu.
Proof.
  intros. unfold max_over_slots_of_funct.
  apply Z.le_trans with (max_over_slots_of_instr valu i).
  unfold max_over_slots_of_instr. apply max_over_list_bound. auto.
  apply max_over_instrs_bound. auto.
Qed.

Lemma local_slot_bound:
  forall i ofs ty,
  In i f.(fn_code) -> In (Local, ofs, ty) (slots_of_instr i) ->
  ofs + typesize ty <= bound_local function_bounds.
Proof.
  intros.
  unfold function_bounds, bound_local.
  change (ofs + typesize ty) with (local_slot (Local, ofs, ty)).
  eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma outgoing_slot_bound:
  forall i ofs ty,
  In i f.(fn_code) -> In (Outgoing, ofs, ty) (slots_of_instr i) ->
  ofs + typesize ty <= bound_outgoing function_bounds.
Proof.
  intros. change (ofs + typesize ty) with (outgoing_slot (Outgoing, ofs, ty)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_r. eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma size_arguments_bound:
  forall sig ros,
  In (Lcall sig ros) f.(fn_code) ->
  size_arguments sig <= bound_outgoing function_bounds.
Proof.
  intros. change (size_arguments sig) with (outgoing_space (Lcall sig ros)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_l. apply max_over_instrs_bound; auto.
Qed.

(** Consequently, all machine registers or stack slots mentioned by one
  of the instructions of function [f] are within bounds. *)

Lemma mreg_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall r, defined_by_instr r i ->
  mreg_within_bounds function_bounds r.
Proof.
  intros. unfold mreg_within_bounds. intros.
  exploit record_regs_of_function_ok; eauto. intros.
  apply RegSet.elements_1 in H2. rewrite InA_alt in H2. destruct H2 as (r' & A & B).
  subst r'; auto.
Qed.

Lemma slot_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall sl ty ofs, In (sl, ofs, ty) (slots_of_instr i) ->
  slot_within_bounds function_bounds sl ofs ty.
Proof.
  intros. unfold slot_within_bounds.
  destruct sl.
  eapply local_slot_bound; eauto.
  auto.
  eapply outgoing_slot_bound; eauto.
Qed.

Lemma slots_of_locs_charact:
  forall sl ofs ty l, In (sl, ofs, ty) (slots_of_locs l) <-> In (S sl ofs ty) l.
Proof.
  induction l; simpl; intros.
  tauto.
  destruct a; simpl; intuition congruence.
Qed.

(** It follows that every instruction in the function is within bounds,
    in the sense of the [instr_within_bounds] predicate. *)

Lemma instr_is_within_bounds:
  forall i,
  In i f.(fn_code) ->
  instr_within_bounds function_bounds i.
Proof.
  intros;
  destruct i;
  generalize (mreg_is_within_bounds _ H); generalize (slot_is_within_bounds _ H);
  simpl; intros; auto.
(* call *)
  eapply size_arguments_bound; eauto.
(* builtin *)
  split; intros.
  apply H1; auto.
  apply H0. rewrite slots_of_locs_charact; auto.
Qed.

Lemma function_is_within_bounds:
  function_within_bounds f function_bounds.
Proof.
  intros; red; intros. apply instr_is_within_bounds; auto.
Qed.

End BOUNDS.

(** Helper to determine the size of the frame area that holds the contents of saved registers. *)

Fixpoint size_callee_save_area_rec (l: list mreg) (ofs: Z) : Z :=
  match l with
  | nil => ofs
  | r :: l =>
      let ty := mreg_type r in
      let sz := AST.typesize ty in
      size_callee_save_area_rec l (align ofs sz + sz)
  end.

Definition size_callee_save_area (b: bounds) (ofs: Z) : Z :=
  size_callee_save_area_rec (used_callee_save b) ofs.

Lemma size_callee_save_area_rec_incr:
  forall l ofs, ofs <= size_callee_save_area_rec l ofs.
Proof.
Local Opaque mreg_type.
  induction l as [ | r l]; intros; simpl.
- lia.
- eapply Z.le_trans. 2: apply IHl.
  generalize (AST.typesize_pos (mreg_type r)); intros.
  apply Z.le_trans with (align ofs (AST.typesize (mreg_type r))).
  apply align_le; auto.
  lia.
Qed.

Lemma size_callee_save_area_incr:
  forall b ofs, ofs <= size_callee_save_area b ofs.
Proof.
  intros. apply size_callee_save_area_rec_incr.
Qed.

(** Layout of the stack frame and its properties.  These definitions
  are used in the machine-dependent [Stacklayout] module and in the
  [Stacking] pass. *)

Record frame_env : Type := mk_frame_env {
  fe_size: Z;
  fe_ofs_link: Z;
  fe_ofs_retaddr: Z;
  fe_ofs_local: Z;
  fe_ofs_callee_save: Z;
  fe_stack_data: Z;
  fe_used_callee_save: list mreg
}.


Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.Named.Wf.
Require Import Crypto.Compilers.Named.ContextDefinitions.
Require Import Crypto.Compilers.Named.ContextProperties.
Require Import Crypto.Compilers.Named.ContextProperties.SmartMap.
Require Import Crypto.Compilers.Named.InterpretToPHOAS.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {Name : Type}
          {base_type_code_dec : DecidableRel (@eq base_type_code)}
          {Name_dec : DecidableRel (@eq Name)}.
  Section with_var.
    Context {var1 var2 : base_type_code -> Type}
            {Context1 : Context Name var1}
            {Context2 : Context Name var2}
            {Context1Ok : ContextOk Context1}
            {Context2Ok : ContextOk Context2}
            (failb1 : forall t, @Syntax.exprf base_type_code op var1 (Tbase t))
            (failb2 : forall t, @Syntax.exprf base_type_code op var2 (Tbase t)).

    Local Ltac t_step :=
      first [ progress intros
            | progress unfold dec in *
            | reflexivity
            | progress subst
            | progress inversion_option
            | erewrite lookupb_extend by assumption
            | rewrite <- !find_Name_and_val_None_iff
            | progress break_innermost_match_step
            | progress break_match_hyps
            | solve [ eauto using find_Name_and_val_flatten_binding_list ]
            | congruence
            | tauto
            | match goal with
              | [ H : lookupb (extend _ _ _) _ = _ |- _ ]
                => erewrite (lookupb_extend _ _ _) in H by assumption
              | [ H : context[List.In _ (_ ++ _)] |- _ ]
                => setoid_rewrite List.in_app_iff in H
              | [ |- context[List.In _ (_ ++ _)] ]
                => rewrite List.in_app_iff
              | [ |- context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] ]
                => lazymatch default with None => fail | _ => idtac end;
                   rewrite (find_Name_and_val_split tdec ndec (default:=default))
              | [ H : context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] |- _ ]
                => lazymatch default with None => fail | _ => idtac end;
                   rewrite (find_Name_and_val_split tdec ndec (default:=default)) in H
              | [ H : forall n t, lookupb _ n = None <-> lookupb _ n = None |- context[lookupb _ _ = None] ]
                => rewrite H
              | [ H : forall n t, lookupb _ n = None |- context[lookupb _ _ = None] ]
                => rewrite H
              end ].
    Local Ltac t := repeat t_step.

    Lemma wff_interpf_to_phoas
          (ctx1 : Context1) (ctx2 : Context2)
          {t} (e : @Named.exprf base_type_code op Name t)
          (Hwf1 : prop_of_option (Named.wff ctx1 e))
          (Hwf2 : prop_of_option (Named.wff ctx2 e))
          G
          (HG : forall n t v1 v2,
              lookupb t ctx1 n = Some v1
              -> lookupb t ctx2 n = Some v2
              -> List.In (existT _ t (v1, v2)%core) G)
          (Hctx1_ctx2 : forall n t,
              lookupb t ctx1 n = None <-> lookupb t ctx2 n = None)
      : wff G (interpf_to_phoas failb1 ctx1 e) (interpf_to_phoas failb2 ctx2 e).
    Proof using Context1Ok Context2Ok Name_dec base_type_code_dec.
      revert dependent G; revert dependent ctx1; revert dependent ctx2; induction e;
        repeat first [ progress intros
                     | progress destruct_head' and
                     | progress break_innermost_match_step
                     | progress simpl in *
                     | progress autorewrite with push_prop_of_option in *
                     | solve [ eauto | tauto ]
                     | match goal with
                       | [ |- wff _ _ _ ] => constructor
                       end ].
      match goal with H : _ |- _ => eapply H end; t.
    Qed.

    Lemma wf_interp_to_phoas_gen
          (ctx1 : Context1) (ctx2 : Context2)
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf1 : Named.wf ctx1 e)
          (Hwf2 : Named.wf ctx2 e)
          (Hctx1 : forall n t, lookupb t ctx1 n = None)
          (Hctx2 : forall n t, lookupb t ctx2 n = None)
      : wf (interp_to_phoas failb1 ctx1 e) (interp_to_phoas failb2 ctx2 e).
    Proof using Context1Ok Context2Ok Name_dec base_type_code_dec.
      constructor; intros.
      apply wff_interpf_to_phoas; t.
    Qed.

    Lemma wf_interp_to_phoas
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf1 : Named.wf (Context:=Context1) empty e)
          (Hwf2 : Named.wf (Context:=Context2) empty e)
      : wf (interp_to_phoas (Context:=Context1) failb1 empty e) (interp_to_phoas (Context:=Context2) failb2 empty e).
    Proof using Context1Ok Context2Ok Name_dec base_type_code_dec.
      apply wf_interp_to_phoas_gen; auto using lookupb_empty.
    Qed.
  End with_var.

  Section all.
    Context {Context : forall var, @Context base_type_code Name var}
            {ContextOk : forall var, ContextOk (Context var)}
            (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)).

    Lemma Wf_InterpToPHOAS_gen
          {ctx : forall var, Context var}
          {t} (e : @Named.expr base_type_code op Name t)
          (Hctx : forall var n t, lookupb t (ctx var) n = None)
          (Hwf : forall var, Named.wf (ctx var) e)
      : Wf (InterpToPHOAS_gen failb ctx e).
    Proof using ContextOk Name_dec base_type_code_dec.
      intros ??; apply wf_interp_to_phoas_gen; auto.
    Qed.

    Lemma Wf_InterpToPHOAS
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf : Named.Wf Context e)
      : Wf (InterpToPHOAS (Context:=Context) failb e).
    Proof using ContextOk Name_dec base_type_code_dec.
      intros ??; apply wf_interp_to_phoas; auto.
    Qed.
  End all.
End language.

Hint Resolve Wf_InterpToPHOAS : wf.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import NArith QArith String.
Require Import ProofIrrelevance.

(*Avoid clash with Ssreflect*)
Delimit Scope Q_scope with coq_Qscope.
Definition Qcoq := Q.

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 OUVerT.strings.
Require Import OUVerT.extrema OUVerT.dist OUVerT.numerics
        OUVerT.bigops OUVerT.dyadic.
Require Import games compile smooth christodoulou combinators.
Require Import OUVerT.listlemmas OUVerT.maplemmas subsettypes.

Local Open Scope ring_scope.

(******************************************
  Resource Games are Compilable
 ******************************************)
Instance resourceEnumerableInstance : Enumerable resource :=
  [:: RYes; RNo].

Program Instance resourceRefineTypeAxiomInstance
  : @RefineTypeAxiomClass [finType of resource] _.
Next Obligation.
  by split => // r; rewrite mem_enum; case: r.
Qed.

Instance resourceRefineTypeInstance
  : @RefineTypeClass [finType of resource] _ _.

Definition ctraffic (N : nat) (m : M.t resource) : N.t :=
  (M.fold (fun i r acc =>
             if (i < N)%N
             then match r with
                  | RYes => acc + 1
                  | RNo => acc
                   end
             else acc)
          m 0)%num.

Lemma ctraffic_sub0 N (l : seq (M.key * resource)) n :
  (List.fold_left
    (fun acc p =>
        if ((nat_of_bin p.1) < N)%N
          then match p.2 with
               | RYes => acc + 1
               | RNo => acc
               end
          else acc)
    l n
      =
  (List.fold_left
    (fun acc p =>
        if ( (nat_of_bin p.1) < N)%N
          then match p.2 with
               | RYes => acc + 1
               | RNo => acc
               end
          else acc)
    l 0 + n))%num.
Proof.
  move: n.
  induction l => //=.
  move => n.
  case: (a.1 < N)%N => //.
  case: a.2; rewrite IHl => //=.
  rewrite (IHl 1%num).
  rewrite -N.add_assoc.
  f_equal.
  apply N.add_comm.
Qed.

Lemma ctraffic_subP N l n :
  (List.fold_left
    (fun acc p =>
        if (nat_of_bin p.1 < N)%N
          then match p.2 with
               | RYes => acc + 1
               | RNo => acc
               end
          else acc)
    l n
      =
  List.fold_left
    (fun acc p =>
        if (nat_of_bin p.1 < N)%N
          then match p.2 with
               | RYes => acc + 1
               | RNo => acc
               end
          else acc)
    (List.rev l) n)%num.
Proof.
  rewrite -List.fold_left_rev_right.
  induction (List.rev l) => //=.
  rewrite IHl0.
  case: (a.1 < N)%N => //.
  case: (a.2) => //.
  rewrite (ctraffic_sub0 _ _ (n+1)%num) ctraffic_sub0.
  by rewrite N.add_assoc.
Qed.

Lemma ctraffic_filter_sub0 (l : seq (M.key * resource)) n :
  (List.fold_left
    (fun acc p =>
      match p.2 with
      | RYes => acc + 1
      | RNo => acc
      end)
    l n
      =
  (List.fold_left
    (fun acc p =>
      match p.2 with
      | RYes => acc + 1
      | RNo => acc
      end)
    l 0 + n))%num.
Proof.
  move: n; induction l => //.
  move => n => /=.
  rewrite IHl.
  case: a.2 => //.
  rewrite (IHl (0+1)%num) N.add_0_l.
  rewrite (N.add_comm n 1) N.add_assoc //.
Qed.

Lemma ctraffic_subF N l n :
  (List.fold_left
    (fun acc p =>
        if (nat_of_bin p.1 < N)%N
          then match p.2 with
               | RYes => acc + 1
               | RNo => acc
               end
          else acc)
    l n
      =
  List.fold_left
    (fun acc p =>
      match p.2 with
      | RYes => acc + 1
      | RNo => acc
      end)
    (List.filter (fun p => (nat_of_bin p.1 < N)%N) l) n)%num.
Proof.
  move: n.
  set f :=
   (fun (acc : N.t) (p : BinNums.N * resource) =>
    if (p.1 < N)%N
    then match p.2 with
        | RYes => (acc + 1)%num
        | RNo => acc
        end
    else acc).
  set f' :=
   (fun (acc : N.t) (p : BinNums.N * resource) =>
   match p.2 with
   | RYes => (acc + 1)%num
   | RNo => acc
   end).
  induction l => //=.
  move => n.
  rewrite ctraffic_sub0 IHl.
  rewrite /f {2}/f'.
  case: (a.1 < N)%N => //=.
  case: a.2.
  rewrite (ctraffic_filter_sub0 _ (n+1)%num) => //.
  rewrite -/f'. symmetry.
  apply ctraffic_filter_sub0.
  rewrite -ctraffic_filter_sub0 => //.
Qed.

Lemma absz_plus a b :
  0 <= a -> 0 <= b ->
  @eq nat_eqType (absz (@GRing.add (GRing.Ring.zmodType int_Ring) a b))
      ((absz a) + (absz b))%N.
Proof. case: a; try auto; case: b => //. Qed.

Lemma rat_to_Q_s_add x (pfx : 0 <= x) :
  (rat_to_Q 1 + rat_to_Q x)%coq_Qscope = rat_to_Q (1 + x).
Proof.
  have Hx1: (le_rat 0 x) by [].
  move: pfx. rewrite ge_rat0 in Hx1. rewrite /numq in Hx1. move: Hx1.
  case: x =>  x.
  case: x => x1 x2 => /= => pf Hx1 pfx. clear pfx.
  rewrite /(GRing.add (V := rat_Ring)) /GRing.Zmodule.add => /=.
  rewrite /addq /addq_subdef => /=.
  rewrite gcdn1 div.divn1 mul1r mulr1.
  rewrite rat_to_Q_fracq_pos_leib /rat_to_Q => /=.
  rewrite /Qplus.
  rewrite Z.mul_1_r Z.mul_1_l => /=.
  f_equal.
  rewrite -int_to_Z_plus.
  {
    case_eq (int_to_Z x1).
    {
      move => H. rewrite Z.add_0_r.
      rewrite /int_to_Z.
      destruct x2. rewrite /int_to_positive.
      rewrite Z_of_nat_pos_of_nat => //.
      case/andP: pf => //.
      case/andP: pf => //.
    }
    {
      move => p H.
      rewrite /int_to_Z.
      destruct x2. rewrite /int_to_positive.
      rewrite Z_of_nat_pos_of_nat => //.
      case/andP: pf => //.
      case/andP: pf => //.
    }
    {
      move => p H.
      rewrite /int_to_Z.
      destruct x2. rewrite /int_to_positive.
      rewrite Z_of_nat_pos_of_nat => //.
      case/andP: pf => //.
      case/andP: pf => //.
    }
  }
  case/andP: pf => //.
  {
    case/andP: pf => H0 H1.
    move: H1. rewrite /coprime. move => /eqP H1. apply /eqP.
    rewrite absz_plus; auto.
    by rewrite gcdnC gcdnDl gcdnC.
  }
Qed.

Lemma Qplus_leib_comm x y:
  (x + y)%coq_Qscope = (y + x)%coq_Qscope.
Proof.
  case: x => x1 x2.
  case: y => y1 y2.
  rewrite /Qplus /Qnum /Qden => //.
  f_equal. ring. apply Pmult_comm.
Qed.

Lemma Qplus_leib_assoc x y z:
  (x + (y + z))%coq_Qscope = ((x + y) + z)%coq_Qscope.
Proof.
  case x => x1 x2.
  case y => y1 y2.
  case z => z1 z2.
  rewrite !/Qplus !/Qnum !/Qden => //.
  f_equal. ring_simplify.
  rewrite Pos.mul_comm [(x2 * y2)%positive] Pos.mul_comm.
  rewrite !Pos2Z.inj_mul !Zmult_assoc //.
  apply Pmult_assoc.
Qed.

Lemma Qplus_leib_0_l x : (0 + x)%coq_Qscope = x.
Proof.
  case: x => x1 x2.
  rewrite /Qplus /Qnum /Qden.
  f_equal. ring.
Qed.

Lemma ctraffic_sub_subP (l : seq (M.key*resource)):
  let f :=
    (fun acc p =>
      match p.2 with
      | RYes => (acc + 1)%num
      | RNo => acc
      end) in
  N_to_Q (List.fold_left f l 0)%num
    =
  rat_to_Q
    ((count
      (fun p => p.2  == RYes)
      l)%:R).
Proof.
  induction l => //=.
  have H : rat_to_Q 1 = 1%coq_Qscope by rewrite /rat_to_Q => //.
  have Hx : N_to_Q 1 = 1%coq_Qscope by [].
  have Hy : N_to_Q 0 = 0%coq_Qscope by [].
  case: a.2; rewrite ctraffic_filter_sub0 /= N_to_Q_plus IHl; set Y := count _ _.
  { rewrite Hx natrD -rat_to_Q_s_add.
    by rewrite Qplus_leib_comm H.
    have H1: (0%:R <= (count (fun p : M.key * resource => p.2 == RYes) l)%:R).
    { move => t. by rewrite ler_nat. }
    by apply: H1. }
  by rewrite Hy addnC addn0 Qplus_leib_comm Qplus_leib_0_l.
Qed.

Definition resource_ccost N (i : OrdNat.t) (m : M.t resource) : D :=
  match M.find i m with
  | Some RYes => N_to_D (ctraffic N m)
  | Some RNo => D0
  | None => D0 (*won't occur when i < N*)
  end.

Global Instance resourceCCostInstance N : CCostClass N resource
  := resource_ccost N.

Definition lift_traffic N (s : {ffun 'I_N -> resource})
  : seq (M.key*resource):=
 map
  (fun (x : 'I_N) => ((N.of_nat x), s x))
  (index_enum (ordinal_finType N)).

Lemma list_trafficP N (s : {ffun 'I_N -> resource}) :
  count (fun j : (M.key*resource) => j.2 == RYes) (lift_traffic s)
  =
  count (fun j: ordinal_finType N => s j == RYes)
    (index_enum (ordinal_finType N)).
Proof.
  rewrite count_map => /=.
  rewrite -!sum1_count => //.
Qed.

Lemma N_of_nat_of_bin x :
  N.of_nat (nat_of_bin x) = x.
Proof.
  rewrite /nat_of_bin.
  case: x => // p.
  have H: (nat_of_pos p = Pos.to_nat p).
  {  elim: p => // p IHp /=.
     - by rewrite Pos2Nat.inj_xI IHp NatTrec.doubleE -mul2n.
     - by rewrite Pos2Nat.inj_xO IHp NatTrec.doubleE -mul2n.
  }
  rewrite H. by apply positive_nat_N.
Qed.

Lemma of_bin_N_of_nat x :
  nat_of_bin (N.of_nat x) = x.
Proof.
  case: x => // p => //=.
  rewrite of_succ_nat_of_nat_plus_1.
  have H: forall m, nat_of_pos m = Pos.to_nat m.
  { move => m; elim: m => // m IHp /=.
     - by rewrite Pos2Nat.inj_xI IHp NatTrec.doubleE -mul2n.
     - by rewrite Pos2Nat.inj_xO IHp NatTrec.doubleE -mul2n.
  }
  rewrite H. rewrite Nat2Pos.id; first by apply addn1.
  case p => //.
Qed.

Lemma InA_NoDupA_Unique A eqA x1 x2 :
  Equivalence eqA ->
  forall l, @SetoidList.NoDupA A eqA l ->
    List.In x1 l ->
    List.In x2 l ->
    eqA x1 x2 ->
      x1 = x2.
Proof.
  induction l => H0 H1 H2 H3; first by inversion H1.
  inversion H0; subst.
  case: H1 => H1; case: H2 => H2; subst => //=.
  {
    inversion H0. apply False_rec. apply H6 => //.
    apply SetoidList.InA_alt.
    exists x2; split => //.
  }
  {
    inversion H0. apply False_rec. apply H6 => //.
    apply SetoidList.InA_alt.
    exists x1; split => //. symmetry => //.
  }
  {
    apply IHl; inversion H0 => //.
  }
Qed.

(*FIXME: MOVE*)
Lemma eq_Qeq q r : q=r -> Qeq q r.
Proof. by move => ->; apply: Qeq_refl. Qed.

Program Instance resourceRefineCostAxiomInstance N
  : @RefineCostAxiomClass N [finType of resource] _ _.
Next Obligation.
  rewrite /(ccost) /resourceCCostInstance /resource_ccost.
  rewrite (H i pf).
  rewrite /(cost) /resourceCostInstance /= /resourceCostFun /=.
  case H2: (s _) => //.
  rewrite /ctraffic M.fold_1 trafficP /traffic' ctraffic_subF.
  move: (M.elements_3w m) => H1.
  rewrite N_to_D_to_Q.
  rewrite ctraffic_sub_subP.
  apply: eq_Qeq.
  f_equal.
  rewrite sum1_count.
  rewrite -list_trafficP.
  f_equal.
  apply /perm_eqP.
  apply uniq_perm_eq.
  {
    induction M.elements => //=.
    case: (a.1 < N)%N => //=.
    {
      apply /andP; split.
      {
        inversion H1; subst.
        apply/negP => H6.
        apply H4.
        rewrite mem_filter in H6.
        case/andP: H6 => H6 H7.
        apply SetoidList.InA_alt.
        exists a.
        split => //.
        apply list_in_iff in H7. apply H7.
      }
      {
        apply IHl.
        inversion H1 => //.
      }
    }
    {
      apply IHl.
      inversion H1 => //.
    }
  }
  {
    rewrite /lift_traffic.
    rewrite map_inj_uniq /index_enum.
    rewrite -enumT => /=.
    apply enum_uniq.
    rewrite /injective => x1 x2 H0.
    inversion H0.
    apply Nnat.Nat2N.inj_iff in H4.
    apply ord_inj in H4 => //.
  }
  {
    rewrite /lift_traffic.
    rewrite /eq_mem => x.
    case_eq
      (x \in List.filter (fun p : BinNums.N * resource => (p.1 < N)%N)
         (M.elements (elt:=resource) m)) => H4.
    {
       rewrite mem_filter in H4.
       case/andP: H4 => H4 H5.
      have H7: exists x', (fun x0 : ordinal N => pair (N.of_nat x0) (s x0)) x' = x.
      {
        specialize (H x.1 H4).
        rewrite MProps.F.elements_o in H.
        apply SetoidList.findA_NoDupA in H => //;
          last by constructor => //=; apply N.eq_trans.
        apply list_in_iff in H5.
        apply SetoidList.InA_alt in H.
        case: H => x' H => /=.
        case: H => H H6.
        case: H => H' H''.
        simpl in H', H''.
        rewrite /N.eq in H'.
        have H: x = x'.
        apply InA_NoDupA_Unique
          with (eqA := (M.eq_key (elt := resource)))
               (l := (M.elements (elt := resource) m)) => //;
          first by apply MProps.eqk_equiv.
        exists (Ordinal H4) => //.
        destruct x as [x1 x2].
        destruct x' as [x1' x2'].
        inversion H. simpl.
        f_equal => //.
        dependent rewrite H3.
        f_equal.
        apply N_of_nat_of_bin.
      }
      case: H7 => x' H7. rewrite -H7.
      rewrite /index_enum -enumT.
      rewrite mem_map; first by rewrite mem_enum => //.
      {
        rewrite /injective => x1 x2 H0.
        inversion H0.
        apply Nnat.Nat2N.inj_iff in H6.
        apply ord_inj in H6 => //.
      }
    }
    {
      rewrite mem_filter in H4.
      case_eq (x \in [seq (N.of_nat (nat_of_ord x0), fun_of_fin s x0)
                | x0 <- index_enum (ordinal_finType N)])=> H5 => //.
      case/mapP: H5 => y H6 H7.
      case/andP: H4; split; destruct x as [x1 x2]; inversion H7 => /=.
      rewrite /index_enum -enumT //= in H6.
      rewrite of_bin_N_of_nat => //.
      apply list_in_iff.
      clear pf H2 H7 H3 H4 H6 x1 x2.
      simpl in y.
      destruct y as [yn Hy].
      move: yn Hy => yn.
      rewrite -(bin_of_natK yn) => Hy.
      specialize (H _ Hy).
      rewrite MProps.F.elements_o in H.
      apply SetoidList.findA_NoDupA in H => //;
        last by constructor => //=; apply N.eq_trans.
      apply SetoidList.InA_alt in H.
      destruct H as [z H].
      destruct H as [H H'].
      destruct H as [H H''].
      simpl in H. simpl in H''.
      have Hz: (z = (N.of_nat (Ordinal (n:=N) (m:=bin_of_nat yn) Hy),
                   s (Ordinal (n:=N) (m:=bin_of_nat yn) Hy))).
      destruct z as [z1 z2].
      f_equal. simpl in H. rewrite -H.
      simpl. rewrite N_of_nat_of_bin => //.
      simpl in H''. rewrite H'' => //.
      rewrite -Hz => //.
    }
  }
Qed.

Instance resourceRefineCostInstance N
  : @RefineCostClass N [finType of resource] _ _ _.

Instance resourceCCostMaxInstance N
  : @CCostMaxClass N [finType of resource] :=
  N_to_D (N.of_nat N).

Instance resourceRefineCostMaxInstance N
  : @RefineCostMaxClass N _ (resourceCostMaxInstance _) (resourceCCostMaxInstance _).
Proof.
  rewrite /RefineCostMaxClass /resourceCCostMaxInstance /resourceCostMaxInstance.
  apply Qle_lteq.
  right => //.
  by rewrite N_to_D_to_Q /= rat_to_Q_N_to_Q.
Qed.

Ltac simp :=
  repeat
    match goal with
    | H : ?x = true |- _ =>
      apply Is_true_eq_left in H; unfold Is_true in H
    | H : ?x = false |- _ =>
      apply negbT in H; unfold negb in H
    | H : context[(?x <= ?N)%N] |- _ =>
      case: leP H => //; intros
    | |- context[(?x <= ?N)%N] =>
      apply /leP => //
    end.

Ltac my_omega :=
  unfold Dlt,Qlt,Dle,Qle,Dle,D_to_Q,Qle in *; simpl;
  simp; simpl in *; intros; omega.

Lemma D_num_le_spec : forall (p p' : Z) ,
    Z.le p p' ->
    Dle {| num := p; den := 1 |} {| num := p'; den := 1 |}%DRed.
Proof.
  intros.
  my_omega.
Qed.

Lemma le_num_le : forall (n n' : N),
    (n <= n')%num <-> le n n'.
  split; intros.
  apply N.le_equiv in H.
  rewrite /N.le_alt in H.
  destruct H.
  apply Nat.le_equiv.
  rewrite /Nat.le_alt.
  exists x.
  rewrite <- nat_of_add_bin.
  rewrite H.
  auto.

  apply N.le_equiv.
  rewrite /N.le_alt.
  apply Nat.le_equiv in H.
  rewrite /Nat.le_alt in H.
  destruct H.
  exists (N.of_nat x).
  replace n with (N.of_nat (nat_of_bin n)) by apply N_of_nat_of_bin.
  rewrite -Nat2N.inj_add.
  rewrite H.
  apply N_of_nat_of_bin.
Qed.

Lemma Z_le_inj : forall (n n' : N),
    (n <= n')%num -> (Z.le (NtoZ n) (NtoZ n')).
Proof.
  intros.
  rewrite /NtoZ.
  induction n => //;
                   destruct n'; auto => //.
Qed.
Hint Resolve Z_le_inj.

Lemma if_not_in_filterN_eq_filterSn : forall
    (l : list (BinNums.N * resource)) (N : BinNums.N) a,
  ~SetoidList.InA (M.eq_key (elt:=resource)) (N, a) l->
  (List.filter (fun p0 : BinNums.N * resource => (nat_of_bin p0.1 < N)%N) l) =
  (List.filter (fun p0 : BinNums.N * resource => (nat_of_bin p0.1 < N.+1)%N) l).
Proof.
  assert (forall x y, {M.eq_key (elt := resource) x y} + {~ M.eq_key x y}).
  destruct x, y; simpl.
  apply M.E.eq_dec.
  assert (forall x l, {SetoidList.InA (M.eq_key (elt:=resource)) x l}
                      + {~ SetoidList.InA (M.eq_key (elt:=resource)) x l}).
  apply SetoidList.InA_dec; intros; auto.
  induction l => //.
  intros N a0 H.
  simpl.
  case_eq (a.1 < N)%N => Hlt //.
  have->: (a.1 < N.+1)%N; auto.
  f_equal.
  eapply IHl; eauto.
  case_eq (a.1 < N.+1)%N => Hlt' //; eauto.
  exfalso.
  apply H.
  constructor.
  rewrite /M.eq_key /M.Raw.Proofs.PX.eqk /N.eq.
  simpl.
  destruct a; simpl in *.
  apply nat_of_bin_inj.
  my_omega.
Qed.

Lemma ctrafficN_relates_ctrafficSn :
  forall (x : BinNums.N) l (N : BinNums.N)  a,
    Datatypes.length
      (List.filter (fun p0 : BinNums.N * resource=> (p0.1 < N)%N) l) = x
    ->
    Datatypes.length
      (List.filter (fun p0 : BinNums.N * resource => (p0.1 < N.+1)%N) l) =
    x.+1 ->
    ~ SetoidList.InA (M.eq_key (elt:=resource)) (N,a) l ->
    (Datatypes.length
       (List.filter (fun p0 : BinNums.N * resource => (p0.1 < N.+1)%N) l)).+1 =
    x
.
Proof.
  intros.
  apply if_not_in_filterN_eq_filterSn with (N0 := N) in H1.
  rewrite <- H1 in *.
  exfalso.
  rewrite -> H0 in *.
  omega.
Qed.

Lemma ctraffic_Sn_or_normal : forall (l : seq (BinNums.N * resource)) N,
    let l' :=  (Datatypes.length
       (List.filter (fun p0 : BinNums.N * resource => (p0.1 < N.+1)%N) l))
    in
    SetoidList.NoDupA (M.eq_key (elt:=resource)) l ->
    l' =
    (Datatypes.length
    (List.filter (fun p0 : BinNums.N * resource => (p0.1 < N)%N) l)).+1
    \/
    l' =
    (Datatypes.length
       (List.filter (fun p0 : BinNums.N * resource => (p0.1 < N)%N) l)).
Proof.
  intros l N l' H.
  unfold l' in *.
  clear l'.
  move: N H.
  induction l => //; auto.
  move => N H.
  inversion H as [| x l0 H2 H3 H1]; subst.
  specialize (IHl N H3).
  destruct IHl; simpl;
  repeat match goal with
         | |- context[if (?x < ?N)%N then _ else _] =>
           let H := fresh "C" in case_eq ((x < N)%N); intros H
  end; simpl; auto; simp; auto.
  {
    have: eq (S (nat_of_bin (@fst BinNums.N resource a))) (S N);
      first by my_omega.
    intros x.
    inversion x.
    subst.
    clear n; clear C0; clear p; clear C; clear x.
    right.
    have:
      exists (n:N), (Datatypes.length
           (List.filter (fun p0 : N * resource => (p0.1 < a.1)%N) l)) = n
           => [| H4].
    destruct (Datatypes.length
      (List.filter (fun p0 : N * resource => (p0.1 < a.1)%N) l)).
    exists N0;
    eauto.
    exists (N.succ (N.of_nat n)).
    rewrite - Nat2N.inj_succ.
    rewrite of_bin_N_of_nat.
    auto.
    destruct H4.
    rewrite -> H1 in *.
    destruct a; simpl in *.
    apply ctrafficN_relates_ctrafficSn with (a := r); auto.
  }
  exfalso.
  my_omega.
Qed.

Lemma filter_length_ltN_if_nodup : forall l N,
    SetoidList.NoDupA (M.eq_key (elt:=resource)) l ->
    (Datatypes.length
      (List.filter (fun p : BinNums.N * resource => (p.1 < N)%N) l) <= N)%coq_nat.
Proof.
  intros.
  induction N => //.
  {
    clear -H.
    induction l => //;
    simpl in *;
    inversion H; subst; auto.
  }
    destruct (ctraffic_Sn_or_normal (l:=l) N); intuition; auto.
Qed.

Lemma lt_fold : forall A (f f' : BinNums.N -> A -> N) l n n',
    (n <= n')%num ->
    (forall (acc acc': N) x, (acc <= acc')%num ->  f acc x <= f' acc' x)%num->
    (le (List.fold_left f l n) (List.fold_left f' l n')).
Proof.
  induction l => //.
  intros.
  simpl.
  apply le_num_le => //.
  intros.
  specialize (IHl (f n a) (f' n' a)).
  apply IHl;
  auto.
Qed.

Lemma lt_size : forall (N : N) (N0 : BinNums.N)
                       (l : seq (BinNums.N * resource)),
    le (List.fold_left
    (fun (acc : BinNums.N) (p : BinNums.N * resource) =>
     match p.2 with
     | RYes => (acc + 1)%num
     | RNo => acc
     end) l
    N0)
  (List.fold_left (fun (a : BinNums.N) (_ : M.key * resource)
                   => (N.add a 1)%N) l N0).
Proof.
  intros.
  assert (N0 <= N0)%num by
  apply N.le_refl.
  apply lt_fold with (f := (fun (acc : BinNums.N) (p : BinNums.N * resource) =>
     match p.2 with
     | RYes => (acc + 1)%num
     | RNo => acc
     end))
                     (f' :=
                        (fun (a : BinNums.N) (_ : M.key * resource) => (N.add a 1))) (l := l)
                   in H; eauto.
  intros.
  case: x.2 => //.
  apply N.add_le_mono_r; auto.
  replace acc with (acc + 0)%num.
  apply N.add_le_mono; auto.
  compute; intros; discriminate.
  case acc =>//.
Qed.

Lemma ctraffic_ltN_lt : forall (N : N) m,
  ((ctraffic N m) <= N)%N.
Proof.
  move => N m.
  rewrite /ctraffic.
  rewrite M.fold_1.
  rewrite ctraffic_subF.
  specialize (M.elements_3w m); intros nodup.
  specialize (filter_length_ltN_if_nodup N nodup).
  generalize dependent (M.elements (elt:=resource) m) => l.
  generalize dependent ((List.filter (fun p : BinNums.N * resource => (p.1 < N)%N) l)).
  intros.
  specialize (lt_size N).
  intros.
  specialize (H0 N0 l0 ).
  generalize dependent ((fun (acc : BinNums.N) (p : BinNums.N * resource) =>
      match p.2 with
      | RYes => (acc + 1)%num
      | RNo => acc
      end)).
  intros.
  move: H0.
  assert (forall n n', n = n' ->  (List.fold_left (fun (a : BinNums.N) (_ : M.key * resource) => N.add a 1) l0 n) =
      (List.fold_left (fun (a : BinNums.N) (_ : M.key * resource) => N.succ (N.of_nat (a)))l0 n')); auto.
  {
    clear.
    induction l0 => //.
    simpl in *.
    intros.
    rewrite (IHl0 (N.add n 1) (N.succ (N.of_nat n'))); subst; auto.
    rewrite -Nat2N.inj_succ.
    rewrite N.add_1_r.
    rewrite Nat2N.inj_succ.
    f_equal.
    rewrite N_of_nat_of_bin => //.
  }
  rewrite (H0 N0 N0); auto.
  clear H0.
  intros.
  apply /leP.
  assert (forall n n',  n = N.of_nat n' ->  List.fold_left
         (fun (a : BinNums.N) (_ : M.key * resource) =>
            N.succ (N.of_nat a)) l0 n =
          N.of_nat (List.fold_left (fun (x : nat) (_ : M.key * resource) => x.+1) l0 n')).
  {
    clear.
    induction l0 => //.
    intros.
    simpl in *.
    rewrite N_of_nat_of_bin.
    specialize (IHl0 (N.succ n) (n'.+1)).
    rewrite IHl0; auto.
    rewrite Nat2N.inj_succ.
    f_equal.
    auto.
  }
  specialize (H1 N0 O ).
  rewrite H1 in H0; auto.
  rewrite List.fold_left_length in H0.
  simpl in *.
  clear H1.
  generalize dependent (List.fold_left n l0 0%num).
  intros.
  rewrite of_bin_N_of_nat in H0.
  clear -H H0.
  unfold M.key in H0.
  unfold N.t in H0.
  omega.
Qed.

Instance resourceCCostMaxMaxClassInstance N
  : @CCostMaxMaxClass N [finType of resource] _
                     _.
Proof.
  split;
  rewrite /ccost_fun /resourceCCostInstance /ccostmax_fun;
  rewrite /resourceCCostMaxInstance;
  rewrite /resource_ccost.
  +
    case: (M.find (elt:=resource) i m) => r //.
    case r => //.
    {
      rewrite /ctraffic.
      apply MProps.fold_rec_weak => //.
      intros.
      case (k < N)%N => //.
      case e => //.
      unfold Dle in *.
      rewrite N_to_D_plus.
      rewrite Dadd_ok.
      clear -H0.
      my_omega.
    }
  +
  rewrite /ccost_fun /resourceCCostInstance /ccostmax_fun.
  rewrite /resourceCCostMaxInstance.
  rewrite /resource_ccost.
  case: (M.find (elt:=resource) i m).
  move => a.
  case a.
  {
    rewrite /N_to_D.
    apply D_num_le_spec.
    apply Z.mul_le_mono_nonneg_l => //.
    apply Z_le_inj.
    rewrite le_num_le.
    rewrite of_bin_N_of_nat.
    specialize ctraffic_ltN_lt.
    intros.
    specialize (H (N.of_nat N) m).
    case: leP H => //.
    intros H.
    rewrite of_bin_N_of_nat in H.
    auto.
  }
  all:
  destruct N;
  compute; intros; discriminate; eauto.
Qed.

Instance resource_cgame N
  : cgame (N:=N) (T:=[finType of resource]) _ _ _ _
      (resourceGame N).

(** [NOTE Enumerable instances]
    ~~~~~~~~~~~~~~~~~~~~~~
    [Enumerable] instances should in general avoid using Ssreflect [enum].
    The reason is, extraction (and computation) of [enum ...] doesn't
    usually (or ever...?) result in usable OCaml terms. Instead,
    use the [enumerate] function of the underlying type to build the
    instance at the current type.
    The example below illustrates the general problem: *)

Definition resources : list resource := Eval hnf in enum [finType of resource].
Extraction resources.
(* let resources =
  filter
    (pred_of_simpl
      (pred_of_mem_pred
        (mem predPredType (sort_of_simpl_pred pred_of_argType))))
    (Obj.magic Finite.EnumDef.enum
      (Finite.clone resource_finType (Finite.coq_class resource_finType))) *)
Definition resources' : list resource := Eval hnf in enumerate [finType of resource].
Extraction resources'.
(* let resources' =
  Cons (RYes, (Cons (RNo, Nil))) *)

(*********************************************
 Singleton Games are Compilable
 *********************************************)

Global Instance singCCostInstance (A : Type) `(Boolable A) N
  : CCostClass N (singleton A)
  :=
    (fun (i : OrdNat.t) (m : M.t (singleton A)) =>
      match M.find i m with
      | Some t => if boolify t then 1 else 0
      | _ => 0
      end)%D.

Instance singCTypeInstance (A : Type) (EnumA : Enumerable A)
    : Enumerable (singleton A) := map (@Wrap Singleton A) (enumerate A).

Instance singCCostMaxInstance (N : nat) (A : Type)
    : @CCostMaxClass N (singleton A) := 1%D.

Section singletonCompilable.
  Context {A : finType} {N: nat} `{RefineTypeAxiomClass A} `{Boolable A}.

  Global Program Instance singRefineTypeAxiomInstance
    : @RefineTypeAxiomClass (singletonType A) (singCTypeInstance _).
  Next Obligation.
    generalize H => H1. clear H. case: H1 => H1 H2.
    split; last first.
    {
      rewrite map_inj_uniq. apply H2.
      rewrite /injective => x1 x2 H3.
      inversion H3 => //.
    }
    rewrite /(enumerate Wrapper Singleton A) /singCTypeInstance.
    move => r.
    apply /mapP.
    case_eq (in_mem r (mem (enum_mem (T:=singletonType A)
              (mem (sort_of_simpl_pred (pred_of_argType
                (Wrapper Singleton A))))))) => H3; rewrite H3.
    {
      move: H3.
      case: r => x H3.
      exists x; last by [].
      rewrite H1 mem_enum.
      rewrite mem_enum in H3 => //.
    }
    {
      move => H4.
      case: H4 => x H4 H5.
      rewrite H5 in H3.
      move/negP: H3 => H3.
      apply H3 => //.
      rewrite mem_enum => //.
    }
  Qed.

  Global Instance singRefineTypeInstance
    : @RefineTypeClass (singletonType A)  _ _.

  Global Program Instance singRefineCostAxiomInstance `(Boolable A)
    : RefineCostAxiomClass _ (singCCostInstance _ N).
  Next Obligation.
    rewrite /cost_fun /singletonCostInstance /cost_fun.
    rewrite /ccost_fun /singCCostInstance /ccost_fun.
    rewrite (H2 i pf).
    case: (boolify (s (Ordinal (n := N) (m := i) pf))) => //.
  Qed.

  Global Instance singRefineCostInstance
    : @RefineCostClass N (singletonType A) _ _ _.

  Global Instance singRefineCostMaxInstance
    : @RefineCostMaxClass N _ (singletonCostMaxInstance _ _) (singCCostMaxInstance N A).
  Proof.
    rewrite /RefineCostMaxClass /resourceCCostMaxInstance
            /singletonCostMaxInstance /singCCostMaxInstance => //.
  Qed.

  Global Instance singCostMaxMaxInstance
    : CCostMaxMaxClass  (singCCostMaxInstance N A) _.
  Proof.
    split;
    unfold CCostMaxMaxClass;
    rewrite /ccostmax_fun/singCCostMaxInstance;
    rewrite /ccost_fun /singCCostInstance.
    all:
    case: (M.find (elt:=singleton A) i m); intros;
      [destruct boolify; eauto | ];
          compute; intros; try discriminate.
  Qed.

  Global Instance sing_cgame
  : @cgame N (singletonType A) _ _ _ (singletonCostInstance H0)
      _
      _ (singletonCostMaxAxiomInstance _ A _) _
      _ _ _ _ singRefineCostMaxInstance _.

End singletonCompilable.

Module SingletonCGameTest. Section singletonCGameTest.
  Context {A : finType} {N : nat} `{Boolable A}.
  Variable i' : OrdNat.t.
  Variable t' : M.t (singletonType A).
  Check ccost_fun (N:=N) i' t'.
End singletonCGameTest. End SingletonCGameTest.

(**********************************************
  Sigma games are compilable
 **********************************************)

Instance sigmaCCostMaxInstance (N : nat) (A : Type)
         (predInstance : PredClass A)
         (ccostMaxInstance : CCostMaxClass N A)
  : @CCostMaxClass N {x : A | the_pred x} := ccostMaxInstance.

Section sigmaCompilable.
  Global Instance sigmaEnumerableInstance (A : Type)
           (enumerableInstance : Enumerable A)
           (predInstance : PredClass A)
    : Enumerable {x : A | the_pred x} :=
    filter_sigma the_pred (enumerate A).

  Global Program Instance sigmaRefineTypeAxiomInstance
          (A : finType)
          `(refineTypeAxiomInstanceA : RefineTypeAxiomClass A)
          (predInstance : PredClass A)
    : @RefineTypeAxiomClass [finType of {x : A | the_pred x}] _.
  Next Obligation.
    rewrite /RefineTypeAxiomClass in refineTypeAxiomInstanceA.
    case: refineTypeAxiomInstanceA=> [H0 H1]. rewrite /eq_mem in H0.
    split.
    { move=> r. rewrite /enumerable_fun. rewrite /sigmaEnumerableInstance.
      have ->: (r \in enum [finType of {x : A | the_pred x}]).
      { apply mem_enum. }
      have ->: (r \in filter_sigma the_pred (enumerate A)).
      { apply list_in_iff, list_in_filter_sigma.
        specialize (H0 (proj1_sig r)). apply list_in_iff.
        rewrite H0. by apply mem_enum. }
        by []. }
    { rewrite /enumerable_fun /sigmaEnumerableInstance. clear H0. move: H1.
      elim: (enumerate A).
      - by [].
      - move => a l IHl H1. simpl. simpl in H1. move: H1=> /andP [H1 H2].
        destruct (to_sigma the_pred a) eqn:Ha. simpl. apply /andP.
        split. rewrite /in_mem. simpl. apply /negP. move=> Contra.
        rewrite /in_mem in H1. simpl in H1. move: H1=> /negP H1.
        rewrite /pred_of_eq_seq in H1. rewrite /pred_of_eq_seq in Contra.

        have H3: (mem_seq (T:=A) l a).
        { apply: mem_seq_filter. apply Ha. assumption. }
        contradiction.
        apply IHl; assumption. apply IHl; assumption. }
  Qed.

  Global Instance sigmaRefineTypeInstance (A : finType)
           (predInstance : PredClass A)
           `(refineTypeAxiomInstanceA : RefineTypeAxiomClass A)
    : @RefineTypeClass [finType of {x : A | the_pred x}]  _ _.

  Global Instance sigmaCCostInstance
           (A : Type) N
           (predInstance : PredClass A)
           (ccostA : @CCostClass N A)
    : CCostClass N {x : A | the_pred x}
    :=
      fun (i : OrdNat.t) (m : M.t {x : A | the_pred x}) =>
        ccost i (M.map (fun x => proj1_sig x) m).

  Global Program Instance sigmaRefineCostAxiomInstance
          (N : nat) (A : finType)
          (predInstance : PredClass A)
          (costA : CostClass N rat_realFieldType A)
          (ccostA : CCostClass N A)
          (refineA : RefineCostAxiomClass costA ccostA)
    : @RefineCostAxiomClass
        N [finType of {x : A | the_pred x}]
        (@sigmaCostInstance N rat_realFieldType A _ costA)
        (@sigmaCCostInstance A _ _ ccostA).
  Next Obligation.
    apply refineA=> j pf'; rewrite ffunE.
    apply MProps.F.find_mapsto_iff, MProps.F.map_mapsto_iff.
    specialize (H j pf'); apply MProps.F.find_mapsto_iff in H.
    by exists (s (Ordinal (n:=N) (m:=j) pf')); split => //.
  Qed.

  Global Instance sigmaRefineCostInstance (N : nat) (A : finType)
           (predInstance : PredClass A)
           (costA : CostClass N rat_realFieldType A)
           (ccostA : CCostClass N A)
           (refineA : RefineCostAxiomClass costA ccostA)
    : @RefineCostClass N [finType of {x : A | the_pred x}] _ _ _.

  Global Instance sigmaCostMaxRefineInstance (N : nat) (A : finType)
           (predInstance : PredClass A)
           (costMaxInstance : CostMaxClass N _ A)
           (ccostMaxInstance : CCostMaxClass N A)
           (refineCostMaxInstance : RefineCostMaxClass costMaxInstance ccostMaxInstance)
    : @RefineCostMaxClass N A
        (sigmaCostMaxInstance predInstance costMaxInstance)
        (sigmaCCostMaxInstance predInstance ccostMaxInstance).
  Proof.
    rewrite /RefineCostMaxClass /sigmaCostMaxInstance
            /sigmaCCostMaxInstance => //.
  Qed.

  Global Instance sigmaCostMaxMaxInstance (N : nat) (A : finType)
         (ccostA : CCostClass N A)
         (ccostMaxInstance : CCostMaxClass N A)
         (predInstance : PredClass A)
         (ccostMaxInstance : CCostMaxClass N A)
         (ccostMaxMaxInstance : @CCostMaxMaxClass N A _ _ )
    : CCostMaxMaxClass (T := [finType of {x : A | the_pred x}]) _ _.
  Proof.
    rewrite /CCostMaxMaxClass /ccost_fun /ccostmax_fun
            /sigmaCCostInstance /sigmaCCostMaxInstance => //.
  Defined.

  Global Instance sigma_cgame (N : nat) (A : finType)
           (predInstance : PredClass A)
           (costA : CostClass N rat_realFieldType A)
           (costAxiomA : @CostAxiomClass N rat_realFieldType A costA)
           (costMaxA : CostMaxClass N rat_realFieldType A)
           (costMaxAxiomA : CostMaxAxiomClass _ _)
           (ccostA : CCostClass N A)
           (ccostMaxA : CCostMaxClass N A)
           (refineCostMaxInstanceA : RefineCostMaxClass costMaxA ccostMaxA)
           (ccostMaxMaxA : @CCostMaxMaxClass N A _ _)
           `(refineTypeA : RefineTypeClass A)
           (refineCostAxiomA : @RefineCostAxiomClass N A costA ccostA)
           (refineCostA : @RefineCostClass N A costA ccostA _)
           (gA : @game A N rat_realFieldType _ _ _ _)
           (cgA : @cgame N A _ _ _ _ _ _ _ _ _ _ _ _ _ _ )
    : @cgame N [finType of {x : A | the_pred x}] _ _ _ _ _ _ _ _ _ _ _
             _
             (sigmaCostMaxRefineInstance refineCostMaxInstanceA)
             (sigmaGameInstance N _ A predInstance gA) .
End sigmaCompilable.

(***************************************
  Product Games are compilable
 ***************************************)

Instance prodEnumerableInstance (aT bT : Type)
         (enumerableA : Enumerable aT)
         (enumerableB : Enumerable bT)
  : Enumerable (aT*bT) :=
  List.list_prod (enumerate aT) (enumerate bT).

Program Instance prodRefineTypeAxiomInstance
        (aT bT : finType)
        `(refineTypeAxiomInstanceA : RefineTypeAxiomClass aT)
        `(refineTypeAxiomInstanceB : RefineTypeAxiomClass bT)
  : @RefineTypeAxiomClass [finType of aT*bT] _.
Next Obligation.
  rewrite /RefineTypeAxiomClass in refineTypeAxiomInstanceA.
  rewrite /RefineTypeAxiomClass in refineTypeAxiomInstanceB.
  case: refineTypeAxiomInstanceA=> [HA0 HA1].
  case: refineTypeAxiomInstanceB=> [HB0 HB1].
  split.
  { move => r. rewrite mem_enum. case: r. move => a b.
    rewrite /prodEnumerableInstance /enumerable_fun.
    rewrite /eq_mem in HA0. rewrite /eq_mem in HB0.
    have H: (List.In (a, b) (List.list_prod (enumerate aT) (enumerate bT))).
    { apply List.in_prod_iff. split; apply list_in_iff.
      - by rewrite HA0; apply mem_enum.
      - by rewrite HB0; apply mem_enum. }
    apply list_in_iff in H. by rewrite H. }
    by apply: list_prod_uniq; assumption.
Qed.

Instance prodRefineTypeInstance (aT bT : finType)
         `(refineTypeAxiomInstanceA : RefineTypeAxiomClass aT)
         `(refineTypeAxiomInstanceB : RefineTypeAxiomClass bT)
  : @RefineTypeClass [finType of aT*bT]  _ _.

Instance prodCCostInstance
       N
       (aT bT : Type)
       `(ccostA : CCostClass N aT)
       `(ccostB : CCostClass N bT)
  : CCostClass N (aT*bT)
  :=
    (fun (i : OrdNat.t) (m : M.t (aT*bT)) =>
       (ccost i (map_split m).1 +
         ccost i (map_split m).2))%D.

Program Instance prodRefineCostAxiomInstance
        (N : nat) (aT bT : finType)
        (costA : CostClass N rat_realFieldType aT)
        (costB : CostClass N rat_realFieldType bT)
        (ccostA : CCostClass N aT)
        (ccostB : CCostClass N bT)
        (refineA : RefineCostAxiomClass costA ccostA)
        (refineB : RefineCostAxiomClass costB ccostB)
  : @RefineCostAxiomClass
      N [finType of aT*bT]
      (@prodCostInstance N rat_realFieldType aT bT costA costB)
      (@prodCCostInstance N aT bT ccostA ccostB).
Next Obligation.
  have H2: (D_to_Q ((ccost) i (map_split m).1) ==
            rat_to_Q
              ((cost) (Ordinal (n:=N) (m:=i) pf) [ffun j => (s j).1]))%coq_Qscope.
  { apply: refineA => j pf'.
    rewrite ffunE.
    specialize (H j pf').
    move: H. case: (s (Ordinal (n:=N) (m:=j) pf')) => a b H.
    apply map_split_spec in H.
    case: H => H0 H1.
    apply H0. }
  have H3: (D_to_Q ((ccost) i (map_split m).2) ==
            rat_to_Q
              ((cost) (Ordinal (n:=N) (m:=i) pf) [ffun j => (s j).2]))%Q.
  { apply refineB. move => j pf'.
    rewrite ffunE.
    specialize (H j pf').
    move: H. case: (s (Ordinal (n:=N) (m:=j) pf')) => a b H.
    apply map_split_spec in H.
    case: H => H0 H1.
    apply H1. }
  rewrite /ccost_fun in H2, H3.
  rewrite Dadd_ok.
  rewrite H2 H3 [rat_to_Q (_ + _)] rat_to_Q_red.
  by apply Qeq_sym; rewrite -rat_to_Q_red rat_to_Q_plus.
Qed.

Instance prodRefineCostInstance (N : nat) (aT bT : finType)
         (costA : CostClass N rat_realFieldType aT)
         (costB : CostClass N rat_realFieldType bT)
         (ccostA : CCostClass N aT)
         (ccostB : CCostClass N bT)
         (refineA : RefineCostAxiomClass costA ccostA)
         (refineB : RefineCostAxiomClass costB ccostB)
  : @RefineCostClass N [finType of aT*bT] _ _ _.

Instance prodCCostMaxInstance (N : nat) (aT bT : Type)
         (ccostMaxA : CCostMaxClass N aT)
         (ccostMaxB : CCostMaxClass N bT)
  : CCostMaxClass N (aT*bT) := (ccostMaxA + ccostMaxB)%D.

Instance prodRefineMaxCostInstance (N : nat) (aT bT : finType)
         (costMaxA   : CostMaxClass N _ aT)
         (ccostMaxA  : CCostMaxClass N aT)
         (refineMaxA : RefineCostMaxClass costMaxA ccostMaxA)
         (costMaxB   : CostMaxClass N _ bT)
         (ccostMaxB  : CCostMaxClass N bT)
         (refineMaxB : RefineCostMaxClass costMaxB ccostMaxB)
  : RefineCostMaxClass
      (prodCostMaxInstance costMaxA costMaxB)
      (prodCCostMaxInstance ccostMaxA ccostMaxB).
Proof.
  rewrite /RefineCostMaxClass /prodCostMaxInstance /prodCCostMaxInstance
          rat_to_Q_plus Dadd_ok.
  by apply: Qplus_le_compat.
Qed.

Lemma split_lt_max :
  forall (N : nat) aT bT
         `(costA : CostClass N rat_realFieldType aT)
         `(costB : CostClass N rat_realFieldType bT)
         (ccostA : CCostClass N aT)
         (ccostB : CCostClass N bT)
         (ccostMaxA  : CCostMaxClass N aT)
         (ccostMaxB  : CCostMaxClass N bT)
         (ccostMaxMaxA : @CCostMaxMaxClass N aT _ _ )
         (ccostMaxMaxB : @CCostMaxMaxClass N bT _ _ )
  (m : M.t (aT * bT)) i,
    (0 <= (ccost_fun (N := N) i (map_split m).1) + (ccost_fun (N := N) i (map_split m).2) <=
     ccostMaxA + ccostMaxB)%DRed.
Proof.
  intros.
  generalize dependent ((map_split m).1) => ma.
  generalize dependent ((map_split m).2) => mb.
  have: (0 <= ccost_fun (N := N) i ma <= ccostMaxA)%DRed;
    last move => H; eauto.
  have: (0 <= (ccost_fun (N := N) i mb) <= ccostMaxB)%DRed;
    last move => H1;
  eauto.
  generalize dependent ((ccost) i ma).
  generalize dependent ((ccost) i mb).
  intros.
  unfold Dle in *.
  rewrite !Dadd_ok.
  destruct H1,H.
  split.
  2: apply Qplus_le_compat; auto.
  clear -H0 H.
  generalize dependent (D_to_Q d).
  generalize dependent (D_to_Q d0).
  intros.
  unfold D_to_Q in *.
  simpl in *.
  assert (0 # 2 == 0)%Q => //.
  rewrite -> H1 in *.
  clear H1.
  clear -H H0.
  destruct q,q0 => //.
  unfold Qle in *.
  simpl in *.
  ring_simplify in H.
  ring_simplify in H0.
  ring_simplify.
  apply Z.add_nonneg_nonneg;
  apply Z.mul_nonneg_nonneg => //.
Qed.

Instance prodCostMaxMaxInstance (N : nat) (aT bT : finType)
         (costA : CostClass N rat_realFieldType aT)
         (costAxiomA : @CostAxiomClass N rat_realFieldType aT costA)
         (costB : CostClass N rat_realFieldType bT)
         (costAxiomB : @CostAxiomClass N rat_realFieldType bT costB)
         (ccostA : CCostClass N aT)
         (ccostB : CCostClass N bT)
         (ccostMaxA  : CCostMaxClass N aT)
         (ccostMaxB  : CCostMaxClass N bT)
         (ccostMaxMaxA : @CCostMaxMaxClass N aT _ _ )
         (ccostMaxMaxB : @CCostMaxMaxClass N bT _ _ )
  : @CCostMaxMaxClass N (aT*bT) _ _ .
Proof.
  rewrite /CCostMaxMaxClass;
  rewrite /ccost_fun /ccostmax_fun
          /prodCCostInstance /prodCCostMaxInstance.
  intros.
  apply split_lt_max => //.
Qed.

Instance prod_cgame (N : nat) (aT bT : finType)
         (costA : CostClass N rat_realFieldType aT)
         (costAxiomA : @CostAxiomClass N rat_realFieldType aT costA)
         (ccostA : CCostClass N aT)
         (costMaxA : CostMaxClass N rat_realFieldType aT)
         (ccostMaxA  : CCostMaxClass N aT)
         (costMaxAxiomA : CostMaxAxiomClass costA _)
         (refineMaxA : RefineCostMaxClass costMaxA ccostMaxA)
         `(refineTypeA : RefineTypeClass aT)
         (refineCostAxiomA : @RefineCostAxiomClass N aT costA ccostA)
         (refineCostA : @RefineCostClass N aT costA ccostA _)
         (costMaxMaxA : @CCostMaxMaxClass N aT _ _)
         (gA : @game aT N rat_realFieldType _ _ _ _)
         (cgA : @cgame N aT _ _ _ _ _ _ _ _ _ _ _ _ _ _)
         (costB : CostClass N rat_realFieldType bT)
         (costAxiomB : @CostAxiomClass N rat_realFieldType bT costB)
         (ccostB : CCostClass N bT)
         (ccostMaxB : CCostMaxClass N bT)
         (costMaxB : CostMaxClass N rat_realFieldType bT)
         (costMaxAxiomB : CostMaxAxiomClass costB _)
         (refineMaxB : RefineCostMaxClass costMaxB ccostMaxB)
         `(refineTypeB : RefineTypeClass bT)
         (refineCostAxiomB : @RefineCostAxiomClass N bT costB ccostB)
         (costMaxMaxA : @CCostMaxMaxClass N bT _ _)
         (refineCostB : @RefineCostClass N bT costB ccostB _)
         (gB : @game bT N rat_realFieldType _ _ _ _)
         (cgB : @cgame N bT _ _ _ _ _ _ _ _ _ _ _ _ _ _)
  : @cgame N [finType of aT*bT] _ _ _ _ _ _ _ _ _ _ _
           _
           _
           (prodGameInstance N _ _ _ gA gB).

Module ProdCGameTest. Section prodCGameTest.
  Context {A B : finType} {N : nat} `{cgame N A} `{cgame N B}.
  Variable i' : OrdNat.t.
  Variable t' : M.t (A*B).
  Check ccost_fun (N:=N) i' t'.
End prodCGameTest. End ProdCGameTest.

(*******************************************
 Scalar Games are Compilable
 *******************************************)

Instance scalarEnumerableInstance
         (A : Type)
         `(Enumerable A)
         `(ScalarClass)
  : Enumerable (scalar scalar_val A) :=
    map (@Wrap (Scalar scalar_val) A) (enumerate A).

Definition unwrapScalarTree
           A `(ScalarClass) : M.t (scalar scalar_val A) -> M.t A :=
  fun m : (M.t (scalar scalar_val A)) =>
    M.fold (fun i r acc =>
              M.add i (unwrap r) acc)
      m (M.empty A).

Global Instance scalarCCostInstance
         N (A : Type)
         `(Enumerable A)
         `(CCostClass N A)
         `(DyadicScalarClass)
  : CCostClass N (scalar scalar_val A)
  :=
    fun (i : OrdNat.t) (m : M.t (@scalar _ scalar_val A)) =>
      (dyadic_scalar_val * ccost i (unwrapScalarTree m))%D.

Instance scalarCCostMaxInstance
         N (A : Type)
         `(cmax : CCostMaxClass N A)
         `(DyadicScalarClass)
  : @CCostMaxClass N (scalar scalar_val A) := (dyadic_scalar_val * cmax)%D.

Section scalarCompilable.
  Context {A N} `{Hdyadic: DyadicScalarClass} `{cgame N A}.

  Global Program Instance scalarRefineTypeAxiomInstance
    : @RefineTypeAxiomClass (scalarType scalar_val A) _.
  Next Obligation.
    clear H1 H2 ccostMaxMaxClass  refineCostAxiomClass H0 refineCostClass ccostClass
          costAxiomClass costMaxAxiomClass costClass.
    generalize H; clear H.
    rewrite /RefineTypeAxiomClass => H.
    destruct H; split; last first.
    {
      rewrite map_inj_uniq. apply H.
      rewrite /injective => x1 x2 H3.
      inversion H3 => //.
    }
    rewrite /(enumerate Wrapper Singleton A) /singCTypeInstance.
    move => r.
    apply /mapP.
    case_eq (in_mem
               r (mem
                  (enum_mem
                     (T:=scalarType (rty:=rat_realFieldType) scalar_val A)
                     (mem (sort_of_simpl_pred (pred_of_argType
              (Wrapper (Scalar (rty:=rat_realFieldType) scalar_val) A)))))))
      => H3; rewrite H3.
    {
      move: H3.
      case: r => x H3.
      exists x; last by [].
      rewrite H0 mem_enum.
      rewrite mem_enum in H3 => //.
    }
    {
      move => H4.
      case: H4 => x H4 H5.
      rewrite H5 in H3.
      move/negP: H3 => H3.
      apply H3 => //.
      rewrite mem_enum => //.
    }
  Qed.

  Global Instance scalarRefineTypeInstance
    : @RefineTypeClass (scalarType scalar_val A)  _ _.

  Lemma unwrapScalarTree_spec i (t : scalarType scalar_val A) m:
    M.find i m = Some t ->
    M.find i (unwrapScalarTree m) = Some (unwrap t).
  Proof.
    clear H H0 H1 H2 ccostMaxMaxClass refineCostAxiomClass refineCostClass
          ccostClass costAxiomClass costMaxAxiomClass costClass.
    rewrite /unwrapScalarTree.
    apply MProps.fold_rec_weak.
    {
      move => mo m' a' H0 H1 H2.
      have H3: (forall (k : M.key) e,
        M.MapsTo k e mo <-> M.MapsTo k e m');
          first by apply MProps.F.Equal_mapsto_iff; apply H0.
      apply M.find_2 in H2. apply H3 in H2. apply M.find_1 in H2.
      apply H1. apply H2.
    }
    {
      move => H. inversion H.
    }
    {
      move => k e a' m' H0 IH. case: e. move => a0 H2 /=.
      rewrite MProps.F.add_o. case: (MProps.F.eq_dec k i) => H3 //.
      generalize H2; clear H2.
      rewrite MProps.F.add_eq_o. move => H2. inversion H2.
      split => []. by []. apply IH.
      generalize H2; clear H2.
      rewrite MProps.F.add_neq_o. move => H2. inversion H2 => //.
      by [].
    }
  Qed.

  Global Program Instance scalarRefineCostAxiomInstance
    : @RefineCostAxiomClass
        N (scalarType scalar_val A)
        (@scalarCostInstance _ _ _ costClass scalar_val)
        _.
  Next Obligation.
    clear H H0 H1 H2
          refineCostClass costAxiomClass.
    rewrite /cost_fun /scalarCostInstance /cost_fun.
    rewrite /(ccost) /scalarCCostInstance /(ccost).
    rewrite [rat_to_Q (_ * _)] rat_to_Q_red.
    rewrite -rat_to_Q_red /scalar_val.
    rewrite rat_to_Q_mul Dmult_ok.
    generalize (Qeq_dec (rat_to_Q (projT1 dyadic_scalar_val)) 0%Q).
    case => H0.
    { rewrite H0 !Qmult_0_l => //.
      have ->: (D_to_Q dyadic_scalar_val == 0)%Q.
      { by rewrite dyadic_rat_to_Q H0. }
      by rewrite Qmult_0_l. }
    have ->: (D_to_Q dyadic_scalar_val == rat_to_Q (projT1 dyadic_scalar_val))%Q.
    { apply: dyadic_rat_to_Q. }
    apply Qmult_inj_l => //.
    move: refineCostAxiomClass; clear refineCostAxiomClass.
    rewrite /RefineCostAxiomClass /(ccost) => refineCostAxiomClass.
    specialize (refineCostAxiomClass pf).
    rewrite -(@refineCostAxiomClass(unwrapScalarTree m)) => //.
    move => j pf'.
    specialize (H3 j pf').
    apply unwrapScalarTree_spec in H3.
    rewrite H3. f_equal.
    rewrite /unwrap_ffun. rewrite ffunE => //.
  Qed.

  Global Instance scalarRefineCostInstance
    : @RefineCostClass N (scalarType scalar_val A)
        (@scalarCostInstance N _ A costClass _) _ _.

  Global Instance scalarRefineCostMaxInstance
         `(scalarAxiomInstance : @ScalarAxiomClass _ scalar_val)
    : @RefineCostMaxClass
        N (scalarType scalar_val A)
        (scalarCostMaxInstance costMaxClass scalar_val)
        (scalarCCostMaxInstance ccostMaxClass dyadic_scalar_val).
  Proof.
    rewrite /RefineCostMaxClass /scalarCostMaxInstance /scalarCCostMaxInstance.
    rewrite rat_to_Q_mul Dmult_ok.
    rewrite /scalar_val.
    have ->: (rat_to_Q (projT1 dyadic_scalar_val) == D_to_Q dyadic_scalar_val)%Q.
    { by rewrite dyadic_rat_to_Q. }
    rewrite Qmult_comm [Qmult (D_to_Q _) _]Qmult_comm.
    apply Qmult_le_compat_r => //.
    have H3 : rat_to_Q 0 = 0%Q by rewrite rat_to_Q0.
    rewrite -H3.
    have ->: (D_to_Q dyadic_scalar_val == rat_to_Q (projT1 dyadic_scalar_val))%Q.
    { by apply: dyadic_rat_to_Q. }
    apply le_rat_to_Q => //.
  Qed.

  Global Instance scalarCostMaxMaxInstance
         `(scalarAxiomInstance : @ScalarAxiomClass _ scalar_val)
         (ccostMaxMax : @CCostMaxMaxClass N A
                                          _ _ )
    : @CCostMaxMaxClass N  (scalarType scalar_val A) _ _.
  Proof.
    split;
      rewrite /CCostMaxMaxClass;
    unfold CCostMaxMaxClass in ccostMaxMax;
    specialize (ccostMaxMax i (unwrapScalarTree m));
    rewrite  /ccost_fun;
    unfold Dle in *;
    repeat rewrite Dmult_ok;
    rewrite Qmult_comm;
    destruct ccostMaxMax.
    +
      have: (D_to_Q 0 == 0)%Q => [|ZeroZero] //.
      rewrite -> ZeroZero in *.
      apply Qmult_le_0_compat => //; eauto.
      have H5 : rat_to_Q 0 = 0%Q by rewrite rat_to_Q0.
      rewrite -H5.
      have ->: (D_to_Q dyadic_scalar_val == rat_to_Q (projT1 dyadic_scalar_val))%Q.
      { by apply: dyadic_rat_to_Q. }
      apply le_rat_to_Q => //.
    +
        have->: (Qmult (D_to_Q (dyadic_rat_to_D Hdyadic))
                     (D_to_Q ccostMaxClass) ==
               Qmult (D_to_Q ccostMaxClass)
                     (D_to_Q (dyadic_rat_to_D Hdyadic)))%coq_Qscope.
      rewrite Qmult_comm => //.
      apply Qmult_le_compat_r => //.
      have H5 : rat_to_Q 0 = 0%Q by rewrite rat_to_Q0.
      rewrite -H5.
      have ->: (D_to_Q dyadic_scalar_val == rat_to_Q (projT1 dyadic_scalar_val))%Q.
      { by apply: dyadic_rat_to_Q. }
      apply le_rat_to_Q => //.
  Qed.

  Global Instance scalar_cgame
         `{scalarA : @ScalarAxiomClass _ scalar_val}
    : @cgame
        N (scalarType scalar_val A)
        _ _ _ _ _ _ _ _ _ _ _ _ _
        (scalarGameInstance _ _ _ _ _).
End scalarCompilable.

Module ScalarCGameTest. Section scalarCGameTest.
  Context {A : finType} {N : nat} `{cgame N A}
          `{Hdyad: DyadicScalarClass}
          `{scalarA : @ScalarAxiomClass _ scalar_val}.
  Variable i' : OrdNat.t.
  Variable t' : M.t (@scalarType rat_realFieldType scalar_val A).
  Check ccost_fun (N:=N) i' t'.
End scalarCGameTest. End ScalarCGameTest.

(**********************************
 Bias Games are Compilable
 **********************************)

Definition unwrapBiasTree A (q : rat) : M.t (bias q A) -> M.t A :=
  fun m : (M.t (bias q A)) =>
    M.fold (fun i r acc =>
              M.add i (unwrap r) acc)
      m (M.empty A).

Global Instance biasCCostInstance
         N (A : Type)
         `(Enumerable A) `(CCostClass N A)
         (q : DRat)
  : CCostClass N (bias (projT1 q) A)
  :=
    fun (i : OrdNat.t) (m : M.t (bias (projT1 q) A)) =>
      (q + ccost i (unwrapBiasTree m))%D.

Instance biasCCostMaxInstance N (A : Type) `(cmax : CCostMaxClass N A) (q : DRat)
  : @CCostMaxClass N (bias (projT1 q) A) := (q + cmax)%D.

Instance biasCTypeInstance A (q : DRat)
         `(Enumerable A)
  : Enumerable (bias (projT1 q) A) :=
  map (@Wrap (Bias (projT1 q)) A) (enumerate A).

Section biasCompilable.
  Context {A N} {q : DRat} `{cgame N A}.

  Global Program Instance biasRefineTypeAxiomInstance
    : @RefineTypeAxiomClass (biasType (projT1 q) A) _.
  Next Obligation.
    clear H1 H2 ccostMaxMaxClass refineCostAxiomClass  H0 refineCostClass
          ccostClass costAxiomClass costMaxAxiomClass costClass.
    generalize H; clear H.
    rewrite /RefineTypeAxiomClass => H.
    destruct H; split; last first.
    {
      rewrite map_inj_uniq. apply H.
      rewrite /injective => x1 x2 H3.
      inversion H3 => //.
    }
    rewrite /(enumerate Wrapper Singleton A) /singCTypeInstance.
    move => r.
    apply /mapP.
    case_eq (in_mem r (mem (enum_mem (T:=biasType (rty:=rat_realFieldType) q A)
              (mem (sort_of_simpl_pred (pred_of_argType
                (Wrapper (Bias (rty:=rat_realFieldType) q) A))))))) => H3; rewrite H3.
    {
      move: H3.
      case: r => x H3.
      exists x; last by [].
      rewrite H0 mem_enum.
      rewrite mem_enum in H3 => //.
    }
    {
      move => H4.
      case: H4 => x H4 H5.
      rewrite H5 in H3.
      move/negP: H3 => H3.
      apply H3 => //.
      rewrite mem_enum => //.
    }
  Qed.

  Global Instance biasRefineTypeInstance
    : @RefineTypeClass (biasType (projT1 q) A)  _ _.

  Lemma unwrapBiasTree_spec i (t : biasType (projT1 q) A) m:
    M.find i m = Some t ->
      M.find i (unwrapBiasTree m) = Some (unwrap t).
  Proof.
    clear H H0 H1 H2 ccostMaxMaxClass refineCostAxiomClass refineCostClass
          ccostClass costAxiomClass costMaxAxiomClass costClass.
    rewrite /unwrapBiasTree.
    apply MProps.fold_rec_weak.
    {
      move => mo m' a' H0 H1 H2.
      have H3: (forall (k : M.key) e,
        M.MapsTo k e mo <-> M.MapsTo k e m');
          first by apply MProps.F.Equal_mapsto_iff; apply H0.
      apply M.find_2 in H2. apply H3 in H2. apply M.find_1 in H2.
      apply H1. apply H2.
    }
    {
      move => H. inversion H.
    }
    {
      move => k e a' m' H0 IH. case: e. move => a0 H2 /=.
      rewrite MProps.F.add_o. case: (MProps.F.eq_dec k i) => H3 //.
      generalize H2; clear H2.
      rewrite MProps.F.add_eq_o. move => H2. inversion H2.
      split => []. by []. apply IH.
      generalize H2; clear H2.
      rewrite MProps.F.add_neq_o. move => H2. inversion H2 => //.
      by [].
    }
  Qed.

  Global Program Instance biasRefineCostAxiomInstance
    : @RefineCostAxiomClass _ (biasType (projT1 q) A) (biasCostInstance costClass) _.
  Next Obligation.
    clear H H0 H1 H2
          refineCostClass costAxiomClass.
    rewrite /cost_fun /biasCostInstance /cost_fun.
    rewrite /(ccost) /biasCCostInstance /ccost_fun /(ccost).
    rewrite [rat_to_Q (_ + _)] rat_to_Q_red.
    rewrite Dadd_ok.
    rewrite -rat_to_Q_red.
    rewrite rat_to_Q_plus /scalar_val.
    rewrite /bias_val.
    have ->: (D_to_Q q == rat_to_Q (projT1 q))%Q.
    { by apply: dyadic_rat_to_Q. }
    move: (Qeq_dec (rat_to_Q q) 0%Q).
    move: refineCostAxiomClass; clear refineCostAxiomClass.
    rewrite /RefineCostAxiomClass /(ccost) => refineCostAxiomClass.
    specialize (refineCostAxiomClass pf) => H.
    rewrite ->(@refineCostAxiomClass(unwrapBiasTree m)) => //.
    move => j pf'.
    specialize (H3 j pf').
    apply unwrapBiasTree_spec in H3.
    rewrite H3. f_equal.
    rewrite /unwrap_ffun. rewrite ffunE => //.
  Qed.

  Global Instance biasRefineCostInstance
    : @RefineCostClass N (biasType (projT1 q) A) (biasCostInstance costClass) _ _.

  Global Instance biasRefineCostMaxInstance
         `(biasAxiomInstance : @BiasAxiomClass _ (projT1 q))
    : @RefineCostMaxClass N (biasType (projT1 q) A)
        (biasCostMaxInstance _ _ _ costMaxClass biasAxiomInstance)
        (biasCCostMaxInstance _ _).
  Proof.
    rewrite /RefineCostMaxClass /biasCostMaxInstance /biasCCostMaxInstance
            rat_to_Q_plus Dadd_ok /bias_val.
    have ->: (D_to_Q q == rat_to_Q (projT1 q))%Q.
    { by apply: dyadic_rat_to_Q. }
    apply Qplus_le_compat => //.
    apply Qle_refl.
  Qed.

  Global Instance biasCostMaxMaxInstance
         `{@BiasAxiomClass rat_realFieldType q}
         : @CCostMaxMaxClass N (biasType (projT1 q) A) _ _.
  Proof.
    split;
    rewrite /CCostMaxMaxClass;
    unfold CCostMaxMaxClass in ccostMaxMaxClass;
    clear H2;
    rename ccostMaxMaxClass into H4;
    specialize (H4 i (unwrapBiasTree m));
    rewrite  /ccost_fun
              /biasCCostInstance;
    rewrite /ccostmax_fun
            /biasCCostMaxInstance;
    destruct H4;
    unfold Dle in *; repeat rewrite Dadd_ok.
    +
      have: (D_to_Q 0 == 0)%Q => [| ZeroZero] //.
      clear -H2 H3 ZeroZero.
      rewrite -> ZeroZero in *.
      {
        move: H2;
        clear H2.
        generalize dependent
                   (D_to_Q ((ccost) i (unwrapBiasTree (A:=A) (q:=projT1 q) m))).
        unfold BiasAxiomClass in H3.
        unfold bias_val in *.
        have: (0 <= D_to_Q q)%Q => //.
        {
          apply le_rat_to_Q in H3=> //.
          clear -H3.
          move: H3.
          have->: ((rat_to_Q 0) = 0)%Q => //.
          rewrite <- dyadic_rat_to_Q => //.
        }
        intros H2 q0 H0.
        generalize dependent (D_to_Q q).
        intros.
        unfold Qle in *.
        simpl in *.
        ring_simplify in H0.
        ring_simplify in H1.
        ring_simplify.
        apply Z.add_nonneg_nonneg;
          apply Z.mul_nonneg_nonneg => //.
      }
      repeat rewrite Dadd_ok.
      apply Qplus_le_compat => //.
      my_omega.
  Qed.

  Global Instance bias_cgame `{@BiasAxiomClass rat_realFieldType q}
    : @cgame N (biasType (projT1 q) A) _ _ _ _ _ _
             (biasCostMaxAxiomInstance _ _ _ _ _ _ _ _)
             _ _ _ _ _ _ (biasGameInstance _ _ _ _ _).
End biasCompilable.

Module BiasCGameTest. Section biasCGameTest.
  Context {A : finType} {N : nat} `{cgame N A} {q : DRat}
          `{biasA : @BiasAxiomClass rat_realFieldType q}.
  Variable i' : OrdNat.t.
  Variable t' : M.t (@biasType rat_realFieldType q A).
  Check ccost_fun (N:=N) i' t'.
End biasCGameTest. End BiasCGameTest.

(***************************
 Unit Games are compilable
 ***************************)

Section unitCompilable.
  Variable (N : nat).

  Global Instance unitEnumerableInstance : Enumerable Unit :=
    [:: mkUnit].

  Global Program Instance unitRefineTypeAxiomInstance
    : @RefineTypeAxiomClass [finType of Unit] _.
  Next Obligation. by split => // r; rewrite mem_enum; case: r. Qed.

  Global Instance unitRefineTypeInstance
    : @RefineTypeClass [finType of Unit]  _ _.

  Definition unit_ccost (i : OrdNat.t) (m : M.t Unit) : D := 0.

  Global Instance unitCCostInstance
    : CCostClass N [finType of Unit] := unit_ccost.

  Global Program Instance unitRefineCostAxiomInstance
    : @RefineCostAxiomClass N [finType of Unit] _ _.
  Next Obligation.
    rewrite /(ccost) /(cost) /unitCostInstance /unitCCostInstance /unit_ccost.
    by rewrite D_to_Q0 rat_to_Q0.
  Qed.

  Global Instance unitRefineCostInstance
    : @RefineCostClass N [finType of Unit] _ _ _.

  Global Instance unitCCostMaxInstance
    : @CCostMaxClass N [finType of Unit] := 0%D.

  Global Instance unitrefineCostMaxInstance
    : @RefineCostMaxClass _ _ (@unitCostMaxInstance N _) unitCCostMaxInstance.
  Proof.
    rewrite /RefineCostMaxClass /unitCostMaxInstance /unitCCostMaxInstance.
    rewrite /rat_to_Q => //.
  Qed.
  Global Instance unitCCostMaxMaxInstance
         : @CCostMaxMaxClass N [finType of Unit] _ _.
  Proof.
    rewrite /CCostMaxMaxClass.
    move => i m.
    rewrite /ccost_fun /ccostmax_fun /unitCCostInstance
            /unit_ccost /unitCCostMaxInstance => //.
  Qed.

  Global Instance unit_cgame : cgame (N:=N) (T:= [finType of Unit]) _ _ _ _ _.
End unitCompilable.

(***************************
 Affine Games are compilable
 ***************************)

Section affineCompilable.
  Context {A N}
          `{scalA : DyadicScalarClass}
          `{scalB : DyadicScalarClass}
          `{cgame N A}
          `{Boolable A}
          (eqA : Eq A) (eqDecA : Eq_Dec eqA).

  Definition affine_preType :=
    ((@scalarType rat_realFieldType (@dyadic_scalar_val scalA) A) *
    (@scalarType rat_realFieldType (@dyadic_scalar_val scalB) (singletonType A)))%type.

  Global Instance affineTypePredInstance :
    PredClass (affine_preType) := affinePredInstance eqDecA.

  Definition affineType := [finType of {x : affine_preType | the_pred x}].

  Section affineGameTest.
    Variable i' : OrdNat.t.
    Variable t' : M.t (affine_preType).

    Check ccost_fun (N:=N) i' t'.
  End affineGameTest.
End affineCompilable.

(* Hints to help automatic instance derivation for typclasses eauto. *)
  Hint Extern 4 (RefineTypeAxiomClass ?t)=>
  refine (sigmaRefineTypeAxiomInstance _ _ _) : typeclass_instances.

  Hint Extern 4 (CostClass ?n ?r ?t) =>
  refine (sigmaCostInstance _) : typeclass_instances.

  Hint Extern 1 (ScalarAxiomClass ?r )=> done : typeclass_instances.

  Hint Extern 4 (CostAxiomClass ?c) =>
  refine (sigmaCostAxiomInstance _ _ _ _ _) : typeclass_instances.

  Hint Extern 4 (RefineCostAxiomClass ?c ?a) =>
  refine (sigmaRefineCostAxiomInstance _ _ _ _ _ _)
    : typeclass_instances.

  Hint Extern 4 (RefineCostAxiomClass ?c ?a) =>
  refine (sigmaCCostInstance _)
    : typeclass_instances.

  Hint Extern 4 (CostMaxAxiomClass ?cc ?cmc) =>
  refine (sigmaCostMaxAxiomInstance _ _ _ _ _ _ _)
    : typeclass_instances.

  Hint Extern 4 (RefineCostMaxClass ?cc ?cmc) =>
  compute; (try discriminate)
    : typeclass_instances.

  Hint Extern 4 (RefineTypeClass ?rtac) =>
  refine  (sigmaRefineTypeInstance _ _ _)
    : typeclass_instances.

  Hint Extern 4 (RefineCostClass ?rtac) =>
  refine (sigmaRefineCostInstance _ _)
    : typeclass_instances.

  Hint Extern 4 (CCostMaxMaxClass ?rtac ?m) =>
  refine (scalarCostMaxMaxInstance _ _)
    : typeclass_instances.