Module TPSmallSteps.

Require Import String.
Open Scope string_scope.

Load TPSyntax.
Export TPSyntax.

Open Scope Z_scope.

Definition TPEvalOp op n1 n2 :=
  match op,  n1, n2 with
    | TPOperatorPlus,     TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n + n')
    | TPOperatorMinus,    TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n - n')
    | TPOperatorMult,     TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n * n')
    | TPOperatorDiv,      TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n / n')
    | TPOperatorMod,      TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPInt (n mod n')
    | TPOperatorLess,     TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zlt_bool n n')
    | TPOperatorLessEq,   TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zle_bool n n')
    | TPOperatorGreater,  TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zgt_bool n n')
    | TPOperatorGreaterEq,TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zge_bool n n')
    | TPOperatorEq,       TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zeq_bool n n')
    | TPOperatorNeq,      TPExpConst (TPConstantInt n), TPExpConst (TPConstantInt n') => TPBool (Zneq_bool n n')
    | _, _, _ => TPHang
  end.

Fixpoint TPFreeVars exp :=
  match exp with
    | TPExpConst _ => nil
    | TPExpId id => id :: nil
    | TPExpApp exp1 exp2 => app (TPFreeVars exp1) (TPFreeVars exp2)
    | TPExpIf exp1 exp2 exp3 => app (TPFreeVars exp1) (app (TPFreeVars exp2) (TPFreeVars exp3))
    | TPExpAbstr id exp => filter (ident_eq id) (TPFreeVars exp)
    | TPExpLet id e1 e2 => app (filter (ident_eq id) (TPFreeVars e2)) (TPFreeVars e1)
    | TPExpRec id exp => filter (ident_eq id) (TPFreeVars exp)
  end.

Definition new_id highest_id id := (TPId (id, S highest_id), S highest_id).

(* Substitute id in e by e', using notation from lecture: e[e'/id] *)
Fixpoint TPSubst (highest_id : nat) e e' id : TPExp * nat :=
  match e with
    | TPExpConst c => (e, highest_id)
    | TPExpId id' =>
      if ident_eq id' id
        then (e', highest_id)
        else (TPExpId id', highest_id)
    | TPExpIf e1 e2 e3 =>
      let (e1', n1) := TPSubst highest_id e1 e' id in
        let (e2', n2) := TPSubst n1 e2 e' id in
          let (e3', n3) := TPSubst n2 e3 e' id in
            (TPIf e1' e2' e3', n3)
    | TPExpApp e1 e2 =>
      let (e1', n1) := TPSubst highest_id e1 e' id in
        let (e2', n2) := TPSubst n1 e2 e' id in
         (TPExpApp e1' e2', n2)
    | TPExpAbstr id' e =>
      if ident_eq id' id
        then (e, highest_id)
        else let (e1, n) := TPSubst highest_id e e' id in (TPExpAbstr id' e1, n)
    | TPExpLet id' e1 e2 =>
      let (e1', n1) := TPSubst highest_id e1 e' id in
        let (e2', n2) := TPSubst n1 e2 e' id in
          (TPExpLet id' e1' (if ident_eq id' id then e2 else e2'), n2)
    | TPExpRec id' e =>
      if ident_eq id' id
        then (e, highest_id)
        else let (e'', n) := TPSubst highest_id e e' id in (TPExpRec id' e'', n)
  end.

(* TODO Figure out, whether this definition is correct. *)
Inductive TPMakesSmallstep: nat -> TPExp -> TPExp * nat -> Prop :=
| smallstep_op: forall idx n1 n2 op,
  TPMakesSmallstep idx (TPApp (TPApp (TPOp op) (TPInt n1)) (TPInt n2)) (TPEvalOp op (TPInt n1) (TPInt n2), idx)
| smallstep_betav: forall idx id exp v,
  TPIsValue v -> TPMakesSmallstep idx (TPApp (TPAbstr id exp) v) (TPSubst idx exp v id)
| smallstep_appleft: forall idx idx' exp1 exp1' exp2,
  TPMakesSmallstep idx exp1 (exp1', idx') -> TPMakesSmallstep idx (TPApp exp1 exp2) (TPApp exp1' exp2, idx')
| smallstep_appright: forall idx idx' exp exp' v,
  TPIsValue v -> TPMakesSmallstep idx exp (exp', idx') -> TPMakesSmallstep idx' (TPApp v exp) (TPApp v exp', idx')
| smallstep_condeval: forall idx idx' exp0 exp0' exp1 exp2,
  TPMakesSmallstep idx exp0 (exp0', idx') -> TPMakesSmallstep idx' (TPIf exp0 exp1 exp2) (TPIf exp0' exp1 exp2, idx')
| smallstep_condtrue: forall idx exp1 exp2,
  TPMakesSmallstep idx (TPIf TPTrue exp1 exp2) (exp1, idx)
| smallstep_condfalse: forall idx exp1 exp2,
  TPMakesSmallstep idx (TPIf TPFalse exp1 exp2) (exp2, idx)
| smallstep_leteval: forall idx idx' id exp1 exp1' exp2,
  TPMakesSmallstep idx exp1 (exp1', idx') -> TPMakesSmallstep idx' (TPLet id exp1 exp2) (TPLet id exp1' exp2, idx')
| smallstep_letexec: forall idx id exp v,
  TPIsValue v -> TPMakesSmallstep idx (TPLet id v exp) (TPSubst idx exp v id)
| smallstep_unfold: forall idx id exp,
  TPMakesSmallstep idx (TPRec id exp) (TPSubst idx exp (TPRec id exp) id).

Fixpoint smallstep (n : nat) (exp : TPExp) : TPExp * nat :=
  match exp with
    | TPExpApp (TPExpApp (TPExpConst (TPConstantOp op)) (TPExpConst (TPConstantInt n1))) (TPExpConst (TPConstantInt n2)) =>
      (TPEvalOp op (TPInt n1) (TPInt n2), n)                                  (* OP *)
    | TPExpApp (TPExpAbstr id e1) e2 =>
      if TPIsValue_bool e2
        then TPSubst n e1 e2 id                                               (* BETA-V *)
        else let (e', n') := smallstep n e2 in (TPApp (TPAbstr id e1) e', n') (* APP-RIGHT *)
    | TPExpApp e1 e2 =>
      if TPIsValue_bool e1
        then let (e', n') := smallstep n e2 in (TPApp e1 e', n')              (* APP-LEFT *)
        else let (e', n') := smallstep n e1 in (TPApp e' e2, n')              (* APP-RIGHT *)
    | TPExpIf e1 e2 e3 =>
      if TPIsValue_bool e1
        then if TPExp_eq e1 TPTrue
          then (e2, n)                                                        (* COND-TRUE *)
          else (e3, n)                                                        (* COND-FALSE *)
        else let (e', n') := smallstep n e1 in (TPIf e' e2 e3, n')            (* COND-EVAL *)
    | TPExpLet id e1 e2 =>
      if TPIsValue_bool e1
        then TPSubst n e2 e1 id                                               (* LET-EXEC *)
        else let (e', n') := smallstep n e1 in (TPLet id e' e2, n')           (* LET-EVAL *)
    | TPExpRec id e => TPSubst n e (TPRec id e) id                            (* UNFOLD *)
  (* Otherwise, no small step exists and the execution hangs *)
    | _ => (TPHang, n)
  end.

Inductive NonEmptyList (A: Type) :=
| Singleton: A -> NonEmptyList A
| Cons: A -> NonEmptyList A -> NonEmptyList A.

Implicit Arguments Singleton [A].
Implicit Arguments Cons [A].

Definition first {A: Type}(l: NonEmptyList A) := match l with
| Singleton a => a
| Cons a l' => a
end.

Fixpoint last {A: Type}(l: NonEmptyList A) := match l with
| Singleton a => a
| Cons a l' => (last l')
end.

Fixpoint length {A: Type}(l: NonEmptyList A) := match l with
| Singleton a => 1%nat
| Cons a l' => S (length l')
end.

Fixpoint nth_default {A: Type}(def: A)(n: nat)(l: NonEmptyList A) := match n,l with
| O, l => first l
| S n', Cons a l' => nth_default def n' l'
| S n', Singleton a => def
end.

Definition TPMultipleSmallsteps exp exp':=
exists steps: NonEmptyList TPExp,
first steps = exp ->
last steps = exp' ->
forall idx n, (n < ((length steps)-1))%nat -> TPMakesSmallstep idx (nth_default TPExn n steps) (nth_default TPExn (n+1) steps, idx).

Definition step0 := (TPLet ("square", 0%nat) (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x",1%nat)))) (TPApp (TPId ("square", 0%nat))(TPApp (TPId ("square", 0%nat)) (TPInt 5)))).
Definition step1 := (TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))))(TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat)))) (TPInt 5))).
Definition step2 := (TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))))(TPApp (TPApp TPMult (TPInt 5)) (TPInt 5))).
Definition step3 := (TPApp (TPAbstr ("x", 1%nat) (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))))(TPInt 25)).
Definition step4 := (TPApp (TPApp TPMult (TPInt 25)) (TPInt 25)).
Definition step5 := TPInt 625.

