Require Import List String.
Require Import Result.
Open Scope string_scope.

Variable data hash : Set.
Variable gen_hash : data -> hash.
Variable concat : hash -> hash -> data.
Axiom concat_left : forall x y a b,
    x <> a -> concat x y <> concat a b.
Axiom concat_right : forall x y a b,
    y <> b -> concat x y <> concat a b.

Variable hash_eq_dec : forall (x y: hash), {x = y} + {x <> y}.

Inductive mtree : Set :=
| L : data -> mtree
| N : mtree -> mtree -> mtree
.

Inductive MTree : nat -> hash -> mtree -> Prop :=
| MTL : forall data, MTree 0 (gen_hash data) (L data)
| MTN : forall n h1 h2 left right,
    MTree n h1 left -> MTree n h2 right ->
    MTree (1 + n) (gen_hash (concat h1 h2)) (N left right)
.

Fixpoint hash_of_tree t :=
  match t with
  | L data => gen_hash data
  | N left_ right_ =>
    gen_hash (concat (hash_of_tree left_) (hash_of_tree right_))
  end.

Lemma hash_of_mtree : forall t n h,
    MTree n h t ->
    hash_of_tree t = h.
Proof.
  induction t; intros n h Htree.
  - now inversion Htree.
  - inversion Htree. subst. simpl.
    now rewrite (IHt1 n0 h1), (IHt2 n0 h2).
Qed.

Definition path := list bool.
Definition len (p: path) : nat := List.length p.

Fixpoint get_elt (path: path) tree :=
  match path with
  | nil =>
    match tree with
    | L data => Ok data
    | N _ _ => Error tt
    end
  | bit :: path' =>
    match tree with
    | L _ => Error tt
    | N left_ right_ =>
      if bit then get_elt path' left_
      else get_elt path' right_
    end
  end.

Inductive proof :=
| Mk_proof : data -> list hash -> proof.

Definition lenp '(Mk_proof data pstream) := List.length pstream.

Definition p_data '(Mk_proof data pstream) := data.
Definition p_stream '(Mk_proof data pstream) := pstream.

