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

Require Import cl.

Set Implicit Arguments.

Section cl_equivalence.

  (* Now the definition of equivalence between the terms
     of combinatory algebras. It is the least equivalence
     relation (reflexive, symmetry and transitive) which
     is congruent with composition o and such that
       I o x ~~ x, K o x o y ~~ x and
       S o x o y o z ~~ x o z o (y o z)
  *)

  Reserved Notation "x '~cl' y" (at level 70).

  Inductive cl_eq : clterm -> clterm -> Prop :=

    | in_cl_eq_I : forall x,               I o x ~cl x

    | in_cl_eq_K : forall x y,         K o x o y ~cl x

    | in_cl_eq_S : forall x y z,   S o x o y o z ~cl x o z o (y o z)

    | in_cl_eq_0 : forall x,                   x ~cl x

    | in_cl_eq_1 : forall x y,                 x ~cl y
                              ->               y ~cl x

    | in_cl_eq_2 : forall x y z,               x ~cl y
                              ->               y ~cl z
                              ->               x ~cl z

    | in_cl_eq_3 : forall x y z,           x     ~cl y
                              ->           x o z ~cl y o z

    | in_cl_eq_4 : forall x y z,               y ~cl     z
                              ->           x o y ~cl x o z

  where "x ~cl y" := (cl_eq x y).

  (* Some exercices with cl_term equivalence *)

  Fact cl_eq_refl f g : f = g -> f ~cl g.
  Proof.
    intro H.
    rewrite H.
    constructor 4.
  Qed.

  Definition cl_eq_sym := in_cl_eq_1.

  Definition cl_eq_trans := in_cl_eq_2.

  Fact cl_eq_app x y a b : x ~cl y -> a ~cl b -> x o a ~cl y o b.
  Proof.
    intros H0 H1; induction H0.

    apply cl_eq_trans with (x o a);
      try (apply in_cl_eq_3; constructor 1);
      try (apply in_cl_eq_4; auto).

    apply cl_eq_trans with (x o a);
      try (apply in_cl_eq_3; constructor 2);
      try (apply in_cl_eq_4; auto).

    apply cl_eq_trans with (x o z o (y o z) o a);
      try (apply in_cl_eq_3; constructor 3);
      try (apply in_cl_eq_4; auto).

    apply in_cl_eq_4; auto.

    apply cl_eq_trans with (x o a);
      try (apply in_cl_eq_3; apply cl_eq_sym; auto);
      try (apply in_cl_eq_4; auto).

    apply cl_eq_trans with (x o b);
      try (apply in_cl_eq_4; auto);
      try (apply in_cl_eq_3; apply cl_eq_trans with y; auto).

    apply cl_eq_trans with (y o z o a);
      try (do 2 apply in_cl_eq_3; auto);
      try (apply in_cl_eq_4; auto).

    apply cl_eq_trans with (x o z o a);
      try (apply in_cl_eq_3; auto; apply in_cl_eq_4; auto);
      try (apply in_cl_eq_4; auto).
  Qed.

  Fact cl_I_prop x : I o x ~cl x.
  Proof.
    apply in_cl_eq_I.
  Qed.

  Fact cl_K_prop x y : K o x o y ~cl x.
  Proof.
    apply in_cl_eq_K.
  Qed.

  Fact cl_S_prop x y z : S o x o y o z ~cl x o z o (y o z).
  Proof.
    apply in_cl_eq_S.
  Qed.

  Fact cl_SKI_prop x : S o K o I o x ~cl x.
  Proof.
    apply cl_eq_trans with (1 := cl_S_prop _ _ _).
    apply cl_K_prop.
  Qed.

  Corollary cl_SKI_I : forall x, S o K o I o x ~cl I o x.
  Proof.
    intros.
    apply cl_eq_trans with (1 := cl_S_prop _ _ _).
    apply cl_eq_trans with (1 := cl_K_prop _ _).
    apply cl_eq_sym.
    constructor 1.
  Qed.

  Definition cl_D := S o I o I.

  Notation D := cl_D.

  Fact cl_D_prop x : D o x ~cl x o x.
  Proof.
    unfold cl_D.
    apply cl_eq_trans with (I o x o (I o x)).
    apply cl_S_prop.
    apply cl_eq_trans with (x o (I o x));
      try apply in_cl_eq_3;
      try apply in_cl_eq_4;
    constructor 1.
  Qed.

  Definition cl_B := S o (K o S) o K.

  Notation B := cl_B.

  Hint Resolve in_cl_eq_0.

  Fact cl_B_prop f g x : B o f o g o x ~cl f o (g o x).
  Proof.
    unfold cl_B.
    apply cl_eq_trans with (K  o S o f o (K o f) o g o x).
    do 2 (apply cl_eq_app; auto); apply cl_S_prop.
    apply cl_eq_trans with (S o (K o f) o g o x).
    do 3 (apply cl_eq_app; auto); apply cl_K_prop.
    apply cl_eq_trans with (1 := cl_S_prop _ _ _).
    apply cl_eq_app; auto.
    apply cl_K_prop.
  Qed.

  Definition cl_L := D o (B o D o D).

  Notation L := cl_L.

  Fact cl_L_prop : L ~cl L o L.
  Proof.
    unfold cl_L.
    apply cl_eq_trans with ((B o D o D) o (B o D o D));
      try apply cl_D_prop.
    do 2 (
      apply cl_eq_trans with (D o (D o (B o D o D)));
        try apply cl_D_prop;
        try (apply cl_B_prop; constructor 4)
    ).
  Qed.

End cl_equivalence.

Notation "x '~cl' y" := (cl_eq x y) (at level 70).


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.QArith.QArith.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Rewriter.Util.Option Rewriter.Util.Strings.ParseArithmetic.
Require Import Rewriter.Rewriter.Examples.PerfTesting.Harness.
Require Import Rewriter.Util.plugins.RewriterBuild.
Require Rewriter.Rewriter.Examples.PerfTesting.Sample.
Require Export Rewriter.Rewriter.Examples.PerfTesting.Settings.
Local Open Scope Z_scope.

Definition iter_plus_acc (m : nat) (acc v : Z) :=
  @nat_rect
    (fun _ => Z -> Z)
    (fun acc => acc)
    (fun _ rec acc => rec (acc + v))
    m
    acc.