Lemma less_nat_cases: forall k n: nat, (k < (S n) <-> k < n \/ k = n)%nat.
Proof.
  intros k n.
  split; intros H.
  (* => *)
    apply lt_n_Sm_le in H.
    case_eq (beq_nat k n); intros Heq.
      (* Case: true *)
      right. apply beq_nat_true_iff in Heq. exact Heq.
      (* Case: false *)
      left. apply beq_nat_false_iff in Heq.
      apply nat_total_order in Heq. destruct Heq as [Heq | Heq].
        (* Case: k < n *)
        exact Heq.
        (* Case: k > n *)
        apply le_lt_trans with (n:=k) in Heq.
          contradict Heq. apply lt_irrefl.
          exact H.
  (* <= *)
    destruct H as [H | H].
      apply lt_S. exact H.
      rewrite H. constructor.
Qed.

Example test1: TPMultipleSmallsteps step0 step5.
Proof.
  unfold TPMultipleSmallsteps.
  exists (Cons step0 (Cons step1 (Cons step2 (Cons step3 (Cons step4 (Singleton step5)))))).
  intros Hfirst Hlast n idx Hn.
  clear Hfirst. clear Hlast. simpl in Hn.

  repeat ((try (apply lt_n_Sm_le in Hn; apply le_n_0_eq in Hn; symmetry in Hn)) || (try (apply less_nat_cases in Hn; destruct Hn as [Hn | H])));
  try rename H into Hn; rewrite Hn; simpl; repeat constructor.
  apply smallstep_appright with (idx := n).
  now apply TPAbstrIsValue.
  assert (H : TPSubst n (TPApp (TPApp TPMult (TPId ("x", 1%nat))) (TPId ("x", 1%nat))) (TPInt 5) ("x", 1%nat) = (TPApp (TPApp TPMult (TPInt 5)) (TPInt 5), n)).
  simpl; unfold TPApp; unfold TPMult; now reflexivity.
  rewrite <- H.
  apply smallstep_betav.
  now apply TPConstIsValue.
  apply smallstep_appright with (idx := n).
  now apply TPAbstrIsValue.
  apply smallstep_op.
Qed.

Lemma smallstep_consist : forall n n' e e', smallstep n e = (e', n') <-> TPMakesSmallstep n e (e', n').
Proof.
  intros n n' e e'.
  induction e.
  unfold smallstep.
Admitted.

End TPSmallSteps.


Require Import Coq.omega.Omega.
Require Import Coq.Lists.ListSet.
Require Import Coq.Lists.List.
Require Import Node.

(** STATE STRUCTURE AND PARAMETERS *)

Inductive Status : Type :=
  | Stabilizing : Status
  | Rectifying : Status.

Inductive adjacent {A} : A -> A -> list A -> Prop :=
  | adj_hd : forall (j k : A) (l : list A),
               head l = Some j ->
               head (tl l) = Some k ->
               adjacent j k l
  | adj_tl : forall (j k : A) (l : list A),
               head l <> None ->
               adjacent j k (tl l) ->
               adjacent j k l.

(* NetState *)
Record NetState : Type := mkNetState
  {
    members: set Node;
    succlength : nat;
    succ : Node -> list Node;
    prdc : Node -> Node;
    status : Node -> Status
  }.

(* Invariant *)
Definition WellFormedNetState (s : NetState) : Prop :=
  NoDup (members s) /\
  succlength s > 0 /\
  forall (n : Node), set_In n (members s) -> length (succ s n) = succlength s.

Definition LiveSuccCondition (s : NetState) : Prop :=
  forall (n : Node), set_In n (members s) ->
    Exists (fun m => set_In m (members s)) (succ s n).

Definition Principal (s : NetState) (p : Node) : Prop :=
  forall n, set_In n (members s) ->
    forall j k : Node, adjacent j k (n :: (succ s n)) ->
    ~ (between j p k).

Definition SufficientPrincipals (s : NetState) : Prop :=
  exists (principals : set Node),
    length principals >= succlength s + 1 /\
    NoDup principals /\
    (forall (p : Node), set_In p principals ->
      set_In p (members s) /\
      Principal s p).

Definition Invariant (s : NetState) : Prop :=
  WellFormedNetState s /\ LiveSuccCondition s /\ SufficientPrincipals s.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.

Require Import Zquot.

(* Why3 comment *)
(* div is replaced with (ZArith.BinInt.Z.quot x x1) by the coq driver *)

(* Why3 comment *)
(* mod1 is replaced with (ZArith.BinInt.Z.rem x x1) by the coq driver *)

(* Why3 goal *)
Lemma Div_mod :
forall (x:Z) (y:Z),
 (~ (y = 0%Z)) ->
 (x = ((y * (ZArith.BinInt.Z.quot x y))%Z + (ZArith.BinInt.Z.rem x y))%Z).
intros x y _.
apply Z.quot_rem'.
Qed.

(* Why3 goal *)
Lemma Div_bound :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
 ((0%Z <= (ZArith.BinInt.Z.quot x y))%Z
  /\ ((ZArith.BinInt.Z.quot x y) <= x)%Z).
intros x y (Hx,Hy).
split.
now apply Z.quot_pos.
destruct (Z_eq_dec y 1) as [H|H].
rewrite H, Z.quot_1_r.
apply Zle_refl.
destruct (Zle_lt_or_eq 0 x Hx) as [H'|H'].
apply Zlt_le_weak.
apply Z.quot_lt with (1 := H').
omega.
now rewrite <- H', Zquot_0_l.
Qed.

(* Why3 goal *)
Lemma Mod_bound :
forall (x:Z) (y:Z),
 (~ (y = 0%Z)) ->
 (((-(ZArith.BinInt.Z.abs y))%Z < (ZArith.BinInt.Z.rem x y))%Z
  /\ ((ZArith.BinInt.Z.rem x y) < (ZArith.BinInt.Z.abs y))%Z).
intros x y Zy.
destruct (Zle_or_lt 0 x) as [Hx|Hx].
refine ((fun H => conj (Zlt_le_trans _ 0 _ _ (proj1 H)) (proj2 H)) _).
clear -Zy ; zify ; omega.
now apply Zrem_lt_pos.
refine ((fun H => conj (proj1 H) (Zle_lt_trans _ 0 _ (proj2 H) _)) _).
clear -Zy ; zify ; omega.
apply Zrem_lt_neg with (2 := Zy).
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma Div_sign_pos :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (0%Z < y)%Z) -> (0%Z <= (ZArith.BinInt.Z.quot x y))%Z.
intros x y (Hx, Hy).
now apply Z.quot_pos.
Qed.

(* Why3 goal *)
Lemma Div_sign_neg :
forall (x:Z) (y:Z),
 ((x <= 0%Z)%Z /\ (0%Z < y)%Z) -> ((ZArith.BinInt.Z.quot x y) <= 0%Z)%Z.
intros x y (Hx, Hy).
generalize (Z.quot_pos (-x) y).
rewrite Zquot_opp_l.
omega.
Qed.

(* Why3 goal *)
Lemma Mod_sign_pos :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ ~ (y = 0%Z)) -> (0%Z <= (ZArith.BinInt.Z.rem x y))%Z.
intros x y (Hx, Zy).
now apply Zrem_lt_pos.
Qed.

(* Why3 goal *)
Lemma Mod_sign_neg :
forall (x:Z) (y:Z),
 ((x <= 0%Z)%Z /\ ~ (y = 0%Z)) -> ((ZArith.BinInt.Z.rem x y) <= 0%Z)%Z.
intros x y (Hx, Zy).
now apply Zrem_lt_neg.
Qed.

(* Why3 goal *)
Lemma Rounds_toward_zero :
forall (x:Z) (y:Z),
 (~ (y = 0%Z)) ->
 ((ZArith.BinInt.Z.abs ((ZArith.BinInt.Z.quot x y) * y)%Z) <= (ZArith.BinInt.Z.abs x))%Z.
intros x y Zy.
rewrite Zmult_comm.
zify.
generalize (Z.mul_quot_le x y).
generalize (Z.mul_quot_ge x y).
omega.
Qed.

(* Why3 goal *)
Lemma Div_1 :
forall (x:Z), ((ZArith.BinInt.Z.quot x 1%Z) = x).
exact Z.quot_1_r.
Qed.

(* Why3 goal *)
Lemma Mod_1 :
forall (x:Z), ((ZArith.BinInt.Z.rem x 1%Z) = 0%Z).
exact Z.rem_1_r.
Qed.

