(* Require Import Paco.paco. *)

(* ViNo - VerIfiable Nock *)
(* The aim of this project is to provide a Nock interpreter
   with jets whose semantic equivalence can be verified w/r/t
   the Gallina (eventually, OCaml) code that uses them *)

Require Import Common.
(* Require Import Applicative *)
(* Require Import NockParse *)
Require Import ZArith.

(* NB we use positive (Z) because without them we will
   spend stupendous amounts
   of time just reading our input *)
Section Nock.

  Open Scope N.

  Inductive noun : Set :=
  | atom : N -> noun
  | cell : noun -> noun -> noun
  .

  Inductive instr : Set :=
  | slice : instr
  | const : instr
  | nock : instr
  | isatom : instr
  | succ : instr
  | equ : instr
  .

  Definition toinstr (n : N) : sum instr N :=
    match n with
    | 0 => inl slice
    | 1 => inl const
    | 2 => inl nock
    | 3 => inl isatom
    | 4 => inl succ
    | 5 => inl equ
    | _ => inr n
    end
  .

  (* Indexing a noun as a tree ("slot")
     Notice how big of a bullet we dodged here.
   *)
  Fixpoint slice_rec (n : positive) (nn : noun) : noun :=
    match n with
    | xH => nn
    | xO n' =>
      match slice_rec n' nn with
      | cell a1 a2 => a1
      | _ => nn
      end
    | xI n' =>
      match slice_rec n' nn with
      | cell a1 a2 => a2
      | _ => nn
      end
    end.

  Coercion atom : N >-> noun.

  Definition slice' (nn b : noun) : noun :=
    match nn with
    | atom (Npos n)  => slice_rec n b
    | _ => nn
    end.

  Definition isatom' (n : noun) : noun :=
    match n with
    | cell _ _ => atom 0
    | atom n => atom 1
    end.

  Definition succ' (n : noun) : noun :=
    match n with
    | atom n => atom (n + 1)
    | cell _ _ => n
    end.

  Definition eq' (n : noun) : noun :=
    match n with
    | cell (atom a) (atom b) =>
      if N.eqb a b
      then atom 0
      else atom 1
    | _ => n
    end.

  Fixpoint nock' (fuel : nat) (subj : noun) (form : noun) : option noun :=
    match fuel with
    | O => None
    | S fuel =>
      match form with
      | cell (atom n) arg =>
        match (toinstr n) with
        | inl i => match i with
                  | slice => Some $ slice' arg subj
                  | const => Some arg
                  | nock =>
                    match arg with
                    | cell b c =>
                      match nock' fuel subj b, nock' fuel subj c with
                      | Some l, Some r => nock' fuel l r
                      | _, _ => None
                      end
                    | _ => Some $ cell subj form
                    end
                  | isatom =>
                    match nock' fuel subj arg with
                    | Some x => Some $ isatom' x
                    | _ => None
                    end
                  | succ =>
                    match nock' fuel subj arg with
                    | Some x => Some $ succ' x
                    | _ => None
                    end
                  | equ =>
                    match nock' fuel subj arg with
                    | Some x => Some $ eq' x
                    | _ => None
                    end
                  end
        | inr _ _ => Some subj
        end
      | _ => Some subj
      end
    end.

End Nock.

