Require Export Crypto.Spec.CompleteEdwardsCurve.

Require Import Crypto.Algebra Crypto.Algebra Crypto.Util.Decidable.
Require Import Crypto.CompleteEdwardsCurve.Pre.
Require Import Coq.Logic.Eqdep_dec.
Require Import Crypto.Tactics.VerdiTactics.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Crypto.Util.Tuple Crypto.Util.Notations Crypto.Util.Tactics.
Require Export Crypto.Util.FixCoqMistakes.

Module E.
  Import Group ScalarMult Ring Field CompleteEdwardsCurve.E.

  Notation onCurve_zero := Pre.onCurve_zero.
  Notation denominator_nonzero := Pre.denominator_nonzero.
  Notation denominator_nonzero_x := Pre.denominator_nonzero_x.
  Notation denominator_nonzero_y := Pre.denominator_nonzero_y.
  Notation onCurve_add := Pre.onCurve_add.

  Section CompleteEdwardsCurveTheorems.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {char_ge_3 : @Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos BinNat.N.two)}
            {Feq_dec:DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x).

    Context {a d: F}
            {nonzero_a : a <> 0}
            {square_a : exists sqrt_a, sqrt_a^2 = a}
            {nonsquare_d : forall x, x^2 <> d}.

    Local Notation onCurve x y := (a*x^2 + y^2 = 1 + d*x^2*y^2) (only parsing).
    Local Notation point := (@E.point F Feq Fone Fadd Fmul a d).
    Local Notation eq    := (@E.eq F Feq Fone Fadd Fmul a d).
    Local Notation zero  := (E.zero(nonzero_a:=nonzero_a)(d:=d)).
    Local Notation add   := (E.add(nonzero_a:=nonzero_a)(square_a:=square_a)(nonsquare_d:=nonsquare_d)).
    Local Notation mul   := (E.mul(nonzero_a:=nonzero_a)(square_a:=square_a)(nonsquare_d:=nonsquare_d)).

    Program Definition opp (P:point) : point := (Fopp (fst P), (snd P)).
    Next Obligation. destruct P as [ [??]?]; cbv; fsatz. Qed.

    Ltac t_step :=
      match goal with
      | _ => solve [trivial | exact _ ]
      | _ => intro
      | |- Equivalence _ => split
      | |- abelian_group => split | |- group => split | |- monoid => split
      | |- is_associative => split | |- is_commutative => split
      | |- is_left_inverse => split | |- is_right_inverse => split
      | |- is_left_identity => split | |- is_right_identity => split
      | _ => progress destruct_head' @E.point
      | _ => progress destruct_head' prod
      | _ => progress destruct_head' and
      | |- context[E.add ?P ?Q] =>
        unique pose proof (Pre.denominator_nonzero_x _ nonzero_a square_a _ nonsquare_d _ _  (proj2_sig P)  _ _  (proj2_sig Q));
        unique pose proof (Pre.denominator_nonzero_y _ nonzero_a square_a _ nonsquare_d _ _  (proj2_sig P)  _ _  (proj2_sig Q))
      | _ => progress cbv [opp E.zero E.eq E.add E.coordinates proj1_sig fieldwise fieldwise'] in *
      (* [_gather_nonzeros] must run before [fst_pair] or [simpl] but after splitting E.eq and unfolding [E.add] *)
      | |- _ /\ _ => split | |- _ <-> _ => split
      end.
    Ltac t := repeat t_step; fsatz.

    Global Instance associative_add : is_associative(eq:=E.eq)(op:=add).
    Proof.
      (* [nsatz_compute] for a denominator runs out of 6GB of stack space *)
      (* COQBUG: https://coq.inria.fr/bugs/show_bug.cgi?id=5359 *)
      Add Field _field : (Algebra.Field.field_theory_for_stdlib_tactic (T:=F)).
      Import Field_tac.
      repeat t_step; (field_simplify_eq; [IntegralDomain.nsatz|]); repeat split; trivial.
      { intro. eapply H3. field_simplify_eq; repeat split; trivial. IntegralDomain.nsatz. }
      { intro. eapply H. field_simplify_eq; repeat split; trivial. IntegralDomain.nsatz. }
      { intro. eapply H4. field_simplify_eq; repeat split; trivial. IntegralDomain.nsatz. }
      { intro. eapply H0. field_simplify_eq; repeat split; trivial. IntegralDomain.nsatz. }
    Qed.

    Global Instance edwards_curve_abelian_group : abelian_group (eq:=eq)(op:=add)(id:=zero)(inv:=opp).
    Proof. t. Qed.

    Global Instance Proper_coordinates : Proper (eq==>fieldwise (n:=2) Feq) coordinates. Proof. repeat t_step. Qed.

    Global Instance Proper_mul : Proper (Logic.eq==>eq==>eq) mul.
    Proof.
      intros n n'; repeat intro; subst n'.
      induction n; (reflexivity || eapply (_:Proper (eq==>eq==>eq) add); eauto).
    Qed.

    Global Instance mul_is_scalarmult : @is_scalarmult point eq add zero mul.
    Proof. split; intros; (reflexivity || exact _). Qed.

    Section PointCompression.
      Local Notation "x ^ 2" := (x*x).

      Lemma a_d_y2_nonzero y : d * y^2 - a <> 0.
      Proof.
        destruct square_a as [sqrt_a], (dec (y=0));
          pose proof nonzero_a; pose proof (nonsquare_d (sqrt_a/y)); fsatz.
      Qed.

      Lemma solve_correct : forall x y, onCurve x y <-> (x^2 = (y^2-1) / (d*y^2-a)).
      Proof. pose proof a_d_y2_nonzero; t. Qed.

      (* TODO: move *)
      Definition exist_option {A} (P : A -> Prop) (x : option A)
        : match x with Some v => P v | None => True end -> option { a : A | P a }.
        destruct x; intros; [apply Some | apply None]; eauto. Defined.
      Lemma exist_option_Some {A} P (x:option A) pf s
            (H:Logic.eq (exist_option P x pf) (Some s))
            : Logic.eq x (Some (proj1_sig s)).
      Proof. destruct x, s; cbv [exist_option proj1_sig] in *; congruence. Qed.
      Lemma exist_option_None {A} P (x:option A) pf
            (H:Logic.eq (exist_option P x pf) None)
            : Logic.eq x None.
      Proof. destruct x; cbv [exist_option proj1_sig] in *; congruence. Qed.

      Context
        {sqrt_div:F -> F -> option F}
        {sqrt_Some: forall u v r, Logic.eq (sqrt_div u v) (Some r) -> r^2 = u/v}
        {sqrt_None: forall u v, Logic.eq (sqrt_div u v) None -> forall r, r^2 <> u/v}
        {parity:F -> bool} {Proper_parity: Proper (Feq ==> Logic.eq) parity}
        {parity_opp: forall x, x <> 0 -> Logic.eq (parity (Fopp x)) (negb (parity x)) }.

      Definition compress (P:point) : (bool*F) :=
        let (x, y) := coordinates P in pair (parity x) y.
      Definition set_sign r p : option F :=
        if dec (Logic.eq (parity r) p)
        then Some r
        else
          let r' := Fopp r in
          if dec (Logic.eq (parity r') p)
          then Some r'
          else None.
      Lemma set_sign_None r p s (H:Logic.eq (set_sign r p) (Some s))
            : s^2 = r^2 /\ Logic.eq (parity s) p.
      Proof.
        repeat match goal with
               | _ => progress subst
               | _ => progress cbv [set_sign] in *
               | _ => progress break_match_hyps
               | _ => progress Option.inversion_option
               | _ => split
               | _ => solve [ trivial | fsatz ]
               end.
      Qed.
      Lemma set_sign_Some r p (H:Logic.eq (set_sign r p) None)
            : forall s, s^2 = r^2 -> not (Logic.eq (parity s) p).
        repeat match goal with
               | _ => progress intros
               | _ => progress subst
               | _ => progress cbv [set_sign] in *
               | _ => progress break_match_hyps
               | _ => progress Option.inversion_option
               end.
        destruct (dec (r = 0)).
        assert (s = 0); [|solve[setoid_subst_rel Feq; trivial] ].
        admit.
        progress rewrite parity_opp in * by assumption.
        destruct (parity r), p; cbv [negb] in *; congruence.
      Admitted.

      Local Ltac t_step :=
        match goal with
        | _ => progress subst
        | _ => progress destruct_head' @E.point
        | _ => progress destruct_head' and
        | _ => progress break_match
        | _ => progress break_match_hyps
        | _ => progress Option.inversion_option
        | _ => progress Prod.inversion_prod
        | H:_ |- _ => unique pose proof (sqrt_Some _ _ _ H); clear H
        | H:_ |- _ => unique pose proof (sqrt_None _ _ H); clear H
        | H:_ |- _ => unique pose proof (set_sign_None _ _ _ H); clear H
        | H:_ |- _ => unique pose proof (set_sign_Some _ _ H); clear H
        | H:_ |- _ => unique pose proof (exist_option_Some _ _ _ _ H); clear H
        | H:_ |- _ => unique pose proof (exist_option_None _ _ _ H); clear H
        | _ => solve [trivial | eapply solve_correct; fsatz]
        end.
      Local Ltac t := repeat t_step.

      Program Definition decompress (b:bool*F) : option point :=
        exist_option _
            match b return option (F*F) with
              (p, y) =>
              match sqrt_div (y^2 - 1) (d*y^2 - a) return option (F*F) with
              | None => None
              | Some r =>
                match set_sign r p return option (F*F) with
                | Some x => Some (x, y)
                | None => None
                end
              end
            end _.
      Next Obligation. t. Qed.

      Lemma decompress_Some b P (H:Logic.eq (decompress b) (Some P))
        : Logic.eq (compress P) b.
      Proof. cbv [compress decompress] in *; t. Qed.

      Lemma decompress_None b (H:Logic.eq (decompress b) None)
        : forall P, not (Logic.eq (compress P) b).
      Proof.
        cbv [compress decompress exist_option coordinates] in *; intros.
        t.
        intro.
        apply (H0 f); [|congruence].
        admit.
        intro. Prod.inversion_prod; subst.
        rewrite solve_correct in y.
        eapply H. eapply y.
      Admitted.
    End PointCompression.
  End CompleteEdwardsCurveTheorems.
  Section Homomorphism.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Fchar_ge_3 : @Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos BinNat.N.two)}
            {Feq_dec:DecidableRel Feq}.

    Context {Fa Fd: F}
            {nonzero_a : not (Feq Fa Fzero)}
            {square_a : exists sqrt_a, Feq (Fmul sqrt_a sqrt_a) Fa}
            {nonsquare_d : forall x, not (Feq (Fmul x x) Fd)}.

    Context {K Keq Kzero Kone Kopp Kadd Ksub Kmul Kinv Kdiv}
            {fieldK: @Algebra.field K Keq Kzero Kone Kopp Kadd Ksub Kmul Kinv Kdiv}
            {Keq_dec:DecidableRel Keq}.
    Context {FtoK:F->K} {HFtoK:@Ring.is_homomorphism F Feq Fone Fadd Fmul
                                                     K Keq Kone Kadd Kmul FtoK}.
    Context {KtoF:K->F} {HKtoF:@Ring.is_homomorphism K Keq Kone Kadd Kmul
                                                     F Feq Fone Fadd Fmul KtoF}.
    Context {HisoF:forall x, Feq (KtoF (FtoK x)) x}.
    Context {Ka} {Ha:Keq (FtoK Fa) Ka} {Kd} {Hd:Keq (FtoK Fd) Kd}.

    Lemma nonzero_Ka : ~ Keq Ka Kzero.
    Proof.
      rewrite <-Ha.
      Ring.pull_homomorphism FtoK.
      intro X.
      eapply (Monoid.is_homomorphism_phi_proper(phi:=KtoF)) in X.
      rewrite 2HisoF in X.
      auto.
    Qed.

    Lemma square_Ka : exists sqrt_a, Keq (Kmul sqrt_a sqrt_a) Ka.
    Proof.
      destruct square_a as [sqrt_a]. exists (FtoK sqrt_a).
      Ring.pull_homomorphism FtoK. rewrite <-Ha.
      eapply Monoid.is_homomorphism_phi_proper; assumption.
    Qed.

    Lemma nonsquare_Kd : forall x, not (Keq (Kmul x x) Kd).
    Proof.
      intros x X. apply (nonsquare_d (KtoF x)).
      Ring.pull_homomorphism KtoF. rewrite X. rewrite <-Hd, HisoF.
      reflexivity.
    Qed.

      (* TODO: character respects isomorphism *)
    Global Instance Kchar_ge_2 :
      @char_ge K Keq Kzero Kone Kopp Kadd Ksub Kmul (BinNat.N.succ_pos BinNat.N.two).
    Proof.
      intros p Hp X; apply (Fchar_ge_3 p Hp).
      eapply Monoid.is_homomorphism_phi_proper in X.
      rewrite (homomorphism_zero(zero:=Fzero)(phi:=KtoF)) in X.
      etransitivity; [|eexact X]; clear X.
      (* TODO: Ring.of_Z of isomorphism *)
    Admitted.

    Local Notation Fpoint := (@E.point F Feq Fone Fadd Fmul Fa Fd).
    Local Notation Kpoint := (@E.point K Keq Kone Kadd Kmul Ka Kd).
    Local Notation FzeroP  := (E.zero(nonzero_a:=nonzero_a)(d:=Fd)).
    Local Notation KzeroP  := (E.zero(nonzero_a:=nonzero_Ka)(d:=Kd)).
    Local Notation FaddP   := (E.add(nonzero_a:=nonzero_a)(square_a:=square_a)(nonsquare_d:=nonsquare_d)).
    Local Notation KaddP   := (E.add(nonzero_a:=nonzero_Ka)(square_a:=square_Ka)(nonsquare_d:=nonsquare_Kd)).

    Obligation Tactic := idtac.
    Program Definition point_phi (P:Fpoint) : Kpoint := exist _ (
      let (x, y) := coordinates P in (FtoK x, FtoK y)) _.
    Next Obligation.
      destruct P as [ [? ?] ?]; cbv.
      rewrite <-!Ha, <-!Hd; pull_homomorphism FtoK.
      eapply Monoid.is_homomorphism_phi_proper; assumption.
    Qed.

    Lemma Proper_point_phi : Proper (eq==>eq) point_phi.
    Proof.
      intros P Q H.
      destruct P as [ [? ?] ?], Q as [ [? ?] ?], H as [Hl Hr]; cbv.
      rewrite !Hl, !Hr. split; reflexivity.
    Qed.

    Lemma lift_ismorphism : @Monoid.is_homomorphism Fpoint eq FaddP
                                                    Kpoint eq KaddP point_phi.
    Proof.
      repeat match goal with
             | |- _ => intro
             | |- Monoid.is_homomorphism => split
             | _ => progress destruct_head' @E.point
             | _ => progress destruct_head' prod
             | _ => progress destruct_head' and
             | |- context[E.add ?P ?Q] =>
               unique pose proof (Pre.denominator_nonzero_x _ nonzero_a square_a _ nonsquare_d _ _  (proj2_sig P)  _ _  (proj2_sig Q));
                 unique pose proof (Pre.denominator_nonzero_y _ nonzero_a square_a _ nonsquare_d _ _  (proj2_sig P)  _ _  (proj2_sig Q))
             | _ => progress cbv [eq add point_phi coordinates] in *
             | |- _ /\ _ => split
             | _ => rewrite !(homomorphism_div(phi:=FtoK)) by assumption
             | _ => rewrite !Ha
             | _ => rewrite !Hd
             | _ => Ring.push_homomorphism FtoK
             | |- _ ?x ?x => reflexivity
             | _ => eapply Monoid.is_homomorphism_phi_proper; assumption
             end.
    Qed.
  End Homomorphism.
End E.


From mathcomp Require Import all_ssreflect.
Require Import ssrstring.                   (* Ascii String *)
(* Require Import Recdef. *)                (* Function *)
Require Import ssrinv.                      (* inv: *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Open Scope string_scope.

Section Options.

  Variable T : Type.

  Fixpoint option_nth (s : seq T) (n : nat) : option T :=
    match s with
    | [::] => None
    | x :: s' => match n with
                 | 0 => Some x
                 | n'.+1 => option_nth s' n'
                 end
    end.

  Fixpoint option_nth1 (s : seq T) (n : nat) : option T :=
    match s with
    | [::] => None
    | x :: s' => match n with
                 | 0 => None
                 | 1 => Some x
                 | n'.+1 => option_nth1 s' n'
                 end
    end.

End Options.

Section Data.

  Inductive sexp :=
  | on of nat
  | ob of bool
  | oc of ascii
  | os of string
  | ol of seq sexp.

  Definition object := option sexp.

End Data.

Section Program.

  Inductive program :=
  | sel of nat
  | tl
  | id
  | atom
  | eq
  | null
  | reverse
  | distl
  | distr
  | length
  | add
  | sub
  | mul
  | div
  | and
  (* trans *) (* transpose *)
  | or
  | not
  | apndl                                   (* cons *)
  | apndr                                   (* snoc *)
  (* rsel of nat *)
  (* rotl of nat *)
  (* rotr of nat *)
  | compose of program & program
  | cons of seq program
  | cond of program & program & program
  | const of object
  | insert of program                       (* foldr *)
  | alpha of program                        (* map / apply all *)
  | bu of program & object                  (* binary to unary *)
  | while of program & program
  | call of string                          (* 定義済関数の呼び出し *)
  .

End Program.

Section Environment.

  Definition env := seq (string * program)%type.

  Fixpoint lookup (e : env) (f : string) : option program :=
    match e with
    | [::] => None
    | (f', p) :: e' => if (f == f') then Some p else lookup e' f
    end.

  Definition environment :=
    [::
       ("last", cond (compose null tl)
                     (sel 1)
                     (compose (call "last") tl));
       ("eq0", compose eq (cons [:: id; const (Some (on 0))]));
       ("sub1", compose sub (cons [:: id; const (Some (on 1))]));
       ("fact", cond (call "eq0")
                     (const (Some (on 1)))
                     (compose mul (cons [:: id;
                                           (compose (call "fact")
                                                    (call "sub1"))])))
    ].

End Environment.

(**
# Big Step (Natural semantics)
*)
Section BigStep.

  Inductive ns : object -> program -> object -> Prop :=
  | ns_sel n xs :
      ns (Some (ol xs))                  (sel n)           (option_nth1 xs n)
  | ns_tl x xs :
      ns (Some (ol (x :: xs)))           tl                (Some (ol xs))
  | ns_id x :
      ns (Some x)                        id                (Some x)
  | ns_atom_nat m :
      ns (Some (on m))                   atom              (Some (ob false))
  | ns_atom_bool x :
      ns (Some (ob x))                   atom              (Some (ob false))
  | ns_atom_char x :
      ns (Some (oc x))                   atom              (Some (ob false))
  | ns_atom_string x :
      ns (Some (os x))                   atom              (Some (ob false))
  | ns_atom_list x :
      ns (Some (ol x))                   atom              (Some (ob true))
  | ns_eq_true y :
      ns (Some (ol [:: y; y]))           eq                (Some (ob true))
  | ns_eq_false y z :
      y <> z ->
      ns (Some (ol [:: y; z]))           eq                (Some (ob false))
  | ns_null_true :
      ns (Some (ol [::]))                null              (Some (ob true))
  | ns_null_false x l :
      ns (Some (ol (x :: l)))            null              (Some (ob false))
  | ns_reverse l  :
      ns (Some (ol l))                   reverse           (Some (ol (rev l)))
  | ns_distl y zs :
      ns (Some (ol [:: y; ol zs]))       distl  (Some (ol [seq ol [:: y; z] | z <- zs]))
  | ns_distr ys z :
      ns (Some (ol [:: ol ys; z]))       distl  (Some (ol [seq ol [:: y; z] | y <- ys]))
  | ns_length xs :
      ns (Some (ol xs))                  length            (Some (on (size xs)))
  | ns_add m n :
      ns (Some (ol [:: on m; on n]))     add               (Some (on (m + n)))
  | ns_sub m n :
      ns (Some (ol [:: on m; on n]))     sub               (Some (on (m - n)))
  | ns_mul m n :
      ns (Some (ol [:: on m; on n]))     mul               (Some (on (m * n)))
  | ns_div m n :
      n <> 0 ->
      ns (Some (ol [:: on m; on n]))     div               (Some (on (m %/ n)))
  | ns_div_zero m :
      ns (Some (ol [:: on m; on 0]))     div               None
  | ns_and b c :
      ns (Some (ol [:: ob b; ob c]))     and               (Some (ob (b && c)))
  | ns_or b c :
      ns (Some (ol [:: ob b; ob c]))     or                (Some (ob (b || c)))
  | ns_not b :
      ns (Some (ob b))                   not               (Some (ob (~~ b)))
  | ns_apndl y zs :
      ns (Some (ol [:: y; ol zs]))       apndl             (Some (ol (y :: zs)))
  | ns_apndr ys z :
      ns (Some (ol [:: ol ys; z]))       apndr             (Some (ol (rcons ys z)))
  (* *** *)
  (* composition *)
  | ns_compose f g x y z :
      ns (Some x)                        g                 (Some y) ->
      ns (Some y)                        f                 z ->
      ns (Some x)                        (compose f g)     z
  | ns_compose_none f g x :
      ns (Some x)                        g                 None ->
      ns (Some x)                        (compose f g)     None
  (* construction *)
  | ns_cons fs x y :
      ns_mapc (Some x)                   fs                (Some y) ->
      ns (Some x)                        (cons fs)         (Some (ol y))
  | ns_cons_none fs x :
      ns_mapc (Some x)                   fs                None ->
      ns (Some x)                        (cons fs)         None
  (* condition *)
  | ns_cond_true p f g x y :
      ns (Some x)                        p                 (Some (ob true)) ->
      ns (Some x)                        f                 y ->
      ns (Some x)                        (cond p f g)      y
  | ns_cond_false p f g x y :
      ns (Some x)                        p                 (Some (ob false)) ->
      ns (Some x)                        g                 y ->
      ns (Some x)                        (cond p f g)      y
  | ns_cond_none p f g x :
      ns (Some x)                        p                 None ->
      ns (Some x)                        (cond p f g)      None
  (* constant *)
  (* 与えられた定数 y によらず、スタック上の引数がNoneならNoneにする。
     一方、定数としてNoneを与えることも可能とする。 *)
  | ns_const x y :
      ns (Some x)                        (const y)         y
  (* insert, foldr *)
  | ns_insert f x y :
      ns_foldr (Some x)                  f                 y ->
      ns (Some (ol x))                   (insert f)        y
  (* alpha, apply-all *)
  | ns_alpha f x y :
      ns_mapa (Some x)                   f                 (Some y) ->
      ns (Some (ol x))                   (alpha f)         (Some (ol y))
  | ns_alpha_none f x :
      ns_mapa (Some x)                   f                 None ->
      ns (Some (ol x))                   (alpha f)         None
  (* bu *)
  | ns_bu f x y z :
      ns (Some (ol [:: x; y]))           f                 (Some z) ->
      ns (Some y)                        (bu f (Some x))   (Some y)
  | ns_bu_none_1 f x y :
      ns (Some (ol [:: x; y]))           f                 None ->
      ns (Some y)                        (bu f (Some x))   None
  | ns_bu_none_2 f y :
      ns (Some y)                        (bu f None)       None
  (* while *)
  | ns_while_true p f x y z :
      ns (Some x)                        p                 (Some (ob true)) ->
      ns (Some x)                        f                 (Some y) ->
      ns (Some y)                        (while p f)       z ->
      ns (Some x)                        (while p f)       z
  | ns_while_true_none p f x :
      ns (Some x)                        p                 (Some (ob true)) ->
      ns (Some x)                        f                 None ->
      ns (Some x)                        (while p f)       None
  | ns_while_false p f x :
      ns (Some x)                        p                 (Some (ob false)) ->
      ns (Some x)                        (while p f)       (Some x)
  | ns_while_none p f x :
      ns (Some x)                        p                 None ->
      ns (Some x)                        (while p f)       None
  (* *** *)
  | ns_call f p x y :
      lookup environment f = Some p ->
      ns (Some x)                        p                 y ->
      ns (Some x)                        (call f)          y
  | ns_call_none f x :
      lookup environment f = None ->
      ns (Some x)                        (call f)          None
  (* *** *)
  | ns_none x f :
      ns x                                f                None
  with ns_mapc : option sexp -> seq program -> option (seq sexp) -> Prop :=
       | ns_mapc_nil x :
           ns_mapc (Some x) [::] (Some [::])
       | ns_mapc_cons x f1 f2 y ys :
           ns (Some x) f1 (Some y) ->
           ns_mapc (Some x) f2 (Some ys) ->
           ns_mapc (Some x) (f1 :: f2) (Some (y :: ys))
       | ns_mapc_none_1 x f1 f2 :
           ns (Some x) f1 None ->
           ns_mapc (Some x) (f1 :: f2) None
       | ns_mapc_none_2 x f1 f2 :
           ns_mapc (Some x) f2 None ->
           ns_mapc (Some x) (f1 :: f2) None
  with ns_foldr : option (seq sexp) -> program -> option sexp -> Prop :=
       (* [::] に対する fold は intrinsics に限定する。 *)
       | ns_foldr_nil_eq  : ns_foldr (Some [::]) add (Some (ob true))
       | ns_foldr_nil_add : ns_foldr (Some [::]) add (Some (on 0))
       | ns_foldr_nil_sub : ns_foldr (Some [::]) sub (Some (on 0))
       | ns_foldr_nil_mul : ns_foldr (Some [::]) mul (Some (on 1))
       | ns_foldr_nil_div : ns_foldr (Some [::]) div (Some (on 1))
       | ns_foldr_nil_and : ns_foldr (Some [::]) and (Some (ob true))
       | ns_foldr_nil_or  : ns_foldr (Some [::]) and (Some (ob false))
       | ns_foldr_nil_apndl : ns_foldr (Some [::]) apndl (Some (ol [::]))
       (* *** *)
       | ns_foldr_one a f :
           ns_foldr (Some [:: a]) f (Some a)
       | ns_foldr_cons x1 x2 f y ys :
           ns_foldr (Some x2) f (Some ys) ->
           ns (Some (ol [:: x1; ys])) f y ->
           ns_foldr (Some (x1 :: x2)) f y
       | ns_foldr_none x1 x2 f :
           ns_foldr (Some x2) f None ->
           ns_foldr (Some (x1 :: x2)) f None
  with ns_mapa : option (seq sexp) -> program -> option (seq sexp) -> Prop :=
       | ns_mapa_nil f :
           ns_mapa (Some [::]) f (Some [::])
       | ns_mapa_cons x xs f y ys :
           ns (Some x) f (Some y) ->
           ns_mapa (Some xs) f (Some ys) ->
           ns_mapa (Some (x :: xs)) f (Some (y :: ys))
       | ns_mapa_none_1 x xs f :
           ns (Some x) f None ->
           ns_mapa (Some (x :: xs)) f None
       | ns_mapa_none_2 x xs f :
           ns_mapa (Some xs) f None ->
           ns_mapa (Some (x :: xs)) f None
  .

End BigStep.

Hint Constructors ns.
Hint Constructors ns_mapc.
Hint Constructors ns_foldr.
Hint Constructors ns_mapa.

(**
次の2行で、ns_compose の y を implicit から外し、指定するようにする。
```
apply: (@ns_compose _ _ _ (ol [:: on 2; on 0])).
```
ではなく、
```
apply: (ns_compose (ol [:: on 2; on 0])).
```
指定したくない場合は、``_`` を指定する。
 *)
Arguments ns_compose : clear implicits.
Arguments ns_compose [f] [g] [x] y [z].

(**
TEST
*)
Goal ns (Some (ol [:: on 1; on 2])) add (Some (on 3)).
Proof.
  apply: ns_add => //.
Qed.

Goal ns (Some (ol [:: on 1; on 2; on 3])) (insert add) (Some (on 6)).
Proof.
  apply: ns_insert => //.
  apply: ns_foldr_cons => //.
  apply: ns_foldr_cons => //.
  apply: ns_add => //.
Qed.

Goal ns (Some (on 0)) (call "eq0") (Some (ob true)).
Proof.
  apply: ns_call => //.
  apply: ns_compose => //.
  apply: ns_cons => //.
  apply: ns_mapc_cons => //.
  apply: ns_mapc_cons => //.
Qed.

(**
# Last
 *)
Section Last.

  (* [:: 0; 1; 2; 3] のときの最後の要素は、 *)
  Compute last 0 [:: 1; 2; 3].              (* 3 *)

  Lemma l_last_nil : ns (Some (ol [::])) (call "last") None.
  Proof.
      by apply: ns_call.
  Qed.

  Lemma l_last_one x : ns (Some (ol [:: x])) (call "last") (Some x).
  Proof.
    apply: ns_call => //.
    apply: ns_cond_true => //.
    - apply: (ns_compose (ol [::])).
      + by apply: ns_tl.
      + by apply: ns_null_true.
    - by apply: ns_sel.
  Qed.

  Lemma l_last_cons x xs : ns (Some (ol (x :: xs))) (call "last") (Some (last x xs)).
  Proof.
    elim: xs x => //= [| x' xs IHl] x.
    (* xs = [::] のとき。 last x [::] = x であることに注意。
       MathComp の last 関数はこれを見越して設計されているのだ。 *)
    - by apply: l_last_one.
    (* xs = x' :: xs のとき。 *)
    - apply: ns_call => //.
      apply: ns_cond_false => //.
      + apply: (ns_compose (ol (x' :: xs))).
        * by apply: ns_tl.
        * by apply: ns_null_false.
      + apply: (ns_compose (ol (x' :: xs))).
        * by apply: ns_tl.
        * by apply: IHl.
  Qed.

End Last.

(**
# Factorial
*)
Section Factorial.

(**
fact 2 = 2 の証明
 *)
  Goal ns (Some (on 2)) (call "fact") (Some (on 2)).
  Proof.
    apply: ns_call => //.                   (* fact *)
    apply: ns_cond_false => //.
    - apply: ns_call => //.                 (* eq0 *)
      apply: (ns_compose (ol [:: on 2; on 0])).
      (* apply: (@ns_compose _ _ _ (ol [:: on 2; on 0])). *)
      + apply: ns_cons => //.
        apply: ns_mapc_cons => //.
          by apply: ns_mapc_cons.
      + by apply: ns_eq_false.
    - apply: (ns_compose (ol [:: on 2; on 1])).
      + apply: ns_cons => //.
        apply: ns_mapc_cons => //.
        apply: ns_mapc_cons => //.
        apply: (ns_compose (on 1)).
        * apply: ns_call => //.             (* sub1 *)
          apply: (ns_compose (ol [:: on 2; on 1])).
          -- apply: ns_cons => //.
             apply: ns_mapc_cons => //.
               by apply: ns_mapc_cons.
          -- by apply: ns_sub.
        * apply: ns_call => //.             (* fact *)
          apply: ns_cond_false.
          -- apply: ns_call => //.          (* eq0 *)
             apply: (ns_compose (ol [:: on 1; on 0])).
             ++ apply: ns_cons => //.
                apply: ns_mapc_cons => //.
                  by apply: ns_mapc_cons.
             ++ by apply: ns_eq_false.
          -- apply: (ns_compose (ol [:: on 1; on 1])).
             ++ apply: ns_cons => //.
                apply: ns_mapc_cons => //.
                apply: ns_mapc_cons => //.
                apply: (ns_compose (on 0)).
                ** apply: ns_call => //.    (* sub1 *)
                   apply: (ns_compose (ol [:: on 1; on 1])).
                   --- apply: ns_cons => //.
                       apply: ns_mapc_cons => //.
                         by apply: ns_mapc_cons.
                   --- by apply: ns_sub.
                ** apply: ns_call => //.    (* fact *)
                   apply: ns_cond_true => //.
                   apply: ns_call => //.
                   apply: (ns_compose (ol [:: on 0; on 0])).
                   --- apply: ns_cons => //.
                       apply: ns_mapc_cons => //.
                         by apply: ns_mapc_cons.
                   --- by apply: ns_eq_true.
             ++ by apply: ns_mul.
      + by apply: ns_mul.
  Qed.

(**
## 補題
*)
  Lemma l_eq0_true :
    ns (Some (on 0)) (call "eq0") (Some (ob true)).
  Proof.
    apply: ns_call => //.                   (* eq0 *)
    apply: (ns_compose (ol [:: on 0; on 0])).
    - apply: ns_cons => //.
      apply: ns_mapc_cons => //.
        by apply: ns_mapc_cons.
    - by apply: ns_eq_true.
  Qed.

  Lemma l_eq0_false n :
    n <> 0 -> ns (Some (on n)) (call "eq0") (Some (ob false)).
  Proof.
    move=> H0.
    apply: ns_call => //.                   (* eq0 *)
    apply: (ns_compose (ol [:: on n; on 0])).
    - apply: ns_cons => //.
      apply: ns_mapc_cons => //.
        by apply: ns_mapc_cons.
    - case: n H0 => //= n H0.
        by apply: ns_eq_false.
  Qed.

  Lemma l_sub1 n :
    ns (Some (on n.+1)) (call "sub1") (Some (on n)).
  Proof.
    apply: ns_call => //.                   (* sub1 *)
    apply: (ns_compose (ol [:: on n.+1; on 1])).
    - apply: ns_cons => //.
      apply: ns_mapc_cons => //.
      + by apply: ns_mapc_cons.
      + have {2}-> : n = n.+1 - 1 by rewrite subn1 -pred_Sn.
          by apply: ns_sub.
  Qed.

  Lemma l_fact_0 : ns (Some (on 0)) (call "fact") (Some (on 1)).
  Proof.
    apply: ns_call => //.                   (* fact *)
    apply: ns_cond_true => //.
    apply: ns_call => //.
    apply: (ns_compose (ol [:: on 0; on 0])).
    - apply: ns_cons => //.
      apply: ns_mapc_cons => //.
        by apply: ns_mapc_cons.
    - by apply: ns_eq_true.
  Qed.

  Lemma fact_2 : ns (Some (on 2)) (call "fact") (Some (on 2)).
  Proof.
    apply: ns_call => //.                   (* fact *)
    apply: ns_cond_false => //.
    - by apply: l_eq0_false.
    - apply: (ns_compose (ol [:: on 2; on 1])).
      + apply: ns_cons => //.
        apply: ns_mapc_cons => //.
        apply: ns_mapc_cons => //.
        apply: (ns_compose (on 1)).
        * by apply: l_sub1.
        * apply: ns_call => //.             (* fact *)
          apply: ns_cond_false.
          -- by apply: l_eq0_false.
          -- apply: (ns_compose (ol [:: on 1; on 1])).
             ++ apply: ns_cons => //.
                apply: ns_mapc_cons => //.
                apply: ns_mapc_cons => //.
                apply: (ns_compose (on 0)).
                ** by apply: l_sub1.
                ** by apply: l_fact_0.
             ++ by apply: ns_mul.
      + by apply: ns_mul.
  Qed.

(**
## 定理
*)
  Lemma fact_n n : ns (Some (on n)) (call "fact") (Some (on n `!)).
  Proof.
    elim: n => [| n IHn].
    - by apply: l_fact_0.                   (* n = 0 *)
    - rewrite factS.                        (* n = n.+1 *)
      apply: ns_call => //.                 (* fact *)
      apply: ns_cond_false => //.
      + by apply: l_eq0_false.
      + apply: (ns_compose (ol [:: on n.+1; on n`!])).
        * apply: ns_cons => //.
          apply: ns_mapc_cons => //.
          apply: ns_mapc_cons => //.
          apply: (ns_compose (on n)).
          -- by apply: l_sub1.
          -- apply: IHn.
        * by apply: ns_mul.
  Qed.

End Factorial.

(**
# Algebra of Programs

inversion で分解することができないので、必要十分条件の証明ができない。
*)
Section Algebra.

  Lemma law1_1 f g h x y z1 z2 :
    ns (Some y) f (Some z1) ->
    ns (Some y) g (Some z2) ->
    ns (Some x) h (Some y) ->
    (ns (Some x) (compose (cons [:: f; g]) h) (Some (ol [:: z1; z2])) /\
     ns (Some x) (cons [:: compose f h; compose g h]) (Some (ol [:: z1; z2]))).
  Proof.
    move=> Hf Hg Hh.
    split.
    - apply: (ns_compose y) => //.
      apply: ns_cons => //.
      apply: ns_mapc_cons => //.
        by apply: ns_mapc_cons.
    - apply: ns_cons => //.
      apply: ns_mapc_cons => //.
      + apply: (ns_compose y) => //.
        apply: ns_mapc_cons => //.
          by apply: (ns_compose y).
  Qed.

  Lemma law1_2 f g h x y1 y2 z1 z2 :
    ns (Some y1) f (Some z1) ->
    ns (Some y2) f (Some z2) ->
    ns (Some x) g (Some y1) ->
    ns (Some x) h (Some y2) ->
    (ns (Some x) (compose (alpha f) (cons [:: g; h])) (Some (ol [:: z1; z2])) /\
     ns (Some x) (cons [:: compose f g; compose f h]) (Some (ol [:: z1; z2]))).
  Proof.
    move=> Hf1 Hf2 Hg Hh.
    split.
    - apply: (ns_compose (ol [:: y1; y2])) => //.
      apply: ns_cons => //.
      apply: ns_mapc_cons => //.
      apply: ns_mapc_cons => //.
      apply: ns_alpha => //.
      apply: ns_mapa_cons => //.
        by apply: ns_mapa_cons.
    - apply: ns_cons => //.
      apply: ns_mapc_cons => //.
      + by apply: (ns_compose y1).
      + apply: ns_mapc_cons => //.
        by apply: (ns_compose y2).
  Qed.

  Lemma law1_3_1 f g1 g2 g3 x y1 y2 y3 z1 z2 :
    ns (Some (ol [:: y1; z2])) f (Some z1) ->
    ns (Some (ol [:: y2; y3])) f (Some z2) ->
    ns (Some x) g1 (Some y1) ->
    ns (Some x) g2 (Some y2) ->
    ns (Some x) g3 (Some y3) ->
    (ns (Some x) (compose (insert f) (cons [:: g1; g2; g3])) (Some z1) /\
     ns (Some x) (compose f (cons [:: g1; compose f (cons [:: g2; g3])])) (Some z1)).
  Proof.
    move=> Hf1 Hf2 Hg1 Hg2 Hg3.
    split.
    - apply: (ns_compose (ol [:: y1; y2; y3])).
      + apply: ns_cons => //.
        apply: ns_mapc_cons => //.
        apply: ns_mapc_cons => //.
          by apply: ns_mapc_cons.
      + apply: ns_insert => //.
        apply: ns_foldr_cons.
        * apply: ns_foldr_cons.
          -- by apply: ns_foldr_one.
          -- by apply: Hf2.
        * apply: Hf1.
    - apply: (ns_compose (ol [:: y1; z2])).
      + apply: ns_cons => //.
        apply: ns_mapc_cons => //.
        apply: ns_mapc_cons => //.
        apply: (ns_compose (ol [:: y2; y3])).
        * apply: ns_cons => //.
          apply: ns_mapc_cons => //.
            by apply: ns_mapc_cons.
        * by apply: Hf2.
      + by apply: Hf1.
  Qed.

  Lemma law1_5_1 f g x y1 y2 :
    ns (Some x) f (Some y1) ->
    ns (Some x) g (Some y2) ->
    ns (Some x) (compose (sel 1) (cons [:: f; g])) (Some y1).
  Proof.
    move=> Hf Hg.
    apply: (ns_compose (ol [:: y1; y2])).
    - apply: ns_cons.
      apply: ns_mapc_cons => //.
        by apply: ns_mapc_cons.
    - by apply: ns_sel.
  Qed.

  Lemma law1_5_2 f g x y1 y2 :
    ns (Some x) f (Some y1) ->
    ns (Some x) g (Some y2) ->
    ns (Some x) (compose (sel 2) (cons [:: f; g])) (Some y2).
  Proof.
    move=> Hf Hg.
    apply: (ns_compose (ol [:: y1; y2])).
    - apply: ns_cons.
      apply: ns_mapc_cons => //.
        by apply: ns_mapc_cons.
    - by apply: ns_sel.
  Qed.

End Algebra.

(* END *)


Require Export prosa.model.schedule.work_conserving.
Require Export prosa.analysis.facts.model.ideal_schedule.
Require Export prosa.analysis.transform.wc_trans.
Require Export prosa.analysis.facts.transform.swaps.
Require Export prosa.analysis.definitions.schedulability.
Require Export prosa.util.list.

From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(** * Correctness of the work-conservation transformation *)
(** This file contains the main argument of the work-conservation proof,
    starting with an analysis of the individual functions that drive
    the work-conservation transformation of a given reference schedule
    and ending with the proofs of individual properties of the obtained
    work-conserving schedule. *)

(** Throughout this file, we assume ideal uniprocessor schedules and
    the basic (i.e., Liu & Layland) readiness model under which any
    pending job is ready. *)
Require Import prosa.model.processor.ideal.
Require Import prosa.model.readiness.basic.

(** In order to discuss the correctness of the work-conservation transformation at a high level,
    we first need a set of lemmas about the inner parts of the procedure. *)
Section AuxiliaryLemmasWorkConservingTransformation.

  (** Consider any type of jobs with arrival times, costs, and deadlines... *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.
  Context `{JobDeadline Job}.

  (** ...and an arbitrary arrival sequence. *)
  Variable arr_seq: arrival_sequence Job.
  Hypothesis H_arr_seq_valid: valid_arrival_sequence arr_seq.

  (** We introduce the notion of work-conservation at a
      given time [t]. The definition is based on the concept of readiness
      of a job, and states that the presence of a ready job implies that
      the processor is not idle. *)
  Definition is_work_conserving_at sched t :=
    (exists j, arrives_in arr_seq j /\ job_ready sched j t) ->
    exists j, sched t = Some j.

  (** First, we prove some useful properties about the most fundamental
      operation of the work-conservation transformation: swapping two processor
      states [t1] and [fsc], with [fsc] being a valid swap candidate of [t1]. *)
  Section JobsMustBeReadyFindSwapCandidate.

    (** Consider an ideal uniprocessor schedule... *)
    Variable sched: schedule (ideal.processor_state Job).

    (** ...in which jobs must be ready to execute. *)
    Hypothesis H_jobs_must_be_ready: jobs_must_be_ready_to_execute sched.

    (** Consider an arbitrary time instant [t1]. *)
    Variable t1: instant.

    (** Let us define [fsc] as the result of the search for a swap candidate
        starting from [t1]... *)
    Let fsc := find_swap_candidate arr_seq sched t1.

    (** ...and [sched'] as the schedule resulting from the swap. *)
    Let sched' := swapped sched t1 fsc.

    (** First, we show that, in any case, the result of the search will yield an
        instant that is in the future (or, in case of failure, equal to [t1]). *)
    Lemma swap_candidate_is_in_future:
      t1 <= fsc.
    Proof.
      rewrite /fsc /find_swap_candidate.
      destruct search_arg as [n|] eqn:search_result; last by done.
      apply search_arg_in_range in search_result.
        by move:search_result => /andP [LEQ LMAX].
    Qed.

    (** Also, we show that the search will not yield jobs that arrive later than the
        given reference time. *)
    Lemma fsc_respects_has_arrived:
      forall j t,
        sched (find_swap_candidate arr_seq sched t) == Some j ->
        has_arrived j t.
    Proof.
      move=> j t.
      rewrite /find_swap_candidate.
      destruct search_arg eqn:RES; last first.
      { move: (H_jobs_must_be_ready j t).
        rewrite /scheduled_at scheduled_in_def => READY SCHED_J.
        apply READY in SCHED_J.
        by apply (ready_implies_arrived sched). }
      { move=> /eqP SCHED_J.
        move: RES => /search_arg_pred.
        rewrite SCHED_J //. }
    Qed.

    (** Next, we extend the previous lemma by stating that no job in the transformed
        schedule is scheduled before its arrival. *)
    Lemma swap_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute sched'.
    Proof.
      move=> j t SCHED_AT.
      move: (swap_job_scheduled_cases _ _ _ _ _ SCHED_AT)=> [OTHER |[AT_T1 | AT_T2]].
      { have READY: job_ready sched j t by apply H_jobs_must_be_ready; rewrite -OTHER //.
          by apply (ready_implies_arrived sched). }
      { set t2 := find_swap_candidate arr_seq sched t1 in AT_T1.
        move: AT_T1 => [EQ_T1 SCHED_AT'].
        apply fsc_respects_has_arrived.
        move: SCHED_AT.
        rewrite EQ_T1 /SCHED_AT' /sched' -/t2.
        rewrite EQ_T1 in SCHED_AT'.
        rewrite SCHED_AT' /scheduled_at.
        by rewrite scheduled_in_def. }
      { set t2 := find_swap_candidate arr_seq sched t1 in AT_T2.
        move: AT_T2 => [EQ_T2 SCHED_AT'].
        have ORDER: t1<=t2 by apply swap_candidate_is_in_future.
        have READY: job_ready sched j t1 by apply H_jobs_must_be_ready; rewrite -SCHED_AT' //.
        rewrite /job_ready /basic_ready_instance /pending /completed_by in READY.
        move: READY => /andP [ARR _].
        rewrite EQ_T2.
        rewrite /has_arrived in ARR.
        apply leq_trans with (n := t1) => //. }
    Qed.

    (** Finally we show that, in the transformed schedule, jobs are scheduled
        only if they are ready. *)
    Lemma fsc_jobs_must_be_ready_to_execute:
      jobs_must_be_ready_to_execute sched'.
    Proof.
      move=> j t SCHED_AT.
      rewrite /sched'.
      set t2 := find_swap_candidate arr_seq sched t1.
      rewrite /job_ready /basic_ready_instance /pending.
      apply /andP; split; first by apply swap_jobs_must_arrive_to_execute.
      rewrite /completed_by; rewrite -ltnNge.
      apply swapped_completed_jobs_dont_execute => //.
      - by apply swap_candidate_is_in_future.
      - by apply ideal_proc_model_provides_unit_service.
      - by apply ideal_proc_model_ensures_ideal_progress.
      - by eapply completed_jobs_are_not_ready.
    Qed.

  End JobsMustBeReadyFindSwapCandidate.

  (** In the following section, we put our attention on the point-wise
      transformation performed at each point in time prior to the horizon. *)
  Section MakeWCAtFacts.

    (** Consider an ideal uniprocessor schedule... *)
    Variable sched: schedule (ideal.processor_state Job).

    (** ...and take an arbitrary point in time... *)
    Variable t: instant.

    (** ...we define [sched'] as the resulting schedule after one point-wise transformation. *)
    Let sched' := make_wc_at arr_seq sched t.

    (** We start by proving that the point-wise transformation can only lead
        to higher service for a job at a given time. This is true because we
        swap only idle processor states with ones in which a job is scheduled. *)
    Lemma mwa_service_bound:
      forall j t, service sched j t <= service sched' j t.
    Proof.
      intros j t'.
      rewrite /sched' /make_wc_at.
      destruct (sched t) eqn:PSTATE => //.
      set t2:= (find_swap_candidate arr_seq sched t).
      move: (swap_candidate_is_in_future sched t) => ORDER.
      destruct (leqP t' t) as [BOUND1|BOUND1];
        first by rewrite (service_before_swap_invariant _ t t2) => //.
      destruct (ltnP t2 t') as [BOUND2 | BOUND2];
        first by rewrite (service_after_swap_invariant  _ t t2) => //.
      destruct (scheduled_at sched j t) eqn:SCHED_AT_T1;
        first by move:SCHED_AT_T1; rewrite scheduled_at_def PSTATE => /eqP.
      move: SCHED_AT_T1 => /negbT NOT_AT_t1.
      destruct (scheduled_at sched j t2) eqn:SCHED_AT_T2;
        last by move: SCHED_AT_T2 => /negbT NOT_AT_t2; rewrite (service_of_others_invariant _ t t2).
      rewrite /swapped /service -service_at_other_times_invariant; last by left.
      rewrite service_in_replaced; last by apply /andP; split => //.
      rewrite (not_scheduled_implies_no_service _ _ _  NOT_AT_t1) subn0.
        by apply leq_addr.
    Qed.

    (** Next, we show that any ready job in the transformed schedule must be ready also in
        the original one, since the transformation can only lead to higher service. *)
    Lemma mwa_ready_job_also_ready_in_original_schedule:
      forall j t, job_ready sched' j t -> job_ready sched j t.
    Proof.
      intros j t'.
      rewrite /job_ready /basic_ready_instance /pending.
      move=> /andP [ARR COMP_BY].
      rewrite ARR Bool.andb_true_l //.
      move: COMP_BY; apply contra.
      rewrite /completed_by.
      have LEQ: (service sched j t') <= (service sched' j t') by apply mwa_service_bound.
      move=> LEQ'; move:LEQ; move: LEQ'.
        by apply leq_trans.
    Qed.

    (** Since the search for a swap candidate is performed until the latest deadline
        among all the jobs arrived before the reference time, we need to show that the computed
        deadline is indeed the latest. *)
    Lemma max_dl_is_greatest_dl:
      forall j t,
        arrives_in arr_seq j ->
        job_arrival j <= t ->
        job_deadline j <= max_deadline_for_jobs_arrived_before arr_seq t.
    Proof.
      move=> j t' ARR_IN ARR.
      rewrite /max_deadline_for_jobs_arrived_before.
      apply in_max0_le; apply map_f.
      rewrite /arrivals_up_to.
      apply arrived_between_implies_in_arrivals;
        by move:H_arr_seq_valid => [CONS UNIQ].
    Qed.

    (** Next, we want to show that, if a job arriving from the arrival
       sequence is ready at some instant, then the point-wise transformation
       is guaranteed to find a job to swap with. We will proceed by doing a case
       analysis, and show that it is impossible that a swap candidate is not found. *)
    Section MakeWCAtFindsReadyJobs.

      (** We need to assume that, in the original schedule, all the deadlines of
          the jobs coming from the arrival sequence are met, in order to be sure that
          a ready job will be eventually scheduled. *)
      Hypothesis H_all_deadlines_of_arrivals_met: all_deadlines_of_arrivals_met arr_seq sched.

      (** We define [max_dl] as the maximum deadline for all jobs arrived before [t]. *)
      Let max_dl := max_deadline_for_jobs_arrived_before arr_seq t.

      (** Next, we define [search_result] as the result of the search for a swap candidate.
          In order to take the first result, it is sufficient to define the ordering function
          as a constant false. *)
      Definition order (_ _ : nat) := false.
      Definition search_result := search_arg sched (relevant_pstate t) order t max_dl.

      (** First, we consider the case in which the procedure finds a job to swap with. *)
      Section MakeWCAtFindsReadyJobs_CaseResultFound.

        (** Assuming that the processor is idle at time t... *)
        Hypothesis H_sched_t_idle: is_idle sched t.

        (** ...let [t_swap] be a time instant found by the search procedure. *)
        Variable t_swap: instant.
        Hypothesis search_result_found: search_result = Some t_swap.

        (** We show that, since the search only yields relevant processor states, a job is found. *)
        Lemma make_wc_at_case_result_found:
          exists j: Job,
            swapped sched t t_swap t = Some j.
        Proof.
          apply search_arg_pred in search_result_found.
          move:search_result_found; rewrite /relevant_pstate.
          destruct (sched t_swap) as [j_swap|] eqn:SCHED; last by done.
          move=>ARR. rewrite /swapped /replace_at.
          destruct (t_swap == t) eqn:SAME_SWAP.
          + move:SAME_SWAP => /eqP SAME_SWAP; subst t_swap.
            move:H_sched_t_idle => /eqP SCHED_NONE.
              by rewrite SCHED_NONE in SCHED; discriminate.
          + exists j_swap.
              by rewrite eq_refl; apply SCHED.
        Qed.

      End MakeWCAtFindsReadyJobs_CaseResultFound.

      (** Conversely, we prove that assuming that the search yields no
          result brings to a contradiction. *)
      Section MakeWCAtFindsReadyJobs_CaseResultNone.

        (** Consider a job that arrives in the arrival sequence, and assume that
            it is ready at time [t] in the transformed schedule. *)
        Variable j: Job.
        Hypothesis H_arrives_in: arrives_in arr_seq j.
        Hypothesis H_job_ready_sched': job_ready sched' j t.

        (** Moreover, assume the search for a swap candidate yields nothing. *)
        Hypothesis H_search_result_none: search_result = None.

        (** First, note that, since nothing was found, it means there is no relevant
           processor state between [t] and [max_dl]. *)
        Lemma no_relevant_state_in_range:
          forall t',
            t <= t' < max_dl ->
            ~~ (relevant_pstate t) (sched t').
        Proof.
            by apply (search_arg_none _ _ (fun _ _ => false)).
        Qed.

        (** Since [j] is ready at time [t], then it must be incomplete. *)
        Lemma service_of_j_is_less_than_cost: service sched j t < job_cost j.
        Proof.
          have READY_ORIG: job_ready sched j t
            by apply (mwa_ready_job_also_ready_in_original_schedule _ _); apply H_job_ready_sched'.
          rewrite /job_ready /basic_ready_instance /pending.
          move:READY_ORIG => /andP [ARR_ NOT_COMPL_ORIG].
          rewrite /completed_by in NOT_COMPL_ORIG.
            by rewrite leqNgt; apply NOT_COMPL_ORIG.
        Qed.

        (** And since [j] is incomplete and meets its deadline, the deadline of [j]
            is in the future. *)
        Lemma t_is_less_than_deadline_of_j: t <= job_deadline j.
        Proof.
          move: (H_all_deadlines_of_arrivals_met j H_arrives_in)=> MEETS_DL_j.
          move_neq_up LEQ_t1.
          unfold job_meets_deadline, completed_by in MEETS_DL_j; move_neq_down MEETS_DL_j.
          eapply leq_ltn_trans; last apply service_of_j_is_less_than_cost.
            by apply service_monotonic, ltnW.
        Qed.

        (** On the other hand, since we know that there is no relevant state between [t] and [max_dl],
            then it must be the case that [j] is never scheduled in this period, and hence gets no
            service. *)
        Lemma equal_service_t_max_dl: service sched j t = service sched j max_dl.
        Proof.
          move:(H_job_ready_sched') => /andP [ARR NOT_COMPL_sched'].
          rewrite -(service_cat sched j t max_dl);
            last by apply (leq_trans t_is_less_than_deadline_of_j), max_dl_is_greatest_dl.
          have ZERO_SERVICE: service_during sched j t max_dl = 0.
          { apply not_scheduled_during_implies_zero_service.
            apply ideal_proc_model_ensures_ideal_progress.
            move=> t_at RANGE.
            move:(no_relevant_state_in_range t_at RANGE) => NOT_REL.
            rewrite scheduled_at_def.
            apply/negP; move => /eqP EQ.
              by move: NOT_REL => /negP T; apply: T; rewrite EQ.
          }
            by rewrite ZERO_SERVICE; rewrite addn0.
        Qed.

        (** Combining the previous lemmas, we can deduce that [j] misses its deadline. *)
        Lemma j_misses_deadline: service sched j (job_deadline j) < job_cost j.
        Proof.
          move:(H_job_ready_sched') => /andP [ARR NOT_COMPL_sched'].
          have J_LESS := service_of_j_is_less_than_cost.
          rewrite equal_service_t_max_dl in J_LESS.
          specialize (H_all_deadlines_of_arrivals_met j H_arrives_in).
          unfold job_meets_deadline, completed_by in H_all_deadlines_of_arrivals_met.
          eapply leq_ltn_trans.
          - by apply service_monotonic, (max_dl_is_greatest_dl _ _ H_arrives_in ARR).
          - by apply J_LESS.
        Qed.

        (** The fact that [j] misses its deadline contradicts the fact that all deadlines
            of jobs coming from the arrival sequence are met. We have a contradiction. *)
        Lemma make_wc_at_case_result_none: False.
        Proof.
          move: (H_all_deadlines_of_arrivals_met j H_arrives_in) => NEQ.
          unfold job_meets_deadline, completed_by in NEQ.
          move_neq_down NEQ.
            by apply j_misses_deadline.
        Qed.

      End MakeWCAtFindsReadyJobs_CaseResultNone.

      (** Next, we show that [make_wc_at] always manages to establish the work-conservation property
          at the given time. Using the above case analysis, we can conclude that the presence of a
          ready job always leads to a valid swap. *)
      Lemma mwa_finds_ready_jobs:
        all_deadlines_of_arrivals_met arr_seq sched ->
        is_work_conserving_at sched' t.
      Proof.
        move=> ALL_DL_MET P_PREFIX.
        destruct (sched t) as [j'|] eqn:SCHED_WC_t;
          first by rewrite /sched' /make_wc_at SCHED_WC_t; exists j'.
        move: P_PREFIX => [j [ARR_IN READY]].
        rewrite /sched' /make_wc_at.
        rewrite SCHED_WC_t /find_swap_candidate.
        destruct search_arg as [t_swap| ] eqn:SEARCH_RES.
        - by apply make_wc_at_case_result_found; move:SCHED_WC_t => /eqP.
        - by exfalso; apply (make_wc_at_case_result_none j); eauto.
      Qed.

    End MakeWCAtFindsReadyJobs.

    (** Next we prove that, given a schedule that respects the work-conservation property until [t-1],
        applying the point-wise transformation at time [t] will extend the property until [t]. *)
    Lemma mwa_establishes_wc:
      all_deadlines_of_arrivals_met arr_seq sched ->
      (forall t_l, t_l < t -> is_work_conserving_at sched t_l) ->
      forall t_l, t_l <= t -> is_work_conserving_at sched' t_l.
    Proof.
      move=> PROP P_PREFIX t' T_MIN [j [ARR_IN READY]].
      set fsc := find_swap_candidate arr_seq sched t.
      have LEQ_fsc: t <= fsc by apply swap_candidate_is_in_future.
      destruct (ltnP t' t) as [tLT | tGE].
      { have SAME: sched' t' = sched t'.
        { rewrite /sched' /make_wc_at.
          destruct (sched t); first by done.
            by rewrite (swap_before_invariant sched t fsc) //. }
        rewrite SAME.
        apply P_PREFIX; eauto.
        exists j; split; auto.
          by eapply mwa_ready_job_also_ready_in_original_schedule, READY.
      }
      { have EQ: t' = t.
        { by apply /eqP; rewrite eqn_leq; apply /andP; split. }
        subst t'; clear T_MIN tGE.
        apply mwa_finds_ready_jobs => //.
          by exists j; split; eauto.
      }
    Qed.

    (** We now show that the point-wise transformation does not introduce any new job
        that does not come from the arrival sequence. *)
    Lemma mwa_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq ->
      jobs_come_from_arrival_sequence sched' arr_seq.
    Proof.
      rewrite /sched' /make_wc_at.
      destruct (sched t) as [j_orig|] eqn:SCHED_orig; first by done.
      by apply swapped_jobs_come_from_arrival_sequence.
    Qed.

    (** We also show that the point-wise transformation does not schedule jobs in instants
        in which they are not ready. *)
    Lemma mwa_jobs_must_be_ready_to_execute:
      jobs_must_be_ready_to_execute sched ->
      jobs_must_be_ready_to_execute sched'.
    Proof.
      move=> READY.
      rewrite /sched' /make_wc_at.
      destruct (sched t) as [j_orig|] eqn:SCHED_orig; first by done.
      by apply fsc_jobs_must_be_ready_to_execute.
    Qed.

    (** Finally, we show that the point-wise transformation does not introduce deadline misses. *)
    Lemma mwa_all_deadlines_of_arrivals_met:
      all_deadlines_of_arrivals_met arr_seq sched ->
      all_deadlines_of_arrivals_met arr_seq sched'.
    Proof.
      move=> ALL j ARR.
      specialize (ALL j ARR).
      unfold job_meets_deadline, completed_by in *.
      by apply (leq_trans ALL (mwa_service_bound _ _)).
    Qed.

  End MakeWCAtFacts.

  (** In the following section, we proceed by proving some useful properties respected by
      the partial schedule obtained by applying the work-conservation transformation up to
      an arbitrary horizon. *)
  Section PrefixFacts.

    (** Consider an ideal uniprocessor schedule. *)
    Variable sched: schedule (ideal.processor_state Job).

    (** We start by proving that the transformation performed with two different horizons
        will yield two schedules that are identical until the earlier horizon. *)
    Section PrefixInclusion.

      (** Consider two horizons... *)
      Variable h1 h2: instant.

      (** ...and assume w.l.o.g. that they are ordered... *)
      Hypothesis H_horizon_order: h1 <= h2.

      (** ...we define two schedules, resulting from the transformation
          performed, respectively, until the first and the second horizon. *)
      Let sched1 := wc_transform_prefix arr_seq sched h1.
      Let sched2 := wc_transform_prefix arr_seq sched h2.

      (** Then, we show that the two schedules are guaranteed to be equal until the
          earlier horizon. *)
      Lemma wc_transform_prefix_inclusion:
        forall t, t < h1 -> sched1 t = sched2 t.
      Proof.
        move=> t before_horizon.
        rewrite /sched1 /sched2.
        induction h2; first by move: (ltn_leq_trans before_horizon H_horizon_order).
        move: H_horizon_order. rewrite leq_eqVlt => /orP [/eqP ->|LT]; first by done.
        move: LT. rewrite ltnS => H_horizon_order_lt.
        rewrite [RHS]/wc_transform_prefix /prefix_map -/prefix_map IHi //.
        rewrite {1}/make_wc_at.
        destruct (prefix_map sched (make_wc_at arr_seq) i i) as [j|] eqn:SCHED; first by done.
        rewrite -(swap_before_invariant _ i (find_swap_candidate arr_seq (wc_transform_prefix arr_seq sched i) i));
          last by apply ltn_leq_trans with (n := h1).
        rewrite //.
        apply swap_candidate_is_in_future.
      Qed.

    End PrefixInclusion.

    (** Next, we show that repeating the point-wise transformation up to a given horizon
        does not introduce any deadline miss. *)
    Section JobsMeetDeadlinePrefix.

      (** Assuming that all deadlines of jobs coming from the arrival sequence are met... *)
      Hypothesis H_all_deadlines_of_arrivals_met: all_deadlines_of_arrivals_met arr_seq sched.

      (** ...let us define [sched'] as the schedule resulting from the
          full work-conservation transformation. Note that, if the schedule is sampled at time
          [t], the transformation is performed until [t+1]. *)
      Let sched' := wc_transform arr_seq sched.

      (** Consider a job from the arrival sequence. *)
      Variable j: Job.
      Hypothesis H_arrives_in: arrives_in arr_seq j.

      (** We show that, in the transformed schedule, the service of the job
          is always greater or equal than in the original one, at any given time. *)
      Lemma wc_prefix_service_bound:
        forall t, service sched j t <= service sched' j t.
      Proof.
        move=> t.
        rewrite /sched' /wc_transform.
        set serv := service (fun t0 : instant => wc_transform_prefix arr_seq sched t0.+1 t0) j t.
        set servp := service (wc_transform_prefix arr_seq sched t.+1) j t.
        have ->: serv = servp.
        { rewrite /serv /servp /service /service_during.
          apply eq_big_nat => t' /andP [_ LT_t].
          rewrite /service_at.
          rewrite (wc_transform_prefix_inclusion t'.+1 t.+1)=> //.
          by auto. }
        rewrite /servp /wc_transform_prefix.
        clear serv servp.
        apply prefix_map_property_invariance; last by done.
        intros. apply leq_trans with (service sched0 j t)=> //.
        by intros; apply mwa_service_bound.
      Qed.

      (** Finally, it follows directly that the transformed schedule cannot introduce
          a deadline miss for any job from the arrival sequence. *)
      Lemma wc_prefix_job_meets_deadline:
        job_meets_deadline sched' j.
      Proof.
        rewrite /job_meets_deadline /completed_by /sched'.
        apply leq_trans with (service sched j (job_deadline j));
          last by apply wc_prefix_service_bound.
        by apply H_all_deadlines_of_arrivals_met.
      Qed.

    End JobsMeetDeadlinePrefix.

    (** Next, consider a given time, used as horizon for the transformation... *)
    Variable h: instant.

    (** ...and let us call [sched'] the schedule resulting from the transformation
        performed until [h]. *)
    Let sched' := wc_transform_prefix arr_seq sched h.

    (** We prove that [sched'] will never introduce jobs not coming from the
        arrival sequence. *)
    Lemma wc_prefix_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq ->
      jobs_come_from_arrival_sequence sched' arr_seq.
    Proof.
      move=> FROM_ARR.
      rewrite /sched' /wc_transform_prefix.
      apply prefix_map_property_invariance; last by done.
      move => schedX t ARR.
      by apply mwa_jobs_come_from_arrival_sequence.
    Qed.

    (** Similarly, we can show that [sched'] will only schedule jobs if they are
        ready. *)
    Lemma wc_prefix_jobs_must_be_ready_to_execute:
      jobs_must_be_ready_to_execute sched ->
      jobs_must_be_ready_to_execute sched'.
    Proof.
      move=> READY.
      rewrite /sched' /wc_transform_prefix.
      apply prefix_map_property_invariance; last by done.
      move=> schedX t ARR.
      by apply mwa_jobs_must_be_ready_to_execute.
    Qed.

  End PrefixFacts.

End AuxiliaryLemmasWorkConservingTransformation.

(** Finally, we can leverage all the previous results to prove statements about the full
    work-conservation transformation. *)
Section WorkConservingTransformation.

  (** Consider any type of jobs with arrival times, costs, and deadlines... *)
  Context {Job : JobType}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.
  Context `{JobDeadline Job}.

  (** ...an arbitrary valid arrival sequence... *)
  Variable arr_seq: arrival_sequence Job.
  Hypothesis H_arr_seq_valid: valid_arrival_sequence arr_seq.

  (** ...and an ideal uniprocessor schedule... *)
  Variable sched: schedule (ideal.processor_state Job).

  (** ...in which jobs come from the arrival sequence, and must be ready to execute...  *)
  Hypothesis H_sched_valid: valid_schedule sched arr_seq.

  (** ...and in which no job misses a deadline. *)
  Hypothesis H_all_deadlines_of_arrivals_met: all_deadlines_of_arrivals_met arr_seq sched.

  (** Let us call [sched_wc] the schedule obtained after applying the work-conservation transformation. *)
  Let sched_wc := wc_transform arr_seq sched.

  (** First, we show that any scheduled job still comes from the arrival sequence. *)
  Lemma wc_jobs_come_from_arrival_sequence:
    jobs_come_from_arrival_sequence sched_wc arr_seq.
  Proof.
    rewrite /sched_wc /wc_transform.
    move=> j t.
    move: H_sched_valid => [ARR READY].
    rewrite /scheduled_at -/(scheduled_at _ j t).
    by apply (wc_prefix_jobs_come_from_arrival_sequence arr_seq sched t.+1 ARR).
  Qed.

  (** Similarly, jobs are only scheduled if they are ready. *)
  Lemma wc_jobs_must_be_ready_to_execute:
    jobs_must_be_ready_to_execute sched_wc.
  Proof.
    move=> j t.
    move: H_sched_valid => [ARR READY].
    rewrite /scheduled_at /sched_wc /wc_transform -/(scheduled_at _ j t) => SCHED_AT.
    have READY': job_ready (wc_transform_prefix arr_seq sched t.+1) j t
      by apply wc_prefix_jobs_must_be_ready_to_execute => //.
    move: READY'.
    rewrite /job_ready /basic.basic_ready_instance
            /pending /completed_by /service.
    rewrite (equal_prefix_implies_same_service_during sched_wc (wc_transform_prefix arr_seq sched t.+1)) //.
    move=> t' /andP [_ BOUND_t'].
    rewrite /sched_wc /wc_transform.
    by apply wc_transform_prefix_inclusion => //; rewrite ltnS; apply ltnW.
  Qed.

  (** Also, no deadline misses are introduced. *)
  Lemma wc_all_deadlines_of_arrivals_met:
    all_deadlines_of_arrivals_met arr_seq sched_wc.
  Proof.
    move=> j ARR_IN.
    rewrite /sched_wc /wc_transform_prefix.
    by apply wc_prefix_job_meets_deadline.
  Qed.

  (** Finally, we can show that the transformation leads to a schedule in which
      the processor is not idle if a job is ready. *)
  Lemma wc_is_work_conserving_at:
    forall j t,
      job_ready sched_wc j t ->
      arrives_in arr_seq j ->
      exists j', sched_wc t = Some j'.
  Proof.
    move=> j t READY ARR_IN.
    rewrite /sched_wc /wc_transform /wc_transform_prefix.
    apply (prefix_map_pointwise_property (all_deadlines_of_arrivals_met arr_seq)
                                         (is_work_conserving_at arr_seq)
                                         (make_wc_at arr_seq)); rewrite //.
    { by apply mwa_all_deadlines_of_arrivals_met. }
    { by intros; apply mwa_establishes_wc. }
    { exists j.
      split; first by apply ARR_IN.
      have EQ: job_ready sched_wc j t = job_ready (prefix_map sched (make_wc_at arr_seq) (succn t)) j t.
      {
        rewrite /sched_wc /wc_transform /job_ready
                /basic_ready_instance /pending /completed_by
                /service /service_during /service_at /wc_transform_prefix.
        destruct has_arrived; last by rewrite Bool.andb_false_l.
        have EQ_SUM: \sum_(0 <= t0 < t) service_in j (prefix_map sched (make_wc_at arr_seq) (succn t0) t0)
                  = \sum_(0 <= t0 < t) service_in j (prefix_map sched (make_wc_at arr_seq) (succn t) t0).
        {  apply eq_big_nat => t' /andP [_ LT_t].
           rewrite -/(wc_transform_prefix arr_seq sched _ _).
           rewrite -/(wc_transform_prefix arr_seq sched _ _).
           rewrite (wc_transform_prefix_inclusion arr_seq sched t'.+1 t.+1)=> //.
           by auto. }
        by rewrite EQ_SUM. }
      move: READY. by rewrite EQ. }
  Qed.

  (** We can easily extend the previous lemma to obtain the definition
      of a work-conserving schedule. *)
  Lemma wc_is_work_conserving:
    work_conserving arr_seq sched_wc.
  Proof.
    move=> j t ARR_IN.
    rewrite /backlogged => /andP [READY _].
    move: (wc_is_work_conserving_at j t READY ARR_IN) => [j' SCHED_wc].
    by exists j'; rewrite scheduled_at_def; apply /eqP.
  Qed.

  (** Ultimately, we can show that the work-conservation transformation maintains
      all the properties of validity, does not introduce new deadline misses, and
      establishes the work-conservation property. *)
  Theorem wc_transform_correctness:
    valid_schedule sched_wc arr_seq /\
    all_deadlines_of_arrivals_met arr_seq sched_wc /\
    work_conserving arr_seq sched_wc.
  Proof.
    repeat split.
    - apply wc_jobs_come_from_arrival_sequence.
    - apply wc_jobs_must_be_ready_to_execute.
    - apply wc_all_deadlines_of_arrivals_met.
    - apply wc_is_work_conserving.
  Qed.

End WorkConservingTransformation.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import PeanoNat.

Require Export Parser.DescriptionInd.
Require Export Parser.NetworkGoodCells.
Require Export Parser.NetworkProperties.

Opaque Nat.eq_dec.

Definition wip_inputs
             { A } (s: Syntax A) { G } (descr: Description G) (N: Network) k (b1 b2: nat): Prop :=
  match s with
  | Epsilon _ => inputs N k = []
  | Failure _ => inputs N k = []
  | Elem _ => inputs N k = []
  | Disjunction s1 s2 => exists opt1 opt2,
      b1 < S k /\
      S (k + syntax_size s1) < b2 /\
      inputs N k = [ S k; S (k + syntax_size s1) ] /\
      map (cells N) (inputs N k) = [
        make_cell_with_state s1 descr opt1; make_cell_with_state s2 descr opt2
      ]
  | Sequence s1 s2 => exists opt1 opt2,
      b1 <= S k /\
      S (k + syntax_size s1) < b2 /\
      inputs N k = [ S k; S (k + syntax_size s1) ] /\
      map (cells N) (inputs N k) = [
        make_cell_with_state s1 descr opt1; make_cell_with_state s2 descr opt2
      ]
  | Map f g s' => exists opt',
      b1 <= S k /\ S k < b2 /\
      inputs N k = [ S k ] /\
      map (cells N) (inputs N k) = [ make_cell_with_state s' descr opt' ]
  | Var x => exists opt',
      inputs N k = [ sum_sizes_until x ] /\
      map (cells N) (inputs N k) = [ make_cell_with_state (e x) descr opt' ]
  end.

Definition wip_cell { G } (descr: Description G) (N: Network) (k: nat) (b1 b2: nat): Prop :=
  exists A (s: Syntax A) (opt: option (G A)),
    cells N k = make_cell_with_state s descr opt /\
    opt_forall opt (descr_ind descr s) /\
    wip_inputs s descr N k b1 b2.

(** The "work-in-progress" property states that the state of every cell can
    be derived from the states of its inputs according to the description `descr`.
    We prove later that this is an invariant of the network (during computation),
    which ensures the soundness statement `fun_soundness_statement` *)
Definition wip_cells { G } (descr: Description G) (N: Network) (b1 b2: nat): Prop :=
  forall k, b1 <= k -> k < b2 -> wip_cell descr N k b1 b2.

Ltac instantiate_wip_cells k :=
  match goal with
  | H: wip_cells _ _ _ _ |- _ =>
    poseNew (Mark k "instantiate_wip_cells");
    let W := fresh "W" in
    unshelve epose proof (H k _ _) as W; eauto with lia; unfold wip_cell in W
  end.

Lemma good_inputs_wip_inputs:
  forall A (s: Syntax A) G (descr: Description G) N k b1 b2,
    good_inputs s descr N k b1 b2 ->
    (forall x, cells N (sum_sizes_until x) = make_cell_with_state (e x) descr None) ->
    wip_inputs s descr N k b1 b2.
Proof.
  destruct s; repeat light; eauto 6.
  exists None; repeat light || rewrite_known_inputs.
Qed.

Lemma good_cell_wip_cell:
  forall G (descr: Description G) N k b1 b2,
    good_cell descr N k b1 b2 ->
    (forall x, cells N (sum_sizes_until x) = make_cell_with_state (e x) descr None) ->
    wip_cell descr N k b1 b2.
Proof.
  unfold good_cell, wip_cell;
    repeat light.
  exists A, s, None; repeat light;
    eauto using good_inputs_wip_inputs.
Qed.

(** Initially, the network satisfies the `wip_cells` invariant *)
Lemma wip_cells_make_network:
  forall A (s: Syntax A) G (descr: Description G) k,
    k < sum_sizes vars + syntax_size s ->
    wip_cell descr (make_network s descr) k 0 (sum_sizes vars + syntax_size s).
Proof.
  intros; apply good_cell_wip_cell;
    eauto using good_cells_make_network;
    eauto using var_cells_make_network.
Qed.

Lemma still_wip_inputs:
  forall A (s: Syntax A) G (descr: Description G) N b1 b2 k opt (opt': option (G A)) H,
    wip_inputs s descr N k b1 b2 ->
    cells N k = make_cell_with_state s descr opt ->
    (forall x, exists optx, cells N (sum_sizes_until x) = make_cell_with_state (e x) descr optx) ->
    wip_inputs s descr (
      set_cell N k {|
       main_type := main_type (cells N k);
       cell_type := cell_type (cells N k);
       input_types := input_types (cells N k);
       update := update (cells N k);
       measure := measure (cells N k);
       state := cast H (s, opt')
      |})
      k b1 b2.
Proof.
  destruct s; repeat light.
  - eexists; eexists; repeat light || map_ext_in || destruct_match || rewrite_known_inputs;
      eauto; try lia.
  - eexists; eexists; repeat light || map_ext_in || destruct_match || rewrite_known_inputs;
      eauto; try lia.
  - eexists; repeat light || map_ext_in || destruct_match || rewrite_known_inputs;
      eauto; try lia.
  - pose proof (Nat.eq_dec k (sum_sizes_until x)); lights;
      try solve [ eexists; repeat light || destruct_match || rewrite_known_inputs; eauto ].
    specialize H2 with x; lights.
    pose proof (eq_trans (eq_sym H1) H0) as HE.
    pose proof (f_equal_dep _ state HE);
      repeat eq_dep || cbn in * || rewrite state_make_cell in * || invert_constructor_equalities.
    exists opt'; repeat light || rewrite_known_inputs || destruct_match || invert_constructor_equalities.
    f_equal.
    generalize H.
    rewrite H3; repeat cbn in * || eq_dep.
    repeat rewrite <- H6 || light || eq_dep.
Qed.

Lemma still_wip_inputs2:
  forall A (s: Syntax A) G (descr: Description G) N b1 b2 k k' hl,
    wip_inputs s descr N k b1 b2 ->
    k <> k' ->
    wip_inputs s descr (
      set_cell N k' {|
       main_type := main_type (cells N k');
       cell_type := cell_type (cells N k');
       input_types := input_types (cells N k');
       update := update (cells N k');
       measure := measure (cells N k');
       state := update (cells N k') hl
      |})
      k b1 b2.
Proof.
  destruct s; repeat light || rewrite_known_inputs || invert_constructor_equalities.
  - destruct (Nat.eq_dec k' (S k)); destruct (Nat.eq_dec k' (S (k + syntax_size s1)));
      repeat light;
      try solve [ repeat syntax_size_gt_0; eauto with lia ].

    + unshelve eexists (@snd (Syntax A) (option (G A)) (cast _ (update (cells N (S k)) hl)));
        try solve [ rewrite_any; eapply cell_type_node_type ].
      exists opt2; repeat light || f_equal;
        eauto using update_make_cell2.

    + exists opt1;
      unshelve eexists (@snd (Syntax A) (option (G A)) (cast _ (update (cells N (S (k + syntax_size s1))) hl)));
        try solve [ rewrite_any; eapply cell_type_node_type ];
        repeat light || f_equal;
        eauto using update_make_cell2.

    + exists opt1, opt2; repeat light || f_equal.

  - destruct (Nat.eq_dec k' (S k)); destruct (Nat.eq_dec k' (S (k + syntax_size s1)));
      repeat light;
      try solve [ repeat syntax_size_gt_0; eauto with lia ].

    + unshelve eexists (@snd (Syntax A) (option (G A)) (cast _ (update (cells N (S k)) hl)));
        try solve [ rewrite_any; eapply cell_type_node_type ].
      exists opt2; repeat light || f_equal;
        eauto using update_make_cell2.

    + exists opt1;
      unshelve eexists (@snd (Syntax B) (option (G B)) (cast _ (update (cells N (S (k + syntax_size s1))) hl)));
        try solve [ rewrite_any; eapply cell_type_node_type ];
        repeat light || f_equal;
        eauto using update_make_cell2.

    + exists opt1, opt2; repeat light || f_equal.

  - destruct (Nat.eq_dec k' (S k));
      repeat light.

    + unshelve eexists (@snd (Syntax A) (option (G A)) (cast _ (update (cells N (S k)) hl)));
        try solve [ rewrite_any; eapply cell_type_node_type ];
        repeat light || f_equal;
        eauto using update_make_cell2.

    + exists opt';
        repeat light || f_equal;
        eauto using update_make_cell2.

  - destruct (Nat.eq_dec k' (sum_sizes_until x));
      repeat light.

    + unshelve eexists (@snd (Syntax (get_type x)) (option (G (get_type x))) (cast _ (update (cells N (sum_sizes_until x)) hl)));
        try solve [ rewrite_any; eapply cell_type_node_type ];
        repeat light || f_equal;
        eauto using update_make_cell2.

    + exists opt';
        repeat light || f_equal;
        eauto using update_make_cell2.
Qed.

Ltac equate_states :=
  match goal with
  | H1: state (cells ?N ?k) = ?q1,
    H2: state (cells ?N ?k) = ?q2 |- _ =>
    poseNew (Mark (H1, H2) "equate_states");
    pose proof (eq_trans (eq_sym H1) H2)
  end.

Lemma update_obligation:
  forall A (s: Syntax A) G (descr : Description G) (N : Network) (k : nat) (opt: option (G A)),
    cells N k = make_cell_with_state s descr opt ->
    (Syntax A * option (G A))%type = cell_type (cells N k).
Proof.
  repeat light || f_equal_dep.
  rewrite_known_cells.
  rewrite cell_type_node_type.
  reflexivity.
Qed.

Lemma update_is_cast:
  forall A (s: Syntax A) G (descr : Description G) (N : Network) (k : nat) (opt: option (G A)) hl
    (H: cells N k = make_cell_with_state s descr opt),
    exists opt': option (G A),
      update (cells N k) hl = cast (update_obligation A s G descr N k opt H) (s, opt').
Proof.
  repeat light || f_equal_dep.
  destruct s;
    repeat light || rewrite_known_updates || eq_dep;
    try solve [
      repeat generalize_proofs; generalize hl;
      rewrite_known_cell_types;
      rewrite H5; repeat light || eq_dep;
      unfold rules_to_update; eauto
    ].
Qed.

(** The "work-in-progress" invariant is maintained after running the network one step *)
Lemma wip_cells_compute_cell:
  forall G (descr: Description G) N N' b1 b2 k pre,
    wip_cells descr N b1 b2 ->
    b1 <= k ->
    k < b2 ->
    (forall x, b1 <= sum_sizes_until x /\ sum_sizes_until x < b2) ->
    (forall x, exists optx, cells N (sum_sizes_until x) = make_cell_with_state (e x) descr optx) ->
    compute_cell N k pre = Some N' ->
    wip_cells descr N' b1 b2.
Proof.
  unfold compute_cell, wip_cells, wip_cell;
    repeat light || destruct_match || invert_constructor_equalities || clear l matched ||
           instantiate_any ||
           lazymatch goal with
           | H: cells ?N ?k = make_cell_with_state ?s _ _ |- exists _ _ _, {| cell_type := cell_type (cells ?N ?k); state := ?q |} = _ /\ _ =>
             eexists _; exists s; unshelve eexists (snd (@cast _ (node_type _ G) _ q))
           end;
      try solve [ rewrite_known_cells; eauto using cell_type_node_type ];
      eauto using update_make_cell;
      eauto using still_wip_inputs;
      try solve [ repeat eexists; eauto using still_wip_inputs2 ].

  - repeat f_equal_dep.
    repeat eq_dep.

    unfold make_cell_with_state in H13, H15, H17.
    destruct s0; rewrite H15; repeat light || eq_dep;
    try solve [
      repeat generalize_proofs;
      rewrite_known_inputs; cbn;
      match goal with
      | H: input_types (cells _ _) = _ |- _ => rewrite H
      end; cbn;
      match goal with
      | H: cell_type (cells _ _) = _ |- _ => rewrite H
      end; cbn;
      unfold opt_forall; repeat light || eq_dep || destruct_match;
      apply_anywhere fold_left_or_else; repeat light; eauto with descr_ind
    ].

    + (* disjunction *)
      repeat generalize_proofs.
      rewrite_known_inputs; repeat cbn in * || invert_constructor_equalities.
      unshelve epose proof (H (S k0) _ _); try lia; repeat destruct_exists || destruct_and.
      unshelve epose proof (H (S (k0 + syntax_size s0_1)) _ _); try lia;
        repeat destruct_exists || destruct_and.
      match goal with
      | H: input_types (cells _ _) = _ |- _ => rewrite H
      end; cbn.

      repeat rewrite_known_cell_types.
      repeat f_equal_dep2.
      rewrite cell_type_node_type in *.
      rewrite state_make_cell in *.
      repeat cbn in * || eq_dep.
      repeat rewrite_known_states; repeat cbn in * || eq_dep.
      repeat generalize_proofs.

      repeat rewrite_known_cell_types; repeat light || eq_dep.
      unfold opt_forall; repeat light || eq_dep || destruct_match.
      apply_anywhere fold_left_or_else; repeat light.
      eapply in_disj_descr; eauto;
        unfold node_type; repeat light || eq_dep.
      * repeat same_cell_same_type; repeat light || eq_dep.
        repeat equate_states.
        repeat equate_states; repeat apply_anywhere eq_rect_reverse;
          repeat light || invert_constructor_equalities.
      * repeat same_cell_same_type; repeat light || eq_dep.
        repeat equate_states; repeat apply_anywhere eq_rect_reverse;
          repeat light || invert_constructor_equalities.

    + (* sequence *)
      repeat generalize_proofs.
      rewrite_known_inputs; repeat cbn in * || invert_constructor_equalities.
      unshelve epose proof (H (S k0) _ _); try lia; repeat destruct_exists || destruct_and.
      unshelve epose proof (H (S (k0 + syntax_size s0_1)) _ _); try lia;
        repeat destruct_exists || destruct_and.
      match goal with
      | H: input_types (cells _ _) = _ |- _ => rewrite H
      end; cbn.

      repeat rewrite_known_cell_types.
      repeat f_equal_dep2.
      rewrite cell_type_node_type in *.
      rewrite state_make_cell in *.
      repeat cbn in * || eq_dep.
      repeat rewrite_known_states; repeat cbn in * || eq_dep.
      repeat generalize_proofs.

      repeat rewrite_known_cell_types; repeat light || eq_dep.
      unfold opt_forall; repeat light || eq_dep || destruct_match.
      apply_anywhere fold_left_or_else; repeat light.
      eapply in_seq_descr; eauto;
        unfold node_type; repeat light || eq_dep.
      * repeat same_cell_same_type; repeat light || eq_dep.
        repeat equate_states; repeat apply_anywhere eq_rect_reverse;
          repeat light || invert_constructor_equalities.
      * repeat same_cell_same_type; repeat light || eq_dep.
        repeat equate_states; repeat apply_anywhere eq_rect_reverse;
          repeat light || invert_constructor_equalities.

    + (* map *)
      repeat generalize_proofs.
      rewrite_known_inputs; repeat cbn in * || invert_constructor_equalities.
      unshelve epose proof (H (S k0) _ _); try lia; repeat destruct_exists || destruct_and.
      match goal with
      | H: input_types (cells _ _) = _ |- _ => rewrite H
      end; cbn.

      repeat rewrite_known_cell_types.
      repeat f_equal_dep2.
      rewrite cell_type_node_type in *.
      rewrite state_make_cell in *.
      repeat cbn in * || eq_dep.
      repeat rewrite_known_states; repeat cbn in * || eq_dep.
      repeat generalize_proofs.

      repeat rewrite_known_cell_types; repeat light || eq_dep.
      unfold opt_forall; repeat light || eq_dep || destruct_match.
      apply_anywhere fold_left_or_else; repeat light.
      eapply in_map_descr; eauto;
        unfold node_type; repeat light || eq_dep.
      repeat same_cell_same_type; repeat light || eq_dep.
      repeat equate_states; repeat apply_anywhere eq_rect_reverse;
        repeat light || invert_constructor_equalities.

    + (* var *)
      repeat generalize_proofs.
      rewrite_known_inputs; repeat cbn in * || invert_constructor_equalities.
      unshelve epose proof (H (sum_sizes_until x) _ _);
        try lia; repeat destruct_exists || destruct_and || apply_any.
      match goal with
      | H: input_types (cells _ _) = _ |- _ => rewrite H
      end; cbn.

      repeat rewrite_known_cell_types.
      repeat f_equal_dep2.
      rewrite cell_type_node_type in *.
      rewrite state_make_cell in *.
      repeat cbn in * || eq_dep.
      repeat rewrite_known_states; repeat cbn in * || eq_dep.
      repeat generalize_proofs.

      repeat rewrite_known_cell_types; repeat light || eq_dep.
      unfold opt_forall; repeat light || eq_dep || destruct_match.
      apply_anywhere fold_left_or_else; repeat light.
      eapply in_var_descr; eauto;
        unfold node_type; repeat light || eq_dep.
      repeat same_cell_same_type; repeat light || eq_dep.
      repeat equate_states; repeat apply_anywhere eq_rect_reverse;
        repeat light || invert_constructor_equalities.

  - match goal with
    | |- context[update ?c ?hl] =>
      unshelve epose proof (update_is_cast _ _ _ _ _ _ _ hl H10)
    end; lights.
    rewrite H11; eauto using still_wip_inputs.
Qed.

Opaque make_cell_with_state.
Opaque compute_cells.

Lemma wip_cells_compute_cells':
  forall m G (descr: Description G) N num_cells ks pre,
    (sum_measures num_cells N, length ks) = m ->
    wip_cells descr N 0 num_cells ->
    (forall k, In k ks -> k < num_cells) ->
    (forall x, sum_sizes_until x < num_cells) ->
    (forall x, exists optx, cells N (sum_sizes_until x) = make_cell_with_state (e x) descr optx) ->
    wip_cells descr (compute_cells num_cells N ks pre) 0 num_cells.
Proof.
  induction m using measure_induction; destruct ks;
    repeat light || compute_cells_def || destruct_match || options.

  - clear matched.
    revert i.
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_3 num_cells N n ks pre).
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_2 num_cells N n ks pre).
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_1 num_cells N n ks pre).
    repeat light || destruct_match || options.

    eapply H;
      repeat light;
      try solve [ apply left_lex; eauto using compute_cell_size ].

    + eapply (wip_cells_compute_cell _ _ N _ _ _ n);
        eauto; repeat light || apply_any; try lia.
    + specialize H4 with x; lights; eauto using compute_cell_still_make_cell.

  - clear matched.
    revert n0.
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_5 num_cells N n ks pre).
    generalize (PropagatorNetwork.compute_cells_obligations_obligation_1 num_cells N n ks pre).
    repeat light || destruct_match;
      eauto 2 with lights.

    eapply H;
      repeat light || apply right_lex;
      eauto using cell_type_compute_cell.
Qed.

(** The "work-in-progress" invariant is maintained after running the network *)
Lemma wip_cells_compute_cells:
  forall G (descr: Description G) N num_cells ks pre,
    wip_cells descr N 0 num_cells ->
    (forall k, In k ks -> k < num_cells) ->
    (forall x, sum_sizes_until x < num_cells) ->
    (forall x, exists optx, cells N (sum_sizes_until x) = make_cell_with_state (e x) descr optx) ->
    wip_cells descr (compute_cells num_cells N ks pre) 0 num_cells.
Proof.
  eauto using wip_cells_compute_cells'.
Qed.

Lemma wip_cells_compute_cells_make_network:
  forall A (s: Syntax A) G (descr: Description G) pre,
    wip_cells descr (
      compute_cells
        (sum_sizes vars + syntax_size s)
        (make_network s descr)
        (range 0 (sum_sizes vars + syntax_size s))
        pre
    ) 0 (sum_sizes vars + syntax_size s).
Proof.
  intros.
  apply wip_cells_compute_cells;
    repeat light || unfold wip_cells;
    try solve [ pose proof (sum_sizes_until_sum_sizes x); eauto with lia ];
    eauto using wip_cells_make_network;
    eauto using var_cells_make_network.
Qed.


Require Import Coq.Structures.Equalities.
Require Import Coq.Lists.List.

Module Type HasDefault (Import T: Typ).
  Parameter Inline(30) default : t.
End HasDefault.

Module Type Default := Typ <+ HasDefault.

Module Type Eqb := Typ <+ HasEqb.

Module Store (K: Eqb) (V: Default).
  Definition store := list (K.t * V.t).
  Definition empty : store := nil.

  Fixpoint get (st: store) (k: K.t) : V.t :=
    match st with
    | nil => V.default
    | (k', v) :: tail =>
        if K.eqb k k'
        then v
        else get tail k
    end.

  Fixpoint set (st: store) (k: K.t) (v: V.t) : store :=
    match st with
    | nil => (k, v) :: nil
    | (k', v') :: tail =>
        if K.eqb k k'
        then (k, v) :: tail
        else (k', v') :: set tail k v
    end.
End Store.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.

Definition HMAC_DRBG_update (HMAC: list Z -> list Z -> list Z) (provided_data K V: list Z): (list Z * list Z) :=
  let K := HMAC (V ++ [0] ++ provided_data) K in
  let V := HMAC V K in
  match provided_data with
    | [] => (K, V)
    | _::_ =>
      let K := HMAC (V ++ [1] ++ provided_data) K in
      let V := HMAC V K in
      (K, V)
  end.