(** Goedel's "Dialectica" functional interpretation of logic, slightly generalized and
   adapted for Coq.

   As a starting point we take chapter VI, "Goedel's Functional Interpretation", by J.
   Avigad and S. Feferman from "Handbook of Proof Theory", edited by S.R. Buss, published
   by Elsevier Science, 1995. A preliminary draft is available at
   http://www.andrew.cmu.edu/user/avigad/Papers/dialect.pdf.

   Author: Andrej Bauer, http://andrej.com/
*)

From Coq Require Import ssreflect ssrbool ssrfun Eqdep_dec.
From mathcomp Require Import ssrnat eqtype.

Set Bullet Behavior "None".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Basic definitions *)

(** We shall allow universal and existential quantification over arbitrary inhabited types.
    The usual interpretation allows quantification over the natural numbers (and possibly
    functionals over the natural numbers), which are of course inhabited. *)

Record Inhabited := inhabit { ty :> Set; member : ty }.

(** The inhabited natural numbers. *)

Definition N := inhabit 0.

(** The inductive type [prp] is a "deep embedding" of the abstract syntax of
    the object language that we shall interpret into Coq. We admit only decidable primitive
    predicates, as is usual in the basic Dialectica variant.

    Our embedding allows us to express "exotic" propositional functions [p : ty -> prp] in
    which the logical structure of [p x] may depend on [x]. Because of this phenomenon we
    will be forced later on to introduce certain type dependencies where there are none in
    the usual Dialectica interpretation. *)

Inductive prp : Type :=
  | primitive : bool -> prp
  | conjunction : prp -> prp -> prp
  | disjunction : prp -> prp -> prp
  | implication : prp -> prp -> prp
  | negation : prp -> prp
  | universal : forall {ty : Inhabited}, (ty -> prp) -> prp
  | existential : forall {ty : Inhabited}, (ty -> prp) -> prp.

(** Convenient notation for the object language. *)

Notation "'[' p ']'" := (primitive p) (at level 80, no associativity).
Notation "'neg' x" := (negation x) (at level 70, no associativity).
Notation "x 'and' y" := (conjunction x y) (at level 74, left associativity).
Notation "x 'or' y" := (disjunction x y) (at level 76, left associativity).
Notation "x ==>> y" := (implication x y) (at level 78, right associativity).
Notation "'all' x : t , p" :=  (@universal t (fun x => p)) (at level 80, x at level 99).
Notation "'some' x : t , p" :=  (@existential t (fun x => p)) (at level 80, x at level 99).