(* Inspired by ImpParser, we use strings to represent nouns
   to get around a limitation of Coq's parser *)

Section NockParse.
  Require Import Coq.Strings.String.
  Require Import Coq.Strings.Ascii.

  Open Scope string_scope.

  (* Utilities, lovingly lifted from Software Foundations (ImpParser.v) *)
  Definition isWhite (c : ascii) : bool :=
    let n := nat_of_ascii c in
    orb (orb (beq_nat n 32) (* space *)
             (beq_nat n 9)) (* tab *)
        (orb (beq_nat n 10) (* linefeed *)
             (beq_nat n 13)). (* Carriage return. *)

  SearchAbout (nat -> N).

  Definition getDigit (c : ascii) : option N :=
    let n := nat_of_ascii c in
    if andb (48 <=? n) (n <=? 57)
    then Some $ N.of_nat (n - 48)%nat
    else None.

  Definition isObrac (c : ascii) : bool :=
    beq_nat $ nat_of_ascii c $ 91%nat.

  Definition isCbrac (c : ascii) : bool :=
    beq_nat $ nat_of_ascii c $ 93%nat.

  Inductive token :=
  | OBRAC : token
  | CBRAC : token
  | NUM : N -> token
  .

  (* Lex' takes:
     s: remaining  string to lex
     n: accumulated N so far *)

  Require Import Coq.Lists.List.
  Import ListNotations.
  Open Scope list_scope.

  (* log, needed for pretty printer *)

  Print Init.Nat.log2.
  Print Init.Nat.log2_iter.
  Require Import Coq.Arith.PeanoNat.

  SearchAbout (nat -> nat -> nat).

  (* I'm skeptical about this. *)
  Definition log (base : nat) (n : nat) :=
    (Nat.log2 n / Nat.log2 base).
(*
  Fixpoint log10' (n : nat) (place : nat) (newskip : nat) (skip : nat) : nat :=
    match n with
    | 0%nat => place
    | 1%nat => place
    | 2%nat => place
    | 3%nat => place
    | 4%nat => place
    | 5%nat => place
    | 6%nat => place
    | 7%nat => place
    | 8%nat => place
    | 9%nat => place
    | S n' =>
      match skip with
      | O => log10' n' (S place) (S place) newskip
      | S skip' => log10' n' place (S newskip) skip'
      end
    end.
 *)
  (* this is not correct. *)
    Definition log10 (n : nat) : nat :=
      log 10 n.

    Eval compute in (log10 120).

    (* Open Scope N *)
    Open Scope nat.

    Opaque apply.

    Fixpoint foopoint (n : nat) :=
      match n with
      | O => O
      | S n' => apply (fun i => foopoint i) n'
      end.

  Fixpoint lex' (s : string) (n : option N) : list token :=
    match s with
    | String a s' =>
      if
        isObrac a then
        match n with
        | Some d' => NUM d' :: OBRAC :: lex' s' None
        | _ => OBRAC :: lex' s' None
        end
      else if
          isCbrac a then
          match n with
          | Some d' => NUM d' :: CBRAC :: lex' s' None
          | _ => CBRAC :: lex' s' None
          end
        else
          match getDigit a with
          | Some d =>
            match n with
            | Some d' => lex' s' (Some $ 10 * d' + d)
            | None => lex' s' $ Some d
            end
          | _ =>
            if isWhite a then
              match n with
              | Some d' => NUM d' :: lex' s' None
              | _ => lex' s' None
              end
            else []
          end
    | EmptyString =>
      match n with
      | Some n => NUM n :: nil
      | _ => nil
      end
    end.

  Definition lex (s : string) : list token :=
    lex' s None.

  Ltac step :=
    match goal with
    | |- context[?L = _] => eval red in L
    end.

  Print Init.Nat.log2_iter.
  Print Init.Nat.log2.

  (* TODO: decanonize, removing as many brackets as possible *)

  Fixpoint explode (s : string) : list ascii :=
    match s with
    | EmptyString => []
    | String a s' => a :: explode s'
    end.

  Definition lascii := list ascii.

  Coercion explode : string >-> list.

  Fixpoint implode (l : list ascii) : string :=
    match l with
    | [] => EmptyString
    | a :: l' => String a $ implode l'
    end.

  Eval compute in (ascii_of_N 48).

  Definition nat_to_ascii (n : nat) : ascii :=
    ascii_of_nat (n + 48)%nat.

  Fixpoint nat_to_string' (n : nat) (fuel : nat) : string :=
    if beq_nat n 0 then EmptyString
    else
      match fuel with
      | O => EmptyString
      | S fuel' =>
        String (nat_to_ascii $ Nat.modulo n 10) (nat_to_string' ((n / 10)%nat) fuel')
      end.

  Definition nat_to_string (n : nat) : string :=
    let s := implode $ List.rev (nat_to_string' n n) in
    match s with
    | EmptyString => "0"%string
    | _ => s
    end.

  Fixpoint pretty (nn : noun) : string :=
    match nn with
    | atom x => nat_to_string (N.to_nat x)
    | cell a b =>
      append
        "["
        (append (pretty a)
                (append " "
                        (append (pretty b) "]")))
    end.

  (* Applicative, for option only (for now) *)
  Definition apure {T : Type} (x : T) : option T := Some x.
  Definition aseq {T1 T2 : Type} (fo : option (T1 -> T2)) (xo : option T1) : option T2 :=
    match fo, xo with
    | None, _ => None
    | _, None => None
    | Some f, Some x => Some $ f x
    end.

  Notation "f <*> x" := (aseq f x) (at level 85).
  Notation "f <$> x" := (aseq (apure f) x) (at level 84).

  (* TODO: Polymorphic coercion?
     Maybe this can be simulated with canonical structures *)

  Fixpoint nn_insert (n : N) (nn : noun) : noun :=
    match nn with
    | atom n' => cell (atom n') (atom n)
    | cell nl nr => cell nl (nn_insert n nr)
    end.

  Fixpoint nn_insert_opt (n : N) (o : option noun) : noun :=
    match o with
    | None => atom n
    | Some nn => nn_insert n nn
    end.

  Definition Niszero (n : nat) : bool :=
    match n with
    | 0%nat => true
    | _ => false
    end.

  Definition isnil {T : Type} (l : list T) : bool :=
    match l with
    | [] => true
    | _ => false
    end.

  (* add more braces to make fully explicit *)
  Fixpoint canonize' (l : list token) (brackets : nat) {struct l} : list token :=
    let bkt := repeat CBRAC brackets in
    match l with
    | h1 :: lt =>
      match lt with
      | h2 :: ltt =>
        match ltt with
          | h3 :: lttt =>
            match h1, h2, h3 with
            | NUM _, NUM _, CBRAC =>
              h1 :: h2 :: bkt ++ canonize' ltt 0
            | NUM _, NUM _, _=>
              h1 :: OBRAC :: canonize' lt (S brackets)
            | CBRAC, _, _ => h1 :: bkt ++ canonize' lt 0
            | _, _, _ => h1 :: canonize' lt brackets
            end
          | _ => l ++ bkt
        end
      | _ => l ++ bkt
      end
    | _ => l ++ bkt
    end.

  Definition canonize (l : list token) : list token :=
    canonize' l 0.

  Eval compute in (canonize (lex "[1 2 3 4]")).

  (* only works on canonized things *)
  (* idea: left stores things we've already seen but can't
     quite output yet, default stores whether we return none
     or a designated cell when we run out of list
   *)

  Print positive.
  SearchAbout list.

  Eval compute in (pretty 900).

  (* This is getting things backwards sometimes *)
  Fixpoint parse'
           (l : list token)
           (depth : nat)
           (lefts : list (option noun))
    : option noun :=
    match l with
    | [] => None
      (*if Niszero depth then
        match lefts with
        | Some lh :: [] => Some lh
        | _ => None
        end
      else None *)
    | t :: l' =>
      match t with
      | OBRAC =>
        parse' l' (depth + 1) (None :: lefts)
      | CBRAC =>
        if negb $ Niszero depth then
          match lefts with
          | Some lh :: t =>
            (* lookahead! *)
            if negb $ isnil l' then
              match parse' l' (depth - 1) t with
              | Some n' => Some (cell lh n')
              | _ => None
              end
            else Some lh
          | None :: t => parse' l' (depth - 1) t
          | [] => None
          end
        else None
      | NUM n =>
        (*
        match parse' l' depth left with
        | Some n' => Some $ cell n n'
        | None => None
        end *)
        match lefts with
        | [] => Some (atom n)
        | lefth :: leftt =>
          parse' l' depth (Some (nn_insert_opt n lefth) :: leftt)
        end
      end
    end.

  Definition parse (s : string) : option noun :=
    parse' (canonize (lex s)) 0 [].

  Definition ex_noun1 : string := "[1 2]".
  Eval compute in (canonize (lex ex_noun1)).

  (* TODO canonize is broken but i think this is otherwise right *)

  Definition ex_noun2 : string := "1".

  Definition ex_noun3 : string := "[1 [2 3] 4]".

  Eval compute in (canonize (lex "[1 [2 3]]")).
