(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

(** Lemmas and tactics for working with and solving goals related to
    non-membership in finite sets.  The main tactic of interest here
    is [solve_notin].

    Implicit arguments are declared by default in this library. *)

Require Import Coq.FSets.FSetInterface.

Require Import CoqFSetDecide.

(* *********************************************************************** *)
(** * Implementation *)

Module Notin_fun
  (E : DecidableType) (Import X : FSetInterface.WSfun E).

Module Import D := CoqFSetDecide.WDecide_fun E X.

(* *********************************************************************** *)
(** * Facts about set non-membership *)

Section Lemmas.

Variables x y  : elt.
Variable  s s' : X.t.

Lemma notin_empty_1 :
  ~ In x empty.
Proof. fsetdec. Qed.

Lemma notin_add_1 :
  ~ In y (add x s) ->
  ~ E.eq x y.
Proof. fsetdec. Qed.

Lemma notin_add_1' :
  ~ In y (add x s) ->
  x <> y.
Proof. fsetdec. Qed.

Lemma notin_add_2 :
  ~ In y (add x s) ->
  ~ In y s.
Proof. fsetdec. Qed.

Lemma notin_add_3 :
  ~ E.eq x y ->
  ~ In y s ->
  ~ In y (add x s).
Proof. fsetdec. Qed.

Lemma notin_singleton_1 :
  ~ In y (singleton x) ->
  ~ E.eq x y.
Proof. fsetdec. Qed.

Lemma notin_singleton_1' :
  ~ In y (singleton x) ->
  x <> y.
Proof. fsetdec. Qed.

Lemma notin_singleton_2 :
  ~ E.eq x y ->
  ~ In y (singleton x).
Proof. fsetdec. Qed.

Lemma notin_remove_1 :
  ~ In y (remove x s) ->
  E.eq x y \/ ~ In y s.
Proof. fsetdec. Qed.

Lemma notin_remove_2 :
  ~ In y s ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_remove_3 :
  E.eq x y ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_remove_3' :
  x = y ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_union_1 :
  ~ In x (union s s') ->
  ~ In x s.
Proof. fsetdec. Qed.

Lemma notin_union_2 :
  ~ In x (union s s') ->
  ~ In x s'.
Proof. fsetdec. Qed.

Lemma notin_union_3 :
  ~ In x s ->
  ~ In x s' ->
  ~ In x (union s s').
Proof. fsetdec. Qed.

Lemma notin_inter_1 :
  ~ In x (inter s s') ->
  ~ In x s \/ ~ In x s'.
Proof. fsetdec. Qed.

Lemma notin_inter_2 :
  ~ In x s ->
  ~ In x (inter s s').
Proof. fsetdec. Qed.

Lemma notin_inter_3 :
  ~ In x s' ->
  ~ In x (inter s s').
Proof. fsetdec. Qed.

Lemma notin_diff_1 :
  ~ In x (diff s s') ->
  ~ In x s \/ In x s'.
Proof. fsetdec. Qed.

Lemma notin_diff_2 :
  ~ In x s ->
  ~ In x (diff s s').
Proof. fsetdec. Qed.

Lemma notin_diff_3 :
  In x s' ->
  ~ In x (diff s s').
Proof. fsetdec. Qed.

End Lemmas.

(* *********************************************************************** *)
(** * Hints *)

Hint Resolve
  @notin_empty_1 @notin_add_3 @notin_singleton_2 @notin_remove_2
  @notin_remove_3 @notin_remove_3' @notin_union_3 @notin_inter_2
  @notin_inter_3 @notin_diff_2 @notin_diff_3.

(* *********************************************************************** *)
(** * Tactics for non-membership *)

(** [destruct_notin] decomposes all hypotheses of the form [~ In x s]. *)

Ltac destruct_notin :=
  match goal with
    | H : In ?x ?s -> False |- _ =>
      change (~ In x s) in H;
      destruct_notin
    | |- In ?x ?s -> False =>
      change (~ In x s);
      destruct_notin
    | H : ~ In _ empty |- _ =>
      clear H;
      destruct_notin
    | H : ~ In ?y (add ?x ?s) |- _ =>
      let J1 := fresh "NotInTac" in
      let J2 := fresh "NotInTac" in
      pose proof H as J1;
      pose proof H as J2;
      apply notin_add_1 in H;
      apply notin_add_1' in J1;
      apply notin_add_2 in J2;
      destruct_notin
    | H : ~ In ?y (singleton ?x) |- _ =>
      let J := fresh "NotInTac" in
      pose proof H as J;
      apply notin_singleton_1 in H;
      apply notin_singleton_1' in J;
      destruct_notin
    | H : ~ In ?y (remove ?x ?s) |- _ =>
      let J := fresh "NotInTac" in
      apply notin_remove_1 in H;
      destruct H as [J | J];
      destruct_notin
    | H : ~ In ?x (union ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      pose proof H as J;
      apply notin_union_1 in H;
      apply notin_union_2 in J;
      destruct_notin
    | H : ~ In ?x (inter ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      apply notin_inter_1 in H;
      destruct H as [J | J];
      destruct_notin
    | H : ~ In ?x (diff ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      apply notin_diff_1 in H;
      destruct H as [J | J];
      destruct_notin
    | _ =>
      idtac
  end.

(** [solve_notin] decomposes hypotheses of the form [~ In x s] and
    then tries some simple heuristics for solving the resulting
    goals. *)

Ltac solve_notin :=
  intros;
  destruct_notin;
  repeat first [ apply notin_union_3
               | apply notin_add_3
               | apply notin_singleton_2
               | apply notin_empty_1
               ];
  auto;
  try tauto;
  fail "Not solvable by [solve_notin]; try [destruct_notin]".

(* *********************************************************************** *)
(** * Examples and test cases *)

(** These examples and test cases are not meant to be exhaustive. *)

Lemma test_solve_notin_1 : forall x E F G,
  ~ In x (union E F) ->
  ~ In x G ->
  ~ In x (union E G).
Proof. solve_notin. Qed.

Lemma test_solve_notin_2 : forall x y E F G,
  ~ In x (union E (union (singleton y) F)) ->
  ~ In x G ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_3 : forall x y,
  ~ E.eq x y ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_4 : forall x y E F G,
  ~ In x (union E (union (singleton x) F)) ->
  ~ In y G.
Proof. solve_notin. Qed.

Lemma test_solve_notin_5 : forall x y E F,
  ~ In x (union E (union (singleton y) F)) ->
  ~ In y E ->
  ~ E.eq y x /\ ~ E.eq x y.
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_6 : forall x y E,
  ~ In x (add y E) ->
  ~ E.eq x y /\ ~ In x E.
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_7 : forall x,
  ~ In x (singleton x) ->
  False.
Proof. solve_notin. Qed.

End Notin_fun.


(**
  This library is concerned with finiteness of a set under some
  projection operation. The motivation is to deal with types that
  contain some sort of propositional part. That is, you might have a
  set that would be represented in normal maths as $A = \{ x \,|\, P\,
  x \}$.

  This set is represented by a Coq sigma types of the form [sig
  P]. However finiteness of [sig P] isn't really very interesting: You
  care about the number of the elements, x, but don't care about how
  many proofs of P x there are.

  We will work by talking about finiteness of the image of some
  projection operation [p : A -> B]. Maybe [A] is a sigma type like
  above and [p] is projection onto the first coordinate. We carefully
  _don't_ construct the type that is the image of [p]: that would have
  exactly the same problems as the original type (two apparently
  identical elements are different because we don't have proof
  irrelevance).

 *)

Require Import Lists.List.
Require Import Program.Basics.
Require Import Logic.FinFun.

Require Import Top.FinSet.ProjSet.
Require Import Top.FinSet.NatMap.

Set Implicit Arguments.

(** * The disjoint sum of two finite sets is finite

   With projections, this might mean an internal or external sum (is
   the target [B + B'] or just [B]?). We'll prove the external version
   here and then use a surjectivity result to prove the internal
   version as a corollary later% (see section
   \ref{sec:int-sum-finite})%.

   To prove this, you take a list for each projection, map the
   elements into an option type and then join the two resulting lists
   together. The new projection we need is a map [A + A' -> B + B']
   which is constructed with [sumf], defined below (it's just the
   external sum of two maps).

 *)
Lemma finite_sum {A A' B B': Type} (p : A -> B) (p' : A' -> B')
      : FiniteProj p -> FiniteProj p' -> FiniteProj (sumf p p').
Proof.
  (* Unfold finiteness and then unpack the assumptions *)
  unfold FiniteProj.
  intros exP exP'.
  destruct exP as [ la fpA ].
  destruct exP' as [ la' fpA' ].
  (* The full element will be map inl la + map inr la' *)
  exists ((map inl la) ++ (map inr la')).
  unfold FullProj. intro aa.
  (* Proceed by case analysis: is aa in A or A'? *)
  destruct aa as [ a | a' ].
  - clear fpA'.
    apply in_proj_or_app; left.
    apply (in_proj_map (nat_map_inl p p')).
    unfold FullProj in fpA. apply fpA.
  - clear fpA.
    apply in_proj_or_app; right.
    apply (in_proj_map (nat_map_inr p' p)).
    unfold FullProj in fpA'. apply fpA'.
Qed.

(** * The surjective image of a finite set is finite.

   Here, we have to be a little careful with what we mean by
   "surjective". Remember that our projection [p: A -> B] needn't
   itself be surjective: we're only interested in the image of [p] as
   a subset of [B] (onto which p is obviously surjective).

   So we define a [SurjectiveProj] predicate. For the usual natural
   square% (see equation \ref{eq:natsq})%, saying that it is
   [SurjectiveProj] means that [g] restricted to the image of [p]
   surjects onto the image of [p']. We define this explicitly, rather
   than with Coq's builtin [Surjective] predicate (because we don't
   want to talk about the image of [p] as a type in itself).

   Note that this surjectivity definition doesn't imply that the upper
   map, f, is surjective. That's a good thing, because in the
   motivating sigma type example, we definitely don't want to claim
   that we can map to every proof "upstairs".

*)

Definition SurjectiveProj
           {A B A' B' : Type} (p : A -> B) (p' : A' -> B') (m : nat_map p p') :=
  forall a' : A', exists a : A, nm_bot m (p a) = p' a'.

Lemma finite_surj
      {A A' B B' : Type} (p : A -> B) (p' : A' -> B') (m : nat_map p p')
  : FiniteProj p -> SurjectiveProj m -> FiniteProj p'.
Proof.
  unfold FiniteProj.
  intros fullP surjH.
  destruct fullP as [l fullH].
  exists (map (nm_top m) l).
  unfold FullProj; intro a'.
  unfold SurjectiveProj in surjH.
  destruct (surjH a') as [ a aH ]; clear surjH.
  rewrite <- aH.
  apply in_proj_map.
  unfold FullProj in fullH.
  apply fullH.
Qed.

(** There's a degenerate case of [finite_surj], where we actually just
   have a second (surjective) projection to apply after [p]. Note that
   this asks for a genuine surjection from [B] to [B']. You could
   weaken this slightly, but at that point you may as well just use
   [finite_surj] explicitly.  *)

Lemma finite_surj_vert {A B B' : Type} (p : A -> B) (q : B -> B')
  : FiniteProj p -> Surjective q -> FiniteProj (compose q p).
Proof.
  intros fpH surjH.
  set (m0 := nat_map_v p).
  set (m1 := nat_map_diag id q).
  assert (midH : forall b : B, nm_top m1 b = nm_bot m0 b); auto.
  apply (finite_surj (m := nat_map_comp_v m0 m1 midH)); auto.
  unfold SurjectiveProj, compose; simpl.
  intro a. exists a. auto.
Qed.

(** ** Finiteness of an internal sum %\label{sec:int-sum-finite}%

  Now for the promised internal sum version of [finite_sum]. The proof
  of this just goes by composing the external sum with a folding
  operation, [codiag: A + A -> A], defined in the obvious way.

 *)
Definition codiag {A : Type} (a : A + A) : A :=
  match a with
  | inl a => a
  | inr a => a
  end.

Lemma surj_codiag A : Surjective (@codiag A).
Proof.
  unfold Surjective.
  intro a.
  exists (inl a).
  unfold codiag.
  exact eq_refl.
Qed.

Definition internal_sumf {A A' B} (f : A -> B) (g : A' -> B) : A + A' -> B :=
  compose codiag (sumf f g).

Lemma finite_sum_internal {A A' B} (p : A -> B) (p' : A' -> B)
  : FiniteProj p -> FiniteProj p' -> FiniteProj (internal_sumf p p').
Proof.
  unfold internal_sumf.
  intros fpH fpH'.
  apply finite_surj_vert.
  - exact (finite_sum fpH fpH').
  - exact (@surj_codiag B).
Qed.

(** * Finiteness with injections

   Now we want to prove something related to the basic result from
   maths that if I have an injection [f : X -> Y] and know that [Y] is
   finite, then [X] must be finite too.

   To prove finiteness in Coq, you need to build some form of a
   listing of [X]. Merely knowing that [f] is injective isn't going to
   be enough to construct this from a listing of [Y]: we'd need some
   non-constructive choice axiom to pick elements of [X] in the
   inverse image. In classical maths, a map [f] is injective if and
   only if it has a left inverse [g] (so $g \circ f =
   \mathrm{id}$). We'll ask to be given this map, which does the "find
   something in the inverse image" operation for us.

   In practice, that's a pain to produce, so we'll actually ask for a
   map [g : Y -> option X], satisfying [g (f a) = Some a]. Note that
   this implies that no element in the image of [f] gets mapped to
   [None], so in a non-constructive setting we could extend [g] to a
   map [Y -> X] by mapping [None] to some arbitrary element of [X].

   ** Mapping and filtering

   If we start with a listing of the image of [p'], we can apply our
   partial inverse to each element to get a list of [option
   A]'s. Filtering out the [None]'s gives a list of elements of [A],
   which generate our listing of the image of [p].
*)

Section map_filter.
  Variables (A A' : Type).
  Variable (h : A' -> option A).

  Fixpoint map_filter (l : list A') : list A :=
    match l with
    | nil => nil
    | cons a' l' => match h a' with
                    | Some a => a :: map_filter l'
                    | None => map_filter l'
                    end
    end.

  Lemma map_filter_inv a' l
    : map_filter (a' :: l) = match h a' with
                                | Some a => a :: map_filter l
                                | None => map_filter l
                                end.
  Proof. reflexivity. Qed.

  (**

     We want to precisely characterise when an element is in the image
     of [map_filter]. To make sense of this, we need to do a little
     more setup. The commutative diagram we're interested in is:
     % \begin{equation}
       \begin{tikzcd}
         A' \arrow[r, "h"] \arrow[d, "p'"] &
         \mathrm{option}\,A \arrow[d] &
         A \arrow[l, "\mathrm{Some}"'] \arrow[d, "p"]
         \\
         B' \arrow[r, "k"] &
         \mathrm{option}\,B &
         B
         \arrow[l, "\mathrm{Some}"']
       \end{tikzcd}
     \end{equation} %
     where the vertical map in the middle is [option_map p]. The right hand
     square commutes for free by the definition of [option_map]. Commutativity
     of the left hand square is the [natH] hypothesis below.

   *)

  Variables (B B' : Type).
  Variable (k : B' -> option B).
  Variable (p : A -> B).
  Variable (p' : A' -> B').
  Hypothesis (natH: forall a', option_map p (h a') = k (p' a')).

  Lemma in_proj_map_filter l a
    : (exists a', k (p' a') = Some (p a) /\ InProj p' (p' a') l) ->
      InProj p (p a) (map_filter l).
  Proof.
    intros H; destruct H as [ a' H ]; destruct H as [ mapH inH ].
    induction l as [ | x' l IH ].
    - contradiction inH.
    - destruct (in_proj_inv inH); clear inH.
      + clear IH.
        (* This is the case where we're supposed to get a hit at the
           start of the list. We have some x' where p' x' = p' a' (both
           elements of B'). *)
        rewrite <- H in mapH; clear H.
        rewrite <- (natH x') in mapH; clear natH.
        (* Now mapH says that option_map p (h x') = Some (p a).
           That must mean h x is Some something (by looking at the
           definition of option_map) *)
        case_eq (h x');
          try (intro U; rewrite U in mapH; discriminate mapH).
        intros x hx'H.
        (* Now we can do a little unpacking to conclude that p x
           equals p a. *)
        assert (p_eq_H: p x = p a);
          try (rewrite hx'H in mapH; inversion mapH; exact eq_refl).
        rewrite map_filter_inv, hx'H.
        apply in_proj_eq.
        exact p_eq_H.
      + (* This is the easier case, where we just pass stuff through
           induction. *)
        enough (InProj p (p a) (map_filter l)) as Hrst.
        * rewrite map_filter_inv.
          destruct (h x'); try (apply in_proj_cons); exact Hrst.
        * apply IH. exact H.
  Qed.

  Lemma full_proj_map_filter l
    : (forall a, exists a' : A', k (p' a') = Some (p a) /\ InProj p' (p' a') l) ->
      FullProj p (map_filter l).
  Proof.
    intro H; unfold FullProj; intro a.
    apply in_proj_map_filter, H.
  Qed.

  Variable f : A -> A'.
  Variable g : B -> B'.
  Hypothesis natfgH: forall a, p' (f a) = g (p a).
  Hypothesis kleftH: forall a, k (g (p a)) = Some (p a).

  (** We finally get to the full lemma. The big commutative diagram
     can be drawn as:
     % \begin{equation}
       \begin{tikzcd}
         A \arrow[rr, "f"] \arrow[dr, hookrightarrow] \arrow[ddd, "p"'] &
         &
         A' \arrow[ld, "h"] \arrow[ddd, "p'"]
         \\
           & \mathrm{option}\,A \arrow[d, "\mathrm{option\_map}(p)"'] &
         \\
           & \mathrm{option}\,B &
         \\
         B \arrow[ur, hookrightarrow] \arrow[rr, "g"]& & B' \arrow[ul, "k"']
       \end{tikzcd}
     \end{equation} %

     The left hand square commutes by definition of [option_map]. The outer
     square commutes, by the hypothesis [natfgH]. The bottom left half of the
     diagram commutes by the hypothesis [kleftH] (because
     [option_map p (Some a) = Some (p a)]).

     The point is that the existence of [k], which acts as (almost) the left
     inverse of the restriction of [g] to the image of [p] is equivalent to
     injectivity of [g] on the image of [p] in a non-constructive setting.
   *)

  Lemma finite_left_inverse : FiniteProj p' -> FiniteProj p.
  Proof.
    unfold FiniteProj.
    destruct 1 as [ l' l'H ].
    exists (map_filter l').
    apply full_proj_map_filter.
    intro a.
    unfold FullProj in l'H.
    exists (f a).
    rewrite (natfgH a).
    rewrite kleftH; clear kleftH.
    constructor; try exact eq_refl.
    enough (H: g (p a) = p' (f a)).
    - rewrite H. apply l'H.
    - rewrite natfgH; exact eq_refl.
  Qed.
End map_filter.

(** * Finiteness of option types

     This section shows that a type is finite if and only if the
     corresponding option type is. Use [finite_option_intro] to infer
     that an option type is finite. More usefully,
     [finite_option_elim] allows you to prove finiteness of an option
     type in order to conclude finiteness of the underlying type.

*)

Section finite_option.
  Variables (A B : Type).
  Variable (p : A -> B).

  Lemma finite_option_intro : FiniteProj p -> FiniteProj (option_map p).
  Proof.
    unfold FiniteProj.
    intro finP.
    destruct finP as [ l fullL ].
    exists (cons None (map Some l)).
    unfold FullProj.
    intro x; destruct x as [ a | ].
    - apply in_proj_cons.
      apply (in_proj_map (nat_map_some p)).
      unfold FullProj in fullL. apply fullL.
    - apply in_proj_eq; reflexivity.
  Qed.

  Lemma finite_option_elim : FiniteProj (option_map p) -> FiniteProj p.
  Proof.
    assert (H0: (forall a' : option A,
                    option_map p (id a') = id (option_map p a')));
      try reflexivity.
    assert (H1: forall a : A, option_map p (Some a) = Some (p a));
      try reflexivity.
    assert (H2: forall a : A, id (Some (p a)) = Some (p a));
      try reflexivity.
    apply (finite_left_inverse id id p H0 Some Some H1 H2).
  Qed.
End finite_option.

(** * An easier way to prove finiteness with surjectivity

    The [finite_surj] lemma is all very well, but it's sometimes a bit
    difficult to construct exactly the map you want. When trying to
    define a surjection from [p : A -> B] to [p' : A' -> B'], there
    might be some elements, [a], that we don't care about and just
    want to map to [None]. In this section, we do the leg-work to make
    this approach work properly.

*)
Module surj_finite_option.
  Definition lift_opt {A B : Type} (f : A -> option B) (oa : option A)
  : option B :=
    match oa with
    | Some a => f a
    | None => None
    end.

  Section surj_finite_option.
    Variables A A' B B' : Type.
    Variable p: A -> B.
    Variable p': A' -> B'.
    Variable f: A -> option A'.
    Variable g: B -> option B'.

    Hypothesis finP : FiniteProj p.
    Hypothesis natH : forall a, option_map p' (f a) = g (p a).
    Hypothesis surjH : forall a' : A', exists a : A, g (p a) = Some (p' a').

    Local Definition xp := option_map p.
    Local Definition xp' := option_map p'.
    Local Definition xf := lift_opt f.
    Local Definition xg := lift_opt g.

    Local Lemma OfinP : FiniteProj xp.
    Proof.
      exact (finite_option_intro finP).
    Qed.

    Local Lemma OnatH: is_nat_map xp xp' (xf, xg).
    Proof.
      unfold is_nat_map. intro a; destruct a; simpl; auto.
    Qed.

    Local Lemma OsurjH : SurjectiveProj (exist _ (xf, xg) OnatH).
    Proof.
      unfold SurjectiveProj; intro x'; destruct x' as [ a' | ].
      - specialize (surjH a').
        destruct surjH as [ a H ]; clear surjH.
        exists (Some a).
        auto.
      - exists None.
        auto.
    Qed.

    Lemma finite_surj_option : FiniteProj p'.
    Proof.
      apply finite_option_elim.
      apply (finite_surj OfinP OsurjH).
    Qed.
  End surj_finite_option.
End surj_finite_option.

Import surj_finite_option.
Export surj_finite_option.

Local Lemma decompose_pair_eq {A B : Type} (a a' : A) (b b' : B)
  : (a, b) = (a', b') -> a = a' /\ b = b'.
Proof.
  intro H; constructor.
  - pose proof (f_equal fst H) as Ha; simpl in Ha. assumption.
  - pose proof (f_equal snd H) as Hb; simpl in Hb. assumption.
Qed.

Lemma in_proj_neq {A B : Type} (p : A -> B) b a l
  : p a <> b -> InProj p b (a :: l) -> InProj p b l.
Proof.
  intros neq consH.
  destruct (in_proj_inv consH); tauto.
Qed.

(** * Sections of projections

    It isn't the case that we can always make a section for a
    projection (as defined in this theory) - the whole point is that
    [p : A -> B] probably isn't surjective. However, if we are given
    some element of A then we can map elements of B that we don't care
    about to that point. If [l] is nonempty, we could just use the
    first element of the list, but I think it's cleaner to pass in
    this element explicitly (which punts on the problems you get
    otherwise when [A] is empty).
 *)
Section proj_section.
  Variables A B : Type.
  Hypothesis decB : forall x y : B, {x = y} + {x <> y}.
  Variable p : A -> B.
  Variable a0 : A.

  Fixpoint proj_section (b : B) (l : list A) : A :=
    match l with
    | nil => a0
    | a :: l' => match decB (p a) b with
                 | left eqH => a
                 | right neH => proj_section b l'
                 end
    end.

  Lemma proj_section_if_in b l
    : In b (map p l) -> p (proj_section b l) = b.
  Proof.
    induction l as [ | a l IH ]; try contradiction.
    unfold proj_section; fold proj_section.
    destruct (decB (p a) b) as [ | neH ]; auto.
    destruct 1 as [ | inH ]; tauto.
  Qed.

  Lemma full_proj_section_is_section l
    : FullProj p l ->
      forall a : A, p (proj_section (p a) l) = p a.
  Proof.
    intros.
    apply proj_section_if_in.
    unfold FullProj, InProj in *; auto.
  Qed.
End proj_section.

(** * Inverses of surjective natural maps

  *)
Lemma map_compose
      {A B C : Type}
      (f : A -> B) (g : B -> C) (l : list A)
  : map (compose g f) l = map g (map f l).
Proof.
  induction l as [ | a l IH ]; auto.
  rewrite map_cons, map_cons, map_cons.
  unfold compose at 1.
  apply f_equal; auto.
Qed.

Section surj_map_is_invertible.
  Variables A B C D : Type.
  Hypothesis decB : forall x y : B, {x = y} + {x <> y}.
  Hypothesis decD : forall x y : D, {x = y} + {x <> y}.
  Variable p : A -> B.
  Variable q : C -> D.
  Variable f : nat_map p q.

  Variable a0 : A.

  Local Fixpoint bot_map (l : list A) (d : D) : B :=
    match l with
    | nil => p a0
    | a :: l' => match decD (nm_bot f (p a)) d with
                 | left _ => p a
                 | right _ => bot_map l' d
                 end
    end.

  Local Lemma bot_map_if_in d l
    : In d (map (compose (nm_bot f) p) l) ->
      nm_bot f (bot_map l d) = d.
  Proof.
    induction l as [ | a l IH ]; try contradiction.
    unfold bot_map; fold bot_map.
    destruct (decD (nm_bot f (p a)) d); auto.
    rewrite map_cons.
    destruct 1; tauto.
  Qed.

  Local Lemma in_map_compose_if c l
    : SurjectiveProj f -> FullProj p l ->
      In (q c) (map (compose (nm_bot f) p) l).
  Proof.
    intros surjH fullH.
    specialize (surjH c).
    destruct surjH as [ a natH ]; rewrite <- natH; clear natH c.
    (* So we need to use fullness of l wrt p. This gives us some
       element of l that maps down to the same element as [a] does.
     *)
    specialize (fullH a); unfold InProj in fullH.
    rewrite in_map_iff in fullH.
    destruct fullH as [ a' H ]; destruct H as [ peqH inH ].
    rewrite map_compose.
    apply in_map.
    rewrite <- peqH.
    apply in_map; assumption.
  Qed.

  Local Definition top_map (l : list A) (c : C) : A :=
    proj_section decB p a0 (bot_map l (q c)) l.

  Local Lemma bot_map_in_proj (l : list A) d
    : In d (map (compose (nm_bot f) p) l) ->
      InProj p (bot_map l d) l.
  Proof.
    induction l as [ | a l IH ]; auto.
    unfold bot_map; fold bot_map.
    intro inH.
    unfold InProj in *; rewrite map_cons.
    destruct (decD (nm_bot f (p a)) d) as [ <- | neH ].
    - apply in_eq.
    - destruct inH as [ | inH ]; try tauto.
      apply in_cons; auto.
  Qed.

  Variable l : list A.
  Hypothesis surjH : SurjectiveProj f.
  Hypothesis fullH : FullProj p l.

  Local Lemma bot_map_exists_lift c
    : exists a, p a = bot_map l (q c) /\ In a l.
  Proof.
    rewrite <- in_map_iff.
    apply bot_map_in_proj.
    apply in_map_compose_if; auto.
  Qed.

  Local Lemma inv_is_nat_map : is_nat_map q p (top_map l, bot_map l).
  Proof.
    intros c; simpl.
    unfold top_map.
    destruct (bot_map_exists_lift c) as [ a H ].
    destruct H as [ <- inH ].
    apply full_proj_section_is_section; auto.
  Qed.

  Definition surj_nat_map_right_inverse : nat_map q p :=
    exist _ (top_map l, bot_map l) inv_is_nat_map.

  Lemma surj_map_is_invertible c
    : nm_bot (nat_map_comp_h surj_nat_map_right_inverse f) (q c) = q c.
  Proof.
    simpl; unfold compose.
    apply bot_map_if_in.
    apply in_map_compose_if; auto.
  Qed.

End surj_map_is_invertible.


Require Import Arith.
Require Import NatIntf CanonicalNatImpl CommutingNatIntf.

(* Compose a function with itself `n` times *)
Fixpoint iterate A (n:nat) (f:A -> A) (x:A) : A :=
  match n with
  | 0 => x
  | S n' => f (iterate A n' f x)
  end.

(* An extension of CommutingNaturalInterface that includes various correctness
 * properties that correct implementations of the natural numbers should
 * satisfy. *)
Module Type VerifiedNatInterface <: CommutingNatInterface.
  Parameter N : Type.

  Parameter zero : N.
  Parameter succ : N -> N.
  Parameter pred : N -> N.
  Parameter add : N -> N -> N.
  Parameter sub : N -> N -> N.
  Parameter comp : N -> N -> comparison.
  Parameter convert : N -> nat.

  Axiom convert_injective : forall n n' : N, convert n = convert n' -> n = n'.
  Axiom zero_commutes : convert zero = CanonicalNat.zero.
  Axiom succ_commutes : forall n : N,
    convert (succ n) = CanonicalNat.succ (convert n).
  Axiom pred_commutes : forall n : N,
    convert (pred n) = CanonicalNat.pred (convert n).
  Axiom add_commutes : forall n n' : N,
    convert (add n n') = CanonicalNat.add (convert n) (convert n').
  Axiom sub_commutes : forall n n' : N,
    convert (sub n n') = CanonicalNat.sub (convert n) (convert n').
  Axiom comp_commutes : forall n n' : N,
    comp n n' = CanonicalNat.comp (convert n) (convert n').

  (* Correctness properties for nat implementations *)
  Axiom unary_repr : forall (n:N),
    iterate _ (convert n) succ zero = n.

  Axiom pos_succ : forall (n:N), comp n zero = Gt -> exists n', n = succ n'.
  Axiom pred_succ : forall (n:N), pred (succ n) = n.

  Axiom add_zero : forall (n:N), add zero n = n.
  Axiom add_succ : forall (m n:N), add (succ m) n = succ (add m n).
  Axiom add_succ_right : forall (m n:N), add m (succ n) = add (succ m) n.

  Axiom sub_zero : forall (n:N), sub n zero = n.
  Axiom sub_succ : forall (m n:N), sub (succ m) (succ n) = sub m n.
  Axiom sub_pred : forall (m n:N), sub (pred m) n = sub m (succ n).

  Axiom comp_zero : forall (n:N), comp n zero <> Lt.
  Axiom comp_succ : forall (m n:N), comp (succ m) (succ n) = comp m n.
  Axiom comp_eq : forall (m n:N), comp m n = Eq <-> m = n.
  Axiom comp_zero_succ : forall (n:N), comp zero (succ n) = Lt.
End VerifiedNatInterface.

(* A functor which produces an implementation of VerifedNatInterface from an
 * implementation of CommutingNatInterface. *)
Module VerifiedCommutingNat (C : CommutingNatInterface)
    : VerifiedNatInterface.
  Definition N := C.N.
  Definition zero := C.zero.
  Definition succ := C.succ.
  Definition pred := C.pred.
  Definition add := C.add.
  Definition sub := C.sub.
  Definition comp := C.comp.
  Definition convert := C.convert.
  Definition convert_injective := C.convert_injective.
  Definition zero_commutes := C.zero_commutes.
  Definition succ_commutes := C.succ_commutes.
  Definition pred_commutes := C.pred_commutes.
  Definition add_commutes := C.add_commutes.
  Definition sub_commutes := C.sub_commutes.
  Definition comp_commutes := C.comp_commutes.

  Lemma unary_repr' : forall (u:nat) (n:N),
      C.convert n = u -> iterate _ u C.succ C.zero = n.
    intros u.
    induction u;
        intros n Heqn; simpl; apply convert_injective.
      (* 0 *)
      rewrite zero_commutes.
      rewrite Heqn.
      auto.
      (* S u *)
      rewrite succ_commutes.
      rewrite Heqn.
      assert (C.convert (C.pred n) = u) as Heqn'.
        rewrite pred_commutes.
        rewrite Heqn.
        auto.
      rewrite (IHu _ Heqn').
      rewrite pred_commutes.
      rewrite Heqn.
      auto.
  Defined.

  Lemma unary_repr : forall (n:N),
      iterate _ (C.convert n) C.succ C.zero = n.
    intros n.
    apply (unary_repr' (C.convert n) n); trivial.
  Defined.

  Lemma pos_succ : forall (n:N),
      comp n C.zero = Gt -> exists n', n = succ n'.
    intros n.
    rewrite comp_commutes.
    rewrite zero_commutes.
    remember (C.convert n) as m.
    destruct m;
        symmetry in Heqm; simpl.
      (* 0 *)
      congruence.
      (* S m *)
      intros _.
      refine (ex_intro _ (pred n) _).
        apply C.convert_injective.
        rewrite succ_commutes.
        rewrite pred_commutes.
        rewrite Heqm.
        simpl.
        reflexivity.
  Defined.

  Lemma pred_succ : forall (n:N), pred (succ n) = n.
    intros n.
    apply C.convert_injective.
    rewrite C.pred_commutes.
    rewrite C.succ_commutes.
    auto.
  Defined.

  Lemma add_zero : forall (n:N), add C.zero n = n.
    intros n.
    apply C.convert_injective.
    rewrite (C.add_commutes _ _).
    rewrite (C.zero_commutes).
    auto.
  Defined.

  Lemma add_succ : forall (m n : N), add (succ m) n = succ (add m n).
    intros m n.
    apply C.convert_injective.
    rewrite (C.add_commutes _ _).
    rewrite (C.succ_commutes _).
    rewrite (C.succ_commutes _).
    rewrite (C.add_commutes _ _).
    simpl.
    reflexivity.
  Defined.

  Lemma add_succ_right : forall (m n : N),
      add m (succ n) = add (succ m) n.
    intros m n.
    apply C.convert_injective.
    rewrite (C.add_commutes _ _).
    rewrite (C.succ_commutes _).
    rewrite (C.add_commutes _ _).
    rewrite (C.succ_commutes _).
    rewrite plus_Snm_nSm.
    reflexivity.
  Defined.

  Lemma sub_zero : forall (n : N), sub n C.zero = n.
    intros n.
    apply C.convert_injective.
    rewrite (C.sub_commutes _ _).
    rewrite C.zero_commutes.
    destruct (C.convert n); auto.
  Defined.

  Lemma sub_succ : forall (m n:N), sub (succ m) (succ n) = sub m n.
    intros m n.
    apply C.convert_injective.
    rewrite C.sub_commutes.
    rewrite C.sub_commutes.
    rewrite C.succ_commutes.
    rewrite C.succ_commutes.
    auto.
  Defined.

  Lemma sub_pred : forall (m n:N), sub (pred m) n = sub m (succ n).
    intros m n.
    apply C.convert_injective.
    rewrite C.sub_commutes.
    rewrite C.sub_commutes.
    rewrite C.pred_commutes.
    rewrite C.succ_commutes.
    destruct (C.convert m);
      simpl; reflexivity.
  Defined.

  Lemma comp_zero :forall (n:N), comp n C.zero <> Lt.
    intros n.
    rewrite C.comp_commutes.
    rewrite C.zero_commutes.
    destruct (C.convert n);
      simpl; congruence.
  Defined.

  Lemma comp_succ : forall (m n:N), comp (succ m) (succ n) = comp m n.
    intros m n.
    rewrite C.comp_commutes.
    rewrite C.comp_commutes.
    rewrite C.succ_commutes.
    rewrite C.succ_commutes.
    auto.
  Defined.

  Lemma comp_eq : forall (m n:N), comp m n = Eq <-> m = n.
    intros m n.
    refine (conj _ _).
      (* -> *)
      rewrite (C.comp_commutes _ _).
      intros Hcomp.
      apply C.convert_injective.
      apply (CanonicalNatImpl.comp_eq).
      assumption.
      (* <- *)
      intros Heq.
      rewrite Heq.
      rewrite (C.comp_commutes _ _).
      apply (CanonicalNatImpl.comp_eq).
      reflexivity.
  Defined.

  Lemma comp_zero_succ : forall (n:N), comp C.zero (succ n) = Lt.
    intros n.
    rewrite (C.comp_commutes _ _).
    rewrite C.zero_commutes.
    rewrite (C.succ_commutes _).
    simpl.
    reflexivity.
  Defined.
End VerifiedCommutingNat.


Require Import PPS.Env.

Set Implicit Arguments.

Inductive AExp : Type :=
| AVar   : nat    -> AExp
| ANum   : nat    -> AExp
| APlus  : AExp -> AExp -> AExp
| AMinus : AExp -> AExp -> AExp
| AMult  : AExp -> AExp -> AExp.

Inductive BExp : Type :=
| BTrue  : BExp
| BFalse : BExp
| BLess  : AExp -> AExp -> BExp.

Notation "e1 :<: e2" := (BLess e1 e2) (at level 40, left associativity).
Notation "e1 :+: e2" := (APlus e1 e2) (at level 40, left associativity).
Notation "e1 :-: e2" := (AMinus e1 e2) (at level 40, left associativity).
Notation "e1 :*: e2" := (AMult e1 e2) (at level 40, left associativity).

Definition Env := listMap nat nat.

Fixpoint aeval (e : AExp) (Sigma : Env) : option nat :=
  match e with
  | ANum n       => Some n
  | AVar ident   => lookup Nat.eqb Sigma ident
  | APlus e1 e2  =>
    match aeval e1 Sigma, aeval e2 Sigma with
    | Some v1, Some v2 => Some (v1 + v2)
    | _, _ => None
    end
  | AMinus e1 e2 =>
    match aeval e1 Sigma, aeval e2 Sigma with
    | Some v1, Some v2 => Some (v1 - v2)
    | _, _ => None
    end
  | AMult e1 e2  =>
    match aeval e1 Sigma, aeval e2 Sigma with
    | Some v1, Some v2 => Some (v1 * v2)
    | _, _ => None
    end
  end.

Fixpoint beval (e : BExp) (Sigma : Env) : option bool :=
  match e with
  | BTrue       => Some true
  | BFalse      => Some false
  | BLess e1 e2 =>
    match aeval e1 Sigma, aeval e2 Sigma with
    | Some v1, Some v2 => Some (Nat.leb v1 v2)
    | _, _ => None
    end
  end.


Require Import rt.util.all.
Require Import rt.model.basic.job rt.model.basic.arrival_sequence rt.model.basic.schedule
               rt.model.basic.platform rt.model.basic.priority.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop seq path.

Module ConcreteScheduler.

  Import Job ArrivalSequence Schedule Platform Priority.

  Section Implementation.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.

    (* Let num_cpus denote the number of processors, ...*)
    Variable num_cpus: nat.

    (* ... and let arr_seq be any arrival sequence.*)
    Variable arr_seq: arrival_sequence Job.

    (* Assume a JLDP policy is given. *)
    Variable higher_eq_priority: JLDP_policy arr_seq.

    (* Consider the list of pending jobs at time t. *)
    Definition jobs_pending_at (sched: schedule num_cpus arr_seq) (t: time) :=
      [seq j <- jobs_arrived_up_to arr_seq t | pending job_cost sched j t].

    (* Next, we sort this list by priority. *)
    Definition sorted_pending_jobs (sched: schedule num_cpus arr_seq) (t: time) :=
      sort (higher_eq_priority t) (jobs_pending_at sched t).

    (* Starting from the empty schedule as a base, ... *)
    Definition empty_schedule : schedule num_cpus arr_seq :=
      fun t cpu => None.

    (* ..., we redefine the mapping of jobs to processors at any time t as follows.
       The i-th job in the sorted list is assigned to the i-th cpu, or to None
       if the list is short. *)
    Definition update_schedule (prev_sched: schedule num_cpus arr_seq)
                               (t_next: time) : schedule num_cpus arr_seq :=
      fun cpu t =>
        if t == t_next then
          nth_or_none (sorted_pending_jobs prev_sched t) cpu
        else prev_sched cpu t.

    (* The schedule is iteratively constructed by applying assign_jobs at every time t, ... *)
    Fixpoint schedule_prefix (t_max: time) : schedule num_cpus arr_seq :=
      if t_max is t_prev.+1 then
        (* At time t_prev + 1, schedule jobs that have not completed by time t_prev. *)
        update_schedule (schedule_prefix t_prev) t_prev.+1
      else
        (* At time 0, schedule any jobs that arrive. *)
        update_schedule empty_schedule 0.

    Definition scheduler (cpu: processor num_cpus) (t: time) := (schedule_prefix t) cpu t.

  End Implementation.

  Section Proofs.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.

    (* Assume a positive number of processors. *)
    Variable num_cpus: nat.
    Hypothesis H_at_least_one_cpu: num_cpus > 0.

    (* Let arr_seq be any arrival sequence of jobs where ...*)
    Variable arr_seq: arrival_sequence Job.
    (* ...jobs have positive cost and...*)
    Hypothesis H_job_cost_positive:
      forall (j: JobIn arr_seq), job_cost_positive job_cost j.
    (* ... at any time, there are no duplicates of the same job. *)
    Hypothesis H_arrival_sequence_is_a_set :
      arrival_sequence_is_a_set arr_seq.

    (* Consider any JLDP policy higher_eq_priority that is transitive and total. *)
    Variable higher_eq_priority: JLDP_policy arr_seq.
    Hypothesis H_priority_transitive: forall t, transitive (higher_eq_priority t).
    Hypothesis H_priority_total: forall t, total (higher_eq_priority t).

    (* Let sched denote our concrete scheduler implementation. *)
    Let sched := scheduler job_cost num_cpus arr_seq higher_eq_priority.

    (* Next, we provide some helper lemmas about the scheduler construction. *)
    Section HelperLemmas.

      (* First, we show that the scheduler preserves its prefixes. *)
      Lemma scheduler_same_prefix :
        forall t t_max cpu,
          t <= t_max ->
          schedule_prefix job_cost num_cpus arr_seq higher_eq_priority t_max cpu t =
          scheduler job_cost num_cpus arr_seq higher_eq_priority cpu t.
      Proof.
        intros t t_max cpu LEt.
        induction t_max.
        {
          by rewrite leqn0 in LEt; move: LEt => /eqP EQ; subst.
        }
        {
          rewrite leq_eqVlt in LEt.
          move: LEt => /orP [/eqP EQ | LESS]; first by subst.
          {
            feed IHt_max; first by done.
            unfold schedule_prefix, update_schedule at 1.
            assert (FALSE: t == t_max.+1 = false).
            {
              by apply negbTE; rewrite neq_ltn LESS orTb.
            } rewrite FALSE.
            by rewrite -IHt_max.
          }
        }
      Qed.

      (* With respect to the sorted list of pending jobs, ...*)
      Let sorted_jobs (t: time) :=
        sorted_pending_jobs job_cost num_cpus arr_seq higher_eq_priority sched t.

      (* ..., we show that a job is mapped to a processor based on that list, ... *)
      Lemma scheduler_nth_or_none_mapping :
        forall t cpu x,
          sched cpu t = x ->
          nth_or_none (sorted_jobs t) cpu = x.
      Proof.
        intros t cpu x SCHED.
        unfold sched, scheduler, schedule_prefix in *.
        destruct t.
        {
          unfold update_schedule in SCHED; rewrite eq_refl in SCHED.
          rewrite -SCHED; f_equal.
          unfold sorted_jobs, sorted_pending_jobs; f_equal.
          unfold jobs_pending_at; apply eq_filter; red; intro j'.
          unfold pending; f_equal; f_equal.
          unfold completed, service.
          by rewrite big_geq // big_geq //.
        }
        {
          unfold update_schedule at 1 in SCHED; rewrite eq_refl in SCHED.
          rewrite -SCHED; f_equal.
          unfold sorted_jobs, sorted_pending_jobs; f_equal.
          unfold jobs_pending_at; apply eq_filter; red; intro j'.
          unfold pending; f_equal; f_equal.
          unfold completed, service; f_equal.
          apply eq_big_nat; move => t0 /andP [_ LT].
          unfold service_at; apply eq_bigl; red; intros cpu'.
          fold (schedule_prefix job_cost num_cpus arr_seq higher_eq_priority).
          by rewrite /scheduled_on 2?scheduler_same_prefix ?leqnn //.
        }
      Qed.

      (* ..., a scheduled job is mapped to a cpu corresponding to its position, ... *)
      Lemma scheduler_nth_or_none_scheduled :
        forall j t,
          scheduled sched j t ->
          exists (cpu: processor num_cpus),
            nth_or_none (sorted_jobs t) cpu = Some j.
      Proof.
        intros j t SCHED.
        move: SCHED => /existsP [cpu /eqP SCHED]; exists cpu.
        by apply scheduler_nth_or_none_mapping.
      Qed.

      (* ..., and that a backlogged job has a position larger than or equal to the number
         of processors. *)
      Lemma scheduler_nth_or_none_backlogged :
        forall j t,
          backlogged job_cost sched j t ->
          exists i,
            nth_or_none (sorted_jobs t) i = Some j /\ i >= num_cpus.
      Proof.
        intros j t BACK.
        move: BACK => /andP [PENDING /negP NOTCOMP].
        assert (IN: j \in sorted_jobs t).
        {
          rewrite mem_sort mem_filter PENDING andTb.
          move: PENDING => /andP [ARRIVED _].
          by rewrite JobIn_has_arrived.
        }
        apply nth_or_none_mem_exists in IN; des.
        exists n; split; first by done.
        rewrite leqNgt; apply/negP; red; intro LT.
        apply NOTCOMP; clear NOTCOMP PENDING.
        apply/existsP; exists (Ordinal LT); apply/eqP.
        unfold sorted_jobs in *; clear sorted_jobs.
        unfold sched, scheduler, schedule_prefix in *; clear sched.
        destruct t.
        {
          unfold update_schedule; rewrite eq_refl.
          rewrite -IN; f_equal.
          fold (schedule_prefix job_cost num_cpus arr_seq higher_eq_priority).
          unfold sorted_pending_jobs; f_equal.
          apply eq_filter; red; intros x.
          unfold pending; f_equal; f_equal.
          unfold completed; f_equal.
          by unfold service; rewrite 2?big_geq //.
        }
        {
          unfold update_schedule at 1; rewrite eq_refl.
          rewrite -IN; f_equal.
          unfold sorted_pending_jobs; f_equal.
          apply eq_filter; red; intros x.
          unfold pending; f_equal; f_equal.
          unfold completed; f_equal.
          unfold service; apply eq_big_nat; move => i /andP [_ LTi].
          unfold service_at; apply eq_bigl; red; intro cpu.
          unfold scheduled_on; f_equal.
          fold (schedule_prefix job_cost num_cpus arr_seq higher_eq_priority).
          by rewrite scheduler_same_prefix.
        }
      Qed.

    End HelperLemmas.

    (* Now, we prove the important properties about the implementation. *)

    (* Jobs do not execute before they arrive, ...*)
    Theorem scheduler_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute sched.
    Proof.
      unfold jobs_must_arrive_to_execute.
      intros j t SCHED.
      move: SCHED => /existsP [cpu /eqP SCHED].
      unfold sched, scheduler, schedule_prefix in SCHED.
      destruct t.
      {
        rewrite /update_schedule eq_refl in SCHED.
        apply (nth_or_none_mem _ cpu j) in SCHED.
        rewrite mem_sort mem_filter in SCHED.
        move: SCHED => /andP [_ ARR].
        by apply JobIn_has_arrived in ARR.
      }
      {
        unfold update_schedule at 1 in SCHED; rewrite eq_refl /= in SCHED.
        apply (nth_or_none_mem _ cpu j) in SCHED.
        rewrite mem_sort mem_filter in SCHED.
        move: SCHED => /andP [_ ARR].
        by apply JobIn_has_arrived in ARR.
      }
    Qed.

    (* ..., jobs are sequential, ... *)
    Theorem scheduler_sequential_jobs: sequential_jobs sched.
    Proof.
      unfold sequential_jobs, sched, scheduler, schedule_prefix.
      intros j t cpu1 cpu2 SCHED1 SCHED2.
      destruct t; rewrite /update_schedule eq_refl in SCHED1 SCHED2;
      have UNIQ := nth_or_none_uniq _ cpu1 cpu2 j _ SCHED1 SCHED2; (apply ord_inj, UNIQ);
      rewrite sort_uniq filter_uniq //;
      by apply JobIn_uniq.
    Qed.

    (* ... and jobs do not execute after completion. *)
    Theorem scheduler_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.
    Proof.
      rename H_job_cost_positive into GT0.
      unfold completed_jobs_dont_execute, service.
      intros j t.
      induction t; first by rewrite big_geq.
      {
        rewrite big_nat_recr // /=.
        rewrite leq_eqVlt in IHt; move: IHt => /orP [/eqP EQ | LESS]; last first.
        {
          destruct (job_cost j); first by rewrite ltn0 in LESS.
          rewrite -addn1; rewrite ltnS in LESS.
          apply leq_add; first by done.
          by apply service_at_most_one, scheduler_sequential_jobs.
        }
        rewrite EQ -{2}[job_cost j]addn0; apply leq_add; first by done.
        destruct t.
        {
          rewrite big_geq // in EQ.
          specialize (GT0 j); unfold job_cost_positive in *.
          by rewrite -EQ ltn0 in GT0.
        }
        {
          unfold service_at; rewrite big_mkcond.
          apply leq_trans with (n := \sum_(cpu < num_cpus) 0);
            last by rewrite big_const_ord iter_addn mul0n addn0.
          apply leq_sum; intros cpu _; desf.
          move: Heq => /eqP SCHED.
          unfold scheduler, schedule_prefix in SCHED.
          unfold sched, scheduler, schedule_prefix, update_schedule at 1 in SCHED.
          rewrite eq_refl in SCHED.
          apply (nth_or_none_mem _ cpu j) in SCHED.
          rewrite mem_sort mem_filter in SCHED.
          fold (update_schedule job_cost num_cpus arr_seq higher_eq_priority) in SCHED.
          move: SCHED => /andP [/andP [_ /negP NOTCOMP] _].
          exfalso; apply NOTCOMP; clear NOTCOMP.
          unfold completed; apply/eqP.
          unfold service; rewrite -EQ.
          rewrite big_nat_cond [\sum_(_ <= _ < _ | true)_]big_nat_cond.
          apply eq_bigr; move => i /andP [/andP [_ LT] _].
          apply eq_bigl; red; ins.
          unfold scheduled_on; f_equal.
          fold (schedule_prefix job_cost num_cpus arr_seq higher_eq_priority).
          by rewrite scheduler_same_prefix.
        }
      }
    Qed.

    (* In addition, the scheduler is work conserving ... *)
    Theorem scheduler_work_conserving:
      work_conserving job_cost sched.
    Proof.
      unfold work_conserving; intros j t BACK cpu.
      set jobs := sorted_pending_jobs job_cost num_cpus arr_seq higher_eq_priority sched t.
      destruct (sched cpu t) eqn:SCHED; first by exists j0; apply/eqP.
      apply scheduler_nth_or_none_backlogged in BACK.
      destruct BACK as [cpu_out [NTH GE]].
      exfalso; rewrite leqNgt in GE; move: GE => /negP GE; apply GE.
      apply leq_ltn_trans with (n := cpu); last by done.
      apply scheduler_nth_or_none_mapping in SCHED.
      apply nth_or_none_size_none in SCHED.
      apply leq_trans with (n := size jobs); last by done.
      by apply nth_or_none_size_some in NTH; apply ltnW.
    Qed.

    (* ... and enforces the JLDP policy. *)
    Theorem scheduler_enforces_policy :
      enforces_JLDP_policy job_cost sched higher_eq_priority.
    Proof.
      unfold enforces_JLDP_policy; intros j j_hp t BACK SCHED.
      set jobs := sorted_pending_jobs job_cost num_cpus arr_seq higher_eq_priority sched t.
      apply scheduler_nth_or_none_backlogged in BACK.
      destruct BACK as [cpu_out [SOME GE]].
      apply scheduler_nth_or_none_scheduled in SCHED.
      destruct SCHED as [cpu SCHED].
      have EQ1 := nth_or_none_nth jobs cpu j_hp j SCHED.
      have EQ2 := nth_or_none_nth jobs cpu_out j j SOME.
      rewrite -EQ1 -{2}EQ2.
      apply sorted_lt_idx_implies_rel; [by done | by apply sort_sorted | |].
      - by apply leq_trans with (n := num_cpus).
      - by apply nth_or_none_size_some in SOME.
    Qed.

  End Proofs.

End ConcreteScheduler.


Section Definitions.
Require Import ZArith.
Open Scope Z_scope.

(* Values (reused) *)
Inductive Value : Set :=
    | VInt  : Z -> Value
    | VBool : bool -> Value.

(* Variables at p.71 *)
Inductive Var : Set :=
    | VId : nat -> Var.

(* Decidability of Var *)
Lemma Var_eq_dec :
    forall x y : Var, {x = y} + {x <> y}.
Proof.
    intros x y.
    destruct x as [i].
    destruct y as [j].
    destruct (eq_nat_dec i j) as [D | D].

        (* Case : i = j *)
        left.
        subst.
        reflexivity.

        (* Case : i <> j *)
        right.
        intro H.
        apply D.
        inversion H as [H'].
        reflexivity.
Qed.

(* Environments at p.71 *)
Inductive Env : Set :=
    | ENil  : Env
    | ECons : Env -> Var -> Value -> Env.

(* Definition at p.71 *)
Inductive Exp : Set :=
    | EValue : Value -> Exp
    | EVar   : Var -> Exp
    | EPlus  : Exp -> Exp -> Exp
    | EMinus : Exp -> Exp -> Exp
    | ETimes : Exp -> Exp -> Exp
    | ELt    : Exp -> Exp -> Exp
    | EIf    : Exp -> Exp -> Exp -> Exp
    | ELet   : Var -> Exp -> Exp -> Exp.

(* Definitions at pp.56-57 (reused) *)
Inductive Plus : Z -> Z -> Z -> Prop :=
    | B_Plus : forall i1 i2 i3 : Z, i3 = i1 + i2 -> Plus i1 i2 i3.
Inductive Minus : Z -> Z -> Z -> Prop :=
    | B_Minus : forall i1 i2 i3 : Z, i3 = i1 - i2 -> Minus i1 i2 i3.
Inductive Times : Z -> Z -> Z -> Prop :=
    | B_Times : forall i1 i2 i3 : Z, i3 = i1 * i2 -> Times i1 i2 i3.
Inductive Lt : Z -> Z -> bool -> Prop :=
    | B_Lt : forall (i1 i2 : Z) (b3 : bool), b3 = (i1 <? i2) -> Lt i1 i2 b3.

Lemma Plus_uniq :
    forall i1 i2 i3 i4 : Z, Plus i1 i2 i3 -> Plus i1 i2 i4 -> i3 = i4.
Proof.
    intros i1 i2 i3 i4 H3 H4.
    inversion H3; subst.
    inversion H4; subst.
    reflexivity.
Qed.

Lemma Minus_uniq :
    forall i1 i2 i3 i4 : Z, Minus i1 i2 i3 -> Minus i1 i2 i4 -> i3 = i4.
Proof.
    intros i1 i2 i3 i4 H3 H4.
    inversion H3; subst.
    inversion H4; subst.
    reflexivity.
Qed.

Lemma Times_uniq :
    forall i1 i2 i3 i4 : Z, Times i1 i2 i3 -> Times i1 i2 i4 -> i3 = i4.
Proof.
    intros i1 i2 i3 i4 H3 H4.
    inversion H3; subst.
    inversion H4; subst.
    reflexivity.
Qed.

Lemma Lt_uniq :
    forall (i1 i2 : Z) (b1 b2 : bool), Lt i1 i2 b1 -> Lt i1 i2 b2 -> b1 = b2.
Proof.
    intros i1 i2 i3 i4 H3 H4.
    inversion H3; subst.
    inversion H4; subst.
    reflexivity.
Qed.

(* Fig 4.1 *)
Inductive EvalTo : Env -> Exp -> Value -> Prop :=
    | E_Int   : forall (E : Env) (i : Z),
                EvalTo E (EValue (VInt i)) (VInt i)
    | E_Bool  : forall (E : Env) (b : bool),
                EvalTo E (EValue (VBool b)) (VBool b)
    | E_Var1  : forall (E : Env) (x : Var) (v : Value),
                EvalTo (ECons E x v) (EVar x) v
    | E_Var2  : forall (E : Env) (x y : Var) (v1 v2 : Value),
                x <> y -> EvalTo E (EVar x) v2 ->
                EvalTo (ECons E y v1) (EVar x) v2
    | E_Plus  : forall (E : Env) (e1 e2 e3 : Exp) (i1 i2 i3 : Z),
                EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                Plus i1 i2 i3 ->
                EvalTo E (EPlus e1 e2) (VInt i3)
    | E_Minus : forall (E : Env) (e1 e2 e3 : Exp) (i1 i2 i3 : Z),
                EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                Minus i1 i2 i3 ->
                EvalTo E (EMinus e1 e2) (VInt i3)
    | E_Times : forall (E : Env) (e1 e2 e3 : Exp) (i1 i2 i3 : Z),
                EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                Times i1 i2 i3 ->
                EvalTo E (ETimes e1 e2) (VInt i3)
    | E_Lt    : forall (E : Env) (e1 e2 : Exp) (i1 i2 : Z) (b3 : bool),
                EvalTo E e1 (VInt i1) -> EvalTo E e2 (VInt i2) ->
                Lt i1 i2 b3 ->
                EvalTo E (ELt e1 e2) (VBool b3)
    | E_IfT   : forall (E : Env) (e1 e2 e3 : Exp) (v : Value),
                EvalTo E e1 (VBool true) -> EvalTo E e2 v ->
                EvalTo E (EIf e1 e2 e3) v
    | E_IfF   : forall (E : Env) (e1 e2 e3 : Exp) (v : Value),
                EvalTo E e1 (VBool false) -> EvalTo E e3 v ->
                EvalTo E (EIf e1 e2 e3) v
    | E_Let   : forall (E : Env) (e1 e2 : Exp) (x : Var) (v1 v : Value),
                EvalTo E e1 v1 -> EvalTo (ECons E x v1) e2 v ->
                EvalTo E (ELet x e1 e2) v.

(* Lemma 4.2 *)
Lemma EvalTo_Var_uniq :
    forall (E : Env) (x : Var) (v v' : Value),
    EvalTo E (EVar x) v -> EvalTo E (EVar x) v' -> v = v'.
Proof.
    induction E as [| E0 H0 x0 v0].

        (* Case : E = ENil *)
        intros x v v' H H'.
        inversion H.

        (* Case : E = ECons E0 x0 v0 *)
        intros x v v' H H'.
        inversion H; subst.

            (* Case : H is from E_Var1 *)
            inversion H'; subst.

                (* Case : H' is from E_Var1 *)
                reflexivity.

                (* Case : H' is from E_Var2 *)
                contradict H6.
                reflexivity.

            (* Case : H' is from E_Var2 *)
            inversion H'; subst.

                (* Case : H' is from E_Var1 *)
                contradict H6.
                reflexivity.

                (* Case : H' is from E_Var2 *)
                apply (H0 _ _ _ H7 H9).
Qed.

(* Theorem 4.1 *)
Theorem EvalTo_uniq :
    forall (E : Env) (e : Exp) (v v' : Value),
    EvalTo E e v -> EvalTo E e v' -> v = v'.
Proof.
    intros E e.
    generalize dependent E.
    induction e as [[i | b] | x |
                    e1 He1 e2 He2 | e1 He1 e2 He2 | e1 He1 e2 He2 |
                    e1 He1 e2 He2 | e1 He1 e2 He2 e3 He3 | x e1 He1 e2 He2 ].

        (* Case : e = VInt i *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        reflexivity.

        (* Case : e = VBool b *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        reflexivity.

        (* Case : e = EVar x *)
        intros E v1 v2 H1 H2.
        apply (EvalTo_Var_uniq _ _ _ _ H1 H2).

        (* Case : e = EPlus e1 e2 *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        assert (VInt i1 = VInt i0) as Hi1 by apply (He1 _ _ _ H3 H4).
        inversion Hi1; subst; clear Hi1.
        assert (VInt i2 = VInt i4) as Hi2 by apply (He2 _ _ _ H5 H8).
        inversion Hi2; subst; clear Hi2.
        assert (i3 = i5) by apply (Plus_uniq _ _ _ _ H7 H10); subst.
        reflexivity.

        (* Case : e = EMinus e1 e2 *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        assert (VInt i1 = VInt i0) as Hi1 by apply (He1 _ _ _ H3 H4).
        inversion Hi1; subst; clear Hi1.
        assert (VInt i2 = VInt i4) as Hi2 by apply (He2 _ _ _ H5 H8).
        inversion Hi2; subst; clear Hi2.
        assert (i3 = i5) by apply (Minus_uniq _ _ _ _ H7 H10); subst.
        reflexivity.

        (* Case : e = ETimes e1 e2 *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        assert (VInt i1 = VInt i0) as Hi1 by apply (He1 _ _ _ H3 H4).
        inversion Hi1; subst; clear Hi1.
        assert (VInt i2 = VInt i4) as Hi2 by apply (He2 _ _ _ H5 H8).
        inversion Hi2; subst; clear Hi2.
        assert (i3 = i5) by apply (Times_uniq _ _ _ _ H7 H10); subst.
        reflexivity.

        (* Case : e = ELt e1 e2 *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        assert (VInt i1 = VInt i0) as Hi1 by apply (He1 _ _ _ H3 H4).
        inversion Hi1; subst; clear Hi1.
        assert (VInt i2 = VInt i3) as Hi2 by apply (He2 _ _ _ H5 H8).
        inversion Hi2; subst; clear Hi2.
        assert (b3 = b0) by apply (Lt_uniq _ _ _ _ H7 H10); subst.
        reflexivity.

        (* Case : e = EIf e1 e2 e3 *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.

            (* Case : EvalTo e1 (VBool true) *)
            inversion H2; subst.

                (* Case : EvalTo e2 (VBool true) *)
                apply (He2 _ _ _ H7 H9).

                (* Case : EvalTo e2 (VBool false) *)
                discriminate (He1 _ _ _ H6 H8).

            (* Case : EvalTo e1 (VBool false) *)
            inversion H2; subst.

                (* Case : EvalTo e2 (VBool true) *)
                discriminate (He1 _ _ _ H6 H8).

                (* Case : EvalTo e2 (VBool false) *)
                apply (He3 _ _ _ H7 H9).

        (* Case : e = ELet x e1 e2 *)
        intros E v1 v2 H1 H2.
        inversion H1; subst.
        inversion H2; subst.
        assert (v0 = v3) by apply (He1 _ _ _ H6 H8) ; subst.
        apply (He2 _ _ _ H7 H9).
Qed.

(* Free variables at p.72 *)
Inductive is_FV : Exp -> Var -> Prop :=
    | FV_Var     : forall x : Var, is_FV (EVar x) x
    | FV_Plus_l  : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (EPlus e1 e2) x
    | FV_Plus_r  : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (EPlus e1 e2) x
    | FV_Minus_l : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (EMinus e1 e2) x
    | FV_Minus_r : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (EMinus e1 e2) x
    | FV_Times_l : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (ETimes e1 e2) x
    | FV_Times_r : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (ETimes e1 e2) x
    | FV_Lt_l    : forall (e1 e2 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (ELt e1 e2) x
    | FV_Lt_r    : forall (e1 e2 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (ELt e1 e2) x
    | FV_If      : forall (e1 e2 e3 : Exp) (x : Var),
                   is_FV e1 x -> is_FV (EIf e1 e2 e3) x
    | FV_IfT     : forall (e1 e2 e3 : Exp) (x : Var),
                   is_FV e2 x -> is_FV (EIf e1 e2 e3) x
    | FV_IfF     : forall (e1 e2 e3 : Exp) (x : Var),
                   is_FV e3 x -> is_FV (EIf e1 e2 e3) x
    | FV_Let1    : forall (e1 e2 : Exp) (x y : Var),
                   is_FV e1 x -> is_FV (ELet y e1 e2) x
    | FV_Let2    : forall (e1 e2 : Exp) (x y : Var),
                   is_FV e2 x -> x <> y -> is_FV (ELet y e1 e2) x.

(* Domains at p.73 *)
Inductive in_dom : Env -> Var -> Prop :=
    | Dom_ECons1 : forall (E : Env) (x : Var) (v : Value),
                   in_dom (ECons E x v) x
    | Dom_ECons2 : forall (E : Env) (x y : Var) (v : Value),
                   in_dom E x -> in_dom (ECons E y v) x.

(* Errors at p.75 *)
Inductive Error : Env -> Exp -> Prop :=
    | E_IfInt       : forall (E : Env) (e1 e2 e3 : Exp) (i : Z),
                      EvalTo E e1 (VInt i) -> Error E (EIf e1 e2 e3)
    | E_PlusBoolL   : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e1 (VBool b) -> Error E (EPlus e1 e2)
    | E_PlusBoolR   : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e2 (VBool b) -> Error E (EPlus e1 e2)
    | E_MinusBoolL  : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e1 (VBool b) -> Error E (EMinus e1 e2)
    | E_MinusBoolR  : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e2 (VBool b) -> Error E (EMinus e1 e2)
    | E_TimesBoolL  : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e1 (VBool b) -> Error E (ETimes e1 e2)
    | E_TimesBoolR  : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e2 (VBool b) -> Error E (ETimes e1 e2)
    | E_LtBoolL     : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e1 (VBool b) -> Error E (ELt e1 e2)
    | E_LtBoolR     : forall (E : Env) (e1 e2 : Exp) (b : bool),
                      EvalTo E e2 (VBool b) -> Error E (ELt e1 e2)
    | E_IfError     : forall (E : Env) (e1 e2 e3 : Exp),
                      Error E e1 -> Error E (EIf e1 e2 e3)
    | E_IfTError    : forall (E : Env) (e1 e2 e3 : Exp),
                      EvalTo E e1 (VBool true) -> Error E e2 ->
                      Error E (EIf e1 e2 e3)
    | E_IfFError    : forall (E : Env) (e1 e2 e3 : Exp),
                      EvalTo E e1 (VBool false) -> Error E e3 ->
                      Error E (EIf e1 e2 e3)
    | E_PlusErrorL  : forall (E : Env) (e1 e2 : Exp),
                      Error E e1 -> Error E (EPlus e1 e2)
    | E_PlusErrorR  : forall (E : Env) (e1 e2 : Exp),
                      Error E e2 -> Error E (EPlus e1 e2)
    | E_MinusErrorL : forall (E : Env) (e1 e2 : Exp),
                      Error E e1 -> Error E (EMinus e1 e2)
    | E_MinusErrorR : forall (E : Env) (e1 e2 : Exp),
                      Error E e2 -> Error E (EMinus e1 e2)
    | E_TimesErrorL : forall (E : Env) (e1 e2 : Exp),
                      Error E e1 -> Error E (ETimes e1 e2)
    | E_TimesErrorR : forall (E : Env) (e1 e2 : Exp),
                      Error E e2 -> Error E (ETimes e1 e2)
    | E_LtErrorL    : forall (E : Env) (e1 e2 : Exp),
                      Error E e1 -> Error E (ELt e1 e2)
    | E_LtErrorR    : forall (E : Env) (e1 e2 : Exp),
                      Error E e2 -> Error E (ELt e1 e2)
    | E_LetError1   : forall (E : Env) (x : Var) (e1 e2 : Exp),
                      Error E e1 -> Error E (ELet x e1 e2)
    | E_LetError2   : forall (E : Env) (x : Var) (v : Value) (e1 e2 : Exp),
                      EvalTo E e1 v -> Error (ECons E x v) e2 ->
                      Error E (ELet x e1 e2).

(* Theorem 4.3 *)
Theorem EvalTo_Error_total :
    forall (E : Env) (e : Exp),
    (forall x : Var, is_FV e x -> in_dom E x) ->
    (exists v : Value, EvalTo E e v) \/ Error E e.
Proof.
    intros E e.
    generalize dependent E.
    induction e as [[i | b] | x |
                    e1 He1 e2 He2 | e1 He1 e2 He2 | e1 He1 e2 He2 |
                    e1 He1 e2 He2 | e1 He1 e2 He2 e3 He3 | x e1 He1 e2 He2].

        (* Case : e = VInt i *)
        intros E H.
        left.
        exists (VInt i).
        apply E_Int.

        (* Case : e = VBool b *)
        intros E H.
        left.
        exists (VBool b).
        apply E_Bool.

        (* Case : e = EVar x *)
        intros E H.
        specialize (H x (FV_Var _)).
        induction H as [E0 x v | E0 x y v H0 H].

            (* Case : E = ECons E0 x v *)
            left.
            exists v.
            apply E_Var1.

            (* Case : in_dom E0 x *)
            destruct (Var_eq_dec x y) as [D | D].

                (* Case : x = y *)
                subst.
                left.
                exists v.
                apply E_Var1.

                (* Case : x <> y *)
                destruct H as [[v' H] | H].

                    (* Case : EvalTo E0 (EVar x) v' *)
                    left.
                    exists v'.
                    apply (E_Var2 E0 _ _ _ _ D H).

                    (* Case : Error E0 (EVar x) *)
                    inversion H.

        (* Case : e = EPlus e1 e2 *)
        intros E H.
        assert (forall x : Var, is_FV e1 x -> in_dom E x) as HFV1.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Plus_l _ _ _ Hx).

        assert (forall x : Var, is_FV e2 x -> in_dom E x) as HFV2.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Plus_r _ _ _ Hx).

        specialize (He1 E HFV1); clear HFV1.
        specialize (He2 E HFV2); clear HFV2.
        destruct He1 as [[[i1 | b1] He1] | He1].

            (* Case : EvalTo E e1 (VInt i1) *)
            destruct He2 as [[[i2 | b2] He2] | He2].

                (* Case : EvalTo E e2 (VInt i2) *)
                left.
                exists (VInt (i1 + i2)).
                apply (E_Plus _ _ _ (EValue (VInt (i1 + i2))) _ _ _ He1 He2).
                apply B_Plus.
                reflexivity.

                (* Case : EvalTo E e2 (VBool b2) *)
                right.
                apply (E_PlusBoolR _ _ _ _ He2).

                (* Case : Error E e2 *)
                right.
                apply (E_PlusErrorR _ _ _ He2).

            (* Case : EvalTo E e1 (VBool b1) *)
            right.
            apply (E_PlusBoolL _ _ _ _ He1).

            (* Case : Error E e1 *)
            right.
            apply (E_PlusErrorL _ _ _ He1).

        (* Case : e = EMinus e1 e2 *)
        intros E H.
        assert (forall x : Var, is_FV e1 x -> in_dom E x) as HFV1.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Minus_l _ _ _ Hx).

        assert (forall x : Var, is_FV e2 x -> in_dom E x) as HFV2.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Minus_r _ _ _ Hx).

        specialize (He1 E HFV1); clear HFV1.
        specialize (He2 E HFV2); clear HFV2.
        destruct He1 as [[[i1 | b1] He1] | He1].

            (* Case : EvalTo E e1 (VInt i1) *)
            destruct He2 as [[[i2 | b2] He2] | He2].

                (* Case : EvalTo E e2 (VInt i2) *)
                left.
                exists (VInt (i1 - i2)).
                apply (E_Minus _ _ _ (EValue (VInt (i1 - i2))) _ _ _ He1 He2).
                apply B_Minus.
                reflexivity.

                (* Case : EvalTo E e2 (VBool b2) *)
                right.
                apply (E_MinusBoolR _ _ _ _ He2).

                (* Case : Error E e2 *)
                right.
                apply (E_MinusErrorR _ _ _ He2).

            (* Case : EvalTo E e1 (VBool b1) *)
            right.
            apply (E_MinusBoolL _ _ _ _ He1).

            (* Case : Error E e1 *)
            right.
            apply (E_MinusErrorL _ _ _ He1).

        (* Case : e = ETimes e1 e2 *)
        intros E H.
        assert (forall x : Var, is_FV e1 x -> in_dom E x) as HFV1.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Times_l _ _ _ Hx).

        assert (forall x : Var, is_FV e2 x -> in_dom E x) as HFV2.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Times_r _ _ _ Hx).

        specialize (He1 E HFV1); clear HFV1.
        specialize (He2 E HFV2); clear HFV2.
        destruct He1 as [[[i1 | b1] He1] | He1].

            (* Case : EvalTo E e1 (VInt i1) *)
            destruct He2 as [[[i2 | b2] He2] | He2].

                (* Case : EvalTo E e2 (VInt i2) *)
                left.
                exists (VInt (i1 * i2)).
                apply (E_Times _ _ _ (EValue (VInt (i1 * i2))) _ _ _ He1 He2).
                apply B_Times.
                reflexivity.

                (* Case : EvalTo E e2 (VBool b2) *)
                right.
                apply (E_TimesBoolR _ _ _ _ He2).

                (* Case : Error E e2 *)
                right.
                apply (E_TimesErrorR _ _ _ He2).

            (* Case : EvalTo E e1 (VBool b1) *)
            right.
            apply (E_TimesBoolL _ _ _ _ He1).

            (* Case : Error E e1 *)
            right.
            apply (E_TimesErrorL _ _ _ He1).

        (* Case : e = ELt e1 e2 *)
        intros E H.
        assert (forall x : Var, is_FV e1 x -> in_dom E x) as HFV1.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Lt_l _ _ _ Hx).

        assert (forall x : Var, is_FV e2 x -> in_dom E x) as HFV2.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_Lt_r _ _ _ Hx).

        specialize (He1 E HFV1); clear HFV1.
        specialize (He2 E HFV2); clear HFV2.
        destruct He1 as [[[i1 | b1] He1] | He1].

            (* Case : EvalTo E e1 (VInt i1) *)
            destruct He2 as [[[i2 | b2] He2] | He2].

                (* Case : EvalTo E e2 (VInt i2) *)
                left.
                exists (VBool (i1 <? i2)).
                apply (E_Lt _ _ _ _ _ _ He1 He2).
                apply B_Lt.
                reflexivity.

                (* Case : EvalTo E e2 (VBool b2) *)
                right.
                apply (E_LtBoolR _ _ _ _ He2).

                (* Case : Error E e2 *)
                right.
                apply (E_LtErrorR _ _ _ He2).

            (* Case : EvalTo E e1 (VBool b1) *)
            right.
            apply (E_LtBoolL _ _ _ _ He1).

            (* Case : Error E e1 *)
            right.
            apply (E_LtErrorL _ _ _ He1).

        (* Case : e = EIf e1 e2 e3 *)
        intros E H.
        assert (forall x : Var, is_FV e1 x -> in_dom E x) as HFV1.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_If _ _ _ _ Hx).

        assert (forall x : Var, is_FV e2 x -> in_dom E x) as HFV2.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_IfT _ _ _ _ Hx).

        assert (forall x : Var, is_FV e3 x -> in_dom E x) as HFV3.

            (* Proof of the assertion *)
            intros x Hx.
            apply H.
            apply (FV_IfF _ _ _ _ Hx).

        specialize (He1 E HFV1); clear HFV1.
        specialize (He2 E HFV2); clear HFV2.
        specialize (He3 E HFV3); clear HFV3.
        destruct He1 as [[[i | [|]] He1]| He1].

            (* Case : EvalTo E e1 (VInt i) *)
            right.
            apply (E_IfInt _ _ _ _ _ He1).

            (* Case : EvalTo E e1 (VBool true *)
            destruct He2 as [[v He2] | He2].

                (* Case : EvalTo E e2 v *)
                left.
                exists v.
                apply (E_IfT _ _ _ _ _ He1 He2).

                (* Case : Error E e2 *)
                right. Print E_IfTError.
                apply (E_IfTError _ _ _ _ He1 He2).

            (* Case : EvalTo E e1 (VBool false) *)
            destruct He3 as [[v He3] | He3].

                (* Case : EvalTo E e3 v *)
                left.
                exists v.
                apply (E_IfF _ _ _ _ _ He1 He3).

                (* Case : Error E e3 *)
                right.
                apply (E_IfFError _ _ _ _ He1 He3).

            (* Case : Error E e1 *)
            right.
            apply (E_IfError _ _ _ _ He1).

        (* Case : e = ELet v e1 e2 *)
        intros E H.
        assert (forall x : Var, is_FV e1 x -> in_dom E x) as HFV1.

            (* Proof of the assertion *)
            intros x0 Hx0.
            apply H.
            apply (FV_Let1 _ _ _ _ Hx0).

        specialize (He1 E HFV1); clear HFV1.
        destruct He1 as [[v He1] | He1].

            (* Case : EvalTo E e1 v *)
            assert (forall x0 : Var,
                    is_FV e2 x0 -> in_dom (ECons E x v) x0) as HFV2.

                (* Proof of the assertion *)
                intros y Hy.
                destruct (Var_eq_dec y x) as [D | D].

                    (* Case : y = x *)
                    subst.
                    apply Dom_ECons1.

                    (* Case : y <> x *)
                    apply Dom_ECons2.
                    apply H.
                    apply (FV_Let2 _ _ _ _ Hy D).

                specialize (He2 (ECons E x v) HFV2); clear HFV2.
                destruct He2 as [[v' He2]| He2].

                    (* Case : EvalTo (ECons E x v) e2 v' *)
                    left.
                    exists v'.
                    apply (E_Let _ _ _ _ _ _ He1 He2).

                    (* Case : Error (ECons E x v) e2 *)
                    right.
                    apply (E_LetError2 _ _ _ _ _ He1 He2).

            (* Case : Error E e1 *)
            right.
            apply (E_LetError1 _ _ _ _ He1).
Qed.

End Definitions.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* ** Object-level encoding of exponential *)

Require Import Arith ZArith List.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac sums rel_iter gcd.

From Undecidability.H10.Matija
  Require Import alpha expo_diophantine.

From Undecidability.H10.Dio
  Require Import dio_logic.

Set Implicit Arguments.

Local Notation power := (mscal mult 1).
Local Notation expo := (mscal mult 1).

(* Here one can witness how workable is automation of recognition
    of Diophantine shapes.

    Notice that alpha_conditions below could probably be optimized
    from the new Diophantine shapes that include Diophantine
    functions. *)

Local Notation "x ≐ ⌞ n ⌟" := (df_cst x n)
      (at level 49, no associativity, format "x  ≐  ⌞ n ⌟").
Local Notation "x ≐ y" := (df_eq x y)
      (at level 49, no associativity, format "x  ≐  y").
Local Notation "x ≐ y ⨢ z" := (df_add x y z)
      (at level 49, no associativity, y at next level, format "x  ≐  y  ⨢  z").
Local Notation "x ≐ y ⨰ z" := (df_mul x y z)
      (at level 49, no associativity, y at next level, format "x  ≐  y  ⨰  z").

Theorem dio_rel_alpha a b c : 𝔻F a -> 𝔻F b -> 𝔻F c
                           -> 𝔻R (fun ν => 3 < b ν /\ a ν = alpha_nat (b ν) (c ν)).
Proof.
  dio by lemma (fun v => alpha_diophantine (a v) (b v) (c v)).
Defined.

#[export] Hint Resolve dio_rel_alpha : dio_rel_db.

Local Fact dio_rel_alpha_example : 𝔻R (fun ν => 3 < ν 1 /\ ν 0 = alpha_nat (ν 1) (ν 2)).
Proof. dio auto. Defined.

(* Eval compute in df_size_Z (proj1_sig dio_rel_alpha_example). *)

Fact dio_rel_alpha_size : df_size_Z (proj1_sig dio_rel_alpha_example) = 1445%Z.
Proof. reflexivity. Qed.

(* This is Matiyasevich theorem stating that q^r is a Diophantine function.

    Notice that expo_conditions below could also probably be optimized *)

Theorem dio_fun_expo q r : 𝔻F q -> 𝔻F r -> 𝔻F (fun ν => expo (r ν) (q ν)).
Proof.
  dio by lemma (fun v => expo_diophantine (v 0) (q v⭳) (r v⭳)).
Defined.

#[export] Hint Resolve dio_fun_expo : dio_fun_db.

Local Fact dio_fun_expo_example : 𝔻F (fun ν => expo (ν 0) (ν 1)).
Proof. dio auto. Defined.

(* Eval compute in df_size_Z (proj1_sig dio_fun_expo_example). *)

(* The new Diophantine shapes (w/o build-in polynimoals)
   build formulas that are a bit bigger ... *)

Local Fact dio_fun_expo_example_size : df_size_Z (proj1_sig dio_fun_expo_example) = 4903%Z.
Proof. reflexivity. Qed.

(* We use the exponantial to characterize digits *)

(* The is_digit c q i y relation stating that

       "y is the i-th digit of c is base q"
 *)

Local Fact is_digit_eq c q i y :
            is_digit c q i y
        <-> y < q
         /\ exists a b p, c = (a*q+y)*p+b
                       /\ b < p
                       /\ p = power i q.
Proof.
  split; intros (H1 & a & b & H2).
  + split; auto; exists a, b, (power i q); repeat split; tauto.
  + destruct H2 as (p & H2 & H3 & H4).
    split; auto; exists a, b; subst; auto.
Qed.

Lemma dio_rel_is_digit c q i y : 𝔻F c -> 𝔻F q -> 𝔻F i -> 𝔻F y
                              -> 𝔻R (fun ν => is_digit (c ν) (q ν) (i ν) (y ν)).
Proof.
  dio by lemma (fun ν => is_digit_eq (c ν) (q ν) (i ν) (y ν)).
Defined.

#[export] Hint Resolve dio_rel_is_digit : dio_rel_db.

Local Fact dio_rel_is_digit_example : 𝔻R (fun ν => is_digit (ν 0) (ν 1) (ν 2) (ν 3)).
Proof. dio auto. Defined.

(* Check dio_rel_is_digit_example. *)
(* Eval compute in df_size_Z (proj1_sig dio_rel_is_digit_example). *)


From Coq Require Import Lists.List.
From Coq Require Import omega.Omega.
Import ListNotations.

(* Useful Lemmas on lists *)
Lemma app_singleton : forall {X : Type} (A B : X) l1 l2,
    [A] = l1 ++ [B] ++ l2 -> l1 = [] /\ l2 = [] /\ A = B.
Proof.
  intros.
  destruct l1.
  - simpl in *.
    injection H.
    intros.
    subst.
    auto.
  - injection H.
    intros.
    destruct l1.
    + simpl in *.
      discriminate.
    + simpl in *.
      discriminate.
Qed.

Proposition same_length :
  forall {X : Type} (l1 l2 l3 l4 : list X),
    length l1 = length l3 ->
    l1 ++ l2 = l3 ++ l4 ->
    l1 = l3.
Proof.
  intros X l1.
  induction l1.
  - simpl in *.
    intros.
    assert (0 = (length l3) -> length l3 = 0) by omega.
    apply H1 in H.
    apply length_zero_iff_nil in H.
    auto.
  - intros.
    simpl in *.
    destruct l3.
    * simpl in *.
      discriminate.
    * simpl in *.
      injection H.
      intros.
      specialize (IHl1 l2 l3 l4 H1).
      injection H0.
      intros.
      specialize (IHl1 H2).
      subst.
      auto.
Qed.

Lemma element_in_app :
  forall {X : Type} (l1 l2 l3 l4 : list X) A,
    l1 ++ l2 = l3 ++ [A] ++ l4
    ->
    (In A l1 /\ length l3 < length l1 /\
     exists l, l1 = l3 ++ [A] ++ l)
    \/
    (In A l2 /\ length l1 <= length l3 /\
     exists l,  l2 = l ++ [A] ++ l4).
Proof.
  intros X l1 l2 l3 l4 A H.
  assert (either:
            length l1 = length l3 \/
            length l3 < length l1 \/
            length l1 < length l3)
         by omega.
  destruct  either.

  (* length l1 = length l3 *)
  - inversion H.
    apply (same_length l1 l2 l3 (A::l4) H0) in H2.
    subst.
    apply app_inv_head in H.
    subst.
    right.
    split.
    + simpl.
      left.
      auto.
    + split.
      * omega.
      * exists [].
        reflexivity.

  (* remaining cases *)
  - destruct H0.

    (* length l1 > length l3, hence A is in l1 *)
    + left.
      generalize dependent l4.
      generalize dependent l3.
      generalize dependent l2.
      {
        induction l1.
        -  intros.
           simpl in *.
           omega.
        - intros.
          destruct l3.
          * simpl in *.
            inversion H.
            subst.
            split.
            + left; auto.
            + split. omega. exists l1. auto.
          * simpl in *.
            inversion H.
            subst.
            apply lt_S_n in H0.
            specialize (IHl1 l2 l3 H0 l4 H3).
            destruct IHl1.
            split.
            + right; auto.
            + {
                split.
                - omega.
                - destruct H2 as [eq1 [l eq2]].
                  subst.
                  injection H.
                  intros Hyp1.
                  rewrite <- app_assoc in Hyp1.
                  apply app_inv_head in Hyp1.
                  inversion Hyp1.
                  subst.
                  assert (eq: (x :: (l3 ++ A :: l)) ++ l2 =
                              (x :: l3 ++ A :: l) ++ l2)
                    by auto.
                  apply app_inv_tail in eq.
                  exists l.
                  auto.
              }
      }

    (* length l3 > length l1, hence A is in l2 *)
    + right.
      generalize dependent l4.
      generalize dependent l3.
      generalize dependent l2.
      {
        induction l1.
        - intros.
          simpl in *.
          subst.
          split.
          * apply in_or_app.
            right.
            simpl.
            left.
            auto.
          * split.
            omega.
            exists l3.
            auto.

        - destruct l3.
          * intros.
            simpl in *.
            omega.
          * intros.
            simpl in *.
            injection H.
            intros.
            subst.
            apply lt_S_n in H0.
            specialize (IHl1 l2 l3 H0 l4 H1 ).
            destruct IHl1.
            split.
            + auto.
            + split.
              omega.
              destruct H3.
              destruct H4.
              exists x0.
              subst.
              auto.
      }
Qed.

Lemma element_in_app_head :
  forall {X : Type} (l2 l3 l4 : list X) A B,
    A :: l2 = l3 ++ [B] ++ l4
    ->
    l3 = [] /\ A=B /\ l2 = l4
    \/
    exists l,  l2 = l ++ [B] ++ l4.
Proof.
  intros.
  assert (H': [A] ++ l2 = l3 ++ [B] ++ l4) by auto.
  apply element_in_app in H'.
  destruct H' as [Left | Right].
  - destruct Left as [ _ [ _ [l H']]].
    apply app_singleton in H'.
    destruct H' as [t1 [t2 t3]].
    left.
    subst.
    inversion H.
    subst.
    auto.
  - destruct Right as [_ [ _ [ l H']]].
    subst.
    right.
    assert (eq: (A :: l) ++ [B] ++ l4 = l3 ++ [B] ++ l4)
      by auto.
    apply app_inv_tail in eq.
    subst.
    exists l; auto.
Qed.

Lemma elements_in_app :
  forall {X : Type} (l1 l2 l3 l4 : list X) A B C,
    l1 ++ [A] ++ [B] ++ l2 = l3 ++ [C] ++ l4
    ->
    (In C l1 /\ exists l, l1 = l3 ++ [C] ++ l)
    \/
    (C = A /\ l1 = l3 /\ [B] ++ l2 = l4)
    \/
    (C = B /\ l1 ++ [A] = l3 /\ l2 = l4)
    \/
    (In C l2 /\ exists l, l2 = l ++ [C] ++ l4).
Proof.
  intros.

  assert (either:
            length l3 < length l1 \/
            length l1 = length l3 \/
            length l1 + 1 = length l3 \/
            length l1 + 2 <= length l3)
    by omega.

  destruct  either.

  (* Case in which |l3| < |l1| *)
  - left.
    generalize dependent l4.
    generalize dependent l3.
    generalize dependent l2.
    {
      induction l1.
      -  intros.
         simpl in *.
         omega.
      - intros.
        destruct l3.
        * simpl in *.
          injection H.
          intros.
          subst.
          split.
          + left. auto.
          + exists l1. auto.
        * simpl in *.
          injection H.
          intros.
          subst.
          apply lt_S_n in H0.
          specialize (IHl1 l2 l3 H0 l4 H1 ).
          destruct IHl1.
          split.
          + right. auto.
          + destruct H3.
            exists x0.
            subst.
            auto.
    }

  (* remaining cases *)
  - { destruct H0.

      (* Case in which |l1| = |l3| *)
      - inversion H.
        apply (same_length l1 (A::B::l2) l3 (C::l4) H0) in H2.
        subst.
        apply app_inv_head in H.
        simpl in *.
        injection H.
        intros.
        subst.
        right. left.
        split; auto.

      (* remaining cases *)
      - { destruct H0.

          (* Case in whcih |l1| + 1 = |l3| *)
          - inversion H.
            assert (length (l1 ++ [A]) = length l3).
            { rewrite app_length.
              simpl.
              auto.
            }
            right. right. left.
            rewrite app_assoc in H.
            apply
              (same_length (l1 ++ [A]) (B::l2) l3 (C::l4) H1)
              in H.
            subst.
            rewrite <- app_assoc in H2.
            apply app_inv_head in H2.
            simpl in *.
            injection H2.
            intros.
            subst.
            split; auto.

          (* Case in whcih |l1| + 2 <= |l3| *)
          - right. right. right.
            rewrite app_assoc in H.
            rewrite app_assoc in H.
            apply
              (element_in_app
                 ((l1 ++ [A]) ++ [B])
                 l2
                 l3
                 l4
                 C) in H.
            destruct H.
            + destruct H.
              destruct H1.
              repeat rewrite app_length in H1.
              simpl in *.
              omega.

            + destruct H.
              destruct H1.
              split.
              * auto.
              * destruct H2.
                exists x.
                auto.
        }
    }
Qed.

Lemma tail_list :
  forall {X : Type} (l : list X),
    l = []
    \/
    exists l' A,  l = l' ++ [A].
Proof.
  induction l.
  - left. auto.
  - right.
    destruct IHl.
    * subst.
      exists [].
      exists a.
      auto.
    * destruct H.
      destruct H.
      subst.
      exists (a :: x).
      exists x0.
      auto.
Qed.