(** With each proposition [p] we associate the types [W p] and [C p] of "witnesses" and
    "counters", respectively. Think of them as moves in a game between a player [W] and an
    opponent [C]. We make two changes to the standard Dialectica representation.

    First, we use sum for counters of conjunctions, where normally a product is used. This
    gives us symmetry between conjunction and disjunction, simplifies the notorious
    conjunction contraction [and_contr], but complicates the adjunction between implication
    and conjunction. Thomas Streicher pointed out that the change is inessential in the
    sense that we could prove a separate lemma which allows us to pass from counters for [p
    and q] as pairs to counters as elements of a sum (such a lemma relies in decidability
    of the [dia] relation defined below).

    Second, because we allow the structure of a propositional function to depend on the
    argument, we are forced to introduce type dependency into [W p] and [C p] when [p] is a
    quantified statement. This is not a big surprise, but what is a little more surprising
    is that the counters for existentials, [C (existential ty p')], involve a dependency
    not only on [ty] but also on [W (p' x)]. The dependency is needed in the rule
    [exists_elim]. The rest of Dialectica interpetation is not influenced by this change,
    with the exception of the Independence of Premise where we have to impose a condition
    that is not required in the usual interpretation.

    These type-dependencies clearly point towards an even more type-dependent Dialectica variant.
    Indeed, we are going to investigate it in a separate file. For now we are just trying
    to faithfully represent the Dialectica interpretation. *)

Fixpoint W (p : prp) : Set :=
  match p with
     | primitive _ => unit
     | conjunction p1 p2 => W p1 * W p2
     | disjunction p1 p2 => W p1 + W p2
     | implication p1 p2 => (W p1 -> W p2) * (W p1 * C p2 -> C p1)
     | negation p' => W p' -> C p'
     | universal ty p' => forall x : ty, W (p' x)
     | existential ty p' => { x : ty & W (p' x) }
  end

with C p : Set :=
  match p with
     | primitive _ => unit
     | conjunction p1 p2 => C p1 + C p2
     | disjunction p1 p2 => C p1 * C p2
     | implication p1 p2 => W p1 * C p2
     | negation p' => W p'
     | universal ty p' => { x : ty & C (p' x) }
     | existential ty p' => forall x : ty, W (p' x) -> C (p' x)
   end.

(** The types [W] and [C] are always inhabited because we restrict quantifiers to inhabited
    types. *)

Definition WC_member (p : prp) : W p * C p.
elim: p=>//=.
- by move=>?[??]?[??]; do!split=>//; right.
- by move=>?[??]?[??]; do!split=>//; left.
- by move=>?[??]?[??].
- by move=>?[??].
- move=>ty ? H; split.
  - by move=>x; case: (H x).
  - by exists (member ty); case: (H (member ty)).
- move=>ty ? H; split.
- by exists (member ty); case: (H (member ty)).
- by move=>x ?; case: (H x).
Defined.

Definition W_member (p : prp) := (WC_member p).1.
Definition C_member (p : prp) := (WC_member p).2.

(** The relation [dia p w c] is what is usually written as [p_D] in the Dialectica
    interpretation, i.e., the matrix of the interpreted formula.

    In terms of games, [dia p w c] tells whether the player move [w] wins against the
    opponent move [c] in the game determined by the proposition [p].
*)

Fixpoint dia (p : prp) : W p -> C p -> Prop :=
  match p return W p -> C p -> Prop with
    | primitive p => fun _ _ => p
    | conjunction p1 p2 =>
      fun a b => match b with
                    | inl b1 => dia a.1 b1
                    | inr b2 => dia a.2 b2
                  end
    | disjunction p1 p2 =>
      fun a b => match a with
                    | inl x => dia x b.1
                    | inr u => dia u b.2
                  end
    | implication p1 p2 =>
      fun a b => dia b.1 (a.2 b) -> dia (a.1 b.1) b.2
    | negation p' =>
      fun a b => ~ dia b (a b)
    | universal _ p' =>
      fun a b => dia (a (projT1 b)) (projT2 b)
    | existential _ p' =>
      fun a b => dia (projT2 a) (b (projT1 a) (projT2 a))
  end.

(** The [dia] relation is decidable. This fact is used only in the adjunction between
    conjunction and implication.

    (Actually, it's also used for the validity of induction).
*)

Fixpoint diab (p : prp) : W p -> C p -> bool :=
  match p return W p -> C p -> bool with
    | primitive p => fun _ _ => p
    | conjunction p1 p2 =>
      fun a b => match b with
                    | inl b1 => diab a.1 b1
                    | inr b2 => diab a.2 b2
                  end
    | disjunction p1 p2 =>
      fun a b => match a with
                    | inl x => diab x b.1
                    | inr u => diab u b.2
                  end
    | implication p1 p2 =>
      fun a b => diab b.1 (a.2 b) ==> diab (a.1 b.1) b.2
    | negation p' =>
      fun a b => ~~ diab b (a b)
    | universal _ p' =>
      fun a b => diab (a (projT1 b)) (projT2 b)
    | existential _ p' =>
      fun a b => diab (projT2 a) (b (projT1 a) (projT2 a))
  end.

Lemma diaP (p : prp) (a : W p) (b : C p) : reflect (dia a b) (diab a b).
Proof.
elim: p a b=>//=.
- by move=>? _ _; exact: idP.
- by move=>? H1 ? H2 ?; case=>?; [exact: H1|exact: H2].
- by move=>? H1 ? H2; case=>??; [exact: H1|exact: H2].
- move=>? H1 ? H2 ??; case: H1=>/=; last by move=>H; apply: ReflectT=>?; exfalso; apply: H.
  by case: H2=>/= D1 ?; [apply: ReflectT | apply: ReflectF=>H; apply/D1/H].
- by move=>? H ??; case: H=>/= ?; [apply: ReflectF|apply: ReflectT].
Qed.

(** Of course, a decidable proposition is stable for double negation. *)

Lemma dia_not_not_stable (p : prp) (w : W p) (c : C p) : ~ ~ dia w c -> dia w c.
Proof. by move/classicP=>H; apply/diaP/H =>/diaP. Qed.

(** The predicate [valid p] is the Dialectica interpretation of [p]. It says that there is
    [w] such that [dia p w c] holds for any [c]. In terms of games semantics this means
    that [W] has a winning strategy (which amounts to a winning move [w]). *)

Definition valid (p : prp) := { a : W p | forall b : C p, dia a b }.

(** * Validity of inference rules *)

(** We now verify that the Hilbert-style axioms for first-order logic are validated by our
    interpretation. We follow Avigad & Feferman. *)

Theorem modus_ponens (p q : prp) : valid p -> valid (p ==>> q) -> valid q.
Proof.
rewrite /valid /=; case=>wp H; case; case=>u ? /= G.
exists (u wp)=>b.
by apply/(G (_, _))/H.
Qed.

Theorem impl_chain (p q r : prp) : valid (p ==>> q) -> valid (q ==>> r) -> valid (p ==>> r).
Proof.
rewrite /valid /=; case; case=>a b /= H; case; case=>c d /= G.
exists (fun w => c (a w), fun v => b (v.1, d (a v.1, v.2)))=>/= g ?.
apply: (G (a g.1, g.2))=>/=.
by apply: (H (g.1, d (a g.1, g.2))).
Qed.

Theorem or_contr (p : prp) : valid (p or p ==>> p).
Proof.
rewrite /valid /=.
exists (fun x => (match x with inl a => a | inr a => a end), fun x => (x.2, x.2))=>/=.
by case; case.
Qed.

(** In the following theorem we avoid decidability of [dia] because we defined
    counters of conjunctions as sums. *)

Theorem and_contr (p : prp) : valid (p ==>> p and p).
Proof.
rewrite /valid /=.
exists (fun x => (x,x),
        fun y => match y.2 with inl c => c | inr c => c end)=>/=.
by case=>?; case.
Qed.

Theorem or_introl (p q : prp) : valid (p ==>> p or q).
Proof.
rewrite /valid /=.
by exists (inl, fst \o snd).
Qed.

Theorem and_eliml (p q : prp) : valid (p and q ==>> p).
Proof.
rewrite /valid /=.
by exists (fst, inl \o snd).
Qed.

Theorem or_comm (p q : prp) : valid (p or q ==>> q or p).
Proof.
rewrite /valid /=.
exists (fun x => match x with inl a => inr a | inr b => inl b end,
        fun y => (y.2.2, y.2.1))=>/=.
by case; case.
Qed.

Theorem and_comm (p q : prp) : valid (p and q ==>> q and p).
Proof.
rewrite /valid /=.
exists (fun x => (x.2, x.1),
        fun y => match y.2 with inl c => inr c | inr c => inl c end)=>/=.
by case=>?; case.
Qed.

Theorem or_distr (p q r : prp) : valid (p ==>> q) -> valid (r or p ==>> r or q).
Proof.
rewrite /valid /=; case; case=>a b /= H.
exists (fun x => match x with inl t => inl t | inr u => inr (a u) end,
        fun y => match y.1 with
                   | inl i => (y.2.1, b (W_member p, y.2.2))
                   | inr j => (y.2.1, b (j         , y.2.2))
                 end)=>/=.
case; case=>?[??] //= ?.
by apply: (H (_,_)).
Qed.

(** The next two theorems verify the adjunction between conjunction and implication. This is
    where we need decidability of [dia p w c] and inhabitation of [W] and [C]. *)

Theorem impl_conj_adjunct1 (p q r : prp) : valid (p ==>> (q ==>> r)) -> valid (p and q ==>> r).
Proof.
rewrite /valid /=; case; case=>a b /= H.
exists (fun x => (a x.1).1 x.2,
        fun (y : W p * W q * C r) =>
          let: ((wp, wq), cr) := y in
          if diab wq ((a wp).2 (wq, cr))
          then inl (b (wp, (wq, cr)))
          else inr ((a wp).2 (wq, cr)))=>/=.
move=>[[??]?].
case: (diaP _ ((a _).2 _))=>//= ??.
by apply: (H (_,(_,_))).
Qed.

Theorem impl_conj_adjunct2 (p q r : prp) : valid (p and q ==>> r) -> valid (p ==>> (q ==>> r)).
Proof.
rewrite /valid /=; case; case=>a b /= H.
exists (fun x => (fun u => a (x, u),
                  fun v => match b ((x, v.1), v.2) with
                              | inl c => C_member q
                              | inr d => d
                            end),
        fun y => match b ((y.1, y.2.1), y.2.2) with
                   | inl c => c
                   | inr d => C_member p
                 end)=>/=.
move=>[?[??]] /= F G.
apply: (H (_,_,_))=>/=; move: F G.
by case: (b _).
Qed.

Theorem false_elim (p : prp) : valid ([false] ==>> p).
Proof.
rewrite /valid /=.
exists (fun _ => W_member p, fun _ => tt)=>/=.
by move=>?.
Qed.

Theorem forall_intro {ty : Inhabited} (p : prp) (q : ty -> prp) :
  (forall x : ty, valid (p ==>> q x)) -> valid (p ==>> all x : ty, q x).
Proof.
rewrite /valid /= =>H.
exists (fun u x => (projT1 (H x)).1 u,
        fun (y : W p * {x : ty & C (q x)}) =>
          (projT1 (H (projT1 y.2))).2 (y.1, projT2 y.2)).
move=>[?[??]] /= H0.
case: H H0=>/= ? H.
by apply: H (_,_).
Qed.

Theorem forall_elim {ty : Inhabited} (a : ty) (p : ty -> prp) :
  valid ((all x : ty, p x) ==>> p a).
Proof.
rewrite /valid /=.
by exists (fun f => f a, fun y => existT _ a y.2).
Qed.

Theorem exists_intro {ty : Inhabited} (a : ty) (p : ty -> prp) :
  valid (p a ==>> some x : ty, p x).
Proof.
rewrite /valid /=.
by exists (fun x => existT _ a x, fun y => y.2 a y.1).
Qed.

(** This is the rule in which we need the dependency of counters in existential statements. *)

Theorem exists_elim {ty : Inhabited} (p : ty -> prp) (q : prp) :
  (forall x : ty, valid (p x ==>> q)) -> valid ((some x : ty, p x) ==>> q).
Proof.
rewrite /valid /= => H.
exists (fun (u : {x : ty & W (p x)}) => (projT1 (H (projT1 u))).1 (projT2 u),
        fun v x w => (projT1 (H x)).2 (w, v.2)).
move=>[[??]?] /= H0.
case: H H0=>/= ? H.
by apply: H (_,_).
Qed.

(** * Equality

      Next we verify the rules of equality. To keep things simple we only consider equality
      of natural numbers. In the general case we could consider decidable equality on an
      inhabited type. *)

Definition prpEq (m n : nat) := [m == n].

(** Dialectica equality implies equality. *)

Theorem prpEq_eq (m n : N) : valid (prpEq m n) -> m = n.
Proof.
rewrite /prpEq /valid /=; case=>_ H.
by apply/eqP/H.
Qed.

(** Reflexivity. *)

Theorem prpEq_refl (n : N) : valid (prpEq n n).
Proof. by rewrite /valid /= eq_refl. Qed.

(** Equality implies Dialectica equality, of course *)

Theorem eq_prpEq (m n : N) : m = n -> valid (prpEq m n).
Proof. by move=>->; exact: prpEq_refl. Qed.

(** Leibniz's law as a rule of inference. *)

Theorem leibniz_rule (p : N -> prp) (m n : N) :
  valid (prpEq m n) -> valid (p m) -> valid (p n).
Proof. by rewrite /valid /=; case=>_ H; move/eqP: (H tt)=>->. Qed.

(** Proving Leibniz's law as a proposition is more complicated because of type dependency
    that is not present in the usual Dialectica interpretation.

   We need UIP (Uniqueness of Identity Proofs) for natural numbers here. *)

Definition eqN_decidable (m n : nat) : decidable (m = n) := decP (@eqP _ m n).

Definition W_transfer (p : nat -> prp) (m n : nat) : W (p m) -> W (p n) :=
  fun w => match eqN_decidable m n with
  | left eq => eq_rect m (fun k => W (p k)) w n eq
  | right _ => W_member (p n)
  end.

Definition C_transfer (p : nat -> prp) (m n : nat) : C (p m) -> C (p n) :=
  fun c => match eqN_decidable m n with
  | left eq => eq_rect m (fun k => C (p k)) c n eq
  | right _ => C_member (p n)
  end.

(** Finally, the validity of Leibniz's law is proved. If someone knows a shortcut,
    I would like to know about it. *)

Theorem leibniz (p : nat -> prp) (m n : nat) : valid (prpEq m n ==>> p m ==>> p n).
Proof.
rewrite /valid /=.
exists (fun _ => (fun w => @W_transfer _ _ _ w,
                  fun y => @C_transfer _ _ _ y.2),
        fun _ => tt)=>/=.
move=>[[] [??]] /=; rewrite /C_transfer /W_transfer.
move/eqP=>E; destruct E.
case: (eqN_decidable m m)=> // E1.
by rewrite (UIP_dec eqN_decidable E1 (refl_equal m)).
Qed.

(** * Natural numbers

      Next we verify that the natural numbers obey Peano axioms. They are easy, except for
      induction which has two parts: the usual "forward" direction by primitive recursion,
      and a "backwards" direction in which we search for a counter-example, starting from an
      upper bound and going down to 0. *)

Theorem nat_zero_not_succ (n : nat) : valid (neg (prpEq (S n) 0)).
Proof. by rewrite /valid /=; exists (fun _ => tt). Qed.

Theorem succ_injective (m n : nat) : valid (prpEq (S m) (S n) ==>> prpEq m n).
Proof. by rewrite /valid /=; exists (fun _ => tt, fun _ => tt). Qed.

(** Given a propositional function [p : nat -> prp], suppose [p m] is not valid. Then [p
   0] is not valid, or one of induction steps [p k ==> p (S k)] fails. The "backwards"
   direction of the Dialectica interpretation of induction is a search functional which
   looks for a failed base case or failed induction step. We construct it separately from
   the main proof. *)

Definition search (p : nat -> prp) (m : nat) :
  W (p 0) ->
  (forall k : nat, W (p k) -> W (p (S k))) ->
  (forall k : nat, W (p k) * C (p (S k)) -> C (p k)) ->
  C (p m) ->
  C (p 0) + {n : nat & (W (p n) * C (p (S n)))%type}.
Proof.
move=>z s b c; elim: m c; first by move=>?; left.
move=>m IH c.
pose w := nat_rect _ z s m.
case: (diaP w (b m (w,c)))=>_.
- by right; exists m.
by apply/IH/b.
Defined.

(** Finally we verify validity of induction. *)

Theorem N_induction (p : nat -> prp) (m : nat) :
  valid (p 0 and (all n : N, p n ==>> p (S n)) ==>> p m).
Proof.
rewrite /valid /=.
exists (fun x => nat_rect _ x.1 (fun k => (x.2 k).1) m,
        fun y => search y.1.1
                   (fun k => (y.1.2 k).1)
                   (fun k => (y.1.2 k).2)
                   y.2)=>/=.
move=>[[??] c] /=.
elim: m c=>//; rewrite /search /= =>? IH ?.
case: diaP=>/= [D1|D2] H.
- by apply/H/D1.
by exfalso; apply/D2/IH/H.
Qed.

(** Having done ordinary induction one is tempted to try validating induction for
   W-types... but not here. *)

(** * Markov Principle and Independence of Premise *)

(** The Dialectica interpretation is characterized by two non-intuitionistic reasoning principles,
    namely Markov principle (MP) and Independence of Premise (IP).

    Both MP and IP involve primitive propositional function [N -> bool]. The point of
    these is that their [W] and [C] types are the unit. So instead of actually using
    primitive proposition, we shall use arbitrary propositions whose [W] and [C] types are
    singletons. First we make the relevant definitions. *)

Definition singleton (t : Inhabited) := forall x, x = member t.

Definition trivial_C (p : prp) := singleton (inhabit (C_member p)).
Definition trivial_W (p : prp) := singleton (inhabit (W_member p)).

(** Primitive propositions are trivial, of course. *)

Lemma primitive_trivial_W (b : bool) : trivial_W ([b]).
Proof. by case. Qed.

Lemma primitive_trivial_C (b : bool) : trivial_C ([b]).
Proof. by case. Qed.

(** Whether there are trivial propositions, other than the primitive ones, depends on what
   extra axioms we have available. For example, in the presence of extensionality of
   functions, implications and negations of trivial propositions are trivial. We do not
   dwell on the exact conditions that give us trivial propositions, but only demonstrate
   how to use extensionality of functions whose codomain is a singleton set to derive
   triviality of implication of trivial propositions.
*)

(** We are only interested in extensionality of functions [s -> t] for which
    [t] is a singleton. Such extensionality can be phrased as "any power of a
    singleton is a singleton". *)

Definition singleton_power :=
  forall t, singleton t -> forall s : Set, singleton (inhabit (fun _ : s => member t)).

(** I _think_ there is no way of proving [singleton_power], is there? We can use it to
    show that [W (p ==> q)] is trivial if [C p] and [W q] are trivial. *)

Lemma implication_trivial_W (p q : prp) :
  singleton_power -> trivial_C p -> trivial_W q -> trivial_W (p ==>> q).
Proof.
move=>E TCp TWq; rewrite /trivial_W /singleton /W_member /=; case=>f g.
rewrite (E _ TWq _ f) (E _ TCp _ g) /=.
by rewrite 2![WC_member _]surjective_pairing.
Qed.

(** Triviality of [C (p ==> q)] does not require any extra assumptions. *)
Lemma implication_trivial_C (p q : prp) :
  trivial_W p -> trivial_C q -> trivial_C (p ==>> q).
Proof.
move=>TWp TCq; rewrite /trivial_C /C_member /=; case=>wp cq /=.
rewrite (TWp wp) (TCq cq) /=.
by rewrite 2![WC_member _]surjective_pairing.
Qed.

(** ** Markov principle *)

(** Markov principle holds for any inhabited type (not just the natural numbers) and
   a proposition which has trivial [W] and [C] types. *)

Theorem markov_generalized (t : Inhabited) (p : t -> prp) :
  (forall x, trivial_C (p x)) ->
  (forall x, trivial_W (p x)) ->
  valid (neg (all x : t, neg (p x)) ==>> some x : t, p x).
Proof.
rewrite /valid /= => TC TW.
pose u := fun (h : _ -> {x : t & W (p x)}) =>
            let y := projT1 (h (fun x (_ : W (p x)) => C_member (p x))) in
            existT (fun x : t => W (p x)) y (W_member (p y)).
exists (u, fun _ x _ => C_member (p x))=>/=.
move=>[f g] /=.
pose v := projT1 (f (fun x _ => C_member (p x))).
pose w := projT2 (f (fun (x : t) (_ : W (p x)) => C_member (p x))).
rewrite (TC v (g v (W_member (p v)))) /=.
move: (TW v w); rewrite /w =>->/=.
by apply: dia_not_not_stable.
Qed.

(** The usual Markov principle now follows easily. *)

Theorem markov (p : nat -> bool) :
  valid (neg (all n : N, neg ([p n])) ==>> some n : N, ([p n])).
Proof.
by apply: markov_generalized=>?; [exact: primitive_trivial_C | exact: primitive_trivial_W].
Qed.

(** ** The Independence of Premise *)

(** The usual IP relates propositional functions [p : s -> bool] and [q : t -> prp]:

    [((all x : s, p x) ==> some y : t, q y) ==> some y : t, (all x : s, p x) ==> q y]

    It is possible to generalize [p] to [p : s -> prp] with trival [W (p x)]. On the other
    hand, the type-dependencies force us to require that [C (q y)] be trivial. *)

Theorem ip_generalized (s t : Inhabited) (p : s -> prp) (q : t -> prp) :
  (forall (x : s), trivial_W (p x)) ->
  (forall (y : t), trivial_C (q y)) ->
  valid (((all x : s, p x) ==>> some y : t, q y) ==>>
          some y : t, (all x : s, p x) ==>> q y).
Proof.
rewrite /valid /= => TW TC.
pose u := fun (x : s) => W_member (p x).
pose v := fun (y : t) (_ : W (q y)) => C_member (q y).
exists (fun a => existT _ (projT1 (a.1 u)) (fun _ => projT2 (a.1 u),
                                            fun b => a.2 (u,v)),
        fun _ => (u,v))=>/=.
move=>[[??] h] /=.
by rewrite (TC _ (h _ _).2) (TW _ ((h _ _).1 _)).
Qed.

(** A special case of our IP occurs when [p] is a primitive propositional function. *)

Theorem ip (s t : Inhabited) (p : s -> bool) (q : t -> prp) :
  (forall (y : t), trivial_C (q y)) ->
  valid (((all x : s, ([p x])) ==>> some y : t, q y) ==>>
          some y : t, (all x : s, ([p x])) ==>> q y).
Proof.
move=>?; apply: ip_generalized=>//.
by move=>?; apply: primitive_trivial_W.
Qed.

(** This concludes the verification of the Dialectica interpretation in Coq. There are at
    least three interesting directions to go:

    - Extract programs from the Dialectica interpretation. It looks like this could be done
      for extraction into Scheme. Extraction into Haskell and Ocaml seem more complicated
      because the [W] and [C] types are dependent and there seems no easy way of
      translating them into a simply-typed programming language. Presumably, concrete
      examples could be extracted with the help of "[Extraction Inline W C.]".

    - Explore other variants, such as the Diller-Nahm interpretation, or perhaps the
      interpretations a la Ulrich Kohlenbach and Paolo Oliva.

    - Explore the possibility of having a fully dependent Dialectica interpretation.
      Initial investigations by Thomas Streicher and myself indicate that it can be done.
      This would give us a way of constructing a two-level type system (with Prop separate
      from Set) that validates MP and IP. *)


Require Import ZArith.
Require Import List.
Require Import FMapPositive.
Require Import String.
Open Scope string_scope.

Require Import domains.
Require Import kstyle.
Require Import coinduction.

Coercion EVar : string >-> Exp.
Coercion ECon : Z >-> Exp.

Open Scope Z_scope.

(* Can a tactic turn a simple rule automatically into a relation?
   What does "pattern reaches" do? *)

Ltac kequiv_tac := repeat (apply conj);[reflexivity|simpl;equate_maps ..].
Ltac kstep_tac := econstructor(reflexivity || (simpl;find_map_entry)).

(*
(* Either solve immediately by using the circularity,
   or bail out for manual intervention if the
   circularity matches structurally *)
Ltac use_circ circ :=
  solve[eapply circ;
  try (match goal with [|- _ ~= _] => equate_maps;reflexivity end);
  instantiate;  omega]
  || (eapply circ;fail 1).

Ltac run := repeat (step_rule || split_if || finish).
Ltac run_circ circ := repeat (use_circ circ || (step_rule || split_if || finish)).

Ltac tstep := refine (Delay (itstep _ _ _ _));[econstructor (solve[reflexivity || find_map_entry])|].
Ltac tsplit_if := cbv beta; (* reduce redexes left from plugging *)
  match goal with
      | [|- tsteps (KCfg (kra (KStmt (SIf (BCon (?x <=? ?y)%Z) _ _)) _) _ _ _) _] =>
        pose proof (Zle_cases x y); destruct (x <=? y)%Z
  end.
 *)

Notation basic_goal rel :=
  (forall env,
  rel (KCfg (kra (SAssign "x" (EPlus "x" "y")) nil)
            (env :* "x" |-> 12%Z :* "y" |-> 13%Z) mapEmpty mapEmpty)
      (kequiv (KCfg nil (env :* "x" |-> 25%Z :* "y" |-> 13%Z) mapEmpty mapEmpty))).
(* Very basic example, no heaps or labels, and even using derived rules *)
Lemma direct_coinduction : basic_goal reaches.
intros.
repeat (eapply step;[econstructor (reflexivity || find_map_entry)|]);apply done.
repeat split;equate_maps.
Qed.

(* Using tactics for kstep, kequiv *)
Lemma basic_tacs : basic_goal reaches.
intros.
repeat (eapply step;[kstep_tac|]);apply done;kequiv_tac.
Qed.

Ltac steps_run := repeat (eapply step;[kstep_tac|]);apply done;kequiv_tac.

(* Now using derived rules *)

(* Try to either finish immediately or take a step at a stepF goal *)
Ltac first_step := (apply DoneF;kequiv_tac) || (eapply StepF;[kstep_tac|]).
Ltac by_rules rules := let H := fresh in
  assert (sound rules) as H;
    [apply trans_sound;destruct 1;first_step
    |intros;apply H;econstructor(eassumption)].

Inductive basic_rule : RRel := BasicGoal : basic_goal basic_rule.

Lemma derived_rules : basic_goal reaches.
by_rules basic_rule.
repeat (eapply tstep;[kstep_tac|]);apply tdone;kequiv_tac.
Qed.

(* Make a basic run tactic *)
Ltac tstep_tac := eapply tstep;[kstep_tac|].
Ltac tfinish_tac := solve[apply tdone;kequiv_tac].

Ltac trun_basic := repeat tstep_tac;try tfinish_tac.

Lemma trun_basic_test : basic_goal reaches.
by_rules basic_rule;trun_basic.
Qed.

Notation heap_goal rel :=
  (forall p env, rel (KCfg (kra (HAssign "x" (EPlus (ELoad "x") 1%Z)) nil)
              (env :* "x" |-> p) (p |-> 12%Z) mapEmpty)
        (kequiv (KCfg nil (env :* "x" |-> p) (p |-> 13%Z) mapEmpty))).

Inductive heap_rule : RRel := HeapGoal : heap_goal heap_rule.
(* Now an example program that has a heap *)
Lemma heap_test : heap_goal reaches.
Proof.
by_rules heap_rule;trun_basic.
Qed.

(* TODO: for insertion sort, have predicates about being sorted
   and being a permutation and stuff

  i = 1
  {{arr A n l' /\
    permutation l l' A /\
    sorted A[0..i-1]}}
   ==>
  {{arr A n l' /\ permutation l l'
    /\ sorted A[0..n]}}
  while (i <= n) {
     to_insert = A[i]
     k = i;
     {{rep A n[0..k-1] (take k l)
       rep A n[k+1..?] (take (n-k) (drop k l))
       permutation ?? /\ sorted ??}}
     while (k > 0 && to_insert < A[k-1]) {
       A[k] = A[k-1];
       --k;
     }
     A[k] = to_insert
     ++i
  }

 *)

(* Slightly more compilicated example, needing to split. *)
Definition step (state event : Z) :=
  match state, event with
    | Z0, Z0 => 1
    | _, _ => 0
  end.
Lemma step_ZZ : forall s e, s = 0 -> e = 0 -> step s e = 1.
intros;subst;reflexivity. Qed.
Lemma step_N1 : forall s e, s <> 0 -> step s e = 0.
intros;destruct s;simpl;congruence. Qed.
Lemma step_N2 : forall s e, e <> 0 -> step s e = 0.
intros;destruct s;destruct e;simpl;congruence. Qed.
Create HintDb step_simpl discriminated.
Hint Rewrite step_ZZ step_N1 step_N2 using assumption: step_simpl.

Notation split_goal rel := (forall state addr event,
  rel (KCfg (kra (SIf
                 (BAnd (BEq (ELoad "state") 0) (BEq "event" 0))
                 (HAssign "state" 1)
                 (HAssign "state" 0)) nil)
              ("event" |-> event :* "state" |-> addr) (addr |-> state) mapEmpty)
      (kequiv (KCfg nil
              ("event" |-> event :* "state" |-> addr) (addr |-> (step state event)) mapEmpty))).
Inductive split_rules : RRel := SplitGoal : split_goal split_rules.

(* First split manually *)
Lemma manual_split : split_goal reaches.
Proof.
by_rules split_rules;trun_basic.
(* Gets stuck at split *)
destruct state;trun_basic.
destruct event;trun_basic.
Qed.
Close Scope Z_scope.

Ltac split_bool bexp :=
  match bexp with
    | negb ?bexp' => split_bool bexp'
    | (?x <=? ?y)%Z => destruct (Z.leb_spec x y)
    | (?x =? ?y)%Z  => destruct (Z.eqb_spec x y)
  end.
Ltac tsplit_if :=
  cbv beta; match goal with
      | [|- trans _ (KCfg (kra (KStmt (SIf (BCon ?test) _ _)) _) _ _ _) _] => split_bool test
      | [|- trans _ (KCfg (kra (KBExp (BAnd (BCon ?test) _)) _) _ _ _) _] => split_bool test
  end.

Ltac trun_split finish_simpl := repeat (tstep_tac || tsplit_if);finish_simpl;try tfinish_tac.

Lemma auto_split : split_goal reaches.
Proof.
by_rules split_rules;trun_split ltac:(autorewrite with step_simpl).
Qed.
Close Scope Z_scope.

(* List reverse *)
Definition listrev :=
  (SWhile (BNot (BEq 0%Z "p"))
     (Seq (SAssign "next" (ELoad (EPlus "p" 1%Z)))
     (Seq (HAssign (EPlus "p" 1%Z) "q")
     (Seq (SAssign "q" "p")
          (SAssign "p" "next"))))).

(* Representation predicate *)
Fixpoint listrep (l : list Z) (p : Z) (m : Map Z Z) : Prop :=
  match l with
    | nil => p = 0%Z /\ m ~= mapEmpty
    | (v :: l') =>
       p <> 0%Z /\
       exists next m',
         m ~= p |-> v :* (p + 1)%Z |-> next :* m'
         /\ listrep l' next m'
  end.

(*
Ltac same_eprefix H :=
  match goal with
      [ H : exists _ : ?A , _ |- exists _ : ?A , _ ] =>
      let x := fresh "x" in destruct H as [x H]; exists x
  end.
*)

Lemma listrep_equiv : forall l p m m', m ~= m' -> listrep l p m -> listrep l p m'.
destruct l;simpl; intuition.
setoid_rewrite <- H; assumption.
Qed.

(* Test a concrete execution of list reverse *)
Lemma rev_test : forall lenv,
  steps (KCfg (kra listrev nil)
              ("p" |-> 1 :* "q" |-> 0 :* "next" |-> 1)%Z
              (1 |-> 12 :* 2 |-> 3 :*
               3 |-> 13 :* 4 |-> 5 :*
               5 |-> 14 :* 6 |-> 0)%Z
              lenv)
        (KCfg nil
              ("p" |-> 0 :* "q" |-> 5 :* "next" |-> 0)%Z
              (1 |-> 12 :* 2 |-> 0 :*
               3 |-> 13 :* 4 |-> 1 :*
               5 |-> 14 :* 6 |-> 3)%Z
              lenv).
Proof.
intros;steps_run.
Qed.

(* Brute force attempt to simplify all representation predicates *)
Ltac simplify_listrep := repeat
  match goal with
    | [H : listrep ?l _ ?heap |- _] =>
      let pf := fresh in
      destruct l;
        [destruct H as [pf H]
        |destruct H as [pf [? [? [H ?]]]]];
        try (exfalso;omega);[clear pf];
        try (rewrite H in * |- *;clear H heap)
  end.

(* Need to adjust tactics to stop at circularities, and maybe do something
   about automatically cleaning up lists *)

(* Idea 1: assume circularities have non-overlapping <k> in left-hand side,
   so we can commit to the first that unifies and (fail 1) if we couldn't
   satisfy it's hypotheses *)
(* Idea 2: add into the run cycle a tactic that recognizes lookups on an
   address registered with a representation predicate, and unfolds/splits to
   make progress
 *)
(* Idea 3: probably folding can be handled by writing invariant rules with
   folded conclusions, and then we only have to deal with it at the finish
   while trying to validate that rule
 *)

(*
Ltac stop_at_circ circ := (eapply circ; fail 1).
(* add to find_map_entry a thing that unfolds/splits *)
Ltac r_step := (eapply r_more;[solve[econstructor(reflexivity||find_map_entry)]|]).
(* Add a thing that cleans up *)
Ltac rsplit_if :=
  cbv beta; match goal with
      | [|- reaches (KCfg (kra (KStmt (SIf (BCon ?test) _ _)) _) _ _ _) _] => split_bool test
  end.
Ltac r_run circ := repeat (stop_at_circ circ || (r_step || (rsplit_if;simplify_listrep))).
*)

Notation rev_goal rel :=
 (forall p l q l' heap0 heap_l heap_l' lenv,
  listrep l p heap_l ->
  listrep l' q heap_l' ->
  heap0 ~= heap_l :* heap_l' ->
  rel (KCfg (kra listrev nil)
                ("p" |-> p :* "next" |-> p :* "q" |-> q)
                heap0
                lenv)
          (fun cfg' =>
             exists q' heap',
               listrep (rev_append l l') q' heap' /\
               kequiv cfg'
                      (KCfg nil
                            ("p" |-> 0 :* "next" |-> 0 :* "q" |-> q')%Z
                            heap'
                            lenv))).

Inductive rev_rule : RRel := RevGoal : rev_goal rev_rule.

Require Import Setoid.

Lemma rev_pf : rev_goal reaches.
by_rules rev_rule.

do 9 tstep_tac.
tsplit_if.
trun_split simplify_listrep.

apply tdone.

rewrite equivComm, equivUnit in H1;
subst;eexists;eexists;split;[|reflexivity];
revert H0;apply listrep_equiv;symmetry;assumption.

do 10 tstep_tac.
simplify_listrep.
do 23 tstep_tac.

clear heap0 H1.
eapply tcirc.
set (heap0 := (p + 1)%Z |-> q :* (p |-> z :* x0) :* heap_l').
assert (listrep (z :: l') p
        ((p + 1)%Z |-> q :* p |-> z :* heap_l')) by
 (clear -n H0;simpl;split;[omega|];eexists;eexists;split;[|eassumption];
            equate_maps).
eapply RevGoal;try eassumption.
unfold heap0;equate_maps.
intros t Pred.

apply tdone. apply Pred.
Qed.


Require Export smonoidalgroupoid.

Section FSMG.

Private Inductive FSMG (X : Type) : Type :=
  | e : FSMG X
  | iota : X -> FSMG X
  | m : FSMG X -> FSMG X -> FSMG X.
Global Arguments e {X}.
Global Arguments iota {X} _.
Global Arguments m {X} _ _.
Context (X : Type).

Definition mm {x x' y y' : FSMG X}
  (p : x = x') (q : y = y')
  : m x y = m x' y'
  := ap011 m p q.

Axiom alpha : @IsAssociative (FSMG X) m.
Axiom lambda : @IsLeftUnital (FSMG X) e m.
Axiom rho : @IsRightUnital (FSMG X) e m.
Axiom tau : @IsSymmetric (FSMG X) m.
Axiom pentagon : IsPentagonCoherent m alpha.
Axiom triangle : IsTriangleCoherent e m alpha lambda rho.
Axiom hexagon : IsHexagonCoherent m alpha tau.
Axiom bigon : IsBigonCoherent m tau.
Axiom T_FSMG : IsTrunc 1 (FSMG X).

Section FSMG_ind.

Context
  (P : FSMG X -> Type)
  (e' : P e)
  (iota' : forall x : X, P (iota x))
  (m' : forall (a b : FSMG X), P a -> P b -> P (m a b)).
Global Arguments m' {a} {b} _ _.

Definition mm'
  {a1 a2 b1 b2 : FSMG X} {p : a1 = a2} {q : b1 = b2}
  {a1' : P a1} {a2' : P a2} {b1' : P b1} {b2' : P b2}
  (p' : transport P p a1' = a2') (q' : transport P q b1' = b2')
  : transport P (mm p q) (m' a1' b1') = m' a2' b2'.
Proof.
  induction p, q, p', q'; constructor.
Defined.

Fixpoint FSMG_ind
  (alpha' : forall (a b c : FSMG X) (a' : P a) (b' : P b) (c' : P c),
    transport P (alpha a b c) (m' (m' a' b') c') = m' a' (m' b' c'))
  (lambda' : forall (b : FSMG X) (b' : P b),
    transport P (lambda b) (m' e' b') = b')
  (rho' : forall (a : FSMG X) (a' : P a),
    transport P (rho a) (m' a' e') = a')
  (tau' : forall (a b : FSMG X) (a' : P a) (b' : P b),
    transport P (tau a b) (m' a' b') = m' b' a')
  (pentagon' : forall (a b c d : FSMG X) (a' : P a) (b' : P b) (c' : P c) (d' : P d),
    concat_D
      (alpha' _ _ _ (m' a' b') c' d')
      (alpha' _ _ _ a' b' (m' c' d'))
    = ap (fun z => transport P z (m' (m' (m' a' b') c') d')) (pentagon a b c d)
      @ concat_D
          (concat_D
            (mm' (alpha' _ _ _ a' b' c') (transport_1 P d'))
            (alpha' _ _ _ a' (m' b' c') d'))
          (mm' (transport_1 P a') (alpha' _ _ _ b' c' d')))
  (triangle' : forall (a b : FSMG X) (a' : P a) (b' : P b),
    concat_D
      (alpha' _ _ _ a' e' b')
      (mm' (transport_1 P a') (lambda' _ b'))
    = ap (fun z => transport P z (m' (m' a' e') b')) (triangle a b)
      @ mm' (rho' _ a') (transport_1 P b'))
  (hexagon' : forall (a b c : FSMG X) (a' : P a) (b' : P b) (c' : P c),
    concat_D
      (concat_D
        (alpha' _ _ _ a' b' c')
        (tau' _ _ a' (m' b' c')))
      (alpha' _ _ _ b' c' a')
    = ap (fun z => transport P z (m' (m' a' b') c')) (hexagon a b c)
    @ concat_D
        (concat_D
          (mm' (tau' _ _ a' b') (transport_1 P c'))
          (alpha' _ _ _ b' a' c'))
        (mm' (transport_1 P b') (tau' _ _ a' c')))
  (bigon' : forall (a b : FSMG X) (a' : P a) (b' : P b),
    concat_D (tau' _ _ a' b') (tau' _ _ b' a')
    = ap (fun z => transport P z (m' a' b')) (bigon a b))
  (T' : forall (w : FSMG X), IsTrunc 1 (P w))
  (w : FSMG X) : P w
  := match w with
    | e => e'
    | iota x => iota' x
    | m a b => m' (FSMG_ind alpha' lambda' rho' tau' pentagon' triangle' hexagon' bigon' T' a) (FSMG_ind alpha' lambda' rho' tau' pentagon' triangle' hexagon' bigon' T' b) end.

Section Axioms.

Context
  (alpha' : forall (a b c : FSMG X) (a' : P a) (b' : P b) (c' : P c),
    transport P (alpha a b c) (m' (m' a' b') c') = m' a' (m' b' c'))
  (lambda' : forall (b : FSMG X) (b' : P b),
    transport P (lambda b) (m' e' b') = b')
  (rho' : forall (a : FSMG X) (a' : P a),
    transport P (rho a) (m' a' e') = a')
  (tau' : forall (a b : FSMG X) (a' : P a) (b' : P b),
    transport P (tau a b) (m' a' b') = m' b' a')
  (pentagon' : forall (a b c d : FSMG X) (a' : P a) (b' : P b) (c' : P c) (d' : P d),
    concat_D
      (alpha' _ _ _ (m' a' b') c' d')
      (alpha' _ _ _ a' b' (m' c' d'))
    = ap (fun z => transport P z (m' (m' (m' a' b') c') d')) (pentagon a b c d)
      @ concat_D
          (concat_D
            (mm' (alpha' _ _ _ a' b' c') (transport_1 P d'))
            (alpha' _ _ _ a' (m' b' c') d'))
          (mm' (transport_1 P a') (alpha' _ _ _ b' c' d')))
  (triangle' : forall (a b : FSMG X) (a' : P a) (b' : P b),
    concat_D
      (alpha' _ _ _ a' e' b')
      (mm' (transport_1 P a') (lambda' _ b'))
    = ap (fun z => transport P z (m' (m' a' e') b')) (triangle a b)
      @ mm' (rho' _ a') (transport_1 P b'))
  (hexagon' : forall (a b c : FSMG X) (a' : P a) (b' : P b) (c' : P c),
    concat_D
      (concat_D
        (alpha' _ _ _ a' b' c')
        (tau' _ _ a' (m' b' c')))
      (alpha' _ _ _ b' c' a')
    = ap (fun z => transport P z (m' (m' a' b') c')) (hexagon a b c)
    @ concat_D
        (concat_D
          (mm' (tau' _ _ a' b') (transport_1 P c'))
          (alpha' _ _ _ b' a' c'))
        (mm' (transport_1 P b') (tau' _ _ a' c')))
  (bigon' : forall (a b : FSMG X) (a' : P a) (b' : P b),
    concat_D (tau' _ _ a' b') (tau' _ _ b' a')
    = ap (fun z => transport P z (m' a' b')) (bigon a b))
  (T' : forall (w : FSMG X), IsTrunc 1 (P w)).

Let FSMG_ind' := FSMG_ind alpha' lambda' rho' tau' pentagon' triangle' hexagon' bigon' T'.

Axiom FSMG_ind_beta_alpha
  : forall (a b c : FSMG X),
    apD FSMG_ind' (alpha a b c) = alpha' _ _ _ (FSMG_ind' a) (FSMG_ind' b) (FSMG_ind' c).

Axiom FSMG_ind_beta_lambda
  : forall (b : FSMG X),
    apD FSMG_ind' (lambda b) = lambda' _ (FSMG_ind' b).

Axiom FSMG_ind_beta_rho
  : forall (a : FSMG X),
    apD FSMG_ind' (rho a) = rho' _ (FSMG_ind' a).

Axiom FSMG_ind_beta_tau
  : forall (a b : FSMG X),
    apD FSMG_ind' (tau a b) = tau' _ _ (FSMG_ind' a) (FSMG_ind' b).

(* Axioms for pentagon and triangle omitted *)

End Axioms.

End FSMG_ind.

Section FSMG_ind_trunc.

Context
  (P : FSMG X -> Type)
  (e' : P e)
  (iota' : forall x : X, P (iota x))
  (m' : forall (a b : FSMG X), P a -> P b -> P (m a b)).
Global Arguments m' {a} {b} _ _.

Definition FSMG_ind_to_set
  (alpha' : forall (a b c : FSMG X) (a' : P a) (b' : P b) (c' : P c),
    transport P (alpha a b c) (m' (m' a' b') c') = m' a' (m' b' c'))
  (lambda' : forall (b : FSMG X) (b' : P b),
    transport P (lambda b) (m' e' b') = b')
  (rho' : forall (a : FSMG X) (a' : P a),
    transport P (rho a) (m' a' e') = a')
  (tau' : forall (a b : FSMG X) (a' : P a) (b' : P b),
    transport P (tau a b) (m' a' b') = m' b' a')
  (T' : forall (w : FSMG X), IsTrunc 0 (P w))
  : forall w : FSMG X, P w.
Proof.
  refine (FSMG_ind P e' iota' (@m') alpha' lambda' rho' tau' _ _ _ _ _);
  intros; apply T'.
Defined.

Definition FSMG_ind_to_prop
  (T' : forall (w : FSMG X), IsTrunc (-1) (P w))
  : forall w : FSMG X, P w.
Proof.
  refine (FSMG_ind_to_set _ _ _ _ _);
    intros; apply T'.
Defined.

End FSMG_ind_trunc.

Section FSMG_ind_paths.

Definition FSMG_ind_to_paths_in_gpd
  (P : Type)
  (f f' : FSMG X -> P)
  (e' : f e = f' e)
  (iota' : forall x : X, f (iota x) = f' (iota x))
  (m' : forall a b : FSMG X, f a = f' a -> f b = f' b -> f (m a b) = f' (m a b))
  (alpha' : forall (a b c : FSMG X) (a' : f a = f' a) (b' : f b = f' b) (c' : f c = f' c),
    m' (m a b) c (m' a b a' b') c' @ ap f' (alpha a b c)
    = ap f (alpha a b c) @ m' a (m b c) a' (m' b c b' c'))
  (lambda' : forall (b : FSMG X) (b' : f b = f' b),
     m' e b e' b' @ ap f' (lambda b) = ap f (lambda b) @ b')
  (rho' : forall (a : FSMG X) (a' : f a = f' a),
    m' a e a' e' @ ap f' (rho a) = ap f (rho a) @ a')
  (tau' : forall (a b : FSMG X) (a' : f a = f' a) (b' : f b = f' b),
    m' a b a' b' @ ap f' (tau a b) = ap f (tau a b) @ m' b a b' a')
  (T' : IsTrunc 1 P)
  : forall w : FSMG X, f w = f' w.
Proof.
  srapply (@FSMG_ind_to_set (fun w => f w = f' w) e' iota' m');
  intros; simpl;
  refine (transport_paths_FlFr _ _ @ _);
  refine (concat_pp_p _ _ _ @ _); apply moveR_Vp.
  + apply alpha'.
  + apply lambda'.
  + apply rho'.
  + apply tau'.
Defined.

Definition FSMG_ind_to_paths_in_set
  (P : Type)
  (f f' : FSMG X -> P)
  (e' : f e = f' e)
  (iota' : forall x : X, f (iota x) = f' (iota x))
  (m' : forall a b : FSMG X, f a = f' a -> f b = f' b -> f (m a b) = f' (m a b))
  (T' : IsTrunc 0 P)
  : forall w : FSMG X, f w = f' w.
Proof.
  srapply (@FSMG_ind_to_prop (fun w => f w = f' w) e' iota' m').
Defined.

Definition FSMG_ind_to_2paths_in_gpd
  (P : Type)
  (f f' : FSMG X -> P)
  (p p' : forall a : FSMG X, f a = f' a)
  (e' : p e = p' e)
  (iota' : forall x : X, p (iota x) = p' (iota x))
  (m' : forall a b : FSMG X, p a = p' a -> p b = p' b -> p (m a b) = p' (m a b))
  (T' : IsTrunc 1 P)
  : forall w : FSMG X, p w = p' w.
Proof.
  srapply (@FSMG_ind_to_prop (fun w => p w = p' w) e' iota' m').
Defined.

Definition FSMG_ind_to_fam_paths_in_gpd
  `{Funext}
  (B C : Type)
  (f f' : FSMG X -> B -> C)
  (e' : forall (b : B), f e b = f' e b)
  (iota' : forall (x : X) (b : B), f (iota x) b = f' (iota x) b)
  (m' : forall (a b : FSMG X)
    (a' : forall c : B, f a c = f' a c)
    (b' : forall c : B, f b c = f' b c)
    (q : B),
    f (m a b) q = f' (m a b) q)
  (alpha' : forall (a b c : FSMG X)
    (a' : forall z : B, f a z = f' a z)
    (b' : forall z : B, f b z = f' b z)
    (c' : forall z : B, f c z = f' c z)
    (q : B),
    m' (m a b) c (m' a b a' b') c' q @ ap (fun z : FSMG X => f' z q) (alpha a b c)
    = ap (fun z : FSMG X => f z q) (alpha a b c) @ m' a (m b c) a' (m' b c b' c') q)
  (lambda' : forall (b : FSMG X)
    (b' : forall z : B, f b z = f' b z)
    (q : B),
    m' e b e' b' q @ ap (fun a : FSMG X => f' a q) (lambda b)
    = ap (fun a : FSMG X => f a q) (lambda b) @ b' q)
  (rho' : forall (a : FSMG X)
    (a' : forall z : B, f a z = f' a z)
    (q : B),
    m' a e a' e' q @ ap (fun a0 : FSMG X => f' a0 q) (rho a)
    = ap (fun a0 : FSMG X => f a0 q) (rho a) @ a' q)
  (tau' : forall (a b : FSMG X)
    (a' : forall z : B, f a z = f' a z)
    (b' : forall z : B, f b z = f' b z)
    (q : B),
    m' a b a' b' q @ ap (fun a0 : FSMG X => f' a0 q) (tau a b)
    = ap (fun a0 : FSMG X => f a0 q) (tau a b) @ m' b a b' a' q)
  (T' : IsTrunc 1 C)
  : forall (a : FSMG X) (b : B), f a b = f' a b.
Proof.
  srefine (@FSMG_ind_to_set (fun a => forall b : B, f a b = f' a b) e' iota' m' _ _ _ _ _);
  simpl; intros;
  apply path_forall; intro q;
  refine (transport_forall' f f' _ _ _ @ _); apply moveR_Vp.
  + apply alpha'.
  + apply lambda'.
  + apply rho'.
  + apply tau'.
Defined.

End FSMG_ind_paths.

Section FSMG_rec.

Context
  (A : Type)
  (e' : A)
  (iota' : X -> A)
  (m' : A -> A -> A)
  (alpha' : @IsAssociative A m')
  (lambda' : @IsLeftUnital A e' m')
  (rho' : @IsRightUnital A e' m')
  (tau' : @IsSymmetric A m')
  (pentagon' : IsPentagonCoherent m' alpha')
  (triangle' : IsTriangleCoherent e' m' alpha' lambda' rho')
  (hexagon' : IsHexagonCoherent m' alpha' tau')
  (bigon' : IsBigonCoherent m' tau')
  (T' : IsTrunc 1 A).

Lemma mm'_transport_const
  {a1 a2 b1 b2 : FSMG X} (p : a1 = a2) (q : b1 = b2)
  {a1' a2' b1' b2' : A}
  (p' : a1' = a2') (q' : b1' = b2')
  : mm' (fun _ => A) (fun _ => fun _ => m') (transport_const p a1' @ p') (transport_const q b1' @ q')
    = transport_const (mm p q) (m' a1' b1') @ ap011 m' p' q'.
Proof.
  induction p, q, p', q'; constructor.
Defined.

Definition FSMG_rec_pentagon
  : forall (a b c d : FSMG X) (a' b' c' d' : A),
    concat_D
      (transport_const (alpha (m a b) c d) (m' (m' (m' a' b') c') d') @ alpha' (m' a' b') c' d')
      (transport_const (alpha a b (m c d)) (m' (m' a' b') (m' c' d')) @ alpha' a' b' (m' c' d'))
    = ap (fun z : m (m (m a b) c) d = m a (m b (m c d)) => transport (fun _ : FSMG X => A) z (m' (m' (m' a' b') c') d')) (pentagon a b c d)
      @ concat_D
          (concat_D
            (mm' (fun _ : FSMG X => A) (fun _ _ : FSMG X => m') (transport_const (alpha a b c) (m' (m' a' b') c') @ alpha' a' b' c') (transport_1 (fun _ : FSMG X => A) d'))
            (transport_const (alpha a (m b c) d) (m' (m' a' (m' b' c')) d') @ alpha' a' (m' b' c') d'))
        (mm' (fun _ : FSMG X => A) (fun _ _ : FSMG X => m') (transport_1 (fun _ : FSMG X => A) a') (transport_const (alpha b c d) (m' (m' b' c') d') @ alpha' b' c' d')).
Proof.
  intros.
  rewrite transport_1_const, transport_1_const,
    mm'_transport_const, mm'_transport_const,
    concat_D_const_p, concat_D_const_p, concat_D_const_p.
  refine (whiskerL _ (pentagon' a' b' c' d') @ _).
  refine (_ @ concat_pp_p _ _ _); apply whiskerR.
  exact (transport_const_pq _ _)^.
Defined.

Definition FSMG_rec_triangle
  : forall (a b : FSMG X) (a' b' : A),
    concat_D
      (transport_const (alpha a e b) (m' (m' a' e') b') @ alpha' a' e' b')
      (mm' (fun _ : FSMG X => A) (fun _ _ : FSMG X => m') (transport_1 (fun _ : FSMG X => A) a') (transport_const (lambda b) (m' e' b') @ lambda' b'))
    = ap (fun z : m (m a e) b = m a b => transport (fun _ : FSMG X => A) z (m' (m' a' e') b')) (triangle a b)
      @ mm' (fun _ : FSMG X => A) (fun _ _ : FSMG X => m') (transport_const (rho a) (m' a' e') @ rho' a') (transport_1 (fun _ : FSMG X => A) b').
Proof.
  intros.
  rewrite transport_1_const, transport_1_const,
    mm'_transport_const, mm'_transport_const,
    concat_D_const_p.
  refine (whiskerL _ (triangle' a' b') @ _).
  refine (_ @ concat_pp_p _ _ _); apply whiskerR.
  exact (transport_const_pq _ _)^.
Defined.

Definition FSMG_rec_hexagon
  : forall (a b c : FSMG X) (a' b' c' : A),
    concat_D
      (concat_D
        (transport_const (alpha a b c) (m' (m' a' b') c') @ alpha' a' b' c')
        (transport_const (tau a (m b c)) (m' a' (m' b' c')) @ tau' a' (m' b' c')))
      (transport_const (alpha b c a) (m' (m' b' c') a') @ alpha' b' c' a')
    = ap (fun z : m (m a b) c = m b (m c a) => transport (fun _ : FSMG X => A) z (m' (m' a' b') c'))
  (hexagon a b c)
  @ concat_D
      (concat_D
        (mm' (fun _ : FSMG X => A) (fun _ _ : FSMG X => m')
          (transport_const (tau a b) (m' a' b') @ tau' a' b')
          (transport_1 (fun _ : FSMG X => A) c'))
        (transport_const (alpha b a c) (m' (m' b' a') c') @ alpha' b' a' c'))
      (mm' (fun _ : FSMG X => A) (fun _ _ : FSMG X => m')
        (transport_1 (fun _ : FSMG X => A) b')
        (transport_const (tau a c) (m' a' c') @ tau' a' c')).
Proof.
  intros.
  rewrite transport_1_const, transport_1_const,
    mm'_transport_const, mm'_transport_const,
    concat_D_const_p, concat_D_const_p, concat_D_const_p, concat_D_const_p.
  refine (whiskerL _ (hexagon' a' b' c') @ _).
  refine (_ @ concat_pp_p _ _ _); apply whiskerR.
  exact (transport_const_pq _ _)^.
Defined.

Definition FSMG_rec_bigon
  : forall (a b : FSMG X) (a' b' : A),
    concat_D
      (transport_const (tau a b) (m' a' b') @ tau' a' b')
      (transport_const (tau b a) (m' b' a') @ tau' b' a')
    = ap (fun z : m a b = m a b => transport (fun _ : FSMG X => A) z (m' a' b')) (bigon a b).
Proof.
  intros.
  rewrite concat_D_const_p.
  refine (whiskerL _ (bigon' a' b') @ concat_p1 _ @ _).
  srefine ((transport_const_pq (bigon a b) _)^ @ _); simpl.
  exact (concat_p1 _).
Defined.

Definition FSMG_rec
  : FSMG X -> A.
Proof.
  srapply (@FSMG_ind (fun _ => A) e' iota' (fun _ => fun _ => m')); hnf.
  + intros. exact (transport_const _ _ @ alpha' a' b' c').
  + intros. exact (transport_const _ _ @ lambda' b').
  + intros. exact (transport_const _ _ @ rho' a').
  + intros. exact (transport_const _ _ @ tau' a' b').
  + hnf. exact FSMG_rec_pentagon.
  + hnf. exact FSMG_rec_triangle.
  + hnf. exact FSMG_rec_hexagon.
  + hnf. exact FSMG_rec_bigon.
Defined.

Definition FSMG_rec_beta_alpha
  : forall a b c : FSMG X,
    ap FSMG_rec (alpha a b c) = alpha' (FSMG_rec a) (FSMG_rec b) (FSMG_rec c).
Proof.
  intros.
  eapply (cancelL (transport_const (alpha a b c) _)).
  refine ((apD_const _ (alpha a b c))^ @ _).
  srapply (@FSMG_ind_beta_alpha _ _ iota' _ _ _ _ _ FSMG_rec_pentagon FSMG_rec_triangle FSMG_rec_hexagon FSMG_rec_bigon _ a b c).
Defined.

Definition FSMG_rec_beta_lambda
  : forall b : FSMG X,
    ap FSMG_rec (lambda b) = lambda' (FSMG_rec b).
Proof.
  intros.
  eapply (cancelL (transport_const (lambda b) _)).
  refine ((apD_const _ (lambda b))^ @ _).
  srapply @FSMG_ind_beta_lambda.
Defined.

Definition FSMG_rec_beta_rho
  : forall a : FSMG X,
    ap FSMG_rec (rho a) = rho' (FSMG_rec a).
Proof.
  intros.
  eapply (cancelL (transport_const (rho a) _)).
  refine ((apD_const _ (rho a))^ @ _).
  srapply @FSMG_ind_beta_rho.
Defined.

Definition FSMG_rec_beta_tau
  : forall a b : FSMG X,
    ap FSMG_rec (tau a b) = tau' (FSMG_rec a) (FSMG_rec b).
Proof.
  intros.
  eapply (cancelL (transport_const (tau a b) _)).
  refine ((apD_const _ (tau a b))^ @ _).
  srapply @FSMG_ind_beta_tau.
Defined.

End FSMG_rec.

Section FSMG_rec_trunc.

Lemma FSMG_rec_to_set
  (A : Type)
  (e' : A)
  (iota' : X -> A)
  (m' : A -> A -> A)
  (alpha' : @IsAssociative A m')
  (lambda' : @IsLeftUnital A e' m')
  (rho' : @IsRightUnital A e' m')
  (tau' : @IsSymmetric A m')
  (T' : IsTrunc 0 A)
  : FSMG X -> A.
Proof.
  refine (@FSMG_rec A e' iota' m' alpha' lambda' rho' tau' _ _ _ _ _);
  [unfold IsPentagonCoherent | unfold IsTriangleCoherent | unfold IsHexagonCoherent | unfold IsBigonCoherent];
  intros; apply T'.
Defined.

Lemma FSMG_rec_to_prop
  (A : Type)
  (e' : A)
  (iota' : X -> A)
  (m' : A -> A -> A)
  (T' : IsTrunc (-1) A)
  : FSMG X -> A.
Proof.
  srapply (@FSMG_rec_to_set A e' iota' m');
  [unfold IsAssociative | unfold IsLeftUnital | unfold IsRightUnital | unfold IsSymmetric];
  intros; apply T'.
Defined.

End FSMG_rec_trunc.

End FSMG.

Arguments mm {X} {_} {_} {_} {_} p q.

Arguments alpha {X} _ _ _.
Arguments lambda {X} _.
Arguments rho {X} _.
Arguments tau {X} _ _.
Arguments pentagon {X} _ _ _ _.
Arguments triangle {X} _ _.
Arguments hexagon {X} _ _ _.
Arguments bigon {X} _ _.
Arguments T_FSMG {X} _ _ _ _ _ _.

Definition FSMG_SMG (X : Type) {T_X : IsHSet X} : SymMonoidalGroupoid
  := Build_SymMonoidalGroupoid (FSMG X) T_FSMG e m alpha lambda rho tau pentagon triangle hexagon bigon.

Section Redefinitions.

Context {X : Type} {T_X : IsHSet X}.

Definition alpha_FSMG_natural {a b c a' b' c' : FSMG X} (pa : a = a') (pb : b = b') (pc : c = c')
  := @alpha_natural (FSMG_SMG X) a b c a' b' c' pa pb pc.

Definition lambda_FSMG_natural {b b' : FSMG X} (pb : b = b')
  := @lambda_natural (FSMG_SMG X) b b' pb.

Definition rho_FSMG_natural {a a' : FSMG X} (pa : a = a')
  := @rho_natural (FSMG_SMG X) a a' pa.

Definition tau_FSMG_natural {a a' b b' : FSMG X} (pa : a = a') (pb : b = b')
  := @tau_natural (FSMG_SMG X) a a' b b' pa pb.

Definition rho_FSMG_a_e (a : FSMG X)
  := @rho_a_e (FSMG_SMG X) a.

Definition lambda_FSMG_e_b (b : FSMG X)
  := @lambda_e_b (FSMG_SMG X) b.

Definition alpha_lambda_FSMG (a b : FSMG X)
  := @alpha_lambda (FSMG_SMG X) a b.

Definition alpha_rho_FSMG (a b : FSMG X)
  := @alpha_rho (FSMG_SMG X) a b.

Definition lambda_rho_FSMG_e
  := @lambda_rho_e (FSMG_SMG X).

Definition tau_lambda_rho_FSMG (a : FSMG X)
  := @tau_lambda_rho (FSMG_SMG X) a.

Definition tau_rho_lambda_FSMG (a : FSMG X)
  := @tau_rho_lambda (FSMG_SMG X) a.

Definition bigon_var_FSMG (a b : FSMG X)
  := @bigon_var (FSMG_SMG X) a b.

Definition hexagon_var_FSMG (a b c : FSMG X)
  := @ hexagon_var (FSMG_SMG X) a b c.

End Redefinitions.


Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Coq.Arith.Peano_dec.
Require Import HJ.Finish.Lang.
Require Import HJ.Tid.
Require Import HJ.Fid.
Require Import Coq.Arith.EqNat.

Import ListNotations.

Module Queue.
  Section Defs.
  Variable A:Type.
  Variable time: A -> nat.

  Definition t := (nat * list A) % type.

  Definition make : t := (0, @nil A).

  Definition curr (e:t) : nat := fst e.

  Definition elements (e:t) := snd e.

  Let empty n : t := (n, @nil A).

  Definition add p (e:t) : t := let (x, y) := e in (x, p :: y).

  (** Increments the current time of the queue. *)
  Let inc (e:t) : t := let (x, y) := e in (S x, y).

  Let step (n:nat) (elems:list A) :=
  let (l, r) :=
    partition (fun p => beq_nat n (time p)) elems
  in
  (l, (if beq_nat (length l) 0 then n else (S n), r)).

  Lemma partition_length:
    forall {A : Type} (f : A -> bool) (l : list A),
    length (fst (partition f l)) + length (snd (partition f l)) = length l.
  Proof.
    induction l. {
      simpl.
      trivial.
    }
    simpl.
    remember (f a).
    symmetry in Heqb.
    remember (partition f l).
    destruct p as (x, y).
    destruct b; simpl in *;
    auto with *.
  Qed.

  Let step_length:
    forall e l r n,
    step n e = (l, r) ->
    length l + length (snd r) = length e.
  Proof.
    induction e; intros; unfold step in *; simpl in *;
    inversion H; subst; clear H.
    - simpl.
      trivial.
    - remember (partition _ _).
      remember (length e) as z.
      symmetry in Heqz.
      rewrite <- partition_length with (f:=fun p : A => PeanoNat.Nat.eqb n (time p)) in Heqz.
      rewrite <- Heqp in *.
      remember (PeanoNat.Nat.eqb n _).
      symmetry in Heqb.
      destruct b. {
        rewrite PeanoNat.Nat.eqb_eq in *.
        rewrite Heqb in *; clear Heqb.
        destruct p as (a1, b1).
        remember (PeanoNat.Nat.eqb _ _).
        symmetry in Heqb.
        destruct b. {
          rewrite PeanoNat.Nat.eqb_eq in *.
          simpl in *.
          inversion Heqb.
        }
        rewrite PeanoNat.Nat.eqb_neq in *.
        inversion H1; subst; clear H1.
        simpl.
        trivial.
      }
      rewrite PeanoNat.Nat.eqb_neq in *.
      destruct p as (a1, b1).
      remember (PeanoNat.Nat.eqb _ _).
      symmetry in Heqb0.
      destruct b. {
        rewrite PeanoNat.Nat.eqb_eq in *.
        inversion H1; subst; clear H1.
        simpl.
        rewrite Heqb0.
        simpl.
        trivial.
      }
      inversion H1; subst; clear H1.
      rewrite PeanoNat.Nat.eqb_neq in *.
      simpl.
      auto with *.
  Qed.

  Function poll (n:nat) (elems: list A) {measure length elems} :=
  let (l1, e1) := step n elems in
  match l1 with
  | nil => (l1, e1)
  | _ =>
    let (l2, e2) := poll (fst e1) (snd e1) in
    (l1 ++ l2, e2)
  end.
  Proof.
    intros.
    apply step_length in teq.
    rewrite <- teq.
    simpl.
    auto with *.
  Defined.
  End Defs.

  Goal @poll _ (fun (x:nat) => x) 0 [1; 0; 3; 2] = ([0; 1; 2; 3], (4, [])).
  Proof.
    compute.
    trivial.
  Qed.
End Queue.

Section Defs.

  Inductive package_op :=
  | PKG_INIT
  | PKG_BEGIN_FINISH
  | PKG_END_FINISH
  | PKG_BEGIN_TASK
  | PKG_END_TASK.

  Definition nat_to_op (o:nat) :=
  match o with
  | 0 => Some PKG_INIT
  | 1 => Some PKG_BEGIN_FINISH
  | 2 => Some PKG_END_FINISH
  | 3 => Some PKG_BEGIN_TASK
  | 4 => Some PKG_END_TASK
  | _ => None
  end.

  Definition op_to_nat o :=
  match o with
  | PKG_INIT => 0
  | PKG_BEGIN_FINISH => 1
  | PKG_END_FINISH => 2
  | PKG_BEGIN_TASK => 3
  | PKG_END_TASK => 4
  end.

  Lemma op_to_nat_spec_1:
    forall o,
    nat_to_op (op_to_nat o) = Some o.
  Proof.
    destruct o; auto.
  Qed.

  Lemma op_to_nat_spec_2:
    forall n o,
    nat_to_op n = Some o ->
    op_to_nat o = n.
  Proof.
    intros.
    repeat (destruct n; simpl in *; inversion H; subst; auto).
  Qed.

  Lemma op_to_nat_spec_3:
    forall n o,
    op_to_nat o = n ->
    nat_to_op n = Some o.
  Proof.
    intros.
    destruct o; simpl in *; subst; simpl; auto.
  Qed.

  Definition nat_to_args o (a:nat) :=
  match o with
  | PKG_INIT => []
  | PKG_BEGIN_FINISH => []
  | PKG_END_FINISH => []
  | PKG_BEGIN_TASK => [a]
  | PKG_END_TASK => []
  end.

  Inductive pkg_parse_err :=
  | PKG_PARSE_NOARGS_EXPECTED
  | PKG_PARSE_TASK_EXPECTED.

  Structure package := make {
    pkg_task : tid;
    pkg_op: package_op;
    pkg_id: fid;
    pkg_time: nat;
    pkg_args: list nat;
    pkg_lineno: option nat;
  }.

  Definition pkg_parse p :=
  match pkg_op p, pkg_args p with
  | PKG_INIT, [] => inl (INIT (pkg_id p))
  | PKG_BEGIN_FINISH, [] => inl (BEGIN_FINISH (pkg_id p))
  | PKG_END_FINISH, [] => inl END_FINISH
  | PKG_BEGIN_TASK, [x] => inl (BEGIN_TASK (taskid x))
  | PKG_END_TASK, [] => inl END_TASK
  | PKG_BEGIN_TASK, _ => inr PKG_PARSE_TASK_EXPECTED
  | _, _ => inr PKG_PARSE_NOARGS_EXPECTED
  end.

  (** Test cases that catch bugs we found: *)

  Goal forall p e,
    pkg_args p <> [] ->
    pkg_op p <> PKG_BEGIN_TASK ->
    pkg_parse p = inr e ->
    e = PKG_PARSE_NOARGS_EXPECTED.
  Proof.
    intros.
    unfold pkg_parse in *.
    destruct p, pkg_op0; simpl in *;
    destruct pkg_args0; try contradiction;
    inversion H1; subst; clear H1; trivial.
  Qed.

  Goal forall p e,
    length (pkg_args p) <> 1 ->
    pkg_op p = PKG_BEGIN_TASK ->
    pkg_parse p = inr e ->
    e = PKG_PARSE_TASK_EXPECTED.
  Proof.
    intros.
    unfold pkg_parse in *.
    destruct p, pkg_op0; simpl in *;
    destruct pkg_args0; inversion H0; clear H0;
    inversion H1; subst; clear H1; auto.
    destruct pkg_args0; inversion H2; subst; auto.
  Qed.

  Goal forall p n,
    pkg_args p = [n] ->
    pkg_op p = PKG_BEGIN_TASK ->
    pkg_parse p = inl (BEGIN_TASK (taskid n)).
  Proof.
    intros.
    unfold pkg_parse.
    rewrite H0.
    rewrite H.
    trivial.
  Qed.

  Goal forall p,
    pkg_args p = [] ->
    pkg_op p <> PKG_BEGIN_TASK ->
    exists o, pkg_parse p = inl o.
  Proof.
    intros.
    unfold pkg_parse.
    remember (pkg_op p).
    destruct p0; subst; rewrite H; eauto.
    contradiction.
  Qed.

  Definition pkg_create (x:tid) (p:fid*nat) (o:package_op) (l:list nat) :=
  {|
    pkg_task := x;
    pkg_op := o;
    pkg_id := (fst p);
    pkg_time := snd p;
    pkg_args := l;
    pkg_lineno := None
  |}.

  Inductive run_err :=
  | RUN_PKG_PARSE_ERROR: pkg_parse_err -> run_err
  | RUN_REDUCES_ERROR: reduces_err -> run_err.

  Definition run (s:state) (p:package) : (state + run_err) % type :=
  match pkg_parse p with
  | inl o =>
    match Lang.reduces s (pkg_task p) o with
    | inl s' => inl s'
    | inr e => inr (RUN_REDUCES_ERROR e)
    end
  | inr e => inr (RUN_PKG_PARSE_ERROR e)
  end.

  Definition add1 s n p :=
  if beq_nat n (pkg_time p)
  then (run s p, (S n, nil))
  else (inl s, (n, p::nil)).

  Inductive parse_trace_err :=
  PARSE_TRACE_ERR: nat -> pkg_parse_err -> parse_trace_err.

  Fixpoint parse_trace (l:list package) : (list action + parse_trace_err) :=
  match l with
  | [] => inl []
  | p::l =>
    match pkg_parse p, parse_trace l with
    | inl o, inl l => inl ((pkg_task p, o)::l)
    | _, inr e => inr e
    | inr e, _ => inr (PARSE_TRACE_ERR (length l) e)
    end
  end.

  Goal
    let l := [
      pkg_create (taskid 0) (finishid 1, 0) PKG_INIT [];
      pkg_create (taskid 0) (finishid 1, 1) PKG_BEGIN_TASK [1];
      pkg_create (taskid 1) (finishid 2, 0) PKG_BEGIN_FINISH [];
      pkg_create (taskid 1) (finishid 2, 1) PKG_BEGIN_TASK [2];
      pkg_create (taskid 2) (finishid 3, 0) PKG_BEGIN_FINISH [];
      pkg_create (taskid 2) (finishid 3, 1) PKG_BEGIN_TASK [5]
    ] in
    parse_trace l = inl [
      (taskid 0, INIT (finishid 1));
      (taskid 0, BEGIN_TASK (taskid 1));
      (taskid 1, BEGIN_FINISH (finishid 2));
      (taskid 1, BEGIN_TASK (taskid 2));
      (taskid 2, BEGIN_FINISH (finishid 3));
      (taskid 2, BEGIN_TASK (taskid 5))
    ].
  Proof.
   compute.
   trivial.
  Qed.

  Inductive reduces_n_err :=
  | REDUCES_N_ERROR: nat -> reduces_err -> reduces_n_err.

  Fixpoint reduces_n (s:state) (l:list action): (state + reduces_n_err) % type :=
  match l with
  | [] => inl s
  | a::l =>
    match reduces s (fst a) (snd a) with
    | inl s =>
      reduces_n s l
    | inr e => inr (REDUCES_N_ERROR (length l) e)
    end
  end.

  Goal
    let l := [
      (taskid 0, INIT (finishid 0));
      (taskid 0, INIT (finishid 1))
    ] in
    reduces_n (Map_TID.empty _) l = inr (REDUCES_N_ERROR 0 (TASK_EXIST (taskid 0))).
  Proof.
    intros.
    simpl.
    destruct (in_dec (finishid 0) (Map_TID.empty _)). {
      apply not_in_empty in i.
      contradiction.
    }
    remember (Map_TID.add _ _ _) as m.
    destruct (in_dec (finishid 1) m). {
      subst.
      inversion i. {
        inversion H; subst; clear H.
        apply Map_TID_Facts.add_mapsto_iff in H0.
        destruct H0 as [(?,Hx)|(?,?)]. {
          subst.
          inversion Hx; subst; clear Hx.
        }
        rewrite Map_TID_Facts.empty_mapsto_iff in *.
        contradiction.
      }
      inversion H; subst; clear H.
      inversion H1; subst; clear H1.
      rewrite Map_TID_Facts.add_mapsto_iff in *.
      destruct H as [(?,Hx)|(?,?)]. {
        subst.
        inversion Hx; subst; clear Hx.
        contradiction.
      }
      rewrite Map_TID_Facts.empty_mapsto_iff in *.
      contradiction.
    }
    subst.
    compute.
    trivial.
  Qed.

  Fixpoint get {A} (n:nat) (l:list A) {struct l} : option A :=
  match l with
  | x :: l =>
    if Nat.eqb n (length l) then Some x
    else (
      if Nat.ltb n (length l) then get n l
      else None
    )
  | _ => None
  end.

  Goal
    let l := [
      (taskid 2, INIT (finishid 2));
      (taskid 1, INIT (finishid 1));
      (taskid 0, INIT (finishid 0))
    ] in
    get 0 l = Some (taskid 0, INIT (finishid 0)) /\
    get 1 l = Some (taskid 1, INIT (finishid 1)) /\
    get 2 l = Some (taskid 2, INIT (finishid 2)).
  Proof.
    compute.
    intuition.
  Qed.

  (** Correctness check: *)
  Let reduces_n_length:
    forall l s n e,
    reduces_n s l = inr (REDUCES_N_ERROR n e) ->
    n < length l.
  Proof.
    induction l; intros. {
      simpl in *.
      inversion H.
    }
    simpl in *.
    remember (reduces _ _ _).
    symmetry in Heqs0.
    destruct s0. {
      apply IHl in H.
      auto.
    }
    inversion H; subst; clear H.
    auto.
  Qed.

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

  Let queue := Queue.t package.

  Structure buffer := {
    buffer_f_queue : Map_FID.t queue;
    buffer_t_queue: Map_TID.t (option (list package));
  }.

  Structure checks := {
    checks_buffer : buffer;
    checks_state : state;
  }.

  Inductive checks_err :=
  | CHECKS_REDUCES_N_ERROR: package -> reduces_err -> checks_err
  | CHECKS_TASK_EXISTS_ERROR: package -> tid -> checks_err
  | CHECKS_INTERNAL_ERROR
  | CHECKS_PARSE_TRACE_ERROR: package -> pkg_parse_err -> checks_err.

  (**
    Goal: we want to have a lexicographic order on (task-time, target-time).

    Idea:
    When adding a a package to the buffer, wrap the package in a pair:
      (number, package) where number is the timestamp of the owner task.

    When we are adding an init or a spawn, we initialize the task-queue
    to zero.

    After we poll from the finish queues, we enqueue the operations
    in the task queue.

    Finally, we poll the operations from each task queue.
    *)

  Let f_queue_add (p:package) (b:Map_FID.t queue) :
    (list package * Map_FID.t queue) :=
  let f := pkg_id p in
  let q := match Map_FID.find f b with
    | Some e => e
    | None => Queue.make _
    end
  in
  let e := Queue.add p q in
  let (l, e) := Queue.poll pkg_time (fst e) (snd e) in
  (l, Map_FID.add f e b).

  Goal
    let p := pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [] in
    f_queue_add p (Map_FID.empty _) = ([p], Map_FID.add (finishid 0) (1, []) (Map_FID.empty _)).
  Proof.
    auto.
  Qed.

  Goal
    let p := pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2] in
    let m := Map_FID.add (finishid 0) (1, []) (Map_FID.empty _) in
    f_queue_add p m = ([p], Map_FID.add (finishid 0) (2, []) m).
  Proof.
    auto.
  Qed.

  Goal
    let p := pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_FINISH [] in
    let m := Map_FID.add (finishid 0) (1, []) (Map_FID.empty _) in
    let m := Map_FID.add (finishid 0) (2, []) m in
    f_queue_add p m = ([], Map_FID.add (finishid 0) (2, [p]) m).
  Proof.
    unfold f_queue_add; simpl.
    auto.
  Qed.

  Goal
    let p1 := pkg_create (taskid 1) (finishid 0, 3) PKG_BEGIN_TASK [2] in
    let p2 := pkg_create (taskid 3) (finishid 1, 0) PKG_BEGIN_FINISH [] in
    let m := Map_FID.add (finishid 0) (1, []) (Map_FID.empty _) in
    let m := Map_FID.add (finishid 0) (2, []) m in
    let m := Map_FID.add (finishid 0) (2, [p1]) m in
    f_queue_add p2 m = ([p2], Map_FID.add (finishid 1) (1, []) m).
  Proof.
    unfold f_queue_add; simpl.
    auto.
  Qed.

  Goal
    let p1 := pkg_create (taskid 1) (finishid 0, 3) PKG_BEGIN_TASK [2] in
    let p2 := pkg_create (taskid 1) (finishid 0, 2) PKG_END_TASK [] in
    let m := Map_FID.add (finishid 0) (1, []) (Map_FID.empty _) in
    let m := Map_FID.add (finishid 0) (2, []) m in
    let m := Map_FID.add (finishid 0) (2, [p1]) m in
    let m := Map_FID.add (finishid 1) (1, []) m in
    f_queue_add p2 m = ([p2;p1], Map_FID.add (finishid 0) (4, []) m).
  Proof.
    unfold f_queue_add; simpl.
    auto.
  Qed.

  (** [t_poll] reorders timed packages and takes out the timestamp,
    leaving just the package. *)

  Let t_queue_add_1 (p:package) (m:Map_TID.t (option (list package))):=
  match pkg_parse p with
  | inl (INIT _) =>
    let x := pkg_task p in
    match Map_TID.find x m with
    | None => ([p], Map_TID.add x None m)
    | _ => ([p], m)
    end
  | inl (BEGIN_TASK x) =>
    let m' := Map_TID.add x None m in
    match Map_TID.find x m with
    | Some (Some l) => (p::l, m')
    | None => ([p], m')
    | Some None => ([p], m)
    end
  | inl _ =>
    let x := pkg_task p in
    match Map_TID.find x m with
    | Some (Some l) => ([], Map_TID.add x (Some (p::l)) m)
    | Some None => ([p], m)
    | None => ([], Map_TID.add x (Some [p]) m)
    end
  | inr e => ([p], m)
  end.

  Let t_queue_add (ps:list package) (m:Map_TID.t (option (list package))) :=
  List.fold_left (fun (r:list package * Map_TID.t (option (list package))) p =>
    let (l1, m) := r in
    let (l2, m) := t_queue_add_1 p m in
    (l1 ++ l2, m)
  ) ps ([], m).

  Goal
    let l := [
      pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [];
      pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2]
    ] in
    t_queue_add l (Map_TID.empty _) = (l, Map_TID.add (taskid 2) None
      (Map_TID.add (taskid 1) None (Map_TID.empty _))).
  Proof.
    simpl; auto.
  Qed.

  Goal
    let l := [
      pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [];
      pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2];
      pkg_create (taskid 3) (finishid 1, 0) PKG_BEGIN_FINISH [];
      pkg_create (taskid 1) (finishid 0, 2) PKG_END_TASK [];
      pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3]
    ] in
    fst (t_queue_add l (Map_TID.empty _)) = [
      pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [];
      pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2];
      pkg_create (taskid 1) (finishid 0, 2) PKG_END_TASK [];
      pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3];
      pkg_create (taskid 3) (finishid 1, 0) PKG_BEGIN_FINISH []
    ].
  Proof.
    auto.
  Qed.

  Let checks_try_run ps b s : (checks + checks_err) %type :=
  match parse_trace ps with
  | inl l =>
    match reduces_n s l with
    | inl s => inl {| checks_buffer := b; checks_state := s |}
    | inr (REDUCES_N_ERROR n e) =>
      match get n ps with
      | Some p => inr (CHECKS_REDUCES_N_ERROR p e)
      | None => inr CHECKS_INTERNAL_ERROR
      end
    end
  | inr (PARSE_TRACE_ERR n e) =>
    match get n ps with
    | Some p => inr (CHECKS_PARSE_TRACE_ERROR p e)
    | None => inr CHECKS_INTERNAL_ERROR
    end
  end.

  Definition buffer_add (p:package) b : (list package * buffer) :=
  let (ps, qf) := f_queue_add p (buffer_f_queue b) in
  let (ps, qt) := t_queue_add ps (buffer_t_queue b) in
  (ps,
      {| buffer_f_queue := qf;
         buffer_t_queue := qt
       |}).

  Definition buffer_make := {|
    buffer_f_queue := Map_FID.empty _;
    buffer_t_queue := Map_TID.empty _;
  |}.

  Definition checks_make := {|
    checks_buffer := buffer_make;
    checks_state := Map_TID.empty _
  |}.

  Definition checks_add (p:package) s : (checks + checks_err) %type :=
  let (ps, b) := buffer_add p (checks_buffer s) in
  checks_try_run ps b (checks_state s).

  Definition checks_running s : list tid :=
  Map_TID_Extra.keys (checks_state s).

  Let to_packages (l:list queue) :=
  List.flat_map_tr (@Queue.elements package) l.

  Definition checks_f_enqueued s : list package :=
  to_packages (Map_FID_Extra.values_tr (buffer_f_queue (checks_buffer s))).

  Definition checks_t_enqueued s : list package :=
  List.flat_map_tr (fun (x:option (list package))  => match x with
  | Some l => l
  | _ => []
  end) (Map_TID_Extra.values_tr (buffer_t_queue (checks_buffer s))).

  Definition checks_enqueued s : list package :=
  List.app_tr (checks_f_enqueued s) (checks_t_enqueued s).

  Definition checks_load (l:list package) : (checks + checks_err) % type :=
  let fix buffer_add_all l m :=
    match l with
    | [] => inl m
    | p::l =>
      match buffer_add_all l m with
      | inl m => checks_add p m
      | inr e => inr e
      end
    end
  in
  buffer_add_all l checks_make.

  Section TestFAdd.
(*
    Let clock_package_aux_1:
        clock_package (pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [])
         (buffer_next_tick buffer_make) = inl
         (0, Map_TID.add (taskid 1) 1 (Map_TID.empty nat)).
    Proof.
      auto.
    Qed.

    Let clock_package_aux_2:
      clock_package
         (pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2])
         (Map_TID.add (taskid 1) 1 (Map_TID.empty nat))
      = inl
      (1, Map_TID.add (taskid 2) 0
      (Map_TID.add (taskid 1) 2 (Map_TID.add (taskid 1) 1 (Map_TID.empty nat)))).
    Proof.
      unfold clock_package; simpl.
      auto.
    Qed.

    Let clock_package_aux_3:
      clock_package
         (pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3])
         (Map_TID.add (taskid 2) 0
            (Map_TID.add (taskid 1) 2
               (Map_TID.add (taskid 1) 1 (Map_TID.empty nat))))
      = inl
      (0,
      Map_TID.add (taskid 3) 0
      (Map_TID.add (taskid 2) 1
      (
        (Map_TID.add (taskid 2) 0
      (Map_TID.add (taskid 1) 2 (Map_TID.add (taskid 1) 1 (Map_TID.empty nat))))))).
    Proof.
      unfold clock_package; simpl; auto.
    Qed.

    Let f_queue_add_aux_1:
      f_queue_add [(0, pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [])]
         (buffer_f_queue buffer_make) =
       ([(0, pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [])],
       Map_FID.add (finishid 0) (1, []) (Map_FID.empty queue)).
    Proof.
      auto.
    Qed.

    Let f_queue_add_aux_2:
      f_queue_add
         [(1, pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2])]
         (Map_FID.add (finishid 0) (1, []) (Map_FID.empty queue)) =
      ([(1, pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2])],
       Map_FID.add (finishid 0) (2, [])
       (Map_FID.add (finishid 0) (1, []) (Map_FID.empty queue))).
    Proof.
      auto.
    Qed.

    Let f_queue_add_aux_3:
      f_queue_add
         [(0, pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3])]
         (Map_FID.add (finishid 0) (2, [])
            (Map_FID.add (finishid 0) (1, []) (Map_FID.empty queue))) =
      ([],
      Map_FID.add (finishid 0) (2, [(0, pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3])])
      (Map_FID.add (finishid 0) (2, [])
            (Map_FID.add (finishid 0) (1, []) (Map_FID.empty queue)))).
    Proof.
      unfold f_queue_add; simpl; auto.
    Qed.

    Let t_queue_add_aux_1:
      t_queue_add [(0, pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [])]
         (buffer_t_queue buffer_make) =
       ([(0, pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [])],
       Map_TID.add (taskid 1) (1, []) (Map_TID.empty queue)).
    Proof.
      auto.
    Qed.
(*
    Let t_queue_add_all_1:
      forall n p,
      t_queue_add_all [(n, p)]
              (buffer_t_queue buffer_make) =
      Map_TID.add (pkg_task p) (0, [(n, p)]) (Map_TID.empty queue).
    Proof.
      intros.
      unfold t_queue_add_all; simpl.
      unfold t_queue_add; simpl.
      trivial.
    Qed.
*)(*
    Goal
      let p :=
        pkg_create (taskid 0) (finishid 1, 0) PKG_INIT []
      in
      exists b, buffer_add p buffer_make = inl ([p], b).
    Proof.
      simpl.
      unfold buffer_add.
      rewrite clock_package_1.
      remember (f_queue_add _ _).
      unfold f_queue_add in Heqp.
      simpl in Heqp.
      rewrite f_queue_add_1.
      rewrite t_queue_add_all_1.
      remember (pkg_task _).
      simpl in Heqt; rewrite Heqt; clear Heqt.
      remember (t_poll_all _ ).
      compute in Heqp0.
      destruct p0 as (a,b).
      compute in Heqp0.
      inversion Heqp0; subst.
      eauto.
    Qed.
*)
    (** Unit-test add *)

    Let buffer_add_all :=
    let fix f ps (b:buffer) :=
      match ps with
      | [] => inl ([], b)
      | p::ps =>
        match buffer_add p b with
        | inl (ps1, b1) =>
          match f ps b1 with
          | inl (ps2, b2) => inl (ps1 ++ ps2, b2)
          | inr e => inr e
          end
        | inr e => inr e
        end
      end
    in
    f.

    Goal
      let l := [
        pkg_create (taskid 0) (finishid 1, 0) PKG_INIT []
      ] in
      exists b, buffer_add_all l buffer_make = inl (l, b).
    Proof.
      simpl.
      eauto.
    Qed.

    Goal
      exists m,
      clock_package
          (pkg_create (taskid 0) (finishid 1, 0) PKG_INIT [])
          (Map_TID.empty _)
      = inl (0, m) /\ Map_TID.MapsTo (taskid 0) 1 m.
    Proof.
      unfold clock_package.
      simpl.
      eauto using Map_TID.add_1.
    Qed.
(*
    Goal
      let l := [
        pkg_create (taskid 0) (finishid 1, 0) PKG_INIT [];
        pkg_create (taskid 0) (finishid 1, 1) PKG_BEGIN_TASK [1]
      ] in
      exists b, buffer_add_all l buffer_make = inl (l, b).
    Proof.
      unfold buffer_add_all.
      simpl.
      eauto.
    Qed.
*)
    Compute
      match buffer_add (pkg_create (taskid 1) (finishid 0, 0) PKG_INIT []) buffer_make
      with
      | inl l => l
      | _ => ([], buffer_make)
      end
    .

    Goal init_package (pkg_create (taskid 1) (finishid 0, 0) PKG_INIT []) (Map_TID.empty _)
    = inl (Map_TID.add (taskid 1) 0 (Map_TID.empty _)).
    Proof. auto. Qed.

    Compute
      let l := [
        pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [];
        pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2](*;
        pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3];
        pkg_create (taskid 3) (finishid 1, 0) PKG_BEGIN_FINISH []*)
        (*;
        ;
        pkg_create (taskid 1) (finishid 0, 2) PKG_END_TASK []*)
      ] in
      buffer_add_all l buffer_make
    .
*)
(*
    Ltac simpl_rw H :=
    simpl in H;
    rewrite H in *;
    clear H.

    Goal
      let l := [
        pkg_create (taskid 1) (finishid 0, 0) PKG_INIT [];
        pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2];
        pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3];
        pkg_create (taskid 3) (finishid 1, 0) PKG_BEGIN_FINISH [];
        pkg_create (taskid 1) (finishid 0, 2) PKG_END_TASK []
      ] in
      exists s,
      buffer_add_all l buffer_make = inl s /\ fst s = [
        pkg_create (taskid 1) (* 0 *) (finishid 0, 0) PKG_INIT [];
        pkg_create (taskid 1) (* 1 *) (finishid 0, 1) PKG_BEGIN_TASK [2];
        pkg_create (taskid 1) (* 2 *) (finishid 0, 2) PKG_END_TASK [];
        pkg_create (taskid 2) (* 0 *) (finishid 0, 3) PKG_BEGIN_TASK [3];
        pkg_create (taskid 3) (* 0 *) (finishid 1, 0) PKG_BEGIN_FINISH []
      ].
    Proof.
      intros.
      unfold buffer_add_all, buffer_add, l; clear l.
      rewrite clock_package_aux_1.
      rewrite f_queue_add_aux_1.
      rewrite t_queue_add_aux_1.
      (* PKG_BEGIN_TASK [2] *)
      (* clock *)
      remember (clock_package (pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2]) _).
      rewrite clock_package_aux_2 in Heqs; subst; clear Heqs.
      (* f *)
      remember (f_queue_add [(1, pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2])] _).
      simpl in Heqp; rewrite f_queue_add_aux_2 in Heqp; subst;
      clear Heqp.
      (* t *)
      remember (t_queue_add
           [(1, pkg_create (taskid 1) (finishid 0, 1) PKG_BEGIN_TASK [2])] _).
      simpl in Heqp.
      rewrite Heqp; clear Heqp p.
      (* PKG_BEGIN_TASK [3] *)
      remember (clock_package
            (pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3]) _).
      simpl in Heqs; rewrite clock_package_aux_3 in Heqs; subst;
      clear Heqs.
      (* f *)
      remember (f_queue_add
             [(0, pkg_create (taskid 2) (finishid 0, 3) PKG_BEGIN_TASK [3])] _).
      simpl in Heqp.
      rewrite f_queue_add_aux_3 in Heqp.
      subst; clear Heqp.
      (* t *)
      remember (t_queue_add [] (buffer_t_queue _)).
      simpl in Heqp; subst.
      (*
    Qed.
*)
(*
    Goal
      let l1 := [
        (10, pkg_create (taskid 0) (finishid 1, 1) PKG_BEGIN_TASK [1])
      ] in
      let l2 := [
        (20, pkg_create (taskid 0) (finishid 1, 0) PKG_INIT [])
      ] in
      let l3 := [
        (20, pkg_create (taskid 0) (finishid 1, 0) PKG_INIT []);
        (10, pkg_create (taskid 0) (finishid 1, 1) PKG_BEGIN_TASK [1])
      ] in
      let m := Map_FID.add (finishid 1) (0, l1) (Map_FID.empty _) in
      buffer_add_all l2 m = (l3, Map_FID.add (finishid 1) (2, []) m).
    Proof.
      intros.
      compute.
      trivial.
    Qed.

    Goal
      let l := [
        (10, pkg_create (taskid 0) (finishid 1, 1) PKG_BEGIN_TASK [1]);
        (20, pkg_create (taskid 0) (finishid 1, 0) PKG_INIT [])
      ] in
      let (l', b) := buffer_add_all l (Map_FID.empty _) in
      l' = l /\ Map_FID.MapsTo (finishid 1) (2, []) b.
    Proof.
      simpl; split; auto using Map_FID.add_1.
    Qed.

    (** Regression test: *)
    Goal
      let foo := [
        (10, pkg_create (taskid 0) (finishid 1, 0) PKG_INIT []);
        (11, pkg_create (taskid 0) (finishid 1, 1) PKG_BEGIN_TASK [1]);
        (12, pkg_create (taskid 1) (finishid 2, 0) PKG_BEGIN_FINISH []);
        (13, pkg_create (taskid 1) (finishid 2, 1) PKG_BEGIN_TASK [2]);
        (14, pkg_create (taskid 2) (finishid 3, 0) PKG_BEGIN_FINISH []);
        (15, pkg_create (taskid 2) (finishid 3, 1) PKG_BEGIN_TASK [5])
      ] in
      fst (buffer_add_all foo (Map_FID.empty _)) = foo.
    Proof.
     compute.
     trivial.
    Qed.

    (** Regression test: *)
    Goal
      let foo := [
        (10, pkg_create (taskid 0) (finishid 0, 0) PKG_INIT []);
        (11, pkg_create (taskid 0) (finishid 1, 0) PKG_BEGIN_FINISH [])
      ] in
      fst (buffer_add_all foo (Map_FID.empty _)) = foo.
    Proof.
     compute.
     trivial.
    Qed.
    *)
    *)
  End TestFAdd.
End Defs.

(* bools *)
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inlined Constant negb => "not".

Extract Inductive sumbool => "bool" [ "true" "false" ].

Extract Inductive sumor => "option" [ "Some" "None" ].

Extract Inductive option => "option" [ "Some" "None" ].

(* list *)
Extract Inductive list => "list" [ "[]" "(::)" ].
Extract Inlined Constant length => "List.length".
Extract Inlined Constant app => "List.append".
Extract Inlined Constant map => "List.map".
Extract Inlined Constant List.rev => "List.rev".
Extract Inlined Constant List.partition => "List.partition".
Extract Inlined Constant List.filter => "List.filter".

(* pairs *)
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inlined Constant fst => "fst".
Extract Inlined Constant snd => "snd".

(* nat *)
Extract Inductive nat => int [ "0" "Pervasives.succ" ]
 "(fun fO fS n -> if n=0 then fO () else fS (n-1))".

Extract Constant plus => "(+)".
Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)".
Extract Constant minus => "fun n m -> Pervasives.max 0 (n-m)".
Extract Constant mult => "( * )".
Extract Inlined Constant max => "Pervasives.max".
Extract Inlined Constant min => "Pervasives.min".
(*Extract Inlined Constant nat_beq => "(=)".*)
Extract Inlined Constant EqNat.beq_nat => "(=)".
Extract Inlined Constant EqNat.eq_nat_decide => "(=)".

Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)".
Extract Inlined Constant PeanoNat.Nat.eqb => "( = )".

Extract Constant PeanoNat.Nat.compare =>
 "fun n m -> if n=m then Eq else if n<m then Lt else Gt".
Extract Inlined Constant Compare_dec.leb => "(<=)".
Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)".
Extract Inlined Constant Compare_dec.lt_dec => "(<)".
Extract Constant Compare_dec.lt_eq_lt_dec => "fun n m -> if n>m then None else Some (n<m)".

Extraction Language OCaml.

Extraction "libhsem/src/finish"
  checks_add checks_make checks_load checks_enqueued checks_t_enqueued
  checks_f_enqueued checks_running nat_to_op nat_to_args op_to_nat.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frédéric Blanqui, 2014-02-18

This file provides a translation into classes of the module types and
functors defined in RelExtras. *)

Set Implicit Arguments.

Require Import LogicUtil EqUtil Relations Setoid Structures.Equalities
  Morphisms Basics.
Require Export RelExtras.

(** Setoids. *)
(* Remark: this is a module type Eqset. *)

Class Setoid := {
  s_typ :> Type;
  s_eq : relation s_typ;
  s_eq_Equiv : Equivalence s_eq }.

(* Remake: this is a module type of Eqset_dec. The declare module export Eq is
: Setoit type.*)

Instance Leibniz_Setoid (A : Type) : Setoid.

Proof.
  apply Build_Setoid with (s_eq := @eq A). constructor. fo. fo.
  unfold Transitive. apply eq_trans.
Defined.

(** Setoids with decidable equivalence. *)
(* Remark: This is a module type Eqset_def <: Eqset is translated to
the first field Setoid. *)

Class Decidable_Setoid := {
  ds_setoid :> Setoid;
  ds_eq_dec : forall x y, {s_eq x y} + {~s_eq x y} }.

(** Ordered setoids. *)

(* Remark: all the add Setoid can be replace by Proper. This is a
module type Ord. *)

Class Ordered_Setoid := {
  os_setoid :> Setoid;
  os_gt : relation s_typ;
  os_gt_compat : Proper (s_eq ==> s_eq ==> impl) os_gt }.

(* Remark: this is a funtor nat_ord taking Ord as type. *)

Instance Nat_as_Ordered_Setoid : Ordered_Setoid.

Proof.
  apply Build_Ordered_Setoid with (os_setoid := Leibniz_Setoid nat)
                                  (os_gt := gt).
  simpl. intros x x' xx' y y' yy' xy. omega.
Defined.


From Equations Require Import Equations.

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.

Require Export SystemFR.ErasedLet.
Require Export SystemFR.RedTactics.

Opaque reducible_values.
Opaque makeFresh.

Lemma reducible_intersection:
  forall ρ e T1 T2,
    valid_interpretation ρ ->
    [ ρ ⊨ e : T1 ] ->
    [ ρ ⊨ e : T2 ] ->
    [ ρ ⊨ e : T_intersection T1 T2 ].
Proof.
  unfold reduces_to;
    repeat step || t_deterministic_star.
  exists v0; repeat step || simp_red; t_closer.
Qed.

Lemma reducible_union:
  forall ρ e T1 T2,
    valid_interpretation ρ ->
    ([ ρ ⊨ e : T1 ] \/ [ ρ ⊨ e : T2 ]) ->
    [ ρ ⊨ e : T_union T1 T2 ].
Proof.
  unfold reduces_to;
    repeat step || t_deterministic_star;
  try solve [ exists v; repeat step || simp_red; t_closer ].
Qed.

Lemma open_reducible_intersection:
  forall Θ Γ e T1 T2,
    [ Θ; Γ ⊨ e : T1 ] ->
    [ Θ; Γ ⊨ e : T2 ] ->
    [ Θ; Γ ⊨ e : T_intersection T1 T2 ].
Proof.
  unfold open_reducible; repeat step || apply reducible_intersection.
Qed.

Lemma open_reducible_union_elim:
  forall Θ (Γ : context) t t' T1 T2 T z,
    subset (fv t') (support Γ) ->
    subset (fv T1) (support Γ) ->
    subset (fv T2) (support Γ) ->
    subset (fv T) (support Γ) ->
    wf t' 1 ->
    wf T1 0 ->
    wf T2 0 ->
    wf T 0 ->
    ~(z ∈ fv_context Γ) ->
    ~(z ∈ fv t') ->
    ~(z ∈ fv T) ->
    ~(z ∈ fv T1) ->
    ~(z ∈ fv T2) ->
    is_erased_term t' ->
    is_erased_type T ->
    [ Θ; Γ ⊨ t : T_union T1 T2 ] ->
    [ Θ; (z, T1) :: Γ ⊨ open 0 t' (fvar z term_var) : T ] ->
    [ Θ; (z, T2) :: Γ ⊨ open 0 t' (fvar z term_var) :  T ] ->
    [ Θ; Γ ⊨ app (notype_lambda t') t : T ].
Proof.
  unfold open_reducible; repeat step || t_instantiate_sat3 || top_level_unfold reduces_to || simp_red.

  - unshelve epose proof (H15 ρ ((z, v) :: lterms) _ _ _);
      repeat step || list_utils || apply SatCons || t_values_info2 || t_deterministic_star || t_substitutions ||
             apply reducible_let2 with (psubstitute (T_union T1 T2) lterms term_var);
      eauto with erased; eauto with fv; eauto with wf; eauto with twf.

  - unshelve epose proof (H16 ρ ((z, v) :: lterms) _ _ _);
      repeat step || list_utils || apply SatCons || t_values_info2 || t_deterministic_star || t_substitutions ||
             apply reducible_let2 with (psubstitute (T_union T1 T2) lterms term_var);
      eauto with erased; eauto with fv; eauto with wf; eauto with twf.
Qed.