Eval compute in (parse' (lex "[1 [2 3]]") 0 []).
  Definition ex_noun4 : string := "[[1 2] 3 4]".
  Definition ex_noun5 : string := "[1 2 3 4]".

  Eval compute in (parse $ ex_noun1).
  Eval compute in (parse $ ex_noun5).

  Eval compute in
      (parse' (canonize $ lex ex_noun1) 0 None).

  Eval compute in (

  Eval compute in (parse'

    Definition parse'2 :=

  (* do_parse - parse, returning a bogus value on fail *)
  (* Coercion do_parse : string >-> noun *)
    (* Coercion print : noun >-> string *)
End NockParse.
(*
  Definition example1 :=
    cell (cell 4 5) (cell 6 (cell 14 15)).
  Eval compute in (slice_rec 15 example1).
*)


Inductive bool : Set :=
| true
| false.

Lemma equality_of_functions_commutes:
  forall (f: bool->bool) x y,
    (f x) = (f y) -> (f y) = (f x).

Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.


(** *)

Add LoadPath ".." as LSMTS.
Require Import Coq.Classes.RelationClasses.
Require Import LSMTS.Classes.DecidableRelation.
Require Import LSMTS.Classes.Order.

(** *)

Class QO_Decidable
    `(Q : PreOrder)
    : Type
    :=
        QO_buildDecidable {

(** *)

            QO_Decidable_QuasiOrder := Q;

(** *)

            QO_decidable : DRel_Decidable (QO_precedes Q)
        }.

(** *)

Arguments QO_buildDecidable {_ _} _ _.

(** *)

Arguments QO_Decidable_QuasiOrder {_ _ _} _.
Arguments QO_decidable {_ _ _} _.

(** *)

Generalizable Variable Q.

(** *)

Coercion QO_Decidable_QuasiOrder : QO_Decidable >-> QO_QuasiOrder.

(** *)

Class SO_Decidable
    `(S : StrictOrder)
    : Type
    :=
        SO_buildDecidable {

(** *)

            SO_Decidable_StrictOrder := S;

(** *)

            SO_decidable : DRel_Decidable (SO_precedes S)
        }.

(** *)

Arguments SO_buildDecidable {_ _} _ _.

(** *)

Arguments SO_Decidable_StrictOrder {_ _ _} _.
Arguments SO_decidable {_ _ _} _.

(** *)

Generalizable Variable S.

(** *)

Coercion SO_Decidable_StrictOrder : SO_Decidable >-> SO_StrictOrder.

(** *)

Class PO_Decidable
    `(P : PartialOrder)
    : Type
    :=
        PO_buildDecidable {

(** *)

            PO_Decidable_PartialOrder := P;

(** *)

            PO_decidable : DRel_Decidable (PO_precedes P);

(** *)

            PO_eq_Decidable : DRel_Decidable (PO_eq P)
        }.

(** *)

Arguments PO_buildDecidable {_ _ _ _ _} _ _ _.

(** *)

Arguments PO_Decidable_PartialOrder {_ _ _ _ _ _} _ _ _.
Arguments PO_decidable {_ _ _ _ _ _} _.
Arguments PO_eq_Decidable {_ _ _ _ _ _} _.

(** *)

Generalizable Variable P.

(** *)

Coercion PO_Decidable_PartialOrder : PO_Decidable >-> PO_PartialOrder.

(** *)

Instance QO_eq_Decidable
    `(Q : QO_Decidable)
    : DRel_Decidable (QO_eq Q).
(* begin hide *)
Proof.
    split.
    intros x y.
    elim (DRel_decidable (QO_decidable Q) x y).
    -   elim (DRel_decidable (QO_decidable Q) y x).
        intros y_precedes_x x_precedes_y.
        left; now split.
        intros y_not_precedes_x x_precedes_y.
        right; intro x_eq_y; now destruct x_eq_y.
    -   intros x_not_precedes_y.
        right; intro x_eq_y; now destruct x_eq_y.
Qed.
(* end hide *)

(** *)

Instance QO_PartialOrder_Decidable
    `(Q : QO_Decidable)
    : PO_Decidable (QO_PartialOrder Q).
(* begin hide *)
Proof.
    split.
    now destruct Q.
    now apply (QO_eq_Decidable Q).
Qed.
(* end hide *)


(*
 * Section 5 Preprocess Example
 *)

Require Import Vector.
Require Import List.
Require Import ZArith.

Require Import Ornamental.Ornaments.

Notation "( x ; y )" := (existT _ x y) (no associativity).
Notation "p .1" := (projT1 p) (left associativity, at level 8, format "p .1").
Notation "p .2" := (projT2 p) (left associativity, at level 8, format "p .2").
Notation "p .&" := (p.1; p.2) (left associativity, at level 6, format "p .&").

Notation vector := Vector.t.
Notation vnil := Vector.nil.
Notation vcons := Vector.cons.

(* --- Preprocess --- *)

Preprocess Module List as List' { opaque (* ignore these: *)
  RelationClasses
  Nat
  Coq.Init.Nat
}.

(* --- Search & Lift --- *)

(* We use automatic search here rather than calling Find Ornament ourselves. *)

Definition list_elim A P : P nil -> (forall x xs, P xs -> P (cons x xs)) -> forall xs, P xs :=
  fun H__nil H__cons xs => @list_rect A P H__nil H__cons xs.

Lift list vector in list_elim as vect_elim.

Check (vect_elim :
         forall (A : Type) (P : {n : nat & vector A n} -> Type),
           P (0; vnil A) ->
           (forall (x : A) (xs : {n : nat & vector A n}),
               P xs.& -> P (S xs.1; vcons A x xs.1 xs.2)) ->
           forall (xs : {n : nat & vector A n}),
             P xs.&).

Lift Module list vector in List' as Vector' { opaque (* ignore these, just for speed *)
  RelationClasses.Equivalence_Reflexive
  RelationClasses.reflexivity
  Nat.add
  Nat.sub
  Nat.lt_eq_cases
  Nat.compare_refl
  Nat.lt_irrefl
  Nat.le_refl
  Nat.bi_induction
  Nat.central_induction
}.

(*
 * There are still two proofs (`partition_length` and `elements_in_partition`)
 * that fail to lift above, due to implementation bugs.
 * See: https://github.com/uwplse/ornamental-search/issues/32
 *
 * The effort here is fully automatic, whereas the old tactics don't work for
 * the repaired proofs here, so there are obvious development time savings.
 *)


From Coq Require Import String Arith Psatz Bool List Program.Equality Lists.ListSet .
From DanTrick Require Import DanTrickLanguage DanLogProp DanLogicHelpers StackLanguage StackLangEval EnvToStack StackLogicGrammar LogicProp.

Definition comp_arith sig :=
  ((fun a => (compile_aexp a (fun x => one_index_opt x sig)
  (List.length sig))))
  .

Definition comp_bool sig :=
  (fun a => (compile_bexp a (fun x => one_index_opt x sig)
  (List.length sig)))
  .

Definition comp_lp map lp_Dan :=
  match lp_Dan with
  |Dan_lp_arith l => MetaNat (compile_prop l (comp_arith map))
  |Dan_lp_bool l => MetaBool (compile_prop l (comp_bool map))
  end.

Fixpoint comp_logic args map log_Dan :=
  match log_Dan with
  |AbsEnvLP lp => BaseState (AbsStkSize (args + List.length map))
    (comp_lp map lp)
  |AbsEnvAnd l1 l2 => AbsAnd (comp_logic args map l1) (comp_logic args map l2)
  |AbsEnvOr l1 l2 => AbsOr (comp_logic args map l1) (comp_logic args map l2)
  end.

Inductive lp_arith_transrelation :
  nat ->
  (list DanTrickLanguage.ident) ->
  LogicProp nat aexp_Dan ->
  LogicProp nat aexp_stack ->
  Prop :=
    |CompiledArith :
      forall sig args d s,
      compile_prop_rel (comp_arith sig) d s ->
      lp_arith_transrelation args sig d s.

Inductive lp_bool_transrelation :
  nat ->
  (list DanTrickLanguage.ident) ->
  LogicProp bool bexp_Dan ->
  LogicProp bool bexp_stack ->
  Prop :=
    |CompiledBool :
      forall sig args d s,
      compile_prop_rel (comp_bool sig) d s ->
      lp_bool_transrelation args sig d s.

Inductive lp_transrelation :
  nat ->
  (list DanTrickLanguage.ident) ->
  Dan_lp ->
  MetavarPred ->
  Prop :=
  |ArithlpTransrelation :
    forall sig args d s,
    lp_arith_transrelation args sig d s ->
    lp_transrelation args sig (Dan_lp_arith d) (MetaNat s)
  |BoollpTransrelation :
    forall args sig d s,
    lp_bool_transrelation args sig d s ->
    lp_transrelation args sig (Dan_lp_bool d) (MetaBool s).

Inductive logic_transrelation :
  nat ->
  (list DanTrickLanguage.ident) ->
  AbsEnv ->
  AbsState ->
  Prop :=
  | LogicLeafTransrelation :
    forall args sig d s,
    lp_transrelation args sig d s ->
    logic_transrelation args sig
      (AbsEnvLP d)
      (BaseState (AbsStkSize ((List.length sig) + args)) s)
  | LogicAndTransrelation :
    forall args sig d1 s1 d2 s2,
    logic_transrelation args sig d1 s1 ->
    logic_transrelation args sig d2 s2 ->
    logic_transrelation args sig (AbsEnvAnd d1 d2) (AbsAnd s1 s2)
  | LogicOrTransrelation :
    forall args sig d1 s1 d2 s2,
    logic_transrelation args sig d1 s1 ->
    logic_transrelation args sig d2 s2 ->
    logic_transrelation args sig (AbsEnvOr d1 d2) (AbsOr s1 s2).

Inductive state_to_stack :
  (list DanTrickLanguage.ident) ->
  nat_env ->
  (list nat) ->
  (list nat) ->
  Prop :=
  | State_trans :
    forall map nenv dbenv,
    state_to_stack map nenv dbenv ((List.map nenv map) ++ dbenv).

Inductive compile_arith_args :
  nat ->
  (list DanTrickLanguage.ident) ->
  list aexp_Dan ->
  list aexp_stack ->
  Prop :=
  |CompiledArithArgs :
    forall sig args d s,
    compile_prop_args_rel (comp_arith sig) d s ->
    compile_arith_args args sig d s.

Inductive compile_bool_args :
  nat ->
  (list DanTrickLanguage.ident) ->
  list bexp_Dan ->
  list bexp_stack ->
  Prop :=
  |CompiledBoolArgs :
    forall sig args d s,
    compile_prop_args_rel (comp_bool sig) d s ->
    compile_bool_args args sig d s.

Scheme compile_prop_args_rel_ind := Induction for compile_prop_args_rel Sort Prop.
Check compile_prop_args_rel_ind.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Util.Notations.

Local Open Scope expr_scope.

Section language.
  Context {base_type_code : Type}
          (base_type_beq : base_type_code -> base_type_code -> bool)
          (base_type_leb : base_type_code -> base_type_code -> bool).
  Local Infix "<=?" := base_type_leb : expr_scope.
  Local Infix "=?" := base_type_beq : expr_scope.

  Definition base_type_min (a b : base_type_code) : base_type_code
    := if a <=? b then a else b.
  Definition base_type_max (a b : base_type_code) : base_type_code
    := if a <=? b then b else a.
  Section gen.
    Context (join : base_type_code -> base_type_code -> base_type_code).
    Fixpoint flat_type_join {t : flat_type base_type_code}
      : interp_flat_type (fun _ => base_type_code) t -> option base_type_code
      := match t with
         | Tbase _ => fun v => Some v
         | Unit => fun _ => None
         | Prod A B
           => fun v => match @flat_type_join A (fst v), @flat_type_join B (snd v) with
                       | Some a, Some b => Some (join a b)
                       | Some a, None => Some a
                       | None, Some b => Some b
                       | None, None => None
                       end
         end.
  End gen.
  Definition flat_type_min {t} := @flat_type_join base_type_min t.
  Definition flat_type_max {t} := @flat_type_join base_type_max t.
End language.


Require Import Coq.Lists.List.
Require Import Program.
Require Import Omega.

Require Import def.
Require Import exec.

Require Import priority_proof.

Section RUNNING_HELPERS.

  (* for find_task_id *)
  Lemma find_task_id_spec:
    forall (tid:nat) (t:task) (tset:taskset)
      (VT: valid_tset tset),
      find_task_id tid tset = Some t <->
      In t tset /\ t.(task_id) = tid.
  Proof.
    intros tid t tset VT.
    unfold valid_tset.
    revert t tid.
    induction tset as [| a tset]; intros.
    - split.
      + intros. inversion H.
      + intros. inversion H. inversion H0.
    - assert (VT2 : valid_tset tset).
      { eapply valid_tset_shrink; eauto. }
      split.
      + intros FIND.
        simpl in FIND.
        destruct (task_id a =? tid) eqn:EQB_ID.
        * split.
          { left. inversion FIND; eauto. }
          { apply beq_nat_true. inversion FIND. subst. eauto. }
        * apply IHtset in FIND; eauto.
          destruct FIND as [IN TID].
          split; eauto.
          right; eauto.
      + intros [IN TID].
        inversion IN.
        * subst. simpl.
          rewrite Nat.eqb_refl. eauto.
        * simpl.
          destruct (task_id a =? tid) eqn:EQB_ID.
          { apply beq_nat_true in EQB_ID.
            unfold valid_tset in VT.
            destruct VT as [UID NOD].
            unfold tset_unique_id in UID.
            assert (AG: task_id a <> task_id t \/ a = t).
            { eapply UID.
              - left; eauto.
              - right; eauto. }
            destruct AG as [NEQ | EQ].
            - subst. exfalso. apply NEQ; eauto.
            - subst. eauto.
          }
          { apply IHtset; eauto. }
  Qed.

  (* for get_nth_job_of_task *)

  Theorem get_next_nth_of_task_spec:
    forall (t:task) (time:nat) (nth:nat),
      get_next_nth_of_task t time = Some nth ->
      (nth_job_of_task t nth).(release_time) = time.
  Proof.
    intros.
    unfold nth_job_of_task.
    unfold get_next_nth_of_task in H.
    destruct (time <? start t) eqn:START; [inversion H| ].
    destruct ((time - start t) / period t * period t =? time - start t) eqn:EQB; [| inversion H].
    destruct t.
    simpl in *.
    inversion H.
    apply beq_nat_true in EQB.
    rewrite Nat.mul_comm.
    rewrite EQB.
    apply Nat.ltb_ge in START.
    apply le_plus_minus_r. eauto.
  Qed.

  (* for add_job_to_queue *)

  Lemma add_job_to_queue_preserve_valid_queue:
    forall (tset:taskset) (j:job) (q:queue),
      valid_tset tset ->
      (exists n, priority_of_tid j.(job_task_id) tset = Some n) ->
      valid_queue tset q ->
      (forall j', In j' q -> j'.(job_task_id) <> j.(job_task_id)) ->
      valid_queue tset (add_job_to_queue tset j q).
  Proof.
    intros tset j q VT EXn VQ DIFF.
    induction VQ.
    - simpl.
      inversion EXn.
      eapply Q_one. eauto.
    - simpl. rewrite -> H.
      destruct (priority_of_tid j.(job_task_id) tset) eqn:PR_IDj.
      + destruct (n0 <? n) eqn:LT.
        * econstructor; eauto.
          { apply Nat.ltb_lt in LT. omega. }
          { econstructor; eauto. }
        * econstructor; eauto.
          { apply Nat.ltb_ge in LT.
            assert (DIFFr: job_task_id j0 <> job_task_id j).
            { apply DIFF. left. eauto. }
            destruct (Nat.eq_dec n n0) eqn:DECn.
            { subst.
              exfalso. apply DIFFr.
              eapply priority_tid_unique; eauto. }
            { apply Nat.le_neq. eauto. }
          }
          { econstructor; eauto. }
      + econstructor; eauto.
    - simpl in *.
      + destruct (priority_of_tid (job_task_id j) tset) eqn:PR_IDj.
        { rewrite H. rewrite H0 in IHVQ.
          destruct (n <? n1) eqn:LT1.
          { destruct (n <? n2) eqn:LT2.
            - econstructor; eauto.
              + apply Nat.ltb_lt in LT1. omega.
              + econstructor; eauto.
            - econstructor; eauto.
              + apply Nat.ltb_lt in LT1. omega.
              + econstructor; eauto.
          }
          { rewrite H0.
            destruct (n <? n2) eqn:LT2.
            - econstructor; eauto.
              apply Nat.ltb_ge in LT1.
              destruct (Nat.eq_dec n1 n) eqn:DECn1.
              + subst.
                assert (EQjs: job_task_id j1 = job_task_id j).
                { eapply priority_tid_unique; eauto. }
                specialize (DIFF j1).
                exfalso. apply DIFF; eauto.
              + apply Nat.le_neq. eauto.
            - econstructor; eauto.
          }
        }
        { econstructor; eauto. }
  Qed.

  Lemma add_job_to_queue_preserve_job:
    forall (tset:taskset) (jq:queue) (j j':job),
      In j jq ->
      In j (add_job_to_queue tset j' jq).
  Proof.
    intros tset jq.
    induction jq as [| jh jq].
    - intros. inversion H.
    - intros.
      simpl.
      destruct (priority_of_tid j'.(job_task_id) tset) eqn:PR_IDj'.
      + destruct (priority_of_tid jh.(job_task_id) tset) eqn:PR_IDjh; eauto.
        destruct (n <? n0) eqn:LTn.
        { destruct H as [EQj | INj].
          - right. left. eauto.
          - right. right. eauto. }
        { destruct H as [EQj | INjq].
          - left. eauto.
          - right. apply IHjq. eauto.
        }
      + eauto.
  Qed.

End RUNNING_HELPERS.

Section RUNNING.

  Lemma filter_fails_spec:
    forall q qt qf time,
      filter_fails q time = (qt, qf) ->
      (forall j:job, (In j qt) -> (time < j.(deadline))) /\
      (forall j:job, (In j qf) -> (j.(deadline) <= time)).
  Proof.
    intros q.
    induction q as [| hq tq].
    - simpl. intros. inversion H.
      split; intros; contradiction.
    - simpl. intros.
      destruct (filter_fails tq time) eqn:ff.
      assert (ff2:=ff).
      apply IHtq in ff.
      destruct (time <? deadline hq) eqn:dl.
      + split.
        * inversion H.
          intros j INj.
          destruct INj as [EQhq | INq].
          { subst. apply Nat.ltb_lt; eauto. }
          { apply ff. eauto. }
        * inversion H. rewrite H2 in ff. apply ff.
      + split.
        * inversion H. rewrite H1 in ff. apply ff.
        * inversion H.
          intros j INj.
          destruct INj as [EQhq | INq].
          { subst. apply Nat.ltb_ge; eauto. }
          { apply ff. eauto. }
  Qed.

  Lemma filter_fails_origin:
    forall q qt qf time j,
      filter_fails q time = (qt, qf) ->
      In j qt \/ In j qf ->
      In j q.
  Proof.
    intros q.
    induction q as [| qh qt].
    - intros qt qf time j FF [INT | INF].
      + simpl in FF. inversion FF. subst; eauto.
      + simpl in FF. inversion FF. subst; eauto.
    - intros qt' qf time j FF [INT | INF].
      + simpl in FF.
        destruct (filter_fails qt time) eqn:FF2.
        destruct (time <? deadline qh) eqn:DL.
        * inversion FF. subst.
          destruct INT as [EQqh | INq].
          { subst. left; eauto. }
          { eapply IHqt in FF2; eauto. right; eauto. }
        * inversion FF. subst.
          eapply IHqt in FF2; eauto. right; eauto.
      + simpl in FF.
        destruct (filter_fails qt time) eqn:FF2.
        destruct (time <? deadline qh) eqn:DL.
        * inversion FF. subst.
          eapply IHqt in FF2; eauto. right; eauto.
        * inversion FF. subst.
          destruct INF as [EQqh | INq].
          { subst. left; eauto. }
          { eapply IHqt in FF2; eauto. right; eauto. }
  Qed.

  Lemma filter_fails_live:
    forall q qt qf time j,
      filter_fails q time = (qt, qf) ->
      In j qt ->
      time < j.(deadline) /\ In j q.
  Proof.
    intros q qt qf time j FF INj.
    assert (FFS:=FF).
    apply filter_fails_spec in FFS.
    destruct FFS as [L F].
    split; eauto.
    eapply filter_fails_origin; eauto.
  Qed.

  Lemma filter_fails_fail:
    forall q qt qf time j,
      filter_fails q time = (qt, qf) ->
      In j qf ->
      j.(deadline) <= time /\ In j q.
  Proof.
    intros q qt qf time j FF INj.
    assert (FFS:=FF).
    apply filter_fails_spec in FFS.
    destruct FFS as [L F].
    split; eauto.
    eapply filter_fails_origin; eauto.
  Qed.

End RUNNING.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Definitions and theorems about semi-open integer intervals *)

Require Import Coqlib.
Require Import Zwf.
Require Coq.Program.Wf.
Require Recdef.

Definition interv : Type := (Z * Z)%type.

(** * Membership *)

Definition In (x: Z) (i: interv) : Prop := fst i <= x < snd i.

Lemma In_dec:
  forall x i, {In x i} + {~In x i}.
Proof.
  unfold In; intros.
  case (zle (fst i) x); intros.
  case (zlt x (snd i)); intros.
  left; auto.
  right; intuition.
  right; intuition.
Qed.

Lemma notin_range:
  forall x i,
  x < fst i \/ x >= snd i -> ~In x i.
Proof.
  unfold In; intros; omega.
Qed.

Lemma range_notin:
  forall x i,
  ~In x i -> fst i < snd i -> x < fst i \/ x >= snd i.
Proof.
  unfold In; intros; omega.
Qed.

(** * Emptyness *)

Definition empty (i: interv) : Prop := fst i >= snd i.

Lemma empty_dec:
  forall i, {empty i} + {~empty i}.
Proof.
  unfold empty; intros.
  case (zle (snd i) (fst i)); intros.
  left; omega.
  right; omega.
Qed.

Lemma is_notempty:
  forall i, fst i < snd i -> ~empty i.
Proof.
  unfold empty; intros; omega.
Qed.

Lemma empty_notin:
  forall x i, empty i -> ~In x i.
Proof.
  unfold empty, In; intros. omega.
Qed.

Lemma in_notempty:
  forall x i, In x i -> ~empty i.
Proof.
  unfold empty, In; intros. omega.
Qed.

(** * Disjointness *)

Definition disjoint (i j: interv) : Prop :=
  forall x, In x i -> ~In x j.

Lemma disjoint_sym:
  forall i j, disjoint i j -> disjoint j i.
Proof.
  unfold disjoint; intros; red; intros. elim (H x); auto.
Qed.

Lemma empty_disjoint_r:
  forall i j, empty j -> disjoint i j.
Proof.
  unfold disjoint; intros. apply empty_notin; auto.
Qed.

Lemma empty_disjoint_l:
  forall i j, empty i -> disjoint i j.
Proof.
  intros. apply disjoint_sym. apply empty_disjoint_r; auto.
Qed.

Lemma disjoint_range:
  forall i j,
  snd i <= fst j \/ snd j <= fst i -> disjoint i j.
Proof.
  unfold disjoint, In; intros. omega.
Qed.

Lemma range_disjoint:
  forall i j,
  disjoint i j ->
  empty i \/ empty j \/ snd i <= fst j \/ snd j <= fst i.
Proof.
  unfold disjoint, empty; intros.
  destruct (zlt (fst i) (snd i)); auto.
  destruct (zlt (fst j) (snd j)); auto.
  right; right.
  destruct (zlt (fst i) (fst j)).
(* Case 1: i starts to the left of j. *)
  destruct (zle (snd i) (fst j)).
(* Case 1.1: i ends to the left of j, OK *)
  auto.
(* Case 1.2: i ends to the right of j's start, not disjoint. *)
  elim (H (fst j)). red; omega. red; omega.
(* Case 2: j starts to the left of i *)
  destruct (zle (snd j) (fst i)).
(* Case 2.1: j ends to the left of i, OK *)
  auto.
(* Case 2.2: j ends to the right of i's start, not disjoint. *)
  elim (H (fst i)). red; omega. red; omega.
Qed.

Lemma range_disjoint':
  forall i j,
  disjoint i j -> fst i < snd i -> fst j < snd j ->
  snd i <= fst j \/ snd j <= fst i.
Proof.
  intros. exploit range_disjoint; eauto. unfold empty; intuition omega.
Qed.

Lemma disjoint_dec:
  forall i j, {disjoint i j} + {~disjoint i j}.
Proof.
  intros.
  destruct (empty_dec i). left; apply empty_disjoint_l; auto.
  destruct (empty_dec j). left; apply empty_disjoint_r; auto.
  destruct (zle (snd i) (fst j)). left; apply disjoint_range; auto.
  destruct (zle (snd j) (fst i)). left; apply disjoint_range; auto.
  right; red; intro. exploit range_disjoint; eauto. intuition.
Qed.

(** * Shifting an interval by some amount *)

Definition shift (i: interv) (delta: Z) : interv := (fst i + delta, snd i + delta).

Lemma in_shift:
  forall x i delta,
  In x i -> In (x + delta) (shift i delta).
Proof.
  unfold shift, In; intros. simpl. omega.
Qed.

Lemma in_shift_inv:
  forall x i delta,
  In x (shift i delta) -> In (x - delta) i.
Proof.
  unfold shift, In; simpl; intros. omega.
Qed.

(** * Enumerating the elements of an interval *)

Section ELEMENTS.

Variable lo: Z.

Function elements_rec (hi: Z) {wf (Zwf lo) hi} : list Z :=
  if zlt lo hi then (hi-1) :: elements_rec (hi-1) else nil.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
Qed.

Lemma In_elements_rec:
  forall hi x,
  List.In x (elements_rec hi) <-> lo <= x < hi.
Proof.
  intros. functional induction (elements_rec hi).
  simpl; split; intros.
  destruct H. clear IHl. omega. rewrite IHl in H. clear IHl. omega.
  destruct (zeq (hi - 1) x); auto. right. rewrite IHl. clear IHl. omega.
  simpl; intuition.
Qed.

End ELEMENTS.

Definition elements (i: interv) : list Z :=
  elements_rec (fst i) (snd i).

Lemma in_elements:
  forall x i,
  In x i -> List.In x (elements i).
Proof.
  intros. unfold elements. rewrite In_elements_rec. auto.
Qed.

Lemma elements_in:
  forall x i,
  List.In x (elements i) -> In x i.
Proof.
  unfold elements; intros.
  rewrite In_elements_rec in H. auto.
Qed.

(** * Checking properties on all elements of an interval *)

Section FORALL.

Variables P Q: Z -> Prop.
Variable f: forall (x: Z), {P x} + {Q x}.
Variable lo: Z.

Program Fixpoint forall_rec (hi: Z) {wf (Zwf lo) hi}:
                 {forall x, lo <= x < hi -> P x}
                 + {exists x, lo <= x < hi /\ Q x} :=
  if zlt lo hi then
    match f (hi - 1) with
    | left _ =>
        match forall_rec (hi - 1) with
        | left _ => left _ _
        | right _ => right _ _
        end
    | right _ => right _ _
    end
  else
    left _ _
.
Next Obligation.
  red. omega.
Qed.
Next Obligation.
  assert (x = hi - 1 \/ x < hi - 1) by omega.
  destruct H2. congruence. auto.
Qed.
Next Obligation.
  exists wildcard'0; split; auto. omega.
Qed.
Next Obligation.
  exists (hi - 1); split; auto. omega.
Qed.
Next Obligation.
  omegaContradiction.
Defined.

End FORALL.

Definition forall_dec
       (P Q: Z -> Prop) (f: forall (x: Z), {P x} + {Q x}) (i: interv) :
       {forall x, In x i -> P x} + {exists x, In x i /\ Q x} :=
 forall_rec P Q f (fst i) (snd i).

(** * Folding a function over all elements of an interval *)

Section FOLD.

Variable A: Type.
Variable f: Z -> A -> A.
Variable lo: Z.
Variable a: A.

Function fold_rec (hi: Z) {wf (Zwf lo) hi} : A :=
  if zlt lo hi then f (hi - 1) (fold_rec (hi - 1)) else a.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
Qed.

Lemma fold_rec_elements:
  forall hi, fold_rec hi = List.fold_right f a (elements_rec lo hi).
Proof.
  intros. functional induction (fold_rec hi).
  rewrite elements_rec_equation. rewrite zlt_true; auto.
  simpl. congruence.
  rewrite elements_rec_equation. rewrite zlt_false; auto.
Qed.

End FOLD.

Definition fold {A: Type} (f: Z -> A -> A) (a: A) (i: interv) : A :=
  fold_rec A f (fst i) a (snd i).

Lemma fold_elements:
  forall (A: Type) (f: Z -> A -> A) a i,
  fold f a i = List.fold_right f a (elements i).
Proof.
  intros. unfold fold, elements. apply fold_rec_elements.
Qed.

(** Hints *)

Hint Resolve
  notin_range range_notin
  is_notempty empty_notin in_notempty
  disjoint_sym empty_disjoint_r empty_disjoint_l
  disjoint_range
  in_shift in_shift_inv
  in_elements elements_in : intv.