(* Why3 goal *)
Lemma Div_inf :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (x < y)%Z) -> ((ZArith.BinInt.Z.quot x y) = 0%Z).
exact Z.quot_small.
Qed.

(* Why3 goal *)
Lemma Mod_inf :
forall (x:Z) (y:Z),
 ((0%Z <= x)%Z /\ (x < y)%Z) -> ((ZArith.BinInt.Z.rem x y) = x).
exact Z.rem_small.
Qed.

(* Why3 goal *)
Lemma Div_mult :
forall (x:Z) (y:Z) (z:Z),
 ((0%Z < x)%Z /\ ((0%Z <= y)%Z /\ (0%Z <= z)%Z)) ->
 ((ZArith.BinInt.Z.quot ((x * y)%Z + z)%Z x) = (y + (ZArith.BinInt.Z.quot z x))%Z).
intros x y z (Hx&Hy&Hz).
rewrite (Zplus_comm y).
rewrite <- Z_quot_plus.
now rewrite Zplus_comm, Zmult_comm.
apply Zmult_le_0_compat with (2 := Hz).
apply Zplus_le_0_compat with (1 := Hz).
apply Zmult_le_0_compat with (1 := Hy).
now apply Zlt_le_weak.
intros H.
now rewrite H in Hx.
Qed.

(* Why3 goal *)
Lemma Mod_mult :
forall (x:Z) (y:Z) (z:Z),
 ((0%Z < x)%Z /\ ((0%Z <= y)%Z /\ (0%Z <= z)%Z)) ->
 ((ZArith.BinInt.Z.rem ((x * y)%Z + z)%Z x) = (ZArith.BinInt.Z.rem z x)).
intros x y z (Hx&Hy&Hz).
rewrite Zplus_comm, Zmult_comm.
apply Z_rem_plus.
apply Zmult_le_0_compat with (2 := Hz).
apply Zplus_le_0_compat with (1 := Hz).
apply Zmult_le_0_compat with (1 := Hy).
now apply Zlt_le_weak.
Qed.


(** Credit to Jasper Hugunin (jashug) for this module.
 *
 * MIT license, (c) Jasper Hugunin
 * Link: https://github.com/jashug/IWTypes/blob/master/Adjointification.v
 *)

(* Turn a pair of inverses into an adjoint equivalence *)
(* Proof follows the HoTT book *)
(* Mostly, just a lot of manipulation of equality proofs *)

(* Lemma 2.4.3 in HoTT book, specialized to g = id *)
Definition commute_homotopy_id {A} {f : A -> A}
  (f_id : forall a, f a = a) {x y : A} (p : x = y)
  : eq_trans (f_id x) p = eq_trans (f_equal f p) (f_id y)
  := match p in (_ = y)
     return eq_trans (f_id x) p = eq_trans (f_equal f p) (f_id y)
     with eq_refl => eq_sym (eq_trans_refl_l (f_id x)) end.

Section adjointify.
Context {A B} (f : A -> B) (g : B -> A).

Section g_adjoint.
Context
  (gf_id : forall a, g (f a) = a)
  (fg_id : forall b, f (g b) = b).

Definition f_adjoint_gives_g_adjoint_pointwise
  (b : B) (f_adjoint_at_gb : fg_id (f (g b)) = f_equal f (gf_id (g b)))
  : gf_id (g b) = f_equal g (fg_id b)
  := let precomposed_eq
      : eq_trans (f_equal (fun a => g (f a)) (f_equal g (fg_id b)))
         (gf_id (g b)) =
        eq_trans (f_equal g (f_equal (fun b => f (g b)) (fg_id b)))
          (f_equal g (fg_id b))
      := eq_trans
         (eq_sym (commute_homotopy_id gf_id (f_equal g (fg_id b))))
         (eq_rect (f_equal g (fg_id (f (g b)))) (fun p => eq_trans p _ = _)
          (eq_trans (eq_trans
           (eq_sym (eq_trans_map_distr g _ _))
           (f_equal (fun p => f_equal g p)
            (commute_homotopy_id fg_id (fg_id b))))
           (eq_trans_map_distr g _ _)) _
          (eq_trans (eq_trans
           (f_equal (fun p => f_equal g p) f_adjoint_at_gb)
           (f_equal_compose f g _))
           (eq_id_comm_r _ gf_id  (g b)))) in
     match fg_id b as p
     return
       forall p1 p2,
       eq_trans (f_equal _ (f_equal g p)) p1 =
       eq_trans (f_equal g (f_equal _ p)) p2 ->
       p1 = p2
     with eq_refl => fun p1 p2 eq =>
       eq_trans (eq_trans
         (eq_sym (eq_trans_refl_l _))
         eq)
         (eq_trans_refl_l _)
     end (gf_id (g b)) (f_equal g (fg_id b)) precomposed_eq.

Definition f_adjoint_gives_g_adjoint
  (f_adjoint : forall a, fg_id (f a) = f_equal f (gf_id a))
  (b : B) : gf_id (g b) = f_equal g (fg_id b)
  := f_adjoint_gives_g_adjoint_pointwise b (f_adjoint (g b)).
End g_adjoint.

Section correction.
Context
  (gf_id : forall a, g (f a) = a)
  (fg_id : forall b, f (g b) = b).

(* N.B.: The adjoint equivalence will use this instead of the given section. *)
Definition fg_id' b : f (g b) = b
  := eq_trans (eq_sym (fg_id (f (g b))))
     (eq_trans (f_equal f (gf_id (g b))) (fg_id b)).

Definition f_adjoint a : fg_id' (f a) = f_equal f (gf_id a)
  := let symmetric_eq
      : eq_trans (f_equal f (gf_id (g (f a)))) (fg_id (f a)) =
        eq_trans (fg_id (f (g (f a)))) (f_equal f (gf_id a))
      := eq_trans (eq_trans
         (f_equal (fun H => eq_trans (f_equal f H) (fg_id (f a)))
          (eq_sym (eq_id_comm_r _ gf_id a)))
         (f_equal (fun p => eq_trans p _)
          (eq_trans
           (f_equal_compose (fun a => g (f a)) f _)
           (eq_sym (f_equal_compose f (fun b => f (g b)) _)))))
         (eq_sym (commute_homotopy_id fg_id (f_equal f (gf_id a)))) in
     match fg_id (f (g (f a))) as p
     return forall p', _ = eq_trans p p' -> eq_trans (eq_sym p) _ = p'
     with eq_refl => fun p' eq =>
       eq_trans (eq_trans_refl_l _) (eq_trans eq (eq_trans_refl_l _))
     end _ symmetric_eq.

Definition g_adjoint
  : forall b, gf_id (g b) = f_equal g (fg_id' b)
  := f_adjoint_gives_g_adjoint gf_id fg_id' f_adjoint.

End correction.

End adjointify.


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path order bigop.
From favssr Require Import prelude.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section Selection.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys zs: seq T) (k : nat).

Definition kthOrd k xs v :=
  k < size xs ->
  (size [seq x <- xs | x < v ] <= k) &&
  (size [seq x <- xs | x > v ] <  size xs - k).

Definition selection (select : nat -> seq T -> T) :=
  forall k xs, kthOrd k xs (select k xs).

Lemma subseq_consr (s1 s2 : seq T) a :
  subseq s1 s2 -> subseq s1 (a :: s2).
Proof.
rewrite -{2}[s1]/([::] ++ s1) -[a :: s2]/([::a] ++ s2).
by apply cat_subseq.
Qed.

Lemma subset_filter_impl xs (p q : pred T) :
  (forall x, p x -> q x) ->
  subseq [seq x <- xs | p x] [seq x <- xs | q x].
Proof.
elim: xs => // a xs IH pi /=.
move: (pi a).
case pa: (p a).
  move => -> //=.
  rewrite eq_refl.
  by apply (IH pi).
case qa: (q a) => _.
  apply subseq_consr. by apply (IH pi).
by apply (IH pi).
Qed.

Lemma filter_size_neg_pred p q xs :
  (forall a, p a = ~~ (q a)) ->
  size [seq x <- xs | p x] + size [seq x <- xs | q x ] = size xs.
Proof.
elim: xs => // a sx IH Hpq //=.
move: (Hpq a).
case (q a) => /= ->.
  by rewrite addnS IH.
by rewrite addSn IH.
Qed.

Lemma leq_le_add (a b x y: nat) : (a <= x -> b < y -> a + b < x + y)%N.
Proof.
move => /subnKC <-.
rewrite -addnA (ltn_add2l a) => b_le_y.
by rewrite ltn_addl.
Qed.

Lemma kthOrd_unique k xs x y :
  k < size xs ->
  kthOrd k xs x ->
  kthOrd k xs y ->
  x = y.
Proof.
case heq: (x == y); move: heq => /eqP; first done.
wlog: x y / x < y.
- case: (ltgtP x y) => Hcmp H neq hk xk yk //.
  + by rewrite (H x y Hcmp _ hk xk yk).
  rewrite (H y x Hcmp _ hk yk xk) //.
  move => Hcontra; by apply neq.
