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

(* ** Luca's theorem *)

Require Import Arith Nat Lia List.

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

From Undecidability.H10.ArithLibs
  Require Import Zp.

Set Implicit Arguments.

Set Default Proof Using "Type".

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

Section fact.

  Let factorial_cancel n a b : fact n * a = fact n * b -> a = b.
  Proof.
    apply Nat.mul_cancel_l.
    generalize (fact_gt_0 n); intro; lia.
  Qed.

  Notation Π := (msum mult 1).

  Notation mprod_an := (fun a n => Π n (fun i => i+a)).

  Fact mprod_factorial n : fact n = mprod_an 1 n.
  Proof.
    induction n as [ | n IHn ].
    + rewrite msum_0; auto.
    + rewrite msum_plus1; auto.
      rewrite mult_comm, <- IHn, fact_S.
      f_equal; lia.
  Qed.

  Variable (p : nat) (Hp : p <> 0).

  Notation "〚 x 〛" := (nat2Zp Hp x).

  Let expo_p_cancel n a b : expo n p * a = expo n p * b -> a = b.
  Proof.
    apply Nat.mul_cancel_l.
    generalize (power_ge_1 n Hp); intros; lia.
  Qed.

  Fact mprod_factorial_Zp i n :〚mprod_an (i*p+1) n〛=〚fact n〛.
  Proof.
    rewrite mprod_factorial.
    induction n as [ | n IHn ].
    + do 2 rewrite msum_0; auto.
    + do 2 (rewrite msum_plus1; auto).
      do 2 rewrite nat2Zp_mult; f_equal; auto.
      apply nat2Zp_inj.
      rewrite (plus_comm n), <- plus_assoc, plus_comm.
      rewrite <- rem_plus_div; auto.
      * f_equal; lia.
      * apply divides_mult, divides_refl.
  Qed.

  Notation φ := (fun n r => mprod_an (n*p+1) r).
  Notation Ψ := (fun n => Π n (fun i => mprod_an (i*p+1) (p-1))).

  Let phi_Zp_eq n r :〚φ n r〛=〚fact r〛.
  Proof. apply mprod_factorial_Zp. Qed.

  Fact mprod_factorial_mult n : fact (n*p) = expo n p * fact n * Ψ n.
  Proof using Hp.
    induction n as [ | n IHn ].
    + rewrite Nat.mul_0_l, msum_0, mscal_0, fact_0; auto.
    + replace (S n*p) with (n*p+p) by ring.
      rewrite mprod_factorial, msum_plus, <- mprod_factorial; auto.
      replace p with (S (p-1)) at 2 by lia.
      rewrite msum_plus1; auto.
      rewrite <- plus_assoc.
      replace (p-1+1) with p by lia.
      replace (n*p+p) with ((S n)*p) by ring.
      rewrite mscal_S, fact_S, msum_S.
      rewrite IHn.
      repeat rewrite mult_assoc.
      rewrite (mult_comm _ p).
      repeat rewrite <- mult_assoc.
      do 2 f_equal.
      rewrite (mult_comm (S n)).
      repeat rewrite <- mult_assoc; f_equal.
      repeat rewrite mult_assoc; f_equal.
      rewrite msum_ext with (f := fun i => n*p+i+1)
                            (g := fun i => i+(n*p+1)).
      2: intros; ring.
      rewrite <- msum_plus1; auto.
  Qed.

  Lemma mprod_factorial_euclid n r : fact (n*p+r) = expo n p * fact n * φ n r * Ψ n.
  Proof using Hp.
    rewrite mprod_factorial, msum_plus; auto.
    rewrite <- mprod_factorial.
    rewrite msum_ext with (f := fun i => n*p+i+1)
                          (g := fun i => i+(n*p+1)).
    2: intros; ring.
    rewrite mprod_factorial_mult; auto; ring.
  Qed.

  Notation Zp := (Zp_zero Hp).
  Notation Op := (Zp_one Hp).
  Notation "∸" := (Zp_opp Hp).
  Infix "⊗" := (Zp_mult Hp) (at level 40, left associativity).
  Notation expoZp := (mscal (Zp_mult Hp) (Zp_one Hp)).

  Hint Resolve Nat_mult_monoid : core.

  Let Psi_Zp_eq n :〚Ψ n〛= expoZp n〚fact (p-1)〛.
  Proof.
    induction n as [ | n IHn ].
    + rewrite msum_0, mscal_0; auto.
    + rewrite msum_plus1, nat2Zp_mult.
      rewrite mscal_plus1; auto.
      2: apply Zp_mult_monoid.
      2: apply Nat_mult_monoid.
      f_equal; auto.
  Qed.

  Hypothesis (Hprime : prime p).

  Let phi_Zp_invertible n r : r < p -> Zp_invertible Hp 〚φ n r〛.
  Proof.
    intros H; simpl; rewrite phi_Zp_eq.
    apply Zp_invertible_factorial; auto.
  Qed.

  Let Psi_Zp_invertible n : Zp_invertible Hp 〚Ψ n〛.
  Proof.
    simpl; rewrite (Psi_Zp_eq n).
    apply Zp_expo_invertible, Zp_invertible_factorial; auto; lia.
  Qed.

  (* rewrite the binomial theorem

               fact k * fact (n-k) * binomial n k = fact n

      when

         k = K*p + k0
         n = N*p + n0

      with

      1)  K <= N & k0 <= n0

      we get n-k = (N-K)*p + (n0-k0) and

        expo K     p * fact K     * φ K      k0     * Ψ K
      .* expo (N-K) p * fact (N-K) * φ (N-K) (n0-k0) * Ψ (N-K)
      .* binomial n k
      = expo N p     * fact N     * φ N      n0     * Ψ N.

      hence, simplifying by expo N p  we get

        fact K * fact (N-K) * φ K k0 * Ψ K * φ (N-K) (n0-k0) * Ψ (N-K) * binomial n k = fact N * φ N n0 * Ψ N.

      then in Z/Zp we derive (modulo Wilson's theorem, unnecessary here〚fact (p-1)〛=〚-1〛)

       〚fact K〛⊗〚fact (N-K)〛⊗〚fact k0〛⊗〚-1〛^K⊗〚fact (n0-k0)〛⊗〚-1〛^(N-K)⊗〚binomial n k〛
      =〚fact N〛⊗〚fact n0〛⊗〚-1〛^N

        that we combine with 〚fact K〛⊗〚fact (N-K)〛⊗〚binomial N K〛=〚fact N〛
                        and  〚fact k0〛⊗〚fact (n0-k0)〛⊗〚binomial n0 k0〛=〚fact n0〛

        to derive the result:〚binomial n k 〛=〚binomial N K〛⊗〚binomial n0 k0〛

      with

      2) K < N & n0 < k0

      we have n-k = (N-(K+1))*p + (p-(k0-n0)) and

        expo K         p * fact K         * φ K          k0         * Ψ K
      .* expo (N-(K+1)) p * fact (N-(K+1)) * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1))
      .* binomial n k
      = expo N p     * fact N     * φ N      n0     * Ψ N.

      hence

         fact K * φ K k0 * Ψ K * fact (N-(K+1)) * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
       = p * ....

      then in Z/Zp all the left factor are invertible except binomial n k which must thus be〚0〛 *)

  Section binomial_without_p_not_zero.

    Variable (n N n0 k K k0 : nat) (Hn : n = N*p+n0) (Hk : k = K*p+k0) (H1 : K <= N) (H2 : k0 <= n0).

    Let Hkn : k <= n.
    Proof.
      rewrite Hn, Hk.
      replace N with (K+(N-K)) by lia.
      rewrite Nat.mul_add_distr_r.
      generalize ((N-K)*p); intros; lia.
    Qed.

    Let Hnk : n - k = (N-K)*p+(n0-k0).
    Proof.
      rewrite Hn, Hk, Nat.mul_sub_distr_r.
      cut (K*p <= N*p).
      + generalize (K*p) (N*p); intros; lia.
      + apply mult_le_compat; auto.
    Qed.

    Fact binomial_wo_p : φ K k0 * Ψ K * φ (N-K) (n0-k0) * Ψ (N-K) * binomial n k
                       = binomial N K * φ N n0 * Ψ N.
    Proof using Hkn.
      apply (factorial_cancel (N-K)); repeat rewrite mult_assoc.
      rewrite (mult_comm (fact _) (binomial _ _)).
      apply (factorial_cancel K); repeat rewrite mult_assoc.
      rewrite (mult_comm (fact _) (binomial _ _)).
      rewrite <- binomial_thm; auto.
      apply expo_p_cancel with N.
      repeat rewrite mult_assoc.
      rewrite <- mprod_factorial_euclid, <- Hn.
      rewrite binomial_thm with (1 := Hkn).
      rewrite Hnk.
      rewrite Hk at 3.
      replace N with (K+(N-K)) at 1 by lia.
      rewrite power_plus.
      do 2 rewrite mprod_factorial_euclid.
      ring.
    Qed.

    Hypothesis (Hn0 : n0 < p).

    Hint Resolve Zp_mult_monoid : core.

    Fact binomial_Zp_prod :〚binomial n k〛=〚binomial N K〛⊗〚binomial n0 k0〛.
    Proof using Hkn Hn0 Hprime.
      generalize binomial_wo_p; intros G.
      apply f_equal with (f := nat2Zp Hp) in G.
      repeat rewrite nat2Zp_mult in G.
      repeat rewrite Psi_Zp_eq in G.
      repeat rewrite phi_Zp_eq in G.
      rewrite binomial_thm with (1 := H2) in G.
      repeat rewrite nat2Zp_mult in G.
      rewrite (Zp_mult_comm _ _〚 fact k0 〛) in G.
      repeat rewrite Zp_mult_assoc in G.
      rewrite (Zp_mult_comm _ _〚 fact k0 〛) in G.
      repeat rewrite <- Zp_mult_assoc in G.
      apply Zp_invertible_cancel_l in G.
      2: apply Zp_invertible_factorial; auto; lia.
      repeat rewrite Zp_mult_assoc in G.
      do 2 rewrite (Zp_mult_comm _ _〚 fact _ 〛) in G.
      repeat rewrite <- Zp_mult_assoc in G.
      apply Zp_invertible_cancel_l in G.
      2: apply Zp_invertible_factorial; auto; lia.
      repeat rewrite Zp_mult_assoc in G.
      rewrite <- mscal_plus in G; auto.
      replace (K+(N-K)) with N in G by lia.
      rewrite (Zp_mult_comm _ _ (expoZp _ _)) in G.
      apply Zp_invertible_cancel_l in G; trivial.
      apply Zp_expo_invertible, Zp_invertible_factorial; auto; lia.
    Qed.

  End binomial_without_p_not_zero.

  Section binomial_without_p_zero.

    Variable (n N n0 k K k0 : nat) (Hn : n = N*p+n0) (Hk : k = K*p+k0)
             (H1 : K < N) (H2 : n0 < k0) (Hk0 : k0 < p).

    Let H3 : p - (k0-n0) < p.    Proof. lia. Qed.
    Let H4 : S (N-1) = N.        Proof. lia. Qed.
    Let H5 : N-1 = K+(N-(K+1)).  Proof. lia. Qed.
    Let H6 : N = K+1+(N-(K+1)).  Proof. lia. Qed.
    Let HNK : N-K = S (N-(K+1)). Proof. lia. Qed.

    Let Hkn : k <= n.
    Proof.
      rewrite Hn, Hk, H6.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((N-(K+1))*p); clear H3 H4 H5 H6 HNK; intros; lia.
    Qed.

    Let Hnk : n - k = (N-(K+1))*p+(p-(k0-n0)).
    Proof.
      rewrite Hn, Hk, Nat.mul_sub_distr_r.
      cut ((K+1)*p <= N*p).
      + rewrite Nat.mul_add_distr_r.
        generalize (K*p) (N*p); clear H3 H4 H5 H6 HNK Hkn; intros; lia.
      + apply mult_le_compat; auto; clear H3 H4 H5 H6 HNK Hkn; lia.
    Qed.

    Fact binomial_with_p : fact K * fact (N-(K+1)) * φ K k0 * Ψ K * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
                         = p * fact N * φ N n0 * Ψ N.
    Proof using Hkn.
      apply expo_p_cancel with (N-1).
      repeat rewrite mult_assoc.
      rewrite (mult_comm (expo _ _) p).
      rewrite <- mscal_S.
      rewrite H4, <- mprod_factorial_euclid, <- Hn.
      rewrite binomial_thm with (1 := Hkn).
      rewrite Hnk.
      rewrite Hk at 3.
      do 2 rewrite mprod_factorial_euclid.
      rewrite H5 at 1.
      rewrite power_plus.
      ring.
    Qed.

    Fact binomial_with_p' : φ K k0 * Ψ K * φ (N-(K+1)) (p-(k0-n0)) * Ψ (N-(K+1)) * binomial n k
                          = p * binomial N K * (N-K) * φ N n0 * Ψ N.
    Proof using Hkn.
      apply (factorial_cancel (N-(K+1))); repeat rewrite mult_assoc.
      apply (factorial_cancel K); repeat rewrite mult_assoc.
      rewrite binomial_with_p.
      rewrite binomial_thm with (n := N) (p := K).
      2: { apply lt_le_weak; auto. }
      rewrite HNK at 1.
      rewrite fact_S.
      rewrite <- HNK.
      ring.
    Qed.

    Fact binomial_Zp_zero :〚binomial n k〛= Zp.
    Proof using Hkn Hprime.
      generalize binomial_with_p'; intros G.
      apply f_equal with (f := nat2Zp Hp) in G.
      repeat rewrite nat2Zp_mult in G.
      rewrite nat2Zp_p in G.
      repeat rewrite Zp_mult_zero in G.
      apply Zp_invertible_eq_zero in G; auto.
      repeat (apply Zp_mult_invertible; auto).
    Qed.

  End binomial_without_p_zero.