Fixpoint verifier (path: path) (proof: proof) :=
  match path with
  | nil =>
    Ok (gen_hash (p_data proof))
  | bit :: path' =>
    match p_stream proof with
    | nil => Error tt
    | hd :: tl =>
      verifier path' (Mk_proof (p_data proof) tl) >>= fun h' =>
      if bit then
        Ok (gen_hash (concat h' hd))
      else
        Ok (gen_hash (concat hd h'))
    end
  end.

Fixpoint prover (path:path) (tree : mtree) :=
  match path with
  | nil =>
    match tree with
    | L data => Ok (Mk_proof data nil)
    | N _ _ => Error tt
    end
  | bit :: path' =>
    match tree with
    | L _ => Error tt
    | N left_ right_ =>
      if bit then
        prover path' left_ >>= fun '(Mk_proof data pstream) =>
        let hr := hash_of_tree right_ in
        Ok (Mk_proof data (hr :: pstream))
      else
        prover path' right_ >>= fun '(Mk_proof data pstream) =>
        let hl := hash_of_tree left_ in
        Ok (Mk_proof data (hl :: pstream))
    end
  end.

Lemma length_prover : forall path h (tree : mtree) proof,
    MTree (len path) h tree ->
    prover path tree = Ok proof ->
    lenp proof = len path.
Proof.
  intros path. induction path; intros h tree proof Htree.
  - inversion Htree. injection 1. intros Hproof. now subst proof.
  - inversion Htree. simpl.
    destruct a.
    +
      case_eq (prover path0 left); [|now auto]. intros proof' Hproof'.
      simpl. destruct proof'. injection 1. intros Hproof. subst.
      now rewrite <- (IHpath h1 left (Mk_proof d l)).
    +
      case_eq (prover path0 right); [|now auto]. intros proof' Hproof'.
      simpl. destruct proof'. injection 1. intros Hproof. subst.
      now rewrite <- (IHpath h2 right (Mk_proof d l)).
Qed.

Theorem correctness : forall path h tree proof,
    MTree (len path) h tree ->
    prover path tree = Ok proof ->
    verifier path proof = Ok h.
Proof.
  intros path. induction path; intros h tree proof MTree.
  - inversion MTree.
    simpl. injection 1. intro. now subst.
  - inversion MTree. simpl. destruct a.
    + case_eq (prover path0 left); [|now auto]. simpl.
      intros [data pstream] Hproof'. injection 1. intro. subst proof. simpl.
      rewrite (hash_of_mtree right _ _ H1).
      now rewrite (IHpath h1 left (Mk_proof data pstream)).
    + case_eq (prover path0 right); [|now auto]. simpl.
      intros [data pstream] Hproof'. injection 1. intro. subst proof. simpl.
      rewrite (hash_of_mtree left _ _ H0).
      now rewrite (IHpath h2 right (Mk_proof data pstream)).
Qed.

Definition hash_collision := exists s1 s2,
    gen_hash s1 = gen_hash s2 /\ s1 <> s2.

Theorem security : forall path h tree proof,
    MTree (len path) h tree ->
    verifier path proof = Ok h ->
    get_elt path tree <> Ok (p_data proof) ->
    hash_collision.
Proof.
  intro path. induction path; intros h tree proof HTree.
  - inversion HTree. subst h tree.
    simpl. injection 1. intros Heq Hneq.
    exists data0, (p_data proof).
    now cut (data0 <> p_data proof); [| intro eq; elim Hneq; now rewrite eq].
  - simpl. destruct (p_stream proof); [now auto|].
    case_eq (verifier path0 (Mk_proof (p_data proof) l)); [|now auto]. intros h' Hh'. simpl.
    destruct a.
    + injection 1. intro. subst h.
      destruct tree; [now inversion HTree|].
      inversion HTree. subst.
      destruct (hash_eq_dec h' h1).
      * intro Helt. subst h'.
        now apply (IHpath h1 tree1 (Mk_proof (p_data proof) l) H4).
      * intros Helt. exists (concat h' h0), (concat h1 h2).
        now apply (concat_left _ h0 _ h2) in n.
    + injection 1. intro. subst h.
      destruct tree; [now inversion HTree|].
      inversion HTree. subst.
      destruct (hash_eq_dec h' h2).
      * intro Helt. subst h'.
        now apply (IHpath h2 tree2 (Mk_proof (p_data proof) l) H5).
      * intros Helt. exists (concat h0 h'), (concat h1 h2).
        now apply (concat_right h0 _ h1 _) in n.
Qed.


(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Proof of the axioms of choice                                           *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics LibLogic LibEpsilon LibRelation.
Generalizable Variables A B.

(** This files includes several versions of the axiom of choice.
    This "axiom" is actually proved in terms of indefinite description.
    Remark: the choice results contained in this file are not very
    useful in practice since it is usually more convenient to use
    the epsilon operator directly. *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Functional choice *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Functional choice *)

(** This result can be used to build a function from a relation that maps
    every input to at least one output. *)

Lemma functional_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  intros. exists (fun x => sig_val (indefinite_description (H x))).
  intro x. apply (sig_proof (indefinite_description (H x))).
Qed.
(* --LATER: the premise is called [defined] in LibRelation *)
(* --LATER: functionality -> definedness? *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Dependent functional choice *)

(** It is a generalization of functional choice to dependent functions. *)

Scheme and_indd := Induction for and Sort Prop.
Scheme eq_indd := Induction for eq Sort Prop.

Lemma dependent_functional_choice :
  forall A (B:A->Type) (R:forall x, B x -> Prop),
  (forall x, exists y, R x y) ->
  (exists f, forall x, R x (f x)).
Proof using.
  introv H.
  pose (B' := { x:A & B x }).
  pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)).
  destruct (functional_choice R') as (f,Hf).
    intros x. destruct (H x) as (y,Hy).
     exists (existT (fun x => B x) x y). split~.
  sets proj1_transparent: (fun P Q (p:P/\Q) => let (a,b) := p in a).
  exists (fun x => eq_rect _ _ (projT2 (f x)) _ (proj1_transparent _ _ (Hf x))).
  intros x. destruct (Hf x) as (Heq,HR) using and_indd.
  destruct (f x). simpls. destruct Heq using eq_indd. apply HR.
Qed.

Arguments dependent_functional_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Guarded functional choice *)

(** Similar to functional choice, except that it targets partial functions *)

Lemma guarded_functional_choice : forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  intros. apply (functional_choice (fun x y => P x -> R x y)).
  intros. applys* indep_general_premises.
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Omniscient functional choice *)

(** Similar to functional choice except that the proof of functionality
    of the relation is given after the fact, for each argument. *)

Lemma omniscient_functional_choice : forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists y, R x y) -> R x (f x).
Proof using. intros. apply~ guarded_functional_choice. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Functional unique choice *)

(** This section provides a similar set of results excepts that it is
    specialized for the case where each argument has a unique image. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Functional unique choice *)

Lemma functional_unique_choice : forall A B (R:A->B->Prop),
  (forall x , exists! y, R x y) ->
  (exists! f, forall x, R x (f x)).
Proof using.
  intros. destruct (functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. apply fun_ext_1. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Dependent functional unique choice *)

Theorem dependent_functional_unique_choice :
  forall (A:Type) (B:A->Type) (R:forall (x:A), B x -> Prop),
  (forall (x:A), exists! y : B x, R x y) ->
  (exists! f : (forall (x:A), B x), forall (x:A), R x (f x)).
Proof using.
  intros. destruct (dependent_functional_choice R) as [f Hf].
  intros. apply (ex_of_ex_unique (H x)).
  exists f. split. auto.
   intros g Hg. extens. intros y.
   apply~ (at_most_one_of_ex_unique (H y)).
 Qed.

Arguments dependent_functional_unique_choice [A] [B].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Guarded functional unique choice *)

Lemma guarded_functional_unique_choice :
  forall A `{Inhab B} (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists! y, R x y) ->
  (exists f, forall x, P x -> R x (f x)).
Proof using.
  introv I M. apply (functional_choice (fun x y => P x -> R x y)).
  intros. apply* indep_general_premises.
  introv H. destruct* (M _ H) as (y&Hy&_).
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Omniscient functional unique choice *)

Lemma omniscient_functional_unique_choice :
  forall A `{Inhab B} (R : A->B->Prop),
  exists f, forall x, (exists! y, R x y) -> R x (f x).
Proof using.
  intros. destruct (omniscient_functional_choice R) as [f F].
  exists f. introv (y&Hy&Uy). autos*.
Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Relational choice *)

(** Relational choice can be used to extract from a relation a subrelation
    that describes a function, by mapping every argument to a unique image. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Relational choice *)

Lemma rel_choice : forall A B (R:A->B->Prop),
  (forall x, exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, exists! y, R' x y).
Proof using.
  introv H. destruct~ (functional_choice R) as [f Hf].
  exists (fun x y => f x = y). split.
    introv E. simpls. subst~.
    intros x. exists~ (f x).
Qed.

(* --TODO: Dependent relational choice, is it meaningful?, useful? *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Guarded relational choice *)

Lemma guarded_rel_choice : forall A B (P : A->Prop) (R : A->B->Prop),
  (forall x, P x -> exists y, R x y) ->
  (exists R', rel_incl R' R
           /\ forall x, P x -> exists! y, R' x y).
Proof using.
  intros. destruct (rel_choice (fun (x:sig P) (y:B) => R (sig_val x) y))
   as (R',(HR'R,M)).
    intros (x,HPx). destruct (H _ HPx) as (y,HRxy). exists~ y.
  set (R'' := fun (x:A) (y:B) => exists (H : P x), R' (exist P x H) y).
  exists R''. split.
    intros x y (HPx,HR'xy). apply (HR'R _ _ HR'xy).
    intros x HPx. destruct (M (exist P x HPx)) as (y,(HR'xy,Uniq)).
     exists y. split.
       exists~ HPx.
       intros y' (H'Px,HR'xy'). apply Uniq.
        rewrite~ (proof_irrelevance HPx H'Px).
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Omniscient relation choice *)

Lemma omniscient_rel_choice : forall A B (R : A->B->Prop),
  exists R', rel_incl R' R
          /\ forall x, (exists y, R x y) -> (exists! y, R' x y).
Proof using. intros. apply~ guarded_rel_choice. Qed.

(* 2021-08-11 15:24 *)


Require Import BinPos.

Definition P := (fun x : positive => x = xH).

Goal forall (p q : positive), P q -> q = p -> P p.
intros; congruence.
Qed.


Require Import Common Computation ADT Ensembles.

Generalizable All Variables.
Set Implicit Arguments.

Section MethodRefinement.

  (** Old and new representations **)
  Variables oldRep newRep : Type.

  (** Abstraction Relation *)
  Variable AbsR : oldRep -> newRep -> Prop.

  Notation "ro ≃ rn" := (AbsR ro rn) (at level 70).

  (** Refinement of a constructor: the computation produced by
   a constructor [newConstructor] should be a refinement
   of the computation produced by the old constructor [oldObserver] on
   [d].  That is, the following diagram should commute:
<<
           old constructor
       Dom --------------> old rep
        ∥                      |
        ∥ id              AbsR |
        ∥                      |
       Dom --------------> new rep
          new constructor
>>
   *)

  Definition refineConstructor
             (Dom : Type)
             (oldConstructor : constructorType oldRep Dom)
             (newConstructor : constructorType newRep Dom)
    := forall d,
         refine (r_o' <- oldConstructor d;
                 {r_n | r_o' ≃ r_n})
                (newConstructor d).

  (** Refinement of a method : the values of the computation
      produced by applying a new method [newMethod] to any new
      state [r_n] related to an old state [r_o] by the abstraction
      relation [AbsR] are related by [AbsR] to some value produced by
      the corresponding old method on [r_o]. Related values
      are taken to related values (with the new method potentially
      producing more deterministic computations). That is, the
      following diagram commutes:
<<
                   old method
       old rep --------------> old rep
          |                         |
     AbsR |                         | AbsR
          ↓                         ↓
       new rep --------------> new rep
                   new method
>>  *)

  Definition refineMethod
             (Dom Cod : Type)
             (oldMethod : methodType oldRep Dom Cod)
             (newMethod : methodType newRep Dom Cod)
    := forall r_o r_n d, r_o ≃ r_n ->
         refine (r_o' <- oldMethod r_o d;
                 r_n' <- {r_n | fst r_o' ≃ r_n};
                 ret (r_n', snd r_o'))
                (newMethod r_n d).

End MethodRefinement.

Record refineADT {Sig} (A B : ADT Sig) :=
  refinesADT {
      AbsR : _;
      ADTRefinementPreservesConstructors
      : forall idx : ConstructorIndex Sig,
          @refineConstructor
            (Rep A) (Rep B) AbsR
            (ConstructorDom Sig idx)
            (Constructors A idx)
            (Constructors B idx);
      ADTRefinementPreservesMethods
      : forall idx : MethodIndex Sig,
          @refineMethod
            (Rep A) (Rep B) AbsR
            (fst (MethodDomCod Sig idx))
            (snd (MethodDomCod Sig idx))
            (Methods A idx)
            (Methods B idx) }.
(** We should always just unfold [refineMethod] and [refineConstructor]
    into [refine], so that we can rewrite with lemmas about [refine]. *)
Arguments refineMethod / .
Arguments refineConstructor / .

Notation "ro ≃ rn" := (@AbsR _ _ _ _ ro rn) (at level 70).


Require Import String.
Require Import Lia.
Require Import List.
Require Import Nat.
Require Import Coq.Vectors.Vector.
Require Import Coq.Vectors.VectorEq.
Require Import Coq.Arith.Bool_nat.
Require Export Coq.Arith.Compare_dec.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Bool.Bool.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export RelationClasses.
Require Export Morphisms.
Require Import Program.
From ST Require Import EVarsScratchwork.
From ST Require Import Vector.
From ST Require Export Logic.V Logic.Term.
From ST Require Export SoftType.Radix.
Import ListNotations.
Import VectorNotations.
Open Scope string_scope.
(** ** Attributes

Attributes may be prepended to types, when registered in an existential cluster.
Otherwise, we can create a formula [Term is Attribute].
*)

Inductive Attribute : Type :=
| Attr : forall (n : nat), name -> Vector.t Term n -> Attribute.

Global Instance EqAttribute : Eq Attribute := {
  eqb (A1 A2 : Attribute) :=
  match A1,A2 with
  | Attr n1 s1 args1, Attr n2 s2 args2 => if andb (eqb n1 n2) (eqb s1 s2) then
    vectors_eqb args1 args2 term_eqb
    else false
  end
}.

Global Instance substAttr : Subst Attribute :=
{
  subst (x : V) (t : Term) (a : Attribute) :=
  match a with
  | Attr n s args => Attr n s (Vector.map (fun (arg : Term) => subst x t arg) args)
  end
}.

Global Instance liftAttr : Lift Attribute :=
{
  lift (c d : nat) (a : Attribute) :=
  match a with
  | Attr n s args => Attr n s (Vector.map (fun (a : Term) => lift c d a) args)
  end;
  unlift (c d : nat) (a : Attribute) :=
  match a with
  | Attr n s args => Attr n s (Vector.map (fun (a : Term) => unlift c d a) args)
  end
}.

Global Instance EnumerateEVarsAttribute : EnumerateEVars Attribute := {
list_evars attr := match attr with
| Attr n s args => Vector.fold_left (fun l' => fun (arg : Term) => insert_merge (list_evars arg) l') []%list args
end
}.

Theorem list_evars_attribute_sorted : forall (A : Attribute),
  sorted (list_evars A).
Proof. intros. destruct A. rename t into args.
  unfold list_evars; unfold EnumerateEVarsAttribute.
  apply insert_merge_vector_fold_sorted2.
  apply sorted_nil.
Qed.


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

Require Import Wellfounded.

Set Implicit Arguments.

(* Dependent recursion principle for Acc, same as Acc_inv_dep but for sort Type
   instead of sort Prop *)

Scheme Acc_drect := Induction for Acc Sort Type.

Section Acc_eq.

  (* Proof that Fix_F is extensionnal *)

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

  (* This is a weaker notion than @eq (Acc R x) but sufficient
     to establish extensinality properties *)

  Inductive Acc_eq : forall x, Acc R x -> Acc R x -> Prop :=
    | in_Acc_eq : forall x H1 H2, (forall y Hy, Acc_eq (H1 y Hy) (H2 y Hy)) -> Acc_eq (Acc_intro x H1) (Acc_intro _ H2).

  (* unless dependent functional extensionality is assumed, it is
     not possible to show that there is a unique accessibility proof
     BUT it is easy to show that they are unique upto Acc_eq ... *)

  Fact Acc_eq_total x (H1 H2 : Acc R x) : Acc_eq H1 H2.
  Proof.
    revert x H1 H2.
    induction H1 as [ x H1 IH ] using Acc_inv_dep; intros [ H2 ].
    constructor; intros; apply IH.
  Qed.

  Variable P : X -> Type.
  Variable F : forall x, (forall y, R y x -> P y) -> P x.

  Variable (E : forall x, P x -> P x -> Prop).

  Hypothesis
    F_ext :
      forall x (f g:forall y, R y x -> P y),
        (forall y (p:R y x), E (f y p) (g y p)) -> E (F f) (F g).

  (* This one generalizes Fix_F_inv from Wf in that it does not assume wellfoundedness *)

  Lemma Fix_F_ext : forall x (r s : Acc R x), E (Fix_F _ F r) (Fix_F _ F s).
  Proof.
    intros ? r s; generalize (Acc_eq_total r s).
    induction 1 as [ ? ? ? ? IH ]; apply F_ext, IH.
  Qed.

  (* This one generalizes Fix_F_eq for arbitrary relations *)

  Theorem Fix_F_equiv x (r : Acc R x) : E (Fix_F _ F r)
                                          (F (fun y Hy => Fix_F _ F (Acc_inv r _ Hy))).
  Proof.
    rewrite Fix_F_eq; apply Fix_F_ext.
  Qed.

  Hypothesis Rwf : well_founded R.

  (* This one generalizes Fix_eq for arbitrary relations *)

  Theorem Fix_equiv x : E (Fix Rwf P F x) (F (fun y _ => Fix Rwf P F y)).
  Proof.
    unfold Fix.
    destruct (Rwf x); simpl.
    apply F_ext.
    intros; apply Fix_F_ext.
  Qed.

End Acc_eq.


From Undecidability.FOL.Arithmetics Require Import FA Signature.
From Undecidability.FOL Require Import PA.
Require Import Lia List Vector.
Import Vector.VectorNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* ** The standard model *)

Section StdModel.

  Definition interp_nat : interp nat.
  Proof.
    split.
    - destruct f; intros v.
      + exact 0.
      + exact (S (Vector.hd v) ).
      + exact (Vector.hd v + Vector.hd (Vector.tl v) ).
      + exact (Vector.hd v * Vector.hd (Vector.tl v) ).
    - destruct P. intros v.
      exact (Vector.hd v = Vector.hd (Vector.tl v) ).
  Defined.

  Fact nat_extensional : extensional interp_nat.
  Proof.
    now intros x y.
  Qed.

  Lemma nat_is_FA_model : forall rho phi,  List.In phi FAeq -> sat interp_nat rho phi.
  Proof.
    intros rho phi. intros H.
    repeat (destruct H as [<- | H]; auto).
    all: cbn; try congruence. inversion H.
  Qed.

  Lemma nat_is_Q_model : forall rho phi,  List.In phi Qeq -> sat interp_nat rho phi.
  Proof.
    intros rho phi. intros H.
    repeat (destruct H as [<- | H]; auto).
    all: cbn; try congruence.
    2: inversion H.
    induction d. now left.
    right. destruct IHd.
    exists 0. congruence.
    exists d. reflexivity.
  Qed.

  Fact nat_eval_num (sigma : env nat) n : @eval _ _ _ interp_nat sigma (μ n) = n.
  Proof.
    induction n.
    - reflexivity.
    - cbn. now rewrite IHn.
  Qed.

  Fact nat_induction phi : forall rho, sat interp_nat rho (ax_induction phi).
  Proof.
    intros rho H0 IH d. induction d; cbn in *.
    rewrite <-sat_single in H0. apply H0.
    apply IH in IHd. rewrite sat_comp in IHd.
    revert IHd. apply sat_ext. intros []; reflexivity.
  Qed.

  Fact nat_is_PAeq_model : forall ax rho, PAeq ax -> sat interp_nat rho ax.
  Proof.
    intros rho psi [].
    now apply nat_is_FA_model.
    all: cbn; try congruence.
    apply nat_induction.
 Qed.

  Fact nat_is_PA_model : forall ax rho, PA ax -> sat interp_nat rho ax.
  Proof.
    intros rho psi [].
    repeat (destruct H as [<- | H]; auto).
    all: cbn; try congruence. inversion H.
    apply nat_induction.
  Qed.

End StdModel.


(*
Last login: Thu Dec 17 09:09:30 on ttys001
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_5.

Coq < Goal forall t r p g n h:Prop, (((t /\ r) -> p) /\ ((~p /\ r) /\ g) /\ ((~t \/ n) -> h)) -> h.
1 subgoal

  ============================
   forall t r p g n h : Prop,
   (t /\ r -> p) /\ ((~ p /\ r) /\ g) /\ (~ t \/ n -> h) -> h

Unnamed_thm < intros.
1 subgoal

  t : Prop
  r : Prop
  p : Prop
  g : Prop
  n : Prop
  h : Prop
  H : (t /\ r -> p) /\ ((~ p /\ r) /\ g) /\ (~ t \/ n -> h)
  ============================
   h

Unnamed_thm < elim H.
1 subgoal

  t : Prop
  r : Prop
  p : Prop
  g : Prop
  n : Prop
  h : Prop
  H : (t /\ r -> p) /\ ((~ p /\ r) /\ g) /\ (~ t \/ n -> h)
  ============================
   (t /\ r -> p) -> ((~ p /\ r) /\ g) /\ (~ t \/ n -> h) -> h

Unnamed_thm < intro.
1 subgoal

  t : Prop
  r : Prop
  p : Prop
  g : Prop
  n : Prop
  h : Prop
  H : (t /\ r -> p) /\ ((~ p /\ r) /\ g) /\ (~ t \/ n -> h)
  H0 : t /\ r -> p
  ============================
   ((~ p /\ r) /\ g) /\ (~ t \/ n -> h) -> h

Unnamed_thm < intro.
1 subgoal

  t : Prop
  r : Prop
  p : Prop
  g : Prop
  n : Prop
  h : Prop
  H : (t /\ r -> p) /\ ((~ p /\ r) /\ g) /\ (~ t \/ n -> h)
  H0 : t /\ r -> p
  H1 : ((~ p /\ r) /\ g) /\ (~ t \/ n -> h)
  ============================
   h

Unnamed_thm < destruct H1.
1 subgoal

  t : Prop
  r : Prop
  p : Prop
  g : Prop
  n : Prop
  h : Prop
  H : (t /\ r -> p) /\ ((~ p /\ r) /\ g) /\ (~ t \/ n -> h)
  H0 : t /\ r -> p
  H1 : (~ p /\ r) /\ g
  H2 : ~ t \/ n -> h
  ============================
   h

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
destruct H1.
firstorder .

Unnamed_thm is defined

Coq <
*)

Section Exercise_5.
Goal forall t r p g n h:Prop, (((t /\ r) -> p) /\ ((~p /\ r) /\ g) /\ ((~t \/ n) -> h)) -> h.
intros.
elim H.
intro.
intro.
destruct H1.
firstorder.
Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.
From LF Require Import Maps.

Module AExp.

  Inductive aexp: Type :=
  | ANum (n: nat)
  | APlus (a1 a2: aexp)
  | AMinus (a1 a2: aexp)
  | AMult(a1 a2: aexp).

  Inductive bexp: Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2: aexp)
  | BLe (a1 a2: aexp)
  | BNot (b: bexp)
  | BAnd (b1 b2: bexp).

  Fixpoint aeval (a : aexp) : nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2 => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

  Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval a1) =? (aeval a2)
  | BLe a1 a2 => (aeval a1) <=? (aeval a2)
  | BNot b1 => negb (beval b1)
  | BAnd b1 b2 => andb (beval b1) (beval b2)
  end.

  Fixpoint optimize_0plus (a:aexp): aexp :=
    match a with
    | ANum n => ANum n
    | APlus (ANum 0) e2 => optimize_0plus e2
    | APlus e1 e2 => APlus (optimize_0plus e1) (optimize_0plus e2)
    | AMinus e1 e2 => AMinus (optimize_0plus e1) (optimize_0plus e2)
    | AMult e1 e2 => AMult (optimize_0plus e1) (optimize_0plus e2)
    end.

  Example test_optimize_0plus:
    optimize_0plus (APlus (ANum 2)
                          (APlus (ANum 0)
                                 (APlus (ANum 0) (ANum 1))))
    = APlus (ANum 2) (ANum 1).
  Proof. reflexivity. Qed.

  Theorem optimize_0plus_sound: forall a,
      aeval (optimize_0plus a) = aeval a.
  Proof.
    intros.
    induction a.
    - unfold optimize_0plus. reflexivity.
    - destruct a1 eqn:Ea1.
      + destruct n.
        * simpl. apply IHa2.
        * simpl. rewrite IHa2. reflexivity.
      + simpl. simpl in IHa1. rewrite IHa2.
        rewrite IHa1. reflexivity.
      + simpl. rewrite IHa2. simpl in IHa1.
        rewrite IHa1. reflexivity.
      + simpl. simpl in IHa1. rewrite IHa1.
        rewrite IHa2. reflexivity.
    - simpl. rewrite IHa1. rewrite IHa2.
      reflexivity.
    - simpl. rewrite IHa1. rewrite IHa2.
      reflexivity.
  Qed.

  Lemma foo': forall n, 0 <=? n = true.
  Proof.
    intros.
    destruct n; simpl; reflexivity.
  Qed.

  (* if try fails just does nothing *)
  Theorem silly1 : forall ae, aeval ae = aeval ae.
  Proof.
    try reflexivity. Qed.

  Theorem silly2: forall (P: Prop), P -> P.
  Proof.
    intros P HP.
    try reflexivity.
    apply HP. Qed.

  (* use try and ; to simplify our prove *)
  Theorem optimize_0plus_sound': forall a,
      aeval (optimize_0plus a) = aeval a.
  Proof.
    intros.
    induction a;
      (* take care the case just rewrite IH*)
      try (simpl; rewrite IHa1; rewrite IHa2;
           reflexivity).
    - reflexivity.
    - destruct a1 eqn:Ea1;
        try (simpl; simpl in IHa1; rewrite IHa1;
             rewrite IHa2; reflexivity).
      + destruct n eqn:En;
          simpl; rewrite IHa2; reflexivity.
  Qed.

 Theorem optimize_0plus_sound'': forall a,
      aeval (optimize_0plus a) = aeval a.
  Proof.
    intros.
    induction a;
      (* take care the case just rewrite IH*)
      try (simpl; rewrite IHa1; rewrite IHa2;
           reflexivity);
      try reflexivity.
    - destruct a1 eqn:Ea1;
        try (simpl; simpl in IHa1; rewrite IHa1;
             rewrite IHa2; reflexivity).
      + destruct n eqn:En;
          simpl; rewrite IHa2; reflexivity.
  Qed.

  Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
  Proof.
    repeat (try (left; reflexivity); right).
  Qed.

  (* if fails just keep original goal *)
  Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
  Proof.
    repeat (left; reflexivity).
    repeat (right; try(left; reflexivity)).
  Qed.

  Fixpoint optimize_0plus_b (b: bexp): bexp :=
    match b with
    | BTrue => BTrue
    | BFalse => BFalse
    | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
    | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
    | BNot b1 => BNot (optimize_0plus_b b1)
    | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
    end.

  Theorem optimize_0plus_b_sound: forall b,
      beval (optimize_0plus_b b) = beval b.
  Proof.
    intros.
    induction b;
      try reflexivity;
      try (simpl;
           repeat (rewrite optimize_0plus_sound);
           reflexivity).
    - simpl; rewrite IHb; reflexivity.
    - simpl; rewrite IHb1; rewrite IHb2;
        reflexivity.
  Qed.

  (* the newtype tool for tactic*)
  Tactic Notation "simpl_and_try" tactic(c) :=
    simpl; try c.

  Example silly_presburger_example: forall m n o p,
      m + n <= n + o /\ o + 3 = p + 3 ->
      m <= p.
  Proof.
    intros. omega. Qed.

  Module avealR_first_try.

    (* evaluate from relation point of view*)

    Inductive aevalR: aexp -> nat -> Prop :=
    | E_ANum n:
        aevalR (ANum n) n
    | E_APlus (e1 e2: aexp) (n1 n2: nat) :
        aevalR e1 n1 ->
        aevalR e2 n2 ->
        aevalR (APlus e1 e2) (n1 + n2)
    | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
        aevalR e1 n1 ->
        aevalR e2 n2 ->
        aevalR (AMinus e1 e2) (n1 - n2)
    | E_AMult (e1 e2: aexp) (n1 n2: nat) :
        aevalR e1 n1 ->
        aevalR e2 n2 ->
        aevalR (AMult e1 e2) (n1 * n2).

    Module TooHardToRead.
      (* A small notational aside. We would previously have written the
   definition of aevalR like this, with explicit names for the
   hypotheses in each case: *)
      Inductive aevalR : aexp -> nat -> Prop :=
      | E_ANum n :
          aevalR (ANum n) n
      | E_APlus (e1 e2: aexp) (n1 n2: nat)
                (H1 : aevalR e1 n1)
                (H2 : aevalR e2 n2) :
          aevalR (APlus e1 e2) (n1 + n2)
      | E_AMinus (e1 e2: aexp) (n1 n2: nat)
                 (H1 : aevalR e1 n1)
                 (H2 : aevalR e2 n2) :
          aevalR (AMinus e1 e2) (n1 - n2)
      | E_AMult (e1 e2: aexp) (n1 n2: nat)
                (H1 : aevalR e1 n1)
                (H2 : aevalR e2 n2) :
          aevalR (AMult e1 e2) (n1 * n2).
      End TooHardToRead.

      Notation "e '\\' n"
        := (aevalR e n)
             (at level 50, left associativity)
           : type_scope.

    End avealR_first_try.
    Reserved Notation "e '\\' n" (at level 90, left associativity).

    Inductive aevalR : aexp -> nat -> Prop :=
    | E_ANum (n : nat) :
        (ANum n) \\ n
    | E_APlus (e1 e2 : aexp) (n1 n2 : nat) :
        (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
    | E_AMinus (e1 e2 : aexp) (n1 n2 : nat) :
        (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
    | E_AMult (e1 e2 : aexp) (n1 n2 : nat) :
        (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

    where "e '\\' n" := (aevalR e n) : type_scope.

    Theorem aeval_iff_aevalR : forall a n,
        (a \\ n) <-> aeval a = n.
    Proof.
      (* WORKED IN CLASS *)
      split.
      - (* -> *)
        intros H; induction H; subst; reflexivity.
      - (* <- *)
        generalize dependent n.
        induction a; simpl; intros;
          subst; constructor;
            try apply IHa1;
            try apply IHa2; reflexivity.
    Qed.

    Inductive bevalR: bexp -> bool -> Prop :=
    | E_BTrue: bevalR BTrue true
    | E_BFalse: bevalR BFalse false
    | E_BEq (a1 a2: aexp) (e1 e2: nat):
        (aevalR a1 e1) -> (aevalR a2  e2) ->
        bevalR (BEq a1 a2) (e1 =? e2)
    | E_BLe (a1 a2: aexp) (e1 e2: nat):
        (aevalR a1 e1) -> (aevalR a2 e2) ->
        bevalR (BLe a1 a2) (e1 <=? e2)
    | E_BNot (b1: bexp) (e1: bool):
        (bevalR b1 e1) -> bevalR (BNot b1) (negb e1)
    | E_BAnd (b1 b2: bexp) (e1 e2: bool):
        (bevalR b1 e1) -> (bevalR b2 e2) ->
        bevalR (BAnd b1 b2) (andb e1 e2).

    Lemma beval_iff_bevalR : forall b bv,
        bevalR b bv <-> beval b = bv.
    Proof.
    (* FILL IN HERE *) Admitted.

    End AExp.

Module aevalR_division.
  Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp). (* <--- NEW *)

  Reserved Notation "e '\\' n"
           (at level 90, left associativity).
  Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum (n : nat) :
      (ANum n) \\ n
  | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)
  | E_ADiv (a1 a2 : aexp) (n1 n2 n3 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (n2 > 0) ->
      (mult n2 n3 = n1) -> (ADiv a1 a2) \\ n3

  where "a '\\' n" := (aevalR a n) : type_scope.
  End aevalR_division.

Module aevalR_extended.

    Reserved Notation "e '\\' n" (at level 90, left associativity).
    Inductive aexp : Type :=
    | AAny (* <--- NEW *)
    | ANum (n : nat)
    | APlus (a1 a2 : aexp)
    | AMinus (a1 a2 : aexp)
    | AMult (a1 a2 : aexp).

    Inductive aevalR : aexp -> nat -> Prop :=
    | E_Any (n : nat) :
        AAny \\ n (* <--- NEW *)
    | E_ANum (n : nat) :
        (ANum n) \\ n
    | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
        (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
    | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
        (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
    | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
        (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)

    where "a '\\' n" := (aevalR a n) : type_scope.
End aevalR_extended.

Definition state := total_map nat.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : string) (* <--- NEW *)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Coercion AId: string >-> aexp.
Coercion ANum : nat >-> aexp.

Definition bool_to_bexp (b : bool) : bexp :=
  if b then BTrue else BFalse.
Coercion bool_to_bexp : bool >-> bexp.
Bind Scope imp_scope with aexp.
Bind Scope imp_scope with bexp.
Delimit Scope imp_scope with imp.
Notation "x + y" := (APlus x y) (at level 50, left associativity) : imp_scope.
Notation "x - y" := (AMinus x y) (at level 50, left associativity) : imp_scope.
Notation "x * y" := (AMult x y) (at level 40, left associativity) : imp_scope.
Notation "x <= y" := (BLe x y) (at level 70, no associativity) : imp_scope.
Notation "x = y" := (BEq x y) (at level 70, no associativity) : imp_scope.
Notation "x && y" := (BAnd x y) (at level 40, left associativity) : imp_scope.
Notation "'~' b" := (BNot b) (at level 75, right associativity) : imp_scope.
Definition example_aexp := (3 + (X * 2))%imp : aexp.
Definition example_bexp := (true && ~(X <= 4))%imp : bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x (* <--- NEW *)
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.
Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval st a1) =? (aeval st a2)
  | BLe a1 a2 => (aeval st a1) <=? (aeval st a2)
  | BNot b1 => negb (beval st b1)
  | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  end.

Definition empty_st := (_ !-> 0).

Notation "a '!->' x" := (t_update empty_st a x) (at level 100).

Inductive com : Type :=
| CSkip
| CAss (x: string) (a: aexp)
| CSeq (c1 c2: com)
| CIf (b: bexp) (c1 c2: com)
| CWhile (b: bexp) (c: com).

Bind Scope imp_scope with com.
Notation "'SKIP'" :=
   CSkip : imp_scope.
Notation "x '::=' a" :=
  (CAss x a) (at level 60) : imp_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : imp_scope.
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity) : imp_scope.
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity) : imp_scope.

Definition fact_in_coq : com :=
  (Z ::= X;;
  Y ::= 1;;
  WHILE ~(Z = 0) DO
    Y ::= Y * Z;;
    Z ::= Z - 1
  END)%imp.

Unset Printing Notations.
Print fact_in_coq.

Set Printing Notations.

Locate "&&".

Locate aexp.

(* examples *)

Definition plus2: com :=
  X ::= X + 2.

Definition XtimeYinZ: com :=
  Z ::= X * Y.

Definition subtract_slowly_body: com :=
  Z ::= Z - 1 ;;
  X ::= X - 1.

Definition subtract_slowly: com :=
  (WHILE ~(X = 0) DO
         subtract_slowly_body
  END)%imp.

Definition subtract_3_from_5_slowly: com :=
  X ::= 3 ;;
  Z ::= 5 ;;
  subtract_slowly_body.

Definition loop : com :=
  WHILE true DO
    SKIP
  END.

Reserved Notation "st '=[' c ']=>' st'"
         (at level 40).

Inductive ceval: com -> state -> state -> Prop :=
| E_Skip: forall st,
    st =[ SKIP ]=> st
| E_Ass: forall st a1 n x,
    aeval st a1 = n ->
    st =[ x ::= a1 ]=> (x !-> n ; st)
| E_Seq: forall c1 c2 st st' st'',
    st =[ c1 ]=> st' ->
    st' =[ c2 ]=> st'' ->
    st =[ c1 ;; c2 ]=> st''
| E_IfTrue: forall st st' b1 c1 c2,
    beval st b1 = true ->
    st =[ c1 ]=> st' ->
    st =[ TEST b1 THEN c1 ELSE c2 FI ]=> st'
| E_IfFalse: forall st st' b1 c1 c2,
    beval st b1 = false ->
    st =[ c2 ]=> st' ->
    st =[ TEST b1 THEN c1 ELSE c2 FI ]=> st'
| E_WhileFalse: forall st b c,
    beval st b = false ->
    st =[ WHILE b DO c END ]=> st
| E_WhileTrue: forall st st' st'' b c,
    beval st b = true ->
    st =[ c ]=> st' ->
    st' =[ WHILE b DO c END ]=> st'' ->
    st =[ WHILE b DO c END ]=> st''
where "st =[ c ]=> st'" := (ceval c st st').

Example ceval_example1:
  empty_st =[
    X ::= 2;;
    TEST X <= 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  - apply E_Ass. reflexivity.
  - apply E_IfFalse. reflexivity.
    apply E_Ass. reflexivity.
Qed.

Hint Constructors ceval.
Hint Transparent state.
Hint Transparent total_map.

Example ceval_example2:
  empty_st =[
    X ::= 0 ;; Y ::= 1 ;; Z ::= 2
  ]=> (Z !-> 2; Y !-> 1; X !-> 0).
Proof.
  eapply E_Seq.
  - apply E_Ass. reflexivity.
  - eauto.
Qed.

Ltac inv H := inversion H; subst; clear H.

Ltac rwinv H1 H2 := rewrite H1 in H2; inv H2.

Ltac find_rwinv :=
  match goal with
    H1: ?E = true,
    H2: ?E = false
    |- _ => rwinv H1 H2
  end.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.

Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1;
    intros st2 E2; inv E2; try find_rwinv;
      repeat find_eqn; auto.
Qed.

(* Theorem plus2_spec: forall st n st', *)
(*     st X = n -> *)
(*     st =[ plus2 ]=> st' -> *)
(*     st' X = n + 2. *)
(* Proof. *)
(*   intros st n st' HX Heval. *)
(*   simpl. *)


Definition pull (T : Type) (P : T -> Prop) : Type := (forall x : T, P x) -> {x : T | P x}.
Definition existence (T : Type) : Type := {x : T | True}.

Theorem cannot_pull : (forall T P, pull T P) -> False.
Proof.
  unfold pull.
  intros.
  specialize (X False (fun _=> False)).
  simpl in X.
  destruct X.
  intros.
  assumption.
  assumption.
  Show Proof.
 Qed.

Theorem but_why : exists T P, pull T P -> False.
Proof.
  exists False, (fun _ => False).
  unfold pull.
  intros.
  destruct H.
  intros. assumption.
  assumption.
Qed.

Theorem can_pull_if_existence : forall T, existence T -> (forall P, pull T P).
Proof.
  unfold existence.
  unfold pull.
  intros.
  destruct X.
  exists x.
  apply H.
Qed.

Theorem existence_if_can_pull : forall T, (forall P, pull T P) -> existence T.
Proof.
  unfold existence.
  unfold pull.
  intros.
  specialize (X (fun _ => True)).
  simpl in X.
  apply X.
  intro.
  apply I.
Qed.


(** * Subsequences

Authors:
    - Jim Portegies

This file is part of Waterproof-lib.

Waterproof-lib is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Waterproof-lib is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)

Require Import Reals.
Require Import ZArith.
Require Import Lra.
Require Import Classical.
Require Import Classical_Pred_Type.
Require Import ClassicalChoice.

Require Import Waterproof.AllTactics.
Require Import Waterproof.populate_database.waterproof_integers.
Require Import Waterproof.load_database.RealsAndIntegers.
Require Import Waterproof.notations.notations.
Require Import Waterproof.set_search_depth.To_5.
Require Import Waterproof.set_intuition.Disabled.
Require Import Waterproof.load_database.DisableWildcard.

(* TODO: this shouldn't really be here ... *)
Require Import Waterproof.populate_database.all_databases.

#[export] Hint Resolve Rabs_Rabsolu : reals.
(** ## Creating a subsequence of elements satisfying a certain property

The purpose of this section is to provide a somewhat general strategy to construct subsequences of elements satisfying a certain property. *)
(** ### From existence of a next element to a function producing this element

The next lemma is quite technical, and is usually not so visible in classical analysis. We rely here on a version of the axiom of choice.*)
Lemma existence_next_el_to_fun :
    ∀ (a : ℕ → ℝ) (P : ℕ → ℝ → Prop),
    (∀ (m : ℕ) (N : ℕ), ∃ k : ℕ, (N ≤ k)%nat ∧ (P m (a k))) ⇒
      ∃ f : ℕ → ℕ → ℕ, ∀ (m : ℕ) (N : ℕ), (N ≤ f m N)%nat ∧ P m (a (f m N)).
Proof.
    Take a : (ℕ → ℝ).
    Take P : (ℕ → ℝ → Prop).
    Assume that (for all m N : ℕ, there exists k : ℕ , (N ≤ k)%nat ∧ P m (a k)).
    We claim that (∀ (m : ℕ),  ∃ g : ℕ → ℕ, ∀ N : ℕ, (N ≤ g N)%nat ∧ (P m (a (g N)))).
    {
        Take m : ℕ.
        apply choice with (R := fun (k : ℕ) (l : ℕ) ↦ ((k ≤ l)%nat ∧ P m (a l))).
        We conclude that (for all x : ℕ, there exists y : ℕ, (x ≤ y)%nat ∧ P m (a y)).
    }
    apply choice with (R := fun (m : ℕ) (h : ℕ → ℕ) ↦ ( ∀ N : ℕ, (N ≤ h N)%nat ∧ P m (a (h N)) ) ).
    We conclude that (for all x : ℕ, there exists y : ℕ ⇨ ℕ , for all N : ℕ, (N ≤ y N)%nat ∧ P x (a (y N))).
Qed.

(** The next definition captures what it means to be an index sequence.*)
Definition is_index_seq (n : ℕ → ℕ) :=
    ∀ k : ℕ, (n k < n (S k))%nat.
(** Given the function that produces 'good' elements, we can use it to construct a subsequence by induction.*)
Fixpoint create_seq
  (f : ℕ → ℕ → ℕ) (l : ℕ) :=
  match l with
  | O => f O O
  | S k => f l (S (create_seq f k))
  end.

(** If the function that produces 'good' elements is such that the produced elements are far enough in the sequence, it is certain that the produced sequence is an index sequence.*)
Lemma created_seq_is_index_seq :
  ∀ (g : ℕ → ℕ → ℕ),
    (∀ (m N : ℕ), (g m N ≥ N)%nat ) ⇒
      is_index_seq (create_seq g).
Proof.
    Take g : (ℕ → ℕ → ℕ).
    Assume that (∀ (m N : ℕ), (g m N ≥ N)%nat) (i).
    Expand the definition of is_index_seq.
    That is, write the goal as (for all k : ℕ, (create_seq g k < create_seq g (S k))%nat).
    Take k : ℕ.
    By (i) it holds that (g (S k) (S (create_seq g k)) ≥ S(create_seq g k))%nat.
    We conclude that (& create_seq g k < g (S k) (S (create_seq g k)) = create_seq g (S k))%nat.
Qed.

(**
The next lemma records that indeed the elements in the subsequence satisfy the desired property.*)
Lemma subseq_sat_rel :
  ∀ (a : ℕ → ℝ) (g : ℕ → ℕ → ℕ) (P : ℕ → ℝ → Prop),
    (∀ m N : ℕ, P m (a (g m N)) ) ⇒
      ∀ k : ℕ, P k (a (create_seq g k)).
Proof.
    Take a : (ℕ → ℝ).
    Take g : (ℕ → ℕ → ℕ).
    Take P : (ℕ → ℝ → Prop).
    Assume that (∀ m N : ℕ, P m (a (g m N))) (i).
    induction k. (*TODO: if we use 'We use induction on k.'-tacftic, then we cannot directly match on k + 1 *)
    - We need to show that (P 0%nat (a (g 0%nat 0%nat))).
      By (i) we conclude that (P 0%nat (a (g 0%nat 0%nat))).
    - We need to show that (P (S k) (a (g (S k) (S (create_seq g k))))).
      By (i) we conclude that (P (S k) (a (g (S k) (S (create_seq g k))))).
Qed.

Lemma exists_good_subseq :
  ∀ (a : ℕ → ℝ) (P : ℕ → ℝ → Prop),
    (∀ (m : ℕ) (N : ℕ), ∃ k : ℕ, (N ≤ k)%nat ∧ (P m (a k))) ⇒
      ∃ n : ℕ → ℕ, is_index_seq n ∧ ∀ k : ℕ, P k (a (n k)).
Proof.
    Take a : (ℕ → ℝ).
    Take P : (ℕ → ℝ → Prop).
    Assume that (for all m N : ℕ, there exists k : ℕ , (N ≤ k)%nat ∧ P m (a k)).
    By existence_next_el_to_fun it holds that
      (∃ g : ℕ → ℕ → ℕ, ∀ (m : ℕ) (N : ℕ), (N ≤ g m N)%nat ∧ P m (a (g m N))) (i).
    Obtain g according to (i), so for g : ℕ → ℕ → ℕ it holds that
      (∀ (m : ℕ) (N : ℕ), (N ≤ g m N)%nat ∧ P m (a (g m N))) (ii).
    Choose n := (create_seq g).
    We show both statements.
    - We need to show that (is_index_seq n).
      We need to show that (is_index_seq (create_seq g)).
      By created_seq_is_index_seq it suffices to show that
        (for all m N : ℕ, (g m N ≥ N)%nat).
      Take m, M : nat.
      By (ii) it holds that ((M ≤ g m M)%nat ∧ P m (a (g m M))).
      We conclude that (g m M >= M)%nat.
    - We need to show that (for all k : ℕ, P k (a (n k))).
      We need to show that (for all k : ℕ, P k (a ((create_seq g) k))).
      Fail By subseq_sat_rel it suffices to show that (for all m N : ℕ, P m (a (g m N))). (*TODO: fix*)
      apply subseq_sat_rel.
      Take m : ℕ.
      Take M : ℕ.
      By (ii) it holds that ((M ≤ g m M)%nat ∧ P m (a (g m M))) (iii).
      Because (iii) both (M ≤ g m M)%nat and (P m (a (g m M))) hold.
      We conclude that (P m (a (g m M))).
Qed.

Definition is_increasing (f : ℕ → ℕ) :=
  ∀ k : ℕ, (f k ≤ f (S k))%nat.
Lemma incr_loc_to_glob :
  ∀ g : ℕ → ℕ,
    is_increasing g
      ⇒ (∀ k l : ℕ, (k ≤ l)%nat ⇒ (g k ≤ g l)%nat).
Proof.
    Take g : (ℕ → ℕ).
    Expand the definition of is_increasing.
    That is, write the goal as ((for all k : ℕ, (g k ≤ g (S k))%nat)
      ⇨ for all k l : ℕ, (k ≤ l)%nat ⇨ (g k ≤ g l)%nat).
    Assume that (∀ k : ℕ, (g k ≤ g (S k))%nat).
    Take k : ℕ.
    induction l as [|l IH_l].

    (** We first need to show that if $k \leq 0$ then $(f (k) \leq f(0))$.*)
    Assume that (k ≤ 0)%nat.
    It holds that (k = 0)%nat.
    We conclude that (& g k = g 0 <= g 0)%nat.

    (** Next, we need to show that if $k \leq S (l)$ then $f(k) \leq f(S (l))$.*)
    Assume that (k ≤ S l)%nat.
    destruct (lt_eq_lt_dec k (S l)) as [temp | k_gt_Sl].
    destruct temp as [k_lt_Sl | k_eq_Sl].
    (** We first consider the case that $k < S(l)$.*)
    It holds that (k ≤ l)%nat.
    By IH_l it holds that (g k ≤ g l)%nat.
    It holds that (g l ≤ g (S l))%nat.
    We conclude that (g k <= g (S l))%nat.
    (** We now consider the case $k = S(l)$. We need to show that $f(k) \leq f(S(l))$. *)
    We conclude that (& g k = g (S l) <= g (S l))%nat.
    (** Finally we consider the case $k > S(l)$. However, this case is in contradiction with $k \leq S(l)$. *)
    It holds that (¬(S l < k)%nat).
    Contradiction.
Qed.

Lemma index_seq_strictly_incr :
  ∀ n : ℕ → ℕ, is_index_seq n ⇒ (is_increasing (fun (k : ℕ) ↦ (n k - k)%nat)).
Proof.
    Take n : (ℕ → ℕ); such that (is_index_seq n) (i).
    Expand the definition of is_increasing.
    That is, write the goal as (for all k : ℕ, (n k - k ≤ n (S k) - S k)%nat).
    Take k : ℕ.
    Expand the definition of is_index_seq in (i).
    That is, write (i) as (for all k0 : ℕ, (n k0 < n (S k0))%nat).
    It holds that (n k < n (S k))%nat.
    We conclude that (n k - k ≤ n (S k) - S k)%nat.
Qed.

Lemma index_seq_grows_0 :
  ∀ n : ℕ → ℕ, is_index_seq n ⇒ ∀ k : ℕ, (n k ≥ k)%nat.
Proof.
    Take n : (ℕ → ℕ); such that (is_index_seq n) (i).
    induction k as [|k IH].
    - We conclude that (n 0 >= 0)%nat.
    - Expand the definition of is_index_seq in (i).
      That is, write (i) as (for all k0 : ℕ, (n k0 < n (S k0))%nat).
      It holds that (n k < n (S k))%nat.
      We conclude that (n (S k) ≥ S k)%nat.
Qed.

Lemma index_seq_grows :
  ∀ n : ℕ → ℕ, is_index_seq n ⇒ (∀ k l : ℕ, (k ≤ l)%nat ⇒ (n k - k ≤ n l - l)%nat).
Proof.
    Take n : (ℕ → ℕ); such that (is_index_seq n).
    Define g := (fun (k : ℕ) ↦ (n k - k)%nat).
    By index_seq_strictly_incr it holds that (is_increasing g).
    By incr_loc_to_glob it holds that (∀ k l : ℕ, (k ≤ l)%nat ⇒ (g k ≤ g l)%nat).
    Take k : ℕ and l : ℕ; such that(k ≤ l)%nat.
    We need to show that (g k <= g l)%nat.
    We conclude that (g k <= g l)%nat.
Qed.

(** ## Constructing a subsequence with elements satisfying a particular property

Given a property $P : \mathbb{N} → \mathbb{R} → \mathrm{Prop}$, and given that it holds for infinitely many elements in the sequence, we want to find a subsequence with all elements satisfying the property. *)
(** ### Finding the smallest element satisfying the property

This seems to require some decidability on the property*)
Fixpoint first_satisfying_element_helper
  (rel : ℕ → ℕ → bool)
  (k : ℕ)
  (N : ℕ) :=
  match k with
  | O => N
  | S l => if (rel (N-k)%nat (N-k)%nat)
                then k
                else (first_satisfying_element_helper rel l N)
  end.
Definition first_satisfying_element
  (rel : ℕ → ℕ → bool)
  (l : ℕ)
  (N : ℕ)
  := first_satisfying_element_helper rel (N-l) N.
(** ### From infinitely many elements to a function producing those elements*)
Lemma inf_el_to_fun :
  ∀ (a : ℕ → ℝ) (P : ℕ → ℝ → Prop),
    (∀ N : ℕ, ∃ k : ℕ, (N ≤ k)%nat ∧ (P N (a k))) ⇒
      ∃ f : ℕ → ℕ, ∀ l : ℕ, (l ≤ f l)%nat ∧ P l (a (f l)).
Proof.
    Take a : (ℕ → ℝ).
    Take P : (ℕ → ℝ → Prop).
    apply choice with (R := fun (k : ℕ) (l : ℕ) ↦ ((k ≤ l)%nat ∧ P k (a l))).
Qed.

Fixpoint seq_of_max (f : ℕ → ℕ) (l : ℕ) :=
  match l with
  | O => f O
  | S k => Nat.max (f l) (seq_of_max f k)
  end.

(** ### The sequence of maxima is increasing*)
Lemma seq_of_max_is_increasing :
  ∀ g : ℕ → ℕ, is_increasing (seq_of_max g).
Proof.
    Take g : (ℕ → ℕ).
    Expand the definition of is_increasing.
    That is, write the goal as (for all k : ℕ, (seq_of_max g k ≤ seq_of_max g (S k))%nat).
    Take k : ℕ.
    We need to show that (seq_of_max g k ≤ Nat.max (g (S k)) (seq_of_max g k))%nat.
    We conclude that (seq_of_max g k ≤ Nat.max (g (S k)) (seq_of_max g k))%nat.
Qed.

Lemma elements_le_seq_of_max_pre :
  ∀ (g : ℕ → ℕ) (n : ℕ),
    (g n ≤ seq_of_max g n)%nat.
Proof.
    Take g : (ℕ → ℕ).
    induction n as [|n IH_n].
    (** We first consider the base case $n=0$.*)
    Expand the definition of seq_of_max.
    That is, write the goal as ((g 0 ≤ g 0)%nat).
    (** We need to show that $f( 0 ) \leq f( 0)$.*)
    We conclude that (g 0 ≤ g 0)%nat.
    (** Next we consider the general case. We need to show that $f(S(n))\leq \mathsf{seqofmax}(f, S(n))$. *)
    Expand the definition of seq_of_max.
    That is, write the goal as ((g (S n) ≤ Nat.max (g (S n))
     ((fix seq_of_max (f : ℕ ⇨ ℕ) (l : ℕ) {struct l} : ℕ :=
         match l with
         | 0 => f 0
         | S k => Nat.max (f l) (seq_of_max f k)
         end) g n))%nat).
    (** By the definition of $\mathsf{seqofmax}(f,S(n))$ as the maximum of $f(S(n))$ and another number, this*)
    We conclude that (g (S n) ≤ Nat.max (g (S n))
     ((fix seq_of_max (f : ℕ ⇨ ℕ) (l : ℕ) {struct l} : ℕ :=
         match l with
         | 0 => f 0
         | S k => Nat.max (f l) (seq_of_max f k)
         end) g n))%nat.
Qed.

Lemma elements_le_seq_of_max :
  ∀ (g : ℕ → ℕ) (n : ℕ) (k : ℕ),
    (k ≤ n)%nat ⇒ (g k ≤ seq_of_max g n)%nat.
Proof.
    Take g : (ℕ → ℕ).
    Take n : ℕ and k : ℕ; such that (k ≤ n)%nat.
    By elements_le_seq_of_max_pre it holds that (g k ≤ seq_of_max g k)%nat.
    We claim that (seq_of_max g k ≤ seq_of_max g n)%nat.
    { By incr_loc_to_glob it suffices to show that (is_increasing (seq_of_max g)).
      By seq_of_max_is_increasing we conclude that (is_increasing (seq_of_max g)).
    }
    We conclude that (& g k <= seq_of_max g k <= seq_of_max g n)%nat.
Qed.

(** ### From a function producing the correct elements to an index sequence*)
Fixpoint build_seq
  (f : ℕ → ℕ)
  (k : ℕ) :=
  match k with
  | O => f O
  | S m => f (S (seq_of_max f (build_seq f m)))
  end.
Lemma built_seq_is_index_seq :
  ∀ g : ℕ → ℕ,
    (∀ k : ℕ, (g k ≥ k)%nat) ⇒
      is_index_seq (build_seq g).
Proof.
    Take g : (ℕ → ℕ).
    Assume that (for all k : ℕ, (g k ≥ k)%nat).
    Expand the definition of is_index_seq.
    That is, write the goal as (for all k : ℕ, (build_seq g k < build_seq g (S k))%nat).
    Take k : ℕ.
    We need to show that (build_seq g k < g (S (seq_of_max g (build_seq g k))))%nat.
    It holds that (g( S(seq_of_max g (build_seq g k)))≥ S(seq_of_max g (build_seq g k)))%nat.
    It holds that (g( S(seq_of_max g (build_seq g k)))> seq_of_max g (build_seq g k))%nat.
    By elements_le_seq_of_max_pre it holds that (seq_of_max g (build_seq g k) ≥ g(build_seq g k))%nat.
    It holds that (g(build_seq g k) ≥ build_seq g k)%nat.
    We conclude that (& build_seq g k <= g(build_seq g k)
                                      <= seq_of_max g (build_seq g k)
                                      <  g( S(seq_of_max g (build_seq g k))))%nat.
Qed.
(** ### Subsequence satisfies relation*)


(** Based on Benjamin Pierce's "Software Foundations" *)

Require Import List.
Import ListNotations.
Require Import Omega.
Require Export Arith Arith.EqNat.
Require Export Id.

From hahn Require Import HahnBase.

Section S.

  Variable A : Set.

  Definition state := list (id * A).

  Reserved Notation "st / x => y" (at level 0).

  Inductive st_binds : state -> id -> A -> Prop :=
    st_binds_hd : forall st id x, ((id, x) :: st) / id => x
  | st_binds_tl : forall st id x id' x', id <> id' -> st / id => x -> ((id', x')::st) / id => x
  where "st / x => y" := (st_binds st x y).

  Definition update (st : state) (id : id) (a : A) : state := (id, a) :: st.

  Notation "st [ x '<-' y ]" := (update st x y) (at level 0).

  Lemma state_deterministic (st : state) (x : id) (n m : A)
        (SN : st / x => n)
        (SM : st / x => m) :
    n = m.
  Proof.
    induction st; inversion SN; subst.
    all: inversion SM; desf.
    apply IHst; desf.
  Qed.

  Lemma update_eq (st : state) (x : id) (n : A) :
    st [x <- n] / x => n.
  Proof. unfold update. constructor. Qed.

  Lemma update_neq (st : state) (x2 x1 : id) (n m : A)
        (NEQ : x2 <> x1) : st / x1 => m <-> st [x2 <- n] / x1 => m.
  Proof.
    split; intros HH.
    { unfold update. apply st_binds_tl; auto. }
    unfold update in HH. inv HH.
  Qed.

  Lemma update_shadow (st : state) (x1 x2 : id) (n1 n2 m : A) :
    st[x2 <- n1][x2 <- n2] / x1 => m <-> st[x2 <- n2] / x1 => m.
  Proof.
    split; intros HH.
    { unfold update in HH.
      inv HH.
      { apply update_eq. }
      inv H5. apply update_neq; auto. }
    inv HH.
    { apply update_eq. }
    repeat (apply update_neq; auto).
  Qed.

  Lemma update_same (st : state) (x1 x2 : id) (n1 m : A)
        (SN : st / x1 => n1)
        (SM : st / x2 => m) :
    st [x1 <- n1] / x2 => m.
  Proof.
    destruct (id_eq_dec x1 x2) as [|NEQ]; subst.
    2: by apply update_neq.
    assert (m = n1); subst.
    2: by apply update_eq.
    eapply state_deterministic; eauto.
  Qed.

  Lemma update_permute (st : state) (x1 x2 x3 : id) (n1 n2 m : A)
        (NEQ : x2 <> x1)
        (SM : st [x2 <- n1][x1 <- n2] / x3 => m) :
    st [x1 <- n2][x2 <- n1] / x3 => m.
  Proof.
    destruct (id_eq_dec x1 x3) as [|NN]; subst.
    { apply update_neq; auto.
      inv SM. apply update_eq. }
    destruct (id_eq_dec x2 x3) as [|AA]; subst.
    { inv SM. inv H5. apply update_eq. }
    repeat (apply update_neq; auto).
    inv SM. inv H5.
  Qed.

End S.


Require Import Bmc.Example.
Require Import Bmc.PDR.

Require Import SMTC.Tactic.
Require Import SMTC.Integers.

Definition r1 (i:nat) (s:state) :=
  match i with
  | O => ex1_I s
  | _ => (s >= 1)%Z
  end.

Axiom a1 : forall s:state, (s >= 4)%Z -> ((s*2+1) mod 8 >= 1)%Z.

Axiom a2 : forall s:state, (s >= 1)%Z -> ((s*2+1) mod 8 >= 1)%Z.

Goal pdr_post_t ex1_I ex1_T ex1_P r1 1.
Proof.
  unfold pdr_post_t.
  repeat split; intros.
  - destruct i; simpl.
    + apply H.
    + unfold ex1_I in H.
      omega.
  - unfold ex1_P.
    destruct i;
    simpl in H; unfold ex1_I in H;
    contradict H;
    rewrite -> H;
    omega.
  - destruct i;
    simpl in *;
    unfold ex1_I in H;
    omega.
  - destruct H0.
    simpl.
    destruct i;
    unfold ex1_T in H1;
    rewrite <- H1;
    simpl in H0; unfold ex1_I in H0.
    + apply a1. omega.
    + apply a2. omega.
  - simpl in *. apply H.
  - simpl in *. apply H.
Qed.


From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import function.

Section FunctionCharacteristic.

  Variable U:Type.
  Variables one zero: U.
  Variables a b c d: U.

  Definition A := {|a,b,c|}.

  Check In U A a.

  Goal In U A a.
  Proof.
    unfold In.
    unfold A.
    left.
    left.
    apply singleton_eq_iff.
    reflexivity.
  Qed.

  Check In U A a.
  Check (forall (X:Ensemble U) (x:U), {In U X x} + {~In U X x}).

  Axiom in_set_dec: forall (X:Ensemble U) (x:U), {In U X x} + {~In U X x}.

  Definition c_fun (X:Ensemble U) (x:U) : U :=
    match in_set_dec X x with
    | left _ => one
    | right _ => zero
    end.

  Definition cast_fun (X:Ensemble U) (x:U) : nat :=
    match in_set_dec X x with
    | left _ => 1
    | right _ => 0
    end.

  Goal c_fun A a = one.
  Proof.
    unfold c_fun.
    destruct (in_set_dec A a).
    reflexivity.
    move : n.
    case.
    left.
    left.
    apply singleton_eq_iff.
    reflexivity.
  Qed.

  Goal a <> d /\ b <> d /\ c <> d -> c_fun A d = zero.
  Proof.
    case => Had [Hbd Hcd].
    unfold c_fun.
    destruct (in_set_dec A d) as [H|H].
    have: ~d ∈ A.
    unfold A.
    unfold not.
    move => H0.
    inversion H0.
    inversion H1.
    apply singleton_eq_iff in H3.
    apply eq_sym in H3.
    move: H3.
    apply Had.
    apply singleton_eq_iff in H3.
    apply eq_sym in H3.
    move: H3.
    apply Hbd.
    apply singleton_eq_iff in H1.
    apply eq_sym in H1.
    move: H1.
    apply Hcd.
    case.
    apply H.
    reflexivity.
  Qed.
End FunctionCharacteristic.


Require Export euclidean__axioms.
Require Export lemma__equalitysymmetric.
Definition lemma__inequalitysymmetric : forall A B, (euclidean__axioms.neq A B) -> (euclidean__axioms.neq B A).
Proof.
intro A.
intro B.
intro H.
assert (* Cut *) (~(B = A)) as H0.
- intro H0.
assert (* Cut *) (A = B) as H1.
-- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric A B H0).
-- apply (@H H1).
- exact H0.
Qed.


Require Import rt.util.all.
Require Import rt.model.basic.task rt.model.basic.job rt.model.basic.schedule
               rt.model.basic.task_arrival rt.model.basic.platform rt.model.basic.response_time
               rt.model.basic.workload rt.model.basic.priority rt.model.basic.schedulability
               rt.model.basic.interference rt.model.basic.interference_edf.
Require Import rt.analysis.parallel.workload_bound rt.analysis.parallel.interference_bound.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop div path.

Module InterferenceBoundEDF.

  Import Job SporadicTaskset Schedule ScheduleOfSporadicTask Schedulability
         WorkloadBound ResponseTime Priority
         SporadicTaskArrival Interference InterferenceEDF.
  Export InterferenceBoundGeneric.

  (* In this section, we define Bertogna and Cirinei's EDF-specific
     interference bound. *)
  Section SpecificBoundDef.

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

    (* Let tsk be the task to be analyzed. *)
    Variable tsk: sporadic_task.

    (* Consider the interference incurred by tsk in a window of length delta... *)
    Variable delta: time.

    (* due to a different task tsk_other, with response-time bound R_other. *)
    Variable tsk_other: sporadic_task.
    Variable R_other: time.

    (* Bertogna and Cirinei define the following bound for task interference
       under EDF scheduling. *)
    Definition edf_specific_interference_bound :=
      let d_tsk := task_deadline tsk in
      let e_other := task_cost tsk_other in
      let p_other := task_period tsk_other in
      let d_other := task_deadline tsk_other in
        (div_ceil (d_tsk + R_other - d_other + 1) p_other) * e_other.

  End SpecificBoundDef.

  (* Next, we define the total interference bound for EDF, which combines the generic
     and the EDF-specific bounds. *)
  Section TotalInterferenceBoundEDF.

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

    (* Let tsk be the task to be analyzed. *)
    Variable tsk: sporadic_task.

    Let task_with_response_time := (sporadic_task * time)%type.

    (* Assume a known response-time bound for each interfering task ... *)
    Variable R_prev: seq task_with_response_time.

    (* ... and an interval length delta. *)
    Variable delta: time.

    Section PerTask.

      Variable tsk_R: task_with_response_time.
      Let tsk_other := fst tsk_R.
      Let R_other := snd tsk_R.

      (* By combining Bertogna's interference bound for a work-conserving
         scheduler ... *)
      Let basic_interference_bound := interference_bound_generic task_cost task_period delta tsk_R.

      (* ... with and EDF-specific interference bound, ... *)
      Let edf_specific_bound := edf_specific_interference_bound task_cost task_period task_deadline tsk tsk_other R_other.

      (* Bertogna and Cirinei define the following interference bound
         under EDF scheduling. *)
      Definition interference_bound_edf :=
        minn basic_interference_bound edf_specific_bound.

    End PerTask.

    Section AllTasks.

      Let interferes_with_tsk := jldp_can_interfere_with tsk.

      (* The total interference incurred by tsk is bounded by the sum
         of individual task interferences. *)
      Definition total_interference_bound_edf :=
        \sum_((tsk_other, R_other) <- R_prev | interferes_with_tsk tsk_other)
           interference_bound_edf (tsk_other, R_other).

    End AllTasks.

  End TotalInterferenceBoundEDF.

  (* In this section, we show that the EDF-specific interference bound is safe. *)
  Section ProofSpecificBound.

    Import Schedule Interference Platform SporadicTaskset.

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

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

    (* Assume any job arrival sequence... *)
    Context {arr_seq: arrival_sequence Job}.

    (* ... in which jobs arrive sporadically and have valid parameters. *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period arr_seq job_task.
    Hypothesis H_valid_job_parameters:
      forall (j: JobIn arr_seq),
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Consider any schedule such that...*)
    Variable num_cpus: nat.
    Variable sched: schedule num_cpus arr_seq.

    (* ...jobs do not execute before their arrival times nor longer
       than their execution costs. *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute sched.
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* Assume there exists at least one processor. *)
    Hypothesis H_at_least_one_cpu :
      num_cpus > 0.

    (* Assume that we have a task set where all tasks have valid
       parameters and constrained deadlines. *)
    Variable ts: taskset_of sporadic_task.
    Hypothesis all_jobs_from_taskset:
      forall (j: JobIn arr_seq), job_task j \in ts.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.
    Hypothesis H_constrained_deadlines:
      forall tsk, tsk \in ts -> task_deadline tsk <= task_period tsk.

    Let no_deadline_is_missed_by_tsk (tsk: sporadic_task) :=
      task_misses_no_deadline job_cost job_deadline job_task sched tsk.
    Let response_time_bounded_by (tsk: sporadic_task) :=
      is_response_time_bound_of_task job_cost job_task tsk sched.

    (* Assume that the scheduler is a work-conserving EDF scheduler. *)
    Hypothesis H_work_conserving: work_conserving job_cost sched.
    Hypothesis H_edf_scheduler:
      enforces_JLDP_policy job_cost sched (EDF job_deadline).

    (* Let tsk_i be the task to be analyzed, ...*)
    Variable tsk_i: sporadic_task.
    Hypothesis H_tsk_i_in_task_set: tsk_i \in ts.

    (* and j_i one of its jobs. *)
    Variable j_i: JobIn arr_seq.
    Hypothesis H_job_of_tsk_i: job_task j_i = tsk_i.

    (* Let tsk_k denote any interfering task, ... *)
    Variable tsk_k: sporadic_task.
    Hypothesis H_tsk_k_in_task_set: tsk_k \in ts.

    (* ...and R_k its response-time bound. *)
    Variable R_k: time.
    Hypothesis H_R_k_le_deadline: R_k <= task_deadline tsk_k.

    (* Consider a time window of length delta <= D_i, starting with j_i's arrival time. *)
    Variable delta: time.
    Hypothesis H_delta_le_deadline: delta <= task_deadline tsk_i.

    (* Assume that the jobs of tsk_k satisfy the response-time bound before the end of the interval *)
    Hypothesis H_all_previous_jobs_completed_on_time :
      forall (j_k: JobIn arr_seq),
        job_task j_k = tsk_k ->
        job_arrival j_k + R_k < job_arrival j_i + delta ->
        completed job_cost sched j_k (job_arrival j_k + R_k).

    (* In this section, we prove that Bertogna and Cirinei's EDF interference bound
       indeed bounds the interference caused by task tsk_k in the interval [t1, t1 + delta). *)
    Section MainProof.

      (* Let's call x the task interference incurred by job j due to tsk_k. *)
      Let x :=
        task_interference job_cost job_task sched j_i
                          tsk_k (job_arrival j_i) (job_arrival j_i + delta).

      (* Also, recall the EDF-specific interference bound for EDF. *)
      Let interference_bound :=
        edf_specific_interference_bound task_cost task_period task_deadline tsk_i tsk_k R_k.

      (* Let's simplify the names a bit. *)
      Let t1 := job_arrival j_i.
      Let t2 := job_arrival j_i + delta.
      Let D_i := task_deadline tsk_i.
      Let D_k := task_deadline tsk_k.
      Let p_k := task_period tsk_k.

      Let n_k := div_ceil (D_i + R_k - D_k + 1) p_k.

      (* Let's give a simpler name to job interference. *)
      Let interference_caused_by := job_interference job_cost sched j_i.

      (* Identify the subset of jobs that actually cause interference *)
      Let interfering_jobs :=
        filter (fun (x: JobIn arr_seq) =>
                 (job_task x == tsk_k) && (interference_caused_by x t1 t2 != 0))
               (jobs_scheduled_between sched t1 t2).

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

      (* Now we proceed with the proof.
         The first step consists in simplifying the sum corresponding to the workload. *)
      Section SimplifyJobSequence.

        (* Use the alternative definition of task interference, based on
           individual job interference. *)
        Lemma interference_bound_edf_use_another_definition :
          x <= \sum_(j <- jobs_scheduled_between sched t1 t2 | job_task j == tsk_k)
                interference_caused_by j t1 t2.
        Proof.
          unfold x, task_interference, interference_caused_by, job_interference.
          rewrite [\sum_(_ <- _ sched _ _ | _) _]exchange_big /=.
          rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
          apply leq_sum. move => t /andP [LEt _].
          rewrite exchange_big /=.
          apply leq_sum; intros cpu _.
          destruct (backlogged job_cost sched j_i t) eqn:BACK;
            last by rewrite andFb (eq_bigr (fun x => 0));
              first by rewrite big_const_seq iter_addn mul0n addn0.
          rewrite andTb.
          destruct (task_scheduled_on job_task sched tsk_k cpu t) eqn:SCHED;
            last by done.
          unfold task_scheduled_on in *.
          destruct (sched cpu t) eqn:SOME; last by done.
          rewrite big_mkcond /= (bigD1_seq j) /=; last by apply undup_uniq.
          {
            rewrite SCHED -addn1 addnC; apply leq_add; last by done.
            apply eq_leq; symmetry; apply/eqP; rewrite eqb1.
            by unfold scheduled_on; apply/eqP.
          }
          {
            unfold jobs_scheduled_between.
            rewrite mem_undup; apply mem_bigcat_nat with (j := t);
              first by done.
            apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
            by unfold make_sequence; rewrite SOME mem_seq1 eq_refl.
          }
        Qed.

        (* Remove the elements that we don't care about from the sum *)
        Lemma interference_bound_edf_simpl_by_filtering_interfering_jobs :
          \sum_(j <- jobs_scheduled_between sched t1 t2 | job_task j == tsk_k)
             interference_caused_by j t1 t2 =
          \sum_(j <- interfering_jobs) interference_caused_by j t1 t2.
        Proof.
          unfold interfering_jobs; rewrite big_filter.
          rewrite big_mkcond; rewrite [\sum_(_ <- _ | _) _]big_mkcond /=.
          apply eq_bigr; intros i _; clear -i.
          destruct (job_task i == tsk_k); rewrite ?andTb ?andFb; last by done.
          destruct (interference_caused_by i t1 t2 != 0) eqn:DIFF; first by done.
          by apply negbT in DIFF; rewrite negbK in DIFF; apply/eqP.
        Qed.

        (* Then, we consider the sum over the sorted sequence of jobs. *)
        Lemma interference_bound_edf_simpl_by_sorting_interfering_jobs :
          \sum_(j <- interfering_jobs) interference_caused_by j t1 t2 =
           \sum_(j <- sorted_jobs) interference_caused_by j t1 t2.
        Proof.
          by rewrite (eq_big_perm sorted_jobs) /=; last by rewrite -(perm_sort earlier_arrival).
        Qed.

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

        (* Also recall that all jobs in the sorted sequence is an interfering job of tsk_k, ... *)
        Lemma interference_bound_edf_all_jobs_from_tsk_k :
          forall j,
            j \in sorted_jobs ->
            job_task j = tsk_k /\
            interference_caused_by j t1 t2 != 0 /\
            j \in jobs_scheduled_between sched t1 t2.
        Proof.
          intros j LT.
          rewrite -interference_bound_edf_job_in_same_sequence mem_filter in LT.
          by move: LT => /andP [/andP [/eqP JOBi SERVi] INi]; repeat split.
        Qed.

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

        (* Also, for any job of task tsk_k, the interference is bounded by the task cost. *)
        Lemma interference_bound_edf_interference_le_task_cost :
          forall j,
            j \in interfering_jobs ->
            interference_caused_by j t1 t2 <= task_cost tsk_k.
        Proof.
          rename H_valid_job_parameters into PARAMS.
          intros j; rewrite mem_filter; move => /andP [/andP [/eqP JOBj _] _].
          specialize (PARAMS j); des.
          apply leq_trans with (n := service_during sched j t1 t2);
            first by apply job_interference_le_service.
          by apply cumulative_service_le_task_cost with (job_task0 := job_task)
                              (task_deadline0 := task_deadline) (job_cost0 := job_cost)
                                                        (job_deadline0 := job_deadline).
        Qed.

      End SimplifyJobSequence.

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

        Hypothesis H_few_jobs: size sorted_jobs <= n_k.

        Lemma interference_bound_edf_holds_for_at_most_n_k_jobs :
           \sum_(j <- sorted_jobs) interference_caused_by j t1 t2 <=
             interference_bound.
        Proof.
          unfold interference_bound, edf_specific_interference_bound; fold D_i p_k n_k.
          apply leq_trans with (n := \sum_(x <- sorted_jobs) task_cost tsk_k);
            last first.
          {
            rewrite big_const_seq iter_addn addn0 count_predT mulnC.
            by rewrite leq_mul2r; apply/orP; right.
          }
          {
            rewrite big_seq_cond [\sum_(_ <- _ | true)_]big_seq_cond.
            apply leq_sum; move => j /andP [IN _].
            apply interference_bound_edf_interference_le_task_cost.
            by rewrite interference_bound_edf_job_in_same_sequence.
          }
        Qed.

      End InterferenceFewJobs.

      (* Otherwise, assume that the number of jobs is larger than n_k >= 0. *)
      Section InterferenceManyJobs.

        Hypothesis H_many_jobs: n_k < size sorted_jobs.

        (* This trivially implies that there's at least one job. *)
        Lemma interference_bound_edf_at_least_one_job: size sorted_jobs > 0.
        Proof.
          by apply leq_ltn_trans with (n := n_k).
        Qed.

        (* Let j_fst be the first job, and a_fst its arrival time. *)
        Variable elem: JobIn arr_seq.
        Let j_fst := nth elem sorted_jobs 0.
        Let a_fst := job_arrival j_fst.

        (* In this section, we prove some basic lemmas about j_fst. *)
        Section FactsAboutFirstJob.

          (* The first job is an interfering job of task tsk_k. *)
          Lemma interference_bound_edf_j_fst_is_job_of_tsk_k :
            job_task j_fst = tsk_k /\
            interference_caused_by j_fst t1 t2 != 0 /\
            j_fst \in jobs_scheduled_between sched t1 t2.
          Proof.
            by apply interference_bound_edf_all_jobs_from_tsk_k, mem_nth,
                     interference_bound_edf_at_least_one_job.
          Qed.

          (* The deadline of j_fst is the deadline of tsk_k. *)
          Lemma interference_bound_edf_j_fst_deadline :
            job_deadline j_fst = task_deadline tsk_k.
          Proof.
            unfold valid_sporadic_job in *.
            rename H_valid_job_parameters into PARAMS.
            have FST := interference_bound_edf_j_fst_is_job_of_tsk_k.
            destruct FST as [FSTtask _].
            by specialize (PARAMS j_fst); des; rewrite PARAMS1 FSTtask.
          Qed.

          (* The deadline of j_i is the deadline of tsk_i. *)
          Lemma interference_bound_edf_j_i_deadline :
            job_deadline j_i = task_deadline tsk_i.
          Proof.
            unfold valid_sporadic_job in *.
            rename H_valid_job_parameters into PARAMS,
                   H_job_of_tsk_i into JOBtsk.
            by specialize (PARAMS j_i); des; rewrite PARAMS1 JOBtsk.
          Qed.

          (* If j_fst completes by its response-time bound, then t1 <= a_fst + R_k,
             where t1 is the beginning of the time window (arrival of j_i). *)
          Lemma interference_bound_edf_j_fst_completion_implies_rt_bound_inside_interval :
            completed job_cost sched j_fst (a_fst + R_k) ->
            t1 <= a_fst + R_k.
          Proof.
            intros RBOUND.
            rewrite leqNgt; apply/negP; unfold not; intro BUG.
            have FST := interference_bound_edf_j_fst_is_job_of_tsk_k.
            destruct FST as [_ [ FSTserv _]].
            move: FSTserv => /negP FSTserv; apply FSTserv.
            rewrite -leqn0; apply leq_trans with (n := service_during sched j_fst t1 t2);
              first by apply job_interference_le_service.
            rewrite leqn0; apply/eqP.
            by apply cumulative_service_after_job_rt_zero with (job_cost0 := job_cost) (R := R_k);
              try (by done); apply ltnW.
          Qed.

        End FactsAboutFirstJob.

        (* Now, let's prove the interference bound for the particular case of a single job.
           This case must be solved separately because the single job can simultaneously
           be carry-in and carry-out job, so its response time is not necessarily
           bounded by R_k (from the hypothesis H_all_previous_jobs_completed_on_time). *)
        Section InterferenceSingleJob.

          (* Assume that there's at least one job in the sorted list. *)
          Hypothesis H_only_one_job: size sorted_jobs = 1.

          Lemma interference_bound_edf_holds_for_a_single_job :
            interference_caused_by j_fst t1 t2 <= interference_bound.
          Proof.
            unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
            rename H_many_jobs into NUM,
                   H_valid_task_parameters into PARAMS,
                   H_only_one_job into SIZE.
            apply leq_trans with (n := task_cost tsk_k).
            {
              apply interference_bound_edf_interference_le_task_cost.
              rewrite interference_bound_edf_job_in_same_sequence.
              by apply mem_nth; rewrite SIZE.
            }
            {
              unfold interference_bound, edf_specific_interference_bound.
              rewrite -{1}[task_cost tsk_k]mul1n.
              rewrite leq_mul2r; apply/orP; right.
              exploit (PARAMS tsk_i); [by done | intro PARAMSi]; des.
              exploit (PARAMS tsk_k); [by done | intro PARAMSk]; des.
              apply ceil_neq0; last by done.
              rewrite -subnBA; last by done.
              by rewrite addn1 ltnS.
            }
          Qed.

        End InterferenceSingleJob.

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

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

          (* Let j_lst be the last job of the sequence and a_lst its arrival time. *)
          Let j_lst := nth elem sorted_jobs num_mid_jobs.+1.
          Let a_lst := job_arrival j_lst.

          (* In this section, we prove some basic lemmas about the first and last jobs. *)
          Section FactsAboutFirstAndLastJobs.

            (* The last job is an interfering job of task tsk_k. *)
            Lemma interference_bound_edf_j_lst_is_job_of_tsk_k :
              job_task j_lst = tsk_k /\
              interference_caused_by j_lst t1 t2 != 0 /\
              j_lst \in jobs_scheduled_between sched t1 t2.
            Proof.
              apply interference_bound_edf_all_jobs_from_tsk_k, mem_nth.
              by rewrite H_at_least_two_jobs.
            Qed.

            (* The deadline of j_lst is the deadline of tsk_k. *)
            Lemma interference_bound_edf_j_lst_deadline :
              job_deadline j_lst = task_deadline tsk_k.
            Proof.
              unfold valid_sporadic_job in *.
              rename H_valid_job_parameters into PARAMS.
              have LST := interference_bound_edf_j_lst_is_job_of_tsk_k.
              destruct LST as [LSTtask _].
              by specialize (PARAMS j_lst); des; rewrite PARAMS1 LSTtask.
            Qed.

            (* The first job arrives before the last job. *)
            Lemma interference_bound_edf_j_fst_before_j_lst :
              job_arrival j_fst <= job_arrival j_lst.
            Proof.
              rename H_at_least_two_jobs into SIZE.
              unfold j_fst, j_lst; rewrite -[num_mid_jobs.+1]add0n.
              apply prev_le_next; last by rewrite SIZE leqnn.
              by intros i LT; apply interference_bound_edf_jobs_ordered_by_arrival.
            Qed.

            (* The last job arrives before the end of the interval. *)
            Lemma interference_bound_edf_last_job_arrives_before_end_of_interval :
              job_arrival j_lst < t2.
            Proof.
              rewrite leqNgt; apply/negP; unfold not; intro LT2.
              exploit interference_bound_edf_all_jobs_from_tsk_k.
              {
                apply mem_nth; instantiate (1 := num_mid_jobs.+1).
                by rewrite -(ltn_add2r 1) addn1 H_at_least_two_jobs addn1.
              }
              instantiate (1 := elem); move => [LSTtsk [/eqP LSTserv LSTin]].
              apply LSTserv; apply/eqP; rewrite -leqn0.
              apply leq_trans with (n := service_during sched j_lst t1 t2);
                first by apply job_interference_le_service.
              rewrite leqn0; apply/eqP; unfold service_during.
              by apply cumulative_service_before_job_arrival_zero.
            Qed.

            (* Since there are multiple jobs, j_fst is far enough from the end of
               the interval that its response-time bound is valid
               (by the assumption H_all_previous_jobs_completed_on_time). *)
            Lemma interference_bound_edf_j_fst_completed_on_time :
              completed job_cost sched j_fst (a_fst + R_k).
            Proof.
              have FST := interference_bound_edf_j_fst_is_job_of_tsk_k; des.
              set j_snd := nth elem sorted_jobs 1.
              exploit interference_bound_edf_all_jobs_from_tsk_k.
              {
                by apply mem_nth; instantiate (1 := 1); rewrite H_at_least_two_jobs.
              }
              instantiate (1 := elem); move => [SNDtsk [/eqP SNDserv _]].
              apply H_all_previous_jobs_completed_on_time; try (by done).
              apply leq_ltn_trans with (n := job_arrival j_snd); last first.
              {
                rewrite ltnNge; apply/negP; red; intro BUG; apply SNDserv.
                apply/eqP; rewrite -leqn0; apply leq_trans with (n := service_during
                                                                          sched j_snd t1 t2);
                  first by apply job_interference_le_service.
                rewrite leqn0; apply/eqP.
                by apply cumulative_service_before_job_arrival_zero.
              }
              apply leq_trans with (n := a_fst + p_k).
              {
                by rewrite leq_add2l; apply leq_trans with (n := D_k);
                  [by apply H_R_k_le_deadline | by apply H_constrained_deadlines].
              }

              (* Since jobs are sporadic, we know that the first job arrives
                 at least p_k units before the second. *)
              unfold p_k; rewrite -FST.
              apply H_sporadic_tasks; [| by rewrite SNDtsk | ]; last first.
              {
                apply interference_bound_edf_jobs_ordered_by_arrival.
                by rewrite H_at_least_two_jobs.
              }
              red; move => /eqP BUG.
              by rewrite nth_uniq in BUG; rewrite ?SIZE //;
                [ by apply interference_bound_edf_at_least_one_job
                | by rewrite H_at_least_two_jobs
                | by rewrite sort_uniq; apply filter_uniq, undup_uniq].
            Qed.

          End FactsAboutFirstAndLastJobs.

          (* Next, we prove that the distance between the first and last jobs is at least
             num_mid_jobs + 1 periods. *)
          Lemma interference_bound_edf_many_periods_in_between :
            a_lst - a_fst >= num_mid_jobs.+1 * p_k.
          Proof.
            unfold a_fst, a_lst, j_fst, j_lst.
            assert (EQnk: num_mid_jobs.+1=(size sorted_jobs).-1).
              by rewrite H_at_least_two_jobs.
            rewrite EQnk telescoping_sum;
              last by ins; apply interference_bound_edf_jobs_ordered_by_arrival.
            rewrite -[_ * _ tsk_k]addn0 mulnC -iter_addn -{1}[_.-1]subn0 -big_const_nat.
            rewrite big_nat_cond [\sum_(0 <= i < _)(_-_)]big_nat_cond.
            apply leq_sum; intros i; rewrite andbT; move => /andP LT; des.

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

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

            (* Show that both cur and next are in the arrival sequence *)
            assert (INnth: cur \in interfering_jobs /\ next \in interfering_jobs).
            {
              rewrite 2!interference_bound_edf_job_in_same_sequence; split.
                by apply mem_nth, (ltn_trans LT0); destruct sorted_jobs; ins.
                by apply mem_nth; destruct sorted_jobs; ins.
            }
            rewrite 2?mem_filter in INnth; des.

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

          Lemma interference_bound_edf_slack_le_delta:
            D_k - R_k <= D_i.
          Proof.
            have AFTERt1 :=
                interference_bound_edf_j_fst_completion_implies_rt_bound_inside_interval
                interference_bound_edf_j_fst_completed_on_time.
            rewrite leq_subLR -(leq_add2r a_fst).
            rewrite -addnA [R_k + _]addnC -addnA.
            apply leq_trans with (n := D_i + t1);
              last by rewrite leq_add2l.
            have FST := interference_bound_edf_j_fst_is_job_of_tsk_k.
            destruct FST as [_ [ LEdl _]].
            apply interference_under_edf_implies_shorter_deadlines with
                (job_deadline0 := job_deadline) in LEdl; try (by done).
            rewrite addnC [D_i + _]addnC.
            unfold D_k, D_i.
            by rewrite -interference_bound_edf_j_fst_deadline
                       -interference_bound_edf_j_i_deadline.
          Qed.

          (* Using the lemma above, we prove that the ratio n_k is at least the number of
             middle jobs + 1, ... *)
          Lemma interference_bound_edf_n_k_covers_all_jobs :
            n_k >= num_mid_jobs.+2.
          Proof.
            have AFTERt1 :=
                interference_bound_edf_j_fst_completion_implies_rt_bound_inside_interval
                interference_bound_edf_j_fst_completed_on_time.
            have SLACK := interference_bound_edf_slack_le_delta.
            rename H_valid_task_parameters into TASK_PARAMS,
                   H_tsk_k_in_task_set into INk.
            unfold valid_sporadic_taskset, is_valid_sporadic_task,
                   interference_bound, edf_specific_interference_bound in *.
            have DIST := interference_bound_edf_many_periods_in_between.
            rewrite leqNgt; apply/negP; unfold not; rewrite ltnS;  intro LTnk.
            assert (BUG: a_lst - a_fst > D_i + R_k - D_k).
            {
              apply leq_trans with (n := num_mid_jobs.+1 * p_k); last by done.
              apply leq_trans with (n := n_k * p_k);
                last by rewrite leq_mul2r; apply/orP; right.
              unfold n_k, div_ceil.
              feed (TASK_PARAMS tsk_k); [by done | des].
              destruct (p_k %| D_i + R_k - D_k + 1) eqn:DIV.
                - by rewrite dvdn_eq in DIV; move: DIV => /eqP DIV; rewrite DIV addn1.
                - by rewrite -addn1; apply ltnW, ltn_ceil.
            }
            rewrite leq_subLR in SLACK.
            rewrite -(leq_add2r a_fst) subh1 in BUG;
              last by apply interference_bound_edf_j_fst_before_j_lst.
            rewrite -[a_lst + _ - _]subnBA // subnn subn0 in BUG.
            rewrite addnC addnS in BUG.
            rewrite addnBA // in BUG; last by rewrite addnC.
            rewrite -(ltn_add2r D_k) in BUG.
            rewrite subh1 in BUG; last first.
            {
              rewrite [D_i + R_k]addnC.
              by apply leq_trans with (n := R_k + D_i);
                last by apply leq_addl.
            }
            rewrite -addnBA // subnn addn0 in BUG.
            rewrite [D_i + _]addnC addnA in BUG.
            apply leq_ltn_trans with (m := t1 + D_i) in BUG;
              last by rewrite leq_add2r.
            have LST := interference_bound_edf_j_lst_is_job_of_tsk_k.
            destruct LST as [_ [ LEdl _]].
            apply interference_under_edf_implies_shorter_deadlines with
                (job_deadline0 := job_deadline) in LEdl; try (by done).
            unfold D_i, D_k in DIST; rewrite interference_bound_edf_j_lst_deadline
                                             interference_bound_edf_j_i_deadline in LEdl.
            by rewrite ltnNge LEdl in BUG.
          Qed.

          (* ... which allows bounding the interference of the middle and last jobs
             using n_k multiplied by the cost. *)
          Lemma interference_bound_edf_holds_for_multiple_jobs :
            \sum_(0 <= i < num_mid_jobs.+2)
              interference_caused_by (nth elem sorted_jobs i) t1 t2
            <= interference_bound.
          Proof.
            apply leq_trans with (n := num_mid_jobs.+2 * task_cost tsk_k); last first.
            {
              rewrite leq_mul2r; apply/orP; right.
              by apply interference_bound_edf_n_k_covers_all_jobs.
            }
            {
              apply leq_trans with (n := \sum_(0 <= i < num_mid_jobs.+2) task_cost tsk_k);
                last by rewrite big_const_nat iter_addn addn0 mulnC subn0.
              rewrite big_nat_cond [\sum_(0 <= i < _ | true) _]big_nat_cond.
              apply leq_sum; intros i; rewrite andbT; move => /andP LT; des.
              apply interference_bound_edf_interference_le_task_cost.
              rewrite interference_bound_edf_job_in_same_sequence.
              by apply mem_nth; rewrite H_at_least_two_jobs.
            }
          Qed.

        End InterferenceTwoOrMoreJobs.

      End InterferenceManyJobs.

      Theorem interference_bound_edf_bounds_interference :
        x <= interference_bound.
      Proof.
        (* Use the definition of workload based on list of jobs. *)
        apply (leq_trans interference_bound_edf_use_another_definition).

        (* We only care about the jobs that cause interference. *)
        rewrite interference_bound_edf_simpl_by_filtering_interfering_jobs.

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

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

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

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

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

        (* Then, we show the same for a single job, or for multiple jobs. *)
        rewrite SIZE; destruct n as [| num_mid_jobs].
        {
          rewrite big_nat_recr // big_geq //.
          rewrite [nth]lock /= -lock add0n.
          by apply interference_bound_edf_holds_for_a_single_job; rewrite SIZE.
        }
        {
          by apply interference_bound_edf_holds_for_multiple_jobs; first by rewrite SIZE.
        }
      Qed.

    End MainProof.

  End ProofSpecificBound.

  (* As required by the proof of convergence of EDF RTA, we show that the
     EDF-specific bound is monotonically increasing with both the size
     of the interval and the value of the previous response-time bounds. *)
  Section MonotonicitySpecificBound.

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

    Variable tsk tsk_other: sporadic_task.
    Hypothesis H_period_positive: task_period tsk_other > 0.

    Variable delta delta' R R': time.
    Hypothesis H_delta_monotonic: delta <= delta'.
    Hypothesis H_response_time_monotonic: R <= R'.
    Hypothesis H_cost_le_rt_bound: task_cost tsk_other <= R.

    Lemma interference_bound_edf_monotonic :
      interference_bound_edf task_cost task_period task_deadline tsk delta (tsk_other, R) <=
      interference_bound_edf task_cost task_period task_deadline tsk delta' (tsk_other, R').
    Proof.
      rename H_response_time_monotonic into LEr, H_delta_monotonic into LEx,
             H_cost_le_rt_bound into LEcost, H_period_positive into GEperiod.
      unfold interference_bound_edf, interference_bound_generic.
      rewrite leq_min; apply/andP; split.
      {
        apply leq_trans with (n := W task_cost task_period (fst (tsk_other, R))
                                     (snd (tsk_other, R)) delta);
          [by apply geq_minl | by apply W_monotonic].
      }
      {
        apply leq_trans with (n := edf_specific_interference_bound task_cost task_period
                                                          task_deadline tsk tsk_other R);
          first by apply geq_minr.
        unfold edf_specific_interference_bound; simpl.
        rewrite leq_mul2r; apply/orP; right.
        apply leq_divceil2r; first by done.
        by rewrite leq_add2r leq_sub2r // leq_add2l.
      }
    Qed.

  End MonotonicitySpecificBound.

End InterferenceBoundEDF.