move => y_le_x _ ksz Hx Hy.
move: (Hx ksz) (Hy ksz) => /andP [lex gtx] /andP [ley gty] {Hx Hy}.
have lex_subs_ley: subseq [seq x' <- xs | x' <= x] [seq x' <- xs | x' < y].
  apply subset_filter_impl => t tleqx.
  by apply (le_lt_trans tleqx y_le_x).
move: (size_subseq lex_subs_ley).
rewrite -(leq_add2r (size [seq x0 <- xs | x < x0])).
have sizexs_eq: size [seq x' <- xs | x' <= x] + size [seq x0 <- xs | x < x0] = size xs.
  apply filter_size_neg_pred.
  move => a.
  by apply (leNgt a x).
rewrite sizexs_eq.
have sizexs_le: size [seq x <- xs | x < y] + size [seq x0 <- xs | x < x0] < k + (size xs - k).
  by apply leq_le_add; [apply ley | apply gtx].
have sizexs_le_eq: k + (size xs - k) = size xs.
  by rewrite addnC subnK //; apply (ltW ksz).
rewrite {}sizexs_le_eq in sizexs_le.
move => sizexs_leq.
have contra: size xs < size xs.
  by apply (@le_lt_trans _ _ _ (size xs) _ sizexs_leq sizexs_le).
by rewrite ltxx in contra.
Qed.

End Selection.


(** Instance for building logics by translating them to
 ** other logics.
 **)
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Tactics.Tactics.

Section from_iso.
  Context {T U : Type} (f : T -> U) (g : U -> T) (ilo : ILogicOps T).

  Instance ILogicOps_iso : ILogicOps U :=
  {| lentails := fun l r => lentails (g l) (g r)
   ; ltrue := f ltrue
   ; lfalse := f lfalse
   ; land := fun l r => f (land (g l) (g r))
   ; lor := fun l r => f (lor (g l) (g r))
   ; limpl := fun l r => f (limpl (g l) (g r))
   ; lforall := fun T P => f (lforall (fun x => g (P x)))
   ; lexists := fun T P => f (lexists (fun x => g (P x)))
   |}.

  Context {il : ILogic T}.
  Hypothesis gf : forall x, g (f x) -|- x.

  Instance ILogic_iso : ILogic U.
  Proof.
    constructor; simpl; intros; repeat rewrite gf in *.
    { constructor.
      { red; simpl; intros; reflexivity. }
      { red; simpl; intros. etransitivity; eassumption. } }
    all: try charge_tauto.
    apply lfalseL.
    eapply lforallL; eauto.
    eapply lforallR; eauto.
    eapply lexistsL; eauto.
    eapply lexistsR; eauto.
    apply lorL; eauto.
  Defined.
End from_iso.
Arguments ILogicOps_iso {_ _} _ _ {_}.
Arguments ILogic_iso {_ _} [_ _ _] {_} _.

Hint Extern 10 (@ILogic _ _) =>
  (eapply ILogic_iso ;
     [ eauto with typeclass_instances
     | intro; eapply RelationClasses.PreOrder_Reflexive ]) : typeclass_instances.


Require Import BinNat.

From Proyecto Require Export Defs_Trie.
From Proyecto Require Export Props_Misc.

(* Teorema: Podemos construir con trie1 o con smartTrie1 sin afectar lookup1 *)
Theorem lookup_cons_indep1: forall (t1 t2: binTrie1) (k: N),
lookup1 k (trie1 t1 t2) = lookup1 k (smartTrie1 t1 t2).
Proof.
intros.
destruct t1, t2; simpl; trivial.
apply obvious_if.
Qed.

(* Mismos teoremas para trie2 y trie3 *)

Theorem lookup_cons_indep2: forall (t1 t2: binTrie2) (k: N),
lookup2 k (trie2 t1 t2) = lookup2 k (smartTrie2 t1 t2).
Proof.
intros.
destruct t1 eqn:T1; destruct t2 eqn:T2; simpl; trivial.
+ apply obvious_if.
+ Admitted.


Require Export Lambda.PTS.Sub Coq.Classes.RelationClasses Setoid.

Open Scope term_scope.

Reserved Notation "x '⟶' y" (no associativity, at level 80).

Inductive br {S : Set} : term S -> term S -> Prop :=
| br_sub A B C :
  (λ A ⇒ B) ⋅ C ⟶ B [[ C ]]
| br_app_l A A' B :
  A ⟶ A' ->
  A ⋅ B ⟶ A' ⋅ B
| br_app_r A B B' :
  B ⟶ B' ->
  A ⋅ B ⟶ A ⋅ B'
| br_abs_l A A' B :
  A ⟶ A' ->
  λ A ⇒ B ⟶ λ A' ⇒ B
| br_abs_r A B B' :
  B ⟶ B' ->
  λ A ⇒ B ⟶ λ A ⇒ B'
| br_pi_l A A' B :
  A ⟶ A' ->
  ∏ A `, B ⟶ ∏ A' `, B
| br_pi_r A B B' :
  B ⟶ B' ->
  ∏ A `, B ⟶ ∏ A `, B'
where "x '⟶' y" := (br x y) : type_scope.

(** Reflexive-transitive closure. *)
Reserved Notation "A '⟶*' B" (at level 80, no associativity).

Inductive br_rt {sorts : Set} : term sorts -> term sorts -> Prop :=
| br_rt_refl A :
  A ⟶* A
| br_rt_trans A B C :
  A ⟶ B -> B ⟶* C -> A ⟶* C
where "A '⟶*' B" := (br_rt A B) : type_scope.

(** Reflexive-symmetric-transitive closure. *)
Reserved Notation "A '=β' B" (at level 80, no associativity).

Inductive br_rst {sorts : Set} : term sorts -> term sorts -> Prop :=
| br_br A B :
  A ⟶ B -> A =β B
| br_refl A :
  A =β A
| br_sym A B :
  A =β B -> B =β A
| br_trans A B C :
  A =β B -> B =β C -> A =β C
where "A '=β' B" := (br_rst A B) : type_scope.