End fact.

Section lucas_lemma.

  (* https://math.stackexchange.com/questions/1463758/proof-of-lucas-theorem-without-the-polynomial-hint *)

  Variables (p : nat) (Hprime : prime p).

  Let Hp : p <> 0.
  Proof.
    generalize (prime_ge_2 Hprime); intro; lia.
  Qed.

  Variables (n N n0 k K k0 : nat)
            (G1 : n = N*p+n0)  (G2 : n0 < p)
            (G3 : k = K*p+k0)  (G4 : k0 < p).

  Let choice : (K <= N  /\ k0 <= n0)
            \/ (n0 < k0 /\ K < N)
            \/ ((n0 < k0 \/ N < K) /\ n < k).
  Proof.
    destruct (le_lt_dec k n) as [ H0 | H0 ];
    destruct (le_lt_dec k0 n0) as [ H1 | H1 ];
    destruct (le_lt_dec K N) as [ H2 | H2 ]; try lia.
    + do 2 right; split; auto.
      rewrite G1, G3.
      replace K with (N+1+(K-N-1)) by lia.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((K-N-1)*p); intros; lia.
    + destruct (eq_nat_dec N K); try lia.
    + do 2 right; split; auto.
      rewrite G1, G3.
      replace K with (N+1+(K-N-1)) by lia.
      do 2 rewrite Nat.mul_add_distr_r.
      generalize ((K-N-1)*p); intros; lia.
  Qed.

  Theorem lucas_lemma : rem (binomial n k) p = rem (binomial N K * binomial n0 k0) p.
  Proof using choice.
    destruct choice as [ (H1 & H2)
                     | [ (H1 & H2)
                       | (H1 & H2) ] ]; clear choice.
    3: { rewrite binomial_gt with (1 := H2).
         f_equal.
         destruct H1 as [ H1 | H1 ];
           rewrite binomial_gt with (1 := H1); ring. }
    + apply nat2Zp_inj with (Hp := Hp).
      rewrite nat2Zp_mult.
      apply binomial_Zp_prod; auto.
    + rewrite binomial_gt with (1 := H1).
      rewrite Nat.mul_0_r.
      apply nat2Zp_inj with (Hp := Hp).
      rewrite nat2Zp_zero.
      apply binomial_Zp_zero with (2 := G1) (3 := G3); auto.
  Qed.

End lucas_lemma.

(* Eval compute in binomial 3 0. *)

Section lucas_theorem.

  Variable (p : nat) (Hp : prime p).

  Implicit Types (l m : list nat).

  (* base_p [x0;x1;x2;...] =  x0 + x1*p + x2*p² ...*)

  Notation base_p := (expand p).

  Fixpoint binomial_p l :=
    match l with
      | nil  => fix loop m := match m with
        | nil  => 1
        | y::m => binomial 0 y * loop m
      end
      | x::l => fun m => match m with
        | nil   => binomial x 0 * binomial_p l nil
        | y::m  => binomial x y * binomial_p l m
      end
    end.

  Fact binomial_p_fix00 : binomial_p nil nil = 1.
  Proof. auto. Qed.

  Fact binomial_p_fix01 y m : binomial_p nil (y::m) = binomial 0 y * binomial_p nil m.
  Proof. auto. Qed.

  Fact binomial_p_fix10 x l : binomial_p (x::l) nil = binomial x 0 * binomial_p l nil.
  Proof. auto. Qed.

  Fact binomial_p_fix11 x l y m : binomial_p (x::l) (y::m) = binomial x y * binomial_p l m.
  Proof. auto. Qed.

  (* This is Luca's thm as described eg on Wikipedia

      if p is prime
      and x = x0 + x1*p + x2*p² ...
      and y = y0 + y1*p + y2*p² ...

      then the identity

         binomial x y = binomial x0 y0 * binomial x1 y1 * binomial x2 y2 * ...

      holds modulo p

   *)

  Theorem lucas_theorem (l m : list nat) :
         Forall (fun i => i < p) l               (* digits must be less than p*)
      -> Forall (fun i => i < p) m               (* digits must be less than p*)
      -> rem (binomial (base_p l) (base_p m)) p
       = rem (binomial_p l m) p.
  Proof using Hp.
    intros H; revert H m.
    induction 1 as [ | x l H1 H2 IH2 ];
    induction 1 as [ | y m H3 H4 IH4 ].
    + simpl; auto.
    + rewrite binomial_p_fix01; simpl base_p.
      rewrite <- rem_mult_rem, <- IH4, rem_mult_rem,
              (mult_comm p), plus_comm, (mult_comm (binomial _ _)).
      apply lucas_lemma; auto; simpl; lia.
    + rewrite binomial_p_fix10; simpl base_p.
      rewrite <- rem_mult_rem, <- IH2, rem_mult_rem; auto.
      rewrite (mult_comm p), plus_comm, (mult_comm (binomial _ _)).
      apply lucas_lemma; auto; simpl; lia.
    + rewrite binomial_p_fix11; simpl base_p.
      rewrite <- rem_mult_rem, <- IH2, rem_mult_rem; auto.
      rewrite !(mult_comm p), !(plus_comm _ (_ * _)), (mult_comm (binomial _ _)).
      apply lucas_lemma; auto; simpl; lia.
  Qed.

End lucas_theorem.

(* Check lucas_theorem. *)


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.

Section mono_epi.

  Context {C : Category}.

  Definition mono {X Y : Obj C} (f : Hom X Y) :=
    forall (A : Obj C) (g1 g2 : Hom A X), f \o g1 = f \o g2 -> g1 = g2.

  Definition epi {X Y : Obj C} (f : Hom X Y) :=
    forall (A : Obj C) (g1 g2 : Hom A X), f \o g1 = f \o g2 -> g1 = g2.

  Lemma iso_mono {X Y : Obj C}:
    forall (f : Hom X Y), isomorphism f -> mono f.
  Proof.
    move => f.
    case.
    move => g.
    case.
    move => eqgf eqfg.
    move => A g1 g2.
    move/ (f_equal (fun x => g \o x)).
    repeat rewrite <- Hom_assoc.
    move: eqgf =>->.
    repeat rewrite Hom_IdL.
    by [].
  Qed.

  Lemma id_mono {X : Obj C} :
    mono (\Id X).
  Proof.
    apply: iso_mono.
    exact: isomorphism_id.
  Qed.

  Lemma mono_comp {X Y Z : Obj C} :
    forall (f : Hom Y Z) (g : Hom X Y), mono f -> mono g -> mono (f \o g).
  Proof.
    move => f g.
    move => mono_f mono_g.
    move => A h1 h2.
    repeat rewrite Hom_assoc.
    move/ mono_f.
    exact: mono_g.
  Qed.

  Lemma iso_epi {X Y : Obj C}:
    forall (f : Hom X Y), isomorphism f -> epi f.
  Proof.
    move => f.
    case.
    move => g.
    case.
    move => eqgf eqfg.
    move => A g1 g2.
    move/ (f_equal (fun x => g \o x)).
    repeat rewrite <- Hom_assoc.
    move: eqgf =>->.
    repeat rewrite Hom_IdL.
    by [].
  Qed.

  Lemma id_epi {X : Obj C} :
    epi (\Id X).
  Proof.
    apply: iso_epi.
    exact: isomorphism_id.
  Qed.

  Lemma epi_comp {X Y Z : Obj C} :
    forall (f : Hom Y Z) (g : Hom X Y), epi f -> epi g -> epi (f \o g).
  Proof.
    move => f g.
    move => mono_f mono_g.
    move => A h1 h2.
    repeat rewrite Hom_assoc.
    move/ mono_f.
    exact: mono_g.
  Qed.

End mono_epi.


Require Import Setoids.
Require Import Category7.
Require Import Eq_Category7.

Record Functor (C D:Category) : Type := functor
    { Func_         : Arr C -> Arr D
    ; Func_compat_  : forall (f g:Arr C), f == g -> Func_ f == Func_ g
    ; Func_source_  : forall (f:Arr C), source (Func_ f) == Func_ (source f)
    ; Func_target_  : forall (f:Arr C), target (Func_ f) == Func_ (target f)
    ; Func_compose_ : forall (f g:Arr C),
        forall (p: target f == source g) (q: target (Func_ f) == source (Func_ g)),
        Func_ (compose_ C g f p) == compose_ D (Func_ g) (Func_ f) q

    }
    .

Arguments Func_ {C} {D} _ _.

Lemma Functor_obj_ : forall (C D:Category)(F:Functor C D)(a:Arr C),
    source a == a -> source (Func_ F a) == Func_ F a.
Proof.
    intros C D F a H. apply trans with (Func_ F (source a)).
    - apply Func_source_.
    - apply Func_compat_. assumption.
Qed.

Arguments Functor_obj_ {C} {D} _ _ _.

Definition apply (C D:Category) (F:Functor C D)(a:Obj C) : Obj D :=
    match a with
    | obj a' p      => obj (Func_ F a') (Functor_obj_ F a' p)
    end.

Arguments apply {C} {D} _ _.

Notation "F $ a" := (apply F a) (at level 0, right associativity) : categ.

Definition lift_arrow_(C D:Category)(a b:Obj C)(F:Functor C D)(f:Hom a b):Arr D :=
    match f with
    | hom f' p q    => Func_ F f'
    end.

Arguments lift_arrow_ {C} {D} {a} {b} _ _.

Definition lift_source_:forall (C D:Category)(a b:Obj C)(F:Functor C D)(f:Hom a b),
    source (lift_arrow_ F f) == arr (F $ a).
Proof.
    intros C D [a Ha] [b Hb] F [f p q]. simpl. simpl in p.
    apply trans with (Func_ F (source f)).
    - apply Func_source_.
    - apply Func_compat_. assumption.
Qed.

Arguments lift_source_ {C} {D} {a} {b} _ _.

Open Scope categ.

Definition lift_target_:forall (C D:Category)(a b:Obj C)(F:Functor C D)(f:Hom a b),
    target (lift_arrow_ F f) == arr F $ b.
Proof.
    intros C D [a Ha] [b Hb] F [f p q]. simpl. simpl in q.
    apply trans with (Func_ F (target f)).
    - apply Func_target_.
    - apply Func_compat_. assumption.
Qed.

Arguments lift_target_ {C} {D} {a} {b} _ _.

Definition lift(C D:Category)(a b:Obj C)(F:Functor C D)(f:Hom a b):
  Hom (F $ a) (F $ b) := hom (lift_arrow_ F f)(lift_source_ F f)(lift_target_ F f).

Arguments lift {C} {D} {a} {b} _ _.

Notation "F <$> f" := (lift F f) (at level 0, right associativity) : categ.

Lemma functor_id : forall (C D:Category) (F:Functor C D) (a:Obj C),
    i F<$>(id a) == i (id F $ a).
Proof. intros C D F [a Ha]. simpl. apply refl. Qed.

Lemma functor_law : forall (C D:Category) (F:Functor C D) (a b c:Obj C),
    forall (g:Hom b c) (f:Hom a b), i F<$>(g # f) == i (F<$>g # F<$>f).
Proof.
    intros C D F [a Ha] [b Hb] [c Hc] [g Ag Bg] [f Af Bf]. simpl.
    unfold compose_arrow. simpl. apply Func_compose_.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (lf3 : natural) : natural := plus lf3 z.


(* This module only serves to demonstrate that defining the notion of well-     *)
(* formed type expression without reference to valid contexts is legitimate.    *)
(* More precisely, we define an alternative definition of validity which is     *)
(* coupled with the definition of well-formed type expressions, where those     *)
(* can only occur in a valid context. We show that this new notion of valid     *)
(* context is equivalent to our existing notion (see Theorem below).            *)

Require Import Logic.STLC.Valid.
Require Import Logic.STLC.Syntax.
Require Import Logic.STLC.IsType.
Require Import Logic.STLC.Context.

(* New notion of validity and new notion of well-formed type expression,        *)
(* defined as mutually recursive predicates. We now require the context         *)
(* involved in a well-formed type expression to be valid.                       *)
(* Note that these definitions cannot be decoupled from one another.            *)
(* Compare with the definiton of Valid.                                         *)
Inductive Valid2 (b v:Type) : Context -> Prop :=
| Valid2O   : Valid2 b v O
| Valid2Ty  : forall (G:Context) (t:b),
    Valid2 b v G -> Valid2 b v (G ; t ::: *)
| Valid2Var : forall (G:Context) (x:v) (Ty:T b),
    Valid2 b v G -> IsType2 b v G Ty -> Valid2 b v (G ; x ::: Ty)
(* Compare with the definition of IsType.                                       *)
with IsType2 (b v:Type) : @Context b v -> T b -> Prop :=
| TVar2 : forall (G:Context) (t:b),
    Valid2 b v G    ->          (* We require the context to be valid.          *)
    G >> t          ->
    IsType2 b v G 't
| TFun2 : forall (G:Context) (Ty Ty':T b),
    Valid2 b v G        ->      (* We require the context to be valid.          *)
    IsType2 b v G Ty    ->
    IsType2 b v G Ty'   ->
    IsType2 b v G (Ty :-> Ty')
.

Arguments Valid2    {b} {v}.
Arguments Valid2O   {b} {v}.
Arguments Valid2Ty  {b} {v}.
Arguments Valid2Var {b} {v}.
Arguments IsType2   {b} {v}.
Arguments TVar2     {b} {v}.
Arguments TFun2     {b} {v}.

(* The defining requirements for IsType2 appear to be stronger than those of    *)
(* IsType, so we expect the implication IsType2 G Ty -> IsType G Ty to hold.    *)
Lemma IsType2IsType : forall (b v:Type) (G:@Context b v) (Ty:T b),
    IsType2 G Ty -> G :> Ty.
Proof.
   intros b v G Ty H1. induction H1 as [G Ty H2 H3|G Ty Ty' H2 H3 IH1 H4 IH2].
   - constructor. assumption.
   - constructor; assumption.
Qed.

(* The defining requirements for Valid2 are based on a stronger IsType2, so we  *)
(* expect the implication Valid2 G -> Valid G to hold.                          *)
Lemma Valid2Valid : forall (b v:Type) (G:@Context b v),
    Valid2 G -> Valid G.
Proof.
    intros b v G H1. induction H1 as [ |G Ty H2 IH|G x Ty H2 IH H3].
    - constructor.
    - constructor. assumption.
    - constructor; try assumption. apply IsType2IsType. assumption.
Qed.

(* We cannot expect the implication IsType G Ty -> IsType2 G Ty to hold, but    *)
(* this is however true if the context involved is 'strongly' valid.            *)
Lemma IsTypeIsType2 : forall (b v:Type) (G:@Context b v) (Ty:T b),
    Valid2 G -> G :> Ty -> IsType2 G Ty.
Proof.
    intros b v G Ty H H1. revert H.
    induction H1 as [G t|G Ty Ty' H2 IH1 H3 IH2].
    - intros H4. constructor; assumption.
    - intros H4. constructor.
        + assumption.
        + apply IH1. assumption.
        + apply IH2. assumption.
Qed.

(* This is the main helper lemma: the conclusion of this lemma needs to be      *)
(* strong enough so we are able to carry out the induction argument.            *)
Lemma ValidValid2IsType2 : forall (b v:Type) (G:@Context b v),
    Valid G -> Valid2 G /\ (forall (Ty:T b), G :> Ty -> IsType2 G Ty).
Proof.
    intros b v G H1. induction H1 as [ |G t H2 IH|G x Ty H2 IH H3].
    - split; try constructor. intros Ty H2.
      apply notIsTypeInO in H2. contradiction.
    - destruct IH as [IH1 IH2]. split.
        + constructor. assumption.
        + intros Ty H3. apply IsTypeIsType2; try assumption.
          constructor. assumption.
    - destruct IH as [IH1 IH2]. split.
        + constructor; try assumption. apply IH2. assumption.
        + intros Ty' H4. apply IsTypeIsType2; try assumption.
          constructor; try assumption. apply IH2. assumption.
Qed.

(* This is a strenghening of the IsTypeIsType2 result, where we can now rely    *)
(* on the weaker assumption that the context is simply valid (not 'strongly').  *)
Lemma IsTypeIsType2' : forall (b v:Type) (G:@Context b v) (Ty:T b),
    Valid G -> G :> Ty -> IsType2 G Ty.
Proof.
    intros b v G Ty H1 H2. apply ValidValid2IsType2 in H1.
    destruct H1 as [H1 H3]. apply H3. assumption.
Qed.

(* So our seemingly weaker notion of validity actually implies strong validity. *)
Lemma ValidValid2 : forall (b v:Type) (G:@Context b v),
    Valid G -> Valid2 G.
Proof.
    intros b v G H1. apply ValidValid2IsType2 in H1.
    destruct H1 as [H1 H2]. assumption.
Qed.

(* This vindicates our approach of decoupling the notions of valid context and  *)
(* well-formed type expressions, where the latter need not require validity.    *)
Theorem ValidValid2Same : forall (b v:Type) (G:@Context b v),
    Valid G <-> Valid2 G.
Proof.
    intros b v G. split; intros H1.
    - apply ValidValid2. assumption.
    - apply Valid2Valid. assumption.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural := Succ x.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (y : natural) : natural := mult z y.


Require Import WildCat
  AbelianGroup AbHom Centralizer AbProjective
  Groups.FreeGroup.

(** * Cyclic groups *)

(** ** The free group on one generator *)

(** We can define the integers as the free group on one generator, which we denote [Z1] below. Results from Centralizer.v and Groups.FreeGroup let us show that [Z1] is abelian. *)

(** We define [Z] as the free group with a single generator. *)
Definition Z1 := FreeGroup Unit.
Definition Z1_gen : Z1 := freegroup_in tt. (* The generator *)

(** The recursion principle of [Z1] and its computation rule. *)
Definition Z1_rec {G : Group@{u}} (g : G) : Z1 $-> G
  := FreeGroup_rec Unit G (unit_name g).

Definition Z1_rec_beta {G : Group} (g : G) : Z1_rec g Z1_gen = g
  := FreeGroup_rec_beta _ _ _.

(* The free group [Z] on one generator is isomorphic to the subgroup of [Z] generated by the generator.  And such cyclic subgroups are known to be commutative, by [commutative_cyclic_subgroup]. *)
Global Instance Z1_commutative `{Funext} : Commutative (@group_sgop Z1)
  := commutative_iso_commutative iso_subgroup_incl_freegroupon.
(* [Funext] is used in [isfreegroupon_freegroup], but there is a comment there saying that it can be removed.  If that is done, don't need it here either. A different proof of this result, directly using the construction of the free group, could probably also avoid [Funext]. *)

Definition ab_Z1 `{Funext} : AbGroup
  := Build_AbGroup Z1 _.

(** The universal property of [ab_Z1]. *)
Lemma equiv_Z1_hom@{u v | u < v} `{Funext} (A : AbGroup@{u})
  : GroupIsomorphism (ab_hom@{u v} ab_Z1@{u v} A) A.
Proof.
  snrapply Build_GroupIsomorphism'.
  - refine (_ oE (equiv_freegroup_rec@{u u u v} A Unit)^-1).
    symmetry. refine (Build_Equiv _ _ (fun a => unit_name a) _).
  - intros f g. cbn. reflexivity.
Defined.

Definition nat_to_Z1 : nat -> Z1
  := fun n => grp_pow Z1_gen n.

Definition Z1_mul_nat `{Funext} (n : nat) : ab_Z1 $-> ab_Z1
  := Z1_rec (nat_to_Z1 n).

Lemma Z1_mul_nat_beta {A : AbGroup} (a : A) (n : nat)
  : Z1_rec a (nat_to_Z1 n) = ab_mul_nat n a.
Proof.
  induction n as [|n H].
  1: easy.
  refine (grp_pow_homo _ _ _ @ _); simpl.
  by rewrite grp_unit_r.
Defined.

(** [ab_Z1] is projective. *)
Global Instance ab_Z1_projective `{Funext}
  : IsAbProjective ab_Z1.
Proof.
  intros A B p f H1.
  pose proof (a := @center _ (H1 (f Z1_gen))).
  strip_truncations.
  snrefine (tr (Z1_rec a.1; _)).
  cbn beta. apply ap10.
  apply ap. (* of the coercion [grp_homo_map] *)
  apply path_homomorphism_from_free_group.
  simpl.
  intros [].
  refine (_ @ a.2).
  exact (ap p (grp_unit_r _)).
Defined.

(** * Finite cyclic groups *)

(** The [n]-th cyclic group is the cokernel of [Z1_mul_nat n]. *)
Definition cyclic@{u v | u < v} `{Funext} (n : nat) : AbGroup@{u}
  := ab_cokernel@{u v} (Z1_mul_nat n).


Require Import rt.util.all rt.util.divround.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.global.response_time rt.model.schedule.global.schedulability
               rt.model.schedule.global.workload.
Require Import rt.model.schedule.global.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq div fintype bigop path.

Module WorkloadBound.

  Import Job SporadicTaskset Schedule ScheduleOfSporadicTask TaskArrival ResponseTime Schedulability Workload.

  Section WorkloadBoundDef.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.

    (* Consider any task tsk with response-time bound R_tsk,
       that is scheduled in an interval of length delta. *)
    Variable tsk: sporadic_task.
    Variable R_tsk: time.
    Variable delta: time.

    (* Based on the number of jobs that execute completely in the interval, ... *)
    Definition max_jobs :=
      div_floor (delta + R_tsk - task_cost tsk) (task_period tsk).

    (* ... Bertogna and Cirinei's workload bound is defined as follows. *)
    Definition W :=
      let e_k := (task_cost tsk) in
      let p_k := (task_period tsk) in
        minn e_k (delta + R_tsk - e_k - max_jobs * p_k) + max_jobs * e_k.

  End WorkloadBoundDef.

  Section BasicLemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.

    (* Let tsk be any task...*)
    Variable tsk: sporadic_task.

    (* ... with period > 0. *)
    Hypothesis H_period_positive: task_period tsk > 0.

    (* Let R1 <= R2 be two response-time bounds that
       are larger than the cost of the tsk. *)
    Variable R1 R2: time.
    Hypothesis H_R_lower_bound: R1 >= task_cost tsk.
    Hypothesis H_R1_le_R2: R1 <= R2.

    Let workload_bound := W task_cost task_period tsk.

    (* Then, Bertogna and Cirinei's workload bound is monotonically increasing. *)
    Lemma W_monotonic :
      forall t1 t2,
        t1 <= t2 ->
        workload_bound R1 t1 <= workload_bound R2 t2.
    Proof.
      intros t1 t2 LEt.
      unfold workload_bound, W, max_jobs, div_floor; rewrite 2!subndiv_eq_mod.
      set e := task_cost tsk; set p := task_period tsk.
      set x1 := t1 + R1.
      set x2 := t2 + R2.
      set delta := x2 - x1.
      rewrite -[x2](addKn x1) -addnBA; fold delta;
        last by apply leq_add.

      induction delta; first by rewrite addn0 leqnn.
      {
         apply (leq_trans IHdelta).

         (* Prove special case for p <= 1. *)
         destruct (leqP p 1) as [LTp | GTp].
         {
           rewrite leq_eqVlt in LTp; move: LTp => /orP LTp; des;
             last by rewrite ltnS in LTp; apply (leq_trans H_period_positive) in LTp.
           {
             rewrite LTp 2!modn1 2!divn1.
             rewrite leq_add2l leq_mul2r; apply/orP; right.
             by rewrite leq_sub2r // leq_add2l.
           }
         }
         (* Harder case: p > 1. *)
         {
           assert (EQ: (x1 + delta.+1 - e) = (x1 + delta - e).+1).
           {
             rewrite -[(x1 + delta - e).+1]addn1.
             rewrite [_+1]addnC addnBA; last first.
             {
               apply (leq_trans H_R_lower_bound).
               by rewrite -addnA addnC -addnA leq_addr.
             }
             by rewrite [1 + _]addnC -addnA addn1.
           } rewrite -> EQ in *; clear EQ.

         have DIV := divSn_cases (x1 + delta - e) p GTp; des.
         {
           rewrite DIV leq_add2r leq_min; apply/andP; split;
             first by rewrite geq_minl.
           by apply leq_trans with (n := (x1 + delta - e) %% p);
             [by rewrite geq_minr | by rewrite -DIV0 addn1 leqnSn].
         }
         {
           rewrite -[minn e _]add0n -addnA; apply leq_add; first by ins.
           rewrite -DIV mulnDl mul1n [_ + e]addnC.
           by apply leq_add; [by rewrite geq_minl | by ins].
         }
       }
     }
   Qed.

  End BasicLemmas.

  Section ProofWorkloadBound.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.
    Variable job_deadline: Job -> time.

    Variable arr_seq: arrival_sequence Job.

    (* Assume that all jobs have valid parameters *)
    Hypothesis H_jobs_have_valid_parameters :
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Consider any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* Assumption: jobs only execute if they arrived.
       This is used to eliminate jobs that arrive after end of the interval t1 + delta. *)
    Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute job_arrival sched.

    (* Assumption: jobs do not execute after they completed.
       This is used to eliminate jobs that complete before the start of the interval t1. *)
    Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

    (* Assumption: Jobs are sequential.
       This is required to use interval lengths as a measure of service. *)
    Hypothesis H_sequential_jobs: sequential_jobs sched.

    (* Assumption: sporadic task model.
       This is necessary to conclude that consecutive jobs ordered by arrival times
       are separated by at least 'period' times units. *)
    Hypothesis H_sporadic_tasks: sporadic_task_model task_period job_arrival job_task arr_seq.

    (* Before starting the proof, let's give simpler names to the definitions. *)
    Let job_has_completed_by := completed job_cost sched.

    Let workload_of (tsk: sporadic_task) (t1 t2: time) := workload job_task sched tsk t1 t2.

    (* Now we define the theorem. Let tsk be any task in the taskset. *)
    Variable tsk: sporadic_task.

    (* Assumption: the task must have valid parameters:
         a) period > 0 (used in divisions)
         b) deadline of the jobs = deadline of the task
         c) cost <= period
            (used to prove that the distance between the first and last
             jobs is at least (cost + n*period), where n is the number
             of middle jobs. If cost >> period, the claim does not hold
             for every task set. *)
    Hypothesis H_valid_task_parameters:
      is_valid_sporadic_task task_cost task_period task_deadline tsk.

    (* Assumption: the task must have a constrained deadline.
       This is required to prove that n_k (max_jobs) from Bertogna
       and Cirinei's formula accounts for at least the number of
       middle jobs (i.e., number of jobs - 2 in the worst case). *)
    Hypothesis H_constrained_deadline: task_deadline tsk <= task_period tsk.

    (* Consider an interval [t1, t1 + delta). *)
    Variable t1 delta: time.

    (* Assume that a response-time bound R_tsk for that task in any
       schedule of this processor platform is also given, ... *)
    Variable R_tsk: time.

    Hypothesis H_response_time_bound :
      forall j,
        arrives_in arr_seq j ->
        job_task j = tsk ->
        job_arrival j + R_tsk < t1 + delta ->
        job_has_completed_by j (job_arrival j + R_tsk).

    (* ... such that R_tsk >= task_cost tsk and R_tsk <= task_deadline tsk. *)
    Hypothesis H_response_time_ge_cost: R_tsk >= task_cost tsk.
    Hypothesis H_no_deadline_miss: R_tsk <= task_deadline tsk.

    Section MainProof.

      (* In this section, we prove that the workload of a task in the
         interval [t1, t1 + delta) is bounded by W. *)

      (* Let's simplify the names a bit. *)
      Let t2 := t1 + delta.
      Let n_k := max_jobs task_cost task_period tsk R_tsk delta.
      Let workload_bound := W task_cost task_period tsk R_tsk delta.

      (* Since we only care about the workload of tsk, we restrict
         our view to the set of jobs of tsk scheduled in [t1, t2). *)
      Let scheduled_jobs :=
        jobs_of_task_scheduled_between job_task sched tsk t1 t2.

      (* Now, let's consider the list of interfering jobs sorted by arrival time. *)
      Let earlier_arrival := fun x y => job_arrival x <= job_arrival y.
      Let sorted_jobs := sort earlier_arrival scheduled_jobs.

      (* The first step consists in simplifying the sum corresponding
         to the workload. *)
      Section SimplifyJobSequence.

        (* After switching to the definition of workload based on a list
           of jobs, we show that sorting the list preserves the sum. *)
        Lemma workload_bound_simpl_by_sorting_scheduled_jobs :
          workload_joblist job_task sched tsk t1 t2 =
           \sum_(i <- sorted_jobs) service_during sched i t1 t2.
        Proof.
          unfold workload_joblist; fold scheduled_jobs.
          rewrite (eq_big_perm sorted_jobs) /= //.
          by rewrite -(perm_sort earlier_arrival).
        Qed.

        (* Remember that both sequences have the same set of elements *)
        Lemma workload_bound_job_in_same_sequence :
          forall j,
            (j \in scheduled_jobs) = (j \in sorted_jobs).
        Proof.
          by apply perm_eq_mem; rewrite -(perm_sort earlier_arrival).
        Qed.

        (* Remember that all jobs in the sorted sequence is an
           interfering job of task tsk. *)
        Lemma workload_bound_all_jobs_from_tsk :
          forall j_i,
            j_i \in sorted_jobs ->
            arrives_in arr_seq j_i /\
            job_task j_i = tsk /\
            service_during sched j_i t1 t2 != 0 /\
            j_i \in jobs_scheduled_between sched t1 t2.
        Proof.
          rename H_jobs_come_from_arrival_sequence into FROMarr.
          intros j_i LTi.
          rewrite -workload_bound_job_in_same_sequence mem_filter in LTi; des.
          have IN := LTi0.
          unfold jobs_scheduled_between in *; rewrite mem_undup in IN.
          apply mem_bigcat_nat_exists in IN; des.
          rewrite mem_scheduled_jobs_eq_scheduled in IN.
          repeat split; try (by done); first by apply (FROMarr j_i i).
          unfold jobs_scheduled_between in *; rewrite mem_undup in LTi0.
          apply mem_bigcat_nat_exists in LTi0; des.
          rewrite mem_scheduled_jobs_eq_scheduled in LTi0.
          apply service_implies_cumulative_service with (t := i);
            first by apply/andP; split.
          by rewrite -not_scheduled_no_service negbK.
        Qed.

        (* Remember that consecutive jobs are ordered by arrival. *)
        Lemma workload_bound_jobs_ordered_by_arrival :
          forall i elem,
            i < (size sorted_jobs).-1 ->
            earlier_arrival (nth elem sorted_jobs i) (nth elem sorted_jobs i.+1).
        Proof.
          intros i elem LT.
          assert (SORT: sorted earlier_arrival sorted_jobs).
            by apply sort_sorted; unfold total, earlier_arrival; ins; apply leq_total.
          by destruct sorted_jobs; simpl in *; [by rewrite ltn0 in LT | by apply/pathP].
        Qed.

      End SimplifyJobSequence.

      (* Next, we show that if the number of jobs is no larger than n_k,
         the workload bound trivially holds. *)
      Section WorkloadNotManyJobs.

        Lemma workload_bound_holds_for_at_most_n_k_jobs :
          size sorted_jobs <= n_k ->
          \sum_(i <- sorted_jobs) service_during sched i t1 t2 <=
            workload_bound.
        Proof.
        intros LEnk.
        rewrite -[\sum_(_ <- _ | _) _]add0n leq_add //.
        apply leq_trans with (n := \sum_(x <- sorted_jobs) task_cost tsk);
          last by rewrite big_const_seq iter_addn addn0 mulnC leq_mul2r; apply/orP; right.
        {
          rewrite [\sum_(_ <- _) service_during _ _ _ _]big_seq_cond.
          rewrite [\sum_(_ <- _) task_cost _]big_seq_cond.
          apply leq_sum; intros j_i; move/andP => [INi _].
          apply workload_bound_all_jobs_from_tsk in INi; des.
          eapply cumulative_service_le_task_cost;
            [by apply H_completed_jobs_dont_execute | by apply INi0 |].
          by apply H_jobs_have_valid_parameters.
        }
      Qed.

      End WorkloadNotManyJobs.

      (* Otherwise, assume that the number of jobs is larger than n_k >= 0.
         First, consider the simple case with only one job. *)
      Section WorkloadSingleJob.

        (* Assume that there's at least one job in the sorted list. *)
        Hypothesis H_at_least_one_job: size sorted_jobs > 0.

        Variable elem: Job.
        Let j_fst := nth elem sorted_jobs 0.

        (* The first job is an interfering job of task tsk. *)
        Lemma workload_bound_j_fst_is_job_of_tsk :
          arrives_in arr_seq j_fst /\
          job_task j_fst = tsk /\
          service_during sched j_fst t1 t2 != 0 /\
          j_fst \in jobs_scheduled_between sched t1 t2.
        Proof.
          by apply workload_bound_all_jobs_from_tsk, mem_nth.
        Qed.

        (* The workload bound holds for the single job. *)
        Lemma workload_bound_holds_for_a_single_job :
          \sum_(0 <= i < 1) service_during sched (nth elem sorted_jobs i) t1 t2 <=
          workload_bound.
        Proof.
          unfold workload_bound, W; fold n_k.
          have INfst := workload_bound_j_fst_is_job_of_tsk; des.
          rewrite big_nat_recr // big_geq // [nth]lock /= -lock add0n.
          destruct n_k; last first.
          {
            rewrite -[service_during _ _ _ _]add0n; rewrite leq_add //.
            rewrite -[service_during _ _ _ _]add0n [_* task_cost tsk]mulSnr.
            apply leq_add; first by done.
            by eapply cumulative_service_le_task_cost;
              [| by apply INfst0
               | by apply H_jobs_have_valid_parameters].
          }
          {
            rewrite 2!mul0n addn0 subn0 leq_min; apply/andP; split.
            {
              by eapply cumulative_service_le_task_cost;
                 [| by apply INfst0
                | by apply H_jobs_have_valid_parameters].
            }
            {
              rewrite -addnBA // -[service_during _ _ _ _]addn0.
              apply leq_add; last by done.
              by apply cumulative_service_le_delta.
            }
          }
        Qed.

      End WorkloadSingleJob.

      (* Next, consider the last case where there are at least two jobs:
         the first job j_fst, and the last job j_lst. *)
      Section WorkloadTwoOrMoreJobs.

        (* There are at least two jobs. *)
        Variable num_mid_jobs: nat.
        Hypothesis H_at_least_two_jobs : size sorted_jobs = num_mid_jobs.+2.

        Variable elem: Job.
        Let j_fst := nth elem sorted_jobs 0.
        Let j_lst := nth elem sorted_jobs num_mid_jobs.+1.

        (* The last job is an interfering job of task tsk. *)
        Lemma workload_bound_j_lst_is_job_of_tsk :
          arrives_in arr_seq j_lst /\
          job_task j_lst = tsk /\
          service_during sched j_lst t1 t2 != 0 /\
          j_lst \in jobs_scheduled_between sched t1 t2.
        Proof.
          apply workload_bound_all_jobs_from_tsk, mem_nth.
          by rewrite H_at_least_two_jobs.
        Qed.

        (* The response time of the first job must fall inside the interval. *)
        Lemma workload_bound_response_time_of_first_job_inside_interval :
          t1 <= job_arrival j_fst + R_tsk.
        Proof.
          rewrite leqNgt; apply /negP; unfold not; intro LTt1.
          exploit workload_bound_all_jobs_from_tsk.
          {
            apply mem_nth; instantiate (1 := 0).
            apply ltn_trans with (n := 1); [by done | by rewrite H_at_least_two_jobs].
          }
          instantiate (1 := elem); move => [FSTarr [FSTtsk [/eqP FSTserv FSTin]]].
          apply FSTserv.
          apply (cumulative_service_after_job_rt_zero job_arrival job_cost) with (R := R_tsk);
            try (by done); last by apply ltnW.
          apply H_response_time_bound; try (by done).
          by apply leq_trans with (n := t1); last by apply leq_addr.
        Qed.

        (* The arrival of the last job must also fall inside the interval. *)
        Lemma workload_bound_last_job_arrives_before_end_of_interval :
          job_arrival j_lst < t2.
        Proof.
          rewrite leqNgt; apply/negP; unfold not; intro LT2.
          exploit workload_bound_all_jobs_from_tsk.
          {
            apply mem_nth; instantiate (1 := num_mid_jobs.+1).
            by rewrite -(ltn_add2r 1) addn1 H_at_least_two_jobs addn1.
          }
          instantiate (1 := elem); move => [LSTarr [LSTtsk [/eqP LSTserv LSTin]]].
          unfold service_during; apply LSTserv.
          by apply cumulative_service_before_job_arrival_zero with (job_arrival0 := job_arrival).
        Qed.

        (* Next, we upper-bound the service of the first and last jobs using their arrival times. *)
        Lemma workload_bound_service_of_first_and_last_jobs :
          service_during sched j_fst t1 t2 +
          service_during sched j_lst t1 t2 <=
            (job_arrival j_fst  + R_tsk - t1) + (t2 - job_arrival j_lst).
        Proof.
          apply leq_add; unfold service_during.
          {
            rewrite -[_ + _ - _]mul1n -[1*_]addn0 -iter_addn -big_const_nat.
            apply leq_trans with (n := \sum_(t1 <= t < job_arrival j_fst + R_tsk)
                                        service_at sched j_fst t);
              last by apply leq_sum; ins; apply service_at_most_one.
            destruct (job_arrival j_fst + R_tsk < t2) eqn:LEt2; last first.
            {
              unfold t2; apply negbT in LEt2; rewrite -ltnNge in LEt2.
              rewrite -> big_cat_nat with (n := t1 + delta) (p := job_arrival j_fst + R_tsk);
                [by apply leq_addr | by apply leq_addr | by done].
            }
            {
              rewrite -> big_cat_nat with (n := job_arrival j_fst + R_tsk);
                [| by apply workload_bound_response_time_of_first_job_inside_interval
                 | by apply ltnW].
              rewrite -{2}[\sum_(_ <= _ < _) _]addn0 /= leq_add2l leqn0; apply/eqP.
              apply (cumulative_service_after_job_rt_zero job_arrival job_cost) with (R := R_tsk); try (by done).
              exploit workload_bound_all_jobs_from_tsk.
                by apply mem_nth; instantiate (1 := 0); rewrite H_at_least_two_jobs.
              instantiate (1 := elem); move => [FSTarr [FSTtsk _]].
              by apply H_response_time_bound.
            }
          }
          {
            rewrite -[_ - _]mul1n -[1 * _]addn0 -iter_addn -big_const_nat.
            destruct (job_arrival j_lst <= t1) eqn:LT.
            {
              apply leq_trans with (n := \sum_(job_arrival j_lst <= t < t2)
                                          service_at sched j_lst t);
                first by rewrite -> big_cat_nat with (m := job_arrival j_lst) (n := t1);
                  [by apply leq_addl | by ins | by apply leq_addr].
              by apply leq_sum; ins; apply service_at_most_one.
            }
            {
              apply negbT in LT; rewrite -ltnNge in LT.
              rewrite -> big_cat_nat with (n := job_arrival j_lst);
                [| by apply ltnW
                 | by apply ltnW, workload_bound_last_job_arrives_before_end_of_interval].
              rewrite /= -[\sum_(_ <= _ < _) 1]add0n; apply leq_add.
              rewrite (cumulative_service_before_job_arrival_zero job_arrival);
                [by apply leqnn | by ins | by apply leqnn].
              by apply leq_sum; ins; apply service_at_most_one.
            }
          }
        Qed.

        (* Simplify the expression from the previous lemma. *)
        Lemma workload_bound_simpl_expression_with_first_and_last :
          job_arrival j_fst + R_tsk - t1 + (t2 - job_arrival j_lst) =
                       delta + R_tsk - (job_arrival j_lst - job_arrival j_fst).
        Proof.
          have lemma1 := workload_bound_last_job_arrives_before_end_of_interval.
          have lemma2 := workload_bound_response_time_of_first_job_inside_interval.
          rewrite addnBA; last by apply ltnW.
          rewrite subh1 // -addnBA; last by apply leq_addr.
          rewrite addnC [job_arrival _ + _]addnC.
          unfold t2; rewrite [t1 + _]addnC -[delta + t1 - _]subnBA // subnn subn0.
          rewrite addnA -subnBA; first by ins.
          unfold j_fst, j_lst. rewrite -[_.+1]add0n.
          apply prev_le_next; last by rewrite H_at_least_two_jobs add0n leqnn.
          by ins; apply workload_bound_jobs_ordered_by_arrival.
        Qed.

        (* Bound the service of the middle jobs. *)
        Lemma workload_bound_service_of_middle_jobs :
          \sum_(0 <= i < num_mid_jobs)
            service_during sched (nth elem sorted_jobs i.+1) t1 t2 <=
            num_mid_jobs * task_cost tsk.
        Proof.
          apply leq_trans with (n := num_mid_jobs * task_cost tsk);
            last by rewrite leq_mul2l; apply/orP; right.
          apply leq_trans with (n := \sum_(0 <= i < num_mid_jobs) task_cost tsk);
            last by rewrite big_const_nat iter_addn addn0 mulnC subn0.
          rewrite big_nat_cond [\sum_(0 <= i < num_mid_jobs) task_cost _]big_nat_cond.
          apply leq_sum; intros i; rewrite andbT; move => /andP LT; des.
          exploit workload_bound_all_jobs_from_tsk.
          {
            instantiate (1 := nth elem sorted_jobs i.+1).
            apply mem_nth; rewrite H_at_least_two_jobs.
            by rewrite ltnS; apply leq_trans with (n := num_mid_jobs).
          }
          move => [ARR [TSK _]].
          by eapply cumulative_service_le_task_cost; eauto 2.
        Qed.

        (* Conclude that the distance between first and last is at least num_mid_jobs + 1 periods. *)
        Lemma workload_bound_many_periods_in_between :
          job_arrival j_lst - job_arrival j_fst >= num_mid_jobs.+1 * (task_period tsk).
        Proof.
          assert (EQnk: num_mid_jobs.+1=(size sorted_jobs).-1).
            by rewrite H_at_least_two_jobs.
          unfold j_fst, j_lst; rewrite EQnk telescoping_sum;
            last by ins; apply workload_bound_jobs_ordered_by_arrival.
          rewrite -[_ * _ tsk]addn0 mulnC -iter_addn -{1}[_.-1]subn0 -big_const_nat.
          rewrite big_nat_cond [\sum_(0 <= i < _)(_-_)]big_nat_cond.
          apply leq_sum; intros i; rewrite andbT; move => /andP LT; des.

          (* To simplify, call the jobs 'cur' and 'next' *)
          set cur := nth elem sorted_jobs i.
          set next := nth elem sorted_jobs i.+1.

          (* Show that cur arrives earlier than next *)
          assert (ARRle: job_arrival cur <= job_arrival next).
            by unfold cur, next; apply workload_bound_jobs_ordered_by_arrival.

          feed (workload_bound_all_jobs_from_tsk cur).
            by apply mem_nth, (ltn_trans LT0); destruct sorted_jobs.
          intros [CURarr [CURtsk [_ CURin]]].

          feed (workload_bound_all_jobs_from_tsk next).
            by apply mem_nth; destruct sorted_jobs.
          intros [NEXTarr [NEXTtsk [_ NEXTin]]].

          (* Use the sporadic task model to conclude that cur and next are separated
             by at least (task_period tsk) units. Of course this only holds if cur != next.
             Since we don't know much about the list (except that it's sorted), we must
             also prove that it doesn't contain duplicates. *)
          assert (CUR_LE_NEXT: job_arrival cur + task_period (job_task cur) <= job_arrival next).
          {
            apply H_sporadic_tasks; try (by done).
            unfold cur, next, not; intro EQ; move: EQ => /eqP EQ.
            rewrite nth_uniq in EQ; first by move: EQ => /eqP EQ; intuition.
              by apply ltn_trans with (n := (size sorted_jobs).-1); destruct sorted_jobs; ins.
              by destruct sorted_jobs; ins.
              by rewrite sort_uniq -/scheduled_jobs filter_uniq // undup_uniq.
              by rewrite CURtsk.
          }
          by rewrite subh3 // addnC -CURtsk.
        Qed.

        (* Prove that n_k is at least the number of the middle jobs *)
        Lemma workload_bound_n_k_covers_middle_jobs :
          n_k >= num_mid_jobs.
        Proof.
          rename H_valid_task_parameters into PARAMS.
          unfold is_valid_sporadic_task in *; des.
          rewrite leqNgt; apply/negP; unfold not; intro LTnk.
          assert (DISTmax: job_arrival j_lst - job_arrival j_fst >= delta + task_period tsk).
          {
            apply leq_trans with (n := n_k.+2 * task_period tsk).
            {
              rewrite -addn1 mulnDl mul1n leq_add2r.
              apply leq_trans with (n := delta + R_tsk - task_cost tsk);
                first by rewrite -addnBA //; apply leq_addr.
              by apply ltnW, ltn_ceil, PARAMS0.
            }
            apply leq_trans with (num_mid_jobs.+1 * task_period tsk);
              first by rewrite leq_mul2r; apply/orP; right.
            by apply workload_bound_many_periods_in_between.
          }
          rewrite <- leq_add2r with (p := job_arrival j_fst) in DISTmax.
          rewrite addnC subh1 in DISTmax; last first.
          {
            unfold j_fst, j_lst; rewrite -[_.+1]add0n.
            apply prev_le_next; last by rewrite H_at_least_two_jobs add0n leqnn.
            by ins; apply workload_bound_jobs_ordered_by_arrival.
          }
          rewrite -subnBA // subnn subn0 in DISTmax.
          rewrite [delta + task_period tsk]addnC addnA in DISTmax.
          have BEFOREt2 := workload_bound_last_job_arrives_before_end_of_interval.
          generalize BEFOREt2; move: BEFOREt2; rewrite {1}ltnNge; move => /negP BEFOREt2'.
          intros BEFOREt2; apply BEFOREt2'; clear BEFOREt2'.
          apply leq_trans with (n := job_arrival j_fst + task_deadline tsk + delta);
            last by apply leq_trans with (n := job_arrival j_fst + task_period tsk + delta);
              [rewrite leq_add2r leq_add2l; apply H_constrained_deadline | apply DISTmax].
          unfold t2; rewrite leq_add2r.
          apply leq_trans with (n := job_arrival j_fst + R_tsk);
            last by rewrite leq_add2l.
          by apply workload_bound_response_time_of_first_job_inside_interval.
        Qed.

        (* If n_k = num_mid_jobs, then the workload bound holds. *)
        Lemma workload_bound_n_k_equals_num_mid_jobs :
          num_mid_jobs = n_k ->
          service_during sched j_lst t1 t2 +
            service_during sched j_fst t1 t2 +
            \sum_(0 <= i < num_mid_jobs)
             service_during sched (nth elem sorted_jobs i.+1) t1 t2
          <= workload_bound.
        Proof.
          rename H_valid_task_parameters into PARAMS.
          unfold is_valid_sporadic_task in *; des.
          unfold workload_bound, W; fold n_k.
          move => NK; rewrite -NK.
          apply leq_add;
            last by apply workload_bound_service_of_middle_jobs.
          apply leq_trans with (delta + R_tsk - (job_arrival j_lst - job_arrival j_fst)).
          {
            rewrite addnC -workload_bound_simpl_expression_with_first_and_last.
            by apply workload_bound_service_of_first_and_last_jobs.
          }
          rewrite leq_min; apply/andP; split.
          {
            rewrite leq_subLR [_ + task_cost _]addnC -leq_subLR.
            apply leq_trans with (num_mid_jobs.+1 * task_period tsk);
              last by apply workload_bound_many_periods_in_between.
            rewrite NK ltnW // -ltn_divLR;
              last by apply PARAMS0.
            by unfold n_k, max_jobs, div_floor.
          }
          {
            rewrite -subnDA; apply leq_sub2l.
            apply leq_trans with (n := num_mid_jobs.+1 * task_period tsk);
              last by apply workload_bound_many_periods_in_between.
            rewrite -addn1 addnC mulnDl mul1n.
            by rewrite leq_add2l; last by apply PARAMS3.
          }
        Qed.

        (* If n_k = num_mid_jobs + 1, then the workload bound holds. *)
        Lemma workload_bound_n_k_equals_num_mid_jobs_plus_1 :
          num_mid_jobs.+1 = n_k ->
          service_during sched j_lst t1 t2 +
            service_during sched j_fst t1 t2 +
            \sum_(0 <= i < num_mid_jobs)
             service_during sched (nth elem sorted_jobs i.+1) t1 t2
          <= workload_bound.
        Proof.
          have MID := workload_bound_service_of_middle_jobs.
          rename H_jobs_have_valid_parameters into JOBPARAMS.
          unfold workload_bound, W; fold n_k.
          move => NK; rewrite -NK.
          rewrite -{2}addn1 mulnDl mul1n [_* _ + _]addnC addnA addn_minl.
          apply leq_add; last by apply MID.
          rewrite leq_min; apply/andP; split.
          {
            assert (SIZE: 0 < size sorted_jobs).
              by rewrite H_at_least_two_jobs.
            have INfst := workload_bound_j_fst_is_job_of_tsk SIZE elem;
            have INlst := workload_bound_j_lst_is_job_of_tsk; des.
            have PARAMSfst := JOBPARAMS j_fst INfst; des.
            have PARAMSlst := JOBPARAMS j_lst INlst; des.
            by apply leq_add; apply cumulative_service_le_task_cost with
                    (task_deadline0 := task_deadline)
                    (job_cost0 := job_cost) (job_deadline0 := job_deadline) (job_task0 := job_task).
          }
          {
            rewrite subnAC subnK; last first.
            {
              assert (TMP: delta + R_tsk = task_cost tsk + (delta + R_tsk - task_cost tsk));
                first by rewrite subnKC; [by ins | by rewrite -[task_cost _]add0n; apply leq_add].
              rewrite TMP; clear TMP.
              rewrite -{1}[task_cost _]addn0 -addnBA NK; [by apply leq_add | by apply leq_trunc_div].
            }
            apply leq_trans with (delta + R_tsk - (job_arrival j_lst - job_arrival j_fst)).
            {
              rewrite addnC -workload_bound_simpl_expression_with_first_and_last.
              by apply workload_bound_service_of_first_and_last_jobs.
            }
            {
              by apply leq_sub2l, workload_bound_many_periods_in_between.
            }
          }
        Qed.

      End WorkloadTwoOrMoreJobs.

      (* Using the lemmas above, we prove the main theorem about the workload bound. *)
      Theorem workload_bounded_by_W :
        workload_of tsk t1 (t1 + delta) <= workload_bound.
      Proof.
        unfold workload_of, workload_bound, W in *; ins; des.
        fold n_k.

        (* Use the definition of workload based on list of jobs. *)
        rewrite workload_eq_workload_joblist.

        (* Now we order the list by job arrival time. *)
        rewrite workload_bound_simpl_by_sorting_scheduled_jobs.

        (* Next, we show that the workload bound holds if n_k
           is no larger than the number of interferings jobs. *)
        destruct (size sorted_jobs <= n_k) eqn:NUM;
          first by apply workload_bound_holds_for_at_most_n_k_jobs.
        apply negbT in NUM; rewrite -ltnNge in NUM.

        (* Find some dummy element to use in the nth function *)
        assert (EX: exists elem: Job, True).
          destruct sorted_jobs; [ by rewrite ltn0 in NUM | by exists s].
        destruct EX as [elem _].

        (* Now we index the sum to access the first and last elements. *)
        rewrite (big_nth elem).

        (* First, we show that the bound holds for an empty list of jobs. *)
        destruct (size sorted_jobs) as [| n] eqn:SIZE;
          first by rewrite big_geq.

        (* Then, we show the same for a singleton set of jobs. *)
        destruct n as [| num_mid_jobs];
          first by apply workload_bound_holds_for_a_single_job; rewrite SIZE.

        (* Knowing that we have at least two elements, we take first and last out of the sum *)
        rewrite [nth]lock big_nat_recl // big_nat_recr // /= -lock.
        rewrite addnA addnC addnA.

        (* There are two cases to be analyze since n <= n_k < n + 2,
           where n is the number of middle jobs. *)
        have NK := workload_bound_n_k_covers_middle_jobs num_mid_jobs SIZE elem.
        move: NK; rewrite leq_eqVlt orbC leq_eqVlt; move => /orP [NK | /eqP NK].
        move: NK => /orP [/eqP NK | NK]; last by rewrite ltnS leqNgt NK in NUM.
        {
          (* Case 1: n_k = n + 1, where n is the number of middle jobs. *)
          by apply (workload_bound_n_k_equals_num_mid_jobs_plus_1 num_mid_jobs).
        }
        {
          (* Case 2: n_k = n, where n is the number of middle jobs. *)
          by apply (workload_bound_n_k_equals_num_mid_jobs num_mid_jobs).
        }
      Qed.

    End MainProof.

  End ProofWorkloadBound.

End WorkloadBound.


From Tweetnacl Require Import Libs.Export.
Require Import ssreflect.

Open Scope Z.

Definition red_by_P n :=
  let n' := n - (2^255-19) in
  if Z.leb 0 n' then
    let n'' := n' - (2^255-19) in
    if Z.leb 0 n'' then
      n''
    else
      n'
  else
    n.

Definition ZPack25519 n :=
  Z.modulo n (Z.pow 2 255 - 19).

Lemma reduce_pos :  forall n, 0 <= n -> 0 <= red_by_P n.
Proof. move=> n Hn ; rewrite /red_by_P.
flatten.
apply Zle_bool_imp_le in Eq0.
omega.
apply Zle_bool_imp_le in Eq.
omega.
Qed.

Lemma reduce_max : forall n, n < 2^256 -> red_by_P n < 2 ^ 255 - 19.
Proof.
move => n Hn ; rewrite /red_by_P.
flatten.
{
apply Zle_bool_imp_le in Eq0.
apply Zle_bool_imp_le in Eq.
assert(n - (2 ^ 255 - 19) - (2 ^ 255 - 19) < 2 ^ 256 - (2 ^ 255 - 19) - (2 ^ 255 - 19)) by omega.
change (2 ^ 256 - (2 ^ 255 - 19) - (2 ^ 255 - 19)) with 38 in H.
change (2^255 - 19) with (57896044618658097711785492504343953926634992332820282019728792003956564819949) in *.
omega.
}
{
apply Zle_bool_imp_le in Eq.
apply Z.leb_gt in Eq0.
omega.
}
{
apply Z.leb_gt in Eq.
omega.
}
Qed.

Theorem reduce_P_mod_correct : forall n,
  (red_by_P n) mod (2^255-19) = n mod (2^255-19).
Proof.
  intros.
  rewrite /red_by_P.
  flatten;
  repeat match goal with
    | _ => reflexivity
    | _ => rewrite -Zminus_0_l_reverse Z.mod_mod
    | _ => rewrite Zminus_mod ; change ((2 ^ 255 - 19) :𝓖𝓕) with 0
    | |- _ <> _ => compute ; go
  end.
Qed.

Theorem reduce_P_is_mod : forall n,
  0 <= n < 2 ^ 256 ->
  ZPack25519 n = red_by_P n.
Proof. intros.
rewrite /ZPack25519 -reduce_P_mod_correct.
apply Zmod_small.
split.
apply reduce_pos ; omega.
apply reduce_max ; omega.
Qed.

Lemma sub_div_256_pos : forall n, 0 <= n < 2 ^256 ->
  0 <= n - (2^255 - 19) ->
  0 <= (n - (2^255 - 19)) / 2 ^ 256 .
Proof.
intros.
apply Z_div_pos.
compute ; go.
assumption.
Qed.

Lemma sub_div_256_neg : forall n, 0 <= n < 2 ^256 ->
  n - (2^255 - 19) < 0 ->
  (n - (2^255 - 19)) / 2 ^ 256 = -1.
Proof.
intros.
assert((n - (2 ^ 255 - 19)) / 2 ^ 256 < 0).
apply Zdiv_lt_upper_bound.
compute ; go.
change(0 * 2^256) with 0.
assumption.
assert(-1 <= (n - (2 ^ 255 - 19)) / 2 ^ 256).
apply Z.div_le_lower_bound.
compute ; go.
change (2 ^ 256) with 115792089237316195423570985008687907853269984665640564039457584007913129639936 in *.
change (2^255 - 19) with 57896044618658097711785492504343953926634992332820282019728792003956564819949 in *.
omega.
omega.
Qed.

Close Scope Z.


Require Import Problem.

Lemma lemma : forall l a, list_in l a = false -> list_in (unique l) a = false.
Proof.
  intros.
  induction l; simpl; [auto|].
  simpl in H.
  remember (Nat.eqb a a0).
  destruct b.
  discriminate.
  destruct (list_in l a0); [auto|].
  simpl.
  rewrite <- Heqb.
  auto.
Qed.

Theorem solution : task.
Proof.
  unfold Problem.task.
  induction l; simpl; [auto|].
  simpl.
  remember (list_in l a).
  destruct b; [auto|].
  simpl.
  rewrite IHl.
  rewrite lemma; auto.
Qed.


(*
  The "Tm" type and the previously defined transition judgements.
  Do not modify these!

  The task starts at line 180.
*)

Require Import Nat.
Require Import Arith.

Inductive Tm : Set :=
  | num (n : nat)
  | plus (t t' : Tm)
  | isZero (t : Tm)
  | true
  | false
  | ifThenElse (t t' t'' : Tm)
.

Notation "t + t'" := (plus t t') : term_scope.
Notation
  "'If' t 'then' t' 'else' t''" :=
  (ifThenElse t t' t'')
  (at level 100)
  : term_scope
.

Delimit Scope term_scope with term.
(* Bind Scope term_scope with Tm. *)
Open Scope term_scope.

(* The set of Ty and the inductive typing relation. *)

Inductive Ty : Set := Nat | Bool.

Inductive TypeJudgement : Tm -> Ty -> Prop :=
  | TJ_num {n : nat} : (num n) :: Nat
  | TJ_plus {t t' : Tm} (j : t :: Nat) (j' : t' :: Nat) : (t + t') :: Nat
  | TJ_isZero {t : Tm} (j : t :: Nat) : (isZero t) :: Bool
  | TJ_true : true :: Bool
  | TJ_false : false :: Bool

  | TJ_ifThenElse
    {t t' t'' : Tm} {A : Ty}
    (j : t :: Bool) (j' : t' :: A) (j'' : t'' :: A)
    : (If t then t' else t'') :: A

where "tm :: ty" := (TypeJudgement tm ty) : term_scope.

(*
  2.3. Operációs szemantika
*)

(* val : 2.9. - 2.11. *)

Reserved Notation "t 'val'" (at level 1).

Inductive ValueJudgement : Tm -> Prop :=
  | VJ_num {n : nat} : (num n) val
  | VJ_true : true val
  | VJ_false : false val
where
  "t 'val'" :=
  (ValueJudgement t)
  : term_scope.

(*
  Transition judgements.
*)

Reserved Notation "t |-> t'" (at level 100).

(* One Step Transition : 2.14. - 2.22. *)

Inductive OneStepTransitionJudgement : Tm -> Tm -> Prop :=
  | OSTJ_sum {n1 n2 n : nat} :
    ((n1 + n2)%nat = n) ->
    num n1 + num n2 |-> num n

  | OSTJ_isZero_true :
    (isZero (num 0)) |-> true

  | OSTJ_isZero_false {n : nat} :
    (n > 0) ->
    isZero (num n) |-> false

  | OSTJ_ifThenElse_true {t t' : Tm} :
    If true then t else t' |-> t

  | OSTJ_ifThenElse_false {t t' : Tm} :
    If false then t else t' |-> t'

  | OSTJ_plus_left {t1 t1' t2 : Tm} :
    (t1 |-> t1') ->
    t1 + t2 |-> t1' + t2

  | OSTJ_plus_right {t1 t2 t2' : Tm} :
    t1 val -> (t2 |-> t2') ->
    t1 + t2 |-> t1 + t2'

  | OSTJ_isZero {t t' : Tm} :
    (t |-> t') ->
    isZero t |-> isZero t'

  | OSTJ_ifThenElse {t t' t1 t2 : Tm} :
    (t |-> t') ->
    If t then t1 else t2 |-> If t' then t1 else t2
where
  "t |-> t'" :=
  (OneStepTransitionJudgement t t')
  : term_scope.

(* Any Step Transition : 2.12. - 2.13. *)

Reserved Notation "t |->* t'" (at level 100).

Inductive AnyStepTransitionJudgement : Tm -> Tm -> Prop :=
  | ASTJ_refl {t : Tm} :
    t |->* t
  | ASTJ_trans {t t'' : Tm} (t' : Tm) :
    (t |-> t') -> (t' |->* t'') ->
    t |->* t''
where "t |->* t'" := (AnyStepTransitionJudgement t t') : term_scope.

(*
  2.27. Tétel.
  Theorem of type preservation.
*)

Theorem type_preservation {t t' : Tm} :
  (t |-> t') -> (forall A : Ty, (t :: A) -> (t' :: A))
.
Proof.
  intros H.
  induction H.

  (* sum *)
  - intros. inversion H0. exact TJ_num.

  (* isZero_true *)
  - intros. inversion H. exact TJ_true.

  (* isZero_false *)
  - intros. inversion H0. exact TJ_false.

  (* ifThenElse_true *)
  - intros. inversion H. exact j'.

  (* ifThenElse_false *)
  - intros. inversion H. exact j''.

  (* plus_left *)
  - intros. inversion H0.
    refine (TJ_plus _ j').
    + pose (ir := IHOneStepTransitionJudgement Nat j).
      exact ir.

  (* plus_right *)
  - intros. inversion H1.
    refine (TJ_plus j _).
    + pose (ir := IHOneStepTransitionJudgement Nat j').
      exact ir.

  (* isZero *)
  - intros. inversion H0.
    refine (TJ_isZero _).
    + exact (IHOneStepTransitionJudgement Nat j).

  (* ifThenElse *)
  - intros. inversion H0.
    refine (TJ_ifThenElse _ j' j'').
    + exact (IHOneStepTransitionJudgement Bool j).
Qed.

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

(*
  Prove the following theorem!
*)

Theorem any_step_type_preservation {t t' : Tm} :
  (t |->* t') -> (forall A : Ty, (t :: A) -> (t' :: A))
.
Proof.
  intro. induction H.
  + intros. exact H.
  + intros. pose (singleStepTyPres := type_preservation H).
    apply IHAnyStepTransitionJudgement.
    apply singleStepTyPres. exact H1.
Qed.


Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export Families.
Require Export IndexedFamilies.
Require Export FiniteTypes.
Require Import EnsemblesSpec.

Record TopologicalSpace : Type := {
  point_set : Type;
  open : Ensemble point_set -> Prop;
  open_family_union : forall F : Family point_set,
    (forall S : Ensemble point_set, In F S -> open S) ->
    open (FamilyUnion F);
  open_intersection2: forall U V:Ensemble point_set,
    open U -> open V -> open (Intersection U V);
  open_full : open Full_set
}.

Implicit Arguments open [[t]].
Implicit Arguments open_family_union [[t]].
Implicit Arguments open_intersection2 [[t]].

Lemma open_empty: forall X:TopologicalSpace,
  open (@Empty_set (point_set X)).
Proof.
intros.
rewrite <- empty_family_union.
apply open_family_union.
intros.
destruct H.
Qed.

Lemma open_union2: forall {X:TopologicalSpace}
  (U V:Ensemble (point_set X)), open U -> open V -> open (Union U V).
Proof.
intros.
assert (Union U V = FamilyUnion (Couple U V)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
exists U; auto with sets.
exists V; auto with sets.
destruct H1.
destruct H1.
left; trivial.
right; trivial.

rewrite H1; apply open_family_union.
intros.
destruct H2; trivial.
Qed.

Lemma open_indexed_union: forall {X:TopologicalSpace} {A:Type}
  (F:IndexedFamily A (point_set X)),
  (forall a:A, open (F a)) -> open (IndexedUnion F).
Proof.
intros.
rewrite indexed_to_family_union.
apply open_family_union.
intros.
destruct H0.
rewrite H1; apply H.
Qed.

Lemma open_finite_indexed_intersection:
  forall {X:TopologicalSpace} {A:Type}
    (F:IndexedFamily A (point_set X)),
    FiniteT A -> (forall a:A, open (F a)) ->
    open (IndexedIntersection F).
Proof.
intros.
induction H.
rewrite empty_indexed_intersection.
apply open_full.

assert (IndexedIntersection F = Intersection
  (IndexedIntersection (fun x:T => F (Some x)))
  (F None)).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
constructor.
constructor.
intros; apply H1.
apply H1.
destruct H1.
destruct H1.
constructor.
destruct a.
apply H1.
apply H2.
rewrite H1.
apply open_intersection2.
apply IHFiniteT.
intros; apply H0.
apply H0.

destruct H1.
assert (IndexedIntersection F =
  IndexedIntersection (fun x:X0 => F (f x))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct H3.
intro; apply H3.
constructor.
destruct H3.
intro; rewrite <- H2 with a.
apply H3.
rewrite H3.
apply IHFiniteT.
intro; apply H0.
Qed.

Definition closed {X:TopologicalSpace} (F:Ensemble (point_set X)) :=
  open (Ensembles.Complement F).

Lemma closed_complement_open: forall {X:TopologicalSpace}
  (U:Ensemble (point_set X)), closed (Ensembles.Complement U) ->
  open U.
Proof.
intros.
red in H.
rewrite Complement_Complement in H.
assumption.
Qed.

Lemma closed_union2: forall {X:TopologicalSpace}
  (F G:Ensemble (point_set X)),
  closed F -> closed G -> closed (Union F G).
Proof.
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Union F G) =
  Intersection (Ensembles.Complement F)
               (Ensembles.Complement G)).
unfold Ensembles.Complement.
apply Extensionality_Ensembles; split; red; intros.
constructor.
auto with sets.
auto with sets.
destruct H1.
red; red; intro.
destruct H3.
apply (H1 H3).
apply (H2 H3).

rewrite H1.
apply open_intersection2; assumption.
Qed.

Lemma closed_intersection2: forall {X:TopologicalSpace}
  (F G:Ensemble (point_set X)),
  closed F -> closed G -> closed (Intersection F G).
Proof.
intros.
red in H, H0.
red.
assert (Ensembles.Complement (Intersection F G) =
  Union (Ensembles.Complement F)
        (Ensembles.Complement G)).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
unfold Ensembles.Complement in H1.
unfold In in H1.
contradict H1.
constructor.
apply NNPP.
red; intro.
auto with sets.
apply NNPP.
red; intro.
auto with sets.

red; red; intro.
destruct H2.
destruct H1; auto with sets.

rewrite H1; apply open_union2; trivial.
Qed.

Lemma closed_family_intersection: forall {X:TopologicalSpace}
  (F:Family (point_set X)),
  (forall S:Ensemble (point_set X), In F S -> closed S) ->
  closed (FamilyIntersection F).
Proof.
intros.
unfold closed in H.
red.
assert (Ensembles.Complement (FamilyIntersection F) =
  FamilyUnion [ S:Ensemble (point_set X) |
                  In F (Ensembles.Complement S) ]).
apply Extensionality_Ensembles; split; red; intros.
apply NNPP.
red; intro.
red in H0; red in H0.
contradict H0.
constructor.
intros.
apply NNPP.
red; intro.
contradict H1.
exists (Ensembles.Complement S).
constructor.
rewrite Complement_Complement; assumption.
assumption.
destruct H0.
red; red; intro.
destruct H2.
destruct H0.
pose proof (H2 _ H0).
contradiction H3.

rewrite H0; apply open_family_union.
intros.
destruct H1.
pose proof (H _ H1).
rewrite Complement_Complement in H2; assumption.
Qed.

Lemma closed_indexed_intersection: forall {X:TopologicalSpace}
  {A:Type} (F:IndexedFamily A (point_set X)),
  (forall a:A, closed (F a)) -> closed (IndexedIntersection F).
Proof.
intros.
rewrite indexed_to_family_intersection.
apply closed_family_intersection.
intros.
destruct H0.
rewrite H1; trivial.
Qed.

Lemma closed_finite_indexed_union: forall {X:TopologicalSpace}
  {A:Type} (F:IndexedFamily A (point_set X)),
  FiniteT A -> (forall a:A, closed (F a)) ->
  closed (IndexedUnion F).
Proof.
intros.
red.
assert (Ensembles.Complement (IndexedUnion F) =
  IndexedIntersection (fun a:A => Ensembles.Complement (F a))).
apply Extensionality_Ensembles; split; red; intros.
constructor.
intros.
red; red; intro.
contradiction H1.
exists a.
assumption.
destruct H1.
red; red; intro.
destruct H2.
contradiction (H1 a).

rewrite H1; apply open_finite_indexed_intersection; trivial.
Qed.

Hint Unfold closed : topology.
Hint Resolve (@open_family_union) (@open_intersection2) open_full
  open_empty (@open_union2) (@open_indexed_union)
  (@open_finite_indexed_intersection) (@closed_complement_open)
  (@closed_union2) (@closed_intersection2) (@closed_family_intersection)
  (@closed_indexed_intersection) (@closed_finite_indexed_union)
  : topology.

Section Build_from_closed_sets.

Variable X:Type.
Variable closedP : Ensemble X -> Prop.
Hypothesis closedP_empty: closedP Empty_set.
Hypothesis closedP_union2: forall F G:Ensemble X,
  closedP F -> closedP G -> closedP (Union F G).
Hypothesis closedP_family_intersection: forall F:Family X,
  (forall G:Ensemble X, In F G -> closedP G) ->
  closedP (FamilyIntersection F).

Definition Build_TopologicalSpace_from_closed_sets : TopologicalSpace.
refine (Build_TopologicalSpace X
  (fun U:Ensemble X => closedP (Ensembles.Complement U)) _ _ _).
intros.
replace (Ensembles.Complement (FamilyUnion F)) with
  (FamilyIntersection [ G:Ensemble X | In F (Ensembles.Complement G) ]).
apply closedP_family_intersection.
destruct 1.
rewrite <- Complement_Complement.
apply H; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H1.
destruct H0.
absurd (In (Ensembles.Complement S) x).
intro.
contradiction H3.
apply H0.
constructor.
rewrite Complement_Complement; trivial.
constructor.
destruct 1.
apply NNPP; intro.
contradiction H0.
exists (Ensembles.Complement S); trivial.

intros.
replace (Ensembles.Complement (Intersection U V)) with
  (Union (Ensembles.Complement U) (Ensembles.Complement V)).
apply closedP_union2; trivial.
apply Extensionality_Ensembles; split; red; intros.
intro.
destruct H2.
destruct H1; contradiction H1.
apply NNPP; intro.
contradiction H1.
constructor; apply NNPP; intro; contradiction H2;
  [ left | right ]; trivial.

apply eq_ind with (1 := closedP_empty).
apply Extensionality_Ensembles; split; auto with sets;
  red; intros.
contradiction H.
constructor.
Defined.

Lemma Build_TopologicalSpace_from_closed_sets_closed:
  forall (F:Ensemble (point_set Build_TopologicalSpace_from_closed_sets)),
  closed F <-> closedP F.
Proof.
intros.
unfold closed.
simpl.
rewrite Complement_Complement.
split; trivial.
Qed.

End Build_from_closed_sets.

Implicit Arguments Build_TopologicalSpace_from_closed_sets [[X]].


Set Warnings "-notation-overridden,-parsing".

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check repeat'.
Check repeat.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0 => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Fail Definition mynil := nil.

Check @nil.

Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Definition list123''' := [1; 2; 3].

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X l. induction l as [| h t IHt'].
  - reflexivity.
  - simpl. rewrite -> IHt'. reflexivity. Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n. induction l as [|h t IHt].
  - simpl. reflexivity.
  - simpl. rewrite -> IHt. reflexivity. Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2. induction l1 as [|h t IHt].
  - simpl. reflexivity.
  - simpl. rewrite -> IHt. reflexivity. Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2. induction l1 as [|h t IHt].
  - simpl. assert(app_nil_right: rev l2 ++ [ ] = rev l2).
    { induction l2 as [|h' t' IHt'].
      - simpl. reflexivity.
      - simpl. rewrite <- app_assoc. rewrite <- IHt'. reflexivity. }
    rewrite -> app_nil_right. reflexivity.
  - simpl. rewrite -> IHt. rewrite <- app_assoc. reflexivity. Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l. induction l as [| h t IHt].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr. rewrite -> IHt. simpl. reflexivity. Qed.

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

 (*standard, optional (combine_checks)*)
 (* type of combine -> forall X Y : Type, list X -> list Y -> list (X * Y)*)
 (*Compute (combine [1;2] [false;false;true;true]). -> [(1,false);(2,false)]]*)
Compute (combine [1;2] [false;false;true;true]).

 (*standard, recommended (split)*)
Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y):=
  match l with
  | nil => ([],[])
  | (x, y) :: t => (x::fst (split t), y::snd (split t))
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
  simpl. reflexivity. Qed.

Module OptionPlayground.

Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

Require Import PeanoNat.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if n =? O then Some a else nth_error l' (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

 (*standard, optional (hd_error_poly)*)
Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | nil => None
  | h :: t => Some h
  end.

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof.
  simpl. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof.
  simpl. reflexivity. Qed.

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Check @doit3times.

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t)
                        else filter test t
  end.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

 (*standard (filter_even_gt7)*)
Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Fixpoint more_than (a b:nat) : bool :=
  match a with
  | O => match b with
         | O => false
         | S b' => false
         end
  | S a' => match b with
            | O => true
            | S b' => more_than a' b'
            end
  end.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (evenb n) (more_than n 7)) l.

Compute(filter_even_gt7 [1;2;6;9;10;3;12;8]).

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

 (*standard (partition)*)

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  ((filter test l), (filter (fun x => negb(test x)) l)).

Definition oddb (n:nat) : bool := negb (evenb n).

Compute(partition oddb [1;2;3;4;5] ).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

 (*standard (map_rev)*)
Lemma map_app : forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros X Y f l1 l2. induction l1 as [| h1 t1 IHt1].
  - simpl. reflexivity.
  - simpl. rewrite -> IHt1. reflexivity. Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l. induction l as [| h t IHt].
  - simpl. reflexivity.
  - simpl. rewrite <- IHt. rewrite -> map_app. reflexivity. Qed.
 (*/standard (map_rev)*)

(*standard, recommended (flat_map)*)
Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) ++ flat_map f t
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.
(*/standard, recommended (flat_map)*)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

 (*standard, optional (implicit_args)*)
Fixpoint filter' (X :Type) (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter' X test t)
                        else filter' X test t
  end.

Example test_filter'1: filter' nat evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Example test_filter'2:
    filter' (list nat) length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Fixpoint map' (X Y: Type) (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map' X Y f t)
  end.

Example test_map'1: map' nat nat (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Example test_map'2:
  map' nat bool oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_map'3:
    map' nat (list bool) (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.
(*/standard, optional (implicit_args)*)

Fixpoint fold {X Y: Type} (f: X->Y->Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Check (fold andb).

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

 (* standard (fold_length)*)
Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l. induction l as [|h t IHt].
  - simpl. reflexivity.
  - simpl. rewrite <- IHt. reflexivity. Qed.
 (* /standard (fold_length)*)

 (*standard (fold_map)*)
Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
  fold (fun x ly => (f x) :: ly) l [].

Theorem map_fold_map_eq :
  forall {X Y:Type} (f : X -> Y) (l : list X),
    map f l = fold_map f l.
Proof.
  intros X Y f l. induction l as [| h t IHt].
  - simpl. reflexivity.
  - simpl. rewrite -> IHt. reflexivity. Qed.
 (*/standard (fold_map)*)

(*advanced (currying)*)
Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Check(prod_curry).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z := (f (fst p))(snd p).

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z x y z. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p. destruct p as [x y]. reflexivity. Qed.
(*/advanced (currying)*)

Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.

(*advanced (church_succ)*)
Definition succ (n : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f(n X f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

End Church.
(*/advanced (church_succ)*)


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

Require Import List Arith Omega Wellfounded Relations.

Require Import base.

Set Implicit Arguments.

Local Notation "A ⊆ B" := (∀x y, A x y -> B x y).

(** Symbols for copy/paste: ∩ ∪ ⊆ ⊇ ⊔ ⊓ ⊑ ≡  ⋅ ↑ ↓ ⇑ ⇓ ∀ ∃ *)

Section IND.

  (* This characterization of well_founded comes from Berardi's paper *)

  (* A R-inductive property *)

   Definition IND I (R : I -> I -> Prop) (P : I -> Prop) := forall x, (forall y, R y x -> P y) -> P x.

   Variable (X : Type) (D : X -> Prop) (R : X -> X -> Prop).

   Implicit Type (P : X -> Prop).

  (* A R-inductive property over a subtype D *)

  Definition IND_st P := forall x, D x -> (forall y, D y -> R y x -> P y) -> P x.

  (* P is R-inductive over subtype D iff P restricted to D is (R restricted to D)-inductive *)

  Theorem IND_st_IND P : IND_st P <-> IND (R⬇D) (P↡D).
  Proof.
    split.
    * intros H (x & Hx) H1; simpl.
      apply (H _ Hx).
      intros y Hy; apply (H1 (exist _ y Hy)).
    * intros H x Hx H1.
      apply (H (exist _ x Hx)).
      intros (y & ?); cbv; auto.
  Qed.

  (* a point is R-well-founded iff it is contained in any R-inductive property *)

  Definition wf x := ∀P, IND R P -> P x.

  (* This is the same as accessibility *)

  Lemma wf_eq_Acc x : wf x <-> Acc R x.
  Proof.
    split.
    * intros H; apply H.
      intro; apply Acc_intro.
    * intros H P HP; revert H.
      induction 1 as [ x _ IHx ].
      apply HP, IHx.
  Qed.

  (* a relation is well_founded iff all its points are well-founded *)

  Theorem well_founded_all_wf : well_founded R <-> ∀ x, wf x.
  Proof. split; intros H x; generalize (H x); apply wf_eq_Acc. Qed.

  (* a point is R-well-founded over D iff it is contained in D and in any R-inductive property over D *)

  Definition wf_st x := D x /\ ∀P, IND_st P -> P x.

  (* This is the same as accessibility in the subtype *)

  Lemma wf_st_eq_Acc x : wf_st x <-> D x /\ ∀H, Acc (R⬇D) (exist _ x H).
  Proof.
    split.
    * intros (H & H1); split; auto; clear H.
      apply H1.
      intros y H2 H3 H4.
      constructor 1.
      intros (z & Hz) H5.
      apply H3; auto.
    * intros (H1 & H2).
      split; auto; intros P HP.
      change (P (proj1_sig (exist _ x H1))).
      generalize (exist _ x H1) (H2 H1); clear x H1 H2.
      induction 1 as [ (x & Hx) H IH ]; simpl.
      apply HP; auto.
      intros y H3 H4.
      apply (IH (exist _ y H3)); auto.
  Qed.

  Theorem well_founded_all_wf_st : well_founded (R⬇D) <->  ∀ x P, D x -> IND_st P -> P x.
  Proof.
    split.
    * intros H x P H1; revert P.
      apply (wf_st_eq_Acc x); split; auto.
    * intros H (x & Hx).
      apply wf_st_eq_Acc; split; auto.
      intro; apply H; auto.
  Qed.

End IND.


Require Import ProofCheckingEuclid.euclidean_axioms.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_s_incirc_within_radius :
	forall P J U V W X Y,
	CI J U V W ->
	BetS U Y X ->
	Cong U X V W ->
	Cong U P U Y ->
	InCirc P J.
Proof.
	intros P J U V W X Y.
	intros CI_J_U_VW.
	intros BetS_U_Y_X.
	intros Cong_UX_VW.
	intros Cong_UP_UY.
	unfold InCirc.
	exists X, Y, U, V, W.
	split.
	exact CI_J_U_VW.
	right.
	repeat split.
	exact BetS_U_Y_X.
	exact Cong_UX_VW.
	exact Cong_UP_UY.
Qed.

End Euclid.