Definition make_tree (n : nat) (m : nat) (v : Z) (acc : Z) :=
  Eval cbv [iter_plus_acc pred] in
    @nat_rect
      (fun _ => Z * Z -> Z)
      (fun '(v, acc) => iter_plus_acc m (acc + acc) v)
      (fun _ rec '(v, acc) => iter_plus_acc m (rec (v, acc) + rec (v, acc)) v)
      n
      (v, acc).

Definition eval_Z_to_nat n : Z.to_nat ('n) = '(Z.to_nat n).
Proof. reflexivity. Qed.

Time Make myrew := Rewriter For (Z.add_0_r, eval_Z_to_nat, eval_rect nat, eval_rect prod).

Notation goal n m := (forall acc, make_tree n m 0 acc = acc) (only parsing).
Ltac start _ := cbv [make_tree]; intros.
Ltac verify_form term :=
  lazymatch term with
  | ?x + ?x => verify_form x
  | _ => is_var term
  end.
Ltac verify _ :=
  lazymatch goal with
  | [ |- ?lhs = ?acc ]
    => is_var acc; verify_form lhs
  end.

(* size(iter_plus_acc(m, acc, v)) := size(acc) + m * (1 + size(v))
   size(make_tree(0, m, v, acc)) := size(iter_plus_acc(m, 1+2*size(acc), v))
   size(make_tree(1+n,m,v, acc)) := size(iter_plus_acc(m, 1+2*size(make_tree(n,m,v,acc)), v)) *)
(* RSolve[{mt[0, m, v, acc] == ipa[m, 1 + 2*acc, v],
   mt[n, m, v, acc] == ipa[m, 1 + 2*mt[n - 1, m, v, acc], v]} /.
  ipa[m_, acc_, v_] :> acc + m*(1 + v), mt[n, m, v, acc], n]
 *)
(* mt[n, m, v, acc] -> -1 + 2^(1 + n) + 2^(1 + n) acc - m + 2^(1 + n) m -
   m v + 2^(1 + n) m v *)
(* mt[n, m, 1, 1] -> 1 + 2 (2^(n + 1) - 1) (m + 1) *)
Definition input_num_nodes (n : Z) (m : Z) : Z
  := (1 + 2 * (2^(n+1) - 1) * (m + 1))%Z.

(* size(iter_plus_acc(m, acc)) := size(acc)
   size(make_tree(0, m, v, acc)) := size(iter_plus_acc(m, 1+2*size(acc), v))
   size(make_tree(1+n,m,v, acc)) := size(iter_plus_acc(m, 1+2*size(make_tree(n,m,v,acc)), v)) *)
(* RSolve[{mt[0, m, v, acc] == ipa[m, 1 + 2*acc, v],
   mt[n, m, v, acc] == ipa[m, 1 + 2*mt[n - 1, m, v, acc], v]} /.
  ipa[m_, acc_, v_] :> acc, mt[n, m, v, acc], n]
 *)
(* mt[n, m, v, acc] -> -1 + 2^(1 + n) + 2^(1 + n) acc *)
(* mt[n, m, _, 1] -> -1 + 2^(2 + n) *)
Definition output_num_nodes (n : Z) (m : Z) : Z
  := (2^(n+2)-1)%Z.

(* #0s(iter_plus_acc(m, acc, v)) := #0s(acc) + m * #0s(v)
   #0s(make_tree(0, m, v, acc)) := #0s(iter_plus_acc(m, 2*#0s(acc), v))
   #0s(make_tree(1+n,m,v, acc)) := #0s(iter_plus_acc(m, 2*#0s(make_tree(n,m,v,acc)), v)) *)
(* RSolve[{mt[0, m, v, acc] == ipa[m, 2*acc, v],
   mt[n, m, v, acc] == ipa[m, 2*mt[n - 1, m, v, acc], v]} /.
  ipa[m_, acc_, v_] :> acc + m*v, mt[n, m, v, acc], n]
 *)
(* mt[n, m, v, acc] -> 2^(1 + n) acc - m v + 2^(1 + n) m v *)
(* mt[n, m, 1, 0] -> (-1 + 2^(n + 1)) m *)
Definition output_num_rewrites (n : Z) (m : Z) : Z
  := ((2^(n+1) - 1) * m)%Z.

Definition size_of_arg (arg : Z * Z) : Z
  := Eval cbv [output_num_nodes output_num_rewrites] in
      output_num_rewrites (fst arg) (snd arg).

Definition invert_size_of_arg_dumb (v : Z) : Z * Z
  := (0%Z, v).

Local Lemma invert_size_of_arg_dumb_correct v
  : size_of_arg (invert_size_of_arg_dumb v) = v.
Proof. cbv [size_of_arg invert_size_of_arg_dumb]; cbn [fst snd]; vm_compute Z.pow; lia. Qed.

Local Instance Z_prod_has_compress : Sample.has_compress (Z * Z) Z := size_of_arg.
Local Instance Z_prod_has_make : Sample.has_make (Z * Z) Z := { make_T := invert_size_of_arg_dumb ; make_T_correct := invert_size_of_arg_dumb_correct }.

Module Import instances.
  Import Coq.QArith.QArith Coq.QArith.Qround Coq.QArith.Qabs Coq.QArith.Qminmax.
  Import Sample.
  Local Open Scope Z_scope.
  Local Set Warnings Append "-ambiguous-paths".
  Local Coercion N.of_nat : nat >-> N.
  Local Coercion N.to_nat : N >-> nat.
  Local Coercion Z.of_N : N >-> Z.
  Local Coercion inject_Z : Z >-> Q.
  Local Coercion Npos : positive >-> N.

  Definition allocate_points_for (n : Z) (min max : Z) (max_points : N) : list (Z * Z)
    := let v : Z := compress_T (n:Z, 1) in
       List.map (fun m => (n:Z, m))
                (Zrange_max_points (Qceiling (min / v))
                                   (Qfloor (max / v))
                                   max_points).
  Fixpoint alloc_down_from (points_remaining : N) (min max : Z) (n : nat) : list (Z * Z)
    := match points_remaining with
       | 0%N => []
       | 1%N => [(0, max)]
       | 2%N => [(0, min); (0, max)]
       | _
         => let max_cur_points := (points_remaining / S n)%N in
            let cur_points := allocate_points_for n min max max_cur_points in
            match n with
            | O => []
            | S n' => alloc_down_from (points_remaining - List.length cur_points) min max n'
            end
              ++ cur_points
       end.

  (** If we don't have enough points, start going through from the smallest value of [n] and filling in all possible points *)
  Fixpoint extra_alloc_at_bottom (extra_points_remaining : N)
           (min max : Z)
           (sparse_points dense_points : list (Z * Z))
           (cur_n : nat)
           (fuel : nat)
    : list (Z * Z)
    := if ((extra_points_remaining =? 0)%N || (max <? min))
       then dense_points ++ sparse_points
       else
         let '(removed_points, sparse_points) := List.partition (fun '(n, m) => (n =? cur_n)) sparse_points in
         let extra_points_remaining := (extra_points_remaining + List.length removed_points)%N in
         let new_points := allocate_points_for extra_points_remaining min max cur_n in
         let extra_points_remaining := (extra_points_remaining - List.length new_points)%N in
         let dense_points := dense_points ++ new_points in
         match fuel with
         | O => dense_points ++ sparse_points
         | S fuel
           => extra_alloc_at_bottom extra_points_remaining min max sparse_points dense_points (S cur_n) fuel
         end.

  Definition extra_alloc_if_necessary
             (max_n : Z)
             (min max : Z)
             (n_points : N)
             (cur_points : list (Z * Z))
    := extra_alloc_at_bottom (n_points - List.length cur_points) min max cur_points [] O (Z.to_nat max_n).

  Global Instance Z_prod_has_alloc : has_alloc (Z * Z)
  := { alloc_T min max n
       := match n with
          | 0%N => []
          | 1%N => [max]
          | 2%N => [min; max]
          | _
            => (let min := compress_T min in
                let max := compress_T max in
                let max_n := (* max = (2^(n+1) - 1) * m; m = 1 *) Z.log2 (max + 1) - 1 in
                if max_n + 1 <=? (1 + (n+1)/3)
                then
                   (* we want all the possible values of the first pair *)
                  alloc_down_from n min max (Z.to_nat max_n)
                else
                  extra_alloc_if_necessary
                    max_n min max n
                    (List.flat_map
                       (fun v => allocate_points_for v min max 3)
                       (alloc_T 0 max_n (1 + (n+1)/3))))%Z
          end }.
End instances.

Inductive rewrite_strat_kind := topdown | bottomup.
Inductive kind_of_rewrite := kind_rewrite_strat (_ : rewrite_strat_kind) | kind_setoid_rewrite | kind_rewrite | kind_autorewrite | kind_ssr_rewrite | kind_rewrite_lhs_for.

Local Notation "'eta_kind' ( k' => f ) k"
  := match k with
     | kind_rewrite_strat topdown
       => subst! (kind_rewrite_strat topdown) for k' in f
     | kind_rewrite_strat bottomup
       => subst! (kind_rewrite_strat bottomup) for k' in f
     | kind_setoid_rewrite => subst! kind_setoid_rewrite for k' in f
     | kind_rewrite => subst! kind_rewrite for k' in f
     | kind_autorewrite => subst! kind_autorewrite for k' in f
     | kind_ssr_rewrite => subst! kind_ssr_rewrite for k' in f
     | kind_rewrite_lhs_for => subst! kind_rewrite_lhs_for for k' in f
     end
       (only parsing, at level 70, k' ident).

Local Lemma sanity : forall T f k, eta_kind (k => f k) k = f k :> T.
Proof. intros; repeat match goal with |- context[match ?e with _ => _ end] => destruct e end; reflexivity. Qed.

(* datastr = <....>;
tbl = Map[
   Map[(If[StringLength[#] == 0, Null,
        If[StringMatchQ[#, NumberString], ToExpression[#], #]]) &,
     StringSplit[#, ",", All]] &, StringSplit[datastr, "\n"]];
cols = Transpose[tbl] /. {x_String, ___} :>
    Sequence[] /;
     Not[StringMatchQ[x, "param-" ~~ ___] ||
       StringMatchQ[x, ___ ~~ "-regression-" ~~ ___ ~~ "-real"]];
data = Map[{#[[1]],
      Transpose[{Drop[cols[[1]], 1], Drop[#, 1]}] /. {_, Null} :>
        Sequence[]} &, cols] /. {x_String, _} :>
    Sequence[] /; StringMatchQ[x, "param-" ~~ ___];
data3D = Map[{#[[1]],
      Transpose[{Drop[cols[[2]], 1], Drop[cols[[3]], 1],
         Drop[#, 1]}] /. {_, _, Null} :> Sequence[]} &,
    cols] /. {x_String, _} :>
    Sequence[] /; StringMatchQ[x, "param-" ~~ ___];
fits = Map[{#[[1]],
     NonlinearModelFit[#[[2]],
      a + b X + c Y + d X Y + e X^2 + f Y^2 + g X^3 + h X^2 Y +
        i X Y^2 + j Y^3 /. {X -> 2^n, Y -> m}, {a, b, c, d, e, f, g,
       h, i, j}, {n, m}]} &, data3D];
fits2 = Map[{#[[1]],
     NonlinearModelFit[#[[2]],
      a + b X + c Y + d X Y + e X^2 + f Y^2 /. {X -> 2^n, Y -> m}, {a,
        b, c, d, e, f}, {n, m}]} &, data3D];
ListPlot[Map[#[[2]] &, data], PlotLegends -> Map[#[[1]] &, data], PlotRange -> Full]
ListPointPlot3D[Map[#[[2]] &, data3D],
 PlotLegends -> Map[#[[1]] &, data3D], PlotRange -> Full,
 AxesLabel -> {n, m, z}]
Table[Function[{d}, {Show[
     ListPointPlot3D[Map[#[[2]] &, data3D[[{d}]]],
      PlotLegends -> Map[#[[1]] &, data3D[[{d}]]],
      PlotRange -> {Full, Full, {0, 10}}, AxesLabel -> {n, m, z}],
     Plot3D[fits[[d]][[2]][n, m], {n, 0, 10}, {m, 0, 1500}(*,
      PlotLegends\[Rule]{Normal[fits[[d]][[2]]]}*)],
     ImageSize -> Large], Normal[fits[[d]][[2]]]}][d], {d, 1,
  Length[data3D]}]
Map[{#[[1]], Normal[#[[2]]] /. n -> 0 /. m -> x} &, fits]
Map[{#[[1]], Normal[#[[2]]] /. n -> 0 /. m -> x} &, fits2]
(*ExpandAll[
 Map[{#[[1]], Normal[#[[2]]] /. n -> Log2[x + 1] - 1 /. m -> 1} &,
  fits]]*)
 *)

Local Notation parse x := (invert_Some (parseQ_arith_strict x)) (only parsing).
Local Notation parse_poly_expr p x := (invert_Some (parseQexpr_arith_with_vars [("x"%string, x)] p)) (only parsing).
Local Notation red_vm_compute x := (ltac:(let z := (eval vm_compute in x) in
                                          exact z)) (only parsing).
Local Notation parse_poly p x := (invert_Some (eval_Qexpr_strict (red_vm_compute (parse_poly_expr p x)))) (only parsing).

Definition size_of_kind (k : kind_of_rewrite) (arg : Z * Z) : Q
  := let termsize := size_of_arg arg in
     let x := inject_Z termsize in
     let '(n, m) := (fst arg, inject_Z (snd arg)) in
     match k with
     | kind_rewrite_strat bottomup
       => (*-0.218 + 3.68E-03*x + 6.64E-06*x^2*)
       parse_poly "-0.964971 + 0.00567641*x + 0.000133294*x^2"%string x
(*       -0.0419087 - 0.015458 * 2^n - 0.000126407 * 2^(2 * n) -
 1.08304E-7 * 2^(3 * n) - 0.0248191 * m + 0.00639815 * 2^n * m +
 0.00021925 * 2^(2 * n) * m + 0.000265979 * m^2 + 0.000269755 * 2^n * m^2 -
 3.14699E-6 * m^3*)
     | kind_rewrite_strat topdown
       => (*0.141 + -8.55E-04*x + 3.28E-06*x^2*)
       parse_poly "-0.151224 + 0.000230063*x + 4.83713E-6*x^2 + 4.31671E-10*x^3"%string x
(*       -0.144716 - 0.00652151 * 2^n + 0.0000138788 * 2^(2 * n) -
 7.77221E-9 * 2^(3 * n) - 0.00374702 * m + 0.00397668 * 2^n * m +
 4.03926E-7 * 2^(2 * n) * m - 0.0000288226 * m^2 + 0.0000336598 * 2^n * m^2 +
 4.31671E-10 * m^3*)
     | kind_setoid_rewrite
       => (*3.51E-03 + 4.45E-04*x + 3.73E-06*x^2*)
       parse_poly "-0.169646 + 0.00123046*x + 8.46486E-6*x^2"%string x
(*       -0.0916119 - 0.0127236 * 2^n + 0.0000322477 * 2^(2 * n) -
 7.57294E-8 * 2^(3 * n) - 0.00446198 * m + 0.00482246 * 2^n * m +
 0.0000287754 * 2^(2 * n) * m - 0.0000508636 * m^2 + 0.0000606788 * 2^n * m^2 -
 5.46448E-10 * m^3*)
     | kind_rewrite
       => (*5.67E-03 + 1.33E-04*x + 1.1E-06*x^2*)
       parse_poly "-0.0698785 + 0.000620073*x + 3.63E-6*x^2 + 9.61722E-10*x^3"%string x
(*       -0.0683191 - 0.00156502 * 2^n + 5.57927E-6 * 2^(2 * n) -
 1.73021E-9 * 2^(3 * n) - 0.000478266 * m + 0.00110145 * 2^n * m -
 3.1091E-6 * 2^(2 * n) * m - 0.0000256011 * m^2 + 0.0000292311 * 2^n * m^2 +
 9.61722E-10 * m^3*)
     | kind_autorewrite
       => (*0.0219 + 2.31E-04*x + 1.02E-06*x^2*)
       parse_poly "-0.0585252 + 0.00014934*x + 4.96778E-6*x^2 + 2.96753E-10*x^3"%string x
(*       -0.0586838 + 0.000158133 *2^n + 4.35038E-7 *2^(2* n) +
 5.13011E-10 *2^(3* n) - 0.000282043 * m + 0.000432666 *2^n* m -
 1.28322E-6 *2^(2 *n) *m - 0.0000307768 *m^2 + 0.0000357446 * 2^n * m^2 +
 2.96753E-10 *m^3*)
     | kind_ssr_rewrite
       => (*3.98E-03 + 2.32E-04*x + 2.01E-06*x^2*)
       parse_poly "-0.0684302 + 0.000469109*x + 7.5704E-6*x^2 + 5.51547E-10*x^3"%string x
(*       -0.0667915 - 0.00164326 * 2^n + 4.56044E-6 * 2^(2 * n) -
 1.29764E-9 * 2^(3 * n) - 0.000935073 * m + 0.00140678 * 2^n * m -
 2.59326E-6 * 2^(2 * n) * m - 0.0000493663 * m^2 + 0.0000569367 * 2^n * m^2 +
 5.51547E-10 * m^3*)
     | kind_rewrite_lhs_for
       => parse_poly "0.256649 - 8.2992E-7 *x + 7.03001E-10 *x^2"%string x
     end%Q.

Definition max_input_of_kind (k : kind_of_rewrite) : option (Z * Z)
  := match k with
     | kind_rewrite_strat _
       => None
     | kind_setoid_rewrite
       => None
     | kind_rewrite
       => None
     | kind_autorewrite
       => None
     | kind_ssr_rewrite
       => None
     | kind_rewrite_lhs_for
       => None
     end%Z.

Definition args_of_size_by_sample' (k : kind_of_rewrite) (s : size) : list (Z * Z)
  := Eval cbv beta iota in
      eta_size
        (s'
         => if match s' with Sanity => true | _ => false end
            then [(0, 1); (0, 2); (0, 3); (1, 1); (0, 4); (0, 5); (0, 6); (1, 2)]
            else eta_kind
                   (k'
                    => Sample.generate_inputs
                         (T:=Z*Z)
                         (0, 1)
                         (size_of_kind k')
                         (Qseconds_of_size s')
                         (Qstandard_max_seconds_of_size s')
                         Sample.default_max_points
                         (max_input_of_kind k'))
                   k)
        s.
Local Set NativeCompute Profiling.
Local Set NativeCompute Timing.
(* Takes about 2 seconds *)
Time Definition args_of_size_by_sample (k : kind_of_rewrite) (s : size)
  := Eval native_compute in eta_size (s' => eta_kind (k' => args_of_size_by_sample' k' s') k) s.

Definition compat_args_of_size' (test_tac_n : nat) (s : size)
  := let ls
         := match test_tac_n, s with
            | 0, SuperFast => [(11, 2); (7, 4)]
            | 1, SuperFast => [(12, 3)]
            | 2, SuperFast => [(8, 3)]
            | 3, SuperFast => [(9, 3)]
            | 4, SuperFast => [(7, 3)]
            | 0, Fast => [(14, 5); (13, 20); (9, 1000)]
            | 1, Fast => [(14, 2); (13, 3); (9, 18); (5, 50); (4, 130); (3, 200); (2, 340); (1, 600)]
            | 2, Fast => [(10, 2); (9, 3); (8, 5); (7, 9); (6, 15); (5, 30); (4, 40); (3, 95); (2, 180); (1, 380)]
            | 3, Fast => [(10, 1); (9, 3); (8, 7); (7, 15); (6, 25); (5, 50); (4, 80); (3, 150); (2, 270); (1, 550)]
            | 4, Fast => [(9, 1); (8, 2); (7, 3); (6, 5); (5, 11); (4, 30); (3, 60); (2, 110); (1, 260)]
            | 0, Medium => [(16, 3); (12, 100)]
            | 1, Medium => [(15, 3); (9, 40)]
            | 2, Medium => [(11, 2); (10, 3); (9, 10)]
            | 3, Medium => [(11, 2); (10, 3); (9, 12)]
            | 4, Medium => [(9, 2); (8, 3); (10, 1)]
            | 0, Slow => [(16, 4)] (* ??? *)
            | 1, Slow => [(16, 4)] (* ??? *)
            | 2, Slow => [(12, 4)] (* ? (11, 3) is 122.176s *)
            | 3, Slow => [(12, 4)] (* ? (11, 3) is 165.575s *)
            | 4, Slow => [(9, 3); (10, 2); (11, 1)] (* ? should we have more for smaller fst of the pair? *)
            | _, VerySlow => [(1000, 1000)] (* ??? *)
            | _, _ => []
            end%nat in
     Zsort_by_fst
       (List.flat_map
          (fun '(n_count, m_count)
           => List.flat_map (fun n => let n := Z.of_nat n in List.map (fun m => (n, Z.of_nat m)) (seq 1 m_count)) (seq 1 n_count))
          ls).

Definition kind_to_compat (k : kind_of_rewrite) : option nat
  := match k with
     | kind_rewrite_lhs_for => Some 0
     | kind_rewrite => Some 1
     | kind_setoid_rewrite => Some 2
     | kind_rewrite_strat topdown => Some 3
     | kind_rewrite_strat bottomup => Some 4
     | kind_autorewrite => None
     | kind_ssr_rewrite => None
     end%nat.

Definition compat_args_of_size (k : kind_of_rewrite) (s : size)
  := match kind_to_compat k, s with
     | _, (Sanity | Slow | VerySlow)
     | None, _
       => args_of_size_by_sample k s
     | Some n, _ => compat_args_of_size' n s
     end.

Time Definition args_of_size (k : kind_of_rewrite) (s : size)
  := Eval native_compute in eta_size (s' => eta_kind (k' => compat_args_of_size k' s') k) s.

Ltac mkgoal kind nm
  := let Z_to_nat := (eval vm_compute in Z.to_nat) in
     lazymatch nm with
     | (?n, ?m)
       => let n := constr:(id Z_to_nat n) in
          let m := constr:(id Z_to_nat m) in
          constr:(goal n m)
     end.
Ltac redgoal _ := start ().
Ltac describe_goal nm :=
  lazymatch nm with
  | (?n, ?m)
    => let sz := (eval vm_compute in (size_of_arg nm)) in
       let input_num_nodes := (eval vm_compute in (input_num_nodes n m)) in
       let output_num_nodes := (eval vm_compute in (output_num_nodes n m)) in
       let num_rewrites := (eval vm_compute in (output_num_rewrites n m)) in
       idtac "Params: 0-nm=" sz ", 1-n=" n ", 2-m=" m ", 3-input-size=" input_num_nodes ", 4-output-size=" output_num_nodes ", 5-num-rewrites=" num_rewrites
  end.

#[global] Hint Rewrite Z.add_0_r : mydb.

Ltac do_coq_rewrite _ := rewrite -> !Z.add_0_r.

Require Import Coq.ssr.ssreflect.

Ltac do_ssr_rewrite _ := rewrite !Z.add_0_r.

Ltac time_solve_goal kind
  := let Z_to_nat := (eval cbv in Z.to_nat) in
     let change_Z_to_nat _ := (change (id Z_to_nat) with Z.to_nat) in
     lazymatch kind with
     | kind_rewrite_strat topdown
       => fun nm
          => time "rewrite_strat(topdown)-regression-cubic"
                  (cbv [nat_rect id]; repeat rewrite_strat topdown hints mydb)
     | kind_rewrite_strat bottomup
       => fun nm
          => time "rewrite_strat(bottomup)-regression-cubic"
                  (cbv [nat_rect id]; repeat rewrite_strat bottomup hints mydb)
     | kind_setoid_rewrite
       => fun nm
          => time "setoid_rewrite-regression-cubic"
                  (cbv [nat_rect id]; repeat setoid_rewrite Z.add_0_r)
     | kind_rewrite
       => fun nm
          => time "rewrite!-regression-cubic"
                  (cbv [nat_rect id]; do_coq_rewrite ())
     | kind_ssr_rewrite
       => fun nm
          => time "ssr-rewrite!-regression-cubic"
                  (cbv [nat_rect id]; do_ssr_rewrite ())
     | kind_autorewrite
       => fun nm
          => time "autorewrite-regression-cubic"
                  (cbv [nat_rect id]; repeat autorewrite with mydb)
     | kind_rewrite_lhs_for
       => fun nm
          => time "Rewrite_lhs_for-regression-quadratic" (change_Z_to_nat (); Rewrite_lhs_for myrew)
     end.

(**
<<<

#!/usr/bin/env python3

print(r'''(**
<<<
''')
print(open(__file__, 'r').read())
print(r'''>>>
 *)''')

for i, c in enumerate(('kind_rewrite_strat topdown', 'kind_rewrite_strat bottomup', 'kind_setoid_rewrite', 'kind_rewrite', 'kind_ssr_rewrite', 'kind_autorewrite')):
    print(f'Ltac mkgoal{i} := mkgoal constr:({c}).\nLtac time_solve_goal{i} := time_solve_goal constr:({c}).\nLtac run{i} sz := Harness.runtests_verify_sanity (args_of_size ({c})) describe_goal mkgoal{i} redgoal time_solve_goal{i} verify sz.\n')

>>>
 *)
Ltac mkgoal0 := mkgoal constr:(kind_rewrite_strat topdown).
Ltac time_solve_goal0 := time_solve_goal constr:(kind_rewrite_strat topdown).
Ltac run0 sz := Harness.runtests_verify_sanity (args_of_size (kind_rewrite_strat topdown)) describe_goal mkgoal0 redgoal time_solve_goal0 verify sz.

Ltac mkgoal1 := mkgoal constr:(kind_rewrite_strat bottomup).
Ltac time_solve_goal1 := time_solve_goal constr:(kind_rewrite_strat bottomup).
Ltac run1 sz := Harness.runtests_verify_sanity (args_of_size (kind_rewrite_strat bottomup)) describe_goal mkgoal1 redgoal time_solve_goal1 verify sz.

Ltac mkgoal2 := mkgoal constr:(kind_setoid_rewrite).
Ltac time_solve_goal2 := time_solve_goal constr:(kind_setoid_rewrite).
Ltac run2 sz := Harness.runtests_verify_sanity (args_of_size (kind_setoid_rewrite)) describe_goal mkgoal2 redgoal time_solve_goal2 verify sz.

Ltac mkgoal3 := mkgoal constr:(kind_rewrite).
Ltac time_solve_goal3 := time_solve_goal constr:(kind_rewrite).
Ltac run3 sz := Harness.runtests_verify_sanity (args_of_size (kind_rewrite)) describe_goal mkgoal3 redgoal time_solve_goal3 verify sz.

Ltac mkgoal4 := mkgoal constr:(kind_ssr_rewrite).
Ltac time_solve_goal4 := time_solve_goal constr:(kind_ssr_rewrite).
Ltac run4 sz := Harness.runtests_verify_sanity (args_of_size (kind_ssr_rewrite)) describe_goal mkgoal4 redgoal time_solve_goal4 verify sz.

Ltac mkgoal5 := mkgoal constr:(kind_autorewrite).
Ltac time_solve_goal5 := time_solve_goal constr:(kind_autorewrite).
Ltac run5 sz := Harness.runtests_verify_sanity (args_of_size (kind_autorewrite)) describe_goal mkgoal5 redgoal time_solve_goal5 verify sz.

Ltac mkgoal6 := mkgoal constr:(kind_rewrite_lhs_for).
Ltac time_solve_goal6 := time_solve_goal constr:(kind_rewrite_lhs_for).
Ltac run6 sz := Harness.runtests_verify_sanity (args_of_size (kind_rewrite_lhs_for)) describe_goal mkgoal6 redgoal time_solve_goal6 verify sz.

#[global] Hint Opaque Z.add : rewrite typeclass_instances.

Global Instance : forall {A}, Proper (eq ==> eq ==> Basics.flip Basics.impl) (@eq A) := _.
Global Instance : Proper (eq ==> eq ==> eq) Z.add := _.
Global Instance : forall {acc}, @ProperProxy Z (@eq Z) acc := _.
Global Instance : forall {A}, subrelation (@eq A) (@eq A) := _.

Global Set NativeCompute Timing.
Global Open Scope Z_scope.

(*
Goal True.
  run3 Sanity.
*)


Require Export GeoCoq.Elements.OriginalProofs.lemma_supplementsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_oppositesidesymmetric.
Require Export GeoCoq.Elements.OriginalProofs.proposition_27.

Section Euclid.
Context `{Ax:euclidean_neutral_ruler_compass}.
Lemma proposition_28B :
   forall A B C D G H,
   BetS A G B -> BetS C H D -> RT B G H G H D -> OS B D G H ->
   Par A B C D.
Proof.
intros.
assert (OS D B G H) by (forward_using lemma_samesidesymmetric).
let Tf:=fresh in
assert (Tf:exists a b c d e, (Supp a b c e d /\ CongA B G H a b c /\ CongA G H D e b d)) by (conclude_def RT );destruct Tf as [a[b[c[d[e]]]]];spliter.
assert (CongA a b c B G H) by (conclude lemma_equalanglessymmetric).
assert (neq G H) by (forward_using lemma_angledistinct).
assert (CongA e b d G H D) by (conclude lemma_equalanglessymmetric).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Out G H H) by (conclude lemma_ray4).
assert (Supp A G H H B) by (conclude_def Supp ).
assert (Supp B G H H A) by (conclude lemma_supplementsymmetric).
assert (CongA e b d H G A) by (conclude lemma_supplements).
assert (CongA G H D e b d) by (conclude lemma_equalanglessymmetric).
assert (CongA G H D H G A) by (conclude lemma_equalanglestransitive).
assert (nCol H G A) by (conclude lemma_equalanglesNC).
assert (CongA H G A A G H) by (conclude lemma_ABCequalsCBA).
assert (CongA G H D A G H) by (conclude lemma_equalanglestransitive).
assert (CongA A G H G H D) by (conclude lemma_equalanglessymmetric).
assert (eq G G) by (conclude cn_equalityreflexive).
assert (Col G H G) by (conclude_def Col ).
assert (nCol A G H) by (conclude lemma_equalanglesNC).
assert (~ Col G H A).
 {
 intro.
 assert (Col A G H) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (TS A G H B) by (conclude_def TS ).
assert (TS B G H A) by (conclude lemma_oppositesidesymmetric).
assert (TS D G H A) by (conclude lemma_planeseparation).
assert (TS A G H D) by (conclude lemma_oppositesidesymmetric).
assert (Par A B C D) by (conclude proposition_27).
close.
Qed.

End Euclid.


From Coq Require Import ssreflect.
Require Import Bool.

Definition truthtable c1 c2 c3 :=
  match c1, c2, c3 with
  | true, true, true => true
  | _, _, _ => false
  end.

Goal forall (c1 c2 c3 : bool), truthtable c1 c2 c3 = c1 && c2 && c3.
  case.
  - case.
    + case.
      * done.
      * done.
    + case.
      * done.
      * done.
  - case.
    + case.
      * done.
      * done.
    + case.
      * done.
      * done.
Qed.


Require Import CT.Category.
Require Import CT.Algebra.Magma.
Require Import CT.Algebra.Monoid.
Require Import CT.Algebra.Semigroup.

(** The category for a given monoid. A monoid is exactly a category with one
    object.
 *)
Program Definition MonoidCategory {T} (M : Monoid) : Category :=
  {| ob := unit;
     mor := fun _ _ => T;
     comp := fun _ _ _ => mu M;
     id := fun a => one M;
  |}.
Next Obligation.
Proof. apply semigroup_assoc. Qed.
Next Obligation.
Proof. symmetry. apply semigroup_assoc. Qed.


Variables P Q R T : Prop.

Section Minimal_propositional_logic.

  (* Using explicit tactics *)
  Theorem imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    intros H H' p.
    apply H'.
    apply H.
    assumption.
  Qed.

  (* Getting Coq to help us *)
  Theorem imp_trans' : (P -> Q) -> (Q -> R) -> P -> R.
  Proof.
    auto.
  Qed.
End Minimal_propositional_logic.

Section example_of_assumption.
  Hypothesis H : P -> Q -> R.

  (* More assumptions! *)
  Lemma L1 : P -> Q -> R.
  Proof.
    assumption.
  Qed.
End example_of_assumption.

Section taken_to_the_extreme.
  (* We can also define proofs in terms of functions.
   * Thanks Curry and Howard!
   *)
  Theorem delta : (P -> P -> Q) -> P -> Q.
  (* Note that inline proofs are not recommended by Bertot *)
  Proof (fun (H:P->P->Q)(p:P) => H p p).
End taken_to_the_extreme.

Print imp_trans.
Print imp_trans'.
Print L1.
Print delta.

(* Regular ol' tactics *)
Theorem compose_example : (P -> Q -> R) -> (P -> Q) -> (P -> R).
Proof.
  intros H H' p.
  apply H.
  apply p.
  apply H'.
  assumption.
Qed.

(* 'Tacticals', or, higher-order tactics. *)
Theorem compose_example' : (P -> Q -> R) -> (P -> Q) -> (P -> R).
Proof.
  intros H H' p.
  apply H;[assumption | apply H'; assumption].
Qed.

(* Regular ol' tactics *)
Lemma L3 : (P->Q)->(P->R)->(P->Q->R->T)->P->T.
Proof.
  intros H H0 H1 p.
  apply H1.
  assumption.
  apply H.
  assumption.
  apply H0.
  assumption.
Qed.

(* 'Tacticals', or, higher-order tactics. Featuring ID. *)
Lemma L3' : (P->Q)->(P->R)->(P->Q->R->T)->P->T.
Proof.
  intros H H0 H1 p.
  apply H1;[idtac | apply H | apply H0]; assumption.
Qed.


Require Import Coq.funind.FunInd.
Require Import Coq.Lists.List Coq.Lists.SetoidList. Import ListNotations.
Require Import Coq.Numbers.BinNums Coq.NArith.BinNat.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Algebra.Monoid Crypto.Algebra.ScalarMult.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.BreakMatch.

Section AddChainExp.
  (* TODO: rewrite this.
     - use CPS and Loop
     - use an inner loop for repeated squaring
     - connect to something that abstracts over F.pow, Z.pow, N.pow NOT scalarmult
  *)

  Function fold_chain {T} (id:T) (op:T->T->T) (is:list (nat*nat)) (acc:list T) {struct is} : T :=
    match is with
    | nil =>
      match acc with
      | nil => id
      | ret::_ => ret
      end
    | (i,j)::is' =>
      let ijx := op (nth_default id acc i) (nth_default id acc j) in
      fold_chain id op is' (ijx::acc)
    end.

  Example wikipedia_addition_chain : fold_chain 0 plus [
  (0, 0); (* 2 = 1 + 1 *) (* the indices say how far back the chain to look *)
  (0, 1); (* 3 = 2 + 1 *)
  (0, 0); (* 6 = 3 + 3 *)
  (0, 0); (* 12 = 6 + 6 *)
  (0, 0); (* 24 = 12 + 12 *)
  (0, 2); (* 30 = 24 + 6 *)
  (0, 6)] (* 31 = 30 + 1 *)
  [1] = 31. reflexivity. Qed.
End AddChainExp.


Require Import List ZArith.
Import ListNotations.

Require Import formal_av1.basic_types.
Require Import formal_av1.entropy.bitstream_position.

(* AV-1 spec 4.10. Descriptors *)

Inductive descriptor : Set :=
  | descriptor_f : nat -> descriptor
  | descriptor_uvlc : descriptor
  | descriptor_le : nat -> descriptor
  | descriptor_leb128 : descriptor
  | descriptor_su : nat -> descriptor
  | descriptor_ns : nat -> descriptor
  | descriptor_L : nat -> descriptor
  | descriptor_S : descriptor
  | descriptor_NS : nat -> descriptor.

Definition bit_to_nat (b : bit) : nat :=
  match b with
  | bit_0 => 0
  | bit_1 => 1
  end.

(* AV-1 spec 4.10.2. f(n) *)
(* AV-1 spec 8.1. Parsing process for f(n) *)

Inductive f_decode_relation : nat -> list bit -> nat -> Prop :=
  | f_decode_relation_nil :
    f_decode_relation 0 [] 0
  | f_decode_relation_next :
    forall n bs b x,
    f_decode_relation n bs x ->
    f_decode_relation (S n) (bs ++ [b]) (2 * x + (bit_to_nat b)).

(* AV-1 spec 4.10.3. uvlc() *)

Inductive uvlc_decode_relation : list bit -> nat -> Prop :=
  | uvlc_decode_less_32 :
    forall leading_zeros, leading_zeros < 32 ->
    forall value l, f_decode_relation leading_zeros l value ->
    uvlc_decode_relation
      ((repeat bit_0 leading_zeros) ++ [bit_1] ++ l)
      (value + 2 ^ leading_zeros - 1)
  | uvlc_decode_over_32 :
    forall leading_zeros, leading_zeros >= 32 ->
    uvlc_decode_relation
      ((repeat bit_0 leading_zeros) ++ [bit_1])
      (2 ^ 32 - 1).

(* AV-1 spec 4.10.4. le(n) *)

Inductive le_decode_relation : nat -> list bit -> nat -> Prop :=
  | le_decode_relation_nil :
    le_decode_relation 0 [] 0
  | le_decode_relation_next :
    forall n l_0 l_more x_0 x_more,
    f_decode_relation byte.bits_count l_0 x_0 ->
    le_decode_relation n l_more x_more ->
    le_decode_relation
      (S n)
      (l_0 ++ l_more)
      (x_0 + 2 ^ byte.bits_count * x_more).

(* AV-1 spec 4.10.5. leb128() *)
(* Continuation bit can only be 1, if i < 7. *)

Inductive leb128_helper (i : nat) : list bit -> nat -> Prop :=
  | leb128_helper_stop_bit :
    forall data_bits x, f_decode_relation 7 data_bits x ->
    leb128_helper i ([bit_0] ++ data_bits) x
  | leb128_helper_more :
    i < 7 ->
    forall data_bits x, f_decode_relation 7 data_bits x ->
    forall bits_more x_more, leb128_helper (S i) bits_more x_more ->
    leb128_helper i ([bit_1] ++ data_bits ++ bits_more) (x + 2 ^ 7 * x_more).

Inductive leb128_decode_relation (bits : list bit) (x : nat) : Prop :=
  | leb128_decode_relation_intro :
    x < 2 ^ 32 ->
    leb128_helper 0 bits x ->
    leb128_decode_relation bits x.

(* AV-1 spec 4.10.6. su(n) *)

Inductive su_decode_relation : nat -> list bit -> Z -> Prop :=
  | su_decode_non_negative :
    forall i bits x,
    f_decode_relation i bits x ->
    su_decode_relation (S i) ([bit_0] ++ bits) (Z.of_nat x)
  | su_decode_negative :
    forall i bits x,
    f_decode_relation i bits x ->
    su_decode_relation
      (S i)
      ([bit_1] ++ bits)
      (- (2 ^ (Z.of_nat i)) + Z.of_nat x).

(* AV-1 spec 4.10.7. ns(n) *)

Inductive ns_w_relation (n w : nat) : Prop :=
  | ns_w_intro :
    2 ^ (w - 1) <= n ->
    n < 2 ^ w ->
    ns_w_relation n w.

Inductive ns_m_relation (n : nat) : nat -> Prop :=
  | ns_m_intro :
    forall w, ns_w_relation n w ->
    ns_m_relation n (2 ^ w - n).

Inductive ns_decode_relation (n : nat) : list bit -> nat -> Prop :=
  | ns_decode_short :
    forall w, ns_w_relation n w ->
    forall m, ns_m_relation n m ->
    forall x, x < m ->
    forall bits, f_decode_relation (w - 1) bits x ->
    ns_decode_relation n bits x
  | ns_decode_long :
    forall w, ns_w_relation n w ->
    forall m, ns_m_relation n m ->
    forall x, x >= m ->
    (* note: 2 * m <= m + x < 2 ^ w *)
    forall bits, f_decode_relation w bits (m + x) ->
    ns_decode_relation n bits x.


Require Import CT.Algebra.Magma.
Require Import CT.Algebra.Group.
Require Import CT.Category.

(** * Grp: The category of groups

*)
Program Definition Grp (T : Type) : Category :=
  {| ob := @Group T;
     mor := GroupHomomorphism;
     comp := fun _ _ _ => group_hom_composition;
     id := fun _ => group_hom_id;
     assoc := fun _ _ _ _ => group_hom_composition_assoc
  |}.
Next Obligation.
Proof.
  symmetry.
  apply group_hom_composition_assoc.
Qed.
Next Obligation.
Proof.
  apply group_hom_eq.
  reflexivity.
Qed.
Next Obligation.
Proof.
  apply group_hom_eq.
  reflexivity.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.arrival_sequence
               prosa.classic.model.schedule.uni.schedule prosa.classic.model.schedule.uni.response_time.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Schedulability.

  Import Job SporadicTaskset ArrivalSequence UniprocessorSchedule ResponseTime.

  (* In this section, we define the notion of deadline miss. *)
  Section DeadlineMisses.

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

    Context {Task: eqType}.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any uniprocessor schedule of these jobs. *)
    Variable sched: schedule Job.

    (* For simplicity, let's define some local names. *)
    Let job_completed_by := completed_by job_cost sched.
    Let response_time_bounded_by :=
      is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched.

    Section Definitions.

      (* In this section, we define the notion of deadline miss for a job. *)
      Section JobLevel.

         (* We say that a job j...*)
        Variable j: Job.

        (* ...misses no deadline if it completes by its absolute deadline.*)
        Definition job_misses_no_deadline :=
          job_completed_by j (job_arrival j + job_deadline j).

      End JobLevel.

      (* Next, we define the notion of deadline miss for a task. *)
      Section TaskLevel.

        (* We say that a task tsk... *)
        Variable tsk: Task.

        (* ...misses no deadline if all of its jobs complete by their absolute deadline. *)
        Definition task_misses_no_deadline :=
          forall j,
            arrives_in arr_seq j ->
            job_task j = tsk ->
            job_misses_no_deadline j.

      End TaskLevel.

      (* Next, we define the notion of deadline miss for a task set. *)
      Section TaskSetLevel.

        (* We say that a task set ts... *)
        Variable ts: seq Task.

        (* ...misses no deadline if all of its tasks do not miss any deadlines. *)
        Definition taskset_misses_no_deadline :=
          forall tsk,
            tsk \in ts ->
            task_misses_no_deadline tsk.

      End TaskSetLevel.

    End Definitions.

    (* In this section, we prove some lemmas related to schedulability. *)
    Section Lemmas.

      Variable task_cost: Task -> time.
      Variable task_deadline: Task -> time.

      (* First, we infer schedulability from the response-time bounds of a task. *)
      Section ResponseTimeIsBounded.

        (* Assume that all jobs in the arrival sequence have the same deadline
           as their tasks. *)
        Hypothesis H_job_deadline_eq_task_deadline:
          forall j,
            arrives_in arr_seq j ->
            job_deadline_eq_task_deadline task_deadline job_deadline job_task j.

        (* Also assume that jobs don't execute after completion. *)
        Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

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

        (* If tsk has response-time bound R that is no larger than its deadline, ... *)
        Variable R: time.
        Hypothesis H_R_le_deadline: R <= task_deadline tsk.
        Hypothesis H_response_time_bounded: response_time_bounded_by tsk R.

        (* ...then tsk misses no deadline. *)
        Lemma task_completes_before_deadline:
          task_misses_no_deadline tsk.
        Proof.
          unfold valid_sporadic_job, valid_realtime_job in *.
          intros j ARRj JOBtsk.
          apply completion_monotonic with (t := job_arrival j + R);
            last by apply H_response_time_bounded.
          rewrite leq_add2l.
          apply: (leq_trans H_R_le_deadline).
            by rewrite H_job_deadline_eq_task_deadline // -JOBtsk leqnn.
       Qed.

     End ResponseTimeIsBounded.

   End Lemmas.

  End DeadlineMisses.

End Schedulability.


Require Import CPidgin.Control.Functor.
Require Import CPidgin.Data.Maybe.

Module MaybeFunctorLaws.

Import Functor.
Import Maybe.Maybe.

(* Helper function to act as an id function. *)
Definition id' {A : Type} (x : A): A :=
    x.

(* Functor Law 1: Identity. *)
Lemma MaybeFunctorPreservesIdentityMorphisms:
    forall (A : Type) (x : Maybe A),
        id' <$> x = x.
Proof.
    intros.
    unfold fmap.
    unfold maybeFunctor.
    unfold id'.
    destruct x.
    trivial.
    trivial.
Qed.

(* Functor Law 2: Composition. *)
Lemma MaybeFunctorPreservesCompositionOfMorphisms:
    forall (A B C : Type) (x : Maybe A) (f : A -> B) (g : B -> C),
        (fun a => g (f a)) <$> x
            = g <$> (f <$> x).
Proof.
    intros.
    unfold fmap.
    unfold maybeFunctor.
    destruct x.
    trivial.
    trivial.
Qed.

End MaybeFunctorLaws.


From mathcomp Require Import ssreflect ssrfun seq ssrnat ssrbool.
From mf Require Import all_mf.
Require Import FunctionalExtensionality ClassicalChoice ChoiceFacts.

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

Section pointwise.
  Context (I: Type).
  Definition mf_ptw R T (f: R ->> T):= make_mf (fun rs ts =>
    forall (i: I), f (rs i) (ts i)).

  Lemma ptw_sur R T (f: R ->> T): f \is_cototal -> (mf_ptw f) \is_cototal.
  Proof.
    move => cotot ts.
    have /choice [rs prp] := cotot.
    exists (rs \o_f ts) => i; exact/prp.
  Qed.

  Lemma ptw_sing R T (f: R ->> T):
    f \is_singlevalued -> (mf_ptw f) \is_singlevalued.
  Proof.
    move => sing rs ts t's val val'.
    apply/functional_extensionality => i.
    exact/sing/val'/val.
  Qed.

  Definition ptw R T (f: R -> T) (rs: I -> R) i := f (rs i).

  Lemma ptw_comp R T (f: R -> T) rs: (ptw f rs) =1 f \o_f rs.
  Proof. done. Qed.

  Lemma F2MF_ptw R T (f: R -> T):
    mf_ptw (F2MF f) =~= F2MF (ptw f).
  Proof.
    move => rs ts /=; split => [prp | <-]//.
    exact/functional_extensionality.
  Qed.

  Definition ptw_op R S T (op: R -> S -> T) (rs: I -> R) (ss: I -> S) i:=
    op (rs i) (ss i).

  Lemma ptwA R (op: R -> R -> R): associative op -> associative (ptw_op op).
  Proof.
    by move => ass x y z; apply/functional_extensionality => n; apply/ass.
  Qed.

  Lemma ptwC R (op: R -> R -> R): commutative op -> commutative (ptw_op op).
  Proof.
    by move => ass x y; apply/functional_extensionality => n; apply/ass.
  Qed.

  Lemma ptwDl R (op op': R -> R -> R):
    left_distributive op op' -> left_distributive (ptw_op op) (ptw_op op').
  Proof.
    by move => ass x y z; apply/functional_extensionality => n; apply/ass.
  Qed.

  Lemma ptwDr R (op op': R -> R -> R):
    right_distributive op op' -> right_distributive (ptw_op op) (ptw_op op').
  Proof.
    by move => ass x y z; apply/functional_extensionality => n; apply/ass.
  Qed.

  Definition uncurry R S T (f: R -> S -> T) rs := f rs.1 rs.2.
End pointwise.
Notation ptwn_op := (@ptw_op nat).
Notation ptwn := (@ptw nat).


Require Import Coq.Strings.Ascii
        Coq.Bool.Bool
        Coq.Lists.List.

Require Export Coq.Vectors.Vector
        Coq.omega.Omega
        Coq.Strings.Ascii
        Coq.Bool.Bool
        Coq.Bool.Bvector
        Coq.Lists.List.

Require Import Fiat.ADT
        Fiat.ADTRefinement.GeneralBuildADTRefinements.

(* A specification of what it means to choose a number that is not in a particular list *)
Definition notInList (ls : list nat) :=
  {n : nat | ~In n ls}%comp.

Ltac refines := intros; repeat computes_to_econstructor; repeat computes_to_inv; subst.
Ltac arithmetic := intros;
  repeat match goal with
         | [ |- context[max ?a ?b] ] => let Heq := fresh "Heq" in
                                        destruct (Max.max_spec a b) as [ [? Heq] | [? Heq] ];
                                          rewrite Heq in *; clear Heq
         end; omega.

(* We can use a simple property to justify a decomposition of the original spec. *)
Theorem notInList_decompose : forall ls,
  refine (notInList ls) (upper <- {upper | forall n, In n ls -> upper >= n};
                         {beyond | beyond > upper}).
Proof.
  refines.
  firstorder.
Qed.

(* A simple traversal will find the maximum list element, which is a good upper bound. *)
Definition listMax := fold_right max 0.

(* ...and we can prove it! *)
Theorem listMax_upperBound : forall init ls,
  forall n, In n ls -> fold_right max init ls >= n.
Proof.
  induction ls; simpl; intuition.
  arithmetic.
  apply IHls in H0.
  arithmetic.
Qed.

(* Now we restate that result as a computation refinement. *)
Theorem listMax_refines : forall ls,
  refine {upper | forall n, In n ls -> upper >= n} (ret (listMax ls)).
Proof.
  refines.
  apply listMax_upperBound.
Qed.

(* An easy way to find a number higher than another: add 1! *)
Theorem increment_refines : forall n,
  refine {higher | higher > n} (ret (n + 1)).
Proof.
  refines.
  arithmetic.
Qed.

Ltac begin := eexists; intro; set_evars.

Ltac monad_simpl := autosetoid_rewrite with refine_monad;
                   try simplify_with_applied_monad_laws; simpl.

(* Let's derive an efficient implementation. *)

Theorem implementation : { f : list nat -> Comp nat | forall ls, refine (notInList ls) (f ls) }.
Proof.
  begin.
  rewrite notInList_decompose.
  rewrite listMax_refines.
  setoid_rewrite increment_refines. (* Different tactic here to let us rewrite under a binder! *)
  monad_simpl.
  finish honing.
Defined.

(* We can extract the program that we found as a standlone, executable Gallina term. *)
Definition impl := Eval simpl in proj1_sig implementation.
Print impl.

Eval compute in impl (1 :: 7 :: 8 :: 2 :: 13 :: 6 :: nil).


(** This file was originally written by Niels van der Weide and Dan Frumin.  *)
Require Import HoTT.

(** We look at heterogeneous equality.
    This is equality between inhabitants of different types.
    We follow the paper 'Cubical Methods in SYnthetic Homotopy Theory.
 *)

(** The first definition is via an inductive tyoe. *)
Inductive heq : forall {A B : Type} (p : A = B) (a : A) (b : B), Type :=
| heq_refl : forall {A : Type} (a : A), heq idpath a a.

(** The second definition uses path induction *)
Definition heq_pi {A B : Type} (p : A = B)
  : A -> B -> Type
  := match p with
     | idpath => fun a b => a = b
     end.

Section equivalences.
  (** Heterogenous equality can be understood as a homogeneous equality.
      For that we need to coerce along the type equality.
      This gives an equivalent definition.
   *)
  Definition heq_to_path_coe
             {A B : Type}
             {p : A = B}
             {a : A} {b : B}
             (q : heq p a b)
    : transport idmap p a = b
    := match q with
       | heq_refl _ _ => idpath
       end.

  Definition path_coe_to_heq
             {A B : Type}
             {p : A = B}
    : forall {a : A} {b : B} (q : transport idmap p a = b), heq p a b
    := match p with
       | idpath => fun a b q => transport (heq 1 a) q (heq_refl a)
       end.

  Global Instance heq_to_path_coeq
         {A B : Type}
         {p : A = B}
         {a : A} {b : B}
    : IsEquiv (heq_to_path_coe (A := A) (B := B) (p := p) (a := a) (b := b)).
  Proof.
    simple refine (isequiv_adjointify _ (@path_coe_to_heq A B p a b) _ _).
    - intros x.
      induction p, x ; reflexivity.
    - intros x.
      induction x ; reflexivity.
  Defined.

  (** Alternatively, we can coerce along the inverse of the type equality.
      This gives an equivalent definition as well.
   *)
  Definition heq_to_path_coe_V
             {A B : Type}
             {p : A = B}
             {a : A} {b : B}
             (q : heq p a b)
    : a = transport idmap p^ b
    := match q with
       | heq_refl _ _ => idpath
       end.

  Definition path_coe_V_to_heq
             {A B : Type}
             {p : A = B}
    : forall {a : A} {b : B} (q : a = transport idmap p^ b), heq p a b
    := match p with
       | idpath => fun a b q => transport (heq 1 a) q (heq_refl a)
       end.

  Global Instance heq_to_path_coeq_V
         {A B : Type}
         {p : A = B}
         {a : A} {b : B}
    : IsEquiv (heq_to_path_coe_V (A := A) (B := B) (p := p) (a := a) (b := b)).
  Proof.
    simple refine (isequiv_adjointify _ (@path_coe_V_to_heq A B p a b) _ _).
    - intros x.
      induction p ; cbn in x ; induction x.
      reflexivity.
    - intros x.
      induction x ; reflexivity.
  Defined.

  (** Lastly, the two definitions of heterogeneous equality given in the beginning, are equivalent.
   *)
  Definition heq_to_heq_pi
             {A B : Type}
             {p : A = B}
             {a : A} {b : B}
             (q : heq p a b)
    : heq_pi p a b
    := match q with
       | heq_refl _ _ => idpath
       end.

  Definition heq_pi_to_heq
             {A B : Type}
             {p : A = B}
    : forall {a : A} {b : B} (q : heq_pi p a b), heq p a b
    := match p with
       | idpath => fun a b q => transport (heq idpath a) q (heq_refl _)
       end.

  Global Instance heq_to_heq_pi_is_equiv
             {A B : Type}
             {p : A = B}
             {a : A} {b : B}
    : IsEquiv (heq_to_heq_pi (A := A) (B := B) (p := p) (a := a) (b := b)).
  Proof.
    simple refine (isequiv_adjointify _ (heq_pi_to_heq (A := A) (B := B) (p := p) (a := a) (b := b)) _ _).
    - intros x.
      induction p, x.
      reflexivity.
    - intros x.
      induction x.
      reflexivity.
  Defined.
End equivalences.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(* * Solvability of finite multiset constraints FMsetC_SAT  *)

(*
  Problem:
    Finite Multiset Constraint Solvability (FMsetC_SAT)

  Finite multisets with one constant 0 and one unary constructor h.
  A finite multiset A is represented by a list of its elements.
  The element (h^n 0) is represented by the natural number n.

  Constraints are of shape:
    x ≐ [0]
    x ≐ y ⊍ z
    x ≐ h (y)

  Constraint semantics:
    φ(y ⊍ z) = φ(y) ++ φ(z)
    φ(h (y)) = map h (φ(y))

  FMsetC:
    Given a list of constraints,
    is there a valuation φ : nat -> list nat such that
    for each constraint c we have
      if c is x ≐ [0], then φ(x) ≡ [0]
      if c is x ≐ y ⊍ z, then φ(x) ≡ φ(y) ++ φ(z)
      if c is x ≐ h (y), then φ(x) ≡ map S (φ(y))
    where ≡ is equality up to permutation?

  References:
    [1] Paliath Narendran: Solving Linear Equations over Polynomial Semirings.
      LICS 1996: 466-472, doi: 10.1109/LICS.1996.561463
*)

Require Import PeanoNat List.
Import ListNotations.

(* list equality up to permutation *)
Definition mset_eq (A B: list nat) : Prop :=
  forall c, count_occ Nat.eq_dec A c = count_occ Nat.eq_dec B c.
Local Notation "A ≡ B" := (mset_eq A B) (at level 65).

(* constraints *)
Inductive msetc : Set :=
  | msetc_zero : nat -> msetc
  | msetc_sum : nat -> nat -> nat -> msetc
  | msetc_h : nat -> nat -> msetc.

(* constraint semantics *)
Definition msetc_sem (φ: nat -> list nat) (c: msetc) :=
  match c with
    | msetc_zero x => φ x ≡ [0]
    | msetc_sum x y z => φ x ≡ (φ y) ++ (φ z)
    | msetc_h x y => φ x ≡ map S (φ y)
  end.

(* given a list l of constraints,
  is there a valuation φ satisfying each constraint? *)
Definition FMsetC_SAT (l : list msetc) := exists φ, forall c, In c l -> msetc_sem φ c.


Require Import Function.
Require Import Functor.

Class Adjunction (L R : Type -> Type) := {
    left_functor :> Functor L;
    right_functor :> Functor R;

    (** Adjoints *)
    leftAdjoint : forall {A B : Type}, (L A -> B) -> A -> R B;

    rightAdjoint : forall {A B : Type}, (A -> R B) -> L A -> B;

    (** Laws/Properties *)

    (** Adjoint Isomorphism *)

    adjoint_bijection_1
        : forall {A B : Type} (g : A -> R B) (a : A)
        , (leftAdjoint (rightAdjoint g)) a = g a;

    adjoint_bijection_2
        : forall {A B : Type} (f : L A -> B) (la : L A)
        , (rightAdjoint (leftAdjoint f)) la = f la;

    (** Adjoint Naturality *)

    adjoint_natural_1
        : forall {A B C : Type} (f : L A -> B) (k : B -> C) (a : A)
        , (leftAdjoint (compose k f)) a = fmap k (leftAdjoint f a);

    adjoint_natural_2
        : forall {A B C : Type} (f : L B -> C) (h : A -> B) (a : A)
        , (leftAdjoint (compose f (fmap h))) a = (leftAdjoint f (h a));

    adjoint_natural_3
        : forall {A B C : Type} (g : B -> R C) (h : A -> B) (la : L A)
        , (rightAdjoint (compose g h)) la = (rightAdjoint g (fmap h la));

    adjoint_natural_4
        : forall {A B C : Type} (g : A -> R B) (k : B -> C) (la : L A)
        , rightAdjoint (compose (fmap k) g) la = k (rightAdjoint g la)
}.

(* unit, counit, join and duplicate *)

Definition adjoint_unit {F G : Type -> Type} {adjunction : Adjunction F G} {A : Type} : A -> G (F A) :=
    leftAdjoint id.

Definition adjoint_counit {F G : Type -> Type} {adjunction : Adjunction F G} {B : Type} : F (G B) -> B :=
    rightAdjoint id.

Definition adjoint_join {F G : Type -> Type} {adjunction : Adjunction F G} {A : Type} : G (F (G (F A))) -> G (F A) :=
    fmap adjoint_counit.

Definition adjoint_duplicate {F G : Type -> Type} {adjunction : Adjunction F G} {A : Type} : F (G A) -> F (G (F (G A))) :=
    fmap adjoint_unit.

(* Theorems *)

Theorem adjoint_bijection_1_pointfree
        : forall (F G : Type -> Type) (A B : Type) (adjunction : Adjunction F G) (g : A -> G B)
        , (leftAdjoint (rightAdjoint g)) = g.
Proof.
    intros.
    assert (forall (x : A), leftAdjoint (rightAdjoint g) x = g x).
    intros.
    apply adjoint_bijection_1.
    apply extensional_equality in H.
    assumption.
Qed.

Theorem adjoint_bijection_2_pointfree
        : forall (F G : Type -> Type) (adjunction : Adjunction F G) (A B : Type) (f : F A -> B)
        , (rightAdjoint (leftAdjoint f)) = f.
Proof.
    intros.
    assert (forall (fa : F A), rightAdjoint (leftAdjoint f) fa = f fa).
    intros.
    apply adjoint_bijection_2.
    apply extensional_equality in H.
    assumption.
Qed.

Theorem adjoint_natural_1_pointfree
        : forall (F G : Type -> Type) (A B C : Type) (adjunction : Adjunction F G) (f : F A -> B) (k : B -> C)
        , (leftAdjoint (compose k f)) = compose (fmap k) (leftAdjoint f).
Proof.
    intros.
    apply extensional_equality.
    intros.
    apply adjoint_natural_1.
Qed.

Theorem adjoint_natural_2_pointfree
    : forall (F G : Type -> Type) (A B C : Type) (adjunction : Adjunction F G) (f : F B -> C) (h : A -> B)
    , (leftAdjoint (compose f (fmap h))) = compose (leftAdjoint f) h.
Proof.
    intros.
    apply extensional_equality.
    intros.
    unfold compose at 2.
    apply adjoint_natural_2.
Qed.

Theorem adjoint_natural_3_pointfree
    : forall (F G : Type -> Type) (A B C : Type) (adjunction : Adjunction F G) (g : B -> G C) (h : A -> B)
    , (rightAdjoint (compose g h)) = compose (rightAdjoint g) (fmap h).
Proof.
    intros.
    apply extensional_equality.
    unfold compose at 2.
    intros.
    apply adjoint_natural_3.
Qed.

Theorem adjoint_natural_4_pointfree
    : forall (F G : Type -> Type) (A B C : Type) (adjunction : Adjunction F G) (g : A -> G B) (k : B -> C)
    , rightAdjoint (compose (fmap k) g) = compose k (rightAdjoint g).
Proof.
    intros.
    apply extensional_equality.
    intros.
    unfold compose at 2.
    apply adjoint_natural_4.
Qed.

Theorem adjoint_unit_left_identity
    : forall (F G : Type -> Type) (A : Type) (adjunction : Adjunction F G)
    , compose adjoint_join adjoint_unit = @id (G (F A)).
Proof.
    intros.
    apply extensional_equality.
    intros.
    unfold id.
    unfold compose.
    unfold adjoint_join.
    unfold adjoint_unit.
    unfold adjoint_counit.
    rewrite <- adjoint_natural_1.
    rewrite -> compose_right_identity.
    rewrite -> adjoint_bijection_1.
    unfold id.
    reflexivity.
Qed.

Theorem adjoint_unit_right_identity
    : forall (F G : Type -> Type) (A : Type) (adjunction : Adjunction F G)
    , compose adjoint_join (fmap (fmap adjoint_unit)) = @id (G (F A)).
Proof.
    intros.
    apply extensional_equality.
    intros.
    unfold id.
    unfold compose.
    unfold adjoint_join.
    rewrite -> functors_preserve_composition.
    unfold adjoint_counit.
    unfold adjoint_unit.
    rewrite <- adjoint_natural_3_pointfree.
    rewrite -> compose_left_identity.
    rewrite -> adjoint_bijection_2_pointfree.
    rewrite -> functor_id_law.
    unfold id.
    reflexivity.
Qed.

Lemma adjoint_counit_squared
    : forall (F G : Type -> Type) (A : Type) (adjunction : Adjunction F G)
    , compose adjoint_counit adjoint_counit = compose adjoint_counit (fmap (@adjoint_join F G adjunction A)).
Proof.
    intros.
    apply extensional_equality.
    unfold adjoint_counit at 3.
    unfold compose at 2.
    intros.
    rewrite <- adjoint_natural_3.
    rewrite -> compose_left_identity.
    unfold compose.
    unfold adjoint_counit at 2.
    assert (rightAdjoint (compose (fmap adjoint_counit) id) x = adjoint_counit (rightAdjoint id x)).
    apply adjoint_natural_4.
    rewrite <- H.
    rewrite -> compose_right_identity.
    unfold adjoint_join.
    reflexivity.
Qed.

Theorem adjoint_join_associative
    : forall (F G : Type -> Type) (A : Type) (adjunction : Adjunction F G)
    , compose adjoint_join (@adjoint_join F G adjunction (G (F A))) = compose adjoint_join ((compose fmap fmap) adjoint_join).
Proof.
    intros.
    apply extensional_equality.
    intros.
    unfold compose.
    unfold adjoint_join at 3.
    rewrite -> functors_preserve_composition.
    unfold adjoint_join at 1.
    unfold adjoint_join at 1.
    rewrite -> functors_preserve_composition.
    rewrite -> adjoint_counit_squared.
    reflexivity.
Qed.


Require Import Init.Init.
Require Import Relation.Relation.

Definition binop (A R: J) := R ∈ (A ⨉ A) ↦ A.
Notation   "x +[ R ] y"   := (R[⟨x, y⟩]).

Definition assoc (A R: J) := ∀ x, ∀ y, ∀ z, x ∈ A → y ∈ A → z ∈ A
  → x +[R] y +[R] z = x +[R] (y +[R] z).

Definition identr (A R e: J) := e ∈ A ∧ ∀ x, x ∈ A → x +[R] e = x.
Definition identl (A R e: J) := e ∈ A ∧ ∀ x, x ∈ A → e +[R] x = x.
Definition ident  (A R e: J) := e ∈ A ∧ ∀ x, x ∈ A → x +[R] e = x ∧ e +[R] x = x.

Definition inver (A R e: J) := ∀ x, ∃ y, x ∈ A
  → y ∈ A ∧ x +[R] y = e ∧ y +[R] x = e.

Definition commu (A R: J) := ∀ x, ∀ y, x ∈ A → y ∈ A → x +[R] y = y +[R] x.

Lemma ident_er: ∀ A, ∀ R, ∀ e, ident A R e → identr A R e.
Proof.
  intros A R e [P1 P2].
  split.
  + apply P1.
  + intros x P3.
    apply (P2 _ P3).
Qed.

Lemma ident_el: ∀ A, ∀ R, ∀ e, ident A R e → identl A R e.
Proof.
  intros A R e [P1 P2].
  split.
  + apply P1.
  + intros x P3.
    apply (P2 _ P3).
Qed.

Lemma binop_close: ∀ A, ∀ R, ∀ m, ∀ n, binop A R → m ∈ A → n ∈ A → m +[R] n ∈ A.
Proof.
  intros A R m n P1 P2 P3.
  apply (fval_codom _ _ _ _ P1).
  apply (cp_i _ _ _ _ P2 P3).
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem: forall l n, Cons n (rev l) = rev (append l (Cons n Nil)).
Proof.
intros. induction l.
  - simpl. rewrite <- IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem2: forall l, rev (rev l) = l.
Proof.
induction l.
  - simpl. rewrite <- lem. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
 induction x.
 - intros. simpl. rewrite <- append_assoc. simpl.
   rewrite lem.  rewrite IHx. lfind.  reflexivity.
Admitted.


Set Implicit Arguments.

Require Import ZArith List Bool MSets.

Definition node := positive.

Module mset := MSetAVL.Make Positive_as_OT.

Notation node_set := mset.t.

Print mset. (*Functions over sets!*)

Definition add := Pos.add.

Definition node_eqb := Pos.eqb.

Lemma node_eqb_eq :
  forall x y : node,
    node_eqb x y = true <-> x = y.
Proof.
  intros x y; unfold node_eqb.
  apply Pos.eqb_eq.
Qed.

Lemma node_eqb_refl :
  forall x,
    node_eqb x x = true.
Proof.
  intros x; unfold node_eqb.
  apply Pos.eqb_refl.
Qed.

Lemma node_eqbP :
  forall x y : node,
    reflect (x = y) (node_eqb x y).
Proof.
  intros.
  destruct (node_eqb x y) eqn:H.
  rewrite node_eqb_eq in H. constructor; auto.
  constructor; intros H2; rewrite H2, node_eqb_refl in H.
  congruence.
Qed.

(** Undirected Graphs *)
Inductive tgraph : Type :=
|Leaf : tgraph
|tNode : node -> node_set -> tgraph -> tgraph -> tgraph.

Inductive graph : Type :=
| Empty : graph
| Node :
    node -> (** this node's id *)
    node_set -> (** its neighbors *)
    graph -> (** the rest of the graph *)
    graph.
Check graph.
Local Open Scope positive_scope.
Require Import MSets.MSetInterface.

Notation "[ ]" := mset.empty.

Notation "[ elt0 , .. , eltn ]" := (mset.add elt0 .. (mset.add eltn (mset.empty )) .. ) (at level 60, right associativity).

Example RefSet: node_set :=
  mset.add 4( mset.add 5 ( mset.add 4 mset.empty)).

Compute mset.elements RefSet.
Print RefSet.
Check mset.empty.

Compute mset.exists_ (fun y  =>  Pos.eqb y 4) RefSet.

Example ex1 : graph :=
  Node 1 ([2,  3])
       (Node 2 ([3])
             (Node 3 [] Empty)).

Example tree1 : tgraph :=
  tNode 1 ([2,3]) Leaf (tNode 2 ([1]) Leaf (tNode 3 [] Leaf Leaf)).

Example ex2 : graph :=
  Node 3 ([2,1])
       (Node 2 ([1])
             (Node 1 ([5])
                   (Node 5 [] Empty))).

(** Return the adjacency list associated by graph g
    with node x. *)
Fixpoint adj_of (x : node) (g : graph) : node_set :=
  match g with
  | Empty => mset.empty
  | Node y adj g' =>
    if node_eqb x y then  adj
    else adj_of x g'
  end.

Compute mset.elements (adj_of 3 ex2).

(** Return all neighbors in g of node x. *)
Definition nodeset_contains (x : node) (s : node_set) :=
  mset.mem x s.

Lemma nodelist_containsP :
  forall (x : node) (s : node_set),
    reflect (mset.In x s) (nodeset_contains x s).
Proof.
  intros.
  apply iff_reflect.
  unfold nodeset_contains.
  symmetry.
  apply mset.mem_spec.
Qed.

Fixpoint neighbors_of (x : node) (g : graph) : node_set:=
  match g with
  | Empty => mset.empty
  | Node y adj g' =>
    if node_eqb x y then  mset.union adj (neighbors_of x g')
    else if nodeset_contains x adj then mset.add y (neighbors_of x g')
         else neighbors_of x g'
  end.

Definition is_neighbor (x y : node) (g : graph) : bool :=
  nodeset_contains x (neighbors_of y g).

Fixpoint tgraph_contains (x : node) (g : tgraph) : bool :=
  match g with
  |Leaf =>  false
  |tNode x' adj lgraph rgraph => if node_eqb x x' then true
                                else orb (tgraph_contains x lgraph) (tgraph_contains x rgraph)
  end.

Fixpoint graph_contains (x : node) (g : graph) : bool :=
  match g with
  | Empty => false
  | Node y adj g' =>
    if node_eqb x y then true
    else graph_contains x g'
  end.

Inductive graph_Contains : node -> graph ->  Prop :=
| gc_inst : forall x g l, graph_Contains x (Node x l g)
| gc_subg : forall x g, graph_Contains x g ->
          forall y l, graph_Contains x (Node y l g).

Lemma graph_containsP : forall x g,
  reflect (graph_Contains x g) (graph_contains x g).
Proof.
  intros x g.
  induction g.
  constructor.
  intros h.
  inversion h.
  simpl.
  case_eq (node_eqb x n);
  intros h.
  apply node_eqb_eq in h.
  subst.
  constructor.
  constructor.
  case_eq (graph_contains x g);
  intros h1.
  apply ReflectT.
  apply gc_subg.
  destruct IHg; auto.
  inversion h1.
  constructor.
  intros h2.
  inversion h2; subst.
  rewrite node_eqb_refl in h.
  inversion h.
  apply reflect_iff in IHg.
  apply IHg in H1.
  rewrite H1 in h1.
  inversion h1.
Qed.

Inductive is_Neighbor : node -> node -> graph -> Prop :=
| IN_inl : forall x y l g, mset.In y l -> is_Neighbor x y (Node x l g)
| IN_inr : forall x y l g, mset.In x l -> is_Neighbor x y (Node y l g)
| IN_subg : forall x y g, is_Neighbor x y g ->
              forall z l, is_Neighbor x y (Node z l g).

Lemma is_Neighbor_symm x y g :
  is_Neighbor x y g -> is_Neighbor y x g.
Proof.
  induction g; intros h;
  inversion h; subst;
  constructor; auto.
Qed.

Lemma is_NeighborP : forall x y g,
  reflect (is_Neighbor x y g) (is_neighbor x y g).
Proof.
  intros x y g.
  induction g.
  constructor.
  intros h.
  inversion h.
  apply iff_reflect.
  split; intros h.
  inversion h; subst.
  {
    unfold is_neighbor.
    apply (reflect_iff (mset.In n (neighbors_of y (Node n t g)))).
    apply nodelist_containsP.
    unfold neighbors_of.
    destruct node_eqb;
    fold neighbors_of.
    apply mset.union_spec.

    right.
    unfold neighbors_of.
    admit.
  (*   apply (reflect_iff (In y l) (nodelist_contains y l)) in  H2. *)
  (*   rewrite H2. simpl; left; auto. *)
  (*   apply nodelist_containsP. *)
  (* } *)
  (* { *)
    admit.
  }
  {
    admit.
  }
  {
    admit.
  }
Admitted.

Inductive graph_ok : graph -> Prop :=
| EmptyOk : graph_ok Empty
| NodeOk :
    forall (x : node) (adj : node_set) (g : graph),
      graph_contains x g = false ->
      mset.for_all (fun y => graph_contains y g) adj = true -> (** No self-loops! *)
      graph_ok g ->
      graph_ok (Node x adj g).

Compute mset.elements ([1, 1, 2]).

(** A so-called "smart constructor" for "Node".
    We enforce the following two properties:
      1) "x" is not already in the graph;
      2) every node in "adj" is in the graph. *)
Definition add_node (x : node) (adj : node_set) (g : graph) : graph :=
  if negb (graph_contains x g)
          && negb (nodeset_contains x adj)
          && mset.for_all (fun y => graph_contains y g) adj
  then Node x adj g
  else g.

Lemma add_node_ok :
  forall x adj g,
    graph_ok g ->
    graph_ok (add_node x adj g).
Proof.
  intros x adj g H.
  unfold add_node.
  destruct (negb (graph_contains x g)) eqn:H3;
  destruct (negb (nodeset_contains x adj)) eqn:H4;
  destruct (mset.for_all (fun y : mset.elt => graph_contains y g) adj) eqn:H0; auto. simpl.
  apply NodeOk; auto.
  apply negb_true_iff. auto.
Qed.

Lemma ex1_graph_ok : graph_ok ex1.
Proof.
  unfold ex1; repeat (constructor; auto).
  (* apply NodeOk. auto. *)
  (* apply NodeOk; auto. *)
  (* apply NodeOk; auto. *)
  (* apply EmptyOk. *)
Qed.

Lemma msetfilter_property :
  forall (s : node_set) (f : mset.elt -> bool),
    mset.for_all f ( mset.filter f s) = true.
Proof.
  intros s f.
  rewrite mset.for_all_spec.
  unfold mset.For_all.
  intros x H0.
  unfold mset.for_all.
  rewrite mset.filter_spec in H0.
  destruct H0 as [_ H0].
  auto. unfold respectful;
  unfold Proper; intros; apply f_equal; auto.
  unfold respectful;
  unfold Proper; intros; apply f_equal; auto.
Qed.

Definition remove (x : node) (adj : node_set) : node_set :=
  mset.filter (fun z => negb (node_eqb x z)) adj.

Lemma remove_union :
  forall x s1 s2,
    remove x (mset.union s1 s2) = mset.union (remove x s1) (remove x s2).
Proof.
Admitted.

Fixpoint remove_node (x : node) (g : graph) : graph :=
  match g with
  | Empty => Empty
  | Node y adj g' =>
    if node_eqb x y then remove_node x g'
    else Node y (remove x adj) (remove_node x g')
  end.
Compute remove 1 [].
Lemma remove_node_neighbors_of :
  forall x y g,
    x <> y ->
    neighbors_of y (remove_node x g) = remove x (neighbors_of y g).
Proof.
  intros x y g H.
Admitted.

(* Old proof for my reference while I go through. *)
(*   intros x y g H; induction g; auto. *)
(*   simpl.  *)
(*   destruct (node_eqb x n) eqn:H2. *)
(*   { rewrite node_eqb_eq in H2; subst n. *)
(*     destruct (node_eqb y x) eqn:H3. *)
(*     { rewrite node_eqb_eq in H3; subst y. *)
(*       exfalso; apply H; auto. } *)
(*     rewrite IHg. *)
(*     destruct (nodelist_contains _ _); auto. *)
(*     simpl. rewrite node_eqb_refl. auto. } *)
(*   destruct (node_eqb y n) eqn:H3. *)
(*   { simpl; rewrite H3; auto. *)
(*     rewrite IHg, remove_app; auto. } *)
(*   simpl. rewrite H3. *)
(*   destruct (nodelist_containsP y (remove x l)). *)
(*   { destruct (nodelist_containsP y l). *)
(*     simpl. rewrite H2. simpl. rewrite IHg. auto. *)
(*     destruct (nodelist_containsP y l). congruence. *)
(*     destruct (nodelist_containsP y (remove x l)); [|congruence]. *)
(*     apply In_remove_weaken in i; contradiction. } *)
(*   destruct (nodelist_containsP y l); auto. *)
(*   simpl. rewrite H2. simpl. rewrite IHg. *)
(*   exfalso. apply H. apply not_In_remove_eq in n0; auto. *)
(* Qed.     *)

Lemma remove_node_contains :
  forall x y g,
    x <> y ->
    graph_contains y (remove_node x g) = graph_contains y g.
Proof.
  intros x y g H; induction g; auto.
  simpl.
  destruct (node_eqb x n) eqn:H2.
  { rewrite node_eqb_eq in H2; subst n.
    destruct (node_eqb y x) eqn:H2.
    { rewrite node_eqb_eq in H2; subst y.
      exfalso; apply H; auto. }
    auto. }
  destruct (node_eqb y n) eqn:H3.
  rewrite node_eqb_eq in H3; subst n.
  simpl. rewrite node_eqb_refl; auto.
  simpl. rewrite H3. auto.
Qed.

(* Lemma remove_NoDup x l : *)
(*   NoDup l -> *)
(*   NoDup (removeL x l). *)
(* Proof. *)
(*   induction l; auto. *)
(*   inversion 1; subst. *)
(*   simpl. destruct (negb _). constructor; auto. *)
(*   intros H4. apply In_remove_weaken in H4; contradiction. *)
(*   auto. *)
(* Qed. *)

Lemma In_remove_weaken :
  forall x y (s : node_set),
  mset.In y (remove x s) -> mset.In y s.
Proof.
  intros.
  unfold remove in H.
  apply mset.filter_spec in H.
  destruct H. auto.
  unfold respectful; unfold Proper; auto;
  intros. f_equal. rewrite H1. auto.
Qed.

Lemma In_remove_eq :
  forall x y (s : node_set),
  mset.In y (remove x s) -> x <> y.
Proof.
  intros.
  unfold remove in H.
  apply mset.filter_spec in H.
  destruct H. unfold node_eqb in H0.
  apply Pos.eqb_neq.
  apply negb_true_iff in H0. auto.
  unfold respectful. unfold Proper; auto.
  intros. f_equal. rewrite H1. auto.
Qed.

Lemma remove_node_ok :
  forall x g,
    graph_ok g ->
    graph_ok (remove_node x g).
Proof.
  intros x g H.
  induction g.
  { simpl; auto. }
  simpl.
  destruct (node_eqb x n) eqn:H2.
  { rewrite node_eqb_eq in H2.
    subst n.
    inversion H; subst; auto. }
  apply NodeOk.
  { inversion H; subst.
    rewrite remove_node_contains; auto.
    intros H3; subst x. rewrite node_eqb_refl in H2. congruence. }
  { inversion H; subst.
    specialize (IHg H6).
    apply mset.for_all_spec.
    unfold respectful.
    unfold Proper.
    intros. f_equal. auto.
    rewrite mset.for_all_spec in H5.
    unfold mset.For_all.
    intros.
    rewrite remove_node_contains.
    unfold mset.For_all in H5.
    apply H5. apply  In_remove_weaken in H0. auto.
    apply In_remove_eq in H0. auto.
    unfold respectful.
    unfold Proper.
    intros. f_equal. auto.
  }
  inversion H. auto.
Qed.

Inductive path (g : graph) : node -> node -> list node -> Prop :=
| start : forall x, graph_Contains x g -> path g x x (x::nil)
| step  : forall x y z l,
            graph_Contains x g ->
            path g y z (y::l) ->
            is_Neighbor x y g ->
              path g x z (x::y::l).

Lemma path_ex1 : path ex1 3 1 (3::2::1::nil).
Proof.
  apply step.
  do 2 apply gc_subg.
  apply gc_inst.
  apply step.
  apply gc_subg.
  apply gc_inst.
  apply start.
  apply gc_inst.
  apply IN_inr.
  apply mset.mem_spec. (*might want to find out how to do this a different way*)
  unfold mset.mem.
  simpl. auto.
  apply IN_subg.
  apply IN_inr.
  apply mset.mem_spec; auto.
Qed.

Inductive independent_Set : list node -> graph -> Prop :=
| IS_nil : forall g, independent_Set nil g
| IS_cons : forall x l g,
              graph_Contains x g ->
              independent_Set l g ->
              (forall y, In y l -> ~ is_Neighbor x y g) ->
                independent_Set (x :: l) g.

Fixpoint vertices (g : graph) : list node :=
  match g with
  |Empty => nil
  |Node n adj g' => n :: vertices g'
  end.

Fixpoint edges (g : graph) : list (node * node) :=
  match g with
  |Empty => nil
  |Node n adj g' => app (map (fun (elem : node) => (n, elem)) (mset.elements adj)) (edges g')
  end.

Fixpoint isSortedG (g : graph) : bool :=
  match g with
    |Empty => true
    |Node x adj g' => match g' with
                     |Empty => true
                     |Node n adj1 g'' =>  (Pos.ltb x n) && (isSortedG g')(*if negb (Pos.ltb x n) then isSortedG g'
                                        else false*)
                     end
  end.

(** Other potential operators/predicates/definitions:
    - definition of paths from x <-> y
    - does such a path exist between x <-> y?
    - graph union
    - set of vertices
    - set of edges
    - induced graph for a given set of vertices
    - graph isomorphism (predicate over a labeling from
      one graph to the other)
    - definitions of independent sets, maximal independent sets, etc.

    Other possible projects:
    - Is there a graph invariant that implies:
      "graph isomorphism implies syntactic equality"?
    - Abstract interface over "inductive graphs", together with
      associated induction principle, plus faster implementation
 *)


Require Import XR_Rsqr.
Require Import XR_Rdiv.
Require Import XR_R0.
Require Import XR_Rmult_assoc.
Require Import XR_Rmult_eq_compat_l.
Require Import XR_Rmult_eq_compat_r.
Require Import XR_Rinv_mult_distr.

Local Open Scope R_scope.

Lemma Rsqr_div : forall x y:R, y <> R0 -> Rsqr (x / y) = Rsqr x / Rsqr y.
Proof.
  intros x y h.
  unfold Rsqr.
  unfold Rdiv.
  repeat rewrite Rmult_assoc.
  apply Rmult_eq_compat_l.
  rewrite Rinv_mult_distr.
  {
    repeat rewrite <- Rmult_assoc.
    apply Rmult_eq_compat_r.
    rewrite Rmult_comm.
    reflexivity.
  }
  { exact h. }
  { exact h. }
Qed.


(* summations on a ring *)
(* I also made SRsummation.v for sommations in a semiring (not having
   opposite) which is more general; normally, this Rsummation.v should
   disappear one day *)

Require Import Utf8 Arith.
Import List.
Require Import Misc deprecat_Ring2.

Fixpoint summation_aux {α} {r : ring_op α} b len g :=
  match len with
  | O => 0%Rng
  | S len₁ => (g b + summation_aux (S b) len₁ g)%Rng
  end.

Definition summation {α} {r : ring_op α} b e g := summation_aux b (S e - b) g.

(* the notation Σ have different implentations for historical reasons;
   here with "summation", but elsewhere with "fold_left"; I'd like to
   change that, but it is not so simple to make it work *)
Notation "'Σ' ( i = b , e ) , g" := (summation b e (λ i, (g)))
  (at level 45, i at level 0, b at level 60, e at level 60) : ring_scope.
(*
Notation "'Σ' ( i = b , e ) , g" :=
  (fold_left (λ c i, c + g) (seq b (S e - b)) 0)%Rng
  (at level 45, i at level 0, b at level 60, e at level 60) : ring_scope.
*)

Theorem fold_left_rng_add_fun_from_0 {A} {ro : ring_op A} {rp : ring_prop} :
  ∀ a l (f : nat → _),
  (fold_left (λ c i, c + f i) l a =
   a + fold_left (λ c i, c + f i) l 0)%Rng.
Proof.
intros.
revert a.
induction l as [| x l]; intros; [ symmetry; apply rng_add_0_r | cbn ].
rewrite IHl; symmetry; rewrite IHl.
rewrite rng_add_0_l.
apply rng_add_assoc.
Qed.

Theorem fold_left_is_summation {A} {ro : ring_op A} {rp : ring_prop} :
  ∀ b e g,
  (fold_left (λ c i, c + g i) (seq b (S e - b)) 0 =
   summation b e g)%Rng.
Proof.
intros.
unfold summation.
remember (S e - b) as len.
clear Heqlen.
revert g b.
induction len; intros; [ easy | cbn ].
rewrite fold_left_rng_add_fun_from_0.
rewrite IHlen.
now rewrite rng_add_0_l.
Qed.

Section theorems_summation.

Context {α : Type}.
Context {ro : ring_op α}.
Context {rp : ring_prop}.

Open Scope nat_scope.

Theorem summation_aux_compat : ∀ g h b₁ b₂ len,
  (∀ i, 0 ≤ i < len → (g (b₁ + i)%nat = h (b₂ + i)%nat)%Rng)
  → (summation_aux b₁ len g = summation_aux b₂ len h)%Rng.
Proof.
intros g h b₁ b₂ len Hgh.
revert b₁ b₂ Hgh.
induction len; intros; [ reflexivity | simpl ].
rewrite (IHlen _ (S b₂)).
 apply rng_add_compat_r.
 assert (0 ≤ 0 < S len) as H.
  split; [ reflexivity | apply Nat.lt_0_succ ].

  apply Hgh in H.
  do 2 rewrite Nat.add_0_r in H; assumption.

 intros i Hi.
 do 2 rewrite Nat.add_succ_l, <- Nat.add_succ_r.
 apply Hgh.
 split; [ apply Nat.le_0_l | idtac ].
 apply lt_n_S.
 destruct Hi; assumption.
Qed.

Theorem summation_compat : ∀ g h b k,
  (∀ i, b ≤ i ≤ k → (g i = h i)%Rng)
  → (Σ (i = b, k), g i = Σ (i = b, k), h i)%Rng.
Proof.
intros g h b k Hgh.
apply summation_aux_compat.
intros i (_, Hi).
apply Hgh.
split; [ apply Nat.le_add_r | idtac ].
apply Nat.lt_add_lt_sub_r, le_S_n in Hi.
rewrite Nat.add_comm; assumption.
Qed.

Theorem summation_mul_comm : ∀ g h b k,
  (Σ (i = b, k), g i * h i
   = Σ (i = b, k), h i * g i)%Rng.
Proof.
intros g h b len.
apply summation_compat; intros i Hi.
apply rng_mul_comm.
Qed.

Theorem all_0_summation_aux_0 : ∀ g b len,
  (∀ i, (b ≤ i < b + len) → (g i = 0)%Rng)
  → (summation_aux b len (λ i, g i) = 0)%Rng.
Proof.
intros g b len H.
revert b H.
induction len; intros; [ reflexivity | simpl ].
rewrite H; [ idtac | split; auto ].
 rewrite rng_add_0_l, IHlen; [ reflexivity | idtac ].
 intros i (Hbi, Hib); apply H.
 rewrite Nat.add_succ_r, <- Nat.add_succ_l.
 split; [ apply Nat.lt_le_incl; auto | auto ].

 rewrite Nat.add_succ_r.
 apply le_n_S, le_plus_l.
Qed.

Theorem all_0_summation_0 : ∀ g i₁ i₂,
  (∀ i, i₁ ≤ i ≤ i₂ → (g i = 0)%Rng)
  → (Σ (i = i₁, i₂), g i = 0)%Rng.
Proof.
intros g i₁ i₂ H.
apply all_0_summation_aux_0.
intros i (H₁, H₂).
apply H.
split; [ assumption | idtac ].
destruct (le_dec i₁ (S i₂)) as [H₃| H₃].
 rewrite Nat.add_sub_assoc in H₂; auto.
 rewrite minus_plus in H₂.
 apply le_S_n; auto.

 apply not_le_minus_0 in H₃.
 rewrite H₃, Nat.add_0_r in H₂.
 apply Nat.nle_gt in H₂; contradiction.
Qed.

Theorem summation_aux_succ_last : ∀ g b len,
  (summation_aux b (S len) g =
   summation_aux b len g + g (b + len)%nat)%Rng.
Proof.
intros g b len.
revert b.
induction len; intros.
 simpl.
 rewrite rng_add_0_l, rng_add_0_r, Nat.add_0_r.
 reflexivity.

 remember (S len) as x; simpl; subst x.
 rewrite IHlen.
 simpl.
 rewrite rng_add_assoc, Nat.add_succ_r.
 reflexivity.
Qed.

Theorem summation_aux_rtl : ∀ g b len,
  (summation_aux b len g =
   summation_aux b len (λ i, g (b + len - 1 + b - i)%nat))%Rng.
Proof.
intros g b len.
revert g b.
induction len; intros; [ reflexivity | idtac ].
remember (S len) as x.
rewrite Heqx in |- * at 1.
simpl; subst x.
rewrite IHlen.
rewrite summation_aux_succ_last.
rewrite Nat.add_succ_l, Nat_sub_succ_1.
do 2 rewrite Nat.add_succ_r; rewrite Nat_sub_succ_1.
rewrite Nat.add_sub_swap, Nat.sub_diag; auto.
rewrite rng_add_comm.
apply rng_add_compat_r, summation_aux_compat.
intros; reflexivity.
Qed.

Theorem summation_rtl : ∀ g b k,
  (Σ (i = b, k), g i = Σ (i = b, k), g (k + b - i)%nat)%Rng.
Proof.
intros g b k.
unfold summation.
rewrite summation_aux_rtl.
apply summation_aux_compat; intros i (Hi, Hikb).
destruct b; simpl.
 rewrite Nat.sub_0_r; reflexivity.

 rewrite Nat.sub_0_r.
 simpl in Hikb.
 eapply Nat.le_lt_trans in Hikb; eauto .
 apply lt_O_minus_lt, Nat.lt_le_incl in Hikb.
 remember (b + (k - b))%nat as x eqn:H .
 rewrite Nat.add_sub_assoc in H; auto.
 rewrite Nat.add_sub_swap in H; auto.
 rewrite Nat.sub_diag in H; subst x; reflexivity.
Qed.

Theorem summation_aux_mul_swap : ∀ a g b len,
  (summation_aux b len (λ i, a * g i) =
   a * summation_aux b len g)%Rng.
Proof.
intros a g b len; revert b.
induction len; intros; simpl.
 rewrite rng_mul_0_r; reflexivity.

 rewrite IHlen, rng_mul_add_distr_l.
 reflexivity.
Qed.

Theorem summation_aux_summation_aux_mul_swap : ∀ g₁ g₂ g₃ b₁ b₂ len,
  (summation_aux b₁ len
     (λ i, summation_aux b₂ (g₁ i) (λ j, g₂ i * g₃ i j))
   = summation_aux b₁ len
       (λ i, g₂ i * summation_aux b₂ (g₁ i) (λ j, g₃ i j)))%Rng.
Proof.
intros g₁ g₂ g₃ b₁ b₂ len.
revert b₁ b₂.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen.
apply rng_add_compat_r.
apply summation_aux_mul_swap.
Qed.

Theorem summation_summation_mul_swap : ∀ g₁ g₂ g₃ k,
  (Σ (i = 0, k), (Σ (j = 0, g₁ i), g₂ i * g₃ i j)
   = Σ (i = 0, k), g₂ i * Σ (j = 0, g₁ i), g₃ i j)%Rng.
Proof.
intros g₁ g₂ g₃ k.
apply summation_aux_summation_aux_mul_swap.
Qed.

Theorem summation_only_one_non_0 : ∀ g b v k,
  (b ≤ v ≤ k)
  → (∀ i, (b ≤ i ≤ k) → (i ≠ v) → (g i = 0)%Rng)
    → (Σ (i = b, k), g i = g v)%Rng.
Proof.
intros g b v k (Hbv, Hvk) Hi.
unfold summation.
rewrite Nat.sub_succ_l; [ idtac | etransitivity; eassumption ].
remember (k - b) as len.
replace k with (b + len) in * .
 clear k Heqlen.
 revert b v Hbv Hvk Hi.
 induction len; intros.
  simpl.
  rewrite rng_add_0_r.
  replace b with v ; [ reflexivity | idtac ].
  rewrite Nat.add_0_r in Hvk.
  apply Nat.le_antisymm; assumption.

  remember (S len) as x; simpl; subst x.
  destruct (eq_nat_dec b v) as [H₁| H₁].
   subst b.
   rewrite all_0_summation_aux_0.
    rewrite rng_add_0_r; reflexivity.

    intros j (Hvj, Hjv).
    simpl in Hjv.
    apply le_S_n in Hjv.
    apply Hi; [ split; auto; apply Nat.lt_le_incl; auto | idtac ].
    intros H; subst j.
    revert Hvj; apply Nat.nle_succ_diag_l.

   rewrite Nat.add_succ_r, <- Nat.add_succ_l in Hvk.
   rewrite Hi; auto.
    rewrite rng_add_0_l.
    apply IHlen; auto; [ apply Nat_le_neq_lt; auto | idtac ].
    intros j (Hvj, Hjvl) Hjv.
    rewrite Nat.add_succ_l, <- Nat.add_succ_r in Hjvl.
    apply Hi; auto; split; auto.
    apply Nat.lt_le_incl; auto.

    split; auto.
    apply Nat.le_sub_le_add_l.
    rewrite Nat.sub_diag.
    apply Nat.le_0_l.

 subst len.
 eapply Nat.le_trans in Hvk; eauto .
 rewrite Nat.add_sub_assoc; auto.
 rewrite Nat.add_comm.
 apply Nat.add_sub.
Qed.

Theorem summation_shift : ∀ b g k,
  b ≤ k
  → (Σ (i = b, k), g i =
     Σ (i = 0, k - b), g (b + i)%nat)%Rng.
Proof.
intros b g k Hbk.
unfold summation.
rewrite Nat.sub_0_r.
rewrite Nat.sub_succ_l; [ idtac | assumption ].
apply summation_aux_compat; intros j Hj.
reflexivity.
Qed.

Theorem summation_summation_shift : ∀ g k,
  (Σ (i = 0, k), (Σ (j = i, k), g i j) =
   Σ (i = 0, k), Σ (j = 0, k - i), g i (i + j)%nat)%Rng.
Proof.
intros g k.
apply summation_compat; intros i Hi.
unfold summation.
rewrite Nat.sub_0_r.
rewrite Nat.sub_succ_l; [ idtac | destruct Hi; assumption ].
apply summation_aux_compat; intros j Hj.
rewrite Nat.add_0_l; reflexivity.
Qed.

Theorem summation_only_one : ∀ g n, (Σ (i = n, n), g i = g n)%Rng.
Proof.
intros g n.
unfold summation.
rewrite Nat.sub_succ_l; [ idtac | reflexivity ].
rewrite Nat.sub_diag; simpl.
rewrite rng_add_0_r; reflexivity.
Qed.

Theorem summation_split_last : ∀ g b k,
  (b ≤ S k)
  → (Σ (i = b, S k), g i = Σ (i = b, k), g i + g (S k))%Rng.
Proof.
intros g b k Hbk.
unfold summation.
rewrite Nat.sub_succ_l; [ idtac | assumption ].
rewrite summation_aux_succ_last.
rewrite Nat.add_sub_assoc; [ idtac | assumption ].
rewrite Nat.add_comm, Nat.add_sub.
reflexivity.
Qed.

Theorem summation_aux_succ_first : ∀ g b len,
  summation_aux b (S len) g = (g b + summation_aux (S b) len g)%Rng.
Proof. reflexivity. Qed.

Theorem summation_split_first : ∀ g b k,
  b ≤ k
  → (Σ (i = b, k), g i)%Rng = (g b + Σ (i = S b, k), g i)%Rng.
Proof.
intros g b k Hbk.
unfold summation.
rewrite Nat.sub_succ.
rewrite <- summation_aux_succ_first.
rewrite <- Nat.sub_succ_l; [ reflexivity | assumption ].
Qed.

Theorem summation_empty : ∀ g b k,
  k < b → (Σ (i = b, k), g i = 0)%Rng.
Proof.
intros * Hkb.
unfold summation.
now replace (S k - b) with 0 by flia Hkb.
Qed.

Theorem summation_split : ∀ j g b k,
  b ≤ S j ≤ S k
  → (Σ (i = b, k), g i = Σ (i = b, j), g i + Σ (i = j+1, k), g i)%Rng.
Proof.
intros * (Hbj, Hjk).
unfold summation.
remember (S j - b) as len1 eqn:Hlen1.
remember (S k - b) as len2 eqn:Hlen2.
move len2 before len1.
replace (S k - (j + 1)) with (len2 - len1) by flia Hlen1 Hlen2 Hbj.
replace (j + 1) with (b + len1) by flia Hlen1 Hbj.
assert (Hll : len1 ≤ len2) by flia Hlen1 Hlen2 Hjk.
clear - rp Hll.
revert b len2 Hll.
induction len1; intros. {
  cbn.
  now rewrite rng_add_0_l, Nat.add_0_r, Nat.sub_0_r.
}
cbn.
destruct len2; [ flia Hll | ].
apply Nat.succ_le_mono in Hll.
cbn.
rewrite IHlen1; [ | easy ].
rewrite rng_add_assoc.
now rewrite Nat.add_succ_comm.
Qed.

Theorem summation_add_distr : ∀ g h b k,
  (Σ (i = b, k), (g i + h i) =
   Σ (i = b, k), g i + Σ (i = b, k), h i)%Rng.
Proof.
intros g h b k.
destruct (le_dec b k) as [Hbk| Hbk].
 revert b Hbk.
 induction k; intros.
  destruct b.
   do 3 rewrite summation_only_one; reflexivity.

   unfold summation; simpl; rewrite rng_add_0_r; reflexivity.

  rewrite summation_split_last; [ idtac | assumption ].
  rewrite summation_split_last; [ idtac | assumption ].
  rewrite summation_split_last; [ idtac | assumption ].
  destruct (eq_nat_dec b (S k)) as [H₂| H₂].
   subst b.
   unfold summation; simpl.
   rewrite Nat.sub_diag; simpl.
   do 2 rewrite rng_add_0_l; rewrite rng_add_0_l.
   reflexivity.

   apply Nat_le_neq_lt in Hbk; [ idtac | assumption ].
   apply Nat.succ_le_mono in Hbk.
   rewrite IHk; [ idtac | assumption ].
   do 2 rewrite <- rng_add_assoc.
   apply rng_add_compat_l.
   rewrite rng_add_comm.
   rewrite <- rng_add_assoc.
   apply rng_add_compat_l.
   rewrite rng_add_comm.
   reflexivity.

 unfold summation.
 apply Nat.nle_gt in Hbk.
 replace (S k - b) with O by flia Hbk; simpl.
 rewrite rng_add_0_r; reflexivity.
Qed.

Theorem summation_summation_exch : ∀ g k,
  (Σ (j = 0, k), (Σ (i = 0, j), g i j) =
   Σ (i = 0, k), Σ (j = i, k), g i j)%Rng.
Proof.
intros g k.
induction k; [ reflexivity | idtac ].
rewrite summation_split_last; [ idtac | apply Nat.le_0_l ].
rewrite summation_split_last; [ idtac | apply Nat.le_0_l ].
rewrite summation_split_last; [ idtac | apply Nat.le_0_l ].
rewrite IHk.
rewrite summation_only_one.
rewrite rng_add_assoc.
apply rng_add_compat_r.
rewrite <- summation_add_distr.
apply summation_compat; intros i (_, Hi).
rewrite summation_split_last; [ reflexivity | idtac ].
apply Nat.le_le_succ_r; assumption.
Qed.

Theorem summation_aux_ub_add : ∀ g b k₁ k₂,
  (summation_aux b (k₁ + k₂) g =
   summation_aux b k₁ g + summation_aux (b + k₁) k₂ g)%Rng.
Proof.
intros g b k₁ k₂.
revert b k₁.
induction k₂; intros.
 simpl.
 rewrite Nat.add_0_r, rng_add_0_r; reflexivity.

 rewrite Nat.add_succ_r, <- Nat.add_succ_l.
 rewrite IHk₂; simpl.
 rewrite <- Nat.add_succ_r.
 rewrite rng_add_assoc.
 apply rng_add_compat_r.
 clear k₂ IHk₂.
 revert b.
 induction k₁; intros; simpl.
  rewrite Nat.add_0_r.
  apply rng_add_comm.

  rewrite <- rng_add_assoc.
  rewrite IHk₁.
  rewrite Nat.add_succ_r, <- Nat.add_succ_l; reflexivity.
Qed.

Theorem summation_ub_add : ∀ g k₁ k₂,
  (Σ (i = 0, k₁ + k₂), g i =
   Σ (i = 0, k₁), g i + Σ (i = S k₁, k₁ + k₂), g i)%Rng.
Proof.
intros g k₁ k₂.
unfold summation.
do 2 rewrite Nat.sub_0_r.
rewrite <- Nat.add_succ_l.
rewrite summation_aux_ub_add; simpl.
rewrite Nat.add_comm, Nat.add_sub; reflexivity.
Qed.

Theorem summation_aux_mul_summation_aux_summation_aux : ∀ g k n,
  (summation_aux 0 (S k * S n) g =
   summation_aux 0 (S k)
     (λ i, summation_aux 0 (S n) (λ j, g (i * S n + j)%nat)))%Rng.
Proof.
intros g k n.
revert n; induction k; intros.
 simpl; rewrite Nat.add_0_r, rng_add_0_r; reflexivity.

 remember (S n) as x.
 remember (S k) as y.
 simpl; subst x y.
 rewrite Nat.add_comm.
 rewrite summation_aux_ub_add, IHk.
 symmetry; rewrite rng_add_comm.
 symmetry.
 rewrite summation_aux_succ_first.
 rewrite rng_add_add_swap, rng_add_comm.
 symmetry.
 replace (S k) with (k + 1)%nat by flia.
 rewrite summation_aux_ub_add.
 rewrite <- rng_add_assoc.
 apply rng_add_compat_l.
 simpl.
 rewrite rng_add_comm.
 apply rng_add_compat_l.
 symmetry; rewrite Nat.add_comm; simpl.
 rewrite Nat.add_0_r, rng_add_0_r.
 apply rng_add_compat_l.
 apply summation_aux_compat; intros i Hi; simpl.
 rewrite Nat.add_succ_r; reflexivity.
Qed.

Theorem summation_mul_summation_summation : ∀ g n k,
  (0 < n)%nat
  → (0 < k)%nat
    → (Σ (i = 0, k * n - 1), g i =
       Σ (i = 0, k - 1), Σ (j = 0, n - 1), g (i * n + j)%nat)%Rng.
Proof.
intros g n k Hn Hk.
unfold summation.
do 2 rewrite Nat.sub_0_r.
destruct n; [ exfalso; revert Hn; apply Nat.lt_irrefl | clear Hn ].
destruct k; [ exfalso; revert Hk; apply Nat.lt_irrefl | clear Hk ].
rewrite Nat.sub_succ, Nat.sub_0_r.
rewrite <- Nat.sub_succ_l, Nat.sub_succ, Nat.sub_0_r.
 rewrite summation_aux_mul_summation_aux_summation_aux.
 apply summation_aux_compat; intros i Hi.
 rewrite Nat.sub_succ, Nat.sub_0_r, Nat.sub_0_r.
 reflexivity.

 simpl; apply le_n_S, Nat.le_0_l.
Qed.

Theorem inserted_0_summation : ∀ g h k n,
  n ≠ O
  → (∀ i, i mod n ≠ O → (g i = 0)%Rng)
    → (∀ i, (g (n * i)%nat = h i)%Rng)
      → (Σ (i = 0, k * n), g i = Σ (i = 0, k), h i)%Rng.
Proof.
intros g h k n Hn Hf Hfg.
destruct k.
 rewrite Nat.mul_0_l.
 apply summation_compat; intros i (_, Hi).
 apply Nat.le_0_r in Hi; subst i.
 rewrite <- Hfg, Nat.mul_0_r; reflexivity.

 destruct n; [ exfalso; apply Hn; reflexivity | clear Hn ].
 replace (S k * S n)%nat with (S k * S n - 1 + 1)%nat.
  rewrite summation_ub_add.
  rewrite summation_mul_summation_summation; try apply Nat.lt_0_succ.
  rewrite Nat_sub_succ_1, Nat.add_comm, summation_only_one.
  simpl; do 2 rewrite Nat.sub_0_r.
  symmetry.
  rewrite <- Nat.add_1_r, summation_ub_add, Nat.add_1_r.
  rewrite summation_only_one, rng_add_comm, <- Hfg.
  symmetry.
  rewrite rng_add_comm.
  apply rng_add_compat; [ symmetry; rewrite Nat.mul_comm; reflexivity |  ].
  apply summation_compat; intros i Hi.
  rewrite summation_only_one_non_0 with (v := 0).
   rewrite Nat.add_0_r, Nat.mul_comm; apply Hfg.

   split; [ reflexivity | apply Nat.le_0_l ].

   intros j Hjn Hj.
   rewrite Hf; [ reflexivity |  ].
   rewrite Nat.add_comm.
   rewrite Nat.mod_add; [  | apply Nat.neq_succ_0 ].
   intros H; apply Hj; clear Hj.
   apply Nat.mod_divides in H; auto.
   destruct H as (c, Hc).
   destruct c.
    rewrite Nat.mul_0_r in Hc; assumption.

    rewrite Hc in Hjn.
    rewrite Nat.mul_comm in Hjn.
    simpl in Hjn.
    destruct Hjn as (_, H).
    apply Nat.nlt_ge in H.
    exfalso; apply H.
    apply le_n_S, Nat.le_add_r.

  rewrite Nat.sub_add; [ apply eq_refl |  ].
  simpl; apply le_n_S, Nat.le_0_l.

Qed.

Theorem summation_add_add_sub : ∀ g b k n,
  (Σ (i = b, k), g i = Σ (i = b + n, k + n), g (i - n)%nat)%Rng.
Proof.
intros g b k n.
unfold summation.
replace (S (k + n) - (b + n))%nat with (S k - b)%nat by flia.
apply summation_aux_compat.
intros i Hi.
replace (b + n + i - n)%nat with (b + i)%nat by flia.
reflexivity.
Qed.

Theorem summation_succ_succ : ∀ b k g,
  (Σ (i = S b, S k), g i = Σ (i = b, k), g (S i))%Rng.
Proof.
intros b k g.
unfold summation.
rewrite Nat.sub_succ.
remember (S k - b)%nat as len; clear Heqlen.
revert b.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen; reflexivity.
Qed.

Theorem rng_mul_summation_distr_l : ∀ a b e f,
  (a * (Σ (i = b, e), f i) = Σ (i = b, e), a * f i)%Rng.
Proof.
intros.
unfold summation.
remember (S e - b) as n eqn:Hn.
revert e a b Hn.
induction n; intros; [ apply rng_mul_0_r | cbn ].
rewrite rng_mul_add_distr_l.
rewrite (IHn e); [ easy | flia Hn ].
Qed.

End theorems_summation.