Section Congruence.
  Context {sorts : Set}.

  Local Hint Constructors br : core.

  Lemma br_subs_context : forall (A B : term sorts) σ,
      A ⟶ B -> subs σ A ⟶ subs σ B.
  Proof.
    intros A B σ h; generalize dependent σ;
      induction h; intro σ; simpl; auto.
    rewrite subs_sub_distr; auto.
  Qed.

  Lemma br_sub_context : forall A B C : term sorts,
      A ⟶ B -> A [[ C ]] ⟶ B [[ C ]].
  Proof.
    eauto using br_subs_context.
  Qed.

  Local Hint Constructors br_rt : core.

  Lemma br_br_rt : forall A B : term sorts, A ⟶ B -> A ⟶* B.
  Proof.
    intros A B h; eauto.
  Qed.

  Lemma br_rt_transitve : forall A B C : term sorts,
      A ⟶* B -> B ⟶* C -> A ⟶* C.
  Proof.
    intros A B C hab; generalize dependent C;
      induction hab; intros C' hbc; auto.
    eapply br_rt_trans; eauto.
  Qed.

  Lemma br_rt_app_cong_l : forall A B C : term sorts,
      A ⟶* B -> A ⋅ C ⟶* B ⋅ C.
  Proof.
    intros A B C h; generalize dependent C;
      induction h; eauto.
  Qed.

  Lemma br_rt_app_cong_r : forall A B C : term sorts,
      B ⟶* C -> A ⋅ B ⟶* A ⋅ C.
  Proof.
    intros A B C h; generalize dependent A;
      induction h; eauto.
  Qed.

  Local Hint Resolve br_rt_transitve : core.
  Local Hint Resolve br_rt_app_cong_l : core.
  Local Hint Resolve br_rt_app_cong_r : core.

  Lemma br_rt_app_cong : forall A B C D : term sorts,
      A ⟶* B -> C ⟶* D -> A ⋅ C ⟶* B ⋅ D.
  Proof. eauto. Qed.

  Lemma br_rt_abs_cong_l : forall A B C : term sorts,
      A ⟶* B -> λ A ⇒ C ⟶* λ B ⇒ C.
  Proof.
    intros A B C h; generalize dependent C; induction h; eauto.
  Qed.

  Lemma br_rt_abs_cong_r : forall A B C : term sorts,
      B ⟶* C -> λ A ⇒ B ⟶* λ A ⇒ C.
  Proof.
    intros A B C h; generalize dependent A; induction h; eauto.
  Qed.

  Local Hint Resolve br_rt_abs_cong_l : core.
  Local Hint Resolve br_rt_abs_cong_r : core.

  Lemma br_rt_abs_cong : forall A B C D : term sorts,
      A ⟶* B -> C ⟶* D -> λ A ⇒ C ⟶* λ B ⇒ D.
  Proof. eauto. Qed.

  Lemma br_rt_pi_cong_l : forall A B C : term sorts,
      A ⟶* B -> ∏ A `, C ⟶* ∏ B `, C.
  Proof.
    intros A B C h; generalize dependent C; induction h; eauto.
  Qed.

  Lemma br_rt_pi_cong_r : forall A B C : term sorts,
      B ⟶* C -> ∏ A `, B ⟶* ∏ A `, C.
  Proof.
    intros A B C h; generalize dependent A; induction h; eauto.
  Qed.

  Local Hint Resolve br_rt_pi_cong_l : core.
  Local Hint Resolve br_rt_pi_cong_r : core.

  Lemma br_rt_pi_cong : forall A B C D : term sorts,
      A ⟶* B -> C ⟶* D -> ∏ A `, C ⟶* ∏ B `, D.
  Proof. eauto. Qed.

  Local Hint Resolve br_rt_app_cong : core.
  Local Hint Resolve br_rt_abs_cong : core.
  Local Hint Resolve br_rt_pi_cong : core.
  Local Hint Resolve br_br_rt : core.

  Lemma br_mapply_rename : forall (A B : term sorts) m ρ,
      A ⟶ B -> mapply m (Rename ρ) A ⟶  mapply m (Rename ρ) B.
  Proof.
    intros A B m ρ h; generalize dependent ρ;
      generalize dependent m; induction h;
      intros m ρ.
    - rewrite mapply_Rename_app,
        mapply_Rename_abs, mapply_Rename_sub_distr; auto.
    - do 2 rewrite mapply_Rename_app; auto.
    - do 2 rewrite mapply_Rename_app; auto.
    - do 2 rewrite mapply_Rename_abs; auto.
    - do 2 rewrite mapply_Rename_abs; auto.
    - do 2 rewrite mapply_Rename_pi; auto.
    - do 2 rewrite mapply_Rename_pi; auto.
  Qed.

  Lemma br_mapply_rename_mapply_sub_helper : forall m n x (A B : term sorts),
      A ⟶ B ->
      mapply n (Rename S) (mapply m exts (sub_helper A) x)
             ⟶* mapply n (Rename S) (mapply m exts (sub_helper B) x).
  Proof.
    intro m; induction m as [| m ih];
      intros n [| x] A B h; cbn; unfold "$"; auto.
    - auto using br_mapply_rename.
    - pose proof ih (S n) x _ _ h as H; cbn in H.
      do 2 rewrite mapply_comm; assumption.
  Qed.

  Lemma br_mapply_sub_helper : forall x m (A B : term sorts),
      A ⟶ B ->
      mapply m exts (sub_helper A) x
             ⟶* mapply m exts (sub_helper B) x.
  Proof.
    intro x; induction x as [| x ih];
      intros [| m] A B h; cbn; unfold "$"; auto.
    pose proof br_mapply_rename_mapply_sub_helper m 1 x _ _ h;
      cbn in *; assumption.
  Qed.

  Lemma br_subs_substitute : forall (A B C : term sorts) m,
      A ⟶ B ->
      subs (mapply m exts (sub_helper A)) C
           ⟶* subs (mapply m exts (sub_helper B)) C.
  Proof.
    intros A B C; generalize dependent B;
      generalize dependent A;
      induction C as
      [s | x | C₁ ihC₁ C₂ ihC₂
      | C₁ ihC₁ C₂ ihC₂ | C₁ ihC₁ C₂ ihC₂];
      intros A B m h; cbn; eauto using br_mapply_sub_helper.
    - apply br_rt_abs_cong; eauto.
      specialize ihC₂ with A B (S m); cbn in ihC₂; auto.
    - apply br_rt_pi_cong; eauto.
      specialize ihC₂ with A B (S m); cbn in ihC₂; auto.
  Qed.

  Lemma br_sub_substitute : forall A B C : term sorts,
      A ⟶ B -> C [[ A ]] ⟶* C [[ B ]].
  Proof.
    intros A B C h; unfold "_ [[ _ ]]".
    pose proof br_subs_substitute A B C 0 h as H;
      cbn in H; assumption.
  Qed.

  Local Hint Constructors br_rst : core.

  Lemma br_rt_rst : forall A B : term sorts,
      A ⟶* B -> A =β B.
  Proof.
    intros A B h; induction h; eauto.
  Qed.

  Lemma br_rst_app_cong_l : forall A₁ A₂ B : term sorts,
      A₁ =β A₂ -> A₁ ⋅ B =β A₂ ⋅ B.
  Proof.
    intros A₁ A₂ B h; generalize dependent B;
      induction h; eauto.
  Qed.

  Lemma br_rst_app_cong_r : forall A B₁ B₂ : term sorts,
      B₁ =β B₂ -> A ⋅ B₁ =β A ⋅ B₂.
  Proof.
    intros A B₁ B₂ h; generalize dependent A;
      induction h; eauto.
  Qed.

  Local Hint Resolve br_rst_app_cong_l : core.
  Local Hint Resolve br_rst_app_cong_r : core.

  Lemma br_rst_app_cong : forall A₁ A₂ B₁ B₂ : term sorts,
      A₁ =β A₂ -> B₁ =β B₂ -> A₁ ⋅ B₁ =β A₂ ⋅ B₂.
  Proof. eauto. Qed.

  Lemma br_rst_abs_cong_l : forall A B C : term sorts,
      A =β B -> λ A ⇒ C =β λ B ⇒ C.
  Proof.
    intros A B C h; generalize dependent C; induction h; eauto.
  Qed.

  Lemma br_rst_abs_cong_r : forall A B C : term sorts,
      B =β C -> λ A ⇒ B =β λ A ⇒ C.
  Proof.
    intros A B C h; generalize dependent A; induction h; eauto.
  Qed.

  Local Hint Resolve br_rst_abs_cong_l : core.
  Local Hint Resolve br_rst_abs_cong_r : core.

  Lemma br_rst_abs_cong : forall A B C D : term sorts,
      A =β B -> C =β D -> λ A ⇒ C =β λ B ⇒ D.
  Proof. eauto. Qed.

  Lemma br_rst_pi_cong_l : forall A B C : term sorts,
      A =β B -> ∏ A `, C =β ∏ B `, C.
  Proof.
    intros A B C h; generalize dependent C; induction h; eauto.
  Qed.

  Lemma br_rst_pi_cong_r : forall A B C : term sorts,
      B =β C -> ∏ A `, B =β ∏ A `, C.
  Proof.
    intros A B C h; generalize dependent A; induction h; eauto.
  Qed.

  Local Hint Resolve br_rst_pi_cong_l : core.
  Local Hint Resolve br_rst_pi_cong_r : core.

  Lemma br_rst_pi_cong : forall A B C D : term sorts,
      A =β B -> C =β D -> ∏ A `, C =β ∏ B `, D.
  Proof. eauto. Qed.

  Lemma br_rst_reflexive : Reflexive (@br_rst sorts).
  Proof. auto. Qed.

  Lemma br_rst_symmetric : Symmetric (@br_rst sorts).
  Proof. auto. Qed.

  Lemma br_rst_transitive : Transitive (@br_rst sorts).
  Proof. eauto. Qed.
End Congruence.

Add Parametric Relation sorts
  : (term sorts)
      (@br_rst sorts)
    reflexivity proved by br_rst_reflexive
    symmetry proved by br_rst_symmetric
    transitivity proved by br_rst_transitive as br_rst_eq.

Add Parametric Morphism sorts : (@app sorts)
    with signature @br_rst sorts ==>  @br_rst sorts ==>  @br_rst sorts as app_mor.
Proof. auto using br_rst_app_cong. Qed.

Add Parametric Morphism sorts : (@abs sorts)
    with signature @br_rst sorts ==>  @br_rst sorts ==>  @br_rst sorts as abs_mor.
Proof. auto using br_rst_abs_cong. Qed.

Add Parametric Morphism sorts : (@pi sorts)
    with signature @br_rst sorts ==>  @br_rst sorts ==>  @br_rst sorts as pi_mor.
Proof. auto using br_rst_pi_cong. Qed.


Require Export prosa.model.task.sequentiality.

Section ExecutionOrder.

  (** Consider any type of job associated with any type of tasks... *)
  Context {Job: JobType}.
  Context {Task: TaskType}.
  Context `{JobTask Job Task}.

  (** ... with arrival times and costs ... *)
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** ... and any kind of processor state model. *)
  Context {PState: Type}.
  Context `{ProcessorState Job PState}.

  (** Assume a schedule ... *)
  Variable sched: schedule PState.

  (** in which the sequential tasks hypothesis holds. *)
  Hypothesis H_sequential_tasks: sequential_tasks sched.

  (** A simple corollary of this hypothesis is that the scheduler
      executes a job with the earliest arrival time. *)
  Corollary scheduler_executes_job_with_earliest_arrival:
    forall j1 j2 t,
      same_task j1 j2 ->
      ~~ completed_by sched j2 t ->
      scheduled_at sched j1 t ->
      job_arrival j1 <= job_arrival j2.
  Proof.
    intros ? ? t TSK NCOMPL SCHED.
    rewrite /same_task eq_sym in TSK.
    have SEQ := H_sequential_tasks j2 j1 t TSK.
    rewrite leqNgt; apply/negP; intros ARR.
    move: NCOMPL => /negP NCOMPL; apply: NCOMPL.
      by apply SEQ.
  Qed.

End ExecutionOrder.


Require Import Coq.Lists.List.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.micromega.Psatz.
Require Export Coq.ZArith.ZArith.
Require Export Coq.Strings.String.
Require Export Coq.Logic.Classical.
Require Import Permutation.
Require Import ListDec.
Require Import FL.Mobius_Definition.
Require Import FL.Mobius_Lemmas.
Require Import FL.Mobius_Lemma2.
Require Import FL.Mobius_Lemma3.

Section Fast_Zeta_Mobius_Transforms.

Import Def.
Import Lemmas.
Import Lemma2.
Import Lemma3.

(*关键定义*)
Print Zeta.
Locate Zeta.
Print Mobius.
Locate Mobius.

(*关键引理*)
Check Constraint_in.
Locate Constraint_in.
Check Exchange_Summ.
Locate Exchange_Summ.
Check Binomial_inner_constraint_new.
Locate Binomial_inner_constraint_new.
Check Binomial_minusone.
Locate Binomial_minusone.

(* Theorem 10.11 f(X) = (mu zeta f) (X) = (zeta mu f) (X) *)
Theorem Inversion_formula: forall (f: (list nat) -> Z) (X: list nat),
  NoDup X ->
  Zeta (Mobius f) X = f X /\ Mobius (Zeta f) X = f X.
Proof.
  split; intros.
  + unfold Mobius, Zeta.
    rewrite Summ_f_g with (g := (fun X0 : list nat => Summ_Of_List (list nat)
                          (f_x_test_in (Mu f (Datatypes.length X0)) (PowerSet X0)) (PowerSet X))).
    2:
    {
      intros.
      apply Constraint_in.
      apply H.
      apply H0.
    }
    rewrite Exchange_Summ with (g := fun (z y: list nat) => f_x_test_in (Mu f (Datatypes.length y))
                               (PowerSet y) z); [ | reflexivity ].
    unfold f_x_test_in, Mu.
    erewrite Summ_f_g.
    2:
    {
      intros.
      assert (forall y: list nat, In y (PowerSet X) ->
                        (MinusOnePower (Datatypes.length y - Datatypes.length x) * f x * test_in_list_Z x (PowerSet y))%Z =
                        (MinusOnePower (Datatypes.length y + Datatypes.length x) * f x * test_in_list_Z x (PowerSet y))%Z).
      {
        intros.
        unfold test_in_list_Z.
        destruct (test_in_list x (PowerSet y));[|lia].
        rewrite MinusOnePower_Minus_to_Add; [reflexivity | apply Subset_length].
        ** eapply PowerSet_Element_NoDup; [apply H | apply H1].
        ** eapply PowerSet_Element_NoDup; [eapply PowerSet_Element_NoDup; [apply H | apply H1 ] | apply i].
        ** apply PowerSet_Subset, i.
      }
      apply Summ_f_g.
      apply H1.
    }
    erewrite Summ_f_g.
    2:
    {
      intros.
      apply Summ_f_g; intros.
      rewrite <- MinusOnePower_Add.
      reflexivity.
    }
    erewrite Summ_f_g.
    2:
    {
      intros.
      assert (forall l: list (list nat), (Summ_Of_List (list nat)
              (fun x0 : list nat =>
              (MinusOnePower (Datatypes.length x0) * MinusOnePower (Datatypes.length x) * f x *
              test_in_list_Z x (PowerSet x0))%Z) l) =
              Z.mul (Z.mul (MinusOnePower (Datatypes.length x)) (f x)) (Summ_Of_List (list nat)
                    (fun x0 : list nat => (MinusOnePower (Datatypes.length x0) * test_in_list_Z x (PowerSet x0))%Z) l)).
      {
        intros.
        induction l.
        - simpl. lia.
        - simpl.
          rewrite IHl.
          lia.
      }
      rewrite H1.
      reflexivity.
    }
    rewrite Summ_f_g with (g := fun x: list nat => Z.mul (f x) (test_list_eq_Z x X)).
    apply Summ_test_eq, H.
    intros.
    rewrite Binomial_inner_constraint_new; [ | tauto | tauto].
    unfold test_list_eq_Z.
    destruct (test_list_eq x X).
    - apply Eq_Subset_Empty in e.
      rewrite e.
      simpl.
      assert (forall a b c:Z, Z.mul (Z.mul a b) c = Z.mul (Z.mul a c) b). { lia. }
      rewrite H1.
      rewrite Z.mul_assoc.
      rewrite MinusOnePower_Add, MinusOnePower_Double; lia.
    - pose proof Binomial_minusone(MinusSet X x).
      destruct H1.
      pose proof PowerSet_Element_NoDup X x H H0.
      pose proof inpowerset_subseq_eq x X.
      apply H4 in H0 as H5.
      pose proof Not_Eq_Subseq x X H H3 H5 n.
      destruct H6 as [x0 [? ?]].
      assert (In x0 (MinusSet X x)).
      {
        unfold MinusSet. apply filter_In.
        split; [tauto | unfold Test_In].
        destruct (test_in x0 x); [tauto | tauto].
      }
      assert (MinusSet X x <> []).
      {
        destruct (classic (MinusSet X x = [] ));[|tauto].
        rewrite H9 in H8. apply in_nil in H8; tauto.
      }
      apply H2 in H9.
      unfold MinusOnetoLen in H9.
      lia.
  + unfold Mobius, Zeta, Mu.
    rewrite Summ_f_g with (g := fun X0: list nat => Summ_Of_List (list nat)
                          (fun x: list nat => Z.mul (MinusOnePower (Datatypes.length X + Datatypes.length X0)) (f x))
                          (PowerSet X0)).
    2:
    {
      intros.
      rewrite <- Out_coef.
      erewrite Summ_f_g; [reflexivity | intros].
      simpl.
      rewrite MinusOnePower_Minus_to_Add; [reflexivity | ].
      apply Subset_length; [tauto | eapply PowerSet_Element_NoDup; [apply H | tauto] | apply PowerSet_Subset; tauto].
    }
    rewrite Summ_f_g with (g:= fun X0: list nat => Summ_Of_List (list nat)
                                      (fun x: list nat => Z.mul
                                      (Z.mul (MinusOnePower (Datatypes.length X + Datatypes.length X0)) (f x))
                                      (test_in_list_Z x (PowerSet X0))) (PowerSet X)).
    2:
    {
      intros.
      assert (NoDup (PowerSet X)). { apply PowerSet_NoDup; tauto. }
      assert (NoDup (PowerSet x)). { apply PowerSet_NoDup. eapply PowerSet_Element_NoDup; [apply H | tauto]. }
      assert (Subset _ (PowerSet x) (PowerSet X)). { apply Subset_PowerSet; [tauto | eapply PowerSet_Element_NoDup; [apply H | tauto] | tauto]. }
      pose proof Summ_constraint_X_Y (PowerSet X) (PowerSet x) ((fun x0 : list nat =>
   (MinusOnePower (Datatypes.length X + Datatypes.length x) * f x0)%Z)) H1 H2 H3.
      rewrite H4.
      unfold f_x_test_in; reflexivity.
    }
    rewrite Exchange_Summ with (g:= fun (z y: list nat) => Z.mul (Z.mul (MinusOnePower (Datatypes.length X + Datatypes.length y)) (f z)) (test_in_list_Z z (PowerSet y))); [ | reflexivity].
    erewrite Summ_f_g.
    2:
    {
      intros.
      erewrite Summ_f_g.
      2:
      {
        intros.
        rewrite <- MinusOnePower_Add.
        assert (forall a b c d: Z, Z.mul (Z.mul (Z.mul a b) c) d = Z.mul (Z.mul a c) (Z.mul b d)). { lia. }
        rewrite H2; reflexivity.
      }
      pose proof Out_coef (list nat) (PowerSet X) (fun x0: list nat => Z.mul (MinusOnePower (Datatypes.length x0)) (test_in_list_Z x (PowerSet x0))) (Z.mul (MinusOnePower (Datatypes.length X)) (f x)).
      rewrite H1; reflexivity.
    }
    rewrite Summ_f_g with (g:= fun x: list nat => Z.mul (f x) (test_list_eq_Z x X)).
    apply Summ_test_eq, H.
    intros.
    rewrite Binomial_inner_constraint_new; [ | tauto | tauto].
    unfold test_list_eq_Z.
    destruct (test_list_eq x X).
    - apply Eq_Subset_Empty in e as H1.
      rewrite H1, e.
      simpl.
      assert (forall a b c d:Z, Z.mul (Z.mul a b) (Z.mul c d) = Z.mul (Z.mul (Z.mul a c) b) d). { lia. }
      rewrite H2, MinusOnePower_Add, MinusOnePower_Double; lia.
    - pose proof Binomial_minusone(MinusSet X x).
      destruct H1.
      pose proof PowerSet_Element_NoDup X x H H0.
      pose proof inpowerset_subseq_eq x X.
      apply H4 in H0 as H5.
      pose proof Not_Eq_Subseq x X H H3 H5 n.
      destruct H6 as [x0 [? ?]].
      assert (In x0 (MinusSet X x)).
      { unfold MinusSet. apply filter_In.
        split; [tauto | unfold Test_In].
        destruct (test_in x0 x); [tauto | tauto]. }
      assert (MinusSet X x <> []).
      { destruct (classic (MinusSet X x = [] )).
        * rewrite H9 in H8.
          apply in_nil in H8; tauto.
        * tauto. }
      apply H2 in H9.
      unfold MinusOnetoLen in H9.
      rewrite H9.
      lia.
Qed.

(*关键定义*)
Print Cover_Product_new.
Locate Cover_Product_new.
(*关键引理*)
Check Summ_Test_Union_Eq.
Locate Summ_Test_Union_Eq.

(* Theorem 10.13 The zeta transform of the cover product is the pointwise product of the zeta-transformed arguments, zeta (f *c g) = (zeta f) * (zeta g) *)
(* Cover_Product_new 的第一个参数是全集(求和的枚举范围), 特别地, 计算 (f *c g) (X) 时，传入的全集是 PowerSet X *)
Theorem BreakUpLemma: forall (f g: list nat -> Z) (Y: list nat),
  NoDup Y ->
  Zeta (Cover_Product_new (PowerSet Y) f g) Y = Z.mul (Zeta f Y) (Zeta g Y).
Proof.
  intros.
  unfold Zeta, Cover_Product_new.
  erewrite Exchange_Summ; [ | reflexivity].
  erewrite Summ_f_g.
  2:{
    intros.
    erewrite Exchange_Summ; [ | reflexivity].
    erewrite Summ_f_g.
    2:{
      intros.
      rewrite Out_coef.
      rewrite Summ_Test_Union_Eq; [ |tauto |tauto |tauto ].
      rewrite Z.mul_1_r.
      reflexivity.
    }
    rewrite Out_coef.
    rewrite Z.mul_comm.
    reflexivity.
  }
  rewrite Out_coef.
  lia.
Qed.

(*关键定义*)
Print Convolution_new.
Locate Convolution_new.
Print Check_i.
Locate Check_i.

(*关键引理*)
Check Add_sum_one.
Locate Add_sum_one.
Check Union_Length_Empty.
Locate Union_Length_Empty.

(* Theorem 10.15 Fast subset convolution *)
(* f_k(S) := f(S) * [|S| = k].
   (f * g) (X) = summ (i from |X| to 0) ((fi *c g(|X|-i)) X) *)
Theorem Fast_Subset_Convolution: forall (f g: list nat -> Z) (X: list nat) (N: nat),
  NoDup X ->
  N = (Datatypes.length X) ->
  Convolution_new (PowerSet X) f g X =
  Summ_Of_List
    (nat)
    (fun i:nat => Cover_Product_new (PowerSet X) (Check_i i f) (Check_i (N-i) g) X)
    (nat_list N).
Proof.
  intros.
  unfold Convolution_new.
  erewrite Summ_f_g.
  2:{
    intros.
    erewrite Summ_f_g.
    2:{
      intros.
      assert (forall a:Z, a = Z.mul a 1%Z). { lia. }
      rewrite H3 at 1.
      assert (Datatypes.length x <= N).
      {
        rewrite H0.
        apply Subset_length; [tauto |eapply PowerSet_Element_NoDup; [apply H | apply H1] | ].
        apply PowerSet_Subset; tauto.
      }
      pose proof Add_sum_one N (Datatypes.length x) H4.
      rewrite <- H5.
      rewrite Summ_to_0_eq_Summ_list.
      rewrite <- Out_coef.
      erewrite Summ_f_g.
      2:{
        intros.
        assert (Z.mul (Z.mul (test_eq_union_Z x x0 X) (test_empty_intersect_Z x x0))
 (Nat_eq_Z (Datatypes.length x) x1) = Z.mul (Z.mul (test_eq_union_Z x x0 X) (Nat_eq_Z (Datatypes.length x) x1)) (Nat_eq_Z (Datatypes.length x0) (N-x1))).
        {
          unfold test_eq_union_Z.
          destruct (test_eq_union x x0 X); [ | lia].
          unfold test_empty_intersect_Z.
          assert (NoDup x). { eapply PowerSet_Element_NoDup. apply H. tauto. }
          assert (NoDup x0). { eapply PowerSet_Element_NoDup. apply H. tauto. }
          pose proof Union_Length_Empty _ _ _ H7 H8 H e.
          destruct (test_empty_intersect x x0).
          - apply H9 in e0.
            unfold Nat_eq_Z.
            destruct (test_eq_nat (Datatypes.length x) x1); [ | lia].
            destruct (test_eq_nat (Datatypes.length x0) (N - x1)); [lia | ].
            rewrite <- H0 in e0.
            rewrite e1 in e0.
            lia.
          - unfold Nat_eq_Z.
            destruct (test_eq_nat (Datatypes.length x) x1); [ | lia].
            destruct (test_eq_nat (Datatypes.length x0) (N - x1)); [ | lia].
            assert (Datatypes.length x + Datatypes.length x0 = Datatypes.length X).
            {
              lia.
            }
            apply H9 in H10.
            tauto.
        }
        assert (forall a b c d e: Z, Z.mul (Z.mul (Z.mul (Z.mul a b) c) d) e = Z.mul (Z.mul a b) (Z.mul (Z.mul c d) e)). { lia. }
        rewrite H8, H7.
        assert (forall a b c d e: Z, Z.mul (Z.mul a b) (Z.mul (Z.mul c d) e) = Z.mul (Z.mul (Z.mul a d) (Z.mul b e)) c). { lia. }
        rewrite H9.
        reflexivity.
      }
      reflexivity.
    }
    erewrite Exchange_Summ2; [ | reflexivity].
    simpl.
    reflexivity.
  }
  erewrite Exchange_Summ2; [ | reflexivity].
  simpl.
  unfold Cover_Product_new, Check_i.
  reflexivity.
Qed.

(* 关键定义 *)
Print Zeta_j.
Locate Zeta_j.

(* 引理 该部分主要是不断地 destruct 因此除了可判性之外不涉及其他重要的引理 *)
Check test_check_j.
Locate test_check_j.

(* Fast Zeta/Mobius transform half_0 证明了递推式的其中一种情况 (xj = 0) (对应于 ~ In j X) *)
Theorem Fast_Mobius_Transform_0: forall (j n:nat) (X: list nat) (f: list nat -> Z),
In X (PowerSet (list_n_1 n)) -> (0 < j) -> (j <= n) -> ~ In j X ->
Zeta_j j f X = Zeta_j (j-1) f X.
Proof.
  unfold Zeta_j; intros.
  apply Summ_f_g; intros.
  unfold test_check_j_Z.
  destruct (test_check_j j x X); destruct (test_check_j (j-1) x X); [lia| | | lia].
  - assert (forall n: nat, j - 1 < n -> In n x <-> In n X).
    {
      intros.
      destruct (classic (j = n1)).
      * subst.
        split; [ | tauto].
        apply subseq_in, inpowerset_subseq_eq; tauto.
      * assert (j < n1). { lia. }
        apply i in H6; tauto.
    }
    tauto.
  - assert (forall n: nat, j < n -> In n x <-> In n X).
    {
      intros.
      assert (j - 1 < n1). { lia. }
      apply i in H5; tauto.
    }
    tauto.
Qed.

(* Fast Zeta/Mobius transform half_1 证明了递推式的其中一种情况 (xj = 1) (对应于 In j X) *)
Theorem Fast_Mobius_Transform_1: forall (j n:nat) (X: list nat) (f: list nat -> Z),
In X (PowerSet (list_n_1 n)) -> (0 < j) -> (j <= n) -> In j X ->
  Zeta_j j f X =
  Z.add
  (Zeta_j (j-1) f X)
  (Zeta_j (j-1) f (filter (fun n0:nat => negb (Nat_eq_b j n0)) X)).
Proof.
  unfold Zeta_j; intros.
  pose proof Summ_constraint_X_Y.
  assert (NoDup X). { eapply PowerSet_Element_NoDup; [ | apply H]. apply NoDup_list_n_1. }
  assert (NoDup (PowerSet X)). { apply PowerSet_NoDup. tauto. }
  assert (In (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X) (PowerSet X)).
  { apply inpowerset_subseq_eq. apply filter_subseq. }
  assert (NoDup (PowerSet (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X))).
  {
    apply PowerSet_NoDup.
    eapply PowerSet_Element_NoDup; [ | ].
    2:{ apply inpowerset_subseq_eq. apply filter_subseq. }
    tauto.
  }
  assert (Subset (list nat) (PowerSet (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X)) (PowerSet X)).
  {
    eapply Subset_PowerSet; [tauto | | tauto].
    eapply subseq_NoDup; [ | apply H4].
    apply filter_subseq.
  }
  pose proof H3 (PowerSet X) _ (fun x : list nat =>
    Z.mul (f x) (test_check_j_Z (j - 1) x (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X))) H5 H7 H8.
  rewrite H9.
  clear H9 H3.
  rewrite Summ_f_plus_g.
  unfold f_x_test_in; simpl.
  erewrite Summ_f_g; [reflexivity | intros; simpl].
  assert (test_check_j_Z j x X = Z.add (test_check_j_Z (j-1) x X) (Z.mul (test_check_j_Z (j - 1) x (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X)) (test_in_list_Z x
   (PowerSet (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X))))).
  {
    unfold test_in_list_Z.
    destruct (test_in_list x (PowerSet (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X))); simpl.
    - destruct (classic (In j x)).
      apply inpowerset_subseq_eq in i as H10.
      pose proof subseq_in _ _ j H10 H9.
      apply filter_In in H11.
      destruct H11.
      unfold Nat_eq_b in H12.
      destruct (Nat.eq_dec j j); [inversion H12 | tauto].
      assert (test_check_j_Z (j-1) x X = 0%Z).
      {
        unfold test_check_j_Z.
        destruct (test_check_j (j-1) x X); [ | lia].
        assert (j - 1 < j). { lia. }
        apply i0 in H10.
        tauto.
      }
      rewrite H10; simpl.
      assert (forall a:Z, Z.mul a 1%Z = a). { lia. }
      rewrite H11.
      unfold test_check_j_Z.
      destruct (test_check_j j x X); destruct (test_check_j (j - 1) x (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X)); [lia | | | lia].
      -- assert ((forall n : nat,
      j - 1 < n ->
      In n x <-> In n (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X))).
         {
           intros.
           split; intros.
           apply filter_In.
           assert (In n1 X).
           { apply inpowerset_subseq_eq in H3 as H14.
             eapply subseq_in. apply H14. tauto. }
           split.
           * tauto.
           * unfold Nat_eq_b.
             destruct (Nat.eq_dec j n1); [ | tauto].
             rewrite <- e in H13; tauto.
           * apply filter_In in H13.
             destruct H13.
             unfold Nat_eq_b in *.
             destruct (Nat.eq_dec j n1); [inversion H14 | ].
             assert (j < n1). { lia. }
             apply i0 in H15.
             tauto.
        }
        tauto.
      -- assert (forall n: nat, j < n -> In n x <-> In n X).
         {
           intros.
           split; intros.
           assert (In n1 X).
           { apply inpowerset_subseq_eq in H3 as H14.
             eapply subseq_in. apply H14. tauto. }
           tauto.
           assert (j-1 < n1). { lia. }
           pose proof i0 _ H14.
           apply H15.
           apply filter_In.
           split; [tauto | ].
           unfold Nat_eq_b.
           destruct (Nat.eq_dec j n1); [lia | tauto].
         }
         tauto.
    - assert (forall a b : Z, Z.add a (Z.mul b 0%Z) = a). { lia. }
      rewrite H9.
      destruct (classic (In j x)).
      -- unfold test_check_j_Z.
         destruct (test_check_j j x X); destruct (test_check_j (j-1) x X); [lia | | | lia].
         * assert (forall n:nat, j-1 < n -> In n x <-> In n X).
           {
             intros; split; intros.
             destruct (classic (j = n2)); [subst; tauto| ].
             assert (j < n2). { lia. }
             apply i in H14; tauto.
             destruct (classic (j = n2)); [subst; tauto| ].
             assert (j < n2). { lia. }
             apply i in H14; tauto.
           }
           tauto.
         * assert (forall n : nat, j < n -> In n x <-> In n X).
           {
             intros; split; intros.
             assert (j - 1 < n2). { lia. }
             apply i in H13; tauto.
             assert (j - 1 < n2). { lia. }
             apply i in H13; tauto.
           }
           tauto.
      -- assert (In x (PowerSet (filter (fun n0 : nat => negb (Nat_eq_b j n0)) X))).
         {
           apply inpowerset_subseq_eq.
           apply subseq_filter_subseq.
           * apply inpowerset_subseq_eq, H3.
           * intros.
             unfold Nat_eq_b.
             destruct (Nat.eq_dec j n1).
             ** rewrite <- e in H11; tauto.
             ** tauto.
         }
         tauto.
   }
  rewrite H9.
  lia.
Qed.

(* 证明了 zeta_j n 和 原先 zeta 变换的结果是一致的, 全集V是 list_n_1 n, 函数变量 X 是 (list_n_1 n) 的子集 *)
Theorem Zeta_n_eq_Zeta:
  forall (n:nat) (f: list nat -> Z) (X: list nat),
  subseq X (list_n_1 n) ->
  Zeta_j n f X = Zeta f X.
Proof.
  intros;unfold Zeta_j, Zeta.
  erewrite Summ_f_g;[reflexivity|].
  intros.
  assert(test_check_j_Z n x X = 1%Z).
  {
    unfold test_check_j_Z.
    destruct test_check_j;[reflexivity|].
    assert ((forall n0 : nat, n < n0 -> In n0 x <-> In n0 X)).
    {
      split; intros.
      - apply inpowerset_subseq_eq in H0 as H3.
        eapply subseq_in; [apply H3 | tauto].
      - assert (forall n0: nat, n < n0 -> In n0 x <-> In n0 X).
        {
          intros.
          pose proof Bign_not_in_list_n_1 n2.
          apply H4 in H3 as H5.
          split; intros.
          * pose proof In_PowerSet_In n2 x X H6 H0; tauto.
          * pose proof subseq_in _ _ _ H H6; tauto.
        }
        tauto.
    }
    tauto.
  }
  rewrite H1.
  lia.
Qed.

End Fast_Zeta_Mobius_Transforms.


(** * Nelist.v: A general theory of non empty lists on Type *)

Set Implicit Arguments.
Set Strict Implicit.

Section NELIST.

Variable A : Type.

Inductive nelist : Type :=
    singl : A -> nelist | add : A -> nelist -> nelist.

Definition hd (l:nelist) : A :=
     match l with (singl a) => a | (add a _) => a end.

Fixpoint app (l m : nelist) {struct l} : nelist :=
    match l with (singl a) => add a m | (add a l1) => add a (app l1 m) end.

Fixpoint rev_app (l m : nelist) {struct l} : nelist :=
    match l with (singl a) => add a m | (add a l1) => rev_app l1 (add a m) end.

Definition rev (l:nelist) : nelist :=
   match l with (singl a) => l | (add a l1) => rev_app l1 (singl a) end.

Lemma app_assoc : forall l1 l2 l3, app l1 (app l2 l3) = app (app l1 l2) l3.
intros; induction l1; simpl; auto.
rewrite IHl1; auto.
Qed.

Hint Resolve app_assoc.

Lemma rev_app_rev : forall l m, rev_app l m = app (rev l) m.
induction l; simpl; intros; auto.
rewrite IHl.
rewrite IHl.
rewrite <- app_assoc; trivial.
Qed.

Hint Resolve rev_app_rev.

Lemma rev_app_app_rev : forall l m, rev (rev_app l m) = app (rev m) l.
induction l; intros;simpl; auto.
rewrite IHl; simpl.
rewrite rev_app_rev.
rewrite <- app_assoc; trivial.
Qed.

Lemma rev_rev : forall l, rev (rev l) = l.
destruct l; simpl; intros; auto.
rewrite rev_app_app_rev; trivial.
Qed.

Lemma rev_app_distr : forall l m, rev (app l m) = app (rev m) (rev l).
induction l; intros;simpl; auto.
rewrite rev_app_rev.
rewrite rev_app_rev.
rewrite IHl; auto.
Qed.

Hint Resolve rev_rev rev_app_distr.

Lemma hd_app : forall l m, hd (app l m) = hd l.
destruct l; simpl; auto.
Qed.

Hint Resolve hd_app.

Lemma hd_rev_add : forall a l, hd (rev (add a l)) = hd (rev l).
simpl; intros.
rewrite rev_app_rev; auto.
Qed.
Hint Resolve hd_rev_add.

